I rather hope that I now have got to where infix operators might be handled properly again, while supporting the INFIX and INFIXR (and indeed NONFIX) directives.

% sml.red                                    Copyright A C Norman, June 2016

% **************************************************************************
% * Copyright (C) 2016, Codemist.                         A C Norman       *
% *                                                                        *
% * Redistribution and use in source and binary forms, with or without     *
% * modification, are permitted provided that the following conditions are *
% * met:                                                                   *
% *                                                                        *
% *     * Redistributions of source code must retain the relevant          *
% *       copyright notice, this list of conditions and the following      *
% *       disclaimer.                                                      *
% *     * Redistributions in binary form must reproduce the above          *
% *       copyright notice, this list of conditions and the following      *
% *       disclaimer in the documentation and/or other materials provided  *
% *       with the distribution.                                           *
% *                                                                        *
% * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    *
% * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      *
% * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS      *
% * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE         *
% * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,   *
% * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,   *
% * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS  *
% * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
% * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR  *
% * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF     *
% * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE * POSSIBILITY OF SUCH *
% * DAMAGE.                                                                *
% **************************************************************************

% $Id: $

% The code here parses (a subset of) SML and generates a Lisp
% tre efrom it. If the SML code is sufficiently simple this Lisp can
% be output as Rlisp code. It may be in more restricted cases, but
% sometimes it may be feasible to generate C or C++ code instead. The
% idea for this is that SML can be used as a prototyping language where its
% flexibility and strong type-checking keep eveything safe, and via
% this code it can ba mapped onto something that will run in more restricted
% contexts.

% This is also a first serious use of the Reduce LALR parser-generator.

on echo;
load_package lalr;

lisp;

if getd 'enable!-errorset then enable!-errorset(3,3);

% Some symbols must be recognized by SML as names of types... Note that
% the lexer will classify any name starting with a quote mark as stanidng
% for a type.

for each x in '(unit bool int real char string list option) do
  put(x, 'lex_is_typename, t);

prec := '(
  !:left  (!:infix9)
  !:right (!:infixr9)
  !:left  (!:infix8)
  !:right (!:infixr8)
  !:left  (!:infix7)
  !:left  ("*")
  !:right (!:infixr7)
  !:left  (!:infix6)
  !:right (!:infixr6)
  !:left  (!:infix5)
  !:right (!:infixr5)
  !:left  ("=")
  !:left  (!:infix4)
  !:right (!:infixr4)
  !:left  (!:infix3)
  !:right (!:infixr3)
  !:left  (!:infix2)
  !:right (!:infixr2)
  !:left  (!:infix1)
  !:right (!:infixr1)
  !:left  (!:infix0)
  !:right (!:infixr0)
  )$

