//  -*- Mode:Common-Lisp;Package:mma; Base:10 -*-
//  Lisp-mathematica (Lmath) parser for Mathematica (tm)-like language.
// (c) copyright 1990, 1991 by Richard J. Fateman
//  Last revised 5/29/91 by RJF
//  Mathematica is described in S. Wolfram: Mathematica, a
//  System for Doing Mathematics By Computer, (Addison-Wesley).
//  this line is not quite enough. Need to do, prior to compiling this
//  file, (set-case-mode :case-sensitive-lower)
//
nil(nil(nil(#f), nil(#f)));

// (provide 'math-parser)
// LTD: Function LOAD not yet implemented.
load("mma");

//  get all the symbols from this file
"(in-package mma)";

// (export '(p  pc rc))
define variable mathbuffer = #f;

define variable stream = #t;

//  if needed
//  The first section consists of readtable hacking for mathematica parser.
//  We set up a separate readtable for
//  mathematica input, and utilize it when scanning.
//  We use lisp atoms to store information on tokens.
//  For production, this could all be put in a Lisp package.
define variable mathrt =
  // LTD: Function COPY-READTABLE not yet implemented.
  copy-readtable(#f);

define variable si =
  // LTD: Function MAKE-SYNONYM-STREAM not yet implemented.
  make-synonym-stream(#"*standard-input*");

begin *print-level* := #f; *print-length* := #f; *print-pretty* := #t; end;

define method pc () peek(stream); end method pc;

define method rc () read-element(stream, nil); end method rc;

define method char-to-int (c)
  let h = as(<integer>, c);
  if (h < 48)
    h - 7;
    //  #\A=17
    elseif (h < 58)
    h - 48;
    //  #\0 is 48 in ascii.
    else
    h - 87;
  end if;
end method char-to-int;

define method collect-integer (val, r)
  if (pc() == '\n')
    val;
  elseif (digit-char?(pc(), r))
    // r is radix
    collect-integer(char-to-int(rc()) + r * val, r);
    // 	((eql (pc) #\`)(rc)(collect-integer val r)) ;;option 123`456 is 123456.
    else
    val;
  end if;
end method collect-integer;

//  to test scanner, try typing
//   (mreadl)  
//  most of these read-table entries were generated by macro expansion
// LTD: Function SET-MACRO-CHARACTER not yet implemented.
set-macro-character('/',
                    method (stream, char)
                      select (pc())
                        '\n'
                           => #"/";
                        ':'
                           => rc(); #"/:";
                        '.'
                           => rc(); #"/.";
                        '@'
                           => rc(); #"/@";
                        ';'
                           => rc(); #"/;";
                        '='
                           => rc(); #"/=";
                        '/'
                           => rc();
                               select (pc())
                                 '\n'
                                    => #"//";
                                 '@'
                                    => rc(); #"//@";
                                 '.'
                                    => rc(); #"//.";
                                 otherwise
                                    => #"//";
                               end select;
                        otherwise
                           => #"/";
                      end select;
                    end method,
                    #f, mathrt);

// LTD: Function SET-MACRO-CHARACTER not yet implemented.
set-macro-character('^',
                    method (stream, char)
                      select (pc())
                        '\n'
                           => #"^";
                        '='
                           => rc(); #"^=";
                        '^'
                           => rc(); #"^^";
                        ':'
                           => rc();
                               select (pc())
                                 '\n'
                                    => #"^:";
                                 '='
                                    => rc(); #"^:=";
                                 otherwise
                                    => #"^:";
                               end select;
                        otherwise
                           => #"^";
                      end select;
                    end method,
                    #f, mathrt);

// LTD: Function SET-MACRO-CHARACTER not yet implemented.
set-macro-character('&',
                    method (stream, char)
                      select (pc())
                        '\n'
                           => #"&";
                        '&'
                           => rc(); #"&&";
                        otherwise
                           => #"&";
                      end select;
                    end method,
                    #f, mathrt);

// LTD: Function SET-MACRO-CHARACTER not yet implemented.
set-macro-character('|',
                    method (stream, char)
                      select (pc())
                        '\n'
                           => #"|";
                        '|'
                           => rc(); #"||";
                        otherwise
                           => #"|";
                      end select;
                    end method,
                    #f, mathrt);

// LTD: Function SET-MACRO-CHARACTER not yet implemented.
set-macro-character('+',
                    method (stream, char)
                      select (pc())
                        '\n'
                           => #"+";
                        '+'
                           => rc(); #"++";
                        '='
                           => rc(); #"+=";
                        otherwise
                           => #"+";
                      end select;
                    end method,
                    #f, mathrt);

// LTD: Function SET-MACRO-CHARACTER not yet implemented.
set-macro-character('*',
                    method (stream, char)
                      select (pc())
                        '\n'
                           => #"*";
                        '*'
                           => rc(); #"**";
                        '='
                           => rc(); #"*=";
                        otherwise
                           => #"*";
                      end select;
                    end method,
                    #f, mathrt);

// LTD: Function SET-MACRO-CHARACTER not yet implemented.
set-macro-character('-',
                    method (stream, char)
                      select (pc())
                        '\n'
                           => #"-";
                        '>'
                           => rc(); #"->";
                        '='
                           => rc(); #"-=";
                        '-'
                           => rc(); #"--";
                        otherwise
                           => #"-";
                      end select;
                    end method,
                    #f, mathrt);

// LTD: Function SET-MACRO-CHARACTER not yet implemented.
set-macro-character('[',
                    method (stream, char)
                      select (pc())
                        '\n'
                           => #"[";
                        '['
                           => rc(); #"[[";
                        otherwise
                           => #"[";
                      end select;
                    end method,
                    #f, mathrt);

// LTD: Function SET-MACRO-CHARACTER not yet implemented.
set-macro-character(']',
                    method (stream, char)
                      select (pc())
                        '\n'
                           => #"]";
                        ']'
                           => rc(); #"]]";
                        otherwise
                           => #"]";
                      end select;
                    end method,
                    #f, mathrt);

// LTD: Function SET-MACRO-CHARACTER not yet implemented.
set-macro-character('{', method (stream, char) #"{"; end method,
                    //  fixed 2/21/91 lvi@ida.liu.se
                    #f, mathrt);

// LTD: Function SET-MACRO-CHARACTER not yet implemented.
set-macro-character('<',
                    method (stream, char)
                      select (pc())
                        '\n'
                           => #"<";
                        '='
                           => rc(); #"<=";
                        otherwise
                           => #"<";
                      end select;
                    end method,
                    #f, mathrt);

// LTD: Function SET-MACRO-CHARACTER not yet implemented.
set-macro-character('>',
                    method (stream, char)
                      select (pc())
                        '\n'
                           => #">";
                        '='
                           => rc(); #">=";
                        '>'
                           => rc();
                               select (pc())
                                 '\n'
                                    => #">>";
                                 '>'
                                    => rc(); #">>>";
                                 otherwise
                                    => #">>";
                               end select;
                        otherwise
                           => #">";
                      end select;
                    end method,
                    #f, mathrt);

// LTD: Function SET-MACRO-CHARACTER not yet implemented.
set-macro-character('!',
                    method (stream, char)
                      select (pc())
                        '\n'
                           => #"!";
                        '!'
                           => rc(); #"!!";
                        '='
                           => rc(); #"!=";
                        otherwise
                           => #"!";
                      end select;
                    end method,
                    #f, mathrt);

// LTD: Function SET-MACRO-CHARACTER not yet implemented.
set-macro-character('#',
                    method (stream, char)
                      select (pc())
                        '\n'
                           => #"#";
                        '#'
                           => rc(); #"##";
                        otherwise
                           => #"#";
                      end select;
                    end method,
                    #f, mathrt);

// LTD: Function SET-MACRO-CHARACTER not yet implemented.
set-macro-character('\\',
                    method (stream, char)
                      select (pc())
                        '\n'
                           => rc(); mread1();
                        #"t"
                           => as(<symbol>,
                                 make(<string>, size: 1, fill: rc()));
                      end select;
                    end method,
                    #f, mathrt);

// LTD: Function SET-MACRO-CHARACTER not yet implemented.
set-macro-character('=',
                    method (stream, char)
                      select (pc())
                        '\n'
                           => #"=";
                        '='
                           => rc();
                               select (pc())
                                 '\n'
                                    => #"==";
                                 '='
                                    => rc(); #"===";
                                 otherwise
                                    => #"==";
                               end select;
                        '!'
                           => rc();
                               select (pc())
                                 '\n'
                                    => #"=!";
                                 '='
                                    => rc(); #"=!=";
                                 otherwise
                                    => #"=!";
                               end select;
                        otherwise
                           => #"=";
                      end select;
                    end method,
                    #f, mathrt);

// LTD: Function SET-MACRO-CHARACTER not yet implemented.
set-macro-character('.',
                    method (stream, char)
                      select (pc())
                        '\n'
                           => #".";
                        '.'
                           => rc();
                               select (pc())
                                 '\n'
                                    => #"..";
                                 '.'
                                    => rc(); #"...";
                                 otherwise
                                    => #"..";
                               end select;
                        otherwise
                           => #".";
                      end select;
                    end method,
                    #f, mathrt);

// LTD: Function SET-MACRO-CHARACTER not yet implemented.
set-macro-character(':',
                    method (stream, char)
                      select (pc())
                        '\n'
                           => #":";
                        '>'
                           => rc(); #":>";
                        ':'
                           => rc();
                               select (pc())
                                 '\n'
                                    => #"::";
                                 '='
                                    => rc(); #"::=";
                                 otherwise
                                    => #"::";
                               end select;
                        '='
                           => rc(); #":=";
                        otherwise
                           => #":";
                      end select;
                    end method,
                    #f, mathrt);

// LTD: Function SET-MACRO-CHARACTER not yet implemented.
set-macro-character('\'', method (stream, char) #"'"; end method, #f, mathrt);

// LTD: Function SET-MACRO-CHARACTER not yet implemented.
set-macro-character('@',
                    method (stream, char)
                      select (pc())
                        '\n'
                           => #"@";
                        '@'
                           => rc(); #"@@";
                        otherwise
                           => #"@";
                      end select;
                    end method,
                    #f, mathrt);

//  above fixed by lvi@ida.liu 3/20/92
// LTD: Function SET-MACRO-CHARACTER not yet implemented.
set-macro-character('~', method (stream, char) #"~"; end method, #f, mathrt);

// LTD: Function SET-MACRO-CHARACTER not yet implemented.
set-macro-character('?', method (stream, char) #"?"; end method, #f, mathrt);

// LTD: Function SET-MACRO-CHARACTER not yet implemented.
set-macro-character(')', method (stream, char) #")"; end method, #f, mathrt);

// LTD: Function SET-MACRO-CHARACTER not yet implemented.
set-macro-character('}', method (stream, char) #"}"; end method, #f, mathrt);

// LTD: Function SET-MACRO-CHARACTER not yet implemented.
set-macro-character(';', method (stream, char) #";"; end method, #f, mathrt);

// LTD: Function SET-MACRO-CHARACTER not yet implemented.
set-macro-character(',', method (stream, char) #","; end method, #f, mathrt);

// LTD: Function SET-MACRO-CHARACTER not yet implemented.
set-macro-character('\n', method (stream, char) #"e-o-l"; end method, #f,
                    mathrt);

begin
  do(method (x) symbol-get-property(x, #"mathtoken") := #t; end method,
     #(#"/", #"/:", #"/.", #"/@", #"/;", #"/=", #"//", #"//@", #"//.", #"^",
       #"^=", #"^^", #"^:=", #"^:", #"&", #"&&", #"|", #"||", #"+", #"++",
       #"+=", #"**", #"*=", #"-", #"->", #"-=", #"--", #"[", #"[[", #"]",
       #"]]", #"{", #"}", #">", #">=", #">>", #">>>", #"<", #"<=", #"!",
       #"!!", #"!=", #"#", #"##", #":=", #":>", #"::", #"::=", #":", #"=",
       #"==", #"===", #"=!=", #".", #"..", #"...", #"\\", #"e-o-l", #"(",
       #")", #"'", #"@", #"~", #"?", #";", #","));
  #(#"/", #"/:", #"/.", #"/@", #"/;", #"/=", #"//", #"//@", #"//.", #"^",
    #"^=", #"^^", #"^:=", #"^:", #"&", #"&&", #"|", #"||", #"+", #"++", #"+=",
    #"**", #"*=", #"-", #"->", #"-=", #"--", #"[", #"[[", #"]", #"]]", #"{",
    #"}", #">", #">=", #">>", #">>>", #"<", #"<=", #"!", #"!!", #"!=", #"#",
    #"##", #":=", #":>", #"::", #"::=", #":", #"=", #"==", #"===", #"=!=",
    #".", #"..", #"...", #"\\", #"e-o-l", #"(", #")", #"'", #"@", #"~", #"?",
    #";", #",");
end;

//   Extension.  This allows us to use foo[*,1]*bar[1,*] notationally.
//  also a * *  means  (Times a *)
// (setf (get '* 'mathtoken t))
// LTD: Function SET-MACRO-CHARACTER not yet implemented.
set-macro-character('_',
                    method (stream, char)
                      select (pc())
                        '\n'
                           => #(#"blank");
                        '.'
                           => rc(); #(#"optional", #(#"blank"));
                        '_'
                           => rc();
                               select (pc())
                                 '\n'
                                    => #(#"blanksequence");
                                 '_'
                                    => rc();
                                        // ___ (3 of em)
                                        if (alpha-char?(pc())
                                             & (next := rt()))
                                        list(#"blanknullsequence", next);
                                        else
                                        #(#"blanknullsequence");
                                        end if;
                                 otherwise
                                    => //  __ (2 of em)
                                        if (alpha-char?(pc())
                                             & (next := rt()))
                                        list(#"blanksequence", next);
                                        else
                                        #(#"blanksequence");
                                        end if;
                               end select;
                        otherwise
                           => //  _ (1 of em)
                               if (alpha-char?(pc()) & (next := rt()))
                                 list(#"blank", next);
                               else
                                 #(#"blank");
                               end if;
                      end select;
                    end method,
                    #f, mathrt);

//  left paren could start a comment
define method sawlpar (stream, char)
  select (pc())
    '*'
       => // skip to end of comment
           rc();
           commentskip(stream);
    otherwise
       => #"(";
  end select;
end method sawlpar;

// )
// LTD: Function SET-MACRO-CHARACTER not yet implemented.
set-macro-character('(', sawlpar, #f, mathrt);

// )
//  the use of the % character is peculiar.
// LTD: Function SET-MACRO-CHARACTER not yet implemented.
set-macro-character('%',
                    method (stream, char)
                      if (pc() == '%')
                        parse-outform1(2);
                      elseif (digit-char?(pc()))
                        list(#"out", collect-integer(0, 10));
                      else
                        #(#"out");
                      end if;
                    end method,
                    #f, mathrt);

define method parse-outform1 (counter)
  //  saw more than one %
  rc();
  if (pc() = '%')
    parse-outform1(1 + counter);
    // another %
    else
    list(#"out", - counter);
  end if;
end method parse-outform1;

define method commentskip (stream)
  block (return)
    while (#t)
      x := rc();
      if (x == '(')
        sawlpar(stream, x);
      elseif (x == '*' & pc() == ')')
        rc();
        //  flush the last leftpar
        return(mread1());
      end if;
    end while;
  end block;
end method commentskip;

//  end of the lexical analysis part
// ----------------------------------------------------------
//  			The Parser
//  You can use (p)  to try out the parser by typing in from the
//  keyboard. It sets up the readtable and calls parse-comp.
//  Reading from lines is set up so that if a sentence ends at
//  an end-of-line, the parse is completed. Otherwise, the e-o-l
//  is absorbed and the reading continued.  A continuation line
//  can be forced by a \.  (This is Mathematica's usual operation)
define variable interactive = #t;

//  t means 2 eol's ends a command. not for files.
//   ps will read from a Mathematica stream  // print to std output
//  e.g.  (ps (open "foo.text"))
define method ps (stream)
  rt();
  while (#t)
    res := block (endofparse) parse-comp(#t); end block;
    //  end=t means a #\newline will end expr.
    print(if ('\n' == pc())
            rc();
            res;
            //  proper ending
            elseif (z := rt())
            begin
              let _that = #f;
              if (_that := z = #"e-o-l")
                _that;
                // may also be proper ending
                else
                format-out("\ngarbage at end of expression:%=\n", z);
              end if;
            end;
            res;
          end if,
          *standard-output*);
  end while;
end method ps;

define method psm (//   (meval (parse ( stream-from-file)))
                   stream(&aux, interactive(nil), res, *readtable*(mathrt),
                          mathbuffer(nil), z))
  rt();
  while (#t)
    res := block (endofparse) parse-comp(#t); end block;
    //  end=t means a #\newline will end expr.
    print(if ('\n' == pc())
            rc();
            res;
            //  proper ending
            elseif (z := meval(rt()))
            //  call meval on stuff read in.
            begin
              let _that = #f;
              if (_that := z = #"e-o-l")
                _that;
                // may also be proper ending
                else
                format-out("\ngarbage at end of expression:%=\n", z);
              end if;
            end;
            res;
          end if,
          *standard-output*);
  end while;
end method psm;

// mreadl is a debugging loop that just reads lexemes until it reads done
define method mreadl ()
  block (return)
    while (#t)
      next := mread1();
      if (next == #"e-o-l") return(#"done"); end if;
      print(next, *standard-output*);
    end while;
  end block;
end method mreadl;

// LTD: No macros.
#"rt";

// LTD: No macros.
#"eolp";

//  this function reads a token. Although it looks like it
//  just reads a lisp s-expression or number, it uses a different
//  read-table. If mread1 encounters a #\newline, it returns the
//  atom e-o-l, as specified in the read-table.
define method mread1 ()
  //  debug  (format t "~% next char = ~s" (pc))
  if (member?(pc(), #(' ', '\t', '\012'), test: \=))
    rc();
    mread1();
    //  fix - 2x bug
    elseif (digit-char?(pc()))
    //  next character is a digit 0-9
    collect-integer(char-to-int(read-element(stream, nil)), 10);
    // radix 10 default
    else
    // LTD: Function READ-PRESERVING-WHITESPACE not yet implemented.
    read-preserving-whitespace(stream, #f, #"e-o-l")
     | #"false";
  end if;
end method mread1;

define method p (#key stream = *standard-input*)
  //   (rt) ;;get something in mathbuffer
  res := block (endofparse) parse-comp(#t); end block;
  //  end=t means a #\newline will end expr.
  if (mathbuffer == #"e-o-l")
    if (res) res; else #"null"; end if;
    //  proper ending
    else
    format-out("\nUnexpected token at end of expression:%=\n", mathbuffer);
    res;
  end if;
end method p;

define method peek-token ()
  let _that = #f;
  if (_that := mathbuffer) _that; else mathbuffer := mread1(); end if;
end method peek-token;

define method parse-nary1 (res, tag)
  if (empty?(tail(res))) head(res); else pair(tag, reverse!(res)); end if;
end method parse-nary1;

define method guess-token (guess)
  if (guess == tok)
    #t;
  elseif (#"e-o-l" == tok)
    rt();
    if (interactive & #"e-o-l" == peek-token())
      //  if two in-a-row; get outta here
      endofparse(#f);
    end if;
  end if;
end method guess-token;

//  a variable is any symbol that looks like a lisp symbol and
//  is not an integer or string, or a pattern-var
define method var-p (token)
  instance?(token, <pair>)
   | //  case of (blank)
  (~ instance?(token, <integer>) & ~ (token == #"e-o-l")
    & (instance?(token, <string>)
        | ~ symbol-get-property(token, #"mathtoken")));
end method var-p;

//  is Head one of the pattern items "blank..."
define method blankp (token)
  ~ not(instance?(token, <list>))
   & member?(head(token),
             #(#"blank", #"blanksequence", #"blanknullsequence",
               #"optional"));
end method blankp;

//  parse a number
define method parse-number (end)
  //  reads floats and radix nums also
  if (x)
    if (pc() = '.')
      //  is the very next character a "."?
      rc();
      //  remove exactly that character.
      //  note: in Mathematica, 1. 2 is 1.0*2 = 2.0
      //  1 .2  is 1*0.2 = 0.2
      //  1 . 2 is Dot[1,2]
      // Now check: Is there a digit next?
      if (digit-char?(pc()))
        afterdot := parse-frac(end);
        if (afterdot)
          make-real(x, afterdot);
          // like 12.34
          else
          x;
        end if;
        //       not a float -> return integer
        else
        make-real(x, 0);
      end if;
    else
      x;
    end if;
    // x is an integer, but no "." follows
    //  still, we must check for  a number of the form .123
    elseif (guess-token(#"."))
    rt();
    // is there a digit next?
    if (digit-char?(pc()))
      afterdot := parse-frac(end);
      if (afterdot)
        make-real(0, afterdot);
        // like 0.34
        else
        "what's a dot doing here?";
      end if;
    elseif (nil);
    end if;
    //  we could make it 0?
    else
    #f;
  end if;
end method parse-number;

// parse an integer, including radix
define method parse-int (end)
  if (instance?(x, <integer>))
    if (eolp(end))
      x;
    elseif (rt() & pc() == '^'
             & //  don't sop up extra spaces here. what if 1 .2
            guess-token(#"^^"))
      //  see if it is, e.g. 8^^101 =65
      rt();
      if (x > 10 | x < 2) format-out("radix %= ?\n", x); elseif (nil); end if;
      collect-integer(0, x);
    else
      x;
    end if;
    //  ok, no radix stuff -- just return x
    else
    #f;
  end if;
end method parse-int;

//  parse the fraction part of a decimal number .123
define method parse-frac (end)
  block (return)
    while (#t)
      //  since all of the line termination chars are not digits, all we
      //  need to check is for digits..
      if (~ (x := digit-char?(pc()))) return(num / den); end if;
      rc();
      //  read past the char
      den := den * 10;
      num := 10 * num + x;
    end while;
  end block;
end method parse-frac;

//  this is a stub until we decide what to really do here
define method make-real (x, y) list(#"real", x, y); end method make-real;

//  parse lists delimited by [] [[]]{}  tricky to  handle f[g[x]].
define method parse-list (#key op)
  next := peek-token();
  if (next = #"[[")
    rt();
    parselist1(list(op, #"part"), #"]]");
  elseif (next = #"[")
    rt();
    parselist1(list(op), #"]");
  elseif (next = #"{")
    rt();
    parselist1(list(#"list"), #"}");
  end if;
end method parse-list;

define method parselist1 (sofar, endmark)
  //  we want to find an expression
  next := peek-token();
  let _that = #f;
  if (next == #",")
    rt();
    //  get past the comma
    parselist1(pair(#f, sofar), endmark);
  elseif (next == endmark)
    rt();
    //  get past the endmark [a,b,]
    if (empty?(tail(sofar)))
      sofar;
      //  f[] -> (f)
      else
      reverse!(pair(#f, sofar));
    end if;
  elseif (_that
           := endmark == #"]"
               & //  we might find a '|]]|
              parse-list-hack(next, pair(#f, sofar)))
    _that;
  elseif (next := parse-comp(#f))
    //  end=nil; can't end with just #\newline
    parselist2(pair(next, sofar), endmark);
  else
    error("parse-list: looking for a comma, expression or endmark");
  end if;
end method parselist1;

define method parse-list-hack (next, sofar)
  // make f[g[h]] work ok by parsing as
  //  f[g[h] ]
  if (next = #"]")
    rt();
    reverse!(sofar);
  elseif (next = #"]]")
    mathbuffer := #"]";
    //  one '\] left over for f[g[h]]
    reverse!(sofar);
  end if;
end method parse-list-hack;

define method parselist2 (sofar, endmark)
  //  we want to find , or close mark
  next := peek-token();
  let _that = #f;
  if (next = #",")
    rt();
    //  get past the comma
    parselist1(sofar, endmark);
  elseif (next = endmark)
    rt();
    reverse!(sofar);
  elseif (_that
           := endmark = #"]"
               & //  we might find a '|]]|
              parse-list-hack(next, sofar))
    _that;
  else
    error("parse-list: looking for a comma, expression or endmark");
  end if;
end method parselist2;

// comparison operators
symbol-get-property(#"==", #"compop") := #"equal";

symbol-get-property(#"!=", #"compop") := #"unequal";

symbol-get-property(#"<", #"compop") := #"less";

symbol-get-property(#"<=", #"compop") := #"lessequal";

symbol-get-property(#">", #"compop") := #"greater";

symbol-get-property(#">=", #"compop") := #"greaterequal";

symbol-get-property(#"===", #"sameop") := #"sameq";

symbol-get-property(#"=!=", #"sameop") := #"unsameq";

//  sample parses.  All comparisons of 3 or more items are questionable,
//  but this is what Mathematica does...
//  a<b<c  (Less a b c)
//  a>b<c  (Inequality a Greater b Less c)  ;but
//  a>b==c (Equal (Greater a b) c)  ;--- associates to left
//  a==b==c (Equal a b c)  ; meaning (And (Equal a b)(Equal b c))
//  but no duplicate evaluation of b; yet
//  (a==b)==c  (Equal (Equal a b) c)  ;; not the same -- a==b is True or False
//  a==(b==c)  (Equal a (Equal b c))
//  a==b!=c (Unequal (Equal a b) c)
//  a!=b==c (Equal (Unequal a b) c)
//  a+b==c  (Equal (Plus a b) c)
define method parse-or (end)
  //  E::=e1||e2  n-ary
  if (eolp(end))
    temp;
  elseif (temp)
    if (guess-token(#"||"))
      // check first to avoid consing
      res := pair(temp, #f);
      block (return)
        while (#t)
          if (eolp(end))
            return(parse-nary1(res, #"or"));
          elseif (guess-token(#"||"))
            rt();
            res := pair(parse-and(end), res);
          else
            return(parse-nary1(res, #"or"));
          end if;
        end while;
      end block;
    else
      temp;
    end if;
  else
    #f;
  end if;
end method parse-or;

define method parse-and (end)
  //  E::=e1 && e2  n-ary  (And)
  if (eolp(end))
    temp;
  elseif (temp)
    if (guess-token(#"&&"))
      // check first to avoid consing
      res := pair(temp, #f);
      block (return)
        while (#t)
          if (eolp(end))
            return(parse-nary1(res, #"and"));
          elseif (guess-token(#"&&"))
            rt();
            res := pair(parse-not(end), res);
          else
            return(parse-nary1(res, #"and"));
          end if;
        end while;
      end block;
    else
      temp;
    end if;
  else
    #f;
  end if;
end method parse-and;

define method parse-not (end)
  if (eolp(end))
    #f;
  elseif (guess-token(#"!"))
    //  Not
    rt();
    list(#"not", parse-not(end));
  else
    parse-same(end);
  end if;
end method parse-not;

//  this definition does not handle 3-way or more comparisons quite
//  the same as Mathematica. 
//  a===b is (SameQ a b) but a=!=b===c is (Inequality a SameQ b SameQ c)
//  rather than (Sameq (UnSameQ a b) c).
//  reason: probably Mathematica is wrong; probably the feature is unused
//  and hence un-noticed.
define method parse-same (end)
  //  E::=e1 ===e2 etc
  if (eolp(end))
    temp;
  elseif (temp)
    op := peek-token();
    if (not(instance?(op, <list>)) & symbol-get-property(op, #"sameop"))
      //  check before cons
      // SameQ
      res := pair(temp, #f);
      block (return)
        while (#t)
          if (eolp(end))
            return(patch-equal(parse-nary1(res, #"inequality")));
          elseif (not(instance?((op := peek-token()), <list>))
                   & (op := symbol-get-property(op, #"sameop")))
            rt();
            res := pair(parse-equal(end), pair(op, res));
          else
            return(patch-equal(parse-nary1(res, #"inequality")));
          end if;
        end while;
      end block;
    else
      temp;
    end if;
  else
    #f;
  end if;
end method parse-same;

define method parse-equal (end)
  //  E::=e1 compop e2  n-ary  (==, etc)
  if (eolp(end))
    temp;
  elseif (temp)
    op := peek-token();
    if (not(instance?(op, <list>)) & symbol-get-property(op, #"compop"))
      //  check before cons
      // Unequal, for example
      res := pair(temp, #f);
      block (return)
        while (#t)
          if (eolp(end))
            return(patch-equal(parse-nary1(res, #"inequality")));
          elseif (not(instance?((op := peek-token()), <list>))
                   & (op := symbol-get-property(op, #"compop")))
            rt();
            res := pair(parse-plus(end), pair(op, res));
          else
            return(patch-equal(parse-nary1(res, #"inequality")));
          end if;
        end while;
      end block;
    else
      temp;
    end if;
  else
    #f;
  end if;
end method parse-equal;

define method patch-equal (h)
  if (size(h) = 4) list(third(h), second(h), cadddr(h)); else h; end if;
end method patch-equal;

//  arithmetic expression
define method parse-plus (end)
  //  E::=T1{+T2} | T1{-T2}
  if (temp)
    if (eolp(end))
      temp;
    elseif (guess-token(#"+") | guess-token(#"-"))
      res := pair(temp, #f);
      block (return)
        while (#t)
          if (eolp(end))
            return(parse-nary1(res, #"plus"));
          elseif (guess-token(#"+"))
            rt();
            res := pair(parse-times(end), res);
          elseif (guess-token(#"-"))
            rt();
            res
             := pair(begin
                       let h = parse-times(end);
                       if (instance?(h, <number>))
                         - h;
                       else
                         list(#"times", -1, h);
                       end if;
                     end,
                     res);
          else
            return(parse-nary1(res, #"plus"));
          end if;
        end while;
      end block;
    else
      temp;
    end if;
  else
    #f;
  end if;
end method parse-plus;

define method parse-comp (end)
  //  E::=E;E;  | E;
  if (temp := parse-put(end))
    if (eolp(end))
      temp;
    elseif (guess-token(#";"))
      // check first to avoid consing
      res := pair(if (temp) temp; else #"null"; end if, #f);
      block (return)
        while (#t)
          if (eolp(end))
            return(parse-nary1(res, #"compoundexpression"));
          elseif (guess-token(#";"))
            rt();
            res := pair(parse-put(end) | #"null", res);
          else
            return(parse-nary1(res, #"compoundexpression"));
          end if;
        end while;
      end block;
    else
      temp;
    end if;
  else
    #f;
  end if;
end method parse-comp;

define method parse-put (end)
  //  e >> file or e>>>file
  if (temp)
    if (eolp(end))
      temp;
    elseif (guess-token(#">>"))
      rt();
      list(#"put", temp, rt());
    elseif (guess-token(#">>>"))
      rt();
      list(#"putappend", temp, rt());
    else
      temp;
    end if;
  else
    #f;
  end if;
end method parse-put;

// replace is left-assoc    e /. e   |  e//.e
//  11/18/94 RJF
define method parse-replace (end)
  if (temp) parse-replace1(temp, end); else #f; end if;
end method parse-replace;

//  formerly
// (defun parse-replace( end &aux(temp(parse-rule end)))
//   (cond (temp (parse-replace1 temp end))
// 	(t nil)))
//
define method parse-replace1 (temp, end)
  if (eolp(end))
    temp;
  elseif (guess-token(#"/."))
    rt();
    parse-replace1(list(#"replaceall", temp, parse-replace(end)), end);
  elseif (guess-token(#"//."))
    rt();
    parse-replace1(list(#"replacerepeated", temp, parse-replace(end)), end);
  else
    temp;
  end if;
end method parse-replace1;

//  added 11/18/94; RJF
//  I do not know if the precedence implied by this
//  is entirely accurate wrt Mathematica.
define method parse-alternatives (end)
  //  E::=e1 \|  e2  n-ary  (Alternatives)
  if (eolp(end))
    temp;
  elseif (temp)
    if (guess-token(#"|"))
      // check first to avoid consing
      res := pair(temp, #f);
      block (return)
        while (#t)
          if (eolp(end))
            return(parse-nary1(res, #"alternatives"));
          elseif (guess-token(#"|"))
            rt();
            res := pair(parse-rule(end), res);
          else
            return(parse-nary1(res, #"alternatives"));
          end if;
        end while;
      end block;
    else
      temp;
    end if;
  else
    #f;
  end if;
end method parse-alternatives;

define method parse-rule (end)
  // e->(e->e) etc
  if (temp)
    if (eolp(end))
      temp;
    elseif (guess-token(#"->"))
      rt();
      list(#"rule", temp, parse-rule(end));
    elseif (guess-token(#":>"))
      rt();
      list(#"ruledelayed", temp, parse-rule(end));
    else
      temp;
    end if;
  else
    #f;
  end if;
end method parse-rule;

// condition is left-assoc
define method parse-condition (end)
  if (temp) parse-condition1(temp, end); else #f; end if;
end method parse-condition;

define method parse-condition1 (temp, end)
  if (eolp(end))
    temp;
  elseif (guess-token(#"/;"))
    rt();
    parse-condition1(list(#"condition", temp, parse-repeated(end)), end);
  else
    temp;
  end if;
end method parse-condition1;

define method parse-repeated (end)
  if (temp)
    if (eolp(end))
      temp;
    elseif (guess-token(#".."))
      rt();
      list(#"repeated", temp);
    elseif (guess-token(#"..."))
      rt();
      list(#"repeatednull", temp);
    else
      temp;
    end if;
  else
    #f;
  end if;
end method parse-repeated;

define method parse-addto (end)
  //  bug noticed by /fixed by lvi@ida.liu.se
  if (temp)
    if (eolp(end))
      temp;
    elseif (guess-token(#"+="))
      rt();
      list(#"addto", temp, parse-addto(end));
    elseif (guess-token(#"*="))
      rt();
      list(#"timesby", temp, parse-addto(end));
    elseif (guess-token(#"-="))
      rt();
      list(#"subtractfrom", temp, parse-addto(end));
    elseif (guess-token(#"/="))
      rt();
      list(#"divideby", temp, parse-addto(end));
    else
      temp;
    end if;
  else
    #f;
  end if;
end method parse-addto;

define method parse-set (end)
  if (temp)
    if (eolp(end))
      temp;
    elseif (guess-token(#"="))
      rt();
      if (guess-token(#"."))
        rt();
        list(#"unset", temp);
      else
        list(#"set", temp, parse-set(end));
      end if;
    elseif (guess-token(#":="))
      rt();
      list(#"setdelayed", temp, parse-set(end));
    elseif (guess-token(#"^="))
      rt();
      list(#"upset", temp, parse-set(end));
    elseif (guess-token(#"^:="))
      rt();
      list(#"upsetdelayed", temp, parse-set(end));
    elseif (guess-token(#"/:"))
      rt();
      list(#"tagset", temp, parse-set(end));
      // actually, Mathematica uses TagSet Delayed, Un.
      elseif (guess-token(#"::="))
      rt();
      if (guess-token(#"."))
        rt();
        list(#"unalias", temp);
      else
        list(#"alias", temp, parse-set(end));
      end if;
    else
      temp;
    end if;
  else
    #f;
  end if;
end method parse-set;

//  f&[a,b] --> ((Function f) a b)
define method parse-ampersand (end)
  if (temp := parse-addto(end))
    if (eolp(end))
      temp;
    elseif (peek-token() == #"&")
      rt();
      parse-fun1(list(#"function", temp), end);
    else
      temp;
    end if;
  else
    #f;
  end if;
end method parse-ampersand;

// left associative  e1//e2
define method parse-// (end)
  if (temp)
    if (eolp(end))
      temp;
    elseif (guess-token(#"//"))
      rt();
      parse-//1(list(parse-ampersand(end), temp), end);
    else
      temp;
    end if;
  else
    #f;
  end if;
end method parse-//;

define method parse-//1 (sofar, end)
  if (eolp(end))
    sofar;
  elseif (guess-token(#"//"))
    rt();
    parse-//1(list(parse-ampersand(end), sofar), end);
  else
    sofar;
  end if;
end method parse-//1;

define method parse-times (end)
  // 
  //   t::=f1{*f2} | f1{/f2} |  f1 <space> f2
  if (eolp(end))
    temp;
  elseif (temp)
    res := pair(temp, #f);
    block (return)
      while (#t)
        if (eolp(end))
          return(parse-nary1(res, #"times"));
        elseif (guess-token(#"*"))
          rt();
          //  a * !b+c is (Times a (Not (Plus b c)))
          res := pair(parse-unary(end), res);
        elseif (guess-token(#"/"))
          rt();
          res := pair(apply(list, #"power", parse-unary(end), #(-1)), res);
          //  note that a / b c  = (a * b^-1 *c) not (a* (b*c)^-1)
          //  this implements the kludge a x = a*x
          //  can't tolerate  a +b ==> (Times a b), and +b is b...
          //  hence use parse-power, not parse-not
          elseif (temp := parse-power(end))
          res := pair(temp, res);
        else
          return(parse-nary1(res, #"times"));
        end if;
      end while;
    end block;
  else
    #f;
  end if;
end method parse-times;

define method parse-unary (end)
  //  E::=+T | -T
  if (guess-token(#"+"))
    rt();
    parse-unary(end);
    // unary +
    elseif (guess-token(#"-"))
    rt();
    begin
      let h = parse-unary(end);
      if (instance?(h, <number>)) - h; else list(#"times", -1, h); end if;
    end;
  elseif (guess-token(#"!"))
    parse-not(end);
    //  extra added attraction!!  'foo  -> (Quote foo)
    elseif (guess-token(#"'"))
    rt();
    list(#"quote", parse-unary(end));
  else
    parse-power(end);
  end if;
end method parse-unary;

define method parse-power (end)
  //  f ::= p^f | p
  if (temp)
    if (eolp(end))
      temp;
    elseif (guess-token(#"^"))
      rt();
      list(#"power", temp, parse-unary(end));
      // really going up the precedence
      else
      temp;
    end if;
  else
    #f;
  end if;
end method parse-power;

define method parse-dot (end)
  //  E::=e1 . e2  n-ary  dot
  if (temp)
    if (eolp(end))
      temp;
    elseif (guess-token(#"."))
      // check first to avoid consing
      res := pair(temp, #f);
      block (return)
        while (#t)
          if (eolp(end))
            return(parse-nary1(res, #"dot"));
          elseif (guess-token(#"."))
            rt();
            res := pair(parse-ncm(end), res);
          else
            return(parse-nary1(res, #"dot"));
          end if;
        end while;
      end block;
    else
      temp;
    end if;
  else
    #f;
  end if;
end method parse-dot;

define method parse-ncm (end)
  //  E::=e1 ** e2  n-ary
  if (temp)
    if (eolp(end))
      temp;
    elseif (guess-token(#"**"))
      // check first to avoid consing
      res := pair(temp, #f);
      block (return)
        while (#t)
          if (eolp(end))
            return(parse-nary1(res, #"noncommutativemultiply"));
          elseif (guess-token(#"**"))
            rt();
            res := pair(parse-fact(end), res);
          else
            return(parse-nary1(res, #"noncommutativemultiply"));
          end if;
        end while;
      end block;
    else
      temp;
    end if;
  else
    #f;
  end if;
end method parse-ncm;

// factorial is left-associative  a ! !  means (a!)!
define method parse-fact (end)
  //   d ::= m | m! | m!!
  if (temp) parse-fact1(temp, end); else #f; end if;
end method parse-fact;

define method parse-fact1 (temp, end)
  //   d ::= m | m! | m!!
  if (eolp(end))
    temp;
  elseif (guess-token(#"!"))
    rt();
    parse-fact1(list(#"factorial", temp), end);
  elseif (guess-token(#"!!"))
    rt();
    parse-fact1(list(#"factorial2", temp), end);
  else
    temp;
  end if;
end method parse-fact1;

define method parse-map (end)
  //   d ::= t | t /@ expr
  if (eolp(end))
    temp;
  elseif (temp)
    if (guess-token(#"/@"))
      rt();
      list(#"map", temp, parse-map(end));
    elseif (guess-token(#"//@"))
      rt();
      list(#"mapall", temp, parse-map(end));
    elseif (guess-token(#"@@"))
      rt();
      list(#"apply", temp, parse-map(end));
    else
      temp;
    end if;
  else
    #f;
  end if;
end method parse-map;

define method parse-tilde (sofar, end)
  if (empty?(sofar))
    #f;
  elseif (eolp(end))
    sofar;
  else
    if (guess-token(#"~") & rt() & (op := parse-at(#f)) & guess-token(#"~")
         & rt()
         & (last := parse-at(end)))
      parse-tilde(list(op, sofar, last), end);
    else
      sofar;
    end if;
  end if;
end method parse-tilde;

define method parse-precrement (end)
  //  look for ++a or --a  ;lvi fix for ++ ++ a
  if (guess-token(#"++"))
    rt();
    list(#"preincrement", parse-precrement(end));
  elseif (guess-token(#"--"))
    rt();
    list(#"predecrement", parse-precrement(end));
  else
    parse-fun(end);
  end if;
end method parse-precrement;

define method parse-pattest (end)
  //  patterntest  is e1?e2
  if (temp)
    if (eolp(end))
      temp;
    elseif (guess-token(#"?"))
      rt();
      list(#"patterntest", temp, parse-var(end));
    else
      temp;
    end if;
  else
    #f;
  end if;
end method parse-pattest;

define variable rpar = #")";

define variable lpar = #"(";

// parse-optional looks for Optional   a_:v is (Optional(Pattern a (Blank)) v)
define method parse-optional (end)
  if (temp)
    if (eolp(end))
      temp;
    elseif (guess-token(#":"))
      rt();
      if (empty?(temp2 := parse-comp(end)))
        // 10/28/94 RJF
        list(#"optional", temp);
      else
        list(#"optional", temp, temp2);
      end if;
    else
      temp;
    end if;
  else
    temp;
  end if;
end method parse-optional;

//  var ::=  var_ etc| #var | _ | __ | ___ | patternstuff  | var :: string
// ( stuff ) |  ( a , ....) | { a , ...} | number
define method parse-var (end)
  if (next == #"e-o-l")
    rt();
    next := peek-token();
    if (next == #"e-o-l") #f; else parse-var(end); end if;
  elseif (var-p(next))
    rt();
    if (eolp(end))
      next;
    elseif (blankp(peek-token()))
      if (head(peek-token()) == #"optional")
        //  10/28/94 RJF
        list(#"optional", apply(list, #"pattern", next, tail(rt())));
      else
        list(#"pattern", next, rt());
      end if;
    elseif (guess-token(#"::"))
      rt();
      list(#"messagename", next, rt());
    elseif (guess-token(#":"))
      rt();
      list(#"pattern", next, parse-repeated(end));
    else
      next;
    end if;
  elseif (next = lpar)
    //  look for (expr)
    //  actually  (a,b,..), a Sequence is not accepted in 2.0, but in 1.2
    rt();
    next := parse-comp(#f);
    begin
      let _that = #f;
      if (guess-token(rpar))
        rt();
        next;
      elseif (_that := parselist2(list(next, #"sequence"), rpar))
        _that;
      else
        error("too few rpars");
      end if;
    end;
  elseif (next = #"{")
    rt();
    //  look for List
    if (guess-token(#"}"))
      rt();
      list(#"list");
    elseif (next := parse-comp(#f))
      // lvi 8/29
      parselist2(list(next, #"list"), #"}");
    else
      error("too few right-}");
    end if;
  elseif (next = #"#")
    parse-slotform(#"slot", end);
  elseif (next = #"##")
    parse-slotform(#"slotsequence", end);
  elseif (next := parse-number(end))
    // (if (atom next) (list 'Integer next) next);;tags integers specifically
    next;
  else
    #f;
  end if;
end method parse-var;

//  # means (Slot 1) ## means (SlotSequence 1)
//  #2 means (Slot 2) etc.
define method parse-slotform (head, end)
  rt();
  //  sop up # or ##
  if (empty?(var := parse-int(end)))
    pair(head, #(1));
  else
    list(head, var);
  end if;
end method parse-slotform;

define method parse-at (end)
  //  collect e1 @ e2 | e++ | e--
  if (var)
    if (eolp(end))
      var;
    elseif (guess-token(#"@"))
      rt();
      list(var, parse-at(end));
    elseif (guess-token(#"++"))
      rt();
      list(#"increment", var);
    elseif (guess-token(#"--"))
      rt();
      list(#"decrement", var);
    else
      var;
    end if;
  else
    #f;
  end if;
end method parse-at;

//  parse-fun collects f[x] or similar; also a++
//  it is left-assoc.  f[x]=(f x);  f[x][y] = ((f x) y)
define method parse-fun (end)
  if (temp) parse-fun1(temp, end); else #f; end if;
end method parse-fun;

//  parser must handle the following cases:
//  f'    --> ((Derivative 1) f)
//  f'x   --> (Times ((Derivative 1) f) x)
//  f'[x] --> (((Derivative 1) f) x)
//  f''  --> ((Derivative 2) f)
define method parse-fun1 (sofar, end)
  if (eolp(end))
    sofar;
    //  handle the derivative cases
    elseif (peek-token() == #"'")
    for (i = 0 then 1+(i), until eolp(end) | ~ guess-token(#"'"))
      rt();
    finally
      parse-fun1(list(list(#"derivative", i), sofar), end);
    end for;
    //  handle the function invocation f[x] and part .. f[[1]]
    elseif (member?(peek-token(), #(#"[", #"[[")))
    parse-fun1(parse-list(sofar), end);
    //  f[], f[x] or maybe (f[x])[y]  etc.
    else
    sofar;
  end if;
end method parse-fun1;

//      some extensions/ modifications
//  1. we parse a==b>c as (Inequality a Equal b Greater c)  
//  2. integers are parsed as (for example) 4, not (Integer 4) ;;optional
//   (we could do this so we can eventually tag integers with other info
//   like precision, accuracy, base)
//  3. integer args to % and # are just lisp integers.
//  4. real numbers like 1.20 are simply (Real 1 20) for the
//    same reason as for integers.
//    (Mathematica has such info stashed away in secret)
//  5. within " " we allow any number of newlines even interactively. M allows 2
//  6. we count lines consisting only of (*comments*) as newlines
//  7 optional.. (commented out) 123`456`789 syntax for long bignumber input
// known bugs or features(?)  1/90
//  we support radix only between 2 and 10; blame it on laziness
//  we do not support non-decimal radix flt. pt; blame it on ditto.
//  we do TagSet slightly differently; ditto
//  fixed bugs/new features  1/91 -- RJF
//  typing nil  provides the symbol False, not nil. I don't know if
//  this is a bug or a feature, though. It means that the parser will
//  not think it has failed to parse a subexpression when it merely 
//  has parsed the symbol nil, so it is convenient, anyway.
//  Mma has the symbol Null, perhaps for similar reasons.
//  fixed 1/28/91
//  fixed the parsing a_:v of which is now
//  (Optional (Pattern a (Blank)) v).
//  fixed the parsing of #1+#2&[a,b] to ((Function (Plus (Slot 1)(Slot 2))) a b)
//  fixed 2/15/91 parsing of a**b followed by eol
//  added 2/3/91
//    'a is same as Quote[a].   f' is derivative, though.  'f'a is
//   (Times (Quote ((Derivative 1)f)) a).  This is not in conflict with mma.
//  added 2/15/91
//  the symbol * can be used, in some circumstances, as a variable name.
//  In those circumstances where it cannot be confused with an operator,
//  it can be used as a symbol.  In some cases it can be used as a symbol
//  even if YOU confuse it.  Advantages: you can use it as a regular-expression
//  tag like  foo[*,3] to denote the 3rd column of a matrix.
//  You can use * * *  to mean  (Times * *)  although  *^2 (Power * 2) also
//  works.  The expressions x * * y and x * * * y mean (Times x * y).
//  The expression ( * * ) means (Times * *)  
//  BUT NOTE  THAT  (* ANYTHING  *)  is A COMMENT !!!!  :) 
//  fixed 5/29/91 from lvi@ida.liu.se 
//  fixed parsing of a+=b;c from a=+(b;c) to (a=+b);c.
//  fixed ++ ++ a also.
//  8/29/91 bug fix from lars viklund (lvi@ida,liu.se)
//  in parse var, replace parse-set by parse-comp (twice)
//  11/23/91 bug fix to repair parsing of 1.004 (was same as 1.4) using 
//    parse-frac. This was pointed out by gotoda@is.s.u-tokyo.ac.jp
//  this next item allows one to do, in lisp, (setq r #mx^2-1
//                                               )
//  10/28/94.  Optionals in patterns were not parsing right  c_. was
//  parsing as (Times c (Optional (Blank))).  It should be
//             (Optional(Pattern C (Blank)))
//  a_:  was parsing as (Optional (Pattern a (Blank))nil) instead of
//                      (Optional (Pattern a (Blank))) . fixed.
set-dispatch-macro-character('#', 'm',
                             method (stream, sub-char, infix-argument)
                               list(#"quote", p(stream));
                             end method);

//  11/18/94
//  had to recompile for new version of allegro common lisp
//  the Alternatives form was added to mathematica... how about for
//  this parser?
//  remove the special meaning of "|" from the emacs reader of lisp code
//  and change it to inherit from the standard syntax table
//
"eof";