(in-package :mma)
;; -*- 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)
;; parts of syntax in version 7 currently missing in this parser:
;; span e[[i;;j]] which is Part[e,Span[i,j]]
;; stringjoin a<>b
;; "scientific notation" 34*^10
;; base.. b^^nnn
;; symbol in context vv`nn [requires introducing name spaces?]
;; continuing at end of line \
;; The rule for ending a line iff the expression is apparently complete
;; is unreliable.
#+ignore ;; just use default case ??
(eval-when (:compile-toplevel :load-toplevel :execute)
#+:allegro(cond((eq *current-case-mode* :case-sensitive-lower))
(t (set-case-mode :case-sensitive-lower)))) ;sort-of works but is it cons or CONS
(declaim (optimize (speed 3)(safety 0)))
;;(provide 'math-parser)
(eval-when (:compile-toplevel) (load "mma")) ;; get all the symbols from this file
;;(export '(p pc rc))
(defvar mathbuffer nil)
(defvar mmastream 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))
#-GCL (setf (readtable-case mathrt) :preserve) ;gcl currently has no readtable-case
(defvar si (make-synonym-stream '*standard-input*))
(setq *print-level* nil *print-length* nil *print-pretty* t)
(defun mysignal(&rest f) (apply #'format (cons t (cdr f)))(signal (car f)))
(defun pc()
(declare (special mmastream))
(peek-char nil mmastream nil 'e-o-l nil))
;;(defun pc()(peek-char nil stream nil #\newline))
(defun rc()
(declare (special mmastream))
(read-char mmastream nil 'e-o-l))
;;an idea that won't work to echo because we read with read-preserving-white-space, mostly, not rc
#+ignore (defun rc()(princ (read-char stream nil 'e-o-l)))
(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 ((member (pc) '(e-o-l #\newline):test 'eql) 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)
#+ignore ;; don't allow [[ as a token
(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))
'[)
nil mathrt)
#+ignore
(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))
'])
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 (typep (pc) 'character)(alpha-char-p (pc))
(setq next(rt)))
`(|BlankNullSequence| ,next))
(t '(|BlankNullSequence|))))
(t ;; __ (2 of em)
(cond ((and (typep (pc) 'character)(alpha-char-p (pc))
(setq next(rt)))
`(|BlankSequence| ,next))
(t '(|BlankSequence|)))
)))
(t ; _ (1 of em)
(cond ((and (typep (pc) 'character)(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))
((and (typep (pc) 'character)(digit-char-p (pc))) ;in case (pc) is e-o-l
`(|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(mmastream &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 mmastream nil 'eof))(return 'done))
))
;; Starting from a character string,
;; parse it into a single (Mock) Mathematica expression
;; and return a lisp expression.
(defun pstring(string &aux (interactive nil)
(*readtable* mathrt)
(mathbuffer nil)
)
(ps (make-string-input-stream string)))
;;; same as ps, but translate to macsyma.
;;; not really useful except as toy demo
(defun pst(mmastream &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 (mma2max
(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 mmastream nil 'eof))(return 'done))
))
#+ignore ;; see mma2max in file mma2maxfun.lisp
(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
#+ignore
(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.
;;; this program will ordinarily be overwritten by mread1 in eval.lisp.
(defun mread1()
; (format t "~% next char = ~s" (pc)) ;; debug
(cond ((eq 'e-o-l (pc) ) '|Null|) ;;???
((digit-char-p (pc));; next character is a digit 0-9
(collect-integer
(char-to-int(rc)) 10) )
;radix 10 default
(t (let* ((rr (read-preserving-whitespace mmastream nil 'e-o-l))
(c(chash #+:allegro rr
#-:allegro (recase rr))))
c)
;; 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: ~a~%" mathbuffer)
(mysignal 'syntax-error)
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((eq (p) 'e-o-l) (make-real x 0))
((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((eq (p) 'e-o-l) (make-real x 0))
((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))
(declare(ignore end))
(loop
;; since all of the line termination chars are not digits, all we
;; need to check is for digits.. but digit-char-p errs out for non-characters. ugh. e-o-l not char
(if (or (eql (pc) 'e-o-l)(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]].
;; there are two possibilities here f [ [ X ] ] which is (Part f X)
;; and f [ X ] which is (f X)
(defun parse-list (&optional op &aux next)
(setq next (peek-token))
(cond ((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 '[) ;;create a Part, and absorb an extra '] at the end
(rt)
(prog1 (cons '|Part|
(parselist1 sofar
endmark))
; (format t "~%sofar =~s" sofar)
(if (eq(peek-token) '])
(rt)
(mysignal 'syntax-error "unmatched ]] at ~s" (car sofar)))))
((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))
;; (print 'xx)
sofar ) ;; f[] -> (f).
(t(nreverse (cons '|Null| sofar)))))
((setq next (parse-comp nil)) ;; end=nil; can't end with just #\newline
(parselist2 (cons next sofar) endmark))
(t (mysignal 'syntax-error "parse-list: looking for a comma, expression or endmark"))
))
(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 ))
((equal endmark '\]) (rt)(nreverse sofar))
(t (mysignal 'syntax-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 Mockmma does
;; a<b<c (Comparison(a, Less b Less c)
;; a>b<c (Comparison a Greater b Less c)
;; a>b==c (Comparison a Greater b Equal c)
;; a+b==c (Comparison (Plus a b) Equal 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 (Comparison 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 '|Comparison|))))
((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 '|Comparison|))))
)))
(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 '|Comparison|))))
((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 '|Comparison|))))
)))
(t temp)))
(t nil) ; not an equal or inequal -expression
))
(defun patch-equal(h)
#+ignore ;; change (Comparison a OP b) to (Op a b). e.g. (Greater a b)
(if (= (length h) 4)
(list (caddr h) (cadr h)(cadddr h)) h)
h ;; leave Comparison, e.g. (Comparison a Greater b)
)
;; 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-alternatives end)))
(cond (temp (parse-condition1 temp end))
(t nil)))
(defun parse-alternatives( end &aux(temp(parse-repeated end)))
(cond (temp (parse-alternatives1 temp end))
(t nil)))
(defun parse-alternatives1(temp end)
(cond ((eolp end) temp)
((guess-token '\| )
(rt)
(parse-alternatives1 `(|Alternatives| ,temp ,(parse-repeated
end)) end))
(t temp)))
(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)(return (fixtimes1(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 (fixtimes1(parse-nary1 res '|Times|)))))))
(t nil) ; not a term
))
;; this hack below is mostly to make (Times 1 (Power x -1)) ==> (Power x -1)
(defun fixtimes1(r)
(cond ((and (consp r)(eq (car r) '|Times|))
(cond((eql (cadr r) 1) ;; (Times 1 x y ) ==> (Times x y)
(setf r (ucons (car r)(cddr r)))
r))
(cond((null (cddr r)) ;; (Times 1 x) ==> x
(setf r (cadr r))))))
r)
(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)
;; also, a_. is (Optional (Pattern a (Blank))) ;; 2/2011 RJF; fixed in parse-var
(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)))
((equal (peek-token)'(|Optional| (|Blank|)))
(rt) ;;example x_. 3/30/92 ; fixed 2/5/2011
`(|Optional|(|Pattern| ,next (|Blank|))))
(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 (mysignal 'syntax-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
(mysignal 'syntax-error "too few right-}"))))
((equal next '|#|)
(parse-slotform '|Slot| end))
((equal next '|##|)
(parse-slotform '|SlotSequence| end))
((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]]
((eql(peek-token)'[)
(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 (Comparison 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
;; 2/7/2011 RJF fixed parsing of Optional in n_.
;; 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)
|#
(defparameter trans-to-2case (make-hash-table))
(defun setupcases()
(map nil #'(lambda (capcase bothcase)
(setf (gethash capcase trans-to-2case)
bothcase))
caps-built-in-syms
built-in-syms))
(defun recase(x)(gethash x trans-to-2case x))
;; really there are 2 situations with GCL
;; 1. Identifier is typed in in whatever cases are available on the keyboard,
;; e.g. Cos, COS, cos and appears to be "COS" because
;; the lisp system is not so clever.
;; 2. Similarly, Foo, fOO, FOO, foo are all "FOO".
;; What to do?
;; a. If the parser sees COS, it looks up on trans-to-2case, and returns |Cos|.
;; b. There is no entry for FOO so the parser may return just FOO. This is
;; ok until one of two situations:
;; 1. It comes time to display FOO, at which point we may want Foo, or foo, or...
;; 2. The user types in two different names that are converted to FOO. That is,
;; Foo and foo are DIFFERENT. Tough luck.
;; With an ANSI CL that has a readtable-case setting there are 2 situations.
;; 1. Identifier is typed in in whatever cases are available on the keyboard,
;; e.g. Cos, COS, cos and appear in the correct case. Great.
;; 2. Similarly, Foo, foo, etc are distinct. The name print is read in as print.
;; Unfortunately, the lisp program that prints expressions is called PRINT.
;; What to do?
;; a. If the parser sees print, all in lower case, it converts it to PRINT.
;; b. If the display is about to display PRINT, all in upper case, it converts it to print.
;; This works.