put('!*,   'lisp_name, 'times);
put('!/,   'lisp_name, 'quotient);
put('!%,   'lisp_name, 'remainder);
put('div,  'lisp_name, 'quotient);
put('mod,  'lisp_name, 'remainder);

put('!+,   'lisp_name, 'plus);
put('!-,   'lisp_name, 'difference);

put('!:!:, 'lisp_name, 'cons);

put('!>,   'lisp_name, 'greaterp);
put('!<,   'lisp_name, 'lessp);
put('!>!=, 'lisp_name, 'geq);
put('!<!=, 'lisp_name, 'leq);
%put('!=,   'lisp_name, 'equal);
put('!<!>, 'lisp_name, 'neq);

put('!:!=, 'lisp_name, 'set);

% The grammar used here is derived from one found at
%    https://www.mpi-sws.org/~rossberg/sml.html
% A naive transliteration from there yields a grammar that has a huge
% number of ambiguities/conflicts. For instance an expression like
%        a b : 'c
% could potentially be treated either as (a (b : 'c) or ((a b) : 'c).
% Some of the issue can be sorted out by precedence rules, but to end up
% with as clear-cut behaviour as I can I am expanding the grammar rules
% somewhat.

grammar := '(

 (toplevel ((progs "eof")))

 (progs    ((prog) (princ "Statement: ") (prettyprint !$1))
           ((progs prog) (princ "Statement: ") (prettyprint !$2)))

% Constants for SML should be
%     int      [~]<digits>
%              [~]0x<hexdigits>
%     float    [~]<digits>.<digits>[e[~]<digits>]
%     word     0w<digits>
%              0wx<hexdigits>
%     string   "<chars>"        may use "\" based escape sequence
%     char     #"<1-char>"

 (con    ((!:number))      % Needs int vs. float, also hex input
         (("~" !:number))
         (("#" !:string))
         ((!:string)))

 (digit  ((!:number)))

 (id     ((!:symbol)))

 (var    ((!:typename))
         ((!:typename)))

 (longid ((id) !$1)
         ((longid "." id)))

 (longvar((var) !$1)
         ((longid "." var)))

 (lab    ((id))
         ((!:number)))

 (tupletail
         ((exp ")") nil)
         ((exp "," tupletail) (cons !$1 !$3)))

 (listtail
         ((exp "]") nil)
         ((exp "," listtail) (cons !$1 !$3)))

 (seqtail
         ((exp ")") nil)
         ((exp ";" seqtail) (cons !$1 !$3)))

% Here I can have
%     x : 'a something
%     x : int * something
% and if the name something is the name of a type it is liable to form
% part of the type, while if it is not then it will be a name of a variable.
% This is an ambiguity that I believe has to be resolved by considering that
% status of the name. Consider cases
%      datatype 'a tree = ...
%      x : int tree;   (* case 1 *)
%      val x = 3;
%      val y = 8;
%      x : int * y;    (* case 2 *)
% so I do not believe that any decision that allows both "exp ::= id" and
% "typ ::= id" can be unambiguous. Oh dear.
 (exp    ((basicexp))
         ((basicexp ":" typ))
         ((exp basicexp))
% The following rule should only apply if "id" has infix status...
%        ((exp id exp) (list !$2 !$1 !$3))
% I will rely on precedence to sort out the mess of grouping within
% infix expressions. Note that I have to treat both "=" and "*" specially
% here because they occur in other syntactic contexts, such as
%     val name = value;
%     fun fname args = body;
%     (expression : type1 * type2)
         ((exp infix0 exp) (print (list 'infix !$2))  (list (get !$2 'lisp_name) !$1 !$3))
         ((exp infix1 exp) (print (list 'infix !$2))  (list (get !$2 'lisp_name) !$1 !$3))
         ((exp infix2 exp) (print (list 'infix !$2))  (list (get !$2 'lisp_name) !$1 !$3))
         ((exp infix3 exp) (print (list 'infix !$2))  (list (get !$2 'lisp_name) !$1 !$3))
         ((exp infix4 exp) (print (list 'infix !$2))  (list (get !$2 'lisp_name) !$1 !$3))
         ((exp "=" exp) (print (list 'infix !$2))  (list 'equal !$1 !$3))
         ((exp infix5 exp) (print (list 'infix !$2))  (list (get !$2 'lisp_name) !$1 !$3))
         ((exp infix6 exp) (print (list 'infix !$2))  (list (get !$2 'lisp_name) !$1 !$3))
         ((exp infix7 exp) (print (list 'infix !$2))  (list (get !$2 'lisp_name) !$1 !$3))
         ((exp "*" exp) (print (list 'infix !$2))  (list 'equal !$1 !$3))
         ((exp infix8 exp) (print (list 'infix !$2))  (list (get !$2 'lisp_name) !$1 !$3))
         ((exp infix9 exp) (print (list 'infix !$2))  (list (get !$2 'lisp_name) !$1 !$3))
         ((exp infixr0 exp) (print (list 'infix !$2))  (list (get !$2 'lisp_name) !$1 !$3))
         ((exp infixr1 exp) (print (list 'infix !$2))  (list (get !$2 'lisp_name) !$1 !$3))
         ((exp infixr2 exp) (print (list 'infix !$2))  (list (get !$2 'lisp_name) !$1 !$3))
         ((exp infixr3 exp) (print (list 'infix !$2))  (list (get !$2 'lisp_name) !$1 !$3))
         ((exp infixr4 exp) (print (list 'infix !$2))  (list (get !$2 'lisp_name) !$1 !$3))
         ((exp infixr5 exp) (print (list 'infix !$2))  (list (get !$2 'lisp_name) !$1 !$3))
         ((exp infixr6 exp) (print (list 'infix !$2))  (list (get !$2 'lisp_name) !$1 !$3))
         ((exp infixr7 exp) (print (list 'infix !$2))  (list (get !$2 'lisp_name) !$1 !$3))
         ((exp infixr8 exp) (print (list 'infix !$2))  (list (get !$2 'lisp_name) !$1 !$3))
         ((exp infixr9 exp) (print (list 'infix !$2))  (list (get !$2 'lisp_name) !$1 !$3))
         ((exp "handle" match))
         ((exp "andalso" exp) (list 'and !$1 !$3))
         ((exp "orelse" exp) (list 'or !$1 !$3))
         (("!" exp) (list 'pling !$2))
         (("~" exp) (list 'minus !$2))
         (("raise" exp))
         (("if" exp "then" exp "else" exp)
             (list 'cond
                (list !$2 !$4)
                (list t !$6)))
         (("while" exp "do" exp))
         (("case" exp "of" match))
         (("fn" match)))

% These silly looking rules are to do with the "trick" that allows one to
% declare infix operators on the fly. If (say) "+" has been made an infix
% operator with precedence 4 it parses as a token of type !:infix4. But the
% value of yylval will still be the plus sign. These rules exist to transfer
% that value into the semantic action so that it is what drives the resr if
% the parser, rather than having the less useful token !:infix4.

 (infix0 ((!:infix0) yylval))
 (infix1 ((!:infix1) yylval))
 (infix2 ((!:infix2) yylval))
 (infix3 ((!:infix3) yylval))
 (infix4 ((!:infix4) yylval))
 (infix5 ((!:infix5) yylval))
 (infix6 ((!:infix6) yylval))
 (infix7 ((!:infix7) yylval))
 (infix8 ((!:infix8) yylval))
 (infix9 ((!:infix9) yylval))
 (infixr0 ((!:infixr0) yylval))
 (infixr1 ((!:infixr1) yylval))
 (infixr2 ((!:infixr2) yylval))
 (infixr3 ((!:infixr3) yylval))
 (infixr4 ((!:infixr4) yylval))
 (infixr5 ((!:infixr5) yylval))
 (infixr6 ((!:infixr6) yylval))
 (infixr7 ((!:infixr7) yylval))
 (infixr8 ((!:infixr8) yylval))
 (infixr9 ((!:infixr9) yylval))

% A basicexp will be an expression that self-terminates

 (basicexp ((con))
         ((longid))
         (("op" longid))
%        ((exp ":" typ))
         (("(" exp ")") !$2)
         (("(" exp "," tupletail))
         (("{" "}"))
         (("{" exprow "}"))
         (("#" lab))
         (("[" "]") 'empty_list)
         (("[" exp "]") (list 'list !$2))
         (("[" exp "," listtail))
         (("(" exp ";" seqtail))
         ((letid dec "in" exp endid))
         ((letid dec "in" exp seqexps)))

 (localid
         (("local") (startcontext)))
 (letid  (("let") (startcontext)))
 (endid  (("end") (endcontext)))

 (seqexps
         ((endid) nil)
         ((";" exp seqexps) (cons !$2 !$3)))

 (exprow ((lab "=" exp))
         ((lab "=" exp "," exprow)))

 (match  ((pat "=>" exp))
         ((pat "=>" exp "|" match)))

 (pat    ((pat1))
         ((pat1 ":" typ))
         ((!:symbol "as" pat1 ":" typ))
         (("op" !:symbol "as" pat1 ":" typ))
         ((!:symbol ":" typ "as" pat1 ":" typ))
         (("op" !:symbol ":" typ "as" pat1 ":" typ)))

 (pat1   ((con))
         (("_"))
         ((id))
         (("op" id))
         ((longid))
         (("op" longid))
         ((longid pat1))
         (("op" longid pat1))
%        ((pat id pat))
% The above line supports patterns that involve an arbitrary infix
% operator. I will only allow known ones. Well right now the only infix
% constructor I can think of is "::". I believe that to make this work
% fully I would want to let the lexer offer a different token class for
% infix operators. I also refuse to support type qualifiers without
% parens here, so if you want to specify types explicitly you must
% parenthesis as in
%                      (a : 'a) :: (b : 'a list)
% rather than just      a : a' :: b : 'a list
%
         ((pat1 "::" pat1))
         (("(" patseq ")"))
         (("(" ")") nil)
         (("{" patrow "}"))
         (("[" patseq "]"))
         (("[" "]") nil))

 (patseq ((pat))
         ((patseq "," pat)))

 (patrow (("..."))
         ((lab "=" pat))
         ((lab "=" pat "," patrow))
         ((id))
         ((id ":" typ))
         ((id "as" pat))
         ((id ":" typ "as" pat))
         ((id "," patrow))
         ((id ":" typ "," patrow))
         ((id "as" pat "," patrow))
         ((id ":" typ "as" pat "," patrow)))

 (typ    ((var))
         ((longvar))
         ((typ longvar))
         (("(" typ "," ttail ")" longid))
         (("(" typ ")"))
         ((typ "->" typ))
         ((typ starstuff))
         (("{" typrow "}")))

 (ttail  ((typ))
         ((typ "," ttail)))

 (starstuff (("*" typ))
            (("*" typ starstuff)))

 (typrow ((lab ":" typ))
         ((lab ":" typ "," typrow)))

 (varcomma (())
         ((var))
         (("(" var varcommatail ")")))

 (varcommatail (("," var))
         (("," var varcommatail)))

 (dec    (("val" varcomma valbind))
         (("fun" varcomma funbind))
         (("type" typbind))
         (("datatype" datbind))
         (("datatype" datbind "withtype" typbind))
         (("datatype" id "=" "datatype" longid))
         (("abstype" datbind "with" dec "end"))
         (("abstype" datbind "withtype" typbind "with" dec "end"))
         (("exception" exnbind))
%        (("structure" strbind))
%@@      ((dec ";" dec))
         ((localid dec "in" dec endid))
%        (("open" longid))   % Could have multiple longids here
% The full syntax here would allow a sequence of opnames here. Just for now
% I will be lazy and only support one.
         (("nonfix" opname) (makeinfix !$2 0 'none))
         (("infix" opname) (makeinfix !$2 0 'left))
         (("infix" digit opname) (makeinfix !$3 !$2 'left))
         (("infixr" opname) (makeinfix !$2 0 'right))
         (("infixr" digit opname) (makeinfix !$3 !$2 'right))
         )

% The words accepted in INFIX and INFIXR directives  should probably include
% things that have already been declared with an infix property. I want
% the identifier itself as my result...
% Also all sorts of other tokens will have been given special lexer codes but
% they should still be things that COULD be made infix... So I list the ones
% that I can think of here! This is really odd in that if (say) "->" is
% a single token then in the process of that case being notes as a dipthong
% the initial "-" will also be given its own lexer code... so I need to
% list initial substrings of any multi-character dipthong here.
%
 (opname  ((id) (princ "opname: ") (print yylval))
          (("*") (princ "opname: ") (print yylval))
          (("/") (princ "opname: ") (print yylval))
          (("%") (princ "opname: ") (print yylval))
          (("+") (princ "opname: ") (print yylval))
          (("-") (princ "opname: ") (print yylval))
          (("::") (princ "opname: ") (print yylval))
          ((":") (princ "opname: ") (print yylval))
          (("=") (princ "opname: ") (print yylval))
          (("<") (princ "opname: ") (print yylval))
          (("<=") (princ "opname: ") (print yylval))
          ((">") (princ "opname: ") (print yylval))
          ((">=") (princ "opname: ") (print yylval))
          (("<>") (princ "opname: ") (print yylval))
          ((":=") (princ "opname: ") (print yylval))
          ((!:infix0) (princ "opname: ") (print yylval))
          ((!:infix1) (princ "opname: ") (print yylval))
          ((!:infix2) (princ "opname: ") (print yylval))
          ((!:infix3) (princ "opname: ") (print yylval))
          ((!:infix4) (princ "opname: ") (print yylval))
          ((!:infix5) (princ "opname: ") (print yylval))
          ((!:infix6) (princ "opname: ") (print yylval))
          ((!:infix7) (princ "opname: ") (print yylval))
          ((!:infix8) (princ "opname: ") (print yylval))
          ((!:infix9) (princ "opname: ") (print yylval))
          ((!:infixr0) (princ "opname: ") (print yylval))
          ((!:infixr1) (princ "opname: ") (print yylval))
          ((!:infixr2) (princ "opname: ") (print yylval))
          ((!:infixr3) (princ "opname: ") (print yylval))
          ((!:infixr4) (princ "opname: ") (print yylval))
          ((!:infixr5) (princ "opname: ") (print yylval))
          ((!:infixr6) (princ "opname: ") (print yylval))
          ((!:infixr7) (princ "opname: ") (print yylval))
          ((!:infixr8) (princ "opname: ") (print yylval))
          ((!:infixr9) (princ "opname: ") (print yylval)))

 (valbind ((pat "=" exp))
          ((pat "=" exp "and" valbind))
          (("rec" valbind)))

 (funbind ((funmatch) (list !$1))
          ((funmatch "and" funbind) (cons !$1 !$3)))

% The explicit type ": typ" qualification here qualifies the return
% type of the whole expression. It seems that the patterns used here must
% not be ones that end in their own ": typ".

 (funmatch ((id patterns "=" exp) (list 'de !$1 !$2 !$4))
           (("op" id patterns "=" exp))
           ((id patterns ":" typ "=" exp))
           (("op" id patterns ":" typ "=" exp))
           ((id patterns "=" exp "|" funmatch))
           (("op" id patterns "=" exp "|" funmatch))
           ((id patterns ":" typ "=" exp "|" funmatch))
           (("op" id patterns ":" typ "=" exp "|" funmatch)))

 (patterns ((pat1) (list !$1))
           ((patterns pat1) (append !$1 (list !$2))))

 (maketyname
           ((id) (maketyname !$1) !$1))

 (typbind  ((varcomma maketyname "=" typ))
           ((varcomma maketyname "=" typ "and" typbind)))

 (datbind  ((varcomma id "=" conbind))
           ((varcomma id "=" conbind "and" datbind)))

 (conbind  ((id))
           ((id "of" typ))
           ((id "|" conbind))
           ((id "of" typ "|" conbind)))

 (exnbind  ((id))
           ((id "of" typ))
           ((id "|" exnbind))
           ((id "of" typ "|" exnbind))
           ((id "=" longid))
           ((id "=" longid "|" exnbind)))

% (str)
% (strbind)
% (sig)
% (typrefin)
% (spec)
% (valdesc)
% (typdesc)
% (detdesc)
% (condest)
% (exndesc)
% (strdesc)

(prog     ((dec))
          ((exp))
          ((";"))
%         (("functor" fctbind))
%         (("signature" sigbind))
%         ((prog ";" prog))       % For now I will only allow one clause
          )

% (fctbind)
% (sigbind)
%
  )$

fluid '(lexer_context context_stack);

symbolic procedure maketyname id;
  begin
    if not zerop posn() then terpri();
    princ "@@@ Identifier "; princ id; printc " is now a type name";
    lexer_context := ('type, id, get(id, 'lex_is_typename)) . lexer_context;
    put(id, 'smltypename, t);
    return id
  end;

global '(infix_lookup);
infix_lookup := mkhash(30, 2, 1.5)$

<< puthash('(0 . none), infix_lookup, get('!:symbol, 'lex_fixed_code));
   puthash('(1 . none), infix_lookup, get('!:symbol, 'lex_fixed_code));
   puthash('(2 . none), infix_lookup, get('!:symbol, 'lex_fixed_code));
   puthash('(3 . none), infix_lookup, get('!:symbol, 'lex_fixed_code));
   puthash('(4 . none), infix_lookup, get('!:symbol, 'lex_fixed_code));
   puthash('(5 . none), infix_lookup, get('!:symbol, 'lex_fixed_code));
   puthash('(6 . none), infix_lookup, get('!:symbol, 'lex_fixed_code));
   puthash('(7 . none), infix_lookup, get('!:symbol, 'lex_fixed_code));
   puthash('(8 . none), infix_lookup, get('!:symbol, 'lex_fixed_code));
   puthash('(9 . none), infix_lookup, get('!:symbol, 'lex_fixed_code));
   puthash('(0 . left), infix_lookup, get('!:infix0, 'lex_fixed_code));
   puthash('(1 . left), infix_lookup, get('!:infix1, 'lex_fixed_code));
   puthash('(2 . left), infix_lookup, get('!:infix2, 'lex_fixed_code));
   puthash('(3 . left), infix_lookup, get('!:infix3, 'lex_fixed_code));
   puthash('(4 . left), infix_lookup, get('!:infix4, 'lex_fixed_code));
   puthash('(5 . left), infix_lookup, get('!:infix5, 'lex_fixed_code));
   puthash('(6 . left), infix_lookup, get('!:infix6, 'lex_fixed_code));
   puthash('(7 . left), infix_lookup, get('!:infix7, 'lex_fixed_code));
   puthash('(8 . left), infix_lookup, get('!:infix8, 'lex_fixed_code));
   puthash('(9 . left), infix_lookup, get('!:infix9, 'lex_fixed_code));
   puthash('(0 . right), infix_lookup, get('!:infixr0, 'lex_fixed_code));
   puthash('(1 . right), infix_lookup, get('!:infixr1, 'lex_fixed_code));
   puthash('(2 . right), infix_lookup, get('!:infixr2, 'lex_fixed_code));
   puthash('(3 . right), infix_lookup, get('!:infixr3, 'lex_fixed_code));
   puthash('(4 . right), infix_lookup, get('!:infixr4, 'lex_fixed_code));
   puthash('(5 . right), infix_lookup, get('!:infixr5, 'lex_fixed_code));
   puthash('(6 . right), infix_lookup, get('!:infixr6, 'lex_fixed_code));
   puthash('(7 . right), infix_lookup, get('!:infixr7, 'lex_fixed_code));
   puthash('(8 . right), infix_lookup, get('!:infixr8, 'lex_fixed_code));
   puthash('(9 . right), infix_lookup, get('!:infixr9, 'lex_fixed_code));
   nil >>;

symbolic procedure makeinfix(id, prec, dirn);
  begin
    if not zerop posn() then terpri();
    princ "@@@ Identifier "; princ id; princ " is now an operator: ";
    princ prec; princ "  "; printc dirn;
    lexer_context := list('type, id, get(id, 'lex_code)) . lexer_context;
    put(id, 'lex_code, gethash(prec . dirn, infix_lookup));
    return id
  end;

symbolic procedure startcontext();
  begin
    context_stack := lexer_context . context_stack;
    lexer_context := nil;
    if not zerop posn() then terpri();
    printc "Starting a nested context";
  end;

symbolic procedure endcontext();
  begin
    if not zerop posn() then terpri();
    printc "Ending a nested context";
% I now need to unwind any local type and infix declarations...
    for each p in lexer_context do
      if eqcar(p, 'infix) then put(cadr p, 'lex_code, cddr p)
      else put(cadr p, 'lex_is_typename, cddr p);
    lexer_context := car context_stack;
    context_stack := cdr context_stack;
  end;

% While debugging it may be helpful to see the grammar diplayed with
% indentation normalised...
%
<< terpri(); prettyprint grammar; nil >>;

<< princ ":infix7 "; print plist '!:infix7;
   princ "= "; print plist '!=;
   princ "* "; print plist '!*;
   princ "- "; print plist '!-;
   nil >>;
pp := lalr_create_parser(prec, grammar)$
<< princ ":infix7 "; print plist '!:infix7;
   princ "= "; print plist '!=;
   princ "* "; print plist '!*;
   princ "- "; print plist '!-;
   nil >>;

lexer_style!* := lexer_style_sml + 0x40; % Support #if and #eval too!

tr yylex, lex_basic_token;

% If parsing the SML code fails I will just exit from Reduce. Otherwise
% it is likely that I will be faced with a mess of further silly messages
% as Reduce tries to make sense if SML input itself.
% I think I may need an option within lalr for parsing from a file, such
% that errors merely close that file - ie so that parsed and regular Reduce
% stuff are kept more separate.

on tracelex, parser_errors_fatal;

begin
   lex_init();
   yyparse pp
end;

use "Library_Reduce.sml";

fun fact n =
  if n = 1 then 1
  else n * fact (n-1)

and g x y z = [x,y,z]

val pi = 3.14159;

(*
 This is the Dutch version of TeX Maths Layout coded in SML, adjusted so
 it only uses a subset of SML. It also has some extensions that add support
 for accents and delimiters, and the aim is that eventually it should
 cover all maths. The stuff here reads in all the source files in an order
 which is safe.
*)

use "General.sml";
use "Powers2.sml";
use "BasicTypes.sml";
use "Distance.sml";
use "Size.sml";
use "FontTypes.sml";
use "LoadFont.sml";
use "FontVector.sml";
use "CharInfo.sml";
use "CharFunctions.sml";
use "Const.sml";
use "FontParams.sml";
use "StyleParams.sml";
use "BoxTypes.sml";
use "BasicBox.sml";
use "NodeDim.sml";
use "NodeListDim.sml";
use "GlueCalculation.sml";
use "HListGlue.sml";
use "BoxPack.sml";
use "MakeVBox.sml";
use "AxisCenter.sml";
use "ChangeStyle.sml";
use "Radical.sml";
use "BasicChar.sml";
use "MakeChar.sml";
use "Accent.sml";
use "MakeLine.sml";
use "MakeAtop.sml";
use "MakeFract.sml";
use "Delimiter.sml";
use "GenFraction.sml";
use "MakeLimOp.sml";
use "MakeScripts.sml";
use "MathTypes.sml";
use "Kind.sml";
use "MathSpace.sml";
use "MathGlue.sml";
use "Spacing.sml";
use "IListTypes.sml";
use "IListDim.sml";
use "ChangeKind.sml";
use "MathPenalty.sml";
use "Boundaries.sml";
use "IListTranslate.sml";
use "MathTranslate.sml";
use "Formula.sml";
use "Out.sml";
use "OutHigh.sml";
use "OutDvi.sml";
use "DviState.sml";
use "DviCmd.sml";
use "SetNode.sml";
use "SetBox.sml";
use "ShipOut.sml";
use "Input.sml";
use "test.sml";

(* End of everything *)

eof

;

if getd 'enable!-errorset then enable!-errorset(0,3);

end;

% sml.red                                    Copyright A C Norman, June 2016

% **************************************************************************
% * Copyright (C) 2016, Codemist.                         A C Norman       *
% *                                                                        *
% * Redistribution and use in source and binary forms, with or without     *
% * modification, are permitted provided that the following conditions are *
% * met:                                                                   *
% *                                                                        *
% *     * Redistributions of source code must retain the relevant          *
% *       copyright notice, this list of conditions and the following      *
% *       disclaimer.                                                      *
% *     * Redistributions in binary form must reproduce the above          *
% *       copyright notice, this list of conditions and the following      *
% *       disclaimer in the documentation and/or other materials provided  *
% *       with the distribution.                                           *
% *                                                                        *
% * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    *
% * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      *
% * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS      *
% * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE         *
% * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,   *
% * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,   *
% * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS  *
% * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
% * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR  *
% * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF     *
% * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE * POSSIBILITY OF SUCH *
% * DAMAGE.                                                                *
% **************************************************************************

% $Id: $

% The code here parses (a subset of) SML and generates a Lisp
% tre efrom it. If the SML code is sufficiently simple this Lisp can
% be output as Rlisp code. It may be in more restricted cases, but
% sometimes it may be feasible to generate C or C++ code instead. The
% idea for this is that SML can be used as a prototyping language where its
% flexibility and strong type-checking keep eveything safe, and via
% this code it can ba mapped onto something that will run in more restricted
% contexts.

% This is also a first serious use of the Reduce LALR parser-generator.

on echo;
load_package lalr;

lisp;

if memq('csl, lispsystem!*) then enable!-errorset(3,3);

% Some symbols must be recognized by SML as names of types... Note that
% the lexer will classify any name starting with a quote mark as stanidng
% for a type.

for each x in '(unit bool int real char string list option) do
  put(x, 'lex_is_typename, t);

prec := '(
  !:left  (!:infix9)
  !:right (!:infixr9)
  !:left  (!:infix8)
  !:right (!:infixr8)
  !:left  (!:infix7)
  !:right (!:infixr7)
  !:left  (!:infix6)
  !:right (!:infixr6)
  !:left  (!:infix5)
  !:right (!:infixr5)
  !:left  (!:infix4)
  !:right (!:infixr4)
  !:left  (!:infix3)
  !:right (!:infixr3)
  !:left  (!:infix2)
  !:right (!:infixr2)
  !:left  (!:infix1)
  !:right (!:infixr1)
  !:left  (!:infix0)
  !:right (!:infixr0)
  )$

lex_keywords '(
  "*"   "/"   "%"   "div" "mod" "+"   "-"   "::"
  ">"   "<"   ">="  "<="  "="   "<>"  ":=");

put('!*,   'lex_code, get('!:infix7, 'lex_fixed_code))$
put('!/,   'lex_code, get('!:infix7, 'lex_fixed_code))$
put('!%,   'lex_code, get('!:infix7, 'lex_fixed_code))$
put('div,  'lex_code, get('!:infix7, 'lex_fixed_code))$
put('mod,  'lex_code, get('!:infix7, 'lex_fixed_code))$

put('!+,   'lex_code, get('!:infix6, 'lex_fixed_code))$
put('!-,   'lex_code, get('!:infix6, 'lex_fixed_code))$

put('!:!:, 'lex_code, get('!:infixr5, 'lex_fixed_code))$

put('!>,   'lex_code, get('!:infix4, 'lex_fixed_code))$
put('!<,   'lex_code, get('!:infix4, 'lex_fixed_code))$
put('!>!=, 'lex_code, get('!:infix4, 'lex_fixed_code))$
put('!<!=, 'lex_code, get('!:infix4, 'lex_fixed_code))$
put('!=,   'lex_code, get('!:infix4, 'lex_fixed_code))$
put('!<!>, 'lex_code, get('!:infix4, 'lex_fixed_code))$

put('!:!=, 'lex_code, get('!:infix3, 'lex_fixed_code))$

put('!*,   'lisp_name, 'times);
put('!/,   'lisp_name, 'quotient);
put('!%,   'lisp_name, 'remainder);
put('div,  'lisp_name, 'quotient);
put('mod,  'lisp_name, 'remainder);

put('!+,   'lisp_name, 'plus);
put('!-,   'lisp_name, 'difference);

put('!:!:, 'lisp_name, 'cons);

put('!>,   'lisp_name, 'greaterp);
put('!<,   'lisp_name, 'lessp);
put('!>!=, 'lisp_name, 'geq);
put('!<!=, 'lisp_name, 'leq);
put('!=,   'lisp_name, 'equal);
put('!<!>, 'lisp_name, 'neq);

put('!:!=, 'lisp_name, 'set);

% The grammar used here is derived from one found at
%    https://www.mpi-sws.org/~rossberg/sml.html
% A naive transliteration from there yields a grammar that has a huge
% number of ambiguities/conflicts. For instance an expression like
%        a b : 'c
% could potentially be treated either as (a (b : 'c) or ((a b) : 'c).
% Some of the issue can be sorted out by precedence rules, but to end up
% with as clear-cut behaviour as I can I am expanding the grammar rules
% somewhat.

grammar := '(

 (toplevel ((prog) !$1))

% Constants for SML should be
%     int      [~]<digits>
%              [~]0x<hexdigits>
%     float    [~]<digits>.<digits>[e[~]<digits>]
%     word     0w<digits>
%              0wx<hexdigits>
%     string   "<chars>"        may use "\" based escape sequence
%     char     #"<1-char>"

 (con    ((!:number))      % Needs int vs. float, also hex input
         (("~" !:number))
         (("#" !:string))
         ((!:string)))

 (digit  ((!:number)))

 (id     ((!:symbol)))

 (var    ((!:typename))
         ((!:typename)))

 (longid ((id) !$1)
         ((longid "." id)))

 (longvar((var) !$1)
         ((longid "." var)))

 (lab    ((id))
         ((!:number)))

 (tupletail
         ((exp ")") nil)
         ((exp "," tupletail) (cons !$1 !$3)))

 (listtail
         ((exp "]") nil)
         ((exp "," listtail) (cons !$1 !$3)))

 (seqtail
         ((exp ")") nil)
         ((exp ";" seqtail) (cons !$1 !$3)))

% Here I can have
%     x : 'a something
%     x : int * something
% and if the name something is the name of a type it is liable to form
% part of the type, while if it is not then it will be a name of a variable.
% This is an ambiguity that I believe has to be resolved by considering that
% status of the name. Consider cases
%      datatype 'a tree = ...
%      x : int tree;   (* case 1 *)
%      val x = 3;
%      val y = 8;
%      x : int * y;    (* case 2 *)
% so I do not believe that any decision that allows both "exp ::= id" and
% "typ ::= id" can be unambiguous. Oh dear.
 (exp    ((basicexp))
         ((basicexp ":" typ))
         ((exp basicexp))
% The following rule should only apply if "id" has infix status...
%        ((exp id exp) (list !$2 !$1 !$3))
% I will rely on precedence to sort out the mess of grouping within
% infix expressions.
         ((exp !:infix0 exp) (list (get !$2 'lisp_name) !$1 !$3))
         ((exp !:infix1 exp) (list (get !$2 'lisp_name) !$1 !$3))
         ((exp !:infix2 exp) (list (get !$2 'lisp_name) !$1 !$3))
         ((exp !:infix3 exp) (list (get !$2 'lisp_name) !$1 !$3))
         ((exp !:infix4 exp) (list (get !$2 'lisp_name) !$1 !$3))
         ((exp !:infix5 exp) (list (get !$2 'lisp_name) !$1 !$3))
         ((exp !:infix6 exp) (list (get !$2 'lisp_name) !$1 !$3))
         ((exp !:infix7 exp) (list (get !$2 'lisp_name) !$1 !$3))
         ((exp !:infix8 exp) (list (get !$2 'lisp_name) !$1 !$3))
         ((exp !:infix9 exp) (list (get !$2 'lisp_name) !$1 !$3))
         ((exp !:infixr0 exp) (list (get !$2 'lisp_name) !$1 !$3))
         ((exp !:infixr1 exp) (list (get !$2 'lisp_name) !$1 !$3))
         ((exp !:infixr2 exp) (list (get !$2 'lisp_name) !$1 !$3))
         ((exp !:infixr3 exp) (list (get !$2 'lisp_name) !$1 !$3))
         ((exp !:infixr4 exp) (list (get !$2 'lisp_name) !$1 !$3))
         ((exp !:infixr5 exp) (list (get !$2 'lisp_name) !$1 !$3))
         ((exp !:infixr6 exp) (list (get !$2 'lisp_name) !$1 !$3))
         ((exp !:infixr7 exp) (list (get !$2 'lisp_name) !$1 !$3))
         ((exp !:infixr8 exp) (list (get !$2 'lisp_name) !$1 !$3))
         ((exp !:infixr9 exp) (list (get !$2 'lisp_name) !$1 !$3))
         ((exp "handle" match))
         ((exp "andalso" exp) (list 'and !$1 !$3))
         ((exp "orelse" exp) (list 'or !$1 !$3))
         (("!" exp) (list 'pling !$2))
         (("~" exp) (list 'minus !$2))
         (("raise" exp))
         (("if" exp "then" exp "else" exp)
             (list 'cond
                (list !$2 !$4)
                (list t !$6)))
         (("while" exp "do" exp))
         (("case" exp "of" match))
         (("fn" match)))

% A basicexp will be an expression that self-terminates

 (basicexp ((con))
         ((longid))
         (("op" longid))
%        ((exp ":" typ))
         (("(" exp ")") !$2)
         (("(" exp "," tupletail))
         (("{" "}"))
         (("{" exprow "}"))
         (("#" lab))
         (("[" "]") 'empty_list)
         (("[" exp "]") (list 'list !$2))
         (("[" exp "," listtail))
         (("(" exp ";" seqtail))
         ((letid dec "in" exp endid))
         ((letid dec "in" exp seqexps)))

 (localid
         (("local") (startcontext)))
 (letid  (("let") (startcontext)))
 (endid  (("end") (endcontext)))

 (seqexps
         ((endid) nil)
         ((";" exp seqexps) (cons !$2 !$3)))

 (exprow ((lab "=" exp))
         ((lab "=" exp "," exprow)))

 (match  ((pat "=>" exp))
         ((pat "=>" exp "|" match)))

 (pat    ((pat1))
         ((pat1 ":" typ))
         ((!:symbol "as" pat1 ":" typ))
         (("op" !:symbol "as" pat1 ":" typ))
         ((!:symbol ":" typ "as" pat1 ":" typ))
         (("op" !:symbol ":" typ "as" pat1 ":" typ)))

 (pat1   ((con))
         (("_"))
         ((id))
         (("op" id))
         ((longid))
         (("op" longid))
         ((longid pat1))
         (("op" longid pat1))
%        ((pat id pat))
% The above line supports patterns that involve an arbitrary infix
% operator. I will only allow known ones. Well right now the only infix
% constructor I can think of is "::". I believe that to make this work
% fully I would want to let the lexer offer a different token class for
% infix operators. I also refuse to support type qualifiers without
% parens here, so if you want to specify types explicitly you must
% parenthesis as in
%                      (a : 'a) :: (b : 'a list)
% rather than just      a : a' :: b : 'a list
%
         ((pat1 "::" pat1))
         (("(" patseq ")"))
         (("(" ")") nil)
         (("{" patrow "}"))
         (("[" patseq "]"))
         (("[" "]") nil))

 (patseq ((pat))
         ((patseq "," pat)))

 (patrow (("..."))
         ((lab "=" pat))
         ((lab "=" pat "," patrow))
         ((id))
         ((id ":" typ))
         ((id "as" pat))
         ((id ":" typ "as" pat))
         ((id "," patrow))
         ((id ":" typ "," patrow))
         ((id "as" pat "," patrow))
         ((id ":" typ "as" pat "," patrow)))

 (typ    ((var))
         ((longvar))
         ((typ longvar))
         (("(" typ "," ttail ")" longid))
         (("(" typ ")"))
         ((typ "->" typ))
         ((typ starstuff))
         (("{" typrow "}")))

 (ttail  ((typ))
         ((typ "," ttail)))

 (starstuff (("*" typ))
            (("*" typ starstuff)))

 (typrow ((lab ":" typ))
         ((lab ":" typ "," typrow)))

 (varcomma (())
         ((var))
         (("(" var varcommatail ")")))

 (varcommatail (("," var))
         (("," var varcommatail)))

 (dec    (("val" varcomma valbind))
         (("fun" varcomma funbind))
         (("type" typbind))
         (("datatype" datbind))
         (("datatype" datbind "withtype" typbind))
         (("datatype" id "=" "datatype" longid))
         (("abstype" datbind "with" dec "end"))
         (("abstype" datbind "withtype" typbind "with" dec "end"))
         (("exception" exnbind))
%        (("structure" strbind))
%@@      ((dec ";" dec))
         ((localid dec "in" dec endid))
%        (("open" longid))   % Could have multiple longids here
         (("nonfix" id) (makeinfix !$2 0 'none))     % multiple ids
         (("infix" id) (makeinfix !$2 0 'left))
         (("infix" digit id) (makeinfix !$2 !$3 'left))
         (("infixr" id) (makeinfix !$2 0 'right))
         (("infixr" digit id) (makeinfix !$3 !$3 'right))
         )

 (valbind ((pat "=" exp))
          ((pat "=" exp "and" valbind))
          (("rec" valbind)))

 (funbind ((funmatch) (list !$1))
          ((funmatch "and" funbind) (cons !$1 !$3)))

% The explicit type ": typ" qualification here qualifies the return
% type of the whole expression. It seems that the patterns used here must
% not be ones that end in their own ": typ".

 (funmatch ((id patterns "=" exp) (list 'de !$1 !$2 !$4))
           (("op" id patterns "=" exp))
           ((id patterns ":" typ "=" exp))
           (("op" id patterns ":" typ "=" exp))
           ((id patterns "=" exp "|" funmatch))
           (("op" id patterns "=" exp "|" funmatch))
           ((id patterns ":" typ "=" exp "|" funmatch))
           (("op" id patterns ":" typ "=" exp "|" funmatch)))

 (patterns ((pat1) (list !$1))
           ((patterns pat1) (append !$1 (list !$2))))

 (maketyname
           ((id) (maketyname !$1) !$1))

 (typbind  ((varcomma maketyname "=" typ))
           ((varcomma maketyname "=" typ "and" typbind)))

 (datbind  ((varcomma id "=" conbind))
           ((varcomma id "=" conbind "and" datbind)))

 (conbind  ((id))
           ((id "of" typ))
           ((id "|" conbind))
           ((id "of" typ "|" conbind)))

 (exnbind  ((id))
           ((id "of" typ))
           ((id "|" exnbind))
           ((id "of" typ "|" exnbind))
           ((id "=" longid))
           ((id "=" longid "|" exnbind)))

% (str)
% (strbind)
% (sig)
% (typrefin)
% (spec)
% (valdesc)
% (typdesc)
% (detdesc)
% (condest)
% (exndesc)
% (strdesc)

(prog     ((dec))
          ((exp))
%         (("functor" fctbind))
%         (("signature" sigbind))
%         ((prog ";" prog))       % For now I will only allow one clause
          )

% (fctbind)
% (sigbind)
%
  )$

fluid '(lexer_context context_stack);

symbolic procedure maketyname id;
  begin
    if not zerop posn() then terpri();
    princ "@@@ Identifier "; princ id; printc " is now a type name";
    lexer_context := ('type, id, get(id, 'lex_is_typename)) . lexer_context;
    put(id, 'smltypename, t);
    return id
  end;

global '(infix_lookup);
infix_lookup := mkhash(30, 2, 1.5);

<< puthash('(0 . none), infix_lookup, get('!:symbol, 'lex_fixed_code));
   puthash('(1 . none), infix_lookup, get('!:symbol, 'lex_fixed_code));
   puthash('(2 . none), infix_lookup, get('!:symbol, 'lex_fixed_code));
   puthash('(3 . none), infix_lookup, get('!:symbol, 'lex_fixed_code));
   puthash('(4 . none), infix_lookup, get('!:symbol, 'lex_fixed_code));
   puthash('(5 . none), infix_lookup, get('!:symbol, 'lex_fixed_code));
   puthash('(6 . none), infix_lookup, get('!:symbol, 'lex_fixed_code));
   puthash('(7 . none), infix_lookup, get('!:symbol, 'lex_fixed_code));
   puthash('(8 . none), infix_lookup, get('!:symbol, 'lex_fixed_code));
   puthash('(9 . none), infix_lookup, get('!:symbol, 'lex_fixed_code));
   puthash('(0 . left), infix_lookup, get('!:infix0, 'lex_fixed_code));
   puthash('(1 . left), infix_lookup, get('!:infix1, 'lex_fixed_code));
   puthash('(2 . left), infix_lookup, get('!:infix2, 'lex_fixed_code));
   puthash('(3 . left), infix_lookup, get('!:infix3, 'lex_fixed_code));
   puthash('(4 . left), infix_lookup, get('!:infix4, 'lex_fixed_code));
   puthash('(5 . left), infix_lookup, get('!:infix5, 'lex_fixed_code));
   puthash('(6 . left), infix_lookup, get('!:infix6, 'lex_fixed_code));
   puthash('(7 . left), infix_lookup, get('!:infix7, 'lex_fixed_code));
   puthash('(8 . left), infix_lookup, get('!:infix8, 'lex_fixed_code));
   puthash('(9 . left), infix_lookup, get('!:infix9, 'lex_fixed_code));
   puthash('(0 . right), infix_lookup, get('!:infixr0, 'lex_fixed_code));
   puthash('(1 . right), infix_lookup, get('!:infixr1, 'lex_fixed_code));
   puthash('(2 . right), infix_lookup, get('!:infixr2, 'lex_fixed_code));
   puthash('(3 . right), infix_lookup, get('!:infixr3, 'lex_fixed_code));
   puthash('(4 . right), infix_lookup, get('!:infixr4, 'lex_fixed_code));
   puthash('(5 . right), infix_lookup, get('!:infixr5, 'lex_fixed_code));
   puthash('(6 . right), infix_lookup, get('!:infixr6, 'lex_fixed_code));
   puthash('(7 . right), infix_lookup, get('!:infixr7, 'lex_fixed_code));
   puthash('(8 . right), infix_lookup, get('!:infixr8, 'lex_fixed_code));
   puthash('(9 . right), infix_lookup, get('!:infixr9, 'lex_fixed_code));
   nil >>;

symbolic procedure makeinfix(id, prec, dirn);
  begin
    if not zerop posn() then terpri();
    princ "@@@ Identifier "; princ id; printc " is now an operator";
    princ prec; princ "  "; printc dirn;
    lexer_context := ('type, id, get(id, 'lex_code)) . lexer_context;
    put(id, 'lex_code, gethash(prec . dirn, infix_lookup));
    return id
  end;

symbolic procedure startcontext();
  begin
    context_stack := lexer_context . context_stack;
    lexer_context := nil;
    if not zerop posn() then terpri();
    printc "Starting a nested context";
  end;

symbolic procedure endcontext();
  begin
    if not zerop posn() then terpri();
    printc "Ending a nested context";
% I now need to unwind any local type and infix declarations...
    for each p in lexer_context do
      if eqcar(p, 'infix) then put(cadr p, 'lex_code, cddr p)
      else put(cadr p, 'lex_is_typename, cddr p);
    lexer_context := car context_stack;
    context_stack := cdr context_stack;
  end;

% While debugging it may be helpful to see the grammar diplayed with
% indentation normalised...
%
<< terpri(); prettyprint grammar; nil >>;

pp := lalr_create_parser(prec, grammar)$

lexer_style!* := lexer_style_sml;

%tr yylex, lex_basic_token, lex_token, readch, yypeek, yyreadch;
%on tracelex;

% This example is to test or illustrate support for SML comments.
<< lex_init(); yyparse pp >>;
(111 (* comment *)+(* comment (* nest *) demo *) 222);

;;

begin
   scalar r, savefile;
   lex_init();
   while (r := yyparse pp) neq 'eof do <<
     if eqcar(r, 'use) then begin
       scalar ff, a;
       ff := cadr r;
       a := open(ff, 'input);
       if null a then error(1, list("Unable to open file", ff));
       savefile := rds a;
     end
     else if lex_char = !$eof!$ then <<
       printc "End of file detected";
       rds savefile;
       lex_char := !$eol!$ >>
     else <<
       terpri();
       printc "@@@@@@@@@@@@@@@@@@";
       princ "LISP: "; prettyprint r;
       printc "##################";
       terpri() >> >>
end;

fun fact n =
  if n = 1 then 1
  else n * fact (n-1)

and g x y z = [x,y,z]

val pi = 3.14159;

(*
 This is the Dutch version of TeX Maths Layout coded in SML, adjusted so
 it only uses a subset of SML. It also has some extensions that add support
 for accents and delimiters, and the aim is that eventually it should
 cover all maths. The stuff here reads in all the source files in an order
 which is safe.
*)

use "General.sml";
use "Powers2.sml";
use "BasicTypes.sml";
use "Distance.sml";
use "Size.sml";
use "FontTypes.sml";
use "LoadFont.sml";
use "FontVector.sml";
use "CharInfo.sml";
use "CharFunctions.sml";
use "Const.sml";
use "FontParams.sml";
use "StyleParams.sml";
use "BoxTypes.sml";
use "BasicBox.sml";
use "NodeDim.sml";
use "NodeListDim.sml";
use "GlueCalculation.sml";
use "HListGlue.sml";
use "BoxPack.sml";
use "MakeVBox.sml";
use "AxisCenter.sml";
use "ChangeStyle.sml";
use "Radical.sml";
use "BasicChar.sml";
use "MakeChar.sml";
use "Accent.sml";
use "MakeLine.sml";
use "MakeAtop.sml";
use "MakeFract.sml";
use "Delimiter.sml";
use "GenFraction.sml";
use "MakeLimOp.sml";
use "MakeScripts.sml";
use "MathTypes.sml";
use "Kind.sml";
use "MathSpace.sml";
use "MathGlue.sml";
use "Spacing.sml";
use "IListTypes.sml";
use "IListDim.sml";
use "ChangeKind.sml";
use "MathPenalty.sml";
use "Boundaries.sml";
use "IListTranslate.sml";
use "MathTranslate.sml";
use "Formula.sml";
use "Out.sml";
use "OutHigh.sml";
use "OutDvi.sml";
use "DviState.sml";
use "DviCmd.sml";
use "SetNode.sml";
use "SetBox.sml";
use "ShipOut.sml";
use "Input.sml";
use "test.sml";

(* End of everything *)

eof

;

end;


FEAT: added any-struct? macro and type-struct! value changed.

Red/System [
	Title:   "Red/System OS-independent runtime"
	Author:  "Nenad Rakocevic"
	File: 	 %common.reds
	Rights:  "Copyright (C) 2011 Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt
	}
]

#define zero? 		  [0 =]
#define positive?	  [0 < ]				;-- space required after the lesser-than symbol
#define negative?	  [0 > ]
#define negate		  [0 -]
#define null?		  [null =]

#define forever		  [while [true]]
#define does		  [func []]
#define unless		  [if not]
#define	raise-error	  ***-on-quit

#define as-byte		  [as byte!]
#define as-logic	  [as logic!]
#define as-integer	  [as integer!]
#define as-c-string	  [as c-string!]

#define null-byte	  #"^(00)"
#define yes			  true
#define no			  false
#define on			  true
#define off			  false

#define byte-ptr!	  [pointer! [byte!]]
#define int-ptr!	  [pointer! [integer!]]
#define make-c-string [as c-string! allocate]

#define type-logic!		1					;-- type ID list for 'typeinfo attribut
#define type-integer!	2
#define type-byte!	    3
#define type-c-string!  4
#define type-byte-ptr!  5
#define type-int-ptr!	6
#define type-function!	7
#define type-struct!	1000
#define any-struct?		[1000 <=]

;-- Global variables definition --
stdout:		-1								;-- uninitialized default value
stdin:		-1								;-- uninitialized default value
stderr:		-1								;-- uninitialized default value

str-array!: alias struct! [
	item [c-string!]
]

typed-value!: alias struct! [
	value	[integer!]
	type	[integer!]
]

__stack!: alias struct! [
	top		[int-ptr!]
	frame	[int-ptr!]
]

system: declare struct! [					;-- store runtime accessible system values
	args-count	[integer!]					;-- command-line arguments count (do not move member)
	args-list	[str-array!]				;-- command-line arguments array pointer (do not move member)
	env-vars 	[str-array!]				;-- environment variables array pointer (always null for Windows)
	stack		[__stack!]					;-- stack virtual access
	pc			[byte-ptr!]					;-- CPU program counter value
	alias		[integer!]					;-- aliases ID virtual access
]

;-------------------------------------------
;-- Convert a type ID to a c-string!
;-------------------------------------------
form-type: func [
	type 	[integer!]						;-- type ID
	return: [c-string!]						;-- type representation as c-string
	/local msg
][
	if type = type-logic! 	 [msg: "logic!"]
	if type = type-integer!  [msg: "integer!"]
	if type = type-byte! 	 [msg: "byte!"]
	if type = type-c-string! [msg: "c-string!"]
	if type = type-byte-ptr! [msg: "pointer! [byte!]"]
	if type = type-int-ptr!  [msg: "pointer! [integer!]"]
	if type = type-struct!   [msg: "struct!"]
	if type = type-function! [msg: "function!"]
	if type > 1000 [msg: "alias"]
	msg
]

#switch OS [
	Windows  [#define LIBC-file	"msvcrt.dll"]
	Syllable [#define LIBC-file	"libc.so.2"]
	MacOSX	 [#define LIBC-file	"libc.dylib"]
	#default [#define LIBC-file	"libc.so.6"]
]

#either use-natives? = no [					;-- C bindings or native counterparts
	#include %lib-C.reds
][
	#include %lib-natives.reds
]

#switch OS [								;-- loading OS-specific bindings
	Windows  [#include %win32.reds]
	Syllable [#include %syllable.reds]
	MacOSX	 [#include %darwin.reds]
	#default [#include %linux.reds]
]

#include %utils.reds						;-- load additional utility functions

#if debug? = yes [#include %debug.reds]		;-- loads optionally debug functions

;-- Run-time error handling --

#define RED_ERR_VMEM_RELEASE_FAILED		96
#define RED_ERR_VMEM_OUT_OF_MEMORY		97

***-on-quit: func [							;-- global exit handler
	status [integer!]
	address [integer!]
	/local msg
][
	unless zero? status [
		print [lf "*** Runtime Error " status ": "]

		if status =  1 [msg: "access violation"]
		if status =  2 [msg: "invalid alignment"]
		if status =  3 [msg: "breakpoint"]
		if status =  4 [msg: "single step"]
		if status =  5 [msg: "bounds exceeded"]
		if status =  6 [msg: "float denormal operan"]
		if status =  7 [msg: "float divide by zero"]
		if status =  8 [msg: "float inexact result"]
		if status =  9 [msg: "float invalid operation"]
		if status = 10 [msg: "float overflow"]
		if status = 11 [msg: "float stack check"]
		if status = 12 [msg: "float underflow"]
		if status = 13 [msg: "integer divide by zero"]
		if status = 14 [msg: "integer overflow"]
		if status = 15 [msg: "privileged instruction"]
		if status = 16 [msg: "invalid virtual address"]
		if status = 17 [msg: "illegal instruction"]
		if status = 18 [msg: "non-continuable exception"]
		if status = 19 [msg: "stack error or overflow"]
		if status = 20 [msg: "invalid disposition"]
		if status = 21 [msg: "guard page"]
		if status = 22 [msg: "invalid handle"]
		if status = 23 [msg: "illegal operand"]
		if status = 24 [msg: "illegal addressing mode"]
		if status = 25 [msg: "illegal trap"]
		if status = 26 [msg: "coprocessor error"]
		if status = 27 [msg: "non-existant physical address"]
		if status = 28 [msg: "object specific hardware error"]
		if status = 29 [msg: "hardware memory error consumed AR"]
		if status = 30 [msg: "hardware memory error consumed AO"]
		if status = 31 [msg: "privileged register"]

		if status = 96 [msg: "virtual memory release failed"]
		if status = 97 [msg: "out of memory"]
		if status = 98 [msg: "assertion failed"]
		if status = 99 [msg: "unknown error"]

		print msg

		#either debug? = yes [
			__print-debug-line as byte-ptr! address
		][
			print [lf "*** at: " as byte-ptr! address "h" lf]
		]
	]

	#if OS = 'Windows [						;-- special exit handler for Windows
		***-on-win32-quit
	]
	quit status
]

Red/System [
	Title:   "Red/System OS-independent runtime"
	Author:  "Nenad Rakocevic"
	File: 	 %common.reds
	Rights:  "Copyright (C) 2011 Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt
	}
]

#define zero? 		  [0 =]
#define positive?	  [0 < ]				;-- space required after the lesser-than symbol
#define negative?	  [0 > ]
#define negate		  [0 -]
#define null?		  [null =]

#define forever		  [while [true]]
#define does		  [func []]
#define unless		  [if not]
#define	raise-error	  ***-on-quit

#define as-byte		  [as byte!]
#define as-logic	  [as logic!]
#define as-integer	  [as integer!]
#define as-c-string	  [as c-string!]

#define null-byte	  #"^(00)"
#define yes			  true
#define no			  false
#define on			  true
#define off			  false

#define byte-ptr!	  [pointer! [byte!]]
#define int-ptr!	  [pointer! [integer!]]
#define make-c-string [as c-string! allocate]

#define type-logic!		1					;-- type ID list for 'typeinfo attribut
#define type-integer!	2
#define type-byte!	    3
#define type-c-string!  4
#define type-byte-ptr!  5
#define type-int-ptr!	6
#define type-struct!	7
#define type-function!	8

;-- Global variables definition --
stdout:		-1								;-- uninitialized default value
stdin:		-1								;-- uninitialized default value
stderr:		-1								;-- uninitialized default value

str-array!: alias struct! [
	item [c-string!]
]

typed-value!: alias struct! [
	value	[integer!]
	type	[integer!]
]

__stack!: alias struct! [
	top		[int-ptr!]
	frame	[int-ptr!]
]

system: declare struct! [					;-- store runtime accessible system values
	args-count	[integer!]					;-- command-line arguments count (do not move member)
	args-list	[str-array!]				;-- command-line arguments array pointer (do not move member)
	env-vars 	[str-array!]				;-- environment variables array pointer (always null for Windows)
	stack		[__stack!]					;-- stack virtual access
	pc			[byte-ptr!]					;-- CPU program counter value
	alias		[integer!]					;-- aliases ID virtual access
]

;-------------------------------------------
;-- Convert a type ID to a c-string!
;-------------------------------------------
form-type: func [
	type 	[integer!]						;-- type ID
	return: [c-string!]						;-- type representation as c-string
	/local msg
][
	if type = type-logic! 	 [msg: "logic!"]
	if type = type-integer!  [msg: "integer!"]
	if type = type-byte! 	 [msg: "byte!"]
	if type = type-c-string! [msg: "c-string!"]
	if type = type-byte-ptr! [msg: "pointer! [byte!]"]
	if type = type-int-ptr!  [msg: "pointer! [integer!]"]
	if type = type-struct!   [msg: "struct!"]
	if type = type-function! [msg: "function!"]
	if type > 1000 [msg: "alias"]
	msg
]

#switch OS [
	Windows  [#define LIBC-file	"msvcrt.dll"]
	Syllable [#define LIBC-file	"libc.so.2"]
	MacOSX	 [#define LIBC-file	"libc.dylib"]
	#default [#define LIBC-file	"libc.so.6"]
]

#either use-natives? = no [					;-- C bindings or native counterparts
	#include %lib-C.reds
][
	#include %lib-natives.reds
]

#switch OS [								;-- loading OS-specific bindings
	Windows  [#include %win32.reds]
	Syllable [#include %syllable.reds]
	MacOSX	 [#include %darwin.reds]
	#default [#include %linux.reds]
]

#include %utils.reds						;-- load additional utility functions

#if debug? = yes [#include %debug.reds]		;-- loads optionally debug functions

;-- Run-time error handling --

#define RED_ERR_VMEM_RELEASE_FAILED		96
#define RED_ERR_VMEM_OUT_OF_MEMORY		97

***-on-quit: func [							;-- global exit handler
	status [integer!]
	address [integer!]
	/local msg
][
	unless zero? status [
		print [lf "*** Runtime Error " status ": "]

		if status =  1 [msg: "access violation"]
		if status =  2 [msg: "invalid alignment"]
		if status =  3 [msg: "breakpoint"]
		if status =  4 [msg: "single step"]
		if status =  5 [msg: "bounds exceeded"]
		if status =  6 [msg: "float denormal operan"]
		if status =  7 [msg: "float divide by zero"]
		if status =  8 [msg: "float inexact result"]
		if status =  9 [msg: "float invalid operation"]
		if status = 10 [msg: "float overflow"]
		if status = 11 [msg: "float stack check"]
		if status = 12 [msg: "float underflow"]
		if status = 13 [msg: "integer divide by zero"]
		if status = 14 [msg: "integer overflow"]
		if status = 15 [msg: "privileged instruction"]
		if status = 16 [msg: "invalid virtual address"]
		if status = 17 [msg: "illegal instruction"]
		if status = 18 [msg: "non-continuable exception"]
		if status = 19 [msg: "stack error or overflow"]
		if status = 20 [msg: "invalid disposition"]
		if status = 21 [msg: "guard page"]
		if status = 22 [msg: "invalid handle"]
		if status = 23 [msg: "illegal operand"]
		if status = 24 [msg: "illegal addressing mode"]
		if status = 25 [msg: "illegal trap"]
		if status = 26 [msg: "coprocessor error"]
		if status = 27 [msg: "non-existant physical address"]
		if status = 28 [msg: "object specific hardware error"]
		if status = 29 [msg: "hardware memory error consumed AR"]
		if status = 30 [msg: "hardware memory error consumed AO"]
		if status = 31 [msg: "privileged register"]

		if status = 96 [msg: "virtual memory release failed"]
		if status = 97 [msg: "out of memory"]
		if status = 98 [msg: "assertion failed"]
		if status = 99 [msg: "unknown error"]

		print msg

		#either debug? = yes [
			__print-debug-line as byte-ptr! address
		][
			print [lf "*** at: " as byte-ptr! address "h" lf]
		]
	]

	#if OS = 'Windows [						;-- special exit handler for Windows
		***-on-win32-quit
	]
	quit status
]


TESTS: added LOAD float tests.

TESTS: added LOAD float tests.

Red [
	Title:   "Red loading test script"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %load-test.reds
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2012 Nenad Rakocevic & Peter W A Wood. All rights reserved."
	License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt"
]

#include  %../../../quick-test/quick-test.red

~~~start-file~~~ "load"

===start-group=== "Delimiter LOAD tests"

	--test-- "load-1"  --assert "" 		 = load {""}
	--test-- "load-2"  --assert "" 		 = load {{}}
	--test-- "load-3"  --assert "{" 	 = load {"^{"}
	--test-- "load-4"  --assert "}" 	 = load {"^}"}
	--test-- "load-5"  --assert "{}"	 = load {"^{^}"}
	--test-- "load-6"  --assert {^}^{} 	 = load {"^}^{"}
	--test-- "load-7"  --assert "^{^}^}" = load {"^{^}^}"}
	--test-- "load-8"  --assert ""		 = load {"^"}
	--test-- "load-9"  --assert ""		 = load "{}"
	--test-- "load-10" --assert "{"		 = load "{^{}"
	--test-- "load-11" --assert {"}		 = load {{"}}
	--test-- "load-12" --assert "^/" 	 = load "{^/}^/"
	--test-- "load-13" --assert "^/" 	 = load "{^/}"
	--test-- "load-14" --assert "{^/}"	 = load {{{^/}}}
	--test-- "load-15" --assert {{"x"}}	 = load {{{"x"}}}
	--test-- "load-16" --assert "{x}"	 = load {{{x}}}
	--test-- "load-17" --assert {"x"}	 = load {{"x"}}
	--test-- "load-18" --assert "x"		 = load {{x}}

===end-group===

===start-group=== "LOAD /part tests"
	src: "123abc789"

	--test-- "load-p1" --assert 123  = load/part src 3
	--test-- "load-p2" --assert 12   = load/part src 2
	--test-- "load-p3" --assert 1    = load/part src 1
	--test-- "load-p4" --assert []   = load/part src 0
	--test-- "load-p4" --assert 'abc = load/part skip src 3 3

===end-group===

===start-group=== "LOAD floats test"

	--test-- "load-30" --assert "123.0"	 = mold load "123.0"
	--test-- "load-31" --assert "1.123"  = mold load "1.123"
	--test-- "load-32" --assert "0.123"  = mold load ".123"
	--test-- "load-33" --assert "100.0"  = mold load "1E2"
	--test-- "load-34" --assert "1200.0" = mold load "1.2E3"
	--test-- "load-35" --assert "10.0"   = mold load ".1E2"
	--test-- "load-36" --assert "12.3"   = mold load ".123E2"

===end-group===

~~~end-file~~~

Red [
	Title:   "Red loading test script"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %load-test.reds
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2012 Nenad Rakocevic & Peter W A Wood. All rights reserved."
	License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt"
]

#include  %../../../quick-test/quick-test.red

~~~start-file~~~ "load"

===start-group=== "Delimiter LOAD tests"

	--test-- "load-1"  --assert "" 		 = load {""}
	--test-- "load-2"  --assert "" 		 = load {{}}
	--test-- "load-3"  --assert "{" 	 = load {"^{"}
	--test-- "load-4"  --assert "}" 	 = load {"^}"}
	--test-- "load-5"  --assert "{}"	 = load {"^{^}"}
	--test-- "load-6"  --assert {^}^{} 	 = load {"^}^{"}
	--test-- "load-7"  --assert "^{^}^}" = load {"^{^}^}"}
	--test-- "load-8"  --assert ""		 = load {"^"}
	--test-- "load-9"  --assert ""		 = load "{}"
	--test-- "load-10" --assert "{"		 = load "{^{}"
	--test-- "load-11" --assert {"}		 = load {{"}}
	--test-- "load-12" --assert "^/" 	 = load "{^/}^/"
	--test-- "load-13" --assert "^/" 	 = load "{^/}"
	--test-- "load-14" --assert "{^/}"	 = load {{{^/}}}
	--test-- "load-15" --assert {{"x"}}	 = load {{{"x"}}}
	--test-- "load-16" --assert "{x}"	 = load {{{x}}}
	--test-- "load-17" --assert {"x"}	 = load {{"x"}}
	--test-- "load-18" --assert "x"		 = load {{x}}

===end-group===

===start-group=== "LOAD /part tests"
	src: "123abc789"

	--test-- "load-p1" --assert 123  = load/part src 3
	--test-- "load-p2" --assert 12   = load/part src 2
	--test-- "load-p3" --assert 1    = load/part src 1
	--test-- "load-p4" --assert []   = load/part src 0
	--test-- "load-p4" --assert 'abc = load/part skip src 3 3

===end-group===

~~~end-file~~~


FEAT: added division by zero error catching.

Red/System [
	Title:   "Integer! datatype runtime functions"
	Author:  "Nenad Rakocevic"
	File: 	 %integer.reds
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2012 Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
]

integer: context [
	verbose: 0

	abs: func [
		value	[integer!]
		return: [integer!]
	][
		if value = -2147483648 [
			fire [TO_ERROR(math overflow)]
		]
		if negative? value [value: 0 - value]
		value
	]

	get*: func [										;-- unboxing integer value from stack
		return: [integer!]
		/local
			int [red-integer!]
	][
		int: as red-integer! stack/arguments
		assert TYPE_OF(int) = TYPE_INTEGER
		int/value
	]

	get-any*: func [									;-- special get* variant for SWITCH
		return: [integer!]
		/local
			int [red-integer!]
	][
		int: as red-integer! stack/arguments
		either TYPE_OF(int) = TYPE_INTEGER [int/value][0] ;-- accept NONE values
	]

	get: func [											;-- unboxing integer value
		value	[red-value!]
		return: [integer!]
		/local
			int [red-integer!]
	][
		assert TYPE_OF(value) = TYPE_INTEGER
		int: as red-integer! value
		int/value
	]

	box: func [
		value	[integer!]
		return: [red-integer!]
		/local
			int [red-integer!]
	][
		int: as red-integer! stack/arguments
		int/header: TYPE_INTEGER
		int/value: value
		int
	]

	form-signed: func [									;@@ replace with sprintf() call?
		i 		[integer!]
		return: [c-string!]
		/local
			s	[c-string!]
			c 	[integer!]
			n 	[logic!]
	][
		s: "-0000000000"								;-- 11 bytes wide
		if zero? i [									;-- zero special case
			s/11: #"0"
			return s + 10
		]
		if i = -2147483648 [							;-- min integer special case
			return "-2147483648"
		]
		n: negative? i
		if n [i: negate i]
		c: 11
		while [i <> 0][
			s/c: #"0" + (i // 10)
			i: i / 10
			c: c - 1
		]
		if n [s/c: #"-" c: c - 1]
		s + c
	]

	do-math: func [
		type		[math-op!]
		return:		[red-value!]
		/local
			left	[red-integer!]
			right	[red-integer!]
	][
		left: as red-integer! stack/arguments
		right: left + 1

		assert any [									;@@ replace by typeset check when possible
			TYPE_OF(left) = TYPE_INTEGER
			TYPE_OF(left) = TYPE_CHAR
		]
		assert any [
			TYPE_OF(right) = TYPE_INTEGER
			TYPE_OF(right) = TYPE_CHAR
			TYPE_OF(right) = TYPE_FLOAT
		]

		either TYPE_OF(right) = TYPE_FLOAT [
			float/do-math type
		][
			left/value: switch type [
				OP_ADD [left/value + right/value]
				OP_SUB [left/value - right/value]
				OP_MUL [left/value * right/value]
				OP_REM [left/value % right/value]
				OP_AND [left/value and right/value]
				OP_OR  [left/value or right/value]
				OP_XOR [left/value xor right/value]
				OP_DIV [
					either zero? right/value [
						fire [TO_ERROR(math zero-divide)]
						0								;-- pass the compiler's type-checking
					][
						left/value / right/value
					]
				]
			]
		]
		as red-value! left
	]

	load-in: func [
		blk	  	[red-block!]
		value 	[integer!]
		/local
			int [red-integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "integer/load-in"]]

		int: as red-integer! ALLOC_TAIL(blk)
		int/header: TYPE_INTEGER
		int/value: value
	]

	push: func [
		value	[integer!]
		return: [red-integer!]
		/local
			int [red-integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "integer/push"]]

		int: as red-integer! stack/push*
		int/header: TYPE_INTEGER
		int/value: value
		int
	]

	to-float: func [
		i		[integer!]
		return: [float!]
		/local
			f	[float!]
			d	[int-ptr!]
	][
		;-- Based on this method: http://stackoverflow.com/a/429812/494472
		;-- A bit more explanation: http://lolengine.net/blog/2011/3/20/understanding-fast-float-integer-conversions
		f: 6755399441055744.0
		d: as int-ptr! :f
		d/value: i or d/value
		either i < 0 [f - 6755403736023040.0][f - 6755399441055744.0]
	]

	;-- Actions --

	make: func [
		proto	 [red-value!]
		spec	 [red-value!]
		return:	 [red-integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "integer/make"]]

		switch TYPE_OF(spec) [
			TYPE_INTEGER [
				as red-integer! spec
			]
			default [
				--NOT_IMPLEMENTED--
				as red-integer! spec					;@@ just for making it compilable
			]
		]
	]

	random: func [
		int		[red-integer!]
		seed?	[logic!]
		secure? [logic!]
		only?   [logic!]
		return: [red-value!]
		/local
			n	 [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "integer/random"]]

		either seed? [
			_random/srand int/value
			int/header: TYPE_UNSET
		][
			n: _random/rand % int/value + 1
			int/value: either negative? int/value [0 - n][n]
		]
		as red-value! int
	]

	to: func [
		type	[red-datatype!]
		spec	[red-integer!]
		return: [red-value!]
		/local
			f	[red-float!]
			buf [red-string!]
	][
		#if debug? = yes [if verbose > 0 [print-line "integer/to"]]

		switch type/value [
			TYPE_FLOAT [
				f: as red-float! type
				f/header: TYPE_FLOAT
				f/value: to-float spec/value
			]
			TYPE_STRING [
				buf: string/rs-make-at as cell! type 1			;-- 16 bits string
				string/concatenate-literal buf form-signed spec/value
			]
			default [
				fire [TO_ERROR(script bad-make-arg) type spec]
			]
		]
		as red-value! type
	]

	form: func [
		int		   [red-integer!]
		buffer	   [red-string!]
		arg		   [red-value!]
		part 	   [integer!]
		return:    [integer!]
		/local
			formed [c-string!]
	][
		#if debug? = yes [if verbose > 0 [print-line "integer/form"]]

		formed: form-signed int/value
		string/concatenate-literal buffer formed
		part - length? formed							;@@ optimize by removing length?
	]

	mold: func [
		int		[red-integer!]
		buffer	[red-string!]
		only?	[logic!]
		all?	[logic!]
		flat?	[logic!]
		arg		[red-value!]
		part 	[integer!]
		indent	[integer!]
		return: [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "integer/mold"]]

		form int buffer arg part
	]

	compare: func [
		value1    [red-integer!]						;-- first operand
		value2    [red-integer!]						;-- second operand
		op	      [integer!]							;-- type of comparison
		return:   [integer!]
		/local
			char  [red-char!]
			f	  [red-float!]
			left  [integer!]
			right [integer!]
			res	  [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "integer/compare"]]

		if all [
			op = COMP_STRICT_EQUAL
			TYPE_OF(value2) <> TYPE_INTEGER
		][return 1]

		left: value1/value

		switch TYPE_OF(value2) [
			TYPE_INTEGER [
				right: value2/value
			]
			TYPE_CHAR [
				char: as red-char! value2				;@@ could be optimized as integer! and char!
				right: char/value						;@@ structures are overlapping exactly
			]
			TYPE_FLOAT [
				f: as red-float! value1
				left: value1/value
				f/value: to-float left
				res: float/compare f as red-float! value2 op
				value1/value: left
				return res
			]
			default [RETURN_COMPARE_OTHER]
		]
		SIGN_COMPARE_RESULT(left right)
	]

	complement: func [
		int		[red-integer!]
		return:	[red-value!]
	][
		int/value: not int/value
		as red-value! int
	]

	remainder: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "integer/remainder"]]
		as red-value! do-math OP_REM
	]

	absolute: func [
		return: [red-integer!]
		/local
			int	  [red-integer!]
			value [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "integer/absolute"]]

		int: as red-integer! stack/arguments
		int/value: abs int/value
		int
	]

	add: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "integer/add"]]
		as red-value! do-math OP_ADD
	]

	divide: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "integer/divide"]]
		as red-value! do-math OP_DIV
	]

	multiply: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "integer/multiply"]]
		as red-value! do-math OP_MUL
	]

	subtract: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "integer/subtract"]]
		as red-value! do-math OP_SUB
	]

	and~: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "integer/and~"]]
		as red-value! do-math OP_AND
	]

	or~: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "integer/or~"]]
		as red-value! do-math OP_OR
	]

	xor~: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "integer/xor~"]]
		as red-value! do-math OP_XOR
	]

	negate: func [
		return: [red-integer!]
		/local
			int [red-integer!]
	][
		int: as red-integer! stack/arguments
		int/value: 0 - int/value
		int 											;-- re-use argument slot for return value
	]

	int-power: func [
		base	[integer!]
		exp		[integer!]
		return: [integer!]
		/local
			res  [integer!]
			neg? [logic!]
	][
		res: 1
		neg?: false

		if exp < 0 [neg?: true exp: 0 - exp]
		while [exp <> 0][
			if as logic! exp and 1 [res: res * base]
			exp: exp >> 1
			base: base * base
		]
		either neg? [1 / res][res]
	]

	power: func [
		return:	 [red-value!]
		/local
			base [red-integer!]
			exp  [red-integer!]
			f	 [red-float!]
	][
		base: as red-integer! stack/arguments
		exp: base + 1
		either any [
			TYPE_OF(exp) = TYPE_FLOAT
			negative? exp/value
		][
			f: as red-float! base
			f/value: to-float base/value
			f/header: TYPE_FLOAT
			float/power
		][
			base/value: int-power base/value exp/value
		]
		as red-value! base
	]

	even?: func [
		int		[red-integer!]
		return: [logic!]
	][
		not as-logic int/value and 1
	]

	odd?: func [
		int		[red-integer!]
		return: [logic!]
	][
		as-logic int/value and 1
	]

	#define INT_TRUNC [int/value: either num > 0 [n - r][r - n]]

	#define INT_FLOOR [
		either m < 0 [
			fire [TO_ERROR(math overflow)]
		][
			int/value: either num > 0 [n - r][0 - m]
		]
	]

	#define INT_CEIL [
		either m < 0 [
			fire [TO_ERROR(math overflow)]
		][
			int/value: either num < 0 [r - n][m]
		]
	]

	#define INT_AWAY [
		either m < 0 [
			fire [TO_ERROR(math overflow)]
		][
			int/value: either num > 0 [m][0 - m]
		]
	]

	round: func [
		value		[red-value!]
		scale		[red-integer!]
		_even?		[logic!]
		down?		[logic!]
		half-down?	[logic!]
		floor?		[logic!]
		ceil?		[logic!]
		half-ceil?	[logic!]
		return:		[red-value!]
		/local
			int		[red-integer!]
			f		[red-float!]
			num		[integer!]
			sc		[integer!]
			s		[integer!]
			n		[integer!]
			m		[integer!]
			r		[integer!]
	][
		int: as red-integer! value
		num: int/value
		if num = 80000000h [return value]
		sc: 1
		if OPTION?(scale) [
			if TYPE_OF(scale) = TYPE_FLOAT [
				f: as red-float! value
				f/value: to-float num
				f/header: TYPE_FLOAT
				return float/round value as red-float! scale _even? down? half-down? floor? ceil? half-ceil?
			]
			sc: abs scale/value
		]

		if zero? sc [
			fire [TO_ERROR(math overflow)]
		]

		n: abs num
		r: n % sc
		if zero? r [return value]

		s: sc - r
		m: n + s
		case [
			down?		[INT_TRUNC]
			floor?		[INT_FLOOR]
			ceil?		[INT_CEIL ]
			r < s		[INT_TRUNC]
			r > s		[INT_AWAY ]
			_even?		[either zero? (n / sc and 1) [INT_TRUNC][INT_AWAY]]
			half-down?	[INT_TRUNC]
			half-ceil?	[INT_CEIL ]
			true		[INT_AWAY ]
		]
		value
	]

	init: does [
		datatype/register [
			TYPE_INTEGER
			TYPE_VALUE
			"integer!"
			;-- General actions --
			:make
			:random
			null			;reflect
			:to
			:form
			:mold
			null			;eval-path
			null			;set-path
			:compare
			;-- Scalar actions --
			:absolute
			:add
			:divide
			:multiply
			:negate
			:power
			:remainder
			:round
			:subtract
			:even?
			:odd?
			;-- Bitwise actions --
			:and~
			:complement
			:or~
			:xor~
			;-- Series actions --
			null			;append
			null			;at
			null			;back
			null			;change
			null			;clear
			null			;copy
			null			;find
			null			;head
			null			;head?
			null			;index?
			null			;insert
			null			;length?
			null			;next
			null			;pick
			null			;poke
			null			;remove
			null			;reverse
			null			;select
			null			;sort
			null			;skip
			null			;swap
			null			;tail
			null			;tail?
			null			;take
			null			;trim
			;-- I/O actions --
			null			;create
			null			;close
			null			;delete
			null			;modify
			null			;open
			null			;open?
			null			;query
			null			;read
			null			;rename
			null			;update
			null			;write
		]
	]
]

Red/System [
	Title:   "Integer! datatype runtime functions"
	Author:  "Nenad Rakocevic"
	File: 	 %integer.reds
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2012 Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
]

integer: context [
	verbose: 0

	abs: func [
		value	[integer!]
		return: [integer!]
	][
		if value = -2147483648 [
			fire [TO_ERROR(math overflow)]
		]
		if negative? value [value: 0 - value]
		value
	]

	get*: func [										;-- unboxing integer value from stack
		return: [integer!]
		/local
			int [red-integer!]
	][
		int: as red-integer! stack/arguments
		assert TYPE_OF(int) = TYPE_INTEGER
		int/value
	]

	get-any*: func [									;-- special get* variant for SWITCH
		return: [integer!]
		/local
			int [red-integer!]
	][
		int: as red-integer! stack/arguments
		either TYPE_OF(int) = TYPE_INTEGER [int/value][0] ;-- accept NONE values
	]

	get: func [											;-- unboxing integer value
		value	[red-value!]
		return: [integer!]
		/local
			int [red-integer!]
	][
		assert TYPE_OF(value) = TYPE_INTEGER
		int: as red-integer! value
		int/value
	]

	box: func [
		value	[integer!]
		return: [red-integer!]
		/local
			int [red-integer!]
	][
		int: as red-integer! stack/arguments
		int/header: TYPE_INTEGER
		int/value: value
		int
	]

	form-signed: func [									;@@ replace with sprintf() call?
		i 		[integer!]
		return: [c-string!]
		/local
			s	[c-string!]
			c 	[integer!]
			n 	[logic!]
	][
		s: "-0000000000"								;-- 11 bytes wide
		if zero? i [									;-- zero special case
			s/11: #"0"
			return s + 10
		]
		if i = -2147483648 [							;-- min integer special case
			return "-2147483648"
		]
		n: negative? i
		if n [i: negate i]
		c: 11
		while [i <> 0][
			s/c: #"0" + (i // 10)
			i: i / 10
			c: c - 1
		]
		if n [s/c: #"-" c: c - 1]
		s + c
	]

	do-math: func [
		type		[math-op!]
		return:		[red-value!]
		/local
			left	[red-integer!]
			right	[red-integer!]
	][
		left: as red-integer! stack/arguments
		right: left + 1

		assert any [									;@@ replace by typeset check when possible
			TYPE_OF(left) = TYPE_INTEGER
			TYPE_OF(left) = TYPE_CHAR
		]
		assert any [
			TYPE_OF(right) = TYPE_INTEGER
			TYPE_OF(right) = TYPE_CHAR
			TYPE_OF(right) = TYPE_FLOAT
		]

		either TYPE_OF(right) = TYPE_FLOAT [
			float/do-math type
		][
			left/value: switch type [
				OP_ADD [left/value + right/value]
				OP_SUB [left/value - right/value]
				OP_MUL [left/value * right/value]
				OP_DIV [left/value / right/value]
				OP_REM [left/value % right/value]
				OP_AND [left/value and right/value]
				OP_OR  [left/value or right/value]
				OP_XOR [left/value xor right/value]
			]
		]
		as red-value! left
	]

	load-in: func [
		blk	  	[red-block!]
		value 	[integer!]
		/local
			int [red-integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "integer/load-in"]]

		int: as red-integer! ALLOC_TAIL(blk)
		int/header: TYPE_INTEGER
		int/value: value
	]

	push: func [
		value	[integer!]
		return: [red-integer!]
		/local
			int [red-integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "integer/push"]]

		int: as red-integer! stack/push*
		int/header: TYPE_INTEGER
		int/value: value
		int
	]

	to-float: func [
		i		[integer!]
		return: [float!]
		/local
			f	[float!]
			d	[int-ptr!]
	][
		;-- Based on this method: http://stackoverflow.com/a/429812/494472
		;-- A bit more explanation: http://lolengine.net/blog/2011/3/20/understanding-fast-float-integer-conversions
		f: 6755399441055744.0
		d: as int-ptr! :f
		d/value: i or d/value
		either i < 0 [f - 6755403736023040.0][f - 6755399441055744.0]
	]

	;-- Actions --

	make: func [
		proto	 [red-value!]
		spec	 [red-value!]
		return:	 [red-integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "integer/make"]]

		switch TYPE_OF(spec) [
			TYPE_INTEGER [
				as red-integer! spec
			]
			default [
				--NOT_IMPLEMENTED--
				as red-integer! spec					;@@ just for making it compilable
			]
		]
	]

	random: func [
		int		[red-integer!]
		seed?	[logic!]
		secure? [logic!]
		only?   [logic!]
		return: [red-value!]
		/local
			n	 [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "integer/random"]]

		either seed? [
			_random/srand int/value
			int/header: TYPE_UNSET
		][
			n: _random/rand % int/value + 1
			int/value: either negative? int/value [0 - n][n]
		]
		as red-value! int
	]

	to: func [
		type	[red-datatype!]
		spec	[red-integer!]
		return: [red-value!]
		/local
			f	[red-float!]
			buf [red-string!]
	][
		#if debug? = yes [if verbose > 0 [print-line "integer/to"]]

		switch type/value [
			TYPE_FLOAT [
				f: as red-float! type
				f/header: TYPE_FLOAT
				f/value: to-float spec/value
			]
			TYPE_STRING [
				buf: string/rs-make-at as cell! type 1			;-- 16 bits string
				string/concatenate-literal buf form-signed spec/value
			]
			default [
				fire [TO_ERROR(script bad-make-arg) type spec]
			]
		]
		as red-value! type
	]

	form: func [
		int		   [red-integer!]
		buffer	   [red-string!]
		arg		   [red-value!]
		part 	   [integer!]
		return:    [integer!]
		/local
			formed [c-string!]
	][
		#if debug? = yes [if verbose > 0 [print-line "integer/form"]]

		formed: form-signed int/value
		string/concatenate-literal buffer formed
		part - length? formed							;@@ optimize by removing length?
	]

	mold: func [
		int		[red-integer!]
		buffer	[red-string!]
		only?	[logic!]
		all?	[logic!]
		flat?	[logic!]
		arg		[red-value!]
		part 	[integer!]
		indent	[integer!]
		return: [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "integer/mold"]]

		form int buffer arg part
	]

	compare: func [
		value1    [red-integer!]						;-- first operand
		value2    [red-integer!]						;-- second operand
		op	      [integer!]							;-- type of comparison
		return:   [integer!]
		/local
			char  [red-char!]
			f	  [red-float!]
			left  [integer!]
			right [integer!]
			res	  [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "integer/compare"]]

		if all [
			op = COMP_STRICT_EQUAL
			TYPE_OF(value2) <> TYPE_INTEGER
		][return 1]

		left: value1/value

		switch TYPE_OF(value2) [
			TYPE_INTEGER [
				right: value2/value
			]
			TYPE_CHAR [
				char: as red-char! value2				;@@ could be optimized as integer! and char!
				right: char/value						;@@ structures are overlapping exactly
			]
			TYPE_FLOAT [
				f: as red-float! value1
				left: value1/value
				f/value: to-float left
				res: float/compare f as red-float! value2 op
				value1/value: left
				return res
			]
			default [RETURN_COMPARE_OTHER]
		]
		SIGN_COMPARE_RESULT(left right)
	]

	complement: func [
		int		[red-integer!]
		return:	[red-value!]
	][
		int/value: not int/value
		as red-value! int
	]

	remainder: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "integer/remainder"]]
		as red-value! do-math OP_REM
	]

	absolute: func [
		return: [red-integer!]
		/local
			int	  [red-integer!]
			value [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "integer/absolute"]]

		int: as red-integer! stack/arguments
		int/value: abs int/value
		int
	]

	add: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "integer/add"]]
		as red-value! do-math OP_ADD
	]

	divide: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "integer/divide"]]
		as red-value! do-math OP_DIV
	]

	multiply: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "integer/multiply"]]
		as red-value! do-math OP_MUL
	]

	subtract: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "integer/subtract"]]
		as red-value! do-math OP_SUB
	]

	and~: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "integer/and~"]]
		as red-value! do-math OP_AND
	]

	or~: func [return: [red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "integer/or~"]]
		as red-value! do-math OP_OR
	]

	xor~: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "integer/xor~"]]
		as red-value! do-math OP_XOR
	]

	negate: func [
		return: [red-integer!]
		/local
			int [red-integer!]
	][
		int: as red-integer! stack/arguments
		int/value: 0 - int/value
		int 											;-- re-use argument slot for return value
	]

	int-power: func [
		base	[integer!]
		exp		[integer!]
		return: [integer!]
		/local
			res  [integer!]
			neg? [logic!]
	][
		res: 1
		neg?: false

		if exp < 0 [neg?: true exp: 0 - exp]
		while [exp <> 0][
			if as logic! exp and 1 [res: res * base]
			exp: exp >> 1
			base: base * base
		]
		either neg? [1 / res][res]
	]

	power: func [
		return:	 [red-value!]
		/local
			base [red-integer!]
			exp  [red-integer!]
			f	 [red-float!]
	][
		base: as red-integer! stack/arguments
		exp: base + 1
		either any [
			TYPE_OF(exp) = TYPE_FLOAT
			negative? exp/value
		][
			f: as red-float! base
			f/value: to-float base/value
			f/header: TYPE_FLOAT
			float/power
		][
			base/value: int-power base/value exp/value
		]
		as red-value! base
	]

	even?: func [
		int		[red-integer!]
		return: [logic!]
	][
		not as-logic int/value and 1
	]

	odd?: func [
		int		[red-integer!]
		return: [logic!]
	][
		as-logic int/value and 1
	]

	#define INT_TRUNC [int/value: either num > 0 [n - r][r - n]]

	#define INT_FLOOR [
		either m < 0 [
			fire [TO_ERROR(math overflow)]
		][
			int/value: either num > 0 [n - r][0 - m]
		]
	]

	#define INT_CEIL [
		either m < 0 [
			fire [TO_ERROR(math overflow)]
		][
			int/value: either num < 0 [r - n][m]
		]
	]

	#define INT_AWAY [
		either m < 0 [
			fire [TO_ERROR(math overflow)]
		][
			int/value: either num > 0 [m][0 - m]
		]
	]

	round: func [
		value		[red-value!]
		scale		[red-integer!]
		_even?		[logic!]
		down?		[logic!]
		half-down?	[logic!]
		floor?		[logic!]
		ceil?		[logic!]
		half-ceil?	[logic!]
		return:		[red-value!]
		/local
			int		[red-integer!]
			f		[red-float!]
			num		[integer!]
			sc		[integer!]
			s		[integer!]
			n		[integer!]
			m		[integer!]
			r		[integer!]
	][
		int: as red-integer! value
		num: int/value
		if num = 80000000h [return value]
		sc: 1
		if OPTION?(scale) [
			if TYPE_OF(scale) = TYPE_FLOAT [
				f: as red-float! value
				f/value: to-float num
				f/header: TYPE_FLOAT
				return float/round value as red-float! scale _even? down? half-down? floor? ceil? half-ceil?
			]
			sc: abs scale/value
		]

		if zero? sc [
			fire [TO_ERROR(math overflow)]
		]

		n: abs num
		r: n % sc
		if zero? r [return value]

		s: sc - r
		m: n + s
		case [
			down?		[INT_TRUNC]
			floor?		[INT_FLOOR]
			ceil?		[INT_CEIL ]
			r < s		[INT_TRUNC]
			r > s		[INT_AWAY ]
			_even?		[either zero? (n / sc and 1) [INT_TRUNC][INT_AWAY]]
			half-down?	[INT_TRUNC]
			half-ceil?	[INT_CEIL ]
			true		[INT_AWAY ]
		]
		value
	]

	init: does [
		datatype/register [
			TYPE_INTEGER
			TYPE_VALUE
			"integer!"
			;-- General actions --
			:make
			:random
			null			;reflect
			:to
			:form
			:mold
			null			;eval-path
			null			;set-path
			:compare
			;-- Scalar actions --
			:absolute
			:add
			:divide
			:multiply
			:negate
			:power
			:remainder
			:round
			:subtract
			:even?
			:odd?
			;-- Bitwise actions --
			:and~
			:complement
			:or~
			:xor~
			;-- Series actions --
			null			;append
			null			;at
			null			;back
			null			;change
			null			;clear
			null			;copy
			null			;find
			null			;head
			null			;head?
			null			;index?
			null			;insert
			null			;length?
			null			;next
			null			;pick
			null			;poke
			null			;remove
			null			;reverse
			null			;select
			null			;sort
			null			;skip
			null			;swap
			null			;tail
			null			;tail?
			null			;take
			null			;trim
			;-- I/O actions --
			null			;create
			null			;close
			null			;delete
			null			;modify
			null			;open
			null			;open?
			null			;query
			null			;read
			null			;rename
			null			;update
			null			;write
		]
	]
]


FEAT: multi-line input support for Red console.

Red [
	Title:	"Red console"
	Author: ["Nenad Rakocevic" "Kaj de Vos"]
	File: 	%console.red
	Tabs: 	4
	Rights: "Copyright (C) 2012-2013 Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
]

#system-global [
	#either OS = 'Windows [
		#import [
			"kernel32.dll" stdcall [
				AttachConsole: 	 "AttachConsole" [
					processID		[integer!]
					return:			[integer!]
				]
				SetConsoleTitle: "SetConsoleTitleA" [
					title			[c-string!]
					return:			[integer!]
				]
				ReadConsole: 	 "ReadConsoleA" [
					consoleInput	[integer!]
					buffer			[byte-ptr!]
					charsToRead		[integer!]
					numberOfChars	[int-ptr!]
					inputControl	[int-ptr!]
					return:			[integer!]
				]
			]
		]
	][
		#switch OS [
			MacOSX [  ; TODO: check this
				#define ReadLine-library "libreadline.dylib"
				#define History-library  "libhistory.dylib"
			]
			#default [
				#define ReadLine-library "libreadline.so.6"
				#define History-library  "libhistory.so.6"
			]
		]
		#import [
			ReadLine-library cdecl [
				read-line: "readline" [  ; Read a line from the console.
					prompt			[c-string!]
					return:			[c-string!]
				]
			]
			History-library cdecl [
				add-history: "add_history" [  ; Add line to the history.
					line			[c-string!]
				]
			]
		]
	]
]

init-console: routine [
	str [string!]
	/local
		ret
][
	#either OS = 'Windows [
		;ret: AttachConsole -1
		;if zero? ret [print-line "ReadConsole failed!" halt]

		ret: SetConsoleTitle as c-string! string/rs-head str
		if zero? ret [print-line "ReadConsole failed!" halt]
	][
		print-line as-c-string string/rs-head str
	]
]

input: routine [
	/local
		len ret str buffer line
][
	#either OS = 'Windows [
		len: 0
		buffer: allocate 128
		ret: ReadConsole stdin buffer 127 :len null
		if zero? ret [print-line "ReadConsole failed!" halt]
		len: len + 1
		buffer/len: null-byte
		str: string/load as c-string! buffer len
;		free buffer
	][
		line: read-line ""
		if line = null [halt]  ; EOF

		add-history line

		str: string/load line  1 + length? line
;		free as byte-ptr! line
	]
	SET_RETURN(str)
]

c: none													;@@ fix me

count-delimiters: func [
	buffer	[string!]
	return: [block!]
	/local list
][
	list: copy [0 0]

	foreach c buffer [
		switch c [
			#"[" [list/1: list/1 + 1]
			#"]" [list/1: list/1 - 1]
			#"{" [list/2: list/2 + 1]
			#"}" [list/2: list/2 - 1]
		]
	]
	list
]

clear-CR: function [str [string!]][
	if crlf = pos: skip tail str -2 [remove pos]
]

do-console: function [][
	buffer: make string! 10000
	prompt: red-prompt: "red>> "
	mode:  'mono

	switch-mode: [
		mode: case [
			cnt/1 > 0 ['block]
			cnt/2 > 0 ['string]
			'else 	  [
				prompt: red-prompt
				do eval
				mode: 'mono								;@@ fix me
			]
		]
		prompt: switch mode [
			block  ["[^-"]
			string ["{^-"]
			mono   [red-prompt]
		]
	]

	eval: [
		code: load/all buffer
		unless tail? code [
			set/any 'result do code
			unless unset? :result [
				print ["==" mold :result]				;@@ use mold/part
			]
		]
		clear buffer
	]

	while [true][
		prin prompt

		unless tail? line: input [
			if crlf = pos: skip tail line -2 [remove pos]	;-- clear extra CR (Windows)

			append buffer line
			cnt: count-delimiters buffer

			switch mode [
				block  [if cnt/1 <= 0 [do switch-mode]]
				string [if cnt/2 <= 0 [do switch-mode]]
				mono   [do either any [cnt/1 > 0 cnt/2 > 0][switch-mode][eval]]
			]
		]
	]
]

q: :quit												;@@ fix me

init-console "Red Console (Xmas demo edition!)"

print {
-=== Red Console alpha version ===-
(only Latin-1 input supported)
}

do-console

Red [
	Title:	"Red console"
	Author: ["Nenad Rakocevic" "Kaj de Vos"]
	File: 	%console.red
	Tabs: 	4
	Rights: "Copyright (C) 2012-2013 Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
]

#system-global [
	#either OS = 'Windows [
		#import [
			"kernel32.dll" stdcall [
				AttachConsole: "AttachConsole" [
					processID		[integer!]
					return:			[integer!]
				]
				SetConsoleTitle: "SetConsoleTitleA" [
					title			[c-string!]
					return:			[integer!]
				]
				ReadConsole: "ReadConsoleA" [
					consoleInput	[integer!]
					buffer			[byte-ptr!]
					charsToRead		[integer!]
					numberOfChars	[int-ptr!]
					inputControl	[int-ptr!]
					return:			[integer!]
				]
			]
		]
	][
		#switch OS [
			MacOSX [  ; TODO: check this
				#define ReadLine-library "libreadline.dylib"
				#define History-library "libhistory.dylib"
			]
			#default [
				#define ReadLine-library "libreadline.so.6"
				#define History-library "libhistory.so.6"
			]
		]
		#import [
			ReadLine-library cdecl [
				read-line: "readline" [  ; Read a line from the console.
					prompt			[c-string!]
					return:			[c-string!]
				]
			]
			History-library cdecl [
				add-history: "add_history" [  ; Add line to the history.
					line			[c-string!]
				]
			]
		]
	]
]

init-console: routine [
	str [string!]
	/local
		ret
][
	#either OS = 'Windows [
		;ret: AttachConsole -1
		;if zero? ret [print-line "ReadConsole failed!" halt]

		ret: SetConsoleTitle as c-string! string/rs-head str
		if zero? ret [print-line "ReadConsole failed!" halt]
	][
		print-line as-c-string string/rs-head str
	]
]

input: routine [
	/local
		len ret str buffer
		line
][
	#either OS = 'Windows [
		prin "red>> "

		len: 0
		buffer: allocate 128
		ret: ReadConsole stdin buffer 127 :len null
		if zero? ret [print-line "ReadConsole failed!" halt]
		len: len + 1
		buffer/len: null-byte
		str: string/load as c-string! buffer len
;		free buffer
	][
		line: read-line "red>> "
		if line = null [halt]  ; EOF

		add-history line

		str: string/load line  1 + length? line
;		free as byte-ptr! line
	]
	SET_RETURN(str)
]

q: :quit

init-console "Red Console (Xmas demo edition!)"

print {
-=== Red Console pre-alpha version ===-
(only Latin-1 input supported)
}

while [true][
	unless tail? line: input [
		code: load/all line
		unless tail? code [
			set/any 'result do code
			unless unset? :result [
				prin "== "
				probe result
			]
		]
	]
]