;; -*- 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)
#+ignore ;; just use default case
(eval-when (compile load eval)
	   #+Allegro(cond((eq *current-case-mode* :case-sensitive-lower))
			 (t (set-case-mode :case-sensitive-lower))))

(declaim (optimize (speed 3)(safety 0)))

;;(provide 'math-parser)
(eval-when (compile
) (load "mma")) ;; get all the symbols from this file
(in-package :mma)
;;(export '(p  pc rc))

(defvar mathbuffer nil) 
(defvar 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.

(defvar mathrt (copy-readtable nil))
(defvar si (make-synonym-stream '*standard-input*))


(setq *print-level* nil *print-length* nil *print-pretty* t)

(defun pc()(peek-char nil stream nil #\newline))
(defun rc()(read-char stream))

(defun char-to-int (c)  ;; return the integer 0-9 corresponding to
			;; the character c, #\0 - #\9
  ;; will not work in larger bases though..
  (let ((h (char-int c)))
    (cond ((< h 48)(- h 7))  ;; #\A=17
	  ((< h 58)  (- h  48)) ; #\0 is 48 in ascii.
	  (t (- h 87)) ; #\a=97
	     )))
(defun collect-integer (val r)
  (cond ((eql (pc) #\newline) val)
	((digit-char-p (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.
	(t val)))

;; to test scanner, try typing
;;  (mreadl)  

;; most of these read-table entries were generated by macro expansion
(set-macro-character #\/
  #'(lambda 
     (stream char)
     (declare (ignore char))
;;     (format t "processing slash")

     (case (pc)
	   (#\newline '/)
	   (#\: (rc) '|/:|)
	   (#\. (rc) '/.)
	   (#\@ (rc) '/@)
	   (#\; (rc) '|/;|)
	   (#\= (rc) '/=)
	   (#\/ (rc)
		(case (pc) (#\newline '//) (#\@ (rc) '//@) (#\. (rc) '//.) (t '//)))
	   (t '/  )))
  nil mathrt)

(set-macro-character #\^
  #'(lambda 
     (stream char)
     (declare (ignore char))
     (case (pc)
	   (#\newline '^)
	   (#\= (rc) '^=)
	   (#\^ (rc) '^^)
	   (#\: (rc)
		(case (pc) (#\newline '|^:|) (#\= (rc) '|^:=|) (t '|^:|)))
	   (t '^)))
  nil mathrt)

(set-macro-character #\&
  #'(lambda (stream char)
      (declare (ignore char))
      (case (pc) (#\newline '&) (#\& (rc) '&&) (t '&)))
  nil mathrt)

(set-macro-character #\|
  #'(lambda (stream char)
      (declare (ignore char))
      (case (pc) (#\newline '\|) (#\| (rc) '\|\|) (t '\|)))
  nil mathrt)

(set-macro-character #\+
  #'(lambda (stream char)
      (declare (ignore char))
      (case (pc)
		  (#\newline '+) (#\+ (rc) '++) (#\= (rc) '+=) (t '+)))
  nil mathrt)

(set-macro-character #\*
  #'(lambda (stream char)
      (declare (ignore char))
      (case (pc) (#\newline '*) (#\* (rc) '**) (#\= (rc) '*=) (t '*)))
  nil mathrt) 

(set-macro-character #\-
  #'(lambda 
     (stream char)
     (declare (ignore char))
     (case (pc)
	   (#\newline '-) (#\> (rc) '->) (#\= (rc) '-=) (#\- (rc) '--) (t '-)))
  nil mathrt)

(set-macro-character #\[
  #'(lambda (stream char)
      (declare (ignore char))
      (case (pc)
		  (#\newline '[) (#\[ (rc) '[[) (t '[))) 
  nil mathrt)

(set-macro-character #\]
  #'(lambda (stream char)
      (declare (ignore char))
      (case (pc) (#\newline ']) (#\] (rc) ']]) (t '])))
  nil mathrt)

(set-macro-character #\{
  #'(lambda (stream char)
      (declare (ignore char)) 
      '{) ; fixed 2/21/91 lvi@ida.liu.se
  nil mathrt) 

(set-macro-character #\<
  #'(lambda (stream char)
      (declare (ignore char))
      (case (pc) (#\newline '<) (#\= (rc) '<=) (t '<)))
  nil mathrt) 

(set-macro-character #\>
  #'(lambda (stream char)
      (declare (ignore char))
      (case (pc)
		  (#\newline '>)
		  (#\= (rc) '>=)
		  (#\> (rc)
		       (case (pc) (#\newline '>>) (#\> (rc) '>>>) (t '>>)))
		  (t '>)))
  nil mathrt) 

(set-macro-character #\!
  #'(lambda (stream char)
      (declare (ignore char))
      (case (pc) (#\newline '!) (#\! (rc) '!!) (#\= (rc) '!=) (t '!)))
  nil mathrt) 

(set-macro-character #\#
  #'(lambda (stream char)
      (declare (ignore char))
      (case (pc) (#\newline '|#|) (#\# (rc) '|##|) (t '|#|)))
  nil mathrt)

(set-macro-character #\\ 
#'(lambda(stream char)
    (declare (ignore char))
    (case (pc)
	(#\newline (rc) (mread1)) ;; \ at end of line -> splice
	(t (intern (make-string 1 :initial-element (rc))))
	; \ within line, ignore the \ and return the next char
	))
nil mathrt)

(set-macro-character #\= 
  #'(lambda(stream char)
      (declare (ignore char))
      (case (pc)
		 (#\newline '|=|)
		 (#\= (rc) 
		      (case(pc) (#\newline '|==|) (#\= (rc) '|===|) (t '|==|)))
		 (#\! (rc) (case(pc)
				(#\newline '|=!|) ;unused
				(#\= (rc) '|=!=|)
				(t '|=!|)))
		 (t '|=|))) nil mathrt)

(set-macro-character #\. 
  #'(lambda (stream char)
      (declare (ignore char))
      (case (pc)
		  (#\newline '|.|)
		  (#\. (rc) 
		       (case (pc)
			     (#\newline '|..|) (#\. (rc) '|...|) (t '|..|)))
		  (t '|.|)))
  nil mathrt)

(set-macro-character #\:
  #'(lambda (stream char)
      (declare (ignore char))
      (case (pc)
		  (#\newline '|:|)
		  (#\> (rc) '|:>|)
		  (#\: (rc)
		       (case (pc) 
			     (#\newline '|::|) (#\= (rc) '|::=|) (t '|::|)))
		  (#\= (rc) '|:=|)
		  (t '|:|)))
  nil mathrt)

(set-macro-character #\' #'(lambda (stream char)
			     (declare (ignore char))
			     '|'|) nil mathrt) 

(set-macro-character #\@ #'(lambda (stream char)
			     (declare (ignore char))
			     (case (pc) (#\newline '@)(#\@ (rc) '@@)(t '@)))
			     nil mathrt) 
;; above fixed by lvi@ida.liu 3/20/92

(set-macro-character #\~ #'(lambda (stream char)  (declare (ignore char))
			     '~) nil mathrt) 
(set-macro-character #\? #'(lambda (stream char)  (declare (ignore char))
			     '?) nil mathrt) 
(set-macro-character #\) #'(lambda (stream char)  (declare (ignore char))
			     '|)|) nil mathrt) 
(set-macro-character #\} #'(lambda (stream char)  (declare (ignore char))
			     '}) nil mathrt) 
(set-macro-character #\; #'(lambda (stream char)  (declare (ignore char))
			     '|;|) nil mathrt) 
(set-macro-character #\, #'(lambda (stream char)   (declare (ignore char))
			     '|,|) nil mathrt) 
(set-macro-character #\newline #'(lambda(stream char)  (declare (ignore char))
				   'e-o-l) nil mathrt)

(mapc #'(lambda(x) (setf (get x 'mathtoken) t))
      '(/ |/:| /. /@ |/;| /= // //@ //.
	  ^ ^= ^^ |^:=| |^:| 
	  & && \| \|\| + ++ +=  ** *= 
	  - -> -= -- [ [[ ] ]] { } > >= >> >>> < <=
	  ! !! != 
	  |#| |##|
	  |:=| |:>|  |::| |::=| |:|
	  |=| |==| |===| |=!=|
	  |.| |..| |...| \\ 
	  e-o-l |(| |)|
	  |'| @ ~ ? |;| |,|))

;;  Extension.  This allows us to use foo[*,1]*bar[1,*] notationally.
;; also a * *  means  (Times a *)
;;(setf (get '* 'mathtoken t))

(set-macro-character #\_
		     #'(lambda (stream char &aux next)
			 (declare (ignore char))
	    (case
	     (pc)
	     (#\Newline '(Blank))  ; _
	     (#\. (rc)
		  '(Optional (Blank)))  ;_.
	     (#\_ (rc)
		  (case
		   (pc)
		   (#\Newline '(BlankSequence))  ;__
		   (#\_
		    (rc)  ;___ (3 of em)
		    (cond ((and (alpha-char-p (pc))
				(setq next(rt)))
			   `(BlankNullSequence ,next))
			  (t '(BlankNullSequence)))) 
		   (t  ;; __ (2 of em)
		       (cond ((and (alpha-char-p (pc))
				   (setq next(rt)))
			      `(BlankSequence ,next))
			     (t '(BlankSequence))) 
		       )))  
	     (t ; _ (1 of em)
		(cond ((and (alpha-char-p (pc))
			    (setq next(rt)))
		       `(Blank ,next))
		      (t '(Blank))))))
  nil
  mathrt)

;; left paren could start a comment


(defun sawlpar (stream char)  ;; comments are (* any text *)
  (declare (ignore char))
  (case (pc)
	(#\* ;skip to end of comment
	     (rc)
	     (commentskip stream))
	(t '\())) ;)

(set-macro-character #\( #'sawlpar nil mathrt)  ;)

;; the use of the % character is peculiar.
(set-macro-character #\% 
  #'(lambda(stream char)
      (declare (ignore char))
      (cond((eq(pc) #\%) (parse-outform1 2))
		((digit-char-p (pc))
		 `(Out,(collect-integer 0 10)))
		(t '(Out))))
  nil mathrt)

(defun parse-outform1(counter) ; saw more than one % 
	 (rc)
	 (cond ((equal (pc) #\%) (parse-outform1 (+ 1 counter))) ;another %
	       (t `(Out ,(- counter)))))
  

(defun commentskip (stream &aux x )
  (loop
   (setq x (rc))
   (cond ((eql x #\( ) (sawlpar stream x))  
	 ((and (eql x #\* )
	       (eql (pc) #\) ))
	 (rc) ; flush the last leftpar
	 (return(mread1)))   ;return next item
   )))
 
;;; 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)

(defvar 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"))

(defun ps(stream  &aux (interactive nil) res (*readtable* mathrt)(mathbuffer nil)z)

  (rt)
  (loop (setq res (catch 'endofparse(parse-comp t)))  ;; end=t means a #\newline will end expr.
  (print (cond ;((null res) (return 'done))
	      ((eq #\newline (pc)) 
	       (rc) 
	       res) ;; proper ending
	       ((setq z(rt))
	       (cond ((equal z 'e-o-l))  ;;may also be proper ending
		     (t(format t "~%garbage at end of expression:~s~%" z )))
		 res)))))




;mreadl is a debugging loop that just reads lexemes until it reads done

(defun mreadl(&aux (stream *standard-input* ) next (*readtable* mathrt))
  (loop 
   (setq next (mread1))
   (when (eq  next 'e-o-l) (return 'done))
   (print next)))

(defmacro rt()`(cond((null mathbuffer)(mread1))
		(t (prog1 mathbuffer (setq mathbuffer nil )))))

(defmacro eolp(end) ;;used all over to see if we've reached an end of line
  `(and ,end (eq 'e-o-l (peek-token))))

;; 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.
(defun mread1()
;    (format t "~% next char = ~s" (pc)) ;; debug
  (cond ((member (pc)'( #\space #\tab #\page) :test #'char=)
	 (rc)(mread1))  ;; fix - 2x bug
	((digit-char-p (pc));; next character is a digit 0-9
	 (collect-integer 
	  (char-to-int(rc)) 10)
	 )
				;radix 10 default
	(t (or(read-preserving-whitespace stream nil 'e-o-l) 'False)
	   ;; nil reads as False
	   )))

(defun p (&optional(stream *standard-input*) 
		  &aux (interactive t)
		  res
		  (*readtable* mathrt)
		  (mathbuffer nil))
;  (rt) ;;get something in mathbuffer
  (setq res (catch 'endofparse (parse-comp t)))  ;; end=t means a #\newline will end expr.
  (cond((eq mathbuffer 'e-o-l)  (if res res 'Null)) ;; proper ending
       (t (format t "~%Unexpected token at end of expression:~s~%" mathbuffer)
	  res)))

(defun peek-token() (cond(mathbuffer)
			 (t (setq mathbuffer(mread1)))))

(defun parse-nary1 (res tag)
  (cond ((null(cdr res))(car res))
	(t (cons tag (nreverse res)))))

(defun guess-token (guess &aux (tok (peek-token)))
  (cond((eql guess tok) t)
       ((eql 'e-o-l tok)(rt)
	(if (and interactive (eql'e-o-l (peek-token))) ;; if two in-a-row; get outta here
	    (throw 'endofparse nil)))))

;; a variable is any symbol that looks like a lisp symbol and
;; is not an integer or string, or a pattern-var

(defun var-p(token)
  (or (consp token) ;; case of (blank)
      (and 
       (not (integerp token))
       (not (eql token 'e-o-l))
       (or (stringp token) (not (get token 'mathtoken))))))

;; is Head one of the pattern items "blank..."
(defun blankp(token)
  (and(not (atom token))
      (member (car token) '(Blank BlankSequence  BlankNullSequence) :test #'eql)))


;; parse a number
(defun parse-number(end &aux (x (parse-int end)) afterdot) ;; reads floats and radix nums also
  (cond (x
	 (cond 
	  ((equal (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?
	   (cond((digit-char-p (pc))
		 (setq afterdot (parse-frac end))
		 (cond (afterdot (make-real x afterdot)) ;;like 12.34
		       (t x)));      not a float -> return integer
		(t (make-real x 0)) ;a float of the form 1. 
		))
	  (t x))) ;;x is an integer, but no "." follows
	;; still, we must check for  a number of the form .123
	((guess-token '|.|)
	 (rt)
	 ;;is there a digit next?
	 (cond((digit-char-p (pc))
	       (setq afterdot (parse-frac end))
	       (cond (afterdot (make-real 0 afterdot)) ;;like 0.34
		     (t "what's a dot doing here?")))));; we could make it 0?
	(t nil) ))



;;parse an integer, including radix

(defun parse-int(end &aux (x (peek-token))) 
  (cond 
   ((integerp x)
	 (cond
	  ((eolp end) x)
	  ((and (rt) (eql (pc) #\^) ;; don't sop up extra spaces here. what if 1 .2
		(guess-token '|^^|)) ;; see if it is, e.g. 8^^101 =65
	   (rt)
	   (cond((or (> x 10)
		     (< x 2))
		 (format t "radix ~s ?~%" x)))
	   (collect-integer 0 x))
	  (t x))) ;; ok, no radix stuff -- just return x
	(t nil)))

;; parse the fraction part of a decimal number .123

(defun parse-frac(end &aux x (num 0)(den 1))
 (loop
   ;; since all of the line termination chars are not digits, all we
   ;; need to check is for digits..
   (if  (not(setq x(digit-char-p (pc)))) (return (/ num den)))
   (rc) ;; read past the char
   (setq den (* den 10))
   (setq num (+ (* 10 num) x))
))

;; this is a stub until we decide what to really do here
(defun make-real (x y) `(|Real| ,x ,y))

;; parse lists delimited by [] [[]]{}  tricky to  handle f[g[x]].
(defun parse-list (&optional op &aux next)
  (setq next (peek-token))
  (cond ((equal next '|[[|)
         (rt)
         (parselist1 (list op 'Part) '|]]|))
        ((equal next '\[)
         (rt)
         (parselist1 (list op) '\]))
        ((equal next '\{)
         (rt)
         (parselist1 (list 'List) '\}))))

(defun parselist1 (sofar endmark &aux next) ;; we want to find an expression
  (setq next (peek-token))
  (cond ((eq next '\,)
	 (rt);; get past the comma
	 (parselist1 (cons nil sofar) endmark))
	((eq next endmark)
	 (rt);; get past the endmark [a,b,]
	 (cond ((null (cdr sofar)) sofar ) ;; f[] -> (f)
	       (t(nreverse (cons nil sofar)))))
	((and(eq endmark '\]) ;; we might find a '|]]|
	     (parse-list-hack next (cons nil sofar))))
	((setq next (parse-comp nil)) ;; end=nil; can't end with just #\newline
	 (parselist2 (cons next sofar) endmark))
	(t (error "parse-list: looking for a comma, expression or endmark"))
	))
(defun parse-list-hack(next sofar) ;make f[g[h]] work ok by parsing as
  ;; f[g[h] ]
  (cond ((equal next '\])
	 (rt)
	 (nreverse sofar))
	((equal next '|]]|)
	 (setq mathbuffer '\]) ; one '\] left over for f[g[h]]
	 (nreverse sofar))))

(defun parselist2 (sofar endmark &aux next) ;; we want to find , or close mark
  (setq next (peek-token))
  (cond ((equal next '\,)
	 (rt);; get past the comma
	 (parselist1 sofar endmark))
	((equal next endmark) (rt) (nreverse sofar ))
	((and(equal endmark '\]) ;; we might find a '|]]|
	 (parse-list-hack next sofar)))
	(t (error "parse-list: looking for a comma, expression or endmark"))
	))

;;comparison operators
(setf (get '== 'compop) '|Equal|)
(setf (get '!= 'compop) '|Unequal|)
(setf (get '< 'compop) '|Less|)
(setf (get '<= 'compop) '|LessEqual|)
(setf (get '> 'compop) '|Greater|)
(setf (get '>= 'compop) '|GreaterEqual|)
(setf (get '=== 'sameop) '|SameQ|)
(setf (get '=!= '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)

(defun parse-or (end &aux (temp (parse-and end)) res)  ; E::=e1||e2  n-ary
  (cond ((eolp end) temp)
	(temp
	 (cond ((guess-token '\|\|) ;;check first to avoid consing
		(setq res (cons temp nil))
		(loop
		 (cond ((eolp end) (return(parse-nary1 res '|Or|)))
		       ((guess-token  '\|\|)
			(rt)
			(setq res (cons (parse-and end) res)))
		       (t (return(parse-nary1 res '|Or|)))
		       )))
	       (t temp)))
	(t nil) ; not an or-expression
	))

(defun parse-and (end &aux (temp (parse-not end)) res)  ; E::=e1 && e2  n-ary  (And)
  (cond ((eolp end) temp)
	(temp
	 (cond ((guess-token '&&) ;;check first to avoid consing
		(setq res (cons temp nil))
		(loop
		 (cond ((eolp end)(return(parse-nary1 res '|And|)))
		       ((guess-token  '&&)
			(rt)
			(setq res (cons (parse-not end) res)))
		       (t (return(parse-nary1 res '|And|)))
		       )))
	       (t temp)))
        (t nil) ; not an and-expression
))

(defun parse-not(end)
  (cond((eolp end) nil)
       ((guess-token '|!|) ;; Not
	 (rt)
	 `(Not ,(parse-not end)))
	(t (parse-same end))))

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

(defun parse-same (end &aux (temp (parse-equal end))res op)  ; E::=e1 ===e2 etc
  (cond ((eolp end) temp)
	(temp
	 (setq op (peek-token))
	 (cond ((and (atom op)(get op 'sameop)) ;; check before cons
		;;SameQ
		(setq res (cons temp nil))
		(loop
		 (cond ((eolp end) 
			(return (patch-equal(parse-nary1 res 'Inequality))))
		       ((and (atom (setq op (peek-token)))
			     (setq op (get op 'sameop)))
			(rt)
			(setq res (cons (parse-equal end) (cons op res))))
		       (t (return (patch-equal(parse-nary1 res 'Inequality))))
		       )))
	       (t temp)))
	(t nil) ; not a SameQ  or UnSameQ
	))

(defun parse-equal (end &aux (temp (parse-plus end))res op)  ; E::=e1 compop e2  n-ary  (==, etc)
  (cond ((eolp end) temp)
	(temp
	 (setq op (peek-token))
	 (cond ((and (atom op)(get op 'compop)) ;; check before cons
		;;Unequal, for example
		(setq res (cons temp nil))
		(loop
		 (cond ((eolp end) (return (patch-equal(parse-nary1 res 'Inequality))))
		       ((and (atom (setq op (peek-token)))
			     (setq op (get op 'compop)))
			(rt)
			(setq res (cons (parse-plus end) (cons op res))))
		       (t (return (patch-equal(parse-nary1 res 'Inequality))))
		       )))
	       (t temp)))
	(t nil) ; not an equal  or inequal -expression
	))
(defun patch-equal(h)
  (if (= (length h) 4)(list (caddr h) (cadr h)(cadddr h)) h))
;; arithmetic expression

(defun parse-plus (end &aux (temp (parse-times end)) res); E::=T1{+T2} | T1{-T2}
  (cond (temp
	 (cond 
	  ((eolp end) temp)
	  ((or (guess-token '+)(guess-token '-))
	   (setq res (cons temp nil))  
	   (loop
	    (cond ((eolp end) (return (parse-nary1 res 'Plus)))
		  ((guess-token '+)
		   (rt)
		   (setq res (cons (parse-times end) res)))
		  ((guess-token '-)
		   (rt)
		   (setq res (cons 

			      (let ((h (parse-times end)))
				(if (numberp h) (- h)
				  `(Times   -1 ,h)
				     )) res)))
		  (t (return(parse-nary1 res 'Plus))))))
	  (t temp)))
	(t nil)) ; not a  Plus expr
  )

(defun parse-comp (end &aux temp res )  ; E::=E;E;  | E;
  (cond ((setq temp (parse-put end))
	 (cond ((eolp end) temp)
	       ((guess-token '|;|) ;;check first to avoid consing
		(setq res (cons (if temp temp 'Null) nil))
		(loop
		 (cond ((eolp end) (return(parse-nary1 res 'CompoundExpression)))
		       ((guess-token  '|;|)
			(rt)
			(setq res (cons (or(parse-put end) 'Null) res)))
		       (t(return (parse-nary1 res 'CompoundExpression))))))
	       (t temp)))
	(t nil)) ; not a compound expr -- something wrong --
  )



(defun parse-put( end &aux (temp (parse-set end))) ; e >> file or e>>>file
  (cond(temp
	(cond((eolp end) temp)
	     ((guess-token '>>)(rt)`(Put ,temp ,(rt)))
	     ((guess-token '>>>)(rt)`(PutAppend ,temp ,(rt)))
	     (t temp)))
       (t nil)))

;;replace is left-assoc    e /. e   |  e//.e

(defun parse-replace( end &aux(temp(parse-rule end)))
  (cond (temp (parse-replace1 temp end))
	(t nil)))

(defun parse-replace1(temp end)
  (cond ((eolp end) temp)
	((guess-token '|/.|)
	 (rt)
	 (parse-replace1 `(ReplaceAll ,temp ,(parse-replace end)) end))
	((guess-token '|//.|)
	 (rt)
	 (parse-replace1 `(ReplaceRepeated ,temp ,(parse-replace end)) end))
	(t temp)))

(defun parse-rule(end &aux (temp (parse-condition end)))  ;e->(e->e) etc
  (cond(temp (cond ((eolp end) temp)
		   ((guess-token '|->|)
		    (rt)
		    `(Rule ,temp ,(parse-rule end)))
		   ((guess-token '|:>|)
		    (rt)
		    `(RuleDelayed ,temp ,(parse-rule end)))
		   (t temp)))
       (t nil)))

;;condition is left-assoc
(defun parse-condition( end &aux(temp(parse-repeated end)))
  (cond (temp (parse-condition1 temp end))
	(t nil)))

(defun parse-condition1(temp end)
  (cond ((eolp end) temp)
	((guess-token '|/;|)
	 (rt)
	 (parse-condition1 `(Condition ,temp ,(parse-repeated
					      end)) end))
	(t temp)))


(defun parse-repeated(end &aux (temp (parse-or end)))
  (cond (temp 
	 (cond((eolp end) temp)
	      ((guess-token '|..|)(rt)`(Repeated ,temp))
	      ((guess-token '|...|)(rt)`(RepeatedNull ,temp))
	      (t temp)))
	(t nil)))


(defun parse-addto(end &aux (temp (parse-replace end)))
  ;; bug noticed by /fixed by lvi@ida.liu.se
  (cond (temp
	 (cond 
	  ((eolp end) temp)
	  ((guess-token '|+=|)(rt)`(AddTo ,temp ,(parse-addto end)))
	  ((guess-token '|*=|)(rt)`(TimesBy ,temp ,(parse-addto end)))
	  ((guess-token '|-=|)(rt)`(SubtractFrom ,temp ,(parse-addto end)))
	  ((guess-token '|/=|)(rt)`(DivideBy ,temp ,(parse-addto end)))
	  (t temp)))
	(t nil)))


(defun parse-set(end &aux (temp (parse-// end)) )
  (cond (temp
	 (cond ((eolp end) temp)
	       ((guess-token '=)(rt)
		(cond ((guess-token '|.|)(rt)`(UnSet ,temp))
		      (t`(|Set|,temp ,(parse-set end)))))
	       ((guess-token '|:=|)(rt)`(SetDelayed ,temp ,(parse-set end)))
	       ((guess-token '^= ) (rt)`(UpSet ,temp ,(parse-set end)))
	       ((guess-token '|^:=| ) (rt)`(UpSetDelayed ,temp ,(parse-set end)))
	       ((guess-token '|/:| ) (rt)`(TagSet ,temp ,(parse-set end)))
	       ;;actually, Mathematica uses TagSet Delayed, Un. 
	       ((guess-token '|::=| ) (rt)
		(cond 
		 ((guess-token '|.|)(rt)`(UnAlias ,temp))
		 (t`(Alias ,temp ,(parse-set end)))))
	       (t temp)))
	(t nil)))

;; f&[a,b] --> ((Function f) a b)
(defun parse-ampersand(end &aux temp)
  (cond((setq temp (parse-addto end))
	(cond ((eolp end) temp)
	      ((eq (peek-token) '\&) (rt)(parse-fun1 `(Function ,temp) end))
	      (t temp)))
       (t nil)))

;;left associative  e1//e2  
(defun parse-//(end &aux (temp (parse-ampersand end)))
  (cond (temp
	 (cond ((eolp end) temp)
	       ((guess-token '|//|)(rt)
		(parse-//1 `(,(parse-ampersand end) ,temp) end))
	       (t temp)))
	(t nil)))

(defun parse-//1(sofar end) 
  (cond ((eolp end) sofar)
	((guess-token '|//|) 
	 (rt)
	 (parse-//1 `(,(parse-ampersand end) ,sofar) end))
	(t sofar)))
  

;;; hacked to eliminate 1/a -> (* 1 (expt a -1)) in favor of
;;; just (expt a -1).  4/26/96 RJF Fixed 5/3/96 to really work. I hope.


(defun parse-times(end &aux (temp (parse-unary end))res) ;
  ;  t::=f1{*f2} | f1{/f2} |  f1 <space> f2   
  (cond ((eolp end) temp)
	(temp 
	 (setq res (cons temp nil))
	 (loop
	   (cond ((eolp end)
		 ; (format t "~%hah res=~s" res)
		  (return (parse-nary1 
				     ;; remove extra 1* stuff
				   (if  (cdr res)  (remove 1 res)
				       res) ;; was just res, 4/26/96
				     'Times)))
		((guess-token '*)
		 (rt)
		 ;; a * !b+c is (Times a (Not (Plus b c)))
		 (setq res (cons (parse-unary end)res)))
		((guess-token '/)
		 (rt)
		 ;;; patch for numbers 1/2 rather than (Power 2 -1)*******

    (let ((denom (parse-unary end)))
		   (setf res
		     (if (numberp denom)
			 (if (numberp (car res))
			     ;; combine numerator and denominator, numerically
			     (cons (/ (car res) denom) (cdr res))
			   ;; just tack on number like 1/2
			   (cons (/ 1 denom) res))
			   
		       (cons  `(Power ,denom -1) res)))
		   
		   )
    ;; old version
	;;	 (setq res (cons `(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
		
		((setq temp (parse-power end)) (setq res (cons temp res)))
		(t (return (parse-nary1  (if (cdr res)  (remove 1 res)
				       res) 'Times))))))
	(t nil) ; not a term
	))
#+ignore
;;; old version
(defun parse-times(end &aux (temp (parse-unary end))res)  ;
  ;  t::=f1{*f2} | f1{/f2} |  f1 <space> f2   
  (cond ((eolp end) temp)
	(temp 
	 (setq res (cons temp nil))
	 (loop
	  (cond ((eolp end)(return (parse-nary1 res 'Times)))
		((guess-token '*)
		 (rt)
		 ;; a * !b+c is (Times a (Not (Plus b c)))
		 (setq res (cons (parse-unary end)res)))
		((guess-token '/)
		 (rt)
		 ;; patch 1/11/96 RJF to make 1/2 come out as 1/2
		 ;; rather than (Times 1(Power 2 -1)).
		 ;; This helped in a pattern matching application
		 ;; so I put it in here too.
		 (let ((denom (parse-unary end)))
		   (setf res
		     (if (numberp denom)
			 (if (numberp (car res))
			     ;; combine numerator and denominator, numerically
			     (cons (/ (car res) denom) (cdr res))
			   ;; just tack on number like 1/2
			   (cons (/ 1 denom) res))
		       (cons  `(Power ,denom -1) res))))
		 ;; previously I just did this...
		 ;;(setq res (cons `(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
		
		((setq temp (parse-power end)) (setq res (cons temp res)))
		(t (return (parse-nary1 res 'Times))))))
	(t nil) ; not a term
	))

(defun parse-unary (end &aux)  ; E::=+T | -T
  (cond ((guess-token '+)(rt)(parse-unary end)) ;unary +
	((guess-token '-)(rt)
	 (let ((h (parse-unary end)))
	   (if (numberp h) (- h)
	     `(Times -1 ,h))))
	((guess-token '|!| )(parse-not end))
	;;; extra added attraction!!  'foo  -> (Quote foo)
	((guess-token '|'|) (rt)`(Quote, (parse-unary end)))
	(t (parse-power end))))
  
(defun parse-power (end &aux (temp (parse-dot end)))  ; f ::= p^f | p
  (cond ;((eolp end) temp)
   (temp
    (cond ((eolp end) temp)
	  ((guess-token '^)
	   (rt)
	   `(Power ,temp ,(parse-unary end))) ;;really going up the precedence
	  (t temp)))
   (t nil)))


(defun parse-dot (end &aux (temp (parse-ncm end))res)  ; E::=e1 . e2  n-ary  dot
  (cond (temp
	 (cond ((eolp end) temp)
	       ((guess-token '|.|) ;;check first to avoid consing
		(setq res (cons temp nil))
		(loop
		 (cond ((eolp end) (return (parse-nary1 res 'Dot)))
		       ((guess-token  '|.|)
			(rt)
			(setq res (cons (parse-ncm end) res)))
		       (t (return (parse-nary1 res 'Dot))))))
	       (t temp)))
	(t nil) ; not a dot-expression
	))

(defun parse-ncm (end &aux (temp (parse-fact end)) res) ; E::=e1 ** e2  n-ary  
  (cond (temp
	 (cond ((eolp end) temp)
	       ((guess-token '**) ;;check first to avoid consing
		(setq res (cons temp nil))
		(loop
		 (cond 
		  ((eolp end)
		   (return 
		    (parse-nary1 res
				 'NonCommutativeMultiply)))
		  ((guess-token  '**)
			(rt)
			(setq res (cons (parse-fact end) res)))
		  (t (return (parse-nary1 res 'NonCommutativeMultiply))))))
	       (t temp)))
        (t nil) ; not a **-expression
))


;;factorial is left-associative  a ! !  means (a!)!

(defun parse-fact (end &aux (temp (parse-map end))) ;  d ::= m | m! | m!!
  (cond (temp (parse-fact1 temp end))
	(t nil)))

(defun parse-fact1 (temp end) ;  d ::= m | m! | m!!
  (cond((eolp end) temp)
       ((guess-token '|!|)
	(rt)
	(parse-fact1 `(Factorial ,temp) end))
       ((guess-token '|!!|)
	(rt)
	(parse-fact1 `(Factorial2 ,temp) end))
       (t temp)))

(defun parse-map 
  (end &aux (temp (parse-tilde (parse-at end) end))) ;  d ::= t | t /@ expr
  (cond ((eolp end) temp)
	(temp
	 (cond ((guess-token '|/@|)
		(rt)
		`(Map  ,temp ,(parse-map end)))
	       ((guess-token '|//@|)
		(rt)
		`(MapAll  ,temp ,(parse-map end))) 
	       ((guess-token '|@@|)
		(rt)
		`(Apply  ,temp ,(parse-map end)))
	       (t temp)))
	(t nil)))


(defun parse-tilde(sofar end &aux op last )
  (cond ((null sofar)nil)
	((eolp end) sofar)
	(t(cond ((and 
		  (guess-token '|~|) (rt)
		  (setq op (parse-at nil))
		  (guess-token '|~|)(rt)
		  (setq last (parse-at end)))
		 (parse-tilde `(,op ,sofar ,last) end))
		(t sofar)))))

(defun parse-precrement(end);; look for ++a or --a  ;lvi fix for ++ ++ a
	 (cond ;((eolp end) nil)
	       ((guess-token '|++|)(rt) `(PreIncrement ,(parse-precrement end)))
	       ((guess-token '|--|)(rt) `(PreDecrement ,(parse-precrement end)))
	       (t (parse-fun end))))

(defun parse-pattest(end &aux (temp (parse-var end))) ; patterntest  is e1?e2
  (cond (temp
	 (cond ((eolp end) temp)
	       ((guess-token '\?)
		(rt)
		`(PatternTest ,temp ,(parse-var end)))
	       (t temp)))
	(t nil)))

(defvar rpar '\) )
(defvar lpar '\( )

;;parse-optional looks for Optional   a_:v is (Optional(Pattern a (Blank)) v)

(defun parse-optional (end &aux (temp (parse-pattest end)))
  (cond (temp 
	 (cond
	       ((eolp end) temp)
	       ((guess-token '\:)
		(rt)
		(list 'Optional temp (parse-comp end)))
	       (t temp)))
      (t temp)))

  ; var ::=  var_ etc| #var | _ | __ | ___ | patternstuff  | var :: string
  ;( stuff ) |  ( a , ....) | { a , ...} | number 

(defun parse-var (end &aux (next (peek-token)))  
  (cond ((eql next 'e-o-l)
	 (rt)
	 (setq next (peek-token))
	 (cond ((eql next 'e-o-l) nil)
	       (t (parse-var end))))
	((var-p next)
	 (rt)
	 (cond ((eolp end) next)
	       ((blankp (peek-token))
		(list 'Pattern next (rt)))
	     
	       ((guess-token '|::|) (rt) (list 'MessageName next (rt)))
	       ((guess-token '|:|)(rt)(list 'Pattern next (parse-repeated end)))
	       (t next)))
	((equal next lpar) ;; look for (expr)
	 ;; actually  (a,b,..), a Sequence is not accepted in 2.0, but in 1.2
	 (rt)
	 (setq next (parse-comp nil))
	 (cond ((guess-token rpar)
		(rt)
		next)
	       ((parselist2 (list next 'Sequence) rpar))
	       (t (error "too few rpars"))))
	((equal next '{) (rt) ;; look for List
	 (cond ((guess-token '})
		(rt)
		(list 'List))
	       ((setq next (parse-comp nil)) ;lvi 8/29
		(parselist2 (list next 'List) '}))
	       (t
		(error "too few right-}"))))
	((equal next '|#|)
	 (parse-slotform 'Slot end))
	((equal next '|##|)
	 (parse-slotform 'SlotSequence end))
#+ignore	((and (setq hh (peek-token)) (format t "hh=~s" hh)
	      (equal hh'(Optional (Blank))))
	 (rt)  ;;example x_.   3/30/92
	 `(Optional(Pattern ,next (Blank))))
	 
	((setq next (parse-number end))
	 ;;(if (atom next) (list 'Integer next) next);;tags integers specifically
	 next;; just leaves integers as self-declared, exact.
	 )
	(t nil)))

;; # means (Slot 1) ## means (SlotSequence 1)
;; #2 means (Slot 2) etc.

(defun parse-slotform(head end &aux var)
  (rt) ;; sop up # or ##
  (cond((null (setq var(parse-int end)))`(,head 1))
       (t `(,head ,var))))


(defun parse-at (end &aux (var (parse-precrement end))) 
  ;; collect e1 @ e2 | e++ | e--
  (cond (var 
	 (cond ((eolp end) var) 
	       ((guess-token `|@|) (rt) `(,var ,(parse-at end)))
	       ((guess-token '|++|) (rt) `(Increment ,var)) 
	       ((guess-token '|--|) (rt) `(Decrement ,var))
	       (t var)))
	(t nil)))

;; parse-fun collects f[x] or similar; also a++
;; it is left-assoc.  f[x]=(f x);  f[x][y] = ((f x) y)

(defun parse-fun(end &aux (temp(parse-optional end)))
  (cond (temp (parse-fun1 temp end))
	(t nil)))

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



(defun parse-fun1(sofar end)
  (cond((eolp end) sofar)
       ;; handle the derivative cases
       ((eq (peek-token) '|'|)
	(do ((i 0 (1+ i)))
	    ((or (eolp end)(not (guess-token '|'| )))
	     (parse-fun1  `((Derivative ,i) ,sofar) end))
	    (rt)))
       ;; handle the function invocation f[x] and part .. f[[1]]
       ((member(peek-token) '(\[ |[[|) :test #'eq)
	(parse-fun1(parse-list sofar) end));; f[], f[x] or maybe (f[x])[y]  etc.


       (t sofar)))


;;     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
;;                                              )
(set-dispatch-macro-character #\# #\m
      #'(lambda (stream sub-char infix-argument)
         (declare (ignore sub-char infix-argument))
         (list 'quote(mma::p stream) )))





#|
(break 'hi)
|#