;; -*- 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
(defmacro rt()`(cond((null mathbuffer)(mread1))
(t (prog1 mathbuffer (setq mathbuffer nil )))))
;; 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)))
;; test for eof on stream
(if (eq 'eof (peek-char nil stream nil 'eof))(return 'done))
))
;;; same as ps, but translate to macsyma.
(defun pst(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 (tomacsyma
(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))))
;; test for eof on stream
(if (eq 'eof (peek-char nil stream nil 'eof))(return 'done))
))
(defparameter macsubs
'((Set . (maxima::msetq))
(SetDelayed . (maxima::mdefine))
(Equal . (maxima::mequal))
(if . (maxima::mif))
(Pattern . (maxima::$Pattern)) ; hardly enough
(Blank . (maxima::$Blank))
(Increment . (maxima::$Increment))
(Part . (maxima::$Part))
(Greater . (maxima::mgreaterp))
(GreaterEqual . (maxima::mgeqp))
(LessEqual . (maxima::mleqp))
(Plus . (maxima::mplus))
(Times . (maxima::mtimes))
(Module . (maxima::mprog))
(List . (maxima::mlist))
(CompoundExpression . (maxima::mprogn))))
(defun tomacsyma(r)
(cond ((numberp r) r)
((symbolp r)
(let ((l (assoc r macsubs)))
(cond (l (cdr l)) ;found a translation
(t (intern (format nil"$~a"r)))))) ;; a symbol foo -> $foo or |$foo| perhaps
;; here we should check for while, for, other complex stuff
(t (mapcar #'tomacsyma r))))
;; . while, for, ordinary function calls.
;; while n>0 do (print(n),n:n-1) looks like this...
; ((MDO) NIL NIL NIL NIL NIL ((MNOT) ((MGREATERP) |$n| 0))
; ((MPROGN) (($PRINT) |$n|) ((MSETQ) |$n| ((MPLUS) |$n| ((MMINUS) 1)))))
;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 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)
|#