Wheeee - things now parse even using the module syntax!

% 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
% tree from 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;
lisp;
load_package lalr;
on comp;

% When running using CSL arrange that errorset can never hide backtraces.
if getd 'enable!-errorset then enable!-errorset(3,3);

prec := '(
  !:left  "op"
  !:left  (!:infix9)
  !:right (!:infixr9)
  !:left  (!:infix8)
  !:right (!:infixr8)
  !:left  (!:infix7)
  !:left  ("*")       % because * is used in types too
  !:right (!:infixr7)
  !:left  (!:infix6)
  !:right (!:infixr6)
  !:left  (!:infix5)
  !:right (!:infixr5)
  !:left  ("=")       % because = used in many places as well as infix
  !:left  (!:infix4)
  !:right (!:infixr4)
  !:left  (!:infix3)
  !:right (!:infixr3)
  !:left  (!:infix2)
  !:right (!:infixr2)
  !:left  (!:infix1)
  !:right (!:infixr1)
  !:left  (!:infix0)
  !:right (!:infixr0)
  !:left  (":")
          ("->")
          ("andalso")
          ("orelse")
          ("handle")
          ("raise")
          ("else")
          ("do")
          ("|")
          ("of")
          ("fn")
          ("=>")
          ("as")
  )$

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);

fluid '(filestack);

symbolic procedure process u;
  begin
    scalar v;
    terpri();
    princ "Input: ";
    if u = !$eof!$ then printc "<EndOfFile>" else prettyprint u;
    if u = !$eof!$ then <<
      if null filestack then error(1, "Unexpected end of file");
      close rds car filestack;
      printc "End of file - returning to previous file";
      filestack := cdr filestack;
