src/nparse.lisp

   1 ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3 ;;;     The data in this file contains enhancements.                   ;;;;;
   4 ;;;                                                                    ;;;;;
   5 ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
   6 ;;;     All rights reserved                                            ;;;;;
   7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8 ;;;     (c) Copyright 1981 Massachusetts Institute of Technology         ;;;
   9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10
  11 (in-package :maxima)
  12
  13 (macsyma-module nparse)
  14
  15 (load-macsyma-macros defcal mopers)
  16
  17 (defvar *ascii-space-chars-for-maxima* '(#\tab #\space #\linefeed #\return #\page #\newline))
  18
  19 (defvar *unicode-space-char-codes-for-maxima*
  20       ;; Adapted from the list given by: https://jkorpela.fi/chars/spaces.html
  21       ;; omitting SPACE, OGHAM SPACE MARK, MONGOLIAN VOWEL SEPARATOR, IDEOGRAPHIC SPACE,
  22       ;; and ZERO WIDTH NO-BREAK SPACE.
  23   '(
  24     #x00A0 ;; NO-BREAK SPACE
  25     #x2000 ;; EN QUAD
  26     #x2001 ;; EM QUAD
  27     #x2002 ;; EN SPACE
  28     #x2003 ;; EM SPACE
  29     #x2004 ;; THREE-PER-EM SPACE
  30     #x2005 ;; FOUR-PER-EM SPACE
  31     #x2006 ;; SIX-PER-EM SPACE
  32     #x2007 ;; FIGURE SPACE
  33     #x2008 ;; PUNCTUATION SPACE
  34     #x2009 ;; THIN SPACE
  35     #x200A ;; HAIR SPACE
  36     #x200B ;; ZERO WIDTH SPACE
  37     #x202F ;; NARROW NO-BREAK SPACE
  38     #x205F ;; MEDIUM MATHEMATICAL SPACE
  39     ))
  40
  41 (defvar *unicode-space-chars-for-maxima*
  42     #-lisp-unicode-capable nil
  43     #+lisp-unicode-capable (mapcar 'code-char *unicode-space-char-codes-for-maxima*))
  44
  45 (defmvar *whitespace-chars* (append *ascii-space-chars-for-maxima* *unicode-space-chars-for-maxima*))
  46
  47 (defun alphabetp (n)
  48   (and (characterp n)
  49        (or (alpha-char-p n) #+gcl(>= (char-code n) 128)
  50            (member n *alphabet*))))
  51
  52 (defun ascii-numberp (num)
  53   (and (characterp num) (char<= num #\9) (char>= num #\0)))
  54
  55 (defvar *parse-window* nil)
  56 (defvar *parse-stream* ()     "input stream for Maxima parser")
  57 (defvar *parse-stream-eof* -1 "EOF value for Maxima parser")
  58 (defvar *parse-tyi* nil)
  59
  60 (defvar *mread-prompt* nil    "prompt used by `mread'")
  61 (defvar *mread-eof-obj* ()    "Bound by `mread' for use by `mread-raw'")
  62 (defvar *current-line-info* nil)
  63
  64 (defvar *parse-string-input-stream*             ;; reference to the input stream
  65   (let ((stream (make-string-input-stream ""))) ;;   used by parse-string
  66     (close stream)                              ;;   in share/stringroc/eval_string.lisp
  67     stream ))                                   ;; (see also add-lineinfo below)
  68
  69 (defmvar $report_synerr_line t "If T, report line number where syntax error occurs; otherwise, report FILE-POSITION of error.")
  70 (defmvar $report_synerr_info t "If T, report the syntax error details from all sources; otherwise, only report details from standard-input.")
  71
  72 (defun mread-synerr (format-string &rest l)
  73   (let ((fp (and (not (eq *parse-stream* *standard-input*))
  74                  (file-position *parse-stream*)))
  75         (file (and (not (eq *parse-stream* *standard-input*))
  76                    (cadr *current-line-info*))))
  77     (flet ((line-number ()
  78              ;; Fix me: Neither batch nor load track the line number
  79              ;; correctly. batch, via dbm-read, does not track the
  80              ;; line number at all (a bug?).
  81              ;;
  82              ;; Find the line number by jumping to the start of file
  83              ;; and reading line-by-line til we reach the current
  84              ;; position
  85              (cond ((and fp (file-position *parse-stream* 0))
  86                     (do ((l (read-line *parse-stream* nil nil) (read-line *parse-stream* nil nil))
  87                          (o 1                                  (1+ p))
  88                          (p (file-position *parse-stream*)     (file-position *parse-stream*))
  89                          (n 1                                  (1+ n)))
  90                         ((or (null p) (>= p fp))
  91                          (cons n (- fp o)))))
  92                    (t '())))
  93            (column ()
  94              (let ((n (get '*parse-window* 'length))
  95                    ch some)
  96                (loop for i from (1- n) downto (- n 20)
  97                   while (setq ch (nth i *parse-window*))
  98                   do
  99                     (cond ((or (eql ch *parse-stream-eof*)
 100                                (char= ch #\newline))
 101                            (return-from column some))
 102                           (t (push ch some))))
 103                some))
 104            (printer (x)
 105              (cond ((symbolp x)
 106                     (print-invert-case (stripdollar x)))
 107                    ((stringp x)
 108                     (maybe-invert-string-case x))
 109                    (t x)))
 110            )
 111       (case (and file $report_synerr_line)
 112         ((t)
 113          ;; print the file, line and column information
 114          (let ((line+column (line-number)))
 115            (format t "~&~a:~a:~a:" file (car line+column) (cdr line+column))))
 116         (otherwise
 117          ;; if file=nil, then print a fresh line only; otherwise print
 118          ;; file and character location
 119          (format t "~&~:[~;~:*~a:~a:~]" file fp)))
 120       (format t (intl:gettext "incorrect syntax: "))
 121       (apply 'format t format-string (mapcar #'printer l))
 122       (cond ((or $report_synerr_info (eql *parse-stream* *standard-input*))
 123              (let ((some (column)))
 124                (format t "~%~{~c~}~%~vt^" some (max 0 (- (length some) 2)))
 125                (read-line *parse-stream* nil nil))))
 126       (terpri)
 127       (finish-output)
 128       (throw-macsyma-top))))
 129
 130 (defun tyi-parse-int (stream eof)
 131   (or *parse-window*
 132       (progn (setq *parse-window* (make-list 25))
 133              (setf (get '*parse-window* 'length) (length *parse-window*))
 134              (nconc *parse-window* *parse-window*)))
 135   (let ((tem (tyi stream eof)))
 136     (setf (car *parse-window*) tem *parse-window*
 137           (cdr *parse-window*))
 138     (if (eql tem #\newline)
 139         (newline stream))
 140     tem))
 141
 142 (defun *mread-prompt* (out-stream char)
 143   (declare (ignore char))
 144   (format out-stream "~&~A" *mread-prompt*))
 145
 146 (defun aliaslookup (op)
 147   (if (symbolp op)
 148       (or (get op 'alias) op)
 149       op))
 150
 151 ;;;; Tokenizing
 152
 153 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 154 ;;;;;                                                                    ;;;;;
 155 ;;;;;                      The Input Scanner                             ;;;;;
 156 ;;;;;                                                                    ;;;;;
 157 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 158
 159 #+gcl
 160 (defun gobble-whitespace (&aux (ch (parse-tyipeek)) (cd (if (eql -1 ch) 0 (char-code (the character ch)))) l i r)
 161   (declare (dynamic-extent l) (fixnum r) ((integer 0 5) i) ((integer 0 255) cd))
 162   (cond ((>= cd 128)
 163          (do ((j 5 (1- j))) ((or (< j 3) (zerop (logand cd (the fixnum (ash 1 (the (integer 0 5) j)))))) (setq i j))
 164            (declare ((integer 0 5) j)))
 165          (setq r (logand cd (the fixnum (1- (the fixnum (ash 1 (the (integer 0 5) i)))))) l (cons (parse-tyi) l))
 166          (do ((i i (1+ i))) ((= i 6))
 167            (declare (fixnum i))
 168            (setq ch (parse-tyi) l (cons ch l) cd (if (eql -1 ch) 0 (char-code (the character ch))) r (logior (the fixnum (ash r 6)) (logand cd #.(1- (ash 1 6))))))
 169          (if (member r *unicode-space-char-codes-for-maxima*)
 170              (gobble-whitespace)
 171              (dolist (l l) (unparse-tyi l))))
 172         ((member ch *whitespace-chars*)
 173          (parse-tyi)
 174          (gobble-whitespace))))
 175
 176 #-gcl
 177 (defun gobble-whitespace ()
 178   (do ((ch (parse-tyipeek) (parse-tyipeek)))
 179       ((not (member ch *whitespace-chars*)))
 180     (parse-tyi)))
 181
 182 (defun read-command-token (obj)
 183   (gobble-whitespace)
 184   (read-command-token-aux obj))
 185
 186 (defun safe-assoc (item lis)
 187   "maclisp would not complain about (car 3), it gives nil"
 188   (loop for v in lis
 189         when (and (consp v)
 190                   (equal (car v) item))
 191         do
 192         (return v)))
 193
 194 ;; list contains an atom, only check
 195 ;; (parser-assoc 1 '(2 1 3)) ==>(1 3)
 196 ;; (parser-assoc 1 '(2 (1 4) 3)) ==>(1 4)
 197
 198 (defun parser-assoc (c lis )
 199   (loop for v on lis
 200          do
 201          (cond ((consp (car v))
 202                 (if (eq (caar v) c)
 203                     (return (car v))))
 204                ((eql (car v) c)
 205                 (return v)))))
 206
 207 ;; we need to be able to unparse-tyi an arbitrary number of
 208 ;; characters, since if you do
 209 ;; PREFIX("ABCDEFGH");
 210 ;; then ABCDEFGA should read as a symbol.
 211 ;; 99% of the time we don't have to unparse-tyi, and so there will
 212 ;; be no consing...
 213
 214 (defun parse-tyi ()
 215   (let ((tem  *parse-tyi*))
 216     (cond ((null tem)
 217            (tyi-parse-int *parse-stream* *parse-stream-eof*))
 218           ((atom tem)
 219            (setq *parse-tyi* nil)
 220            tem)
 221           (t ;;consp
 222            (setq *parse-tyi* (cdr tem))
 223            (car tem)))))
 224
 225 ;; read one character but leave it there. so next parse-tyi gets it
 226 (defun parse-tyipeek ()
 227   (let ((tem  *parse-tyi*))
 228     (cond ((null tem)
 229            (setq *parse-tyi* (tyi-parse-int *parse-stream* *parse-stream-eof*)))
 230           ((atom tem) tem)
 231           (t (car tem)))))
 232
 233 ;; push characters back on the stream
 234 (defun unparse-tyi (c)
 235   (let ((tem  *parse-tyi*))
 236     (if (null tem)
 237         (setq *parse-tyi* c)
 238         (setq *parse-tyi* (cons c tem)))))
 239
 240 ;;I know that the tradition says there should be no comments
 241 ;;in tricky code in maxima.  However the operator parsing
 242 ;;gave me a bit of trouble.   It was incorrect because
 243 ;;it could not handle things produced by the extensions
 244 ;;the following was broken for prefixes
 245
 246 (defun read-command-token-aux (obj)
 247   (let* (result
 248          (ch (parse-tyipeek))
 249          (lis (if (eql ch *parse-stream-eof*)
 250                   nil
 251                   (parser-assoc ch obj))))
 252     (cond ((null lis)
 253            nil)
 254           (t
 255            (parse-tyi)
 256            (cond ((atom (cadr lis))
 257                   ;; INFIX("ABC"); puts into macsyma-operators
 258                   ;;something like: (#\A #\B #\C (ANS $abc))
 259                   ;; ordinary things are like:
 260                   ;; (#\< (ANS $<) (#\= (ANS $<=)))
 261                   ;; where if you fail at the #\< #\X
 262                   ;; stage, then the previous step was permitted.
 263                   (setq result (read-command-token-aux (list (cdr lis)))))
 264                  ((null (cddr lis))
 265                   ;; lis something like (#\= (ANS $<=))
 266                   ;; and this says there are no longer operators
 267                   ;; starting with this.
 268                   (setq result
 269                         (and (eql (car (cadr lis)) 'ans)
 270                              ;; When we have an operator, which starts with a
 271                              ;; literal, we check, if the operator is
 272                              ;; followed with a whitespace. With this code
 273                              ;; Maxima parses an expression grad x or grad(x)
 274                              ;; as (($grad) x) and gradef(x) as (($gradef) x),
 275                              ;; when grad is defined as a prefix operator.
 276                              ;; See bug report ID: 2970792.
 277                              (or (not (alphabetp (cadr (exploden (cadr (cadr lis))))))
 278                                  (member (parse-tyipeek) *whitespace-chars*))
 279                              (cadr (cadr lis)))))
 280                  (t
 281                   (let ((res   (and (eql (car (cadr lis)) 'ans)
 282                                     (cadr (cadr lis))))
 283                         (com-token (read-command-token-aux (cddr lis) )))
 284                     (setq result (or com-token res
 285                                      (read-command-token-aux (list (cadr lis))))))))
 286              (or result (unparse-tyi ch))
 287              result))))
 288
 289 (defun scan-macsyma-token ()
 290   ;; note that only $-ed tokens are GETALIASed.
 291   (getalias (implode (cons '#\$ (scan-token t)))))
 292
 293 (defun scan-lisp-token ()
 294   (let ((charlist (scan-token nil)))
 295     (if charlist
 296         (implode charlist)
 297         (mread-synerr "Lisp symbol expected."))))
 298
 299 ;; Example: ?mismatch(x+y,x*z,?:from\-end,true); => 3
 300 (defun scan-keyword-token ()
 301   (let ((charlist (cdr (scan-token nil))))
 302     (if charlist
 303         (let ((*package* (find-package :keyword)))
 304           (implode charlist))
 305         (mread-synerr "Lisp keyword expected."))))
 306
 307 (defun scan-token (flag)
 308   (do ((c (parse-tyipeek) (parse-tyipeek))
 309        (l () (cons c l)))
 310       ((or (eql c *parse-stream-eof*)
 311            (and flag
 312                 (not (or (digit-char-p c (max 10 *read-base*))
 313                          (alphabetp c)
 314                          (char= c #\\ )))))
 315        (nreverse (or l (list (parse-tyi))))) ; Read at least one char ...
 316     (when (char= (parse-tyi) #\\ )
 317       (setq c (parse-tyi)))
 318     (setq flag t)))
 319
 320 (defun scan-lisp-string () (scan-string))
 321 (defun scan-macsyma-string () (scan-string))
 322
 323 (defun scan-string (&optional init)
 324   (let ((buf (make-array 50 :element-type ' #.(array-element-type "a")
 325                          :fill-pointer 0 :adjustable t)))
 326     (when init
 327       (vector-push-extend init buf))
 328     (do ((c (parse-tyipeek) (parse-tyipeek)))
 329         ((cond ((eql c *parse-stream-eof*))
 330                ((char= c #\")
 331                 (parse-tyi) t))
 332          (copy-seq buf))
 333       (if (char= (parse-tyi) #\\ )
 334           (setq c (parse-tyi)))
 335       (vector-push-extend c  buf))))
 336
 337 (defun readlist (lis)
 338   (read-from-string (coerce lis 'string)))
 339
 340 ;; These variables control how we convert bfloat inputs to the
 341 ;; internal bfloat representation.  These variables should probably go
 342 ;; away after some testing.
 343 (defmvar $fast_bfloat_conversion t
 344   "Use fast, but possibly inaccurate conversion")
 345 (defmvar $fast_bfloat_threshold 100000.
 346   "Exponents larger than this (in absolute value) will use the fast
 347   conversion instead of the accurate conversion")
 348 (defvar *fast-bfloat-extra-bits* 0)
 349
 350 ;; Here is a test routine to test the fast bfloat conversion
 351 #+nil
 352 (defun test-make-number (&optional (n 1000))
 353   (let ((failures 0))
 354     (dotimes (k n)
 355       (flet ((digit-list (n)
 356                (coerce (format nil "~D" n) 'list)))
 357         (let ((numlist nil))
 358           ;; Generate a random number with 30 fraction digits and an
 359           ;; large exponent.
 360           (push (digit-list (random 10)) numlist)
 361           (push '(#\.) numlist)
 362           (push (digit-list (random (expt 10 30))) numlist)
 363           (push '(#\B) numlist)
 364           (push (if (zerop (random 2)) '(#\+) '(#\-)) numlist)
 365           (push (digit-list (+ $fast_bfloat_threshold
 366                                (random $fast_bfloat_threshold)))
 367                 numlist)
 368           ;; Convert using accurate and fast methods and compare the
 369           ;; results.
 370           (let ((true (let (($fast_bfloat_conversion nil))
 371                         (make-number (copy-list numlist))))
 372                 (fast (let (($fast_bfloat_conversion t))
 373                         (make-number (copy-list numlist)))))
 374             (format t "Test ~3A: " k)
 375             (map nil #'(lambda (x)
 376                          (map nil #'princ x))
 377                  (reverse numlist))
 378             (terpri)
 379             (finish-output)
 380             (unless (equalp true fast)
 381               (incf failures)
 382               (format t "NUM:  ~A~%  TRUE: ~S~%  FAST: ~S~%"
 383                       (reverse numlist) true fast))))))
 384     (format t "~D failures in ~D tests (~F%)~%"
 385             failures n (* 100 failures (/ (float n))))))
 386
 387
 388 ;; WARNING: MAKE-NUMBER destructively modifies it argument!  Should we
 389 ;; change that?
 390 (defun make-number (data)
 391   (setq data (nreverse data))
 392   ;; Maxima really wants to read in any number as a flonum
 393   ;; (except when we have a bigfloat, of course!).  So convert exponent
 394   ;; markers to the flonum-exponent-marker.
 395   (let ((marker (car (nth 3 data))))
 396     (unless (eql marker +flonum-exponent-marker+)
 397       (when (member marker '(#\E #\F #\S #\D #\L #+cmu #\W))
 398         (setf (nth 3 data) (list +flonum-exponent-marker+)))))
 399   (if (not (equal (nth 3 data) '(#\B)))
 400       (readlist (apply #'append data))
 401       (let*
 402            ((*read-base* 10.)
 403             (int-part (readlist (or (first data) '(#\0))))
 404             (frac-part (readlist (or (third data) '(#\0))))
 405             (frac-len (length (third data)))
 406             (exp-sign (first (fifth data)))
 407             (exp (readlist (sixth data))))
 408         (if (and $fast_bfloat_conversion
 409                  (> (abs exp) $fast_bfloat_threshold))
 410             ;; Exponent is large enough that we don't want to do exact
 411             ;; rational arithmetic.  Instead we do bfloat arithmetic.
 412             ;; For example, 1.234b1000 is converted by computing
 413             ;; bfloat(1234)*10b0^(1000-3).  Extra precision is used
 414             ;; during the bfloat computations.
 415             (let* ((extra-prec (+ *fast-bfloat-extra-bits* (ceiling (log exp 2e0))))
 416                    (fpprec (+ fpprec extra-prec))
 417                    (mant (+ (* int-part (expt 10 frac-len)) frac-part))
 418                    (bf-mant (bcons (intofp mant)))
 419                    (p (power (bcons (intofp 10))
 420                              (- (if (char= exp-sign #\-)
 421                                     (- exp)
 422                                     exp)
 423                                 frac-len)))
 424                    ;; Compute the product using extra precision.  This
 425                    ;; helps to get the last bit correct (but not
 426                    ;; always).  If we didn't do this, then bf-mant and
 427                    ;; p would be rounded to the target precision and
 428                    ;; then the product is rounded again.  Doing it
 429                    ;; this way, we still have 3 roundings, but bf-mant
 430                    ;; and p aren't rounded too soon.
 431                    (result (mul bf-mant p)))
 432               (let ((fpprec (- fpprec extra-prec)))
 433                 ;; Now round the product back to the desired precision.
 434                 (bigfloatp result)))
 435             ;; For bigfloats, turn them into rational numbers then
 436             ;; convert to bigfloat.  Fix for the 0.25b0 # 2.5b-1 bug.
 437             ;; Richard J. Fateman posted this fix to the Maxima list
 438             ;; on 10 October 2005.  Without this fix, some tests in
 439             ;; rtestrationalize will fail.  Used with permission.
 440             (let ((ratio (* (+ int-part (* frac-part (expt 10 (- frac-len))))
 441                             (expt 10 (if (char= exp-sign #\-)
 442                                          (- exp)
 443                                          exp)))))
 444             ($bfloat (cl-rat-to-maxima ratio)))))))
 445
 446 ;; Richard J. Fateman wrote the big float to rational code and the function
 447 ;; cl-rat-to-maxmia.
 448
 449 (defun cl-rat-to-maxima (x)
 450   (if (integerp x)
 451       x
 452       (list '(rat simp) (numerator x) (denominator x))))
 453
 454 (defun scan-digits (data continuation? continuation &optional exponent-p)
 455   (do ((c (parse-tyipeek) (parse-tyipeek))
 456        (l () (cons c l)))
 457       ((not (and (characterp c) (digit-char-p c (max 10. *read-base*))))
 458        (cond ((member c continuation?)
 459               (funcall continuation (list* (ncons (char-upcase
 460                                                    (parse-tyi)))
 461                                            (nreverse l)
 462                                            data)))
 463              ((and (null l) exponent-p)
 464               ;; We're trying to parse the exponent part of a number,
 465               ;; and we didn't get a value after the exponent marker.
 466               ;; That's an error.
 467               (mread-synerr "parser: incomplete number; missing exponent?"))
 468              (t
 469               (make-number (cons (nreverse l) data)))))
 470     (parse-tyi)))
 471
 472 (defun scan-number-after-dot (data)
 473   (scan-digits data '(#\E #\e #\F #\f #\B #\b #\D #\d #\S #\s #\L #\l #+cmu #\W #+cmu #\w) #'scan-number-exponent))
 474
 475 (defun scan-number-exponent (data)
 476   (push (ncons (if (or (char= (parse-tyipeek) #\+)
 477                        (char= (parse-tyipeek) #\-))
 478                    (parse-tyi)
 479                    #\+))
 480         data)
 481   (scan-digits data () () t))
 482
 483 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 484 ;;;;;                                                                    ;;;;;
 485 ;;;;;                    The Expression Parser                           ;;;;;
 486 ;;;;;                                                                    ;;;;;
 487 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 488
 489 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 490 ;;;                                                                      ;;;
 491 ;;;     Based on a theory of parsing presented in:                       ;;;
 492 ;;;                                                                      ;;;
 493 ;;;         Pratt, Vaughan R., ``Top Down Operator Precedence,''         ;;;
 494 ;;;         ACM Symposium on Principles of Programming Languages         ;;;
 495 ;;;         Boston, MA; October, 1973.                                   ;;;
 496 ;;;                                                                      ;;;
 497 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 498
 499 ;;;     Implementation Notes ....
 500 ;;;
 501 ;;;     JPG     Chars like ^A, ^B, ... get left around after interrupts and
 502 ;;;             should be thrown away by the scanner if not used as editing
 503 ;;;             commands.
 504 ;;;
 505 ;;;     KMP     There is RBP stuff in DISPLA, too. Probably this sort of
 506 ;;;             data should all be in one place somewhere.
 507 ;;;
 508 ;;;     KMP     Maybe the parser and/or scanner could use their own GC scheme
 509 ;;;             to recycle conses used in scan/parse from line to line which
 510 ;;;             really ought not be getting dynamically discarded and reconsed.
 511 ;;;             Alternatively, we could call RECLAIM explicitly on certain
 512 ;;;             pieces of structure which get used over and over. A
 513 ;;;             local-reclaim abstraction may want to be developed since this
 514 ;;;             stuff will always be needed, really. On small-address-space
 515 ;;;             machines, this could be overridden when the last DYNAMALLOC
 516 ;;;             GC barrier were passed (indicating that space was at a premium
 517 ;;;             -- in such case, real RECLAIM would be more economical -- or
 518 ;;;             would the code to control that be larger than the area locked
 519 ;;;             down ...?)
 520 ;;;
 521 ;;;     KMP     GJC has a MAKE-EVALUATOR type package which could probably
 522 ;;;             replace the CALL-IF-POSSIBLE stuff used here.
 523 ;;;             [So it was written, so it was done. -gjc]
 524 ;;;
 525 ;;;     KMP     DEFINE-SYMBOL and KILL-OPERATOR need to be redefined.
 526 ;;;             Probably these shouldn't be defined in this file anyway.
 527 ;;;
 528 ;;;     KMP     The relationship of thisfile to SYNEX needs to be thought
 529 ;;;             out more carefully.
 530 ;;;
 531 ;;;     GJC     Need macros for declaring INFIX, PREFIX, etc ops
 532 ;;;
 533 ;;;     GJC     You know, PARSE-NARY isn't really needed it seems, since
 534 ;;;             the SIMPLIFIER makes the conversion of
 535 ;;;                     ((MTIMES) ((MTIMES) A B) C) => ((MTIMES) A B C)
 536 ;;;             I bet you could get make "*" infix and nobody would
 537 ;;;             ever notice.
 538
 539 ;;; The following terms may be useful in deciphering this code:
 540 ;;;
 541 ;;; NUD -- NUll left Denotation (op has nothing to its left (prefix))
 542 ;;; LED -- LEft Denotation      (op has something to left (postfix or infix))
 543 ;;;
 544 ;;; LBP -- Left Binding Power  (the stickiness to the left)
 545 ;;; RBP -- Right Binding Power (the stickiness to the right)
 546 ;;;
 547
 548 ;;;; Macro Support
 549
 550 (defvar scan-buffered-token (list nil)
 551   "put-back buffer for scanner, a state-variable of the reader")
 552
 553 (defun peek-one-token ()
 554   (peek-one-token-g nil nil))
 555
 556 (defun peek-one-token-g (eof-ok? eof-obj)
 557   (cond
 558    ((car scan-buffered-token)
 559     (cdr scan-buffered-token))
 560    (t (rplacd scan-buffered-token (scan-one-token-g eof-ok? eof-obj))
 561       (cdr (rplaca scan-buffered-token t)))))
 562
 563 (defun scan-one-token ()
 564   (scan-one-token-g nil nil))
 565
 566 (defun scan-one-token-g (eof-ok? eof-obj)
 567   (declare (special macsyma-operators))
 568   (cond ((car scan-buffered-token)
 569          (rplaca scan-buffered-token ())
 570          (cdr scan-buffered-token))
 571         ((read-command-token macsyma-operators))
 572         (t
 573          (let ((test (parse-tyipeek)))
 574            (cond  ((eql test *parse-stream-eof*)
 575                    (parse-tyi)
 576                    (if eof-ok? eof-obj
 577                        (mread-synerr (intl:gettext "end of file while scanning expression."))))
 578                   ((eql test #\/)
 579                    (parse-tyi)
 580                    (cond ((char= (parse-tyipeek) #\*)
 581                           (parse-tyi)
 582                           (gobble-comment)
 583                           (scan-one-token-g eof-ok? eof-obj))
 584                          (t '$/)))
 585                   ((eql test #\.) (parse-tyi)   ; Read the dot
 586                    (if (digit-char-p (parse-tyipeek) 10.)
 587                        (scan-number-after-dot (list (ncons #\.) nil))
 588                        '|$.|))
 589                   ((eql test #\")
 590                    (parse-tyi)
 591                    (scan-macsyma-string))
 592                   ((eql test #\?)
 593                    (parse-tyi)
 594                    (cond ((char= (parse-tyipeek) #\")
 595                           (parse-tyi)
 596                           (scan-lisp-string))
 597                          ((char= (parse-tyipeek) #\:)
 598                           (scan-keyword-token))
 599                          (t
 600                           (scan-lisp-token))))
 601                   (t
 602                    (if (digit-char-p test 10.)
 603                        (scan-number-before-dot ())
 604                        (scan-macsyma-token))))))))
 605
 606 ;; nested comments are permitted.
 607 (defun gobble-comment ()
 608   (prog (c depth)
 609         (setq depth 1)
 610      read
 611         (setq c (parse-tyipeek))
 612         (parse-tyi)
 613         (cond ((= depth 0) (return t)))
 614         (cond ((eql c *parse-stream-eof*)
 615                (mread-synerr (intl:gettext "end of file in comment.")))
 616               ((char= c #\*)
 617                (cond ((char= (parse-tyipeek) #\/)
 618                       (decf depth)
 619                       (parse-tyi)
 620                       (cond ((= depth 0) (return t)))
 621                       (go read))))
 622               ((char= c #\/)
 623                (cond ((char= (parse-tyipeek) #\*)
 624                       (incf depth) (parse-tyi)
 625                       (go read)))))
 626         (go read))
 627   )
 628
 629 (defun scan-number-rest (data)
 630   (let ((c (caar data)))
 631     (cond ((char= c #\.)
 632            ;; We found a dot
 633            (scan-number-after-dot data))
 634           ((member c '(#\E #\e #\F #\f #\B #\b #\D #\d #\S #\s #\L #\l #+cmu #\W #+cmu #\w))
 635            ;; Dot missing but found exponent marker.  Fake it.
 636            (setf data (push (ncons #\.) (rest data)))
 637            (push (ncons #\0) data)
 638            (push (ncons c) data)
 639            (scan-number-exponent data)))))
 640
 641 (defun scan-number-before-dot (data)
 642   (scan-digits data '(#\. #\E #\e #\F #\f #\B #\b #\D #\d #\S #\s #\L #\l #+cmu #\W #+cmu #\w)
 643                #'scan-number-rest))
 644
 645
 646 ;; "First character" and "Pop character"
 647
 648 (defmacro first-c () '(peek-one-token))
 649 (defmacro pop-c   () '(scan-one-token))
 650
 651 (defun mstringp (x) (stringp x)) ;; OBSOLETE. PRESERVE FOR SAKE OF POSSIBLE CALLS FROM NON-MAXIMA CODE !!
 652
 653 (defun inherit-propl (op-to op-from getl)
 654   (let ((propl (getl op-from getl)))
 655     (if propl
 656         (progn (remprop op-to (car propl))
 657                (putprop op-to (cadr propl) (car propl)))
 658         (inherit-propl op-to
 659                        (maxima-error "has no ~a properties. ~a ~a" getl op-from 'wrng-type-arg)
 660                        getl))))
 661
 662
 663 ;;; (NUD <op>)
 664 ;;; (LED <op> <left>)
 665 ;;;
 666 ;;;  <op>   is the name of the operator which was just popped.
 667 ;;;  <left> is the stuff to the left of the operator in the LED case.
 668 ;;;
 669
 670 (eval-when
 671   (:execute :compile-toplevel :load-toplevel)
 672   (defmacro def-nud-equiv (op equiv)
 673     (list 'putprop (list 'quote op) (list 'function equiv)
 674           (list 'quote 'nud)))
 675
 676   (defmacro nud-propl () ''(nud))
 677
 678   (defmacro def-nud-fun (op-name op-l . body)
 679     (list* 'defun-prop (list* op-name 'nud 'nil) op-l body))
 680
 681   (defmacro def-led-equiv (op equiv)
 682     (list 'putprop (list 'quote op) (list 'function equiv)
 683           (list 'quote 'led)))
 684
 685   (defmacro led-propl () ''(led))
 686
 687   (defmacro def-led-fun (op-name op-l . body)
 688     (list* 'defun-prop (list* op-name 'led 'nil) op-l body)))
 689
 690 (defun nud-call (op)
 691   (let ((tem (and (symbolp op) (getl op '(nud)))) res)
 692     (setq res
 693           (if (null tem)
 694               (if (operatorp op)
 695                   (mread-synerr "~A is not a prefix operator" (mopstrip op))
 696                   (cons '$any op))
 697               (funcall (cadr tem) op)))
 698     res))
 699
 700 (defun led-call (op l)
 701   (let ((tem (and (symbolp op) (getl op '(led)))) res)
 702     (setq res
 703           (if (null tem)
 704               (mread-synerr "~A is not an infix operator" (mopstrip op))
 705               (funcall (cadr tem) op l)))
 706     res))
 707
 708 ;;; (DEF-NUD (op lbp rbp) bvl . body)
 709 ;;;
 710 ;;;  Defines a procedure for parsing OP as a prefix operator.
 711 ;;;
 712 ;;;  OP  should be the name of the symbol as a string or symbol.
 713 ;;;  LBP is an optional left  binding power for the operator.
 714 ;;;  RBP is an optional right binding power for the operator.
 715 ;;;  BVL must contain exactly one variable, which the compiler will not
 716 ;;;      complain about if unused, since it will rarely be of use anyway.
 717 ;;;      It will get bound to the operator being parsed.
 718 ;;;  lispm:Optional args not allowed in release 5 allowed, necessary afterwards..
 719
 720 (defmacro def-nud ((op . lbp-rbp) bvl . body)
 721   (let (( lbp (nth 0 lbp-rbp))
 722         ( rbp (nth 1 lbp-rbp)))
 723     `(progn ,(make-parser-fun-def op 'nud bvl body)
 724             (set-lbp-and-rbp ',op ',lbp ',rbp))))
 725
 726 (defun set-lbp-and-rbp (op lbp rbp)
 727   (cond ((not (consp op))
 728          (let ((existing-lbp (get op 'lbp))
 729                (existing-rbp (get op 'rbp)))
 730            (cond ((not lbp) ;; ignore omitted arg
 731                   )
 732                  ((not existing-lbp)
 733                   (putprop op lbp 'lbp))
 734                  ((not (equal existing-lbp lbp))
 735                   (maxima-error "Incompatible LBP's defined for this operator ~a" op)))
 736            (cond ((not rbp) ;; ignore omitted arg
 737                   )
 738                  ((not existing-rbp)
 739                   (putprop op rbp 'rbp))
 740                  ((not (equal existing-rbp rbp))
 741                   (maxima-error "Incompatible RBP's defined for this operator ~a" op)))))
 742         (t
 743          (mapcar #'(lambda (x) (set-lbp-and-rbp x lbp rbp))
 744                  op))))
 745
 746 ;;; (DEF-LED (op lbp rbp) bvl . body)
 747 ;;;
 748 ;;;  Defines a procedure for parsing OP as an infix or postfix operator.
 749 ;;;
 750 ;;;  OP  should be the name of the symbol as a string or symbol.
 751 ;;;  LBP is an optional left  binding power for the operator.
 752 ;;;  RBP is an optional right binding power for the operator.
 753 ;;;  BVL must contain exactly two variables, the first of which the compiler
 754 ;;;       will not complain about if unused, since it will rarely be of use
 755 ;;;       anyway. Arg1 will get bound to the operator being parsed. Arg2 will
 756 ;;;       get bound to the parsed structure which was to the left of Arg1.
 757
 758
 759 (defmacro def-led((op . lbp-rbp) bvl . body)
 760   (let (( lbp (nth 0 lbp-rbp))
 761         ( rbp (nth 1 lbp-rbp)))
 762     `(progn ,(make-parser-fun-def  op 'led bvl body)
 763             (set-lbp-and-rbp ',op ',lbp ',rbp))))
 764
 765 (defmacro def-collisions (op &rest alist)
 766   (let ((keys (do ((i 1 (ash i 1))
 767                    (lis  alist (cdr lis))
 768                    (nl ()    (cons (cons (caar lis) i) nl)))
 769                   ((null lis) nl))))
 770     `(progn
 771        (defprop ,op ,(let nil
 772                           (copy-tree keys )) keys)
 773        ,@(mapcar #'(lambda (data)
 774                      `(defprop ,(car data)
 775                                ,(do ((i 0 (logior i  (cdr (assoc (car lis) keys :test #'eq))))
 776                                      (lis (cdr data) (cdr lis)))
 777                                     ((null lis) i))
 778                                ,op))
 779                  alist))))
 780
 781
 782 (defun collision-lookup (op active-bitmask key-bitmask)
 783   (let ((result (logand active-bitmask key-bitmask)))
 784     (if (not (zerop result))
 785         (do ((l (get op 'keys) (cdr l)))
 786             ((null l) (parse-bug-err 'collision-check))
 787           (if (not (zerop (logand result (cdar l))))
 788               (return (caar l)))))))
 789
 790 (defun collision-check (op active-bitmask key)
 791   (let ((key-bitmask (get key op)))
 792     (if (not key-bitmask)
 793         (mread-synerr "~A is an unknown keyword in a ~A statement."
 794                       (mopstrip key) (mopstrip op)))
 795     (let ((collision (collision-lookup op active-bitmask key-bitmask)))
 796       (if collision
 797           (if (eq collision key)
 798               (mread-synerr "This ~A's ~A slot is already filled."
 799                             (mopstrip op)
 800                             (mopstrip key))
 801               (mread-synerr "A ~A cannot have a ~A with a ~A field."
 802                             (mopstrip op)
 803                             (mopstrip key)
 804                             (mopstrip collision))))
 805       (logior (cdr (assoc key (get op 'keys) :test #'eq)) active-bitmask))))
 806
 807 ;;;; Data abstraction
 808
 809 ;;; LBP = Left Binding Power
 810 ;;;
 811 ;;; (LBP <op>)           - reads an operator's Left Binding Power
 812 ;;; (DEF-LBP <op> <val>) - defines an operator's Left Binding Power
 813
 814 (defun lbp (lex) (cond ((safe-get lex 'lbp)) (t 200.)))
 815
 816 (defmacro def-lbp (sym val) `(defprop ,sym ,val lbp))
 817
 818 ;;; RBP = Right Binding Power
 819 ;;;
 820 ;;; (RBP <op>)           - reads an operator's Right Binding Power
 821 ;;; (DEF-RBP <op> <val>) - defines an operator's Right Binding Power
 822
 823 (defun rbp (lex) (cond ((safe-get lex 'rbp)) (t 200.)))
 824
 825 (defmacro def-rbp (sym val) `(defprop ,sym ,val rbp))
 826
 827 (defmacro def-match (x m) `(defprop ,x ,m match))
 828
 829 ;;; POS = Part of Speech!
 830 ;;;
 831 ;;; (LPOS <op>)
 832 ;;; (RPOS <op>)
 833 ;;; (POS  <op>)
 834 ;;;
 835
 836 (defun lpos (op) (cond ((safe-get op 'lpos)) (t '$any)))
 837 (defun rpos (op) (cond ((safe-get op 'rpos)) (t '$any)))
 838 (defun pos (op) (cond ((safe-get op 'pos)) (t '$any)))
 839
 840 (defmacro def-pos  (op pos) `(defprop ,op ,pos  pos))
 841 (defmacro def-rpos (op pos) `(defprop ,op ,pos rpos))
 842 (defmacro def-lpos (op pos) `(defprop ,op ,pos lpos))
 843
 844 ;;; MHEADER
 845
 846 (defun mheader (op) (add-lineinfo (or (safe-get op 'mheader) (ncons op))))
 847
 848 (defmacro def-mheader (op header) `(defprop ,op ,header mheader))
 849
 850 ;;;; Misplaced definitions
 851
 852 (defmacro def-operatorp ()
 853   `(defun operatorp (lex)
 854      (and (symbolp lex) (getl lex '(,@(nud-propl) ,@(led-propl))))))
 855
 856 (def-operatorp)
 857
 858 (defmacro def-operatorp1 ()
 859   ;Defmfun -- used by SYNEX if not others.
 860   `(defun operatorp1 (lex)
 861      ;; Referenced outside of package: OP-SETUP, DECLARE1
 862      ;; Use for truth value only, not for return-value.
 863      (and (symbolp lex) (getl lex '(lbp rbp ,@(nud-propl) ,@(led-propl))))))
 864
 865 (def-operatorp1)
 866
 867 ;;;; The Macsyma Parser
 868
 869 ;;; (MREAD) with arguments compatible with losing maclisp READ style.
 870 ;;;
 871 ;;; Returns a parsed form of tokens read from stream.
 872 ;;;
 873 ;;; If you want rubout processing, be sure to call some stream which knows
 874 ;;; about such things. Also, I'm figuring that the PROMPT will be
 875 ;;; an attribute of the stream which somebody can hack before calling
 876 ;;; MREAD if he wants to.
 877
 878
 879 ;;Important for lispm rubout handler
 880 (defun mread (&rest read-args)
 881   (progn
 882     (when *mread-prompt*
 883       (and *parse-window* (setf (car *parse-window*) nil
 884                                 *parse-window* (cdr *parse-window*)))
 885       (princ *mread-prompt*)
 886       (finish-output))
 887     (apply 'mread-raw read-args)))
 888
 889 (defun mread-prompter (stream char)
 890   (declare (special *mread-prompt-internal*)
 891            (ignore char))
 892   (fresh-line stream)
 893   (princ *mread-prompt-internal* stream))
 894
 895 ;; input can look like:
 896 ;;aa && bb && jim:3;
 897
 898 (defun mread-raw (*parse-stream* &optional *mread-eof-obj*)
 899   (let ((scan-buffered-token (list nil))
 900         *parse-tyi*)
 901     (if (eq scan-buffered-token ;; a handly unique object for the EQ test.
 902             (peek-one-token-g t scan-buffered-token))
 903         *mread-eof-obj*
 904         (do ((labels ())
 905              (input (parse '$any 0.) (parse '$any 0.)))
 906             (nil)
 907           (case (first-c)
 908             ((|$;| |$$|)
 909               ;force a separate line info structure
 910              (setf *current-line-info* nil)
 911              (return (list (mheader (pop-c))
 912                            (if labels (cons (mheader '|$[|) (nreverse labels)))
 913                            input)))
 914             ((|$&&|)
 915              (pop-c)
 916              (if (symbolp input)
 917                  (push input labels)
 918                  (mread-synerr "Invalid && tag. Tag must be a symbol")))
 919             (t
 920              (parse-bug-err 'mread-raw)))))))
 921
 922 ;;; (PARSE <mode> <rbp>)
 923 ;;;
 924 ;;;  This will parse an expression containing operators which have a higher
 925 ;;;  left binding power than <rbp>, returning as soon as an operator of
 926 ;;;  lesser or equal binding power is seen. The result will be in the given
 927 ;;;  mode (which allows some control over the class of result expected).
 928 ;;;  Modes used are as follows:
 929 ;;;     $ANY    = Match any type of expression
 930 ;;;     $CLAUSE = Match only boolean expressions (or $ANY)
 931 ;;;     $EXPR   = Match only mathematical expressions (or $ANY)
 932 ;;;  If a mismatched mode occurs, a syntax error will be flagged. Eg,
 933 ;;;  this is why "X^A*B" parses but "X^A and B" does not. X^A is a $EXPR
 934 ;;;  and not coercible to a $CLAUSE. See CONVERT.
 935 ;;;
 936 ;;;  <mode> is the required mode of the result.
 937 ;;;  <rbp>  is the right binding power to use for the parse. When an
 938 ;;;          LED-type operator is seen with a lower left binding power
 939 ;;;          than <rbp>, this parse returns what it's seen so far rather
 940 ;;;          than calling that operator.
 941 ;;;
 942
 943 (defun parse (mode rbp)
 944   (do ((left (nud-call (pop-c))         ; Envoke the null left denotation
 945              (led-call (pop-c) left)))  ;  and keep calling LED ops as needed
 946       ((>= rbp (lbp (first-c)))         ; Until next op lbp too low
 947        (convert left mode))))           ;  in which case, return stuff seen
 948
 949 ;;; (PARSE-PREFIX <op>)
 950 ;;;
 951 ;;;  Parses prefix forms -- eg, -X or NOT FOO.
 952 ;;;
 953 ;;;  This should be the NUD property on an operator. It fires after <op>
 954 ;;;  has been seen. It parses forward looking for one more expression
 955 ;;;  according to its right binding power, returning
 956 ;;;  ( <mode> . ((<op>) <arg1>) )
 957
 958 (defun parse-prefix (op)
 959   (list (pos op)                        ; Operator mode
 960         (mheader op)                    ; Standard Macsyma expression header
 961         (parse (rpos op) (rbp op))))    ; Convert single argument for use
 962
 963 ;;; (PARSE-POSTFIX <op> <left>)
 964 ;;;
 965 ;;;  Parses postfix forms. eg, X!.
 966 ;;;
 967 ;;;  This should be the LED property of an operator. It fires after <left>
 968 ;;;  has been accumulated and <op> has been seen and gobbled up. It returns
 969 ;;;  ( <mode> . ((<op>) <arg1>) )
 970
 971 (defun parse-postfix (op l)
 972   (list (pos op)                        ; Operator's mode
 973         (mheader op)                    ; Standard Macsyma expression header
 974         (convert l (lpos op))))         ; Convert single argument for use
 975
 976 ;;; (PARSE-INFIX <op> <left>)
 977 ;;;
 978 ;;;  Parses infix (non-nary) forms. eg, 5 mod 3.
 979 ;;;
 980 ;;;  This should be the led property of an operator. It fires after <left>
 981 ;;;  has been accumulated and <op> has been seen and gobbled up. It returns
 982 ;;;  ( <mode> . ((<op>) <arg1> <arg2>) )
 983
 984 (defun parse-infix (op l)
 985   (list (pos op)                        ; Operator's mode
 986         (mheader op)                    ; Standard Macsyma expression header
 987         (convert l (lpos op))           ; Convert arg1 for immediate use
 988         (parse (rpos op) (rbp op))))    ; Look for an arg2
 989
 990 ;;; (PARSE-NARY <op> <left>)
 991 ;;;
 992 ;;;  Parses nary forms. Eg, form1*form2*... or form1+form2+...
 993 ;;;  This should be the LED property on an operator. It fires after <op>
 994 ;;;  has been seen, accumulating and returning
 995 ;;;  ( <mode> . ((<op>) <arg1> <arg2> ...) )
 996 ;;;
 997 ;;;  <op>   is the being parsed.
 998 ;;;  <left> is the stuff that has been seen to the left of <op> which
 999 ;;;         rightly belongs to <op> on the basis of parse precedence rules.
1000
1001 (defun parse-nary (op l)
1002   (list* (pos op)                           ; Operator's mode
1003          (mheader op)                       ; Normal Macsyma operator header
1004          (convert l (lpos op))              ; Check type-match of arg1
1005          (prsnary op (lpos op) (lbp op))))  ; Search for other args
1006
1007 ;;; (PARSE-MATCHFIX <lop>)
1008 ;;;
1009 ;;;  Parses matchfix forms. eg, [form1,form2,...] or (form1,form2,...)
1010 ;;;
1011 ;;;  This should be the NUD property on an operator. It fires after <op>
1012 ;;;  has been seen. It parses <lop><form1>,<form2>,...<rop> returning
1013 ;;;  ( <mode> . ((<lop>) <form1> <form2> ...) ).
1014
1015 (defun parse-matchfix (op)
1016   (list* (pos op)                                ; Operator's mode
1017          (mheader op)                            ; Normal Macsyma operator header
1018          (prsmatch (safe-get op 'match) (lpos op))))  ; Search for matchfixed forms
1019
1020 ;;; (PARSE-NOFIX <op>)
1021 ;;;
1022 ;;;  Parses an operator of no args. eg, @+X where @ designates a function
1023 ;;;  call (eg, @() is implicitly stated by the lone symbol @.)
1024 ;;;
1025 ;;;  This should be a NUD property on an operator which takes no args.
1026 ;;;  It immediately returns ( <mode> . ((<op>)) ).
1027 ;;;
1028 ;;;  <op> is the name of the operator.
1029 ;;;
1030 ;;;  Note: This is not used by default and probably shouldn't be used by
1031 ;;;   someone who doesn't know what he's doing. Example lossage. If @ is
1032 ;;;   a nofix op, then @(3,4) parses, but parses as "@"()(3,4) would -- ie,
1033 ;;;   to ((MQAPPLY) (($@)) 3 4) which is perhaps not what the user will expect.
1034
1035 (defun parse-nofix (op) (list (pos op) (mheader op)))
1036
1037 ;;; (PRSNARY <op> <mode> <rbp>)
1038 ;;;
1039 ;;;  Parses an nary operator tail Eg, ...form2+form3+... or ...form2*form3*...
1040 ;;;
1041 ;;;  Expects to be entered after the leading form and the first call to an
1042 ;;;  nary operator has been seen and popped. Returns a list of parsed forms
1043 ;;;  which belong to that operator. Eg, for X+Y+Z; this should be called
1044 ;;;  after the first + is popped. Returns (Y Z) and leaves the ; token
1045 ;;;  in the parser scan buffer.
1046 ;;;
1047 ;;;  <op>   is the nary operator in question.
1048 ;;;  <rbp>  is (LBP <op>) and is provided for efficiency. It is for use in
1049 ;;;          recursive parses as a binding power to parse for.
1050 ;;;  <mode> is the name of the mode that each form must be.
1051
1052 (defun prsnary (op mode rbp)
1053   (do ((nl (list (parse mode rbp))         ; Get at least one form
1054            (cons (parse mode rbp) nl)))    ;  and keep getting forms
1055       ((not (eq op (first-c)))             ; until a parse pops on a new op
1056        (nreverse nl))                      ;  at which time return forms
1057       (pop-c)))                            ; otherwise pop op
1058
1059 ;;; (PRSMATCH <match> <mode>)
1060 ;;;
1061 ;;; Parses a matchfix sequence. Eg, [form1,form2,...] or (form1,form2,...)
1062 ;;; Expects to be entered after the leading token is the popped (ie, at the
1063 ;;;  point where the parse of form1 will begin). Returns (form1 form2 ...).
1064 ;;;
1065 ;;; <match> is the token to look for as a matchfix character.
1066 ;;; <mode>  is the name of the mode that each form must be.
1067
1068 (defun prsmatch (match mode)                      ; Parse for matchfix char
1069   (cond ((eq match (first-c)) (pop-c) nil)        ; If immediate match, ()
1070         (t                                        ; Else, ...
1071          (do ((nl (list (parse mode 10.))         ;  Get first element
1072                   (cons (parse mode 10.) nl)))    ;   and Keep adding elements
1073              ((eq match (first-c))                ;  Until we hit the match.
1074               (pop-c)                             ;   Throw away match.
1075               (nreverse nl))                      ;   Put result back in order
1076            (if (eq '|$,| (first-c))               ;  If not end, look for ","
1077                (pop-c)                            ;   and pop it if it's there
1078                (mread-synerr "Missing ~A"         ;   or give an error message.
1079                              (mopstrip match)))))))
1080
1081 ;;; (CONVERT <exp> <mode>)
1082 ;;;
1083 ;;;  Parser coercion function.
1084 ;;;
1085 ;;;  <exp>  should have the form ( <expressionmode> . <expression> )
1086 ;;;  <mode> is the target mode.
1087 ;;;
1088 ;;;  If <expressionmode> and <mode> are compatible, returns <expression>.
1089
1090 (defun convert (item mode)
1091   (if (or (eq mode (car item))          ; If modes match exactly
1092           (eq '$any mode)               ;    or target is $ANY
1093           (eq '$any (car item)))        ;    or input is $ANY
1094       (cdr item)                        ;  then return expression
1095       (mread-synerr "Found ~A expression where ~A expression expected"
1096                     (get (car item) 'english)
1097                     (get mode       'english))))
1098
1099 (defprop $any    "untyped"   english)
1100 (defprop $clause "logical"   english)
1101 (defprop $expr   "algebraic" english)
1102
1103 ;;;; Parser Error Diagnostics
1104
1105  ;; Call this for random user-generated parse errors
1106
1107 (defun parse-err () (mread-synerr "Syntax error"))
1108
1109  ;; Call this for random internal parser lossage (eg, code that shouldn't
1110  ;;  be reachable.)
1111
1112 (defun parse-bug-err (op)
1113   (mread-synerr
1114     "Parser bug in ~A. Please report this to the Maxima maintainers,~
1115    ~%including the characters you just typed which caused the error. Thanks."
1116     (mopstrip op)))
1117
1118 ;;; Random shared error messages
1119
1120 (defun delim-err (op)
1121   (mread-synerr "Illegal use of delimiter ~A" (mopstrip op)))
1122
1123 (defun erb-err (op l) l ;Ignored
1124   (mread-synerr "Too many ~A's" (mopstrip op)))
1125
1126 (defun premterm-err (op)
1127   (mread-synerr "Premature termination of input at ~A."
1128                 (mopstrip op)))
1129
1130 ;;;; Operator Specific Data
1131
1132 (def-nud-equiv |$]| delim-err)
1133 (def-led-equiv |$]| erb-err)
1134 (def-lbp     |$]| 5.)
1135
1136 (def-nud-equiv  |$[| parse-matchfix)
1137 (def-match      |$[| |$]|)
1138 (def-lbp        |$[| 200.)
1139 ;No RBP
1140 (def-mheader    |$[| (mlist))
1141 (def-pos        |$[| $any)
1142 (def-lpos       |$[| $any)
1143 ;No RPOS
1144
1145 (def-led (|$[| 200.) (op left)
1146   (setq left (convert left '$any))
1147   (if (numberp left) (parse-err))                       ; number[...] invalid
1148   (let ((header (if (atom left)
1149                     (add-lineinfo (list (amperchk left) 'array))
1150                   (add-lineinfo '(mqapply array))))
1151         (right (prsmatch '|$]| '$any)))                 ; get sublist in RIGHT
1152     (cond ((null right)                                 ; 1 subscript minimum
1153            (mread-synerr "No subscripts given"))
1154           ((atom left)                                  ; atom[...]
1155            (setq right (cons header
1156                              right))
1157            (cons '$any (aliaslookup right)))
1158           (t                                            ; exp[...]
1159            (cons '$any (cons header
1160                              (cons left right)))))))
1161
1162
1163 (def-nud-equiv |$)| delim-err)
1164 (def-led-equiv |$)| erb-err)
1165 (def-lbp       |$)| 5.)
1166
1167 (def-mheader   |$(| (mprogn))
1168
1169   ;; KMP: This function optimizes out (exp) into just exp.
1170   ;;  This is useful for mathy expressions, but obnoxious for non-mathy
1171   ;;  expressions. I think DISPLA should be made smart about such things,
1172   ;;  but probably the (...) should be carried around in the internal
1173   ;;  representation. This would make things like BUILDQ much easier to
1174   ;;  work with.
1175   ;; GJC: CGOL has the same behavior, so users tend to write extensions
1176   ;;  to the parser rather than write Macros per se. The transformation
1177   ;;  "(EXP)" ==> "EXP" is done by the evaluator anyway, the problem
1178   ;;  comes inside quoted expressions. There are many other problems with
1179   ;;  the "QUOTE" concept however.
1180
1181 (def-nud (|$(| 200.) (op)
1182   (let ((right)(hdr (mheader '|$(|)))        ; make mheader first for lineinfo
1183     (cond ((eq '|$)| (first-c)) (parse-err))              ; () is illegal
1184           ((or (null (setq right (prsmatch '|$)| '$any))) ; No args to MPROGN??
1185                (cdr right))                               ;  More than one arg.
1186           (when (suspicious-mprogn-p right)
1187             (mtell (intl:gettext "warning: parser: I'll let it stand, but (...) doesn't recognize local variables.~%"))
1188             (mtell (intl:gettext "warning: parser: did you mean to say: block(~M, ...) ?~%") (car right)))
1189            (cons '$any (cons hdr right)))         ; Return an MPROGN
1190           (t (cons '$any (car right))))))                 ; Optimize out MPROGN
1191
1192 (defun suspicious-mprogn-p (right)
1193   ;; Look for a Maxima list of symbols or assignments to symbols.
1194   (and ($listp (car right))
1195        (every #'(lambda (e) (or (symbolp e)
1196                                 (and (consp e) (eq (caar e) 'msetq) (symbolp (second e)))))
1197               (rest (car right)))))
1198
1199 (def-led (|$(| 200.) (op left)
1200   (setq left (convert left '$any))                      ;De-reference LEFT
1201   (if (numberp left) (parse-err))                       ;number(...) illegal
1202   (let ((hdr (and (atom left)(mheader (amperchk left))))
1203         (r (prsmatch '|$)| '$any))                       ;Get arglist in R
1204         )
1205     (cons '$any                                         ;Result is type $ANY
1206           (cond ((atom left)                            ;If atom(...) =>
1207                  (cons hdr r))    ;(($atom) exp . args)
1208                 (t                                      ;Else exp(...) =>
1209                  (cons '(mqapply) (cons left r)))))))   ;((MQAPPLY) op . args)
1210
1211 (def-mheader |$'| (mquote))
1212
1213 (def-nud (|$'|) (op)
1214   (let (right)
1215     (cond ((eq '|$(| (first-c))
1216            (list '$any (mheader '|$'|) (parse '$any 190.)))
1217           ((or (atom (setq right (parse '$any 190.)))
1218                (member (caar right) '(mquote mlist $set mprog mprogn lambda) :test #'eq))
1219            (list '$any (mheader '|$'|) right))
1220           ((eq 'mqapply (caar right))
1221            (cond ((eq (caaadr right) 'lambda)
1222                   (list '$any (mheader '|$'|) right))
1223                  (t (rplaca (cdr right)
1224                             (cons (cons ($nounify (caaadr right))
1225                                         (cdaadr right))
1226                                   (cdadr right)))
1227                     (cons '$any right))))
1228           (t (cons '$any (cons (cons ($nounify (caar right)) (cdar right))
1229                                (cdr right)))))))
1230
1231 (def-nud (|$''|) (op)
1232   (let (right)
1233     (cons '$any
1234           (cond ((eq '|$(| (first-c))  (meval (parse '$any 190.)))
1235                 ((atom (setq right (parse '$any 190.))) (meval1 right))
1236                 ((eq 'mqapply (caar right))
1237                  (rplaca (cdr right)
1238                          (cons (cons ($verbify (caaadr right)) (cdaadr right))
1239                                (cdadr right)))
1240                  right)
1241                 (t (cons (cons ($verbify (caar right)) (cdar right))
1242                          (cdr right)))))))
1243
1244 (def-led-equiv |$:| parse-infix)
1245 (def-lbp       |$:| 180.)
1246 (def-rbp       |$:|  20.)
1247 (def-pos       |$:| $any)
1248 (def-rpos      |$:| $any)
1249 (def-lpos      |$:| $any)
1250 (def-mheader   |$:| (msetq))
1251
1252 (def-led-equiv |$::| parse-infix)
1253 (def-lbp       |$::| 180.)
1254 (def-rbp       |$::|  20.)
1255 (def-pos       |$::| $any)
1256 (def-rpos      |$::| $any)
1257 (def-lpos      |$::| $any)
1258 (def-mheader   |$::| (mset))
1259
1260 (def-led-equiv |$:=| parse-infix)
1261 (def-lbp       |$:=| 180.)
1262 (def-rbp       |$:=|  20.)
1263 (def-pos       |$:=| $any)
1264 (def-rpos      |$:=| $any)
1265 (def-lpos      |$:=| $any)
1266 (def-mheader   |$:=| (mdefine))
1267
1268 (def-led-equiv |$::=| parse-infix)
1269 (def-lbp       |$::=| 180.)
1270 (def-rbp       |$::=|  20.)
1271 (def-pos       |$::=| $any)
1272 (def-rpos      |$::=| $any)
1273 (def-lpos      |$::=| $any)
1274 (def-mheader   |$::=| (mdefmacro))
1275
1276 (def-led-equiv  |$!| parse-postfix)
1277 (def-lbp        |$!| 160.)
1278 ;No RBP
1279 (def-pos        |$!| $expr)
1280 (def-lpos       |$!| $expr)
1281 ;No RPOS
1282 (def-mheader    |$!| (mfactorial))
1283
1284 (def-mheader |$!!| (%genfact))
1285
1286 (def-led (|$!!| 160.) (op left)
1287   (list '$expr
1288         (mheader '$!!)
1289         (convert left '$expr)
1290         (list (mheader '$/) (convert left '$expr) 2)
1291         2))
1292
1293 (def-lbp     |$^| 140.)
1294 (def-rbp     |$^| 139.)
1295 (def-pos     |$^| $expr)
1296 (def-lpos    |$^| $expr)
1297 (def-rpos    |$^| $expr)
1298 (def-mheader |$^| (mexpt))
1299
1300 (def-led ((|$^| |$^^|)) (op left)
1301   (cons '$expr
1302         (aliaslookup (list (mheader op)
1303                            (convert left (lpos op))
1304                            (parse (rpos op) (rbp op))))))
1305
1306 (mapc #'(lambda (prop) ; Make $** like $^
1307           (let ((propval (get '$^ prop)))
1308             (if propval (putprop '$** propval prop))))
1309       '(lbp rbp pos rpos lpos mheader))
1310
1311 (inherit-propl  '$** '$^ (led-propl))
1312
1313 (def-lbp     |$^^| 140.)
1314 (def-rbp     |$^^| 139.)
1315 (def-pos     |$^^| $expr)
1316 (def-lpos    |$^^| $expr)
1317 (def-rpos    |$^^| $expr)
1318 (def-mheader |$^^| (mncexpt))
1319
1320 ;; note y^^4.z gives an error because it scans the number 4 together with
1321 ;; the trailing '.' as a decimal place.    I think the error is correct.
1322 (def-led-equiv  |$.| parse-infix)
1323 (def-lbp        |$.| 130.)
1324 (def-rbp        |$.| 129.)
1325 (def-pos        |$.| $expr)
1326 (def-lpos       |$.| $expr)
1327 (def-rpos       |$.| $expr)
1328 (def-mheader    |$.| (mnctimes))
1329
1330 ;; Copy properties to noun operator.
1331 (setf (get '%mnctimes 'op) (get 'mnctimes 'op))
1332
1333 (def-led-equiv  |$*| parse-nary)
1334 (def-lbp        |$*| 120.)
1335 ;RBP not needed
1336 (def-pos        |$*| $expr)
1337 ;RPOS not needed
1338 (def-lpos       |$*| $expr)
1339 (def-mheader    |$*| (mtimes))
1340
1341 (def-led-equiv  $/  parse-infix)
1342 (def-lbp        $/  120.)
1343 (def-rbp        $/  120.)
1344 (def-pos        $/  $expr)
1345 (def-rpos       $/  $expr)
1346 (def-lpos       $/  $expr)
1347 (def-mheader    $/  (mquotient))
1348
1349 (def-nud-equiv  |$+| parse-prefix)
1350 (def-lbp        |$+| 100.)
1351 (def-rbp        |$+| 134.) ; Value increased from 100 to 134 (DK 02/2010).
1352 (def-pos        |$+| $expr)
1353 (def-rpos       |$+| $expr)
1354 ;LPOS not needed
1355 (def-mheader    |$+| (mplus))
1356
1357 (def-led ((|$+| |$-|) 100.) (op left)
1358   (setq left (convert left '$expr))
1359   (do ((nl (list (if (eq op '$-)
1360                      (list (mheader '$-) (parse '$expr 100.))
1361                      (parse '$expr 100.))
1362                  left)
1363            (cons (parse '$expr 100.) nl)))
1364       ((not (member (first-c) '($+ $-) :test #'eq))
1365        (list* '$expr (mheader '$+) (nreverse nl)))
1366     (if (eq (first-c) '$+) (pop-c))))
1367
1368 (def-nud-equiv  |$-| parse-prefix)
1369 (def-lbp        |$-| 100.)
1370 (def-rbp        |$-| 134.)
1371 (def-pos        |$-| $expr)
1372 (def-rpos       |$-| $expr)
1373 ;LPOS not needed
1374 (def-mheader    |$-| (mminus))
1375
1376 (def-led-equiv  |$=| parse-infix)
1377 (def-lbp        |$=| 80.)
1378 (def-rbp        |$=| 80.)
1379 (def-pos        |$=| $clause)
1380 (def-rpos       |$=| $expr)
1381 (def-lpos       |$=| $expr)
1382 (def-mheader    |$=| (mequal))
1383
1384 (def-led-equiv  |$#| parse-infix)
1385 (def-lbp        |$#| 80.)
1386 (def-rbp        |$#| 80.)
1387 (def-pos        |$#| $clause)
1388 (def-rpos       |$#| $expr)
1389 (def-lpos       |$#| $expr)
1390 (def-mheader    |$#| (mnotequal))
1391
1392 (def-led-equiv  |$>| parse-infix)
1393 (def-lbp        |$>| 80.)
1394 (def-rbp        |$>| 80.)
1395 (def-pos        |$>| $clause)
1396 (def-rpos       |$>| $expr)
1397 (def-lpos       |$>| $expr)
1398 (def-mheader    |$>| (mgreaterp))
1399
1400 (def-led-equiv  |$>=| parse-infix)
1401 (def-lbp        |$>=| 80.)
1402 (def-rbp        |$>=| 80.)
1403 (def-pos        |$>=| $clause)
1404 (def-rpos       |$>=| $expr)
1405 (def-lpos       |$>=| $expr)
1406 (def-mheader    |$>=| (mgeqp))
1407
1408 (def-led-equiv  |$<| parse-infix)
1409 (def-lbp        |$<| 80.)
1410 (def-rbp        |$<| 80.)
1411 (def-pos        |$<| $clause)
1412 (def-rpos       |$<| $expr)
1413 (def-lpos       |$<| $expr)
1414 (def-mheader    |$<| (mlessp))
1415
1416 (def-led-equiv  |$<=| parse-infix)
1417 (def-lbp        |$<=| 80.)
1418 (def-rbp        |$<=| 80.)
1419 (def-pos        |$<=| $clause)
1420 (def-rpos       |$<=| $expr)
1421 (def-lpos       |$<=| $expr)
1422 (def-mheader    |$<=| (mleqp))
1423
1424 (def-nud-equiv  $not parse-prefix)
1425 ;LBP not needed
1426 (def-rbp        $not 70.)
1427 (def-pos        $not $clause)
1428 (def-rpos       $not $clause)
1429 (def-lpos       $not $clause)
1430 (def-mheader    $not (mnot))
1431
1432 (def-led-equiv  $and parse-nary)
1433 (def-lbp        $and 65.)
1434 ;RBP not needed
1435 (def-pos        $and $clause)
1436 ;RPOS not needed
1437 (def-lpos       $and $clause)
1438 (def-mheader    $and (mand))
1439
1440 (def-led-equiv  $or parse-nary)
1441 (def-lbp        $or 60.)
1442 ;RBP not needed
1443 (def-pos        $or $clause)
1444 ;RPOS not needed
1445 (def-lpos       $or $clause)
1446 (def-mheader    $or (mor))
1447
1448 (def-led-equiv  |$,| parse-nary)
1449 (def-lbp        |$,| 10.)
1450 ;RBP not needed
1451 (def-pos        |$,| $any)
1452 ;RPOS not needed
1453 (def-lpos       |$,| $any)
1454 (def-mheader    |$,| ($ev))
1455
1456 (def-nud-equiv $then delim-err)
1457 (def-lbp $then 5.)
1458 (def-rbp $then 25.)
1459
1460 (def-nud-equiv $else delim-err)
1461 (def-lbp $else 5.)
1462 (def-rbp $else 25.)
1463
1464 (def-nud-equiv $elseif delim-err)
1465 (def-lbp  $elseif 5.)
1466 (def-rbp  $elseif 45.)
1467 (def-pos  $elseif $any)
1468 (def-rpos $elseif $clause)
1469
1470 ;No LBP - Default as high as possible
1471 (def-rbp     $if 45.)
1472 (def-pos     $if $any)
1473 (def-rpos    $if $clause)
1474 ;No LPOS
1475 (def-mheader $if (mcond))
1476
1477 (def-nud ($if) (op)
1478   (list* (pos op)
1479          (mheader op)
1480          (parse-condition op)))
1481
1482 (defun parse-condition (op)
1483   (list* (parse (rpos op) (rbp op))
1484          (if (eq (first-c) '$then)
1485              (parse '$any (rbp (pop-c)))
1486              (mread-synerr "Missing `then'"))
1487          (case (first-c)
1488            (($else)   (list t (parse '$any (rbp (pop-c)))))
1489            (($elseif) (parse-condition (pop-c)))
1490            (t         (list t '$false)))))
1491
1492 (def-mheader $do (mdo))
1493
1494 (defun parse-$do (lex &aux (left (make-mdo)))
1495   (setf (car left) (mheader 'mdo))
1496   (do ((op lex (pop-c))  (active-bitmask 0))
1497       (nil)
1498     (if (eq op '|$:|) (setq op '$from))
1499     (setq active-bitmask (collision-check '$do active-bitmask op))
1500     (let ((data (parse (rpos op) (rbp op))))
1501       (case op
1502         ($do            (setf (mdo-body left) data) (return (cons '$any left)))
1503         ($for           (setf (mdo-for  left) data))
1504         ($from          (setf (mdo-from left) data))
1505         ($in            (setf (mdo-op   left) 'mdoin)
1506                         (setf (mdo-from left) data))
1507         ($step          (setf (mdo-step left) data))
1508         ($next          (setf (mdo-next left) data))
1509         ($thru          (setf (mdo-thru left) data))
1510         (($unless $while)
1511                         (if (eq op '$while)
1512                             (setq data (list (mheader '$not) data)))
1513                         (setf (mdo-unless left)
1514                            (if (null (mdo-unless left))
1515                                data
1516                                (list (mheader '$or) data (mdo-unless left)))))
1517         (t (parse-bug-err '$do))))))
1518
1519 (def-lbp $for    25.)
1520 (def-lbp $from   25.)
1521 (def-lbp $step   25.)
1522 (def-lbp $next   25.)
1523 (def-lbp $thru   25.)
1524 (def-lbp $unless 25.)
1525 (def-lbp $while  25.)
1526 (def-lbp $do     25.)
1527
1528 (def-nud-equiv $for    parse-$do)
1529 (def-nud-equiv $from   parse-$do)
1530 (def-nud-equiv $step   parse-$do)
1531 (def-nud-equiv $next   parse-$do)
1532 (def-nud-equiv $thru   parse-$do)
1533 (def-nud-equiv $unless parse-$do)
1534 (def-nud-equiv $while  parse-$do)
1535 (def-nud-equiv $do     parse-$do)
1536
1537 (def-rbp $do      25.)
1538 (def-rbp $for    200.)
1539 (def-rbp $from    95.)
1540 (def-rbp $in      95.)
1541 (def-rbp $step    95.)
1542 (def-rbp $next    45.)
1543 (def-rbp $thru    95.)
1544 (def-rbp $unless  45.)
1545 (def-rbp $while   45.)
1546
1547 (def-rpos $do     $any)
1548 (def-rpos $for    $any)
1549 (def-rpos $from   $any)
1550 (def-rpos $step   $expr)
1551 (def-rpos $next   $any)
1552 (def-rpos $thru   $expr)
1553 (def-rpos $unless $clause)
1554 (def-rpos $while  $clause)
1555
1556
1557 (def-collisions $do
1558   ($do     . ())
1559   ($for    . ($for))
1560   ($from   . ($in $from))
1561   ($in     . ($in $from $step $next $thru))
1562   ($step   . ($in       $step $next))
1563   ($next   . ($in       $step $next))
1564   ($thru   . ($in $thru)) ;$IN didn't used to get checked for
1565   ($unless . ())
1566   ($while  . ()))
1567
1568 (def-mheader   |$$| (nodisplayinput))
1569 (def-nud-equiv |$$| premterm-err)
1570 (def-lbp       |$$| -1)
1571 ;No RBP, POS, RPOS, RBP, or MHEADER
1572
1573 (def-mheader   |$;| (displayinput))
1574 (def-nud-equiv |$;| premterm-err)
1575 (def-lbp       |$;| -1)
1576 ;No RBP, POS, RPOS, RBP, or MHEADER
1577
1578 (def-nud-equiv  |$&&| delim-err)
1579 (def-lbp        |$&&| -1)
1580
1581 (defun mopstrip (x)
1582   ;; kludge interface function to allow the use of lisp PRINC in places.
1583   (cond ((null x) 'false)
1584         ((or (eq x t) (eq x 't)) 'true)
1585         ((numberp x) x)
1586         ((symbolp x)
1587          (or (get x 'reversealias)
1588              (let ((name (symbol-name x)))
1589                (if (member (char name 0) '(#\$ #\%) :test #'char=)
1590                    (subseq name 1)
1591                    name))))
1592         (t x)))
1593
1594 (define-initial-symbols
1595     ;; * Note: /. is looked for explicitly rather than
1596     ;;     existing in this chart. The reason is that
1597     ;;     it serves a dual role (as a decimal point) and
1598     ;;     must be special-cased.
1599     ;;
1600     ;;     Same for // because of the /* ... */ handling
1601     ;;     by the tokenizer
1602     ;; Single character
1603     |+| |-| |*| |^| |<| |=| |>| |(| |)| |[| |]| |,|
1604     |:| |!| |#| |'| |;| |$| |&|
1605     ;;Two character
1606     |**| |^^| |:=| |::| |!!| |<=| |>=| |''| |&&|
1607     ;; Three character
1608     |::=|
1609     )
1610
1611 ;; !! FOLLOWING MOVED HERE FROM MLISP.LISP (DEFSTRUCT STUFF)
1612 ;; !! SEE NOTE THERE
1613 (define-symbol "@")
1614
1615 ;;; User extensibility:
1616 (defmfun $prefix (operator &optional (rbp  180.)
1617                                      (rpos '$any)
1618                                      (pos  '$any))
1619   (def-operator operator pos ()  ()     rbp rpos () t
1620                 '(nud . parse-prefix) 'msize-prefix 'dimension-prefix ()   )
1621   operator)
1622
1623 (defmfun $postfix (operator &optional (lbp  180.)
1624                                      (lpos '$any)
1625                                      (pos  '$any))
1626   (def-operator operator pos lbp lpos   ()  ()   t  ()
1627                 '(led . parse-postfix) 'msize-postfix 'dimension-postfix  ()   )
1628   operator)
1629
1630 (defmfun $infix  (operator &optional (lbp  180.)
1631                                      (rbp  180.)
1632                                      (lpos '$any)
1633                                      (rpos '$any)
1634                                      (pos  '$any))
1635   (def-operator operator pos lbp lpos   rbp rpos t t
1636                 '(led . parse-infix) 'msize-infix 'dimension-infix () )
1637   operator)
1638
1639 (defmfun $nary   (operator &optional (bp     180.)
1640                                      (argpos '$any)
1641                                      (pos    '$any))
1642   (def-operator operator pos bp  argpos bp  ()   t t
1643                 '(led . parse-nary) 'msize-nary 'dimension-nary () )
1644   operator)
1645
1646 (defmfun $matchfix (operator
1647                     match  &optional (argpos '$any)
1648                                      (pos    '$any))
1649   ;shouldn't MATCH be optional?
1650   (def-operator operator pos ()  argpos ()  ()  () ()
1651                 '(nud . parse-matchfix) 'msize-matchfix 'dimension-match match)
1652   operator)
1653
1654 (defmfun $nofix  (operator &optional (pos '$any))
1655   (def-operator operator pos ()  ()     ()  () () ()
1656                 '(nud . parse-nofix) 'msize-nofix 'dimension-nofix ()   )
1657   operator)
1658
1659 ;;; (DEF-OPERATOR op pos lbp lpos rbp rpos sp1 sp2
1660 ;;;     parse-data grind-fn dim-fn match)
1661 ;;; OP        is the operator name.
1662 ;;; POS       is its ``part of speech.''
1663 ;;; LBP       is its ``left binding power.''
1664 ;;; LPOS      is the part of speech of the arguments to its left, or of all.
1665 ;;;            arguments for NARY and MATCHFIX.
1666 ;;; RBP       is its ``right binding power.''
1667 ;;; RPOS      is the part of speech of the argument to its right.
1668 ;;; SP1       says if the DISSYM property needs a space on the right.
1669 ;;; SP2       says if the DISSYM property needs a space on the left.
1670 ;;; PARSE-DATA is (prop . fn) -- parser prop name dotted with function name
1671 ;;; GRIND-FN  is the grinder function for the operator.
1672 ;;; DIM-FN    is the dimension function for the operator.
1673 ;;; PARSEPROP is the property name to use for parsing. One of LED or NUD.
1674 ;;; MATCH     if non-(), ignores SP1 and SP2. Should be the match symbol.
1675 ;;;             sets OP up as matchfix with MATCH.
1676 ;;;
1677 ;;; For more complete descriptions of these naming conventions, see
1678 ;;; the comments in GRAM package, which describe them in reasonable detail.
1679
1680 (defun def-operator (op pos lbp lpos rbp rpos sp1 sp2
1681                         parse-data grind-fn dim-fn match)
1682   (let ((x))
1683     (if (or (and rbp (not (integerp (setq x rbp))))
1684             (and lbp (not (integerp (setq x lbp)))))
1685         (merror (intl:gettext "syntax extension: binding powers must be integers; found: ~M") x))
1686     (if (stringp op) (setq op (define-symbol op)))
1687     (op-setup op)
1688     (let ((noun   ($nounify op))
1689           (dissym (cdr (exploden op))))
1690       (cond
1691        ((not match)
1692         (setq dissym (append (if sp1 '(#\space)) dissym (if sp2 '(#\space)))))
1693        (t (if (stringp match) (setq match (define-symbol match)))
1694           (op-setup match)
1695           (putprop op    match 'match)
1696           (putprop match 5.    'lbp)
1697           (setq dissym (cons dissym (cdr (exploden match))))))
1698       (putprop op pos 'pos)
1699       (putprop op (cdr parse-data) (car parse-data))
1700       (putprop op   grind-fn  'grind)
1701       (putprop op   dim-fn    'dimension)
1702       (putprop noun dim-fn    'dimension)
1703       (putprop op   dissym 'dissym)
1704       (putprop noun dissym 'dissym)
1705       (when rbp
1706         (putprop op   rbp  'rbp)
1707         (putprop noun rbp  'rbp))
1708       (when lbp
1709         (putprop op   lbp  'lbp)
1710         (putprop noun lbp  'lbp))
1711       (when lpos (putprop op   lpos 'lpos))
1712       (when rpos (putprop op   rpos 'rpos))
1713       (getopr op))))
1714
1715 (defun op-setup (op)
1716   (let ((dummy (or (get op 'op)
1717                    (coerce (string* op) 'string))))
1718     (putprop op    dummy 'op )
1719     (putopr dummy op)
1720     (if (and (operatorp1 op) (not (member dummy (cdr $props) :test #'eq)))
1721         (push dummy *mopl*))
1722     (add2lnc dummy $props)))
1723
1724 (defun kill-operator (op)
1725   (let
1726     ((opr (get op 'op))
1727      (noun-form ($nounify op)))
1728     ;; Refuse to kill an operator which appears on *BUILTIN-$PROPS*.
1729     (unless (member opr *builtin-$props* :test #'equal)
1730       (undefine-symbol opr)
1731       (remopr opr)
1732       (rempropchk opr)
1733       (mapc #'(lambda (x) (remprop op x))
1734           '(nud nud-expr nud-subr                       ; NUD info
1735                      led led-expr led-subr              ; LED info
1736                      lbp rbp                    ; Binding power info
1737                      lpos rpos pos              ; Part-Of-Speech info
1738                      grind dimension dissym     ; Display info
1739                      op))                       ; Operator info
1740       (mapc #'(lambda (x) (remprop noun-form x))
1741           '(dimension dissym lbp rbp)))))
1742
1743
1744
1745 ;; the functions get-instream etc.. are all defined in
1746 ;; gcl lsp/debug.lsp
1747 ;; they are all generic common lisp and could be used by
1748 ;; any Common lisp implementation.
1749
1750 #-gcl
1751 (defstruct instream
1752   stream
1753   (line 0 :type fixnum)
1754   stream-name)
1755
1756 #-gcl
1757 (defvar *stream-alist* nil)
1758
1759 #-gcl
1760 (defun stream-name (path)
1761   (let ((errset nil))
1762     (car (errset (namestring (pathname path))))))
1763
1764 #-gcl
1765 (defun instream-name (instr)
1766   (or (instream-stream-name instr)
1767       (stream-name (instream-stream instr))))
1768
1769 ;; (closedp stream) checks if a stream is closed.
1770 ;; how to do this in common lisp!!
1771
1772 #-gcl
1773 (defun cleanup ()
1774   #+never-clean-up-dont-know-how-to-close
1775   (dolist (v *stream-alist*)
1776     (if (closedp (instream-stream v))
1777         (setq *stream-alist* (delete v *stream-alist*)))))
1778
1779 #-gcl
1780 (defun get-instream (str)
1781   (or (dolist (v *stream-alist*)
1782         (cond ((eq str (instream-stream v))
1783                (return v))))
1784       (let (name errset)
1785         (errset (setq name (namestring str)))
1786         (car (setq *stream-alist*
1787                    (cons  (make-instream :stream str :stream-name name)
1788                           *stream-alist*))))))
1789
1790 (defun newline (str)
1791   (incf (instream-line (get-instream str)))
1792   (values))
1793
1794 (defun find-stream (stream)
1795    (dolist (v *stream-alist*)
1796         (cond ((eq stream (instream-stream v))
1797                (return v)))))
1798
1799
1800 (defun add-lineinfo (lis)
1801   (if (or (atom lis)
1802           (eq *parse-stream* *parse-string-input-stream*) ;; avoid consing *parse-string-input-stream*
1803                                                           ;;   via get-instream to *stream-alist*
1804           (and (eq *parse-window* *standard-input*)
1805                (not (find-stream *parse-stream*)) ))
1806     lis
1807     (let* ((st (get-instream *parse-stream*))
1808            (n (instream-line st))
1809            (nam (instream-name st)))
1810       (or nam (return-from add-lineinfo lis))
1811       (setq *current-line-info*
1812             (cond ((eq (cadr *current-line-info*) nam)
1813                    (cond ((eql (car *current-line-info*) n)
1814                           *current-line-info*)
1815                          (t  (cons n (cdr *current-line-info*)))))
1816                   (t (list n nam  'src))))
1817       (cond ((null (cdr lis))
1818              (list (car lis) *current-line-info*))
1819             (t (append lis (list *current-line-info*)))))))
1820
1821 ;; Remove debugging stuff.
1822 ;; STRIP-LINEINFO does not modify EXPR.
1823
1824 (defun strip-lineinfo (expr)
1825   (if (or (atom expr) (specrepp expr))
1826       expr
1827       (cons (strip-lineinfo-op (car expr)) (mapcar #'strip-lineinfo (cdr expr)))))
1828
1829 ;; If something in the operator looks like debugging stuff, remove it.
1830 ;; It is assumed here that debugging stuff is a list comprising an integer and a string
1831 ;; (and maybe other stuff, which is ignored).
1832
1833 (defun strip-lineinfo-op (maxima-op)
1834   (remove-if #'(lambda (x) (and (consp x) (integerp (first x)) (stringp (second x)))) maxima-op))