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