% Almost unreasonably I MUST sort of fake in a semicolon where I
% switch files...
      lex_char := '!;;
      lex_peek_char := nil >>
    else if eqcar(u, 'use) then <<
      u := cadr u;
      v := open(u, 'input);
      if null v then error(1, list("file", u, "could not be opened"));
      princ "+++ Reading from file "; print u;
      which_line := 1;
      if_depth := 0;
      for i := 0:63 do putv(last64, i, nil);
      last64p := 0;
      lex_char := '!;;
      lex_peek_char := nil;
      filestack := rds v . filestack >>
  end;

fluid '(lexer_context context_stack);

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
% Allow for multiple declarations in one.
    if not atom id then <<
      for each x in id do makeinfix(x, prec, dirn);
      return nil >>;
    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 nil
  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 printf("+++ Unknown context save: %p%n", p);
    lexer_context := car context_stack;
    context_stack := cdr context_stack;
  end;

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

% 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 and return to using Reduce on
% an outer file... ie so that parsed and regular Reduce stuff are kept
% more separate.

on parse_errors_fatal;

% The grammar used here is derived from one found at
%    https://www.mpi-sws.org/~rossberg/sml.html

% I am re-working the original grammar that I had here using information
% fron "The Definition of Standard ML (Revised)", 1997. At least that will
% be definitive! I hope it will let me get rid of syntactic ambiguity.

<< terpri(); lpri list("grammar has", length (grammar := '(

 (toplevel ((progs "EOF")))

 (progs    ((prog) (process !$1))
           ((exp) (process !$1))
           ((progs prog) (process !$2))
           ((progs !:eof) (process !$eof!$)))

% 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))      % Note that lexer deals with "~1" for negative
         (("#" !:string))  % character literal
         ((!:string)))

 (digit  ((!:number)))

% I have changed the lexer so that aaa.bbb.ccc lexes as a single symbol.
% that means that I do not have any concept of "long id" here. That
% may simplify some matters, but if I implemented a full module system I
% would then need to dive inside ids that happened to be long to extract
% information about them.

 (lab    ((!:symbol))
         ((!:number)))

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

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

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

 (id_with_op
         ((!:symbol) !$1)
         (("op" opname) !$2))

% 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 noted as a dipthong
% the initial "-" will also be given its own lexer code... so I need to
% list initial substrings of any dipthong here. In most cases the token
% will start off as amere !:symbol items, but ones that I will map onto
% custom Lisp names are best noted explicitly here I think.

 (opname  ((!:symbol))
          (("*"))
          (("/"))
          (("%"))
          (("+"))
          (("-"))
          ((":"))
          (("::"))
          (("="))
          (("<"))
          (("<="))
          ((">"))
          ((">="))
          (("<>"))
          ((":="))
          ((!:infix0))
          ((!:infix1))
          ((!:infix2))
          ((!:infix3))
          ((!:infix4))
          ((!:infix5))
          ((!:infix6))
          ((!:infix7))
          ((!:infix8))
          ((!:infix9))
          ((!:infixr0))
          ((!:infixr1))
          ((!:infixr2))
          ((!:infixr3))
          ((!:infixr4))
          ((!:infixr5))
          ((!:infixr6))
          ((!:infixr7))
          ((!:infixr8))
          ((!:infixr9)))

 (opnames (((plus opname))))

 (emptylist (("[" "]")))

 (unit   (("(" ")")))

 (atexp  ((con))
         ((id_with_op) !$1)
         (("{" exprow "}"))
         (("#" lab))
         ((unit))                            % Unit
         (("(" exp "," tupletail))           % A tuple
         ((emptylist) 'empty_list)           % Empty list
         (("[" exp "]") (list 'list !$2))    % List of length 1
         (("[" exp "," listtail))            % Longer list
         (("(" exp ";" seqtail))             % Sequence
         ((letid dec "in" seqexps endid))
         (("(" exp ")") !$2))                % Mere parentheses

 (appexp ((atexp))
         ((appexp atexp)))

 (infexp ((appexp))
         ((infexp !:infix0 infexp) (list (get !$2 'lisp_name) !$1 !$3))
         ((infexp !:infix1 infexp) (list (get !$2 'lisp_name) !$1 !$3))
         ((infexp !:infix2 infexp) (list (get !$2 'lisp_name) !$1 !$3))
         ((infexp !:infix3 infexp) (list (get !$2 'lisp_name) !$1 !$3))
         ((infexp !:infix4 infexp) (list (get !$2 'lisp_name) !$1 !$3))
         ((infexp "=" infexp) (list 'equal !$1 !$3))
         ((infexp !:infix5 infexp) (list (get !$2 'lisp_name) !$1 !$3))
         ((infexp !:infix6 infexp) (list (get !$2 'lisp_name) !$1 !$3))
         ((infexp !:infix7 infexp) (list (get !$2 'lisp_name) !$1 !$3))
         ((infexp "*" infexp) (list 'times !$1 !$3))
         ((infexp !:infix8 infexp) (list (get !$2 'lisp_name) !$1 !$3))
         ((infexp !:infix9 infexp) (list (get !$2 'lisp_name) !$1 !$3))
         ((infexp !:infixr0 infexp) (list (get !$2 'lisp_name) !$1 !$3))
         ((infexp !:infixr1 infexp) (list (get !$2 'lisp_name) !$1 !$3))
         ((infexp !:infixr2 infexp) (list (get !$2 'lisp_name) !$1 !$3))
         ((infexp !:infixr3 infexp) (list (get !$2 'lisp_name) !$1 !$3))
         ((infexp !:infixr4 infexp) (list (get !$2 'lisp_name) !$1 !$3))
         ((infexp !:infixr5 infexp) (list (get !$2 'lisp_name) !$1 !$3))
         ((infexp !:infixr6 infexp) (list (get !$2 'lisp_name) !$1 !$3))
         ((infexp !:infixr7 infexp) (list (get !$2 'lisp_name) !$1 !$3))
         ((infexp !:infixr8 infexp) (list (get !$2 'lisp_name) !$1 !$3))
         ((infexp !:infixr9 infexp) (list (get !$2 'lisp_name) !$1 !$3))
         )

% I first look at the grammar as given in the specification, and note
% two particular messy cases which have to be reolved by a from of
% precedence.
%     if A then B else C handle ...
% must lead to a shift rather than a reduce. This case can be covered to
% giving HANDLE and ELSE precedence settings. Indeed I hope that by
% giving most of the keywords used here precedence values the apparent
% ambiguities can all be resolved.

 (exp    ((infexp))
         ((exp ":" typ))
         ((exp "andalso" exp) (list 'and !$1 !$3))
         ((exp "orelse" exp) (list 'or !$1 !$3))
         ((exp "handle" match))
         (("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))
         )

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

 (seqexps((exp))
         ((seqexps ";" exp)))

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

 (match  ((onematch) !$1)
         ((match "|" onematch)))

 (tracedpat ((pat) !$1))

 (onematch ((tracedpat "=>" exp)))

 (pat1   ((atpat))
         ((id_with_op atpat))
         ((pat1 !:infix0 pat1) (list (get !$2 'lisp_name) !$1 !$3))
         ((pat1 !:infix1 pat1) (list (get !$2 'lisp_name) !$1 !$3))
         ((pat1 !:infix2 pat1) (list (get !$2 'lisp_name) !$1 !$3))
         ((pat1 !:infix3 pat1) (list (get !$2 'lisp_name) !$1 !$3))
         ((pat1 !:infix4 pat1) (list (get !$2 'lisp_name) !$1 !$3))
% The rules of ML are that "=" may not be re-bound, and hence it can
% not end up as a constructor. Specifically that means it can not end
% up in use as as infix constructor in a patten.
% I will leave the syntax rule in here but commented out mostly so that
%  divergence between the rules here for patterns and the mostly matching
%  ones for expressions can be compared.
%        ((pat1 "=" pat1) (list 'equal !$1 !$3))
         ((pat1 !:infix5 pat1) (list (get !$2 'lisp_name) !$1 !$3))
         ((pat1 !:infix6 pat1) (list (get !$2 'lisp_name) !$1 !$3))
         ((pat1 !:infix7 pat1) (list (get !$2 'lisp_name) !$1 !$3))
         ((pat1 "*" pat1) (list 'times !$1 !$3))
         ((pat1 !:infix8 pat1) (list (get !$2 'lisp_name) !$1 !$3))
         ((pat1 !:infix9 pat1) (list (get !$2 'lisp_name) !$1 !$3))
         ((pat1 !:infixr0 pat1) (list (get !$2 'lisp_name) !$1 !$3))
         ((pat1 !:infixr1 pat1) (list (get !$2 'lisp_name) !$1 !$3))
         ((pat1 !:infixr2 pat1) (list (get !$2 'lisp_name) !$1 !$3))
         ((pat1 !:infixr3 pat1) (list (get !$2 'lisp_name) !$1 !$3))
         ((pat1 !:infixr4 pat1) (list (get !$2 'lisp_name) !$1 !$3))
         ((pat1 !:infixr5 pat1) (list (get !$2 'lisp_name) !$1 !$3))
         ((pat1 !:infixr6 pat1) (list (get !$2 'lisp_name) !$1 !$3))
         ((pat1 !:infixr7 pat1) (list (get !$2 'lisp_name) !$1 !$3))
         ((pat1 !:infixr8 pat1) (list (get !$2 'lisp_name) !$1 !$3))
         ((pat1 !:infixr9 pat1) (list (get !$2 'lisp_name) !$1 !$3))
         ((id_with_op "as" pat1))
         )

 (pat    ((pat1))
         ((pat ":" typ))
% This rule is over-generous, in that the only case actually allowed
% is '["op"] id ":" typ "as" pat1' but then if you see an identifier x
% followed by a colon you know you next have to read a type, but until
% you have looked way forward to see if the word "as" is coming you can not
% be certain if the identifier should be reduced all the way to pat before
% having the type attached.

         ((pat ":" typ "as" pat1))
         )

 (opttyp (())
         ((":" typ)))

 (atpat  ((con) !$1)
         (("_"))
         ((id_with_op) !$1)
         (("{" patrow "}"))
         ((unit))
         ((emptylist))
         (("[" patseq "]"))
         (("(" patseq ")")))

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

 (patrow (("..."))
         ((lab "=" pat optmorepatrow))
         ((!:symbol opttyp (opt "as" pat) optmorepatrow)))

 (optmorepatrow (())
         (("," patrow)))

 (tyseq  ((typ))
         ((typ "," tyseq)))

 (attyp  ((!:typename))
         (("{" typrow "}"))
         (("(" typ ")"))
         ((!:symbol)))

 (typ1   ((attyp))
         ((typ1 !:symbol))
         (("(" typ "," tyseq ")" !:symbol))
         )

 (typ2   ((typ1))
         ((typ2 "*" typ1))
         )

 (typ3   ((typ2))
         ((typ2 "->" typ3)))

 (typ    ((typ3))
         )

 (labtyp ((lab ":" typ)))

 (typrow ((labtyp))
         ((typrow "," labtyp)))

 (tyvarseq
         ((!:typename))
         (("(" tvs2 ")")))

 (tvs2   ((!:typename))
         ((tvs2 "," !:typename)))

 (symbols ((!:symbol))
         ((symbols !:symbol)))

 (dec1   (("val" valbind))
         (("val" tyvarseq valbind))
         (("fun" fvalbind))
         (("fun" tyvarseq fvalbind))
         (("type" typbind))
         (("datatype" datbind))
         (("datatype" datbind "withtype" typbind))
         (("datatype" !:symbol "-=-" "datatype" !:symbol))
         (("abstype" datbind "with" dec "end"))
         (("abstype" datbind "withtype" typbind "with" dec "end"))
         (("exception" exnbind))
         ((localid dec "in" dec endid))
         (("open" symbols))
         (("structure" strbind))
         (("nonfix" opnames) (makeinfix !$2 0 'none))
         (("infix" opnames) (makeinfix !$2 0 'left))
         (("infix" digit opnames) (makeinfix !$3 !$2 'left))
         (("infixr" opnames) (makeinfix !$2 0 'right))
         (("infixr" digit opnames) (makeinfix !$3 !$2 'right))
         )

 (dec    ((dec1))
         ((dec dec1))
         ((dec ";" dec1)))

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

 (fvalbind ((nfvalbindings (opt "and" fvalbind))))

 (nfvalbindings ((onefvalbinding))
           ((nfvalbindings "|" onefvalbinding)))

 (onefvalbinding
          ((id_with_op (plus atpat) opttyp "=" exp)))

 (typbind  ((!:symbol "=" typ (opt "and" typbind)))
           ((tyvarseq !:symbol "=" typ (opt "and" typbind))))

 (datbind  ((!:symbol "=" conbind (opt "and" datbind)))
           ((tyvarseq !:symbol "=" conbind (opt "and" datbind))))

 (optoftyp (())
           (("of" typ)))

 (conbind  ((id_with_op optoftyp (opt "|" conbind))))

 (optandexnbind
           (())
           (("and" exnbind)))

 (exnbind  ((id_with_op optoftyp optandexnbind))
           ((id_with_op "=" !:symbol optandexnbind)))

 (onestrbind ((!:symbol "=" strexp))
           ((!:symbol ":" sigexp "=" strexp))
           ((!:symbol ":>" sigexp "=" strexp))
           )

 (strbind  ((onestrbind))
           ((strbind "and" onestrbind)))

 (strexp   ((structid dec endid))
           ((!:symbol))
           ((strexp ":" sigexp))
           ((strexp ":>" sigexp))
           ((!:symbol "(" strexp ")"))
           ((!:symbol "(" dec ")"))
           ((letid dec "in" strexp endid))
           )

 (structid (("struct") (startcontext)))

 (sigexp  ((sigid spec endid))
          ((!:symbol))
          ((sigexp "where" "type" !:symbol "=" typ))
          ((sigexp "where" "type" tyvarseq !:symbol "=" typ))
          )

 (sigid   (("sig") (startcontext)))

 (sigdec  (("signature" sigbind)))

 (sigbind ((!:symbol "=" sigexp (opt "and" sigbind))))

 (onespec (("val" valdesc))
          (("type" typdesc))
          (("eqtype" typdesc))
          (("datatype" datdesc))
          (("datatype" !:symbol "-=-" "datatype" !:symbol))
          (("exception" exdesc))
          (("structure" strdesc))
          (("include" sigexp))
          )

 (spec    ((onespec))
          ((spec ";" onespec))
          ((spec onespec))
          ((spec "sharing" "type" !:symbol eqsymlist))
          )

 (fundec  (("functor" funbind)))

 (onefunbind ((!:symbol "(" !:symbol ":" sigexp ")" "=" strexp))
          ((!:symbol "(" !:symbol ":" sigexp ")" ":" sigexp "=" strexp))
          ((!:symbol "(" !:symbol ":" sigexp ")" ":>" sigexp "=" strexp))
          ((!:symbol "(" spec ")" ":" sigexp "=" strexp))
          ((!:symbol "(" spec ")" ":>" sigexp "=" strexp))
          )

 (funbind  ((onefunbind))
           ((funbind "and" onefunbind)))

 (eqsymlist (("=" !:symbol))
          ((eqsymlist "=" !:symbol)))

 (valdesc ((!:symbol ":" typ (opt "and" valdesc))))

 (onetypdesc ((!:symbol))
          ((tyvarseq !:symbol)))

 (typdesc ((onetypdesc))
          ((typdesc "and" onetypdesc))
          )

 (onedatdesc ((!:symbol "=" condesc))
          ((tyvarseq !:symbol "=" condesc)))

 (datdesc ((onedatdesc))
          ((datdesc "and" onedatdesc)))

 (condesc ((!:symbol (opt "of" typ) (opt "|" condesc))))

 (exdesc  ((!:symbol (opt "of" typ) (opt "and" exdesc))))

 (strdesc ((!:symbol ":" sigexp))
          ((!:symbol ":" sigexp "and" strdesc)))

% The syntax that I started from did not include the possibility of an
% expression here. That sort of makes sense because consider
%   fun foo f = f
%   22;
% which could (potentially) either parse as a function definition followed
% by an expression or as a function definition with RHS "f 22". To try to
% avoid this ambiguity I am going to insist that there be (at least one)
% semicolon ahead of any expression to separate it from the previous
% input.
% This is much like the need for a semicolon if one wrote
%   1+2
%   3+4;
% to avoid that being parse as something that wanted to use 2 as a function
% applied to the argument 3. I rather hope that all declarations start with
% keywords and so the issue of where one endsd and the next starts will
% not be a severe problem.

(prog     ((dec1))
          ((";" exp) !$2)
          ((";") nil)
          ((fundec))
          ((sigdec))
          )

  )), "clauses") >>;

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

% This will tend to lead to a LOT of output - much of which will be hard to
% decode. But while debugging the grammar it may be necessary.
% on lalr_verbose;

%@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

pp := lalr_create_parser(prec, grammar)$

%@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

begin
   scalar !*raise, !*lower;
   lex_init();
   yyparse pp
end;

use "Library_Reduce.sml";

(* I will often put test fragments of code here to see if I can
   parse them - and then later on so I can adjust the generated parse trees
   until they are reasonably Lisp-like. *)

;

(*
 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
;
quit;

% 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
% tree from 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;
lisp;
load_package lalr;
on comp;

% When running using CSL arrange that errorset can never hide backtraces.
if getd 'enable!-errorset then enable!-errorset(3,3);

prec := '(
  !:left  "op"
  !:left  (!:infix9)
  !:right (!:infixr9)
  !:left  (!:infix8)
  !:right (!:infixr8)
  !:left  (!:infix7)
  !:left  ("*")       % because * is used in types too
  !:right (!:infixr7)
  !:left  (!:infix6)
  !:right (!:infixr6)
  !:left  (!:infix5)
  !:right (!:infixr5)
  !:left  ("=")       % because = used in many places as well as infix
  !:left  (!:infix4)
  !:right (!:infixr4)
  !:left  (!:infix3)
  !:right (!:infixr3)
  !:left  (!:infix2)
  !:right (!:infixr2)
  !:left  (!:infix1)
  !:right (!:infixr1)
  !:left  (!:infix0)
  !:right (!:infixr0)
  !:left  (":")
          ("->")
          ("andalso")
          ("orelse")
          ("handle")
          ("raise")
          ("else")
          ("do")
          ("|")
          ("of")
          ("fn")
          ("=>")
          ("as")
  )$

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);

fluid '(filestack);

symbolic procedure process u;
  begin
    scalar v;
    terpri();
    princ "Input: ";
    if u = !$eof!$ then printc "<EndOfFile>" else prettyprint u;
    if u = !$eof!$ then <<
      if null filestack then error(1, "Unexpected end of file");
      close rds car filestack;
      printc "End of file - returning to previous file";
      filestack := cdr filestack;
% Almost unreasonably I MUST sort of fake in a semicolon where I
% switch files...
      lex_char := '!;;
      lex_peek_char := nil >>
    else if eqcar(u, 'use) then <<
      u := cadr u;
      v := open(u, 'input);
      if null v then error(1, list("file", u, "could not be opened"));
      princ "+++ Reading from file "; print u;
      which_line := 1;
      if_depth := 0;
      for i := 0:63 do putv(last64, i, nil);
      last64p := 0;
      lex_char := '!;;
      lex_peek_char := nil;
      filestack := rds v . filestack >>
  end;

fluid '(lexer_context context_stack);

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
% Allow for multiple declarations in one.
    if not atom id then <<
      for each x in id do makeinfix(x, prec, dirn);
      return nil >>;
    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 nil
  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 printf("+++ Unknown context save: %p%n", p);
    lexer_context := car context_stack;
    context_stack := cdr context_stack;
  end;

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

% 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 and return to using Reduce on
% an outer file... ie so that parsed and regular Reduce stuff are kept
% more separate.

on parse_errors_fatal;

% The grammar used here is derived from one found at
%    https://www.mpi-sws.org/~rossberg/sml.html

% I am re-working the original grammar that I had here using information
% fron "The Definition of Standard ML (Revised)", 1997. At least that will
% be definitive! I hope it will let me get rid of syntactic ambiguity.

<< terpri(); lpri list("grammar has", length (grammar := '(

 (toplevel ((progs "EOF")))

 (progs    ((prog) (process !$1))
           ((exp) (process !$1))
           ((progs prog) (process !$2))
           ((progs !:eof) (process !$eof!$)))

% 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))      % Note that lexer deals with "~1" for negative
         (("#" !:string))  % character literal
         ((!:string)))

 (digit  ((!:number)))

% I have changed the lexer so that aaa.bbb.ccc lexes as a single symbol.
% that means that I do not have any concept of "long id" here. That
% may simplify some matters, but if I implemented a full module system I
% would then need to dive inside ids that happened to be long to extract
% information about them.

 (lab    ((!:symbol))
         ((!:number)))

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

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

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

 (id_with_op
         ((!:symbol) !$1)
         (("op" opname) !$2))

% 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 noted as a dipthong
% the initial "-" will also be given its own lexer code... so I need to
% list initial substrings of any dipthong here. In most cases the token
% will start off as amere !:symbol items, but ones that I will map onto
% custom Lisp names are best noted explicitly here I think.

 (opname  ((!:symbol))
          (("*"))
          (("/"))
          (("%"))
          (("+"))
          (("-"))
          ((":"))
          (("::"))
          (("="))
          (("<"))
          (("<="))
          ((">"))
          ((">="))
          (("<>"))
          ((":="))
          ((!:infix0))
          ((!:infix1))
          ((!:infix2))
          ((!:infix3))
          ((!:infix4))
          ((!:infix5))
          ((!:infix6))
          ((!:infix7))
          ((!:infix8))
          ((!:infix9))
          ((!:infixr0))
          ((!:infixr1))
          ((!:infixr2))
          ((!:infixr3))
          ((!:infixr4))
          ((!:infixr5))
          ((!:infixr6))
          ((!:infixr7))
          ((!:infixr8))
          ((!:infixr9)))

 (opnames (((plus opname))))

 (emptylist (("[" "]")))

 (unit   (("(" ")")))

 (atexp  ((con))
         ((id_with_op) !$1)
         (("{" exprow "}"))
         (("#" lab))
         ((unit))                            % Unit
         (("(" exp "," tupletail))           % A tuple
         ((emptylist) 'empty_list)           % Empty list
         (("[" exp "]") (list 'list !$2))    % List of length 1
         (("[" exp "," listtail))            % Longer list
         (("(" exp ";" seqtail))             % Sequence
         ((letid dec "in" seqexps endid))
         (("(" exp ")") !$2))                % Mere parentheses

 (appexp ((atexp))
         ((appexp atexp)))

 (infexp ((appexp))
         ((infexp !:infix0 infexp) (list (get !$2 'lisp_name) !$1 !$3))
         ((infexp !:infix1 infexp) (list (get !$2 'lisp_name) !$1 !$3))
         ((infexp !:infix2 infexp) (list (get !$2 'lisp_name) !$1 !$3))
         ((infexp !:infix3 infexp) (list (get !$2 'lisp_name) !$1 !$3))
         ((infexp !:infix4 infexp) (list (get !$2 'lisp_name) !$1 !$3))
         ((infexp "=" infexp) (list 'equal !$1 !$3))
         ((infexp !:infix5 infexp) (list (get !$2 'lisp_name) !$1 !$3))
         ((infexp !:infix6 infexp) (list (get !$2 'lisp_name) !$1 !$3))
         ((infexp !:infix7 infexp) (list (get !$2 'lisp_name) !$1 !$3))
         ((infexp "*" infexp) (list 'times !$1 !$3))
         ((infexp !:infix8 infexp) (list (get !$2 'lisp_name) !$1 !$3))
         ((infexp !:infix9 infexp) (list (get !$2 'lisp_name) !$1 !$3))
         ((infexp !:infixr0 infexp) (list (get !$2 'lisp_name) !$1 !$3))
         ((infexp !:infixr1 infexp) (list (get !$2 'lisp_name) !$1 !$3))
         ((infexp !:infixr2 infexp) (list (get !$2 'lisp_name) !$1 !$3))
         ((infexp !:infixr3 infexp) (list (get !$2 'lisp_name) !$1 !$3))
         ((infexp !:infixr4 infexp) (list (get !$2 'lisp_name) !$1 !$3))
         ((infexp !:infixr5 infexp) (list (get !$2 'lisp_name) !$1 !$3))
         ((infexp !:infixr6 infexp) (list (get !$2 'lisp_name) !$1 !$3))
         ((infexp !:infixr7 infexp) (list (get !$2 'lisp_name) !$1 !$3))
         ((infexp !:infixr8 infexp) (list (get !$2 'lisp_name) !$1 !$3))
         ((infexp !:infixr9 infexp) (list (get !$2 'lisp_name) !$1 !$3))
         )

% I first look at the grammar as given in the specification, and note
% two particular messy cases which have to be reolved by a from of
% precedence.
%     if A then B else C handle ...
% must lead to a shift rather than a reduce. This case can be covered to
% giving HANDLE and ELSE precedence settings. Indeed I hope that by
% giving most of the keywords used here precedence values the apparent
% ambiguities can all be resolved.

 (exp    ((infexp))
         ((exp ":" typ))
         ((exp "andalso" exp) (list 'and !$1 !$3))
         ((exp "orelse" exp) (list 'or !$1 !$3))
         ((exp "handle" match))
         (("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))
         )

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

 (seqexps((exp))
         ((seqexps ";" exp)))

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

 (match  ((onematch) !$1)
         ((match "|" onematch)))

 (tracedpat ((pat) !$1))

 (onematch ((tracedpat "=>" exp)))

 (pat1   ((atpat))
         ((id_with_op atpat))
         ((pat1 !:infix0 pat1) (list (get !$2 'lisp_name) !$1 !$3))
         ((pat1 !:infix1 pat1) (list (get !$2 'lisp_name) !$1 !$3))
         ((pat1 !:infix2 pat1) (list (get !$2 'lisp_name) !$1 !$3))
         ((pat1 !:infix3 pat1) (list (get !$2 'lisp_name) !$1 !$3))
         ((pat1 !:infix4 pat1) (list (get !$2 'lisp_name) !$1 !$3))
% The rules of ML are that "=" may not be re-bound, and hence it can
% not end up as a constructor. Specifically that means it can not end
% up in use as as infix constructor in a patten.
% I will leave the syntax rule in here but commented out mostly so that
%  divergence between the rules here for patterns and the mostly matching
%  ones for expressions can be compared.
%        ((pat1 "=" pat1) (list 'equal !$1 !$3))
         ((pat1 !:infix5 pat1) (list (get !$2 'lisp_name) !$1 !$3))
         ((pat1 !:infix6 pat1) (list (get !$2 'lisp_name) !$1 !$3))
         ((pat1 !:infix7 pat1) (list (get !$2 'lisp_name) !$1 !$3))
         ((pat1 "*" pat1) (list 'times !$1 !$3))
         ((pat1 !:infix8 pat1) (list (get !$2 'lisp_name) !$1 !$3))
         ((pat1 !:infix9 pat1) (list (get !$2 'lisp_name) !$1 !$3))
         ((pat1 !:infixr0 pat1) (list (get !$2 'lisp_name) !$1 !$3))
         ((pat1 !:infixr1 pat1) (list (get !$2 'lisp_name) !$1 !$3))
         ((pat1 !:infixr2 pat1) (list (get !$2 'lisp_name) !$1 !$3))
         ((pat1 !:infixr3 pat1) (list (get !$2 'lisp_name) !$1 !$3))
         ((pat1 !:infixr4 pat1) (list (get !$2 'lisp_name) !$1 !$3))
         ((pat1 !:infixr5 pat1) (list (get !$2 'lisp_name) !$1 !$3))
         ((pat1 !:infixr6 pat1) (list (get !$2 'lisp_name) !$1 !$3))
         ((pat1 !:infixr7 pat1) (list (get !$2 'lisp_name) !$1 !$3))
         ((pat1 !:infixr8 pat1) (list (get !$2 'lisp_name) !$1 !$3))
         ((pat1 !:infixr9 pat1) (list (get !$2 'lisp_name) !$1 !$3))
         ((id_with_op "as" pat1))
         )

 (pat    ((pat1))
         ((pat ":" typ))
% This rule is over-generous, in that the only case actually allowed
% is '["op"] id ":" typ "as" pat1' but then if you see an identifier x
% followed by a colon you know you next have to read a type, but until
% you have looked way forward to see if the word "as" is coming you can not
% be certain if the identifier should be reduced all the way to pat before
% having the type attached.

         ((pat ":" typ "as" pat1))
         )

 (opttyp (())
         ((":" typ)))

 (atpat  ((con) !$1)
         (("_"))
         ((id_with_op) !$1)
         (("{" patrow "}"))
         ((unit))
         ((emptylist))
         (("[" patseq "]"))
         (("(" patseq ")")))

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

 (patrow (("..."))
         ((lab "=" pat optmorepatrow))
         ((!:symbol opttyp (opt "as" pat) optmorepatrow)))

 (optmorepatrow (())
         (("," patrow)))

 (tyseq  ((typ))
         ((typ "," tyseq)))

 (attyp  ((!:typename))
         (("{" typrow "}"))
         (("(" typ ")"))
         ((!:symbol)))

 (typ1   ((attyp))
         ((typ1 !:symbol))
         (("(" typ "," tyseq ")" !:symbol))
         )

 (typ2   ((typ1))
         ((typ2 "*" typ1))
         )

 (typ3   ((typ2))
         ((typ2 "->" typ3)))

 (typ    ((typ3))
         )

 (labtyp ((lab ":" typ)))

 (typrow ((labtyp))
         ((typrow "," labtyp)))

 (tyvarseq
         ((!:typename))
         (("(" tvs2 ")")))

 (tvs2   ((!:typename))
         ((tvs2 "," !:typename)))

 (symbols ((!:symbol))
         ((symbols !:symbol)))

 (dec1   (("val" valbind))
         (("val" tyvarseq valbind))
         (("fun" fvalbind))
         (("fun" tyvarseq fvalbind))
         (("type" typbind))
         (("datatype" datbind))
         (("datatype" datbind "withtype" typbind))
         (("datatype" !:symbol "-=-" "datatype" !:symbol))
         (("abstype" datbind "with" dec "end"))
         (("abstype" datbind "withtype" typbind "with" dec "end"))
         (("exception" exnbind))
         ((localid dec "in" dec endid))
         (("open" symbols))
         (("structure" strbind))
         (("nonfix" opnames) (makeinfix !$2 0 'none))
         (("infix" opnames) (makeinfix !$2 0 'left))
         (("infix" digit opnames) (makeinfix !$3 !$2 'left))
         (("infixr" opnames) (makeinfix !$2 0 'right))
         (("infixr" digit opnames) (makeinfix !$3 !$2 'right))
         )

 (dec    ((dec1))
         ((dec dec1))
         ((dec ";" dec1)))

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

 (fvalbind ((nfvalbindings (opt "and" fvalbind))))

 (nfvalbindings ((onefvalbinding))
           ((nfvalbindings "|" onefvalbinding)))

 (onefvalbinding
          ((id_with_op (plus atpat) opttyp "=" exp)))

 (typbind  ((!:symbol "=" typ (opt "and" typbind)))
           ((tyvarseq !:symbol "=" typ (opt "and" typbind))))

 (datbind  ((!:symbol "=" conbind (opt "and" datbind)))
           ((tyvarseq !:symbol "=" conbind (opt "and" datbind))))

 (optoftyp (())
           (("of" typ)))

 (conbind  ((id_with_op optoftyp (opt "|" conbind))))

 (optandexnbind
           (())
           (("and" exnbind)))

 (exnbind  ((id_with_op optoftyp optandexnbind))
           ((id_with_op "=" !:symbol optandexnbind)))

 (strbind  ((!:symbol "=" strexp (opt "and" strbind))))

 (strexp   ((structid dec endid))
           ((!:symbol))
           ((strexp ":" sigexp))
           ((strexp ":>" sigexp))
           ((!:symbol "(" strexp ")"))
           ((letid dec "in" strexp endid))
           )

 (structid (("struct") (startcontext)))

 (sigexp  ((sigid spec endid))
          ((!:symbol))
          ((sigexp "where" "type" tyvarseq !:symbol "=" typ))
          )

 (sigid   (("struct") (startcontext)))

 (sigdec  (("signature" sigbind)))

 (sigbind ((!:symbol "=" sigexp (opt "and" sigbind))))

 (onespec (("val" valdesc))
          (("type" typdesc))
          (("eqtype" typdesc))
          (("datatype" datdesc))
          (("datatype" !:symbol "-=-" "datatype" !:symbol))
          (("exception" exdesc))
          (("structure" strdesc))
          (("include" sigexp))
          )

 (spec    ((onespec))
          ((spec ";" onespec))
          ((spec onespec))
          ((spec "sharing" "type" !:symbol eqsymlist))
          )

 (fundec  (("functor" funbind)))

 (funbind ((!:symbol "(" !:symbol ":" sigexp ")" "=" strexp
           (opt "and" funbind))))

 (eqsymlist (("=" !:symbol))
          ((eqsymlist "=" !:symbol)))

 (valdesc ((!:symbol ":" typ (opt "and" valdesc))))

 (typdesc ((tyvarseq !:symbol (opt "and" typdesc))))

 (datdesc ((tyvarseq !:symbol "=" condesc (opt "and" datdesc))))

 (condesc ((!:symbol (opt "of" typ) (opt "|" condesc))))

 (exdesc  ((!:symbol (opt "of" typ) (opt "and" exdesc))))

 (strdesc ((!:symbol ":" sigexp (opt "and" strdesc))))

% The syntax that I started from did not include the possibility of an
% expression here. That sort of makes sense because consider
%   fun foo f = f
%   22;
% which could (potentially) either parse as a function definition followed
% by an expression or as a function definition with RHS "f 22". To try to
% avoid this ambiguity I am going to insist that there be (at least one)
% semicolon ahead of any expression to separate it from the previous
% input.
% This is much like the need for a semicolon if one wrote
%   1+2
%   3+4;
% to avoid that being parse as something that wanted to use 2 as a function
% applied to the argument 3. I rather hope that all declarations start with
% keywords and so the issue of where one endsd and the next starts will
% not be a severe problem.

(prog     ((dec1))
          ((";" exp) !$2)
          ((";") nil)
          ((fundec))
          ((sigdec))
          )

  )), "clauses") >>;

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

% This will tend to lead to a LOT of output - much of which will be hard to
% decode. But while debugging the grammar it may be necessary.
% on lalr_verbose;

%@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

pp := lalr_create_parser(prec, grammar)$

%@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

begin
   scalar !*raise, !*lower;
   lex_init();
   yyparse pp
end;

use "Library_Reduce.sml";

(* I will often put test fragments of code here to see if I can
   parse them - and then later on so I can adjust the generated parse trees
   until they are reasonably Lisp-like. *)

;

(*
 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
;
quit;


FIX: issue #525 (Tokeniser chokes on multi-line curlies). FIX: new fix for issue #522.

Red/System [
	Title:   "Red data loader"
	Author:  "Nenad Rakocevic"
	File: 	 %tokenizer.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
	}
]

tokenizer: context [

	#define NOT_DELIMITER?(c) [
		all [
			c <> null-byte
			c <> #" "
			c <> #"/"
			c <> #"^/"
			c <> #"^M"
			c <> #"^-"
			c <> #":"
			c <> #"^""
			c <> #"["
			c <> #"]"
			c <> #"("
			c <> #")"
			c <> #"{"
			c <> #"}"
			c <> #";"
		]
	]

	#define NOT_FILE_DELIMITER?(c) [
		all [
			c <> null-byte
			c <> #" "
			c <> #"^/"
			c <> #"^M"
			c <> #"^-"
			c <> #":"
			c <> #"^""
			c <> #"["
			c <> #"]"
			c <> #"("
			c <> #")"
			c <> #"{"
			c <> #"}"
			c <> #";"
		]
	]

	#enum errors! [
		ERR_PREMATURE_END
		ERR_STRING_DELIMIT
		ERR_MULTI_STRING_DELIMIT
		ERR_CHAR_DELIMIT
		ERR_INVALID_INTEGER
		ERR_INVALID_PATH
		ERR_INVALID_CHAR
	]

	throw-error: func [id [integer!]][
		print "*** Load Error: "
		print switch id [
			ERR_PREMATURE_END		 ["unmatched ] closing bracket"]
			ERR_STRING_DELIMIT 		 [{string ending delimiter " not found}]
			ERR_MULTI_STRING_DELIMIT ["string ending delimiter } not found"]
			ERR_CHAR_DELIMIT		 [{char ending delimiter " not found}]
			ERR_INVALID_INTEGER		 ["invalid integer"]
			ERR_INVALID_PATH		 ["invalid path"]
			ERR_INVALID_CHAR		 ["invalid char"]
		]
		print-line #"!"
	]

	preprocess: func [
		str [red-string!]
		/local
			src	 [byte-ptr!]
			tail [byte-ptr!]
			dst	 [byte-ptr!]
			s	 [series!]
			c	 [byte!]
	][
		s: 		GET_BUFFER(str)
		src:	string/rs-head str
		tail:   string/rs-tail str
		dst:	src

		while [src < tail][
			either src/1 = #"^^" [
				src: src + 1
				c: src/1
				dst/1: switch c [
					#"-"	[#"^-"]
					#"/"	[#"^/"]
					#"^""	[#"^""]
					#"^^"	[#"^^"]
					default [src/1 - #"@"]
				]
			][
				if dst <> src [dst/1: src/1]
			]
			src: src + 1
			dst: dst + 1
		]
		dst/1: null-byte
		s/tail:	as red-value! dst
	]

	skip-spaces: func [
		src		[c-string!]
		return: [c-string!]
		/local
			c	[byte!]
	][
		while [
			c: src/1
			any [
				c = #" "
				c = #"^/"
				c = #"^M"
				c = #"^-"
			]
		][
			if c = null-byte [return src]
			src: src + 1
		]
		src
	]

	scan-comment: func [
		s		[c-string!]
		return: [c-string!]
	][
		while [not any [s/1 = #"^/" s/1 = null-byte]][s: s + 1]
		s
	]

	scan-char: func [
		s		[c-string!]
		blk		[red-block!]
		return: [c-string!]
		/local
			c	 [byte!]
			byte [byte!]
	][
		byte: either s/1 = #"^^" [
			s: s + 1
			c: s/1
			either all [#"@" <= c c <= #"Z"][
				c - #"@"
			][
				switch c [
					#"^"" [#"^""]
					#"/"  [#"^/"]
					#"-"  [#"^-"]
					#"?"  [#"^~"]
					#"^^" [#"^^"]
					default [throw-error ERR_INVALID_CHAR]
				]
			]
		][
			s/1
		]
		s: s + 1
		if s/1 <> #"^"" [throw-error ERR_CHAR_DELIMIT]

		char/load-in as-integer byte blk
		s + 1
	]

	scan-string-multi: func [
		s		[c-string!]
		blk		[red-block!]
		return: [c-string!]
		/local
			e	  [c-string!]
			c	  [byte!]
			saved [byte!]
			count [integer!]
	][
		s: s + 1										;-- skip opening brace
		e: s
		c: e/1
		count: 1

		while [all [c <> null-byte count > 0]][
			while [all [c <> null-byte c <> #"}"]][
				if c = #"{" [count: count + 1]
				e: e + either c = #"^^" [2][1]
				c: e/1
			]
			if c = #"}" [
				count: count - 1
				e: e + 1
				c: e/1
			]
		]
		e: e - 1
		c: e/1

		if c <> #"}" [throw-error ERR_MULTI_STRING_DELIMIT]
		saved: e/1										;@@ allocate a new buffer instead
		e/1: null-byte
		preprocess string/load-in s (as-integer e - s) + 1 blk
		e/1: saved
		either c = #"}" [e + 1][e]
	]

	scan-string: func [
		s		[c-string!]
		blk		[red-block!]
		return: [c-string!]
		/local
			e	  [c-string!]
			c	  [byte!]
			saved [byte!]
	][
		s: s + 1										;-- skip first double quote
		e: s
		c: e/1

		while [all [c <> null-byte c <> #"^""]][
			e: e + either c = #"^^" [2][1]
			c: e/1
		]
		if c <> #"^"" [throw-error ERR_STRING_DELIMIT]
		saved: e/1										;@@ allocate a new buffer instead
		e/1: null-byte
		preprocess string/load-in s (as-integer e - s) + 1 blk
		e/1: saved
		either c = #"^"" [e + 1][e]
	]

	scan-file: func [
		s		[c-string!]
		blk		[red-block!]
		return: [c-string!]
		/local
			e	  [c-string!]
			c	  [byte!]
			saved [byte!]
	][
		s: s + 1										;-- skip first double quote
		e: s
		c: e/1

		while [NOT_FILE_DELIMITER?(c)][
			e: e + 1
			c: e/1
		]
		saved: e/1										;@@ allocate a new buffer instead
		e/1: null-byte
		file/load-in s (as-integer e - s) + 1 blk
		e/1: saved
		e
	]

	scan-integer: func [
		s		 [c-string!]
		blk		 [red-block!]
		neg?	 [logic!]
		return:  [c-string!]
		/local
			e	 [c-string!]
			c	 [byte!]
			i	 [integer!]
	][
		e: s
		c: e/1
		i: 0

		while [
			all [c <> null-byte #"0" <= c c <= #"9"]
		][
			i: i * 10
			i: i + (c - #"0")
			e: e + 1
			c: e/1
		]
		if neg? [i: 0 - i]
		integer/load-in blk i
		e
	]

	scan-minus: func [
		src		[c-string!]
		blk		[red-block!]
		return:	[c-string!]
		/local
			c	[byte!]
	][
		c: src/2
		either all [#"0" <= c c <= #"9"][
			scan-integer src + 1 blk yes
		][
			scan-word src blk TYPE_WORD no
		]
	]

	scan-word: func [
		s		  [c-string!]
		blk		  [red-block!]
		type	  [integer!]
		in-path?  [logic!]
		return:   [c-string!]
		/local
			e	  [c-string!]
			c	  [byte!]
			saved [byte!]
			set?  [logic!]
			path? [logic!]
	][
		e: s + 1
		c: e/1

		while [NOT_DELIMITER?(c)][
			e: e + 1
			c: e/1
		]
		set?:  all [e/1 = #":"  not in-path?]
		path?: all [e/1 = slash not in-path?]

		if all [
			type = TYPE_REFINEMENT
			s + 1 = e
		][
			type: TYPE_WORD								;-- / as word case
		]

		either path? [
			return scan-path s e blk type = TYPE_LIT_WORD
		][
			saved: e/1										;@@ allocate a new buffer instead
			e/1: null-byte
			case [
				type = TYPE_GET_WORD	[get-word/load-in s blk]
				type = TYPE_LIT_WORD	[lit-word/load-in s blk]
				type = TYPE_ISSUE		[issue/load-in s blk]
				type = TYPE_REFINEMENT	[refinement/load-in s + 1 blk]
				set?				 	[set-word/load-in s blk]
				true				 	[word/load-in s blk]
			]
			e/1: saved
			return either set? [e + 1][e]
		]
	]

	scan-path: func [
		s		 [c-string!]
		src		 [c-string!]
		blk		 [red-block!]
		lit?	 [logic!]
		return:  [c-string!]
		/local
			path  [red-block!]
			saved [byte!]
			set?  [logic!]
	][
		path: block/make-in blk 4						;-- arbitrary start size

		saved: src/1									;-- push first element
		src/1: null-byte
		word/load-in s path								;-- store undecorated word
		src/1: saved
		c: src/1
		set?: no

		while [c = #"/"][
			src: src + 1
			c: src/1
			case [
				c = #"("  [src: scan-paren src + 1 path]
				c = #":"  [src: scan-word src + 1 path TYPE_GET_WORD yes]
				c = #"-"  [src: scan-minus src path]
				all [#"0" <= c c <= #"9"][src: scan-integer src path no]
				all [#" " <  c c <= #""][src: scan-word src path TYPE_WORD yes]
				yes [throw-error ERR_INVALID_PATH]
			]
			c: src/1
			if c = #":" [set?: yes]
		]

		path/header: case [
			set? [TYPE_SET_PATH]
			lit? [TYPE_LIT_PATH]
			true [TYPE_PATH]
		]
		either set? [src + 1][src]
	]

	scan-block: func [
		src		[c-string!]
		blk		[red-block!]
		return: [c-string!]
	][
		src: scan src block/make-in blk 4				;-- arbitrary start size
		src + 1											;-- skip ] character
	]

	scan-paren: func [
		src		 [c-string!]
		blk		 [red-block!]
		return:  [c-string!]
		/local
			s	 [series!]
			slot [red-value!]
	][
		src: scan src block/make-in blk 4				;-- arbitrary start size
		s: GET_BUFFER(blk)
		slot: s/tail - 1
		slot/header: TYPE_PAREN
		src + 1											;-- skip ) character

	]

	scan: func [
		src		  [c-string!]
		parent	  [red-block!]
		return:	  [c-string!]
		/local
			blk	  [red-block!]
			start [c-string!]
			end	  [c-string!]
			c	  [byte!]
	][
		blk: either null? parent [
			block/push* 4								;-- arbitrary start size
		][
			parent
		]

		while [
			src: skip-spaces src
			c: src/1
			all [
				c <> null-byte
				c <> #"]"
				c <> #")"
			]
		][
			case [
				c = #";"  [src: scan-comment src]
				c = #"-"  [src: scan-minus src blk]
				c = #"^"" [src: scan-string src blk]
				c = #"{"  [src: scan-string-multi src blk]
				c = #"%"  [src: scan-file src blk]
				c = #"["  [src: scan-block src + 1 blk]
				c = #"("  [src: scan-paren src + 1 blk]
				c = #":"  [src: scan-word src + 1 blk TYPE_GET_WORD no]
				c = #"'"  [src: scan-word src + 1 blk TYPE_LIT_WORD no]
				c = #"/"  [src: scan-word src blk TYPE_REFINEMENT no]
				c = #"#"  [
					c: src/2
					either c = #"^"" [
						src: scan-char src + 2 blk
					][
						src: scan-word src + 1 blk TYPE_ISSUE no
					]
				]
				all [#"0" <= c c <= #"9"][src: scan-integer src blk no]
				all [#" " <  c c <= #""][src: scan-word src blk TYPE_WORD no]
			]
		]
		if null? parent [
			if src/1 <> null-byte [throw-error ERR_PREMATURE_END]
			stack/set-last as red-value! blk
		]
		src
	]

]

Red/System [
	Title:   "Red data loader"
	Author:  "Nenad Rakocevic"
	File: 	 %tokenizer.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
	}
]

tokenizer: context [

	#define NOT_DELIMITER?(c) [
		all [
			c <> null-byte
			c <> #" "
			c <> #"/"
			c <> #"^/"
			c <> #"^M"
			c <> #"^-"
			c <> #":"
			c <> #"^""
			c <> #"["
			c <> #"]"
			c <> #"("
			c <> #")"
			c <> #"{"
			c <> #"}"
			c <> #";"
		]
	]

	#define NOT_FILE_DELIMITER?(c) [
		all [
			c <> null-byte
			c <> #" "
			c <> #"^/"
			c <> #"^M"
			c <> #"^-"
			c <> #":"
			c <> #"^""
			c <> #"["
			c <> #"]"
			c <> #"("
			c <> #")"
			c <> #"{"
			c <> #"}"
			c <> #";"
		]
	]

	#enum errors! [
		ERR_PREMATURE_END
		ERR_STRING_DELIMIT
		ERR_MULTI_STRING_DELIMIT
		ERR_CHAR_DELIMIT
		ERR_INVALID_INTEGER
		ERR_INVALID_PATH
		ERR_INVALID_CHAR
	]

	throw-error: func [id [integer!]][
		print "*** Load Error: "
		print switch id [
			ERR_PREMATURE_END		 ["unmatched ] closing bracket"]
			ERR_STRING_DELIMIT 		 [{string ending delimiter " not found}]
			ERR_MULTI_STRING_DELIMIT ["string ending delimiter } not found"]
			ERR_CHAR_DELIMIT		 [{char ending delimiter " not found}]
			ERR_INVALID_INTEGER		 ["invalid integer"]
			ERR_INVALID_PATH		 ["invalid path"]
			ERR_INVALID_CHAR		 ["invalid char"]
		]
		print-line #"!"
	]

	preprocess: func [
		str [red-string!]
		/local
			src	 [byte-ptr!]
			tail [byte-ptr!]
			dst	 [byte-ptr!]
			s	 [series!]
			c	 [byte!]
	][
		s: 		GET_BUFFER(str)
		src:	string/rs-head str
		tail:   string/rs-tail str
		dst:	src

		while [src < tail][
			either src/1 = #"^^" [
				src: src + 1
				c: src/1
				dst/1: switch c [
					#"-"	[#"^-"]
					#"/"	[#"^/"]
					#"^""	[#"^""]
					#"^^"	[#"^^"]
					default [src/1 - #"@"]
				]
			][
				if dst <> src [dst/1: src/1]
			]
			src: src + 1
			dst: dst + 1
		]
		dst/1: null-byte
		s/tail:	as red-value! dst
	]

	skip-spaces: func [
		src		[c-string!]
		return: [c-string!]
		/local
			c	[byte!]
	][
		while [
			c: src/1
			any [
				c = #" "
				c = #"^/"
				c = #"^M"
				c = #"^-"
			]
		][
			if c = null-byte [return src]
			src: src + 1
		]
		src
	]

	scan-comment: func [
		s		[c-string!]
		return: [c-string!]
	][
		while [not any [s/1 = #"^/" s/1 = null-byte]][s: s + 1]
		s
	]

	scan-char: func [
		s		[c-string!]
		blk		[red-block!]
		return: [c-string!]
		/local
			c	 [byte!]
			byte [byte!]
	][
		byte: either s/1 = #"^^" [
			s: s + 1
			c: s/1
			either all [#"@" <= c c <= #"Z"][
				c - #"@"
			][
				switch c [
					#"^"" [#"^""]
					#"/"  [#"^/"]
					#"-"  [#"^-"]
					#"?"  [#"^~"]
					#"^^" [#"^^"]
					default [throw-error ERR_INVALID_CHAR]
				]
			]
		][
			s/1
		]
		s: s + 1
		if s/1 <> #"^"" [throw-error ERR_CHAR_DELIMIT]

		char/load-in as-integer byte blk
		s + 1
	]

	scan-string-multi: func [
		s		[c-string!]
		blk		[red-block!]
		return: [c-string!]
		/local
			e	  [c-string!]
			c	  [byte!]
			saved [byte!]
			count [integer!]
	][
		s: s + 1										;-- skip opening brace
		e: s
		c: e/1
		count: 1

		while [all [c <> null-byte count > 0]][
			while [all [c <> null-byte c <> #"}"]][
				if c = #"{" [count: count + 1]
				e: e + either c = #"^^" [2][1]
				c: e/1
			]
			if c = #"}" [
				count: count - 1
				if e/2 <> null-byte [
					e: e + 1
					c: e/1
				]
			]
		]
		if c <> #"}" [throw-error ERR_MULTI_STRING_DELIMIT]
		saved: e/1										;@@ allocate a new buffer instead
		e/1: null-byte
		preprocess string/load-in s (as-integer e - s) + 1 blk
		e/1: saved
		either c = #"}" [e + 1][e]
	]

	scan-string: func [
		s		[c-string!]
		blk		[red-block!]
		return: [c-string!]
		/local
			e	  [c-string!]
			c	  [byte!]
			saved [byte!]
	][
		s: s + 1										;-- skip first double quote
		e: s
		c: e/1

		while [all [c <> null-byte c <> #"^""]][
			e: e + either c = #"^^" [2][1]
			c: e/1
		]
		if c <> #"^"" [throw-error ERR_STRING_DELIMIT]
		saved: e/1										;@@ allocate a new buffer instead
		e/1: null-byte
		preprocess string/load-in s (as-integer e - s) + 1 blk
		e/1: saved
		either c = #"^"" [e + 1][e]
	]

	scan-file: func [
		s		[c-string!]
		blk		[red-block!]
		return: [c-string!]
		/local
			e	  [c-string!]
			c	  [byte!]
			saved [byte!]
	][
		s: s + 1										;-- skip first double quote
		e: s
		c: e/1

		while [NOT_FILE_DELIMITER?(c)][
			e: e + 1
			c: e/1
		]
		saved: e/1										;@@ allocate a new buffer instead
		e/1: null-byte
		file/load-in s (as-integer e - s) + 1 blk
		e/1: saved
		e
	]

	scan-integer: func [
		s		 [c-string!]
		blk		 [red-block!]
		neg?	 [logic!]
		return:  [c-string!]
		/local
			e	 [c-string!]
			c	 [byte!]
			i	 [integer!]
	][
		e: s
		c: e/1
		i: 0

		while [
			all [c <> null-byte #"0" <= c c <= #"9"]
		][
			i: i * 10
			i: i + (c - #"0")
			e: e + 1
			c: e/1
		]
		if neg? [i: 0 - i]
		integer/load-in blk i
		e
	]

	scan-minus: func [
		src		[c-string!]
		blk		[red-block!]
		return:	[c-string!]
		/local
			c	[byte!]
	][
		c: src/2
		either all [#"0" <= c c <= #"9"][
			scan-integer src + 1 blk yes
		][
			scan-word src blk TYPE_WORD no
		]
	]

	scan-word: func [
		s		  [c-string!]
		blk		  [red-block!]
		type	  [integer!]
		in-path?  [logic!]
		return:   [c-string!]
		/local
			e	  [c-string!]
			c	  [byte!]
			saved [byte!]
			set?  [logic!]
			path? [logic!]
	][
		e: s + 1
		c: e/1

		while [NOT_DELIMITER?(c)][
			e: e + 1
			c: e/1
		]
		set?:  all [e/1 = #":"  not in-path?]
		path?: all [e/1 = slash not in-path?]

		if all [
			type = TYPE_REFINEMENT
			s + 1 = e
		][
			type: TYPE_WORD								;-- / as word case
		]

		either path? [
			return scan-path s e blk type = TYPE_LIT_WORD
		][
			saved: e/1										;@@ allocate a new buffer instead
			e/1: null-byte
			case [
				type = TYPE_GET_WORD	[get-word/load-in s blk]
				type = TYPE_LIT_WORD	[lit-word/load-in s blk]
				type = TYPE_ISSUE		[issue/load-in s blk]
				type = TYPE_REFINEMENT	[refinement/load-in s + 1 blk]
				set?				 	[set-word/load-in s blk]
				true				 	[word/load-in s blk]
			]
			e/1: saved
			return either set? [e + 1][e]
		]
	]

	scan-path: func [
		s		 [c-string!]
		src		 [c-string!]
		blk		 [red-block!]
		lit?	 [logic!]
		return:  [c-string!]
		/local
			path  [red-block!]
			saved [byte!]
			set?  [logic!]
	][
		path: block/make-in blk 4						;-- arbitrary start size

		saved: src/1									;-- push first element
		src/1: null-byte
		word/load-in s path								;-- store undecorated word
		src/1: saved
		c: src/1
		set?: no

		while [c = #"/"][
			src: src + 1
			c: src/1
			case [
				c = #"("  [src: scan-paren src + 1 path]
				c = #":"  [src: scan-word src + 1 path TYPE_GET_WORD yes]
				c = #"-"  [src: scan-minus src path]
				all [#"0" <= c c <= #"9"][src: scan-integer src path no]
				all [#" " <  c c <= #""][src: scan-word src path TYPE_WORD yes]
				yes [throw-error ERR_INVALID_PATH]
			]
			c: src/1
			if c = #":" [set?: yes]
		]

		path/header: case [
			set? [TYPE_SET_PATH]
			lit? [TYPE_LIT_PATH]
			true [TYPE_PATH]
		]
		either set? [src + 1][src]
	]

	scan-block: func [
		src		[c-string!]
		blk		[red-block!]
		return: [c-string!]
	][
		src: scan src block/make-in blk 4				;-- arbitrary start size
		src + 1											;-- skip ] character
	]

	scan-paren: func [
		src		 [c-string!]
		blk		 [red-block!]
		return:  [c-string!]
		/local
			s	 [series!]
			slot [red-value!]
	][
		src: scan src block/make-in blk 4				;-- arbitrary start size
		s: GET_BUFFER(blk)
		slot: s/tail - 1
		slot/header: TYPE_PAREN
		src + 1											;-- skip ) character

	]

	scan: func [
		src		  [c-string!]
		parent	  [red-block!]
		return:	  [c-string!]
		/local
			blk	  [red-block!]
			start [c-string!]
			end	  [c-string!]
			c	  [byte!]
	][
		blk: either null? parent [
			block/push* 4								;-- arbitrary start size
		][
			parent
		]

		while [
			src: skip-spaces src
			c: src/1
			all [
				c <> null-byte
				c <> #"]"
				c <> #")"
			]
		][
			case [
				c = #";"  [src: scan-comment src]
				c = #"-"  [src: scan-minus src blk]
				c = #"^"" [src: scan-string src blk]
				c = #"{"  [src: scan-string-multi src blk]
				c = #"%"  [src: scan-file src blk]
				c = #"["  [src: scan-block src + 1 blk]
				c = #"("  [src: scan-paren src + 1 blk]
				c = #":"  [src: scan-word src + 1 blk TYPE_GET_WORD no]
				c = #"'"  [src: scan-word src + 1 blk TYPE_LIT_WORD no]
				c = #"/"  [src: scan-word src blk TYPE_REFINEMENT no]
				c = #"#"  [
					c: src/2
					either c = #"^"" [
						src: scan-char src + 2 blk
					][
						src: scan-word src + 1 blk TYPE_ISSUE no
					]
				]
				all [#"0" <= c c <= #"9"][src: scan-integer src blk no]
				all [#" " <  c c <= #""][src: scan-word src blk TYPE_WORD no]
			]
		]
		if null? parent [
			if src/1 <> null-byte [throw-error ERR_PREMATURE_END]
			stack/set-last as red-value! blk
		]
		src
	]

]


FIX: fixed bugs found in console, original code restored.

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)
]

count-delimiters: function [
	buffer	[string!]
	return: [block!]
][
	list: copy [0 0]
	c: none

	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
				'mono
			]
		]
		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]]
			]
		]
	]
]

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 [
		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


day11

Red [
  Url: https://adventofcode.com/2017/day/11
]

input: split read %../../resources/2017/day11 ","

move: function [pos dir][
  switch dir [
    "n"  [reduce [pos/1 (pos/2 + 1) (pos/3 - 1)]]
    "ne" [reduce [(pos/1 + 1) pos/2 (pos/3 - 1)]]
    "se" [reduce [(pos/1 + 1) (pos/2 -1) pos/3]]
    "s"  [reduce [pos/1 (pos/2 -1) (pos/3 + 1)]]
    "sw" [reduce [(pos/1 - 1) pos/2 (pos/3 + 1)]]
    "nw" [reduce [(pos/1 - 1) (pos/2 + 1) pos/3]]
  ]
]

steps: function [pos] [
  result: 0
  foreach x pos [
    result: max result absolute x
  ]
]

pos: copy [0 0 0]
max-steps: 0

foreach dir input [
  pos: move pos dir
  curr-steps: steps pos
  max-steps: max max-steps curr-steps
]

print curr-steps
; 764

print max-steps
; 1532

error: pathspec 'src/aoc17-red/day11.red' did not match any file(s) known to git


add help, what to the console build

add help, what to the console build

Red [
   Title: "Help function for Red"
   Author: "Ingo Hohmann"
]

help: function [
   "Get help for functions"
   'func-name "Word you are looking for"
][
   argument-rule: [
      [set word word! (pre: "") | set word lit-word! (pre: "'") | set word get-word! (pre: ":")]
      opt [ set annotation block! (prin [ " " mold annotation])]
      opt [ set info string! (prin [ " =>" info])]
      (print [ ])
   ]
   either all [ word? func-name any [ action? get func-name function? get func-name native? get func-name]][
;      print ["^/" func-name "is of type" type? get :func-name newline]

      prin ["^/USAGE:^/" func-name ]
      parse spec-of get func-name [ any [ /local to end | set w word! (prin[" " w]) | set w [ lit-word! | refinement! ] (prin [" " mold w]) | skip ]]
      parse spec-of get func-name [
	 opt [set annotation block! (prin ["^/^/ANNOTATIONS:^/" mold annotation])]
	 opt [set info string! (print ["^/^/DESCRIPTION:^/" info])]
	 (print "^/ARGUMENTS:")
	 any [
	    argument-rule
	    (print "")
	 ]
	 (print "^/REFINEMENTS:")
	 any [
	    [/local [ to set-word! | to end ] ]
	    |
	    [
	       set ref refinement! (prin mold ref)
	       opt [ set info string! (prin [ " =>" info])]
	       (print "")
	       any [argument-rule (print "")]
	    ]
	 ]
	 opt [
	    set-word! set block block!
	    (print ["^/RETURN:^/" mold block])
	 ]
      ]
   ][
      print [func-name "is of type" either word? func-name [type? get func-name][type? func-name] "."]
      print "No more help available."
   ]
   exit
]

what: function [
   "Lists all functions, or words of a given type"
][
   foreach w system/words [
      if any [ function? get w native? get w action? get w][
	 print w
      ]
   ]
]

source: function [
   "print the source of a function"
   func-name [lit-word!] "The name of the function as lit-word!"
][
   either function? get func-name [
      print mold body-of :func-name
   ][
      print ["Sorry," func-name "is a" type? :func-name "so no source is available"]
   ]
]

error: pathspec 'tests/help.red' did not match any file(s) known to git


reduce function to help convert TFM PL to sml-tex font metric file format

lisp;

set!-print!-precision 50;

fluid '(skew);
symbolic procedure parse_tfm (tfm, skewchar);
  begin
    scalar skew;
    skew := skewchar;
    while (caar tfm) neq 'CHARACTER do tfm := cdr tfm;
    for each char in tfm do <<
      if ((car char) neq 'CHARACTER) or ((cadr char) neq 'O) then error(0,0);
      princ "C"; print caddr char;
      for each prop in cdddr char do parse_prop prop >>;
    printc "E"
  end;

symbolic procedure parse_prop prop;
  begin
    scalar type;
    type := car prop;
    if type = 'CHARWD or type = 'CHARHT or type = 'CHARDP or type = 'CHARIC then parse_simple_prop prop
    else if type = 'NEXTLARGER then parse_larger_prop prop
    else if type = 'VARCHAR then for each vprop in cdr prop do parse_varchar_prop vprop
    else if type = 'COMMENT then for each cprop in cdr prop do parse_comment_prop cprop
    else error(0,0)
  end;

symbolic procedure parse_simple_prop prop;
  begin
    if ((cadr prop) neq 'R) or ((length prop) neq 3) then error(0,0);
    if      car prop = 'CHARWD then princ "W"
    else if car prop = 'CHARHT then princ "H"
    else if car prop = 'CHARDP then princ "D"
    else if car prop = 'CHARIC then princ "I";
    print caddr prop
  end;

symbolic procedure parse_larger_prop prop;
  if ((cadr prop) neq 'O) or ((length prop) neq 3) then error(0,0)
  else << princ "L"; print caddr prop >>;

symbolic procedure parse_varchar_prop prop;
  begin
    scalar type;
    type := car prop;
    if      type = 'TOP then princ "T"
    else if type = 'REP then princ "R"
    else if type = 'BOT then princ "B"
    else error(0,0);
    if (cadr prop) neq 'O then error(0,0);
    print caddr prop
  end;

symbolic procedure parse_comment_prop prop;
  begin
    scalar type;
    type := car prop;
    if      type = 'LIG then return nil
    else if type = 'KRN then parse_kern_prop prop
    else error(0,0)
  end;

symbolic procedure parse_kern_prop prop;
  if ((cadr prop) neq 'O) or ((cadddr prop) neq 'R) then error(0,0)
  else if (caddr prop) neq skew then nil
  else << princ "S"; print cadddr cdr prop >>;

end;

error: pathspec 'sml-tex/formulae/parseTFMPL.red' did not match any file(s) known to git