← Back to branch summary

~ubuntu-branches/debian/squeeze/maxima/squeeze

« back to all changes in this revision

Viewing changes to src/nparse.lisp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2006-10-18 14:52:42 UTC
  • mto: (1.1.5 upstream)
  • mto: This revision was merged to the branch mainline in revision 4.
  • Revision ID: james.westby@ubuntu.com-20061018145242-vzyrm5hmxr8kiosf
Import upstream version 5.10.0

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/nparse.lisp
8
8
;;;     (c) Copyright 1981 Massachusetts Institute of Technology         ;;;
9
9
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
10
10
 
11
 
(in-package "MAXIMA")
 
11
(in-package :maxima)
12
12
 
13
13
(macsyma-module nparse)
14
14
(load-macsyma-macros defcal mopers)
15
15
 
16
16
(proclaim '(optimize (safety 2) (speed 2) (space 2)))
17
 
(DEFMVAR ALPHABET
 
17
(defmvar alphabet
18
18
  '(#\_ #\%)
19
19
  "alphabetic exceptions list")
20
20
;;;  Note: The following algorithms work only in environments where 
22
22
;;;        Normal ASCII and LispM encoding makes this true. If we ever
23
23
;;;        bring this up on EBCDIC machines, we may lose.
24
24
 
25
 
(DEFMACRO IMEMBER (X L)
26
 
  #+(OR CL NIL) `(MEMBER ,X ,L)
27
 
  #-(OR CL NIL) `(zl-MEMBER ,X ,L))
28
 
 
29
 
#-cl ;;defined in commac or via common
30
 
(cond ((not (fboundp 'char<=)))
31
 
 (defun char<= (a b) (<= a b))
32
 
 (defun char>= (a b) (>= a b)))
33
 
 
34
 
 
35
 
(PROGN
36
 
 
37
 
(DEFMVAR ALPHABET '(#\_ #\%))
38
 
 
39
 
(DEFMFUN ALPHABETP (N)
40
 
 #-cl (DECLARE (FIXNUM N))
41
 
 (and (characterp n)
42
 
 (OR (AND (CHAR>= N #\A) (CHAR<= N #\Z))  ; upper case
43
 
     (AND (CHAR>= N #\a) (CHAR<= N #\z)) ; lower case
44
 
     (imember n '(#\_ #\%))
45
 
     (IMEMBER N ALPHABET))))
 
25
(defmacro imember (x l)
 
26
  `(member ,x ,l))
 
27
 
 
28
;#-cl ;;defined in commac or via common
 
29
;(cond ((not (fboundp 'char<=)))
 
30
; (defun char<= (a b) (<= a b))
 
31
; (defun char>= (a b) (>= a b)))
 
32
 
 
33
 
 
34
(progn
 
35
 
 
36
  (defmvar alphabet '(#\_ #\%))
 
37
 
 
38
  (defmfun alphabetp (n)
 
39
    #-cl (declare (fixnum n))
 
40
    (and (characterp n)
 
41
         (or (and (char>= n #\A) (char<= n #\Z)) ; upper case
 
42
             (and (char>= n #\a) (char<= n #\z)) ; lower case
 
43
             (imember n '(#\_ #\%))
 
44
             (imember n alphabet))))
46
45
; test for %, _, or other declared
47
 
                                  ;    alphabetic characters.
48
 
(DEFMFUN ASCII-NUMBERP (NUM)
49
 
  #-cl (DECLARE (FIXNUM NUM))
50
 
  (AND (characterp num) (CHAR<= NUM #\9) (CHAR>= NUM #\0)))
51
 
 
52
 
(DEFUN GETALIAS (X) (COND ((GET X 'ALIAS)) ((EQ X '$FALSE) NIL) (T X)))
53
 
 
54
 
)
 
46
                                        ;    alphabetic characters.
 
47
  (defmfun ascii-numberp (num)
 
48
    (and (characterp num) (char<= num #\9) (char>= num #\0))))
55
49
 
56
50
 ;End of #-LISPM
57
51
 
61
55
 
62
56
(defvar *parse-window* nil)
63
57
 
64
 
(DEFUN MREAD-SYNERR (sSTRING &REST L)
 
58
(defun mread-synerr (sstring &rest l)
65
59
;  #+lispm (sys:parse-ferror    (format nil sstring l)  :correct-input )
66
 
  #+lispm (dbg:parse-ferror    (format nil sstring l)  :correct-input )
67
 
  #+(OR  NIL) (APPLY #'ERROR #+LISPM NIL #+NIL ':READ-ERROR sSTRING L)
68
 
  #-(OR LISPM NIL)
 
60
;  #+lispm (dbg:parse-ferror    (format nil sstring l)  :correct-input )
 
61
  #+(or  nil) (apply #'error #+lispm nil #+nil ':read-error sstring l)
 
62
  #-(or lispm nil)
69
63
  (progn 
70
64
    (let (tem 
71
65
          errset
77
71
            (t ;(terpri)
78
72
               ))
79
73
      (format t "Incorrect syntax: ")
80
 
      (apply 'format t sstring l)
 
74
      (apply 'format t sstring (mapcar #'(lambda (x)
 
75
                                           (if (symbolp x)
 
76
                                               (print-invert-case x)
 
77
                                               x))
 
78
                                       l))
81
79
      (cond ((output-stream-p *standard-input*)
82
80
             (let ((n (get '*parse-window* 'length))
83
81
                   some ch
84
82
                   k
85
83
                   )
86
 
               (sloop for   i below 20
 
84
               (loop for   i below 20
87
85
                      while (setq ch (nth (- n i 1) *parse-window*))
88
86
                                          
89
87
                      do
96
94
                            (t (push ch some))))
97
95
               (setq k (length some))
98
96
               (setq some (append some
99
 
                                  (sloop for i below 20 for tem =
 
97
                                  (loop for i below 20 for tem =
100
98
                                         nil 
101
99
                                         ;(read-char-no-hang)
102
100
                                         while tem collect tem)))
103
101
               (terpri)
104
 
               (sloop for v in some do (princ v))
 
102
               (loop for v in some do (princ v))
105
103
               (terpri)
106
 
               (sloop for i from 2 below k do (princ #\space))
 
104
               (loop for i from 2 below k do (princ #\space))
107
105
               (princ "^")
108
106
               
109
 
               ;(sloop while (read-char-no-hang) )
 
107
               ;(loop while (read-char-no-hang) )
 
108
           (read-line *parse-stream* nil nil)
110
109
               )))
111
110
      (terpri)
112
111
      (throw-macsyma-top) 
125
124
;;;  Otherwise, it returns its argument.
126
125
 
127
126
#+cl
128
 
(DEFUN FIXNUM-CHAR-UPCASE (C)
 
127
(defun fixnum-char-upcase (c)
129
128
  (char-upcase c))
130
129
 
131
130
;  (char-code (char-upcase (code-char c))))
132
131
 
133
132
 
134
 
(DEFUN FIRSTCHARN (X)
135
 
  #+NIL     (CHAR-CODE (CHAR (SYMBOL-NAME X) 0))
136
 
  #+cl (aref (string x) 0)
137
 
  #+MACLISP (GETCHARN X 1))
 
133
(defun firstcharn (x)
 
134
  (aref (string x) 0))
138
135
 
139
 
(DEFVAR *PARSE-STREAM*          ()          "input stream for Macsyma parser")
140
 
(DEFVAR MACSYMA-OPERATORS       ()          "Macsyma operators structure")
141
 
(DEFVAR *MREAD-PROMPT*          nil         "prompt used by MREAD")
142
 
(DEFVAR *MREAD-EOF-OBJ* () "Bound by MREAD for use by MREAD-RAW")
 
136
(defvar *parse-stream*          ()        "input stream for Maxima parser")
 
137
(defvar macsyma-operators       ()        "Maxima operators structure")
 
138
(defvar *mread-prompt*          nil       "prompt used by `mread'")
 
139
(defvar *mread-eof-obj* () "Bound by `mread' for use by `mread-raw'")
143
140
 
144
141
(defun tyi-parse-int (stream eof)
145
142
  (or *parse-window*
146
143
      (progn (setq *parse-window* (make-list 25))
147
144
             (setf (get '*parse-window* 'length) (length *parse-window*))
148
145
             (nconc *parse-window* *parse-window*)))
149
 
  (let ((tem (TYI stream eof)))
 
146
  (let ((tem (tyi stream eof)))
150
147
    (setf (car *parse-window*) tem *parse-window*
151
148
          (cdr *parse-window*))
152
149
    (if (eql tem #\newline) (newline stream #\newline))
187
184
 
188
185
 
189
186
 
190
 
(DEFUN *MREAD-PROMPT* (OUT-STREAM CHAR)
191
 
  CHAR
192
 
  (FORMAT OUT-STREAM "~&~A" *MREAD-PROMPT*))
 
187
(defun *mread-prompt* (out-stream char)
 
188
  char
 
189
  (format out-stream "~&~A" *mread-prompt*))
193
190
  
194
 
(DEFUN ALIASLOOKUP (OP)
195
 
  (IF (SYMBOLP OP)
196
 
      (OR (GET OP 'ALIAS) OP)
197
 
      OP))
 
191
(defun aliaslookup (op)
 
192
  (if (symbolp op)
 
193
      (or (get op 'alias) op)
 
194
      op))
198
195
 
199
 
 
200
196
 
201
197
;;;; Tokenizing
202
198
 
207
203
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
208
204
 
209
205
;; gobble whitespace, recognize '#' comments..
210
 
(DEFUN GOBBLE-WHITESPACE ( &aux saw-newline ch saw-other)
211
 
  (DO () (NIL) ; Gobble whitespace
212
 
      (setq ch (PARSE-TYIPEEK))
 
206
(defun gobble-whitespace ( &aux saw-newline ch saw-other)
 
207
  (do () (nil) ; Gobble whitespace
 
208
      (setq ch (parse-tyipeek))
213
209
      (cond ((eql ch #\newline)
214
210
             (setq saw-other nil)
215
211
             (setq saw-newline t))
216
 
            ((IMEMBER ch
217
 
                  '(#\TAB #\SPACE #\Linefeed #\return ;#\control-C
218
 
                          #\Page))
 
212
            ((imember ch
 
213
                  '(#\tab #\space #\linefeed #\return ;#\control-C
 
214
                          #\page))
219
215
             (setq saw-other t))
220
216
            ;; allow comments to be lines which are whitespace and then
221
217
            ;; a '#' character.
232
228
     (parse-tyi)
233
229
     ))
234
230
 
235
 
(DEFUN READ-COMMAND-TOKEN (OBJ)
236
 
  (GOBBLE-WHITESPACE)
237
 
  (READ-COMMAND-TOKEN-AUX OBJ))
 
231
(defun read-command-token (obj)
 
232
  (gobble-whitespace)
 
233
  (read-command-token-aux obj))
238
234
 
239
235
(defun ch-minusp (z)
240
236
  (and (numberp z) (< z 0)))
241
237
 
242
238
(defun safe-assoc (item lis)
243
239
  "maclisp would not complain about (car 3) it gives nil"
244
 
  (sloop for v in lis
 
240
  (loop for v in lis
245
241
        when (and (consp v)
246
242
                  (equal (car v) item))
247
243
        do
273
269
;; (parser-assoc 1 '(2 (1 4) 3)) ==>(1 4)
274
270
 
275
271
(defun parser-assoc (c lis )
276
 
  (sloop for v on lis
 
272
  (loop for v on lis
277
273
         do
278
274
         (cond ((consp (car v))
279
275
                (if (eq (caar v) c)
292
288
(defun parse-tyi ()
293
289
  (let ((tem  *parse-tyi*))
294
290
    (cond ((null tem)
295
 
           (tyi-parse-int *PARSE-STREAM* -1))
 
291
           (tyi-parse-int *parse-stream* -1))
296
292
          ((atom tem)
297
293
           (setq *parse-tyi* nil)
298
294
           tem)
326
322
(defun read-command-token-aux (obj)
327
323
  (let* (result
328
324
         (ch (parse-tyipeek))
329
 
         (lis (if (eql ch -1) nil  (parser-assoc (char-upcase ch) obj))))
 
325
         (lis (if (eql ch -1)
 
326
                  nil
 
327
                  (parser-assoc ch
 
328
                                obj))))
330
329
    (cond ((null lis) 
331
330
           nil)
332
331
          (t
333
332
           (parse-tyi)
334
333
           (cond ((atom (cadr lis))
335
 
           ;; INFIX("ABC"); puts into macsyma-operators
336
 
           ;;something like: (#\A #\B #\C (ANS |$ABC|))
337
 
           ;; ordinary things are like:
338
 
           ;; (#\< (ANS $<) (#\= (ANS $<=)))
339
 
           ;; where if you fail at the #\< #\X
340
 
           ;; stage, then the previous step was permitted.
 
334
                  ;; INFIX("ABC"); puts into macsyma-operators
 
335
                  ;;something like: (#\A #\B #\C (ANS |$ABC|))
 
336
                  ;; ordinary things are like:
 
337
                  ;; (#\< (ANS $<) (#\= (ANS $<=)))
 
338
                  ;; where if you fail at the #\< #\X
 
339
                  ;; stage, then the previous step was permitted.
341
340
                  (setq result (read-command-token-aux (list (cdr lis) ))))
342
341
                 ((null (cddr lis))
343
342
                  ;; lis something like (#\= (ANS $<=))
345
344
                  ;; starting with this.
346
345
                  (setq result
347
346
                        (and (eql (car (cadr lis)) 'ans)
348
 
                              (cadr (cadr lis)))))
 
347
                             (cadr (cadr lis)))))
349
348
                 (t
350
349
                  (let ((res   (and (eql (car (cadr lis)) 'ans)
351
350
                                    (cadr (cadr lis))))
353
352
                    (setq result (or com-token res 
354
353
                                     (read-command-token-aux
355
354
                                      (list (cadr lis))))))
356
 
                    ))
 
355
                  ))
357
356
             (or result (unparse-tyi ch))
358
357
             result))))
359
358
 
360
359
 
361
 
(DEFUN SCAN-MACSYMA-TOKEN ()
 
360
(defun scan-macsyma-token ()
362
361
  ;; note that only $-ed tokens are GETALIASed.
363
 
  (let ((tem (CONS '#\$ (SCAN-TOKEN T))))
364
 
    (setq tem (if $bothcases (bothcase-implode tem) (implode1 tem nil)))
365
 
  (GETALIAS tem)))
 
362
  (let ((tem (cons '#\$ (scan-token t))))
 
363
    (setq tem (bothcase-implode tem))
 
364
  (getalias tem)))
366
365
 
367
366
(defun scan-lisp-token ()
368
367
  (let ((charlist (scan-token nil)))
375
374
  (let ((charlist (cdr (scan-token nil))))
376
375
    (if (and charlist
377
376
             (setq charlist (lisp-token-fixup-case charlist)))
378
 
        (let ((*package* (find-package "KEYWORD")))
 
377
        (let ((*package* (find-package :keyword)))
379
378
          (implode charlist))
380
379
        (mread-synerr "Lisp keyword expected."))))
381
380
 
383
382
;; except that || is a literal |.
384
383
 
385
384
;; Note that this function modifies LIST destructively.
 
385
#+nil
386
386
(defun lisp-token-fixup-case (list)
387
387
  (let* ((list (cons nil list))
388
388
         (todo list)
401
401
              (pop todo)
402
402
              (setq preserve (not preserve))))))))
403
403
 
404
 
(defvar $bothcases t)
405
 
(DEFUN SCAN-TOKEN (FLAG)
406
 
  (DO ((C (PARSE-TYIPEEK) (PARSE-TYIPEEK))
407
 
       (L () (CONS C L)))
408
 
      ((AND FLAG (NOT (OR (ASCII-NUMBERP C) (ALPHABETP C) (char= C #.back-slash-char)))) ;;#/\
409
 
       (NREVERSE (OR L (NCONS (PARSE-TYI))))) ; Read at least one char ...
410
 
    (IF (char= (PARSE-TYI) #. back-slash-char);; #/\
411
 
        (SETQ C (PARSE-TYI))
412
 
        (or $bothcases  (SETQ C (FIXNUM-CHAR-UPCASE C))))
413
 
    (SETQ FLAG T)))
414
 
 
415
 
(DEFUN SCAN-LISP-STRING () (INTERN (SCAN-STRING)))
416
 
 
417
 
(DEFUN SCAN-MACSYMA-STRING () (INTERN (SCAN-STRING #\&)))
418
 
 
419
 
(defvar *scan-string-buffer*
420
 
  nil)
421
 
 
422
 
(DEFUN SCAN-STRING (&optional init)
 
404
(defun lisp-token-fixup-case (list)
 
405
  list)
 
406
 
 
407
(defun scan-token (flag)
 
408
  (do ((c (parse-tyipeek) (parse-tyipeek))
 
409
       (l () (cons c l)))
 
410
      ((and flag (not (or (ascii-numberp c) (alphabetp c) (char= c #.back-slash-char)))) ;;#/\
 
411
       (nreverse (or l (ncons (parse-tyi))))) ; Read at least one char ...
 
412
    (if (char= (parse-tyi) #. back-slash-char);; #/\
 
413
        (setq c (parse-tyi)))
 
414
    (setq flag t)))
 
415
 
 
416
(defun scan-lisp-string ()
 
417
  (intern (scan-string)))
 
418
 
 
419
(defun scan-macsyma-string ()
 
420
  (intern-invert-case (scan-string #\&)))
 
421
 
 
422
(defun scan-string (&optional init)
423
423
  (let ((buf (or *scan-string-buffer*
424
424
                 (setq *scan-string-buffer*
425
425
                       (make-array 50 :element-type ' #.(array-element-type "abc")
427
427
        (*scan-string-buffer* nil))
428
428
    (setf (fill-pointer buf) 0)
429
429
    (when init (vector-push-extend (coerce init 'character) buf))
430
 
    (DO ((C (PARSE-TYIPEEK) (PARSE-TYIPEEK)))
 
430
    (do ((c (parse-tyipeek) (parse-tyipeek)))
431
431
        ((cond ((eql c -1))
432
432
               ((char= c #. double-quote-char)
433
433
                (parse-tyi) t))
434
434
         (copy-seq buf))
435
 
      (IF (char= (PARSE-TYI) #. back-slash-char) ;; #/\ )
436
 
          (SETQ C (PARSE-TYI)))
 
435
      (if (char= (parse-tyi) #. back-slash-char) ;; #/\ )
 
436
          (setq c (parse-tyi)))
437
437
      #-cl
438
438
      (vector-push-extend (code-char c) buf)
439
439
      #+cl
443
443
(defvar *string-register* (make-array 100 :fill-pointer 0 :adjustable t :element-type '#.(array-element-type "a")))
444
444
(defun readlist (lis)
445
445
  (setf (fill-pointer *string-register*) 0)
446
 
  (sloop for u in lis do (vector-push-extend u *string-register*))
 
446
  (loop for u in lis do (vector-push-extend u *string-register*))
447
447
  (read-from-string   *string-register*))
448
448
 
449
449
 
450
 
(DEFUN MAKE-NUMBER (DATA)
451
 
  (SETQ DATA (NREVERSE DATA))
 
450
(defun make-number (data)
 
451
  (setq data (nreverse data))
452
452
  ;; Maxima really wants to read in any number as a double-float
453
453
  ;; (except when we have a bigfloat, of course!).  So convert an E or
454
454
  ;; S exponent marker to D.
455
455
  (when (member (car (nth 3. data)) '(#\E #\S))
456
456
    (setf (nth 3. data) (list #\D)))
457
 
  (IF (NOT (EQUAL (NTH 3. DATA) '(#\B)))
458
 
      (READLIST (APPLY #'APPEND DATA))
459
 
      ;; For bigfloats, turn them into rational numbers then convert to bigfloat
460
 
      ($BFLOAT `((MTIMES) ((MPLUS) ,(READLIST (or (FIRST DATA) '(#\0)))
461
 
                                   ((MTIMES) ,(READLIST (or (THIRD DATA) '(#\0)))
462
 
                                             ((MEXPT) 10. ,(f- (LENGTH (THIRD DATA))))))
463
 
                          ((MEXPT) 10. ,(FUNCALL (IF (char= (FIRST (FIFTH DATA)) #\-) #'- #'+)
464
 
                                                 (READLIST (SIXTH DATA))))))))
465
 
 
466
 
(DEFUN SCAN-DIGITS (DATA CONTINUATION? CONTINUATION &optional exponent-p)
467
 
  (DO ((C (PARSE-TYIPEEK) (PARSE-TYIPEEK))
468
 
       (L () (CONS C L)))
469
 
      ((NOT (ASCII-NUMBERP C))
470
 
       (COND ((IMEMBER C CONTINUATION?)
471
 
              (FUNCALL CONTINUATION (LIST* (NCONS (FIXNUM-CHAR-UPCASE
472
 
                                                   (PARSE-TYI)))
473
 
                                           (NREVERSE L)
474
 
                                           Data)
 
457
  (if (not (equal (nth 3. data) '(#\B)))
 
458
      (readlist (apply #'append data))
 
459
      ;; For bigfloats, turn them into rational numbers then convert to bigfloat.
 
460
      ;; Fix for the 0.25b0 # 2.5b-1 bug.  Richard J. Fateman posted this fix to the 
 
461
      ;; Maxima list on 10 October 2005.  Without this fix, some tests in rtestrationalize
 
462
      ;; will fail.  Used with permission.
 
463
      ($bfloat (simplifya `((mtimes) ((mplus) ,(readlist (or (first data) '(#\0)))
 
464
                                    ((mtimes) ,(readlist (or (third data) '(#\0)))
 
465
                                     ((mexpt) 10. ,(f- (length (third data))))))
 
466
                          ((mexpt) 10. ,(funcall (if (char= (first (fifth data)) #\-) #'- #'+)
 
467
                                                 (readlist (sixth data))))) nil))))
 
468
 
 
469
;; Richard J. Fateman wrote the big float to rational code and the function 
 
470
;; cl-rat-to-maxmia.  
 
471
 
 
472
(defun cl-rat-to-maxima (x) (if (integerp x) x (list '(rat simp) (numerator x) (denominator x))))
 
473
 
 
474
(defun scan-digits (data continuation? continuation &optional exponent-p)
 
475
  (do ((c (parse-tyipeek) (parse-tyipeek))
 
476
       (l () (cons c l)))
 
477
      ((not (ascii-numberp c))
 
478
       (cond ((imember c continuation?)
 
479
              (funcall continuation (list* (ncons (fixnum-char-upcase
 
480
                                                   (parse-tyi)))
 
481
                                           (nreverse l)
 
482
                                           data)
475
483
                                   ))
476
484
             ((and (null l) exponent-p)
477
485
              ;; We're trying to parse the exponent part of a number,
478
486
              ;; and we didn't get a value after the exponent marker.
479
487
              ;; That's an error.
480
488
              (merror "Incomplete number.  Missing exponent?"))
481
 
             (T
482
 
              (MAKE-NUMBER (CONS (NREVERSE L) DATA)))))
483
 
    (PARSE-TYI)))
484
 
 
485
 
#+nil
486
 
(DEFUN SCAN-NUMBER-BEFORE-DOT (DATA)
487
 
  (SCAN-DIGITS DATA '(#. period-char) #'SCAN-NUMBER-AFTER-DOT))
488
 
 
489
 
(DEFUN SCAN-NUMBER-AFTER-DOT (DATA)
490
 
  (SCAN-DIGITS DATA '(#\E #\e #\B #\b #\D #\d #\S #\s) #'SCAN-NUMBER-EXPONENT))
491
 
 
492
 
(DEFUN SCAN-NUMBER-EXPONENT (DATA)
493
 
  (PUSH (NCONS (IF (OR (char= (PARSE-TYIPEEK) #\+)
494
 
                       (char= (PARSE-TYIPEEK) #\-))
495
 
                   (PARSE-TYI)
 
489
             (t
 
490
              (make-number (cons (nreverse l) data)))))
 
491
    (parse-tyi)))
 
492
 
 
493
;#+nil
 
494
;(DEFUN SCAN-NUMBER-BEFORE-DOT (DATA)
 
495
;  (SCAN-DIGITS DATA '(#. period-char) #'SCAN-NUMBER-AFTER-DOT))
 
496
 
 
497
(defun scan-number-after-dot (data)
 
498
  (scan-digits data '(#\E #\e #\B #\b #\D #\d #\S #\s) #'scan-number-exponent))
 
499
 
 
500
(defun scan-number-exponent (data)
 
501
  (push (ncons (if (or (char= (parse-tyipeek) #\+)
 
502
                       (char= (parse-tyipeek) #\-))
 
503
                   (parse-tyi)
496
504
                   #\+))
497
 
        DATA)
498
 
  (SCAN-DIGITS DATA () () t))
 
505
        data)
 
506
  (scan-digits data () () t))
499
507
 
500
 
 
501
508
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
502
509
;;;;;                                                                    ;;;;;
503
510
;;;;;                    The Expression Parser                           ;;;;;
563
570
;;; RBP -- Right Binding Power (the stickiness to the right)
564
571
;;;
565
572
 
566
 
 
567
573
;;;; Macro Support
568
574
 
569
575
;; "First character" and "Pop character"
570
576
 
571
 
(DEFVAR SCAN-BUFFERED-TOKEN (LIST NIL)
 
577
(defvar scan-buffered-token (list nil)
572
578
  "put-back buffer for scanner, a state-variable of the reader")
573
579
 
574
 
(DEFUN PEEK-ONE-TOKEN ()
575
 
  (PEEK-ONE-TOKEN-G NIL NIL))
 
580
(defun peek-one-token ()
 
581
  (peek-one-token-g nil nil))
576
582
 
577
 
(DEFUN PEEK-ONE-TOKEN-G (EOF-OK? EOF-OBJ)
 
583
(defun peek-one-token-g (eof-ok? eof-obj)
578
584
  (cond
579
 
   ((CAR SCAN-BUFFERED-TOKEN)
580
 
    (CDR SCAN-BUFFERED-TOKEN))
581
 
   (t (RPLACD SCAN-BUFFERED-TOKEN (SCAN-ONE-TOKEN-G EOF-OK? EOF-OBJ))
582
 
      (CDR (RPLACA SCAN-BUFFERED-TOKEN T)))))
583
 
 
584
 
(DEFUN SCAN-ONE-TOKEN ()
585
 
  (SCAN-ONE-TOKEN-G NIL NIL))
586
 
 
587
 
(DEFUN SCAN-ONE-TOKEN-G (EOF-OK? EOF-OBJ)
588
 
  (COND ((CAR SCAN-BUFFERED-TOKEN)
589
 
         (RPLACA SCAN-BUFFERED-TOKEN ())
590
 
         (CDR SCAN-BUFFERED-TOKEN))
591
 
        ((READ-COMMAND-TOKEN MACSYMA-OPERATORS))
592
 
        (T
593
 
         (LET ((TEST (PARSE-TYIPEEK)))
 
585
   ((car scan-buffered-token)
 
586
    (cdr scan-buffered-token))
 
587
   (t (rplacd scan-buffered-token (scan-one-token-g eof-ok? eof-obj))
 
588
      (cdr (rplaca scan-buffered-token t)))))
 
589
 
 
590
(defun scan-one-token ()
 
591
  (scan-one-token-g nil nil))
 
592
 
 
593
(defun scan-one-token-g (eof-ok? eof-obj)
 
594
  (cond ((car scan-buffered-token)
 
595
         (rplaca scan-buffered-token ())
 
596
         (cdr scan-buffered-token))
 
597
        ((read-command-token macsyma-operators))
 
598
        (t
 
599
         (let ((test (parse-tyipeek)))
594
600
           (cond  ((eql test -1.)
595
 
                   (PARSE-TYI)
596
 
                   (IF EOF-OK? EOF-OBJ
597
 
                       (MAXIMA-ERROR "End of file while scanning expression")))
 
601
                   (parse-tyi)
 
602
                   (if eof-ok? eof-obj
 
603
                       (maxima-error "End of file while scanning expression")))
598
604
                  ((eql test forward-slash-char) ;;#//)
599
 
                   (PARSE-TYI)
600
 
                   (COND ((char= (PARSE-TYIPEEK) #\*)
601
 
                          (GOBBLE-COMMENT)
602
 
                          (SCAN-ONE-TOKEN-G EOF-OK? EOF-OBJ))
603
 
                         (T '#-cl $// #+cl $/ )))
604
 
                  ((eql test #. period-char) (PARSE-TYI)        ; Read the dot
605
 
                   (IF (ASCII-NUMBERP (PARSE-TYIPEEK))
606
 
                       (SCAN-NUMBER-AFTER-DOT (LIST (NCONS #. period-char) NIL))
 
605
                   (parse-tyi)
 
606
                   (cond ((char= (parse-tyipeek) #\*)
 
607
                          (gobble-comment)
 
608
                          (scan-one-token-g eof-ok? eof-obj))
 
609
                         (t '#-cl $// #+cl $/ )))
 
610
                  ((eql test #. period-char) (parse-tyi)        ; Read the dot
 
611
                   (if (ascii-numberp (parse-tyipeek))
 
612
                       (scan-number-after-dot (list (ncons #. period-char) nil))
607
613
                       '|$.|))
608
614
                  ((eql test double-quote-char );;#/")
609
 
                   (PARSE-TYI)
610
 
                   (SCAN-MACSYMA-STRING))
 
615
                   (parse-tyi)
 
616
                   (scan-macsyma-string))
611
617
                  ((eql test #\?)
612
 
                   (PARSE-TYI)
613
 
                   (COND ((char= (PARSE-TYIPEEK) double-quote-char );;#/")
614
 
                          (PARSE-TYI)
615
 
                          (SCAN-LISP-STRING))
 
618
                   (parse-tyi)
 
619
                   (cond ((char= (parse-tyipeek) double-quote-char );;#/")
 
620
                          (parse-tyi)
 
621
                          (scan-lisp-string))
616
622
                         ((char= (parse-tyipeek) #\:)
617
623
                          (scan-keyword-token))
618
624
                         (t
619
 
                          (SCAN-LISP-TOKEN))))
620
 
                  (T
621
 
                   (IF (ASCII-NUMBERP TEST)
622
 
                       (SCAN-NUMBER-BEFORE-DOT ())
623
 
                       (SCAN-MACSYMA-TOKEN))))))))
 
625
                          (scan-lisp-token))))
 
626
                  (t
 
627
                   (if (ascii-numberp test)
 
628
                       (scan-number-before-dot ())
 
629
                       (scan-macsyma-token))))))))
624
630
 
625
631
;; nested comments are permitted.
626
632
(defun gobble-comment ()
660
666
  (scan-digits data '(#. period-char #\E #\e #\B #\b #\D #\d #\S #\s)
661
667
               #'scan-number-rest))
662
668
 
663
 
    
664
 
 
665
 
(DEFMACRO FIRST-C () '(PEEK-ONE-TOKEN))
666
 
(DEFMACRO POP-C   () '(SCAN-ONE-TOKEN))
667
 
 
668
 
 
669
 
 
670
 
(DEFUN MSTRINGP (X)
671
 
  (AND (SYMBOLP X) (char= (FIRSTCHARN X) #\&)))
 
669
 
 
670
 
 
671
(defmacro first-c () '(peek-one-token))
 
672
(defmacro pop-c   () '(scan-one-token))
 
673
 
 
674
 
 
675
(defun mstringp (x)
 
676
  (and (symbolp x) (char= (firstcharn x) #\&)))
672
677
 
673
678
 
674
679
;(DEFUN AMPERCHK (NAME)
675
680
;  (IF (MSTRINGP NAME) (DOLLARIFY-NAME NAME) NAME))
676
681
;;see suprv1
677
682
 
678
 
(DEFUN INHERIT-PROPL (OP-TO OP-FROM GETL)
679
 
  (LET ((PROPL (GETL OP-FROM GETL)))
680
 
    (IF PROPL
681
 
        (PROGN (REMPROP OP-TO (CAR PROPL))
682
 
               (PUTPROP OP-TO (CADR PROPL) (CAR PROPL)))
683
 
        (INHERIT-PROPL OP-TO
684
 
                       (MAXIMA-ERROR (LIST "has no" GETL "properties.")
685
 
                              OP-FROM
686
 
                              'WRNG-TYPE-ARG)
687
 
                       GETL))))
 
683
(defun inherit-propl (op-to op-from getl)
 
684
  (let ((propl (getl op-from getl)))
 
685
    (if propl
 
686
        (progn (remprop op-to (car propl))
 
687
               (putprop op-to (cadr propl) (car propl)))
 
688
        (inherit-propl op-to
 
689
                       (maxima-error (list "has no" getl "properties.")
 
690
                              op-from
 
691
                              'wrng-type-arg)
 
692
                       getl))))
688
693
 
689
694
 
690
695
;;; (NUD <op>)
695
700
;;;
696
701
 
697
702
(eval-when (eval compile load)
698
 
 
699
 
 
700
 
#+already-expanded-below
701
 
(DEF-PROPL-CALL NUD (OP)
702
 
  (IF (OPERATORP OP)
703
 
      ;; If first element is an op, it better have a NUD
704
 
      (MREAD-SYNERR "~A is not a prefix operator" (MOPSTRIP OP))
705
 
      ;; else take it as is.
706
 
      (CONS '$ANY OP)))
 
703
  #+already-expanded-below
 
704
  (def-propl-call nud (op)
 
705
    (if (operatorp op)
 
706
        ;; If first element is an op, it better have a NUD
 
707
        (mread-synerr "~A is not a prefix operator" (mopstrip op))
 
708
        ;; else take it as is.
 
709
        (cons '$any op)))
707
710
;;begin expansion
708
 
(DEFMACRO DEF-NUD-EQUIV (OP EQUIV)
709
 
   (LIST 'PUTPROP (LIST 'QUOTE OP) (LIST 'FUNCTION EQUIV)
710
 
          (LIST 'QUOTE 'NUD)))
711
 
(DEFMACRO NUD-PROPL () ''(NUD))
712
 
  (DEFMACRO DEF-NUD-FUN (OP-NAME OP-L . BODY)
713
 
    (LIST* 'DEFUN-PROP (LIST* OP-NAME 'NUD 'NIL) OP-L BODY))
714
 
(DEFUN NUD-CALL (OP)
715
 
    (LET ((TEM (AND (SYMBOLP OP) (GETL OP '(NUD)))) res)
716
 
         (setq res       
717
 
               (IF (NULL TEM)
718
 
                   (IF (OPERATORP OP)
719
 
                       (MREAD-SYNERR "~A is not a prefix operator"
720
 
                                     (MOPSTRIP OP))
721
 
                       (CONS '$ANY OP))
722
 
                   (FUNCALL (CADR TEM) OP)))
723
 
         res
724
 
         ))
 
711
  (defmacro def-nud-equiv (op equiv)
 
712
    (list 'putprop (list 'quote op) (list 'function equiv)
 
713
          (list 'quote 'nud)))
 
714
  (defmacro nud-propl () ''(nud))
 
715
  (defmacro def-nud-fun (op-name op-l . body)
 
716
    (list* 'defun-prop (list* op-name 'nud 'nil) op-l body))
 
717
  (defun nud-call (op)
 
718
    (let ((tem (and (symbolp op) (getl op '(nud)))) res)
 
719
      (setq res  
 
720
            (if (null tem)
 
721
                (if (operatorp op)
 
722
                    (mread-synerr "~A is not a prefix operator"
 
723
                                  (mopstrip op))
 
724
                    (cons '$any op))
 
725
                (funcall (cadr tem) op)))
 
726
      res))
725
727
;;end expansion 
726
728
 
727
729
;;following defines def-led-equiv led-propl def-led-fun led-call
728
 
#+already-expanded-below
729
 
(DEF-PROPL-CALL LED (OP L)
730
 
  (MREAD-SYNERR "~A is not an infix operator" (MOPSTRIP OP)))
731
 
)
 
730
  #+already-expanded-below
 
731
  (def-propl-call led (op l)
 
732
    (mread-synerr "~A is not an infix operator" (mopstrip op))))
 
733
 
732
734
;;begin expansion
733
 
(DEFMACRO DEF-LED-EQUIV (OP EQUIV)
734
 
    (LIST 'PUTPROP (LIST 'QUOTE OP) (LIST 'FUNCTION EQUIV)
735
 
          (LIST 'QUOTE 'LED)))
 
735
(defmacro def-led-equiv (op equiv)
 
736
    (list 'putprop (list 'quote op) (list 'function equiv)
 
737
          (list 'quote 'led)))
 
738
 
736
739
(eval-when (compile load eval)
737
 
  (DEFMACRO LED-PROPL () ''(LED)))
738
 
(DEFMACRO DEF-LED-FUN (OP-NAME OP-L . BODY)
739
 
    (LIST* 'DEFUN-PROP (LIST* OP-NAME 'LED 'NIL) OP-L BODY))
740
 
(DEFUN LED-CALL (OP L)
741
 
   
742
 
    (LET ((TEM (AND (SYMBOLP OP) (GETL OP '(LED)))) res)
743
 
         (setq res
744
 
      (IF (NULL TEM)
745
 
          (MREAD-SYNERR "~A is not an infix operator" (MOPSTRIP OP))
746
 
          (FUNCALL (CADR TEM) OP L))
747
 
      )
748
 
         res
749
 
      ))
 
740
  (defmacro led-propl () ''(led)))
 
741
 
 
742
(defmacro def-led-fun (op-name op-l . body)
 
743
    (list* 'defun-prop (list* op-name 'led 'nil) op-l body))
 
744
(defun led-call (op l)
 
745
  (let ((tem (and (symbolp op) (getl op '(led)))) res)
 
746
    (setq res
 
747
          (if (null tem)
 
748
              (mread-synerr "~A is not an infix operator" (mopstrip op))
 
749
              (funcall (cadr tem) op l)))
 
750
    res))
 
751
 
750
752
;;end expansion
751
753
 
752
754
;;; (DEF-NUD (op lbp rbp) bvl . body)
761
763
;;;      It will get bound to the operator being parsed.
762
764
;;;  lispm:Optional args not allowed in release 5 allowed, necessary afterwards..
763
765
 
764
 
#+cl
765
 
(DEFMACRO DEF-NUD ((OP . LBP-RBP) BVL . BODY)
 
766
(defmacro def-nud ((op . lbp-rbp) bvl . body)
766
767
  (let (( lbp (nth 0 lbp-rbp))
767
768
        ( rbp (nth 1 lbp-rbp)))
768
 
    `(PROGN 'COMPILE      ,(MAKE-PARSER-FUN-DEF OP 'NUD BVL BODY)
769
 
            (SET-LBP-AND-RBP ',OP ',LBP ',RBP))))
770
 
 
771
 
#-cl
772
 
(DEFMACRO DEF-NUD ((OP #+nil &OPTIONAL LBP RBP) BVL . BODY)
773
 
  `(PROGN 'COMPILE        ,(MAKE-PARSER-FUN-DEF OP 'NUD BVL BODY)
774
 
          (SET-LBP-AND-RBP ',OP ',LBP ',RBP)))
775
 
 
776
 
(DEFUN SET-LBP-AND-RBP (OP LBP RBP)
777
 
  (COND ((NOT (consp OP))
778
 
         (LET ((EXISTING-LBP (GET OP 'LBP))
779
 
               (EXISTING-RBP (GET OP 'RBP)))
780
 
           (COND ((NOT LBP)
781
 
                  (COMMENT IGNORE OMITTED ARG))
782
 
                 ((NOT EXISTING-LBP)
783
 
                  (PUTPROP OP LBP 'LBP))
784
 
                 ((NOT (EQUAL EXISTING-LBP LBP))
785
 
                  (MAXIMA-ERROR "Incompatible LBP's defined for this operator" OP)))
786
 
           (COND ((NOT RBP)
787
 
                  (COMMENT IGNORE OMITTED ARG))
788
 
                 ((NOT EXISTING-RBP)
789
 
                  (PUTPROP OP RBP 'RBP))
790
 
                 ((NOT (EQUAL EXISTING-RBP RBP))
791
 
                  (MAXIMA-ERROR "Incompatible RBP's defined for this operator" OP)))))
792
 
        ('ELSE
793
 
         (MAPCAR #'(LAMBDA (X) (SET-LBP-AND-RBP X LBP RBP))
794
 
                 OP))))
 
769
    `(progn 'compile      ,(make-parser-fun-def op 'nud bvl body)
 
770
            (set-lbp-and-rbp ',op ',lbp ',rbp))))
 
771
 
 
772
;#-cl
 
773
;(DEFMACRO DEF-NUD ((OP #+nil &OPTIONAL LBP RBP) BVL . BODY)
 
774
;  `(PROGN 'COMPILE       ,(MAKE-PARSER-FUN-DEF OP 'NUD BVL BODY)
 
775
;         (SET-LBP-AND-RBP ',OP ',LBP ',RBP)))
 
776
 
 
777
(defun set-lbp-and-rbp (op lbp rbp)
 
778
  (cond ((not (consp op))
 
779
         (let ((existing-lbp (get op 'lbp))
 
780
               (existing-rbp (get op 'rbp)))
 
781
           (cond ((not lbp)
 
782
                  (comment ignore omitted arg))
 
783
                 ((not existing-lbp)
 
784
                  (putprop op lbp 'lbp))
 
785
                 ((not (equal existing-lbp lbp))
 
786
                  (maxima-error "Incompatible LBP's defined for this operator" op)))
 
787
           (cond ((not rbp)
 
788
                  (comment ignore omitted arg))
 
789
                 ((not existing-rbp)
 
790
                  (putprop op rbp 'rbp))
 
791
                 ((not (equal existing-rbp rbp))
 
792
                  (maxima-error "Incompatible RBP's defined for this operator" op)))))
 
793
        ('else
 
794
         (mapcar #'(lambda (x) (set-lbp-and-rbp x lbp rbp))
 
795
                 op))))
795
796
                                   
796
797
 
797
798
;;; (DEF-LED (op lbp rbp) bvl . body)
807
808
;;;       get bound to the parsed structure which was to the left of Arg1.
808
809
 
809
810
 
810
 
#+cl
811
 
(DEFMACRO DEF-LED((OP . LBP-RBP) BVL . BODY)
 
811
(defmacro def-led((op . lbp-rbp) bvl . body)
812
812
  (let (( lbp (nth 0 lbp-rbp))
813
813
        ( rbp (nth 1 lbp-rbp)))
814
 
    `(PROGN 'COMPILE
815
 
            ,(MAKE-PARSER-FUN-DEF  OP 'LED BVL BODY)
816
 
            (SET-LBP-AND-RBP ',OP ',LBP ',RBP))))
817
 
 
818
 
#-cl
819
 
(DEFMACRO DEF-LED ((OP #+(or cl NIL) &OPTIONAL LBP RBP) BVL . BODY)
820
 
  `(PROGN 'COMPILE
821
 
          ,(MAKE-PARSER-FUN-DEF  OP 'LED BVL BODY)
822
 
          (SET-LBP-AND-RBP ',OP ',LBP ',RBP)))
823
 
 
824
 
(DEFMACRO DEF-COLLISIONS (OP &REST ALIST)
825
 
  (LET ((KEYS (DO ((I  1.    (#+cl ash #-cl LSH I 1.))
826
 
                   (LIS  ALIST (CDR LIS))
827
 
                   (NL ()    (CONS (CONS (CAAR LIS) I) NL)))
828
 
                  ((NULL LIS) NL))))
829
 
    `(PROGN 'COMPILE
830
 
       (DEFPROP ,OP ,(let #+lispm ((default-cons-area working-storage-area))
 
814
    `(progn 'compile
 
815
            ,(make-parser-fun-def  op 'led bvl body)
 
816
            (set-lbp-and-rbp ',op ',lbp ',rbp))))
 
817
 
 
818
;#-cl
 
819
;(DEFMACRO DEF-LED ((OP #+(or cl NIL) &OPTIONAL LBP RBP) BVL . BODY)
 
820
;  `(PROGN 'COMPILE
 
821
;         ,(MAKE-PARSER-FUN-DEF  OP 'LED BVL BODY)
 
822
;         (SET-LBP-AND-RBP ',OP ',LBP ',RBP)))
 
823
 
 
824
(defmacro def-collisions (op &rest alist)
 
825
  (let ((keys (do ((i  1.    (#+cl ash #-cl lsh i 1.))
 
826
                   (lis  alist (cdr lis))
 
827
                   (nl ()    (cons (cons (caar lis) i) nl)))
 
828
                  ((null lis) nl))))
 
829
    `(progn 'compile
 
830
       (defprop ,op ,(let #+lispm ((default-cons-area working-storage-area))
831
831
                          #-lispm nil
832
 
                       (copy-tree KEYS )) KEYS)
833
 
       ,@(MAPCAR #'(LAMBDA (DATA)
834
 
                     `(DEFPROP ,(CAR DATA)
835
 
                               ,(DO ((I 0 (LOGIOR I  (CDR (ASSQ (CAR LIS) KEYS))))
836
 
                                     (LIS (CDR DATA) (CDR LIS)))
837
 
                                    ((NULL LIS) I))
838
 
                               ,OP))
839
 
                 ALIST))))
840
 
 
841
 
 
842
 
 
843
 
(DEFUN COLLISION-LOOKUP (OP ACTIVE-BITMASK KEY-BITMASK)
844
 
  (LET ((RESULT (LOGAND ACTIVE-BITMASK KEY-BITMASK)))
845
 
    (IF (NOT (ZEROP RESULT))
846
 
        (DO ((L (GET OP 'KEYS) (CDR L)))
847
 
            ((NULL L) (PARSE-BUG-ERR 'COLLISION-CHECK))
848
 
          (IF (NOT (ZEROP (LOGAND RESULT (CDAR L))))
849
 
              (RETURN (CAAR L)))))))
850
 
 
851
 
(DEFUN COLLISION-CHECK (OP ACTIVE-BITMASK KEY)
852
 
  (LET ((KEY-BITMASK (GET KEY OP)))
853
 
    (IF (NOT KEY-BITMASK)
854
 
        (MREAD-SYNERR "~A is an unknown keyword in a ~A statement."
855
 
                      (MOPSTRIP KEY) (MOPSTRIP OP)))
856
 
    (LET ((COLLISION (COLLISION-LOOKUP OP ACTIVE-BITMASK KEY-BITMASK)))
857
 
      (IF COLLISION
858
 
          (IF (EQ COLLISION KEY)
859
 
              (MREAD-SYNERR "This ~A's ~A slot is already filled."
860
 
                            (MOPSTRIP OP)
861
 
                            (MOPSTRIP KEY))
862
 
              (MREAD-SYNERR "A ~A cannot have a ~A with a ~A field."
863
 
                            (MOPSTRIP OP)
864
 
                            (MOPSTRIP KEY)
865
 
                            (MOPSTRIP COLLISION))))
866
 
      (LOGIOR (CDR (ASSQ KEY (GET OP 'KEYS))) ACTIVE-BITMASK))))
 
832
                       (copy-tree keys )) keys)
 
833
       ,@(mapcar #'(lambda (data)
 
834
                     `(defprop ,(car data)
 
835
                               ,(do ((i 0 (logior i  (cdr (assq (car lis) keys))))
 
836
                                     (lis (cdr data) (cdr lis)))
 
837
                                    ((null lis) i))
 
838
                               ,op))
 
839
                 alist))))
 
840
 
 
841
 
 
842
(defun collision-lookup (op active-bitmask key-bitmask)
 
843
  (let ((result (logand active-bitmask key-bitmask)))
 
844
    (if (not (zerop result))
 
845
        (do ((l (get op 'keys) (cdr l)))
 
846
            ((null l) (parse-bug-err 'collision-check))
 
847
          (if (not (zerop (logand result (cdar l))))
 
848
              (return (caar l)))))))
 
849
 
 
850
(defun collision-check (op active-bitmask key)
 
851
  (let ((key-bitmask (get key op)))
 
852
    (if (not key-bitmask)
 
853
        (mread-synerr "~A is an unknown keyword in a ~A statement."
 
854
                      (mopstrip key) (mopstrip op)))
 
855
    (let ((collision (collision-lookup op active-bitmask key-bitmask)))
 
856
      (if collision
 
857
          (if (eq collision key)
 
858
              (mread-synerr "This ~A's ~A slot is already filled."
 
859
                            (mopstrip op)
 
860
                            (mopstrip key))
 
861
              (mread-synerr "A ~A cannot have a ~A with a ~A field."
 
862
                            (mopstrip op)
 
863
                            (mopstrip key)
 
864
                            (mopstrip collision))))
 
865
      (logior (cdr (assq key (get op 'keys))) active-bitmask))))
867
866
      
868
867
 
869
 
 
870
868
;;;; Data abstraction
871
869
 
872
870
;;; LBP = Left Binding Power
874
872
;;; (LBP <op>)           - reads an operator's Left Binding Power
875
873
;;; (DEF-LBP <op> <val>) - defines an operator's Left Binding Power
876
874
 
877
 
(DEFMFUN LBP (LEX) (COND ((safe-GET LEX 'LBP)) (T 200.)))
 
875
(defmfun lbp (lex) (cond ((safe-get lex 'lbp)) (t 200.)))
878
876
 
879
 
(DEFMACRO DEF-LBP (SYM VAL) `(DEFPROP ,SYM ,VAL LBP))
 
877
(defmacro def-lbp (sym val) `(defprop ,sym ,val lbp))
880
878
 
881
879
;;; RBP = Right Binding Power
882
880
;;;
883
881
;;; (RBP <op>)           - reads an operator's Right Binding Power
884
882
;;; (DEF-RBP <op> <val>) - defines an operator's Right Binding Power
885
883
 
886
 
(DEFMFUN RBP (LEX) (COND ((safe-GET LEX 'RBP)) (T 200.)))
887
 
 
888
 
(DEFMACRO DEF-RBP (SYM VAL) `(DEFPROP ,SYM ,VAL RBP))
889
 
 
890
 
(DEFMACRO DEF-MATCH (X M) `(DEFPROP ,X ,M MATCH))
 
884
(defmfun rbp (lex) (cond ((safe-get lex 'rbp)) (t 200.)))
 
885
 
 
886
(defmacro def-rbp (sym val) `(defprop ,sym ,val rbp))
 
887
 
 
888
(defmacro def-match (x m) `(defprop ,x ,m match))
891
889
 
892
890
;;; POS = Part of Speech!
893
891
;;; 
896
894
;;; (POS  <op>)
897
895
;;;
898
896
 
899
 
(DEFUN LPOS (OP) (COND ((safe-GET OP 'LPOS)) (T '$ANY)))
900
 
(DEFUN RPOS (OP) (COND ((safe-GET OP 'RPOS)) (T '$ANY)))
901
 
(DEFUN POS (OP) (COND ((safe-GET OP 'POS)) (T '$ANY)))
 
897
(defun lpos (op) (cond ((safe-get op 'lpos)) (t '$any)))
 
898
(defun rpos (op) (cond ((safe-get op 'rpos)) (t '$any)))
 
899
(defun pos (op) (cond ((safe-get op 'pos)) (t '$any)))
902
900
 
903
 
(DEFMACRO DEF-POS  (OP POS) `(DEFPROP ,OP ,POS  POS))
904
 
(DEFMACRO DEF-RPOS (OP POS) `(DEFPROP ,OP ,POS RPOS))
905
 
(DEFMACRO DEF-LPOS (OP POS) `(DEFPROP ,OP ,POS LPOS))
 
901
(defmacro def-pos  (op pos) `(defprop ,op ,pos  pos))
 
902
(defmacro def-rpos (op pos) `(defprop ,op ,pos rpos))
 
903
(defmacro def-lpos (op pos) `(defprop ,op ,pos lpos))
906
904
 
907
905
;;; MHEADER
908
906
 
909
 
(DEFUN MHEADER (OP) (add-lineinfo (OR (safe-GET OP 'MHEADER) (NCONS OP))))
910
 
 
911
 
(DEFMACRO DEF-MHEADER (OP HEADER) `(DEFPROP ,OP ,HEADER MHEADER))
912
 
 
913
 
 
914
 
(DEFMVAR $PARSEWINDOW 10.
 
907
(defun mheader (op) (add-lineinfo (or (safe-get op 'mheader) (ncons op))))
 
908
 
 
909
(defmacro def-mheader (op header) `(defprop ,op ,header mheader))
 
910
 
 
911
 
 
912
(defmvar $parsewindow 10.
915
913
         "The maximum number of 'lexical tokens' that are printed out on
916
914
each side of the error-point when a syntax (parsing) MAXIMA-ERROR occurs.  This
917
915
option is especially useful on slow terminals.  Setting it to -1 causes the
918
916
entire input string to be printed out when an MAXIMA-ERROR occurs."
919
 
         FIXNUM)
 
917
         fixnum)
920
918
 
921
 
 
922
919
 
923
920
;;;; Misplaced definitions
924
921
 
925
 
(DEFMACRO DEF-OPERATORP ()
926
 
  `(DEFMFUN OPERATORP (LEX)
927
 
     (AND (SYMBOLP LEX) (GETL LEX '(,@(NUD-PROPL) ,@(LED-PROPL))))))
928
 
 
929
 
(DEF-OPERATORP)
930
 
 
931
 
(DEFMACRO DEF-OPERATORP1 ()
 
922
(defmacro def-operatorp ()
 
923
  `(defmfun operatorp (lex)
 
924
     (and (symbolp lex) (getl lex '(,@(nud-propl) ,@(led-propl))))))
 
925
 
 
926
(def-operatorp)
 
927
 
 
928
(defmacro def-operatorp1 ()
932
929
  ;Defmfun -- used by SYNEX if not others.
933
 
  `(DEFMFUN OPERATORP1 (LEX)
 
930
  `(defmfun operatorp1 (lex)
934
931
     ;; Referenced outside of package: OP-SETUP, DECLARE1
935
932
     ;; Use for truth value only, not for return-value.
936
 
     (AND (SYMBOLP LEX) (GETL LEX '(LBP RBP ,@(NUD-PROPL) ,@(LED-PROPL))))))
937
 
 
938
 
(DEF-OPERATORP1)
939
 
 
940
 
 
 
933
     (and (symbolp lex) (getl lex '(lbp rbp ,@(nud-propl) ,@(led-propl))))))
 
934
 
 
935
(def-operatorp1)
 
936
 
941
937
;;;; The Macsyma Parser
942
938
 
943
939
;;; (MREAD) with arguments compatible with losing maclisp READ style.
949
945
;;; an atribute of the stream which somebody can hack before calling
950
946
;;; MREAD if he wants to.
951
947
 
952
 
#+Lispm
953
 
(DEFUN READ-APPLY (F READ-ARGS &AUX WHICH-OPERS)
954
 
  (MULTIPLE-VALUE-BIND (STREAM EOF)
955
 
                       (SI:DECODE-READ-ARGS READ-ARGS)
956
 
 
957
 
    (SETQ WHICH-OPERS (FUNCALL STREAM ':WHICH-OPERATIONS))
958
 
    (IF (MEMQ ':RUBOUT-HANDLER WHICH-OPERS)
959
 
        (FUNCALL STREAM ':RUBOUT-HANDLER '((:PROMPT *MREAD-PROMPT*))
960
 
                 F STREAM EOF)
961
 
        (FUNCALL F STREAM EOF))))
962
 
 
963
 
#+Maclisp
964
 
(DEFUN READ-APPLY (F READ-ARGS &AUX WHICH-OPERS)
965
 
  (LET ((STREAM (CAR READ-ARGS))
966
 
        (EOF (CADR READ-ARGS)))
967
 
    ;; apply the correction.
968
 
    (COND ((AND (NULL (CDR READ-ARGS))
969
 
                (NOT (OR (EQ STREAM T)
970
 
                         (SFAP STREAM)
971
 
                         (FILEP STREAM))))
972
 
           (SETQ STREAM NIL EOF STREAM)))
973
 
    (COND ((EQ STREAM T)
974
 
           (SETQ STREAM TYI))
975
 
          ((EQ STREAM NIL)
976
 
           (IF ^Q (SETQ STREAM INFILE) (SETQ STREAM TYI))))
977
 
    (SETQ WHICH-OPERS (AND (SFAP STREAM)
978
 
                           (SFA-CALL STREAM 'WHICH-OPERATIONS NIL)))
979
 
    (IF (MEMQ 'RUBOUT-HANDLER WHICH-OPERS)
980
 
        (SFA-CALL STREAM 'RUBOUT-HANDLER F)
981
 
        (FUNCALL F STREAM EOF))))
 
948
;#+Lispm
 
949
;(DEFUN READ-APPLY (F READ-ARGS &AUX WHICH-OPERS)
 
950
;  (MULTIPLE-VALUE-BIND (STREAM EOF)
 
951
;                      (SI:DECODE-READ-ARGS READ-ARGS)
 
952
 
 
953
;    (SETQ WHICH-OPERS (FUNCALL STREAM ':WHICH-OPERATIONS))
 
954
;    (IF (MEMQ ':RUBOUT-HANDLER WHICH-OPERS)
 
955
;       (FUNCALL STREAM ':RUBOUT-HANDLER '((:PROMPT *MREAD-PROMPT*))
 
956
;                F STREAM EOF)
 
957
;       (FUNCALL F STREAM EOF))))
 
958
 
 
959
;#+Maclisp
 
960
;(DEFUN READ-APPLY (F READ-ARGS &AUX WHICH-OPERS)
 
961
;  (LET ((STREAM (CAR READ-ARGS))
 
962
;       (EOF (CADR READ-ARGS)))
 
963
;    ;; apply the correction.
 
964
;    (COND ((AND (NULL (CDR READ-ARGS))
 
965
;               (NOT (OR (EQ STREAM T)
 
966
;                        (SFAP STREAM)
 
967
;                        (FILEP STREAM))))
 
968
;          (SETQ STREAM NIL EOF STREAM)))
 
969
;    (COND ((EQ STREAM T)
 
970
;          (SETQ STREAM TYI))
 
971
;         ((EQ STREAM NIL)
 
972
;          (IF ^Q (SETQ STREAM INFILE) (SETQ STREAM TYI))))
 
973
;    (SETQ WHICH-OPERS (AND (SFAP STREAM)
 
974
;                          (SFA-CALL STREAM 'WHICH-OPERATIONS NIL)))
 
975
;    (IF (MEMQ 'RUBOUT-HANDLER WHICH-OPERS)
 
976
;       (SFA-CALL STREAM 'RUBOUT-HANDLER F)
 
977
;       (FUNCALL F STREAM EOF))))
982
978
 
983
979
(defvar *current-line-info* nil)
984
980
 
985
981
;;Important for lispm rubout handler
986
 
(DEFUN MREAD (&REST READ-ARGS)
987
 
  #+NIL (let ((*mread-prompt-internal* *mread-prompt*)
 
982
(defun mread (&rest read-args)
 
983
  #+nil (let ((*mread-prompt-internal* *mread-prompt*)
988
984
              (si:*ttyscan-dispatch-table *macsyma-ttyscan-operators*))
989
985
          (declare (special *mread-prompt-internal*))
990
 
          (SI:READ-APPLY ':MREAD #'MREAD-RAW (coerce READ-ARGS 'sys:vector)
 
986
          (si:read-apply ':mread #'mread-raw (coerce read-args 'sys:vector)
991
987
                         '(:prompt mread-prompter)
992
988
                         '(:reprompt mread-prompter)))
993
989
  #+cl (progn
996
992
                                         *parse-window* (cdr *parse-window*)))
997
993
               (princ *mread-prompt*)
998
994
               (force-output))
999
 
         (#+lispm read-apply #-lispm apply 'mread-raw read-args)
 
995
         (apply 'mread-raw read-args)
1000
996
                    )
1001
 
  #-(or NIL cl)
1002
 
  (READ-APPLY #'MREAD-RAW READ-ARGS))
 
997
  #-(or nil cl)
 
998
  (read-apply #'mread-raw read-args))
1003
999
 
1004
1000
(defun mread-prompter (stream char)
1005
1001
  (declare (special *mread-prompt-internal*))
1007
1003
  (fresh-line stream)
1008
1004
  (princ *mread-prompt-internal* stream))
1009
1005
 
1010
 
#+NIL
1011
 
(DEFUN MREAD-WITH-PROMPT (PROMPT)
 
1006
#+nil
 
1007
(defun mread-with-prompt (prompt)
1012
1008
  (let ((*mread-prompt-internal* prompt)
1013
1009
        (si:*ttyscan-dispatch-table *macsyma-ttyscan-operators*))
1014
1010
    (declare (special *mread-prompt-internal*))
1015
 
    (SI:READ-APPLY ':MREAD #'MREAD-RAW (SYS:VECTOR)
 
1011
    (si:read-apply ':mread #'mread-raw (sys:vector)
1016
1012
                   '(:prompt mread-prompter)
1017
1013
                   '(:reprompt mread-prompter))))
1018
1014
 
1020
1016
;;aa && bb && jim:3;
1021
1017
 
1022
1018
 
1023
 
(DEFUN MREAD-RAW (*PARSE-STREAM* &OPTIONAL *MREAD-EOF-OBJ*)
1024
 
  (LET ((SCAN-BUFFERED-TOKEN (LIST NIL))
 
1019
(defun mread-raw (*parse-stream* &optional *mread-eof-obj*)
 
1020
  (let ((scan-buffered-token (list nil))
1025
1021
        *parse-tyi*
1026
1022
        )
1027
 
    (IF (EQ SCAN-BUFFERED-TOKEN ;; a handly unique object for the EQ test.
1028
 
            (PEEK-ONE-TOKEN-G T SCAN-BUFFERED-TOKEN))
1029
 
        *MREAD-EOF-OBJ*
1030
 
        (DO ((LABELS ())
1031
 
             (INPUT (PARSE '$ANY 0.) (PARSE '$ANY 0.)))
1032
 
            (NIL)
1033
 
          (CASE (FIRST-C)
 
1023
    (if (eq scan-buffered-token ;; a handly unique object for the EQ test.
 
1024
            (peek-one-token-g t scan-buffered-token))
 
1025
        *mread-eof-obj*
 
1026
        (do ((labels ())
 
1027
             (input (parse '$any 0.) (parse '$any 0.)))
 
1028
            (nil)
 
1029
          (case (first-c)
1034
1030
            ((|$;| |$$|)
1035
1031
              ;force a separate line info structure
1036
 
             (SETF *CURRENT-LINE-INFO* NIL)
1037
 
             (RETURN (LIST (MHEADER (POP-C))
1038
 
                           (IF LABELS (CONS (MHEADER '|$[|) (NREVERSE LABELS)))
1039
 
                           INPUT)))
 
1032
             (setf *current-line-info* nil)
 
1033
             (return (list (mheader (pop-c))
 
1034
                           (if labels (cons (mheader '|$[|) (nreverse labels)))
 
1035
                           input)))
1040
1036
            ((|$&&|)
1041
 
             (POP-C)
1042
 
             (IF (SYMBOLP INPUT)
1043
 
                 (PUSH INPUT LABELS)
1044
 
                 (MREAD-SYNERR "Invalid && tag. Tag must be a symbol")))
1045
 
            (T
1046
 
             (PARSE-BUG-ERR 'MREAD-RAW)))))))
 
1037
             (pop-c)
 
1038
             (if (symbolp input)
 
1039
                 (push input labels)
 
1040
                 (mread-synerr "Invalid && tag. Tag must be a symbol")))
 
1041
            (t
 
1042
             (parse-bug-err 'mread-raw)))))))
1047
1043
 
1048
1044
;;; (PARSE <mode> <rbp>)
1049
1045
;;;
1056
1052
;;;     $CLAUSE = Match only boolean expressions (or $ANY)
1057
1053
;;;     $EXPR   = Match only mathematical expressions (or $ANY)
1058
1054
;;;  If a mismatched mode occurs, a syntax error will be flagged. Eg,
1059
 
;;;  this is why "X^A*B" parses but "X^A AND B" does not. X^A is a $EXPR
 
1055
;;;  this is why "X^A*B" parses but "X^A and B" does not. X^A is a $EXPR
1060
1056
;;;  and not coercible to a $CLAUSE. See CONVERT.
1061
1057
;;;
1062
1058
;;;  <mode> is the required mode of the result.
1066
1062
;;;          than calling that operator.
1067
1063
;;;
1068
1064
 
1069
 
(DEFUN PARSE (MODE RBP) 
1070
 
  (DO ((LEFT (NUD-CALL (POP-C))         ; Envoke the null left denotation
1071
 
             (LED-CALL (POP-C) LEFT)))  ;  and keep calling LED ops as needed
1072
 
      ((>= RBP (LBP (FIRST-C)))         ; Until next op lbp too low
1073
 
       (CONVERT LEFT MODE))))           ;  in which case, return stuff seen
 
1065
(defun parse (mode rbp) 
 
1066
  (do ((left (nud-call (pop-c))         ; Envoke the null left denotation
 
1067
             (led-call (pop-c) left)))  ;  and keep calling LED ops as needed
 
1068
      ((>= rbp (lbp (first-c)))         ; Until next op lbp too low
 
1069
       (convert left mode))))           ;  in which case, return stuff seen
1074
1070
 
1075
1071
;;; (PARSE-PREFIX <op>)
1076
1072
;;;
1081
1077
;;;  according to its right binding power, returning
1082
1078
;;;  ( <mode> . ((<op>) <arg1>) )
1083
1079
 
1084
 
(DEFUN PARSE-PREFIX (OP)
1085
 
  (LIST (POS OP)                        ; Operator mode
1086
 
        (MHEADER OP)                    ; Standard Macsyma expression header
1087
 
        (PARSE (RPOS OP) (RBP OP))))    ; Convert single argument for use
 
1080
(defun parse-prefix (op)
 
1081
  (list (pos op)                        ; Operator mode
 
1082
        (mheader op)                    ; Standard Macsyma expression header
 
1083
        (parse (rpos op) (rbp op))))    ; Convert single argument for use
1088
1084
 
1089
1085
;;; (PARSE-POSTFIX <op> <left>)
1090
1086
;;;
1094
1090
;;;  has been accumulated and <op> has been seen and gobbled up. It returns
1095
1091
;;;  ( <mode> . ((<op>) <arg1>) )
1096
1092
 
1097
 
(DEFUN PARSE-POSTFIX (OP L)
1098
 
  (LIST (POS OP)                        ; Operator's mode
1099
 
        (MHEADER OP)                    ; Standard Macsyma expression header
1100
 
        (CONVERT L (LPOS OP))))         ; Convert single argument for use
 
1093
(defun parse-postfix (op l)
 
1094
  (list (pos op)                        ; Operator's mode
 
1095
        (mheader op)                    ; Standard Macsyma expression header
 
1096
        (convert l (lpos op))))         ; Convert single argument for use
1101
1097
 
1102
1098
;;; (PARSE-INFIX <op> <left>)
1103
1099
;;;
1107
1103
;;;  has been accumulated and <op> has been seen and gobbled up. It returns
1108
1104
;;;  ( <mode> . ((<op>) <arg1> <arg2>) )
1109
1105
 
1110
 
(DEFUN PARSE-INFIX (OP L)
1111
 
  (LIST (POS OP)                        ; Operator's mode
1112
 
        (MHEADER OP)                    ; Standard Macsyma expression header
1113
 
        (CONVERT L (LPOS OP))           ; Convert arg1 for immediate use
1114
 
        (PARSE (RPOS OP) (RBP OP))))    ; Look for an arg2 
 
1106
(defun parse-infix (op l)
 
1107
  (list (pos op)                        ; Operator's mode
 
1108
        (mheader op)                    ; Standard Macsyma expression header
 
1109
        (convert l (lpos op))           ; Convert arg1 for immediate use
 
1110
        (parse (rpos op) (rbp op))))    ; Look for an arg2 
1115
1111
 
1116
1112
;;; (PARSE-NARY <op> <left>)
1117
1113
;;;
1124
1120
;;;  <left> is the stuff that has been seen to the left of <op> which 
1125
1121
;;;         rightly belongs to <op> on the basis of parse precedence rules.
1126
1122
 
1127
 
(DEFUN PARSE-NARY (OP L)
1128
 
  (LIST* (POS OP)                           ; Operator's mode
1129
 
         (MHEADER OP)                       ; Normal Macsyma operator header
1130
 
         (CONVERT L (LPOS OP))              ; Check type-match of arg1
1131
 
         (PRSNARY OP (LPOS OP) (LBP OP))))  ; Search for other args
 
1123
(defun parse-nary (op l)
 
1124
  (list* (pos op)                           ; Operator's mode
 
1125
         (mheader op)                       ; Normal Macsyma operator header
 
1126
         (convert l (lpos op))              ; Check type-match of arg1
 
1127
         (prsnary op (lpos op) (lbp op))))  ; Search for other args
1132
1128
 
1133
1129
;;; (PARSE-MATCHFIX <lop>)
1134
1130
;;;
1138
1134
;;;  has been seen. It parses <lop><form1>,<form2>,...<rop> returning
1139
1135
;;;  ( <mode> . ((<lop>) <form1> <form2> ...) ).
1140
1136
 
1141
 
(DEFUN PARSE-MATCHFIX (OP)
1142
 
  (LIST* (POS OP)                                ; Operator's mode
1143
 
         (MHEADER OP)                            ; Normal Macsyma operator header
1144
 
         (PRSMATCH (SAFE-GET OP 'MATCH) (LPOS OP))))  ; Search for matchfixed forms
 
1137
(defun parse-matchfix (op)
 
1138
  (list* (pos op)                                ; Operator's mode
 
1139
         (mheader op)                            ; Normal Macsyma operator header
 
1140
         (prsmatch (safe-get op 'match) (lpos op))))  ; Search for matchfixed forms
1145
1141
 
1146
1142
;;; (PARSE-NOFIX <op>)
1147
1143
;;;
1158
1154
;;;   a nofix op, then @(3,4) parses, but parses as "@"()(3,4) would -- ie, 
1159
1155
;;;   to ((MQAPPLY) (($@)) 3 4) which is perhaps not what the user will expect.
1160
1156
 
1161
 
(DEFUN PARSE-NOFIX (OP) (LIST (POS OP) (MHEADER OP)))
 
1157
(defun parse-nofix (op) (list (pos op) (mheader op)))
1162
1158
 
1163
1159
;;; (PRSNARY <op> <mode> <rbp>)
1164
1160
;;;
1175
1171
;;;          recursive parses as a binding power to parse for.
1176
1172
;;;  <mode> is the name of the mode that each form must be.
1177
1173
 
1178
 
(DEFUN PRSNARY (OP MODE RBP) 
1179
 
  (DO ((NL (LIST (PARSE MODE RBP))         ; Get at least one form
1180
 
           (CONS (PARSE MODE RBP) NL)))    ;  and keep getting forms
1181
 
      ((NOT (EQ OP (FIRST-C)))             ; until a parse pops on a new op
1182
 
       (NREVERSE NL))                      ;  at which time return forms
1183
 
      (POP-C)))                            ; otherwise pop op
 
1174
(defun prsnary (op mode rbp) 
 
1175
  (do ((nl (list (parse mode rbp))         ; Get at least one form
 
1176
           (cons (parse mode rbp) nl)))    ;  and keep getting forms
 
1177
      ((not (eq op (first-c)))             ; until a parse pops on a new op
 
1178
       (nreverse nl))                      ;  at which time return forms
 
1179
      (pop-c)))                            ; otherwise pop op
1184
1180
 
1185
1181
;;; (PRSMATCH <match> <mode>)
1186
1182
;;;
1191
1187
;;; <match> is the token to look for as a matchfix character.
1192
1188
;;; <mode>  is the name of the mode that each form must be.
1193
1189
 
1194
 
(DEFUN PRSMATCH (MATCH MODE)                      ; Parse for matchfix char
1195
 
  (COND ((EQ MATCH (FIRST-C)) (POP-C) NIL)        ; If immediate match, ()
1196
 
        (T                                        ; Else, ...
1197
 
         (DO ((NL (LIST (PARSE MODE 10.))         ;  Get first element
1198
 
                  (CONS (PARSE MODE 10.) NL)))    ;   and Keep adding elements
1199
 
             ((EQ MATCH (FIRST-C))                ;  Until we hit the match.
1200
 
              (POP-C)                             ;   Throw away match.
1201
 
              (NREVERSE NL))                      ;   Put result back in order
1202
 
           (IF (EQ '|$,| (FIRST-C))               ;  If not end, look for ","
1203
 
               (POP-C)                            ;   and pop it if it's there
1204
 
               (MREAD-SYNERR "Missing ~A"         ;   or give an error message.
1205
 
                             (MOPSTRIP MATCH)))))))
 
1190
(defun prsmatch (match mode)                      ; Parse for matchfix char
 
1191
  (cond ((eq match (first-c)) (pop-c) nil)        ; If immediate match, ()
 
1192
        (t                                        ; Else, ...
 
1193
         (do ((nl (list (parse mode 10.))         ;  Get first element
 
1194
                  (cons (parse mode 10.) nl)))    ;   and Keep adding elements
 
1195
             ((eq match (first-c))                ;  Until we hit the match.
 
1196
              (pop-c)                             ;   Throw away match.
 
1197
              (nreverse nl))                      ;   Put result back in order
 
1198
           (if (eq '|$,| (first-c))               ;  If not end, look for ","
 
1199
               (pop-c)                            ;   and pop it if it's there
 
1200
               (mread-synerr "Missing ~A"         ;   or give an error message.
 
1201
                             (mopstrip match)))))))
1206
1202
 
1207
1203
;;; (CONVERT <exp> <mode>)
1208
1204
;;;
1213
1209
;;;
1214
1210
;;;  If <expressionmode> and <mode> are compatible, returns <expression>.
1215
1211
 
1216
 
(DEFUN CONVERT (ITEM MODE) 
1217
 
  (IF (OR (EQ MODE (CAR ITEM))          ; If modes match exactly
1218
 
          (EQ '$ANY MODE)               ;    or target is $ANY
1219
 
          (EQ '$ANY (CAR ITEM)))        ;    or input is $ANY
1220
 
      (CDR ITEM)                        ;  then return expression
1221
 
      (MREAD-SYNERR "Found ~A expression where ~A expression expected" 
1222
 
                    (GET (CAR ITEM) 'ENGLISH)
1223
 
                    (GET MODE       'ENGLISH))))
1224
 
 
1225
 
(DEFPROP $ANY    "untyped"   ENGLISH)
1226
 
(DEFPROP $CLAUSE "logical"   ENGLISH)
1227
 
(DEFPROP $EXPR   "algebraic" ENGLISH)
1228
 
 
1229
 
 
 
1212
(defun convert (item mode) 
 
1213
  (if (or (eq mode (car item))          ; If modes match exactly
 
1214
          (eq '$any mode)               ;    or target is $ANY
 
1215
          (eq '$any (car item)))        ;    or input is $ANY
 
1216
      (cdr item)                        ;  then return expression
 
1217
      (mread-synerr "Found ~A expression where ~A expression expected" 
 
1218
                    (get (car item) 'english)
 
1219
                    (get mode       'english))))
 
1220
 
 
1221
(defprop $any    "untyped"   english)
 
1222
(defprop $clause "logical"   english)
 
1223
(defprop $expr   "algebraic" english)
 
1224
 
1230
1225
;;;; Parser Error Diagnostics
1231
1226
 
1232
1227
 ;; Call this for random user-generated parse errors
1233
1228
 
1234
 
(DEFUN PARSE-ERR () (MREAD-SYNERR "Syntax error")) 
 
1229
(defun parse-err () (mread-synerr "Syntax error")) 
1235
1230
 
1236
1231
 ;; Call this for random internal parser lossage (eg, code that shouldn't
1237
1232
 ;;  be reachable.)
1238
1233
 
1239
 
(DEFUN PARSE-BUG-ERR (OP)
1240
 
  (MREAD-SYNERR
1241
 
    "Parser bug in ~A. Please report this to the Macsyma maintainers,~
 
1234
(defun parse-bug-err (op)
 
1235
  (mread-synerr
 
1236
    "Parser bug in ~A. Please report this to the Maxima maintainers,~
1242
1237
   ~%including the characters you just typed which caused the error. Thanks."
1243
 
    (MOPSTRIP OP)))
 
1238
    (mopstrip op)))
1244
1239
 
1245
1240
;;; Random shared error messages
1246
1241
 
1247
 
(DEFUN DELIM-ERR (OP)
1248
 
  (MREAD-SYNERR "Illegal use of delimiter ~A" (MOPSTRIP OP)))
1249
 
 
1250
 
(DEFUN ERB-ERR (OP L) L ;Ignored
1251
 
  (MREAD-SYNERR "Too many ~A's" (MOPSTRIP OP)))
1252
 
 
1253
 
(DEFUN PREMTERM-ERR (OP)
1254
 
  (MREAD-SYNERR "Premature termination of input at ~A."
1255
 
                (MOPSTRIP OP)))
1256
 
 
1257
 
 
 
1242
(defun delim-err (op)
 
1243
  (mread-synerr "Illegal use of delimiter ~A" (mopstrip op)))
 
1244
 
 
1245
(defun erb-err (op l) l ;Ignored
 
1246
  (mread-synerr "Too many ~A's" (mopstrip op)))
 
1247
 
 
1248
(defun premterm-err (op)
 
1249
  (mread-synerr "Premature termination of input at ~A."
 
1250
                (mopstrip op)))
 
1251
 
1258
1252
;;;; Operator Specific Data
1259
1253
 
1260
 
(DEF-NUD-EQUIV |$]| DELIM-ERR)
1261
 
(DEF-LED-EQUIV |$]| ERB-ERR)
1262
 
(DEF-LBP     |$]| 5.)
 
1254
(def-nud-equiv |$]| delim-err)
 
1255
(def-led-equiv |$]| erb-err)
 
1256
(def-lbp     |$]| 5.)
1263
1257
 
1264
 
(DEF-NUD-EQUIV  |$[| PARSE-MATCHFIX)
1265
 
(DEF-MATCH      |$[| |$]|)
1266
 
(DEF-LBP        |$[| 200.)
 
1258
(def-nud-equiv  |$[| parse-matchfix)
 
1259
(def-match      |$[| |$]|)
 
1260
(def-lbp        |$[| 200.)
1267
1261
;No RBP
1268
 
(DEF-MHEADER    |$[| (MLIST))
1269
 
(DEF-POS        |$[| $ANY)
1270
 
(DEF-LPOS       |$[| $ANY)
 
1262
(def-mheader    |$[| (mlist))
 
1263
(def-pos        |$[| $any)
 
1264
(def-lpos       |$[| $any)
1271
1265
;No RPOS
1272
1266
 
1273
 
(DEF-LED (|$[| 200.) (OP LEFT)
1274
 
  (SETQ LEFT (CONVERT LEFT '$ANY))
1275
 
  (IF (NUMBERP LEFT) (PARSE-ERR))                       ; number[...] invalid
1276
 
  (LET ((header (if (atom left)
1277
 
                    (add-lineinfo (LIST (AMPERCHK LEFT) 'array))
1278
 
                  (add-lineinfo '(MQAPPLY ARRAY))))
 
1267
(def-led (|$[| 200.) (op left)
 
1268
  (setq left (convert left '$any))
 
1269
  (if (numberp left) (parse-err))                       ; number[...] invalid
 
1270
  (let ((header (if (atom left)
 
1271
                    (add-lineinfo (list (amperchk left) 'array))
 
1272
                  (add-lineinfo '(mqapply array))))
1279
1273
                  
1280
 
        (RIGHT (PRSMATCH '|$]| '$ANY)))                 ; get sublist in RIGHT
1281
 
    (COND ((NULL RIGHT)                                 ; 1 subscript minimum
1282
 
           (MREAD-SYNERR "No subscripts given"))
1283
 
          ((ATOM LEFT)                                  ; atom[...]
1284
 
           (SETQ RIGHT (CONS header
1285
 
                             RIGHT))
1286
 
           (CONS '$ANY (ALIASLOOKUP RIGHT)))
1287
 
          (T                                            ; exp[...]
1288
 
           (CONS '$ANY (CONS header
1289
 
                             (CONS LEFT RIGHT)))))))
1290
 
 
1291
 
 
1292
 
(DEF-NUD-EQUIV |$)| DELIM-ERR)
1293
 
(DEF-LED-EQUIV |$)| ERB-ERR)
1294
 
(DEF-LBP       |$)| 5.)
1295
 
 
1296
 
(DEF-MHEADER   |$(| (MPROGN))
 
1274
        (right (prsmatch '|$]| '$any)))                 ; get sublist in RIGHT
 
1275
    (cond ((null right)                                 ; 1 subscript minimum
 
1276
           (mread-synerr "No subscripts given"))
 
1277
          ((atom left)                                  ; atom[...]
 
1278
           (setq right (cons header
 
1279
                             right))
 
1280
           (cons '$any (aliaslookup right)))
 
1281
          (t                                            ; exp[...]
 
1282
           (cons '$any (cons header
 
1283
                             (cons left right)))))))
 
1284
 
 
1285
 
 
1286
(def-nud-equiv |$)| delim-err)
 
1287
(def-led-equiv |$)| erb-err)
 
1288
(def-lbp       |$)| 5.)
 
1289
 
 
1290
(def-mheader   |$(| (mprogn))
1297
1291
 
1298
1292
  ;; KMP: This function optimizes out (exp) into just exp. 
1299
1293
  ;;  This is useful for mathy expressions, but obnoxious for non-mathy
1307
1301
  ;;  comes inside quoted expressions. There are many other problems with
1308
1302
  ;;  the "QUOTE" concept however.
1309
1303
 
1310
 
(DEF-NUD (|$(| 200.) (OP)
1311
 
  (LET ((RIGHT)(hdr (MHEADER '|$(|)))        ; make mheader first for lineinfo
1312
 
    (COND ((EQ '|$)| (FIRST-C)) (PARSE-ERR))              ; () is illegal
1313
 
          ((OR (NULL (SETQ RIGHT (PRSMATCH '|$)| '$ANY))) ; No args to MPROGN??
1314
 
               (CDR RIGHT))                               ;  More than one arg.
1315
 
           (CONS '$ANY (CONS hdr RIGHT)))         ; Return an MPROGN
1316
 
          (T (CONS '$ANY (CAR RIGHT))))))                 ; Optimize out MPROGN
 
1304
(def-nud (|$(| 200.) (op)
 
1305
  (let ((right)(hdr (mheader '|$(|)))        ; make mheader first for lineinfo
 
1306
    (cond ((eq '|$)| (first-c)) (parse-err))              ; () is illegal
 
1307
          ((or (null (setq right (prsmatch '|$)| '$any))) ; No args to MPROGN??
 
1308
               (cdr right))                               ;  More than one arg.
 
1309
           (cons '$any (cons hdr right)))         ; Return an MPROGN
 
1310
          (t (cons '$any (car right))))))                 ; Optimize out MPROGN
1317
1311
 
1318
 
(DEF-LED (|$(| 200.) (OP LEFT)
1319
 
  (SETQ LEFT (CONVERT LEFT '$ANY))                      ;De-reference LEFT
1320
 
  (IF (NUMBERP LEFT) (PARSE-ERR))                       ;number(...) illegal
1321
 
  (LET ((HDR (AND (ATOM LEFT)(MHEADER (AMPERCHK LEFT))))
1322
 
        (R (PRSMATCH '|$)| '$ANY))                       ;Get arglist in R
 
1312
(def-led (|$(| 200.) (op left)
 
1313
  (setq left (convert left '$any))                      ;De-reference LEFT
 
1314
  (if (numberp left) (parse-err))                       ;number(...) illegal
 
1315
  (let ((hdr (and (atom left)(mheader (amperchk left))))
 
1316
        (r (prsmatch '|$)| '$any))                       ;Get arglist in R
1323
1317
        )
1324
 
    (CONS '$ANY                                         ;Result is type $ANY
1325
 
          (COND ((ATOM LEFT)                            ;If atom(...) =>
1326
 
                 (CONS hdr R))    ;(($atom) exp . args)
1327
 
                (T                                      ;Else exp(...) =>
1328
 
                 (CONS '(MQAPPLY) (CONS LEFT R)))))))   ;((MQAPPLY) op . args)
1329
 
 
1330
 
(DEF-MHEADER |$'| (MQUOTE))
1331
 
 
1332
 
(DEF-NUD (|$'|) (OP)
1333
 
  (LET (RIGHT)
1334
 
    (COND ((EQ '|$(| (FIRST-C))
1335
 
           (LIST '$ANY (MHEADER '|$'|) (PARSE '$ANY 190.)))
1336
 
          ((OR (ATOM (SETQ RIGHT (PARSE '$ANY 190.)))
1337
 
               (MEMQ (CAAR RIGHT) '(MQUOTE MLIST MPROG MPROGN LAMBDA)))
1338
 
           (LIST '$ANY (MHEADER '|$'|) RIGHT))
1339
 
          ((EQ 'MQAPPLY (CAAR RIGHT))
1340
 
           (COND ((EQ (CAAADR RIGHT) 'LAMBDA)
1341
 
                  (LIST '$ANY (MHEADER '|$'|) RIGHT))
1342
 
                 (T (RPLACA (CDR RIGHT)
1343
 
                            (CONS (CONS ($NOUNIFY (CAAADR RIGHT))
1344
 
                                        (CDAADR RIGHT))
1345
 
                                  (CDADR RIGHT)))
1346
 
                    (CONS '$ANY RIGHT))))
1347
 
          (T (CONS '$ANY (CONS (CONS ($NOUNIFY (CAAR RIGHT)) (CDAR RIGHT))
1348
 
                               (CDR RIGHT)))))))
1349
 
 
1350
 
(DEF-NUD (|$''|) (OP)
1351
 
  (LET (RIGHT)
1352
 
    (CONS '$ANY
1353
 
          (COND ((EQ '|$(| (FIRST-C))  (MEVAL (PARSE '$ANY 190.)))
1354
 
                ((ATOM (SETQ RIGHT (PARSE '$ANY 190.))) (MEVAL1 RIGHT))
1355
 
                ((EQ 'MQAPPLY (CAAR RIGHT))
1356
 
                 (RPLACA (CDR RIGHT)
1357
 
                         (CONS (CONS ($VERBIFY (CAAADR RIGHT)) (CDAADR RIGHT))
1358
 
                               (CDADR RIGHT)))
1359
 
                 RIGHT)
1360
 
                (T (CONS (CONS ($VERBIFY (CAAR RIGHT)) (CDAR RIGHT))
1361
 
                         (CDR RIGHT)))))))
1362
 
 
1363
 
(DEF-LED-EQUIV |$:| PARSE-INFIX)
1364
 
(DEF-LBP       |$:| 180.)
1365
 
(DEF-RBP       |$:|  20.)
1366
 
(DEF-POS       |$:| $ANY)
1367
 
(DEF-RPOS      |$:| $ANY)
1368
 
(DEF-LPOS      |$:| $ANY)
1369
 
(DEF-MHEADER   |$:| (MSETQ))
1370
 
 
1371
 
(DEF-LED-EQUIV |$::| PARSE-INFIX)
1372
 
(DEF-LBP       |$::| 180.)
1373
 
(DEF-RBP       |$::|  20.)
1374
 
(DEF-POS       |$::| $ANY)
1375
 
(DEF-RPOS      |$::| $ANY)
1376
 
(DEF-LPOS      |$::| $ANY)
1377
 
(DEF-MHEADER   |$::| (MSET))
1378
 
 
1379
 
(DEF-LED-EQUIV |$:=| PARSE-INFIX)
1380
 
(DEF-LBP       |$:=| 180.)
1381
 
(DEF-RBP       |$:=|  20.)
1382
 
(DEF-POS       |$:=| $ANY)
1383
 
(DEF-RPOS      |$:=| $ANY)
1384
 
(DEF-LPOS      |$:=| $ANY)
1385
 
(DEF-MHEADER   |$:=| (MDEFINE))
1386
 
 
1387
 
(DEF-LED-EQUIV |$::=| PARSE-INFIX)
1388
 
(DEF-LBP       |$::=| 180.)
1389
 
(DEF-RBP       |$::=|  20.)
1390
 
(DEF-POS       |$::=| $ANY)
1391
 
(DEF-RPOS      |$::=| $ANY)
1392
 
(DEF-LPOS      |$::=| $ANY)
1393
 
(DEF-MHEADER   |$::=| (MDEFMACRO))
1394
 
 
1395
 
(DEF-LED-EQUIV  |$!| PARSE-POSTFIX)
1396
 
(DEF-LBP        |$!| 160.)
 
1318
    (cons '$any                                         ;Result is type $ANY
 
1319
          (cond ((atom left)                            ;If atom(...) =>
 
1320
                 (cons hdr r))    ;(($atom) exp . args)
 
1321
                (t                                      ;Else exp(...) =>
 
1322
                 (cons '(mqapply) (cons left r)))))))   ;((MQAPPLY) op . args)
 
1323
 
 
1324
(def-mheader |$'| (mquote))
 
1325
 
 
1326
(def-nud (|$'|) (op)
 
1327
  (let (right)
 
1328
    (cond ((eq '|$(| (first-c))
 
1329
           (list '$any (mheader '|$'|) (parse '$any 190.)))
 
1330
          ((or (atom (setq right (parse '$any 190.)))
 
1331
               (memq (caar right) '(mquote mlist mprog mprogn lambda)))
 
1332
           (list '$any (mheader '|$'|) right))
 
1333
          ((eq 'mqapply (caar right))
 
1334
           (cond ((eq (caaadr right) 'lambda)
 
1335
                  (list '$any (mheader '|$'|) right))
 
1336
                 (t (rplaca (cdr right)
 
1337
                            (cons (cons ($nounify (caaadr right))
 
1338
                                        (cdaadr right))
 
1339
                                  (cdadr right)))
 
1340
                    (cons '$any right))))
 
1341
          (t (cons '$any (cons (cons ($nounify (caar right)) (cdar right))
 
1342
                               (cdr right)))))))
 
1343
 
 
1344
(def-nud (|$''|) (op)
 
1345
  (let (right)
 
1346
    (cons '$any
 
1347
          (cond ((eq '|$(| (first-c))  (meval (parse '$any 190.)))
 
1348
                ((atom (setq right (parse '$any 190.))) (meval1 right))
 
1349
                ((eq 'mqapply (caar right))
 
1350
                 (rplaca (cdr right)
 
1351
                         (cons (cons ($verbify (caaadr right)) (cdaadr right))
 
1352
                               (cdadr right)))
 
1353
                 right)
 
1354
                (t (cons (cons ($verbify (caar right)) (cdar right))
 
1355
                         (cdr right)))))))
 
1356
 
 
1357
(def-led-equiv |$:| parse-infix)
 
1358
(def-lbp       |$:| 180.)
 
1359
(def-rbp       |$:|  20.)
 
1360
(def-pos       |$:| $any)
 
1361
(def-rpos      |$:| $any)
 
1362
(def-lpos      |$:| $any)
 
1363
(def-mheader   |$:| (msetq))
 
1364
 
 
1365
(def-led-equiv |$::| parse-infix)
 
1366
(def-lbp       |$::| 180.)
 
1367
(def-rbp       |$::|  20.)
 
1368
(def-pos       |$::| $any)
 
1369
(def-rpos      |$::| $any)
 
1370
(def-lpos      |$::| $any)
 
1371
(def-mheader   |$::| (mset))
 
1372
 
 
1373
(def-led-equiv |$:=| parse-infix)
 
1374
(def-lbp       |$:=| 180.)
 
1375
(def-rbp       |$:=|  20.)
 
1376
(def-pos       |$:=| $any)
 
1377
(def-rpos      |$:=| $any)
 
1378
(def-lpos      |$:=| $any)
 
1379
(def-mheader   |$:=| (mdefine))
 
1380
 
 
1381
(def-led-equiv |$::=| parse-infix)
 
1382
(def-lbp       |$::=| 180.)
 
1383
(def-rbp       |$::=|  20.)
 
1384
(def-pos       |$::=| $any)
 
1385
(def-rpos      |$::=| $any)
 
1386
(def-lpos      |$::=| $any)
 
1387
(def-mheader   |$::=| (mdefmacro))
 
1388
 
 
1389
(def-led-equiv  |$!| parse-postfix)
 
1390
(def-lbp        |$!| 160.)
1397
1391
;No RBP
1398
 
(DEF-POS        |$!| $EXPR)
1399
 
(DEF-LPOS       |$!| $EXPR)
 
1392
(def-pos        |$!| $expr)
 
1393
(def-lpos       |$!| $expr)
1400
1394
;No RPOS
1401
 
(DEF-MHEADER    |$!| (MFACTORIAL))
1402
 
 
1403
 
(DEF-MHEADER |$!!| ($GENFACT))
1404
 
 
1405
 
(DEF-LED (|$!!| 160.) (OP LEFT)
1406
 
  (LIST '$EXPR
1407
 
        (MHEADER '$!!)
1408
 
        (CONVERT LEFT '$EXPR)
1409
 
        (LIST (MHEADER '#-cl $// #+cl $/ ) (CONVERT LEFT '$EXPR) 2)
 
1395
(def-mheader    |$!| (mfactorial))
 
1396
 
 
1397
(def-mheader |$!!| ($genfact))
 
1398
 
 
1399
(def-led (|$!!| 160.) (op left)
 
1400
  (list '$expr
 
1401
        (mheader '$!!)
 
1402
        (convert left '$expr)
 
1403
        (list (mheader '#-cl $// #+cl $/ ) (convert left '$expr) 2)
1410
1404
        2))
1411
1405
 
1412
 
(DEF-LBP     |$^| 140.) 
1413
 
(DEF-RBP     |$^| 139.)
1414
 
(DEF-POS     |$^| $EXPR)
1415
 
(DEF-LPOS    |$^| $EXPR)
1416
 
(DEF-RPOS    |$^| $EXPR)
1417
 
(DEF-MHEADER |$^| (MEXPT))
1418
 
 
1419
 
(DEF-LED ((|$^| |$^^|)) (OP LEFT)
1420
 
  (CONS '$EXPR 
1421
 
        (ALIASLOOKUP (LIST (MHEADER OP)
1422
 
                           (CONVERT LEFT (LPOS OP))
1423
 
                           (PARSE (RPOS OP) (RBP OP))))))
1424
 
 
1425
 
(MAPC #'(LAMBDA (PROP) ; Make $** like $^
1426
 
          (LET ((PROPVAL (GET '$^ PROP)))
1427
 
            (IF PROPVAL (PUTPROP '$** PROPVAL PROP))))
1428
 
      '(LBP RBP POS RPOS LPOS MHEADER))
1429
 
(INHERIT-PROPL  '$** '$^ (LED-PROPL))
1430
 
 
1431
 
(DEF-LBP     |$^^| 140.)
1432
 
(DEF-RBP     |$^^| 139.)
1433
 
(DEF-POS     |$^^| $EXPR)
1434
 
(DEF-LPOS    |$^^| $EXPR)
1435
 
(DEF-RPOS    |$^^| $EXPR)
1436
 
(DEF-MHEADER |$^^| (MNCEXPT))
 
1406
(def-lbp     |$^| 140.) 
 
1407
(def-rbp     |$^| 139.)
 
1408
(def-pos     |$^| $expr)
 
1409
(def-lpos    |$^| $expr)
 
1410
(def-rpos    |$^| $expr)
 
1411
(def-mheader |$^| (mexpt))
 
1412
 
 
1413
(def-led ((|$^| |$^^|)) (op left)
 
1414
  (cons '$expr 
 
1415
        (aliaslookup (list (mheader op)
 
1416
                           (convert left (lpos op))
 
1417
                           (parse (rpos op) (rbp op))))))
 
1418
 
 
1419
(mapc #'(lambda (prop) ; Make $** like $^
 
1420
          (let ((propval (get '$^ prop)))
 
1421
            (if propval (putprop '$** propval prop))))
 
1422
      '(lbp rbp pos rpos lpos mheader))
 
1423
(inherit-propl  '$** '$^ (led-propl))
 
1424
 
 
1425
(def-lbp     |$^^| 140.)
 
1426
(def-rbp     |$^^| 139.)
 
1427
(def-pos     |$^^| $expr)
 
1428
(def-lpos    |$^^| $expr)
 
1429
(def-rpos    |$^^| $expr)
 
1430
(def-mheader |$^^| (mncexpt))
1437
1431
 
1438
1432
;; note y^^4.z gives an error because it scans the number 4 together with
1439
1433
;; the trailing '.' as a decimal place.    I think the error is correct.
1440
 
(DEF-LED-EQUIV  |$.| PARSE-INFIX)
1441
 
(DEF-LBP        |$.| 130.)
1442
 
(DEF-RBP        |$.| 129.)
1443
 
(DEF-POS        |$.| $EXPR)
1444
 
(DEF-LPOS       |$.| $EXPR)
1445
 
(DEF-RPOS       |$.| $EXPR)
1446
 
(DEF-MHEADER    |$.| (MNCTIMES))
 
1434
(def-led-equiv  |$.| parse-infix)
 
1435
(def-lbp        |$.| 130.)
 
1436
(def-rbp        |$.| 129.)
 
1437
(def-pos        |$.| $expr)
 
1438
(def-lpos       |$.| $expr)
 
1439
(def-rpos       |$.| $expr)
 
1440
(def-mheader    |$.| (mnctimes))
1447
1441
 
1448
 
(DEF-LED-EQUIV  |$*| PARSE-NARY)
1449
 
(DEF-LBP        |$*| 120.)
 
1442
(def-led-equiv  |$*| parse-nary)
 
1443
(def-lbp        |$*| 120.)
1450
1444
;RBP not needed
1451
 
(DEF-POS        |$*| $EXPR)
 
1445
(def-pos        |$*| $expr)
1452
1446
;RPOS not needed
1453
 
(DEF-LPOS       |$*| $EXPR)
1454
 
(DEF-MHEADER    |$*| (MTIMES))
1455
 
 
1456
 
(DEF-LED-EQUIV  #-cl |$//| #+cl $/  PARSE-INFIX)
1457
 
(DEF-LBP        #-cl |$//| #+cl $/  120.)
1458
 
(DEF-RBP        #-cl |$//| #+cl $/  120.)
1459
 
(DEF-POS        #-cl |$//| #+cl $/  $EXPR)
1460
 
(DEF-RPOS       #-cl |$//| #+cl $/  $EXPR)
1461
 
(DEF-LPOS       #-cl |$//| #+cl $/  $EXPR)
1462
 
(DEF-MHEADER    #-cl |$//| #+cl $/  (MQUOTIENT))
1463
 
 
1464
 
(DEF-NUD-EQUIV  |$+| PARSE-PREFIX)
1465
 
(DEF-LBP        |$+| 100.)
1466
 
(DEF-RBP        |$+| 100.)
1467
 
(DEF-POS        |$+| $EXPR)
1468
 
(DEF-RPOS       |$+| $EXPR)
1469
 
;LPOS not needed
1470
 
(DEF-MHEADER    |$+| (MPLUS))
1471
 
 
1472
 
(DEF-LED ((|$+| |$-|) 100.) (OP LEFT)
1473
 
  (SETQ LEFT (CONVERT LEFT '$EXPR))
1474
 
  (DO ((NL (LIST (IF (EQ OP '$-)
1475
 
                     (LIST (MHEADER '$-) (PARSE '$EXPR 100.))
1476
 
                     (PARSE '$EXPR 100.))
1477
 
                 LEFT)
1478
 
           (CONS (PARSE '$EXPR 100.) NL)))
1479
 
      ((NOT (MEMQ (FIRST-C) '($+ $-)))
1480
 
       (LIST* '$EXPR (MHEADER '$+) (NREVERSE NL)))
1481
 
    (IF (EQ (FIRST-C) '$+) (POP-C))))
1482
 
 
1483
 
(DEF-NUD-EQUIV  |$-| PARSE-PREFIX)
1484
 
(DEF-LBP        |$-| 100.)
1485
 
(DEF-RBP        |$-| 134.)
1486
 
(DEF-POS        |$-| $EXPR)
1487
 
(DEF-RPOS       |$-| $EXPR)
1488
 
;LPOS not needed
1489
 
(DEF-MHEADER    |$-| (MMINUS))
1490
 
 
1491
 
(DEF-LED-EQUIV  |$=| PARSE-INFIX)
1492
 
(DEF-LBP        |$=| 80.)
1493
 
(DEF-RBP        |$=| 80.)
1494
 
(DEF-POS        |$=| $CLAUSE)
1495
 
(DEF-RPOS       |$=| $EXPR)
1496
 
(DEF-LPOS       |$=| $EXPR)
1497
 
(DEF-MHEADER    |$=| (MEQUAL))
1498
 
 
1499
 
(DEF-LED-EQUIV  |$#| PARSE-INFIX)
1500
 
(DEF-LBP        |$#| 80.)
1501
 
(DEF-RBP        |$#| 80.)
1502
 
(DEF-POS        |$#| $CLAUSE)
1503
 
(DEF-RPOS       |$#| $EXPR)
1504
 
(DEF-LPOS       |$#| $EXPR)
1505
 
(DEF-MHEADER    |$#| (MNOTEQUAL))
1506
 
 
1507
 
(DEF-LED-EQUIV  |$>| PARSE-INFIX)
1508
 
(DEF-LBP        |$>| 80.)
1509
 
(DEF-RBP        |$>| 80.)
1510
 
(DEF-POS        |$>| $CLAUSE)
1511
 
(DEF-RPOS       |$>| $EXPR)
1512
 
(DEF-LPOS       |$>| $EXPR)
1513
 
(DEF-MHEADER    |$>| (MGREATERP))
1514
 
 
1515
 
(DEF-LED-EQUIV  |$>=| PARSE-INFIX)
1516
 
(DEF-LBP        |$>=| 80.)
1517
 
(DEF-RBP        |$>=| 80.)
1518
 
(DEF-POS        |$>=| $CLAUSE)
1519
 
(DEF-RPOS       |$>=| $EXPR)
1520
 
(DEF-LPOS       |$>=| $EXPR)
1521
 
(DEF-MHEADER    |$>=| (MGEQP))
1522
 
 
1523
 
 
1524
 
(DEF-NUD (|$>| 80.) (OP) ; > is a single-char object
1525
 
  '($ANY . |$>|))
1526
 
 
1527
 
(DEF-LED-EQUIV  |$<| PARSE-INFIX)
1528
 
(DEF-LBP        |$<| 80.)
1529
 
(DEF-RBP        |$<| 80.)
1530
 
(DEF-POS        |$<| $CLAUSE)
1531
 
(DEF-RPOS       |$<| $EXPR)
1532
 
(DEF-LPOS       |$<| $EXPR)
1533
 
(DEF-MHEADER    |$<| (MLESSP))
1534
 
 
1535
 
(DEF-LED-EQUIV  |$<=| PARSE-INFIX)
1536
 
(DEF-LBP        |$<=| 80.)
1537
 
(DEF-RBP        |$<=| 80.)
1538
 
(DEF-POS        |$<=| $CLAUSE)
1539
 
(DEF-RPOS       |$<=| $EXPR)
1540
 
(DEF-LPOS       |$<=| $EXPR)
1541
 
(DEF-MHEADER    |$<=| (MLEQP))
1542
 
 
1543
 
(DEF-NUD-EQUIV  |$NOT| PARSE-PREFIX)
 
1447
(def-lpos       |$*| $expr)
 
1448
(def-mheader    |$*| (mtimes))
 
1449
 
 
1450
(def-led-equiv  #-cl |$//| #+cl $/  parse-infix)
 
1451
(def-lbp        #-cl |$//| #+cl $/  120.)
 
1452
(def-rbp        #-cl |$//| #+cl $/  120.)
 
1453
(def-pos        #-cl |$//| #+cl $/  $expr)
 
1454
(def-rpos       #-cl |$//| #+cl $/  $expr)
 
1455
(def-lpos       #-cl |$//| #+cl $/  $expr)
 
1456
(def-mheader    #-cl |$//| #+cl $/  (mquotient))
 
1457
 
 
1458
(def-nud-equiv  |$+| parse-prefix)
 
1459
(def-lbp        |$+| 100.)
 
1460
(def-rbp        |$+| 100.)
 
1461
(def-pos        |$+| $expr)
 
1462
(def-rpos       |$+| $expr)
 
1463
;LPOS not needed
 
1464
(def-mheader    |$+| (mplus))
 
1465
 
 
1466
(def-led ((|$+| |$-|) 100.) (op left)
 
1467
  (setq left (convert left '$expr))
 
1468
  (do ((nl (list (if (eq op '$-)
 
1469
                     (list (mheader '$-) (parse '$expr 100.))
 
1470
                     (parse '$expr 100.))
 
1471
                 left)
 
1472
           (cons (parse '$expr 100.) nl)))
 
1473
      ((not (memq (first-c) '($+ $-)))
 
1474
       (list* '$expr (mheader '$+) (nreverse nl)))
 
1475
    (if (eq (first-c) '$+) (pop-c))))
 
1476
 
 
1477
(def-nud-equiv  |$-| parse-prefix)
 
1478
(def-lbp        |$-| 100.)
 
1479
(def-rbp        |$-| 134.)
 
1480
(def-pos        |$-| $expr)
 
1481
(def-rpos       |$-| $expr)
 
1482
;LPOS not needed
 
1483
(def-mheader    |$-| (mminus))
 
1484
 
 
1485
(def-led-equiv  |$=| parse-infix)
 
1486
(def-lbp        |$=| 80.)
 
1487
(def-rbp        |$=| 80.)
 
1488
(def-pos        |$=| $clause)
 
1489
(def-rpos       |$=| $expr)
 
1490
(def-lpos       |$=| $expr)
 
1491
(def-mheader    |$=| (mequal))
 
1492
 
 
1493
(def-led-equiv  |$#| parse-infix)
 
1494
(def-lbp        |$#| 80.)
 
1495
(def-rbp        |$#| 80.)
 
1496
(def-pos        |$#| $clause)
 
1497
(def-rpos       |$#| $expr)
 
1498
(def-lpos       |$#| $expr)
 
1499
(def-mheader    |$#| (mnotequal))
 
1500
 
 
1501
(def-led-equiv  |$>| parse-infix)
 
1502
(def-lbp        |$>| 80.)
 
1503
(def-rbp        |$>| 80.)
 
1504
(def-pos        |$>| $clause)
 
1505
(def-rpos       |$>| $expr)
 
1506
(def-lpos       |$>| $expr)
 
1507
(def-mheader    |$>| (mgreaterp))
 
1508
 
 
1509
(def-led-equiv  |$>=| parse-infix)
 
1510
(def-lbp        |$>=| 80.)
 
1511
(def-rbp        |$>=| 80.)
 
1512
(def-pos        |$>=| $clause)
 
1513
(def-rpos       |$>=| $expr)
 
1514
(def-lpos       |$>=| $expr)
 
1515
(def-mheader    |$>=| (mgeqp))
 
1516
 
 
1517
(def-led-equiv  |$<| parse-infix)
 
1518
(def-lbp        |$<| 80.)
 
1519
(def-rbp        |$<| 80.)
 
1520
(def-pos        |$<| $clause)
 
1521
(def-rpos       |$<| $expr)
 
1522
(def-lpos       |$<| $expr)
 
1523
(def-mheader    |$<| (mlessp))
 
1524
 
 
1525
(def-led-equiv  |$<=| parse-infix)
 
1526
(def-lbp        |$<=| 80.)
 
1527
(def-rbp        |$<=| 80.)
 
1528
(def-pos        |$<=| $clause)
 
1529
(def-rpos       |$<=| $expr)
 
1530
(def-lpos       |$<=| $expr)
 
1531
(def-mheader    |$<=| (mleqp))
 
1532
 
 
1533
(def-nud-equiv  $not parse-prefix)
1544
1534
;LBP not needed
1545
 
(DEF-RBP        |$NOT| 70.)
1546
 
(DEF-POS        |$NOT| $CLAUSE)
1547
 
(DEF-RPOS       |$NOT| $CLAUSE)
1548
 
(DEF-LPOS       |$NOT| $CLAUSE)
1549
 
(DEF-MHEADER    |$NOT| (MNOT))
1550
 
 
1551
 
(DEF-LED-EQUIV  |$AND| PARSE-NARY)
1552
 
(DEF-LBP        |$AND| 65.)
1553
 
;RBP not needed
1554
 
(DEF-POS        |$AND| $CLAUSE)
1555
 
;RPOS not needed
1556
 
(DEF-LPOS       |$AND| $CLAUSE)
1557
 
(DEF-MHEADER    |$AND| (MAND))
1558
 
 
1559
 
(DEF-LED-EQUIV  |$OR| PARSE-NARY)
1560
 
(DEF-LBP        |$OR| 60.)
1561
 
;RBP not needed
1562
 
(DEF-POS        |$OR| $CLAUSE)
1563
 
;RPOS not needed
1564
 
(DEF-LPOS       |$OR| $CLAUSE)
1565
 
(DEF-MHEADER    |$OR| (MOR))
1566
 
 
1567
 
(DEF-LED-EQUIV  |$,| PARSE-NARY)
1568
 
(DEF-LBP        |$,| 10.)
1569
 
;RBP not needed
1570
 
(DEF-POS        |$,| $ANY)
1571
 
;RPOS not needed
1572
 
(DEF-LPOS       |$,| $ANY)
1573
 
(DEF-MHEADER    |$,| ($EV))
1574
 
 
1575
 
(DEF-NUD-EQUIV |$THEN| DELIM-ERR)
1576
 
(DEF-LBP |$THEN| 5.)
1577
 
(DEF-RBP |$THEN| 25.)
1578
 
 
1579
 
(DEF-NUD-EQUIV |$ELSE| DELIM-ERR)
1580
 
(DEF-LBP |$ELSE| 5.)
1581
 
(DEF-RBP |$ELSE| 25.)
1582
 
 
1583
 
(DEF-NUD-EQUIV |$ELSEIF| DELIM-ERR)
1584
 
(DEF-LBP  |$ELSEIF| 5.)
1585
 
(DEF-RBP  |$ELSEIF| 45.)
1586
 
(DEF-POS  |$ELSEIF| $ANY)
1587
 
(DEF-RPOS |$ELSEIF| $CLAUSE)
 
1535
(def-rbp        $not 70.)
 
1536
(def-pos        $not $clause)
 
1537
(def-rpos       $not $clause)
 
1538
(def-lpos       $not $clause)
 
1539
(def-mheader    $not (mnot))
 
1540
 
 
1541
(def-led-equiv  $and parse-nary)
 
1542
(def-lbp        $and 65.)
 
1543
;RBP not needed
 
1544
(def-pos        $and $clause)
 
1545
;RPOS not needed
 
1546
(def-lpos       $and $clause)
 
1547
(def-mheader    $and (mand))
 
1548
 
 
1549
(def-led-equiv  $or parse-nary)
 
1550
(def-lbp        $or 60.)
 
1551
;RBP not needed
 
1552
(def-pos        $or $clause)
 
1553
;RPOS not needed
 
1554
(def-lpos       $or $clause)
 
1555
(def-mheader    $or (mor))
 
1556
 
 
1557
(def-led-equiv  |$,| parse-nary)
 
1558
(def-lbp        |$,| 10.)
 
1559
;RBP not needed
 
1560
(def-pos        |$,| $any)
 
1561
;RPOS not needed
 
1562
(def-lpos       |$,| $any)
 
1563
(def-mheader    |$,| ($ev))
 
1564
 
 
1565
(def-nud-equiv $then delim-err)
 
1566
(def-lbp $then 5.)
 
1567
(def-rbp $then 25.)
 
1568
 
 
1569
(def-nud-equiv $else delim-err)
 
1570
(def-lbp $else 5.)
 
1571
(def-rbp $else 25.)
 
1572
 
 
1573
(def-nud-equiv $elseif delim-err)
 
1574
(def-lbp  $elseif 5.)
 
1575
(def-rbp  $elseif 45.)
 
1576
(def-pos  $elseif $any)
 
1577
(def-rpos $elseif $clause)
1588
1578
 
1589
1579
;No LBP - Default as high as possible
1590
 
(DEF-RBP     $IF 45.)
1591
 
(DEF-POS     $IF $ANY)
1592
 
(DEF-RPOS    $IF $CLAUSE)
 
1580
(def-rbp     $if 45.)
 
1581
(def-pos     $if $any)
 
1582
(def-rpos    $if $clause)
1593
1583
;No LPOS
1594
 
(DEF-MHEADER $IF (MCOND))
1595
 
 
1596
 
(DEF-NUD (|$IF|) (OP)
1597
 
  (LIST* (POS OP)
1598
 
         (MHEADER OP)
1599
 
         (PARSE-CONDITION OP)))
1600
 
 
1601
 
(DEFUN PARSE-CONDITION (OP)
1602
 
  (LIST* (PARSE (RPOS OP) (RBP OP))
1603
 
         (IF (EQ (FIRST-C) '$THEN)
1604
 
             (PARSE '$ANY (RBP (POP-C)))
1605
 
             (MREAD-SYNERR "Missing THEN"))
1606
 
         (CASE (FIRST-C)
1607
 
           (($ELSE)   (LIST T (PARSE '$ANY (RBP (POP-C)))))
1608
 
           (($ELSEIF) (PARSE-CONDITION (POP-C)))
1609
 
           (T ; Note: $FALSE instead of () makes DISPLA suppress display!
1610
 
            (LIST T '$FALSE)))))
1611
 
 
1612
 
(DEF-MHEADER $DO (MDO))
1613
 
 
1614
 
(DEFUN PARSE-$DO (LEX &aux (left (make-mdo)))
1615
 
  (setf (car LEFT) (mheader 'mdo))
1616
 
  (DO ((OP LEX (POP-C))  (ACTIVE-BITMASK 0))
1617
 
      (NIL)
1618
 
    (IF (EQ OP '|$:|) (SETQ OP '$FROM))
1619
 
    (SETQ ACTIVE-BITMASK (COLLISION-CHECK '$DO ACTIVE-BITMASK OP))
1620
 
    (LET ((DATA (PARSE (RPOS OP) (RBP OP))))
1621
 
      (CASE OP
1622
 
        ($DO            (SETF (MDO-BODY LEFT) DATA) (RETURN (CONS '$ANY LEFT)))
1623
 
        ($FOR           (SETF (MDO-FOR  LEFT) DATA))
1624
 
        ($FROM          (SETF (MDO-FROM LEFT) DATA))
1625
 
        ($IN            (SETF (MDO-OP   LEFT) 'MDOIN)
1626
 
                        (SETF (MDO-FROM LEFT) DATA))
1627
 
        ($STEP          (SETF (MDO-STEP LEFT) DATA))
1628
 
        ($NEXT          (SETF (MDO-NEXT LEFT) DATA))
1629
 
        ($THRU          (SETF (MDO-THRU LEFT) DATA))
1630
 
        (($UNLESS $WHILE)
1631
 
                        (IF (EQ OP '$WHILE)
1632
 
                            (SETQ DATA (LIST (MHEADER '$NOT) DATA)))
1633
 
                        (SETF (MDO-UNLESS LEFT)
1634
 
                           (IF (NULL (MDO-UNLESS LEFT))
1635
 
                               DATA
1636
 
                               (LIST (MHEADER '$OR) DATA (MDO-UNLESS LEFT)))))
1637
 
        (T (PARSE-BUG-ERR '$DO))))))
1638
 
 
1639
 
(DEF-LBP $FOR    25.)
1640
 
(DEF-LBP $FROM   25.)
1641
 
(DEF-LBP $STEP   25.)
1642
 
(DEF-LBP $NEXT   25.)
1643
 
(DEF-LBP $THRU   25.)
1644
 
(DEF-LBP $UNLESS 25.)
1645
 
(DEF-LBP $WHILE  25.)
1646
 
(DEF-LBP $DO     25.)
1647
 
 
1648
 
(DEF-NUD-EQUIV $FOR    PARSE-$DO)
1649
 
(DEF-NUD-EQUIV $FROM   PARSE-$DO)
1650
 
(DEF-NUD-EQUIV $STEP   PARSE-$DO)
1651
 
(DEF-NUD-EQUIV $NEXT   PARSE-$DO)
1652
 
(DEF-NUD-EQUIV $THRU   PARSE-$DO)
1653
 
(DEF-NUD-EQUIV $UNLESS PARSE-$DO)
1654
 
(DEF-NUD-EQUIV $WHILE  PARSE-$DO)
1655
 
(DEF-NUD-EQUIV $DO     PARSE-$DO)
1656
 
 
1657
 
(DEF-RBP $DO      25.)
1658
 
(DEF-RBP $FOR    200.)
1659
 
(DEF-RBP $FROM    95.)
1660
 
(DEF-RBP $IN      95.)
1661
 
(DEF-RBP $STEP    95.)
1662
 
(DEF-RBP $NEXT    45.)
1663
 
(DEF-RBP $THRU    95.)
1664
 
(DEF-RBP $UNLESS  45.)
1665
 
(DEF-RBP $WHILE   45.)
1666
 
 
1667
 
(DEF-RPOS $DO     $ANY)
1668
 
(DEF-RPOS $FOR    $ANY)
1669
 
(DEF-RPOS $FROM   $ANY)
1670
 
(DEF-RPOS $STEP   $EXPR)
1671
 
(DEF-RPOS $NEXT   $ANY)
1672
 
(DEF-RPOS $THRU   $EXPR)
1673
 
(DEF-RPOS $UNLESS $CLAUSE)
1674
 
(DEF-RPOS $WHILE  $CLAUSE)
1675
 
 
1676
 
 
1677
 
(DEF-COLLISIONS $DO
1678
 
  ($DO     . ())
1679
 
  ($FOR    . ($FOR))
1680
 
  ($FROM   . ($IN $FROM))
1681
 
  ($IN     . ($IN $FROM $STEP $NEXT))
1682
 
  ($STEP   . ($IN       $STEP $NEXT))
1683
 
  ($NEXT   . ($IN       $STEP $NEXT))
1684
 
  ($THRU   . ($IN $THRU)) ;$IN didn't used to get checked for
1685
 
  ($UNLESS . ())
1686
 
  ($WHILE  . ()))
1687
 
 
1688
 
#+ti  ;;because of a bug the preceding doesn't give this..
1689
 
(defprop $do (($WHILE . 256) ($UNLESS . 128)
1690
 
                ($THRU . 64)
1691
 
                ($NEXT . 32)
1692
 
                ($STEP . 16)
1693
 
                ($IN . 8)
1694
 
                ($FROM . 4)
1695
 
                ($FOR . 2)
1696
 
                ($DO . 1)) keys)
1697
 
 
1698
 
 
1699
 
(DEF-MHEADER   |$$| (NODISPLAYINPUT))
1700
 
(DEF-NUD-EQUIV |$$| PREMTERM-ERR)
1701
 
(DEF-LBP       |$$| -1)
1702
 
;No RBP, POS, RPOS, RBP, or MHEADER
1703
 
 
1704
 
(DEF-MHEADER   |$;| (DISPLAYINPUT))
1705
 
(DEF-NUD-EQUIV |$;| PREMTERM-ERR)
1706
 
(DEF-LBP       |$;| -1)
1707
 
;No RBP, POS, RPOS, RBP, or MHEADER
1708
 
 
1709
 
(DEF-NUD-EQUIV  |$&&| DELIM-ERR)
1710
 
(DEF-LBP        |$&&| -1)
1711
 
 
1712
 
(defun MOPSTRIP (x)
 
1584
(def-mheader $if (mcond))
 
1585
 
 
1586
(def-nud ($if) (op)
 
1587
  (list* (pos op)
 
1588
         (mheader op)
 
1589
         (parse-condition op)))
 
1590
 
 
1591
(defun parse-condition (op)
 
1592
  (list* (parse (rpos op) (rbp op))
 
1593
         (if (eq (first-c) '$then)
 
1594
             (parse '$any (rbp (pop-c)))
 
1595
             (mread-synerr "Missing `then'"))
 
1596
         (case (first-c)
 
1597
           (($else)   (list t (parse '$any (rbp (pop-c)))))
 
1598
           (($elseif) (parse-condition (pop-c)))
 
1599
           (t ; Note: $false instead of () makes DISPLA suppress display!
 
1600
            (list t '$false)))))
 
1601
 
 
1602
(def-mheader $do (mdo))
 
1603
 
 
1604
(defun parse-$do (lex &aux (left (make-mdo)))
 
1605
  (setf (car left) (mheader 'mdo))
 
1606
  (do ((op lex (pop-c))  (active-bitmask 0))
 
1607
      (nil)
 
1608
    (if (eq op '|$:|) (setq op '$from))
 
1609
    (setq active-bitmask (collision-check '$do active-bitmask op))
 
1610
    (let ((data (parse (rpos op) (rbp op))))
 
1611
      (case op
 
1612
        ($do            (setf (mdo-body left) data) (return (cons '$any left)))
 
1613
        ($for           (setf (mdo-for  left) data))
 
1614
        ($from          (setf (mdo-from left) data))
 
1615
        ($in            (setf (mdo-op   left) 'mdoin)
 
1616
                        (setf (mdo-from left) data))
 
1617
        ($step          (setf (mdo-step left) data))
 
1618
        ($next          (setf (mdo-next left) data))
 
1619
        ($thru          (setf (mdo-thru left) data))
 
1620
        (($unless $while)
 
1621
                        (if (eq op '$while)
 
1622
                            (setq data (list (mheader '$not) data)))
 
1623
                        (setf (mdo-unless left)
 
1624
                           (if (null (mdo-unless left))
 
1625
                               data
 
1626
                               (list (mheader '$or) data (mdo-unless left)))))
 
1627
        (t (parse-bug-err '$do))))))
 
1628
 
 
1629
(def-lbp $for    25.)
 
1630
(def-lbp $from   25.)
 
1631
(def-lbp $step   25.)
 
1632
(def-lbp $next   25.)
 
1633
(def-lbp $thru   25.)
 
1634
(def-lbp $unless 25.)
 
1635
(def-lbp $while  25.)
 
1636
(def-lbp $do     25.)
 
1637
 
 
1638
(def-nud-equiv $for    parse-$do)
 
1639
(def-nud-equiv $from   parse-$do)
 
1640
(def-nud-equiv $step   parse-$do)
 
1641
(def-nud-equiv $next   parse-$do)
 
1642
(def-nud-equiv $thru   parse-$do)
 
1643
(def-nud-equiv $unless parse-$do)
 
1644
(def-nud-equiv $while  parse-$do)
 
1645
(def-nud-equiv $do     parse-$do)
 
1646
 
 
1647
(def-rbp $do      25.)
 
1648
(def-rbp $for    200.)
 
1649
(def-rbp $from    95.)
 
1650
(def-rbp $in      95.)
 
1651
(def-rbp $step    95.)
 
1652
(def-rbp $next    45.)
 
1653
(def-rbp $thru    95.)
 
1654
(def-rbp $unless  45.)
 
1655
(def-rbp $while   45.)
 
1656
 
 
1657
(def-rpos $do     $any)
 
1658
(def-rpos $for    $any)
 
1659
(def-rpos $from   $any)
 
1660
(def-rpos $step   $expr)
 
1661
(def-rpos $next   $any)
 
1662
(def-rpos $thru   $expr)
 
1663
(def-rpos $unless $clause)
 
1664
(def-rpos $while  $clause)
 
1665
 
 
1666
 
 
1667
(def-collisions $do
 
1668
  ($do     . ())
 
1669
  ($for    . ($for))
 
1670
  ($from   . ($in $from))
 
1671
  ($in     . ($in $from $step $next))
 
1672
  ($step   . ($in       $step $next))
 
1673
  ($next   . ($in       $step $next))
 
1674
  ($thru   . ($in $thru)) ;$IN didn't used to get checked for
 
1675
  ($unless . ())
 
1676
  ($while  . ()))
 
1677
 
 
1678
;#+ti  ;;because of a bug the preceding doesn't give this..
 
1679
;(defprop $do (($WHILE . 256) ($UNLESS . 128)
 
1680
;                ($THRU . 64)
 
1681
;                ($NEXT . 32)
 
1682
;                ($STEP . 16)
 
1683
;                ($IN . 8)
 
1684
;                ($FROM . 4)
 
1685
;                ($FOR . 2)
 
1686
;                ($DO . 1)) keys)
 
1687
 
 
1688
 
 
1689
(def-mheader   |$$| (nodisplayinput))
 
1690
(def-nud-equiv |$$| premterm-err)
 
1691
(def-lbp       |$$| -1)
 
1692
;No RBP, POS, RPOS, RBP, or MHEADER
 
1693
 
 
1694
(def-mheader   |$;| (displayinput))
 
1695
(def-nud-equiv |$;| premterm-err)
 
1696
(def-lbp       |$;| -1)
 
1697
;No RBP, POS, RPOS, RBP, or MHEADER
 
1698
 
 
1699
(def-nud-equiv  |$&&| delim-err)
 
1700
(def-lbp        |$&&| -1)
 
1701
 
 
1702
(defun mopstrip (x)
1713
1703
  ;; kludge interface function to allow the use of lisp PRINC in places.
1714
 
  (COND ((NULL X) 'FALSE)
1715
 
        ((OR (EQ X T) (EQ X 'T)) 'TRUE)
1716
 
        ((NUMBERP X) X)
1717
 
        ((SYMBOLP X)
1718
 
         (OR (GET X 'REVERSEALIAS)
1719
 
             (IF (IMEMBER (FIRSTCHARN X) '(#\$ #\% #\&))
1720
 
                 (IMPLODE (CDR (EXPLODEN X)))
1721
 
                 X)))
1722
 
        (T (MAKNAM (MSTRING X)))))
 
1704
  (cond ((null x) 'false)
 
1705
        ((or (eq x t) (eq x 't)) 'true)
 
1706
        ((numberp x) x)
 
1707
        ((symbolp x)
 
1708
         (or (get x 'reversealias)
 
1709
             (if (imember (firstcharn x) '(#\$ #\% #\&))
 
1710
                 (implode (cdr (exploden x)))
 
1711
                 x)))
 
1712
        (t (maknam (mstring x)))))
1723
1713
        
1724
 
 
1725
 
(DEFINE-INITIAL-SYMBOLS
 
1714
(define-initial-symbols
1726
1715
  ;; * Note: /. is looked for explicitly rather than
1727
1716
  ;;     existing in this chart. The reason is that
1728
1717
  ;;     it serves a dual role (as a decimal point) and
1738
1727
  ;; Three character
1739
1728
  |::=|
1740
1729
  )
1741
 
 
 
1730
 
1742
1731
;;; User extensibility:
1743
 
(defmacro upcase (operator)
1744
 
 `(setq operator (intern (string-upcase (string ,operator)))))
1745
 
 
1746
 
(DEFMFUN $PREFIX (OPERATOR &OPTIONAL (RBP  180.)
1747
 
                                     (RPOS '$ANY)
1748
 
                                     (POS  '$ANY))
1749
 
         (upcase operator)
1750
 
  (DEF-OPERATOR OPERATOR POS ()  ()     RBP RPOS () T
1751
 
    '(NUD . PARSE-PREFIX) 'MSIZE-PREFIX 'DIMENSION-PREFIX ()   ))
1752
 
 
1753
 
(DEFMFUN $POSTFIX (OPERATOR &OPTIONAL (LBP  180.)
1754
 
                                     (LPOS '$ANY)
1755
 
                                     (POS  '$ANY))
1756
 
                 (upcase operator)
1757
 
  (DEF-OPERATOR OPERATOR POS LBP LPOS   ()  ()   T  ()
1758
 
    '(LED . PARSE-POSTFIX) 'MSIZE-POSTFIX 'DIMENSION-POSTFIX  ()   ))
1759
 
 
1760
 
(DEFMFUN $INFIX  (OPERATOR &OPTIONAL (LBP  180.)
1761
 
                                     (RBP  180.)
1762
 
                                     (LPOS '$ANY)
1763
 
                                     (RPOS '$ANY)
1764
 
                                     (POS  '$ANY))
1765
 
                 (upcase operator)
1766
 
  (DEF-OPERATOR OPERATOR POS LBP LPOS   RBP RPOS T T
1767
 
    '(LED . PARSE-INFIX) 'MSIZE-INFIX 'DIMENSION-INFIX () ))
1768
 
 
1769
 
(DEFMFUN $NARY   (OPERATOR &OPTIONAL (BP     180.)
1770
 
                                     (ARGPOS '$ANY)
1771
 
                                     (POS    '$ANY))
1772
 
                 (upcase operator)
1773
 
  (DEF-OPERATOR OPERATOR POS BP  ARGPOS BP  ()   T T
1774
 
    '(LED . PARSE-NARY) 'MSIZE-NARY 'DIMENSION-NARY () ))
1775
 
 
1776
 
(DEFMFUN $MATCHFIX (OPERATOR
1777
 
                    MATCH  &OPTIONAL (ARGPOS '$ANY)
1778
 
                                     (POS    '$ANY))
 
1732
(defmfun $prefix (operator &optional (rbp  180.)
 
1733
                                     (rpos '$any)
 
1734
                                     (pos  '$any))
 
1735
  (def-operator operator pos ()  ()     rbp rpos () t
 
1736
                '(nud . parse-prefix) 'msize-prefix 'dimension-prefix ()   )
 
1737
  operator)
 
1738
 
 
1739
(defmfun $postfix (operator &optional (lbp  180.)
 
1740
                                     (lpos '$any)
 
1741
                                     (pos  '$any))
 
1742
  (def-operator operator pos lbp lpos   ()  ()   t  ()
 
1743
                '(led . parse-postfix) 'msize-postfix 'dimension-postfix  ()   )
 
1744
  operator)
 
1745
 
 
1746
(defmfun $infix  (operator &optional (lbp  180.)
 
1747
                                     (rbp  180.)
 
1748
                                     (lpos '$any)
 
1749
                                     (rpos '$any)
 
1750
                                     (pos  '$any))
 
1751
  (def-operator operator pos lbp lpos   rbp rpos t t
 
1752
                '(led . parse-infix) 'msize-infix 'dimension-infix () )
 
1753
  operator)
 
1754
 
 
1755
(defmfun $nary   (operator &optional (bp     180.)
 
1756
                                     (argpos '$any)
 
1757
                                     (pos    '$any))
 
1758
  (def-operator operator pos bp  argpos bp  ()   t t
 
1759
                '(led . parse-nary) 'msize-nary 'dimension-nary () )
 
1760
  operator)
 
1761
 
 
1762
(defmfun $matchfix (operator
 
1763
                    match  &optional (argpos '$any)
 
1764
                                     (pos    '$any))
1779
1765
  ;shouldn't MATCH be optional?
1780
 
                 (upcase operator)
1781
 
  (DEF-OPERATOR OPERATOR POS ()  ARGPOS ()  ()  () () 
1782
 
    '(NUD . PARSE-MATCHFIX) 'MSIZE-MATCHFIX 'DIMENSION-MATCH MATCH))
1783
 
 
1784
 
(DEFMFUN $NOFIX  (OPERATOR &OPTIONAL (POS '$ANY))
1785
 
                 (upcase operator)
1786
 
  (DEF-OPERATOR OPERATOR POS ()  ()     ()  () () ()
1787
 
    '(NUD . PARSE-NOFIX) 'MSIZE-NOFIX 'DIMENSION-NOFIX ()   ))
1788
 
 
1789
 
 
 
1766
  (def-operator operator pos ()  argpos ()  ()  () () 
 
1767
                '(nud . parse-matchfix) 'msize-matchfix 'dimension-match match)
 
1768
  operator)
 
1769
 
 
1770
(defmfun $nofix  (operator &optional (pos '$any))
 
1771
  (def-operator operator pos ()  ()     ()  () () ()
 
1772
                '(nud . parse-nofix) 'msize-nofix 'dimension-nofix ()   )
 
1773
  operator)
 
1774
 
1790
1775
;;; (DEF-OPERATOR op pos lbp lpos rbp rpos sp1 sp2 
1791
1776
;;;     parse-data grind-fn dim-fn match)
1792
1777
;;; OP        is the operator name.
1808
1793
;;; For more complete descriptions of these naming conventions, see
1809
1794
;;; the comments in GRAM package, which describe them in reasonable detail.
1810
1795
 
1811
 
(DEFUN DEF-OPERATOR (OP POS LBP LPOS RBP RPOS SP1 SP2
1812
 
                        PARSE-DATA GRIND-FN DIM-FN MATCH)
1813
 
  (LET ((X))
1814
 
    (IF (OR (AND RBP (NOT (INTEGERP (SETQ X RBP))))
1815
 
            (AND LBP (NOT (INTEGERP (SETQ X LBP)))))
1816
 
        (MERROR "Binding powers must be integers.~%~M is not an integer." X))
1817
 
    (IF (MSTRINGP OP) (SETQ OP (DEFINE-SYMBOL OP)))
1818
 
    (OP-SETUP OP)
1819
 
    (LET ((NOUN   ($NOUNIFY OP))
1820
 
          (DISSYM (CDR (EXPLODEN OP))))
 
1796
(defun def-operator (op pos lbp lpos rbp rpos sp1 sp2
 
1797
                        parse-data grind-fn dim-fn match)
 
1798
  (let ((x))
 
1799
    (if (or (and rbp (not (integerp (setq x rbp))))
 
1800
            (and lbp (not (integerp (setq x lbp)))))
 
1801
        (merror "Binding powers must be integers.~%~M is not an integer." x))
 
1802
    (if (mstringp op) (setq op (define-symbol op)))
 
1803
    (op-setup op)
 
1804
    (let ((noun   ($nounify op))
 
1805
          (dissym (cdr (exploden op))))
1821
1806
      (cond
1822
 
       ((NOT MATCH)
1823
 
        (SETQ DISSYM (APPEND (IF SP1 '(#\Space)) DISSYM (IF SP2 '(#\Space)))))
1824
 
       (t (IF (MSTRINGP MATCH) (SETQ MATCH (DEFINE-SYMBOL MATCH)))
1825
 
          (OP-SETUP MATCH)
1826
 
          (PUTPROP OP    MATCH 'MATCH)
1827
 
          (PUTPROP MATCH 5.    'LBP)
1828
 
          (SETQ DISSYM (CONS DISSYM (CDR (EXPLODEN MATCH))))))
1829
 
      (PUTPROP OP POS 'POS)
1830
 
      (PUTPROP OP (CDR PARSE-DATA) (CAR PARSE-DATA))
1831
 
      (PUTPROP OP   GRIND-FN  'GRIND)
1832
 
      (PUTPROP OP   DIM-FN    'DIMENSION)
1833
 
      (PUTPROP NOUN DIM-FN    'DIMENSION)
1834
 
      (PUTPROP OP   DISSYM 'DISSYM)
1835
 
      (PUTPROP NOUN DISSYM 'DISSYM)
1836
 
      (WHEN RBP
1837
 
        (PUTPROP OP   RBP  'RBP)
1838
 
        (PUTPROP NOUN RBP  'RBP))
1839
 
      (WHEN LBP
1840
 
        (PUTPROP OP   LBP  'LBP)
1841
 
        (PUTPROP NOUN LBP  'LBP))
1842
 
      (WHEN LPOS (PUTPROP OP   LPOS 'LPOS))
1843
 
      (WHEN RPOS (PUTPROP OP   RPOS 'RPOS))
1844
 
      (GETOPR OP))))
 
1807
       ((not match)
 
1808
        (setq dissym (append (if sp1 '(#\space)) dissym (if sp2 '(#\space)))))
 
1809
       (t (if (mstringp match) (setq match (define-symbol match)))
 
1810
          (op-setup match)
 
1811
          (putprop op    match 'match)
 
1812
          (putprop match 5.    'lbp)
 
1813
          (setq dissym (cons dissym (cdr (exploden match))))))
 
1814
      (putprop op pos 'pos)
 
1815
      (putprop op (cdr parse-data) (car parse-data))
 
1816
      (putprop op   grind-fn  'grind)
 
1817
      (putprop op   dim-fn    'dimension)
 
1818
      (putprop noun dim-fn    'dimension)
 
1819
      (putprop op   dissym 'dissym)
 
1820
      (putprop noun dissym 'dissym)
 
1821
      (when rbp
 
1822
        (putprop op   rbp  'rbp)
 
1823
        (putprop noun rbp  'rbp))
 
1824
      (when lbp
 
1825
        (putprop op   lbp  'lbp)
 
1826
        (putprop noun lbp  'lbp))
 
1827
      (when lpos (putprop op   lpos 'lpos))
 
1828
      (when rpos (putprop op   rpos 'rpos))
 
1829
      (getopr op))))
1845
1830
 
1846
 
(DEFUN OP-SETUP (OP)
 
1831
(defun op-setup (op)
1847
1832
  (declare (special mopl))
1848
 
  (LET ((DUMMY (OR (GET OP 'OP)
1849
 
                   (IMPLODE (CONS '& (STRING* OP))))))
1850
 
    (PUTPROP OP    DUMMY 'OP )
1851
 
    (PUTPROP DUMMY OP    'OPR)
1852
 
    (IF (AND (OPERATORP1 OP) (NOT (MEMQ DUMMY (CDR $PROPS))))
1853
 
        (PUSH DUMMY MOPL))
1854
 
    (ADD2LNC DUMMY $PROPS)))
 
1833
  (let ((dummy (or (get op 'op)
 
1834
                   (implode (cons '& (string* op))))))
 
1835
    (putprop op    dummy 'op )
 
1836
    (putprop dummy op    'opr)
 
1837
    (if (and (operatorp1 op) (not (memq dummy (cdr $props))))
 
1838
        (push dummy mopl))
 
1839
    (add2lnc dummy $props)))
1855
1840
 
1856
 
(DEFUN KILL-OPERATOR (OP)
1857
 
  (UNDEFINE-SYMBOL (STRIPDOLLAR OP))
1858
 
  (LET ((OPR (GET OP 'OP)) (NOUN-FORM ($NOUNIFY OP)))
1859
 
    (REMPROP OPR 'OPR)
1860
 
    (REMPROPCHK OPR)
1861
 
    (MAPC #'(LAMBDA (X) (REMPROP OP X))
1862
 
          '(NUD-EXPR NUD-SUBR                   ; NUD info
1863
 
                     LED LED-EXPR LED-SUBR              ; LED info
1864
 
                     LBP RBP                    ; Binding power info
1865
 
                     LPOS RPOS POS              ; Part-Of-Speech info
1866
 
                     GRIND DIMENSION DISSYM     ; Display info
1867
 
                     OP
 
1841
(defun kill-operator (op)
 
1842
  (undefine-symbol (stripdollar op))
 
1843
  (let ((opr (get op 'op)) (noun-form ($nounify op)))
 
1844
    (remprop opr 'opr)
 
1845
    (rempropchk opr)
 
1846
    (mapc #'(lambda (x) (remprop op x))
 
1847
          '(nud nud-expr nud-subr                       ; NUD info
 
1848
                     led led-expr led-subr              ; LED info
 
1849
                     lbp rbp                    ; Binding power info
 
1850
                     lpos rpos pos              ; Part-Of-Speech info
 
1851
                     grind dimension dissym     ; Display info
 
1852
                     op
1868
1853
                     ))                 ; Operator info
1869
 
    (MAPC #'(LAMBDA (X) (REMPROP NOUN-FORM X))
1870
 
          '(DIMENSION DISSYM LBP RBP))))
 
1854
    (mapc #'(lambda (x) (remprop noun-form x))
 
1855
          '(dimension dissym lbp rbp))))
1871
1856
 
1872
1857
 
1873
1858
 
1878
1863
 
1879
1864
 
1880
1865
#-gcl
1881
 
(eval-when (compile eval load)
1882
 
 
1883
 
(defvar *stream-alist* nil)
1884
 
 
1885
 
(defun stream-name (path)
1886
 
  (let ((tem (errset (namestring (pathname path)))))
1887
 
    (car tem)))
1888
 
 
1889
 
(defun instream-name (instr)
1890
 
  (or (instream-stream-name instr)
1891
 
      (stream-name (instream-stream instr))))
1892
 
 
1893
 
(defstruct instream
1894
 
  stream
1895
 
  (line 0 :type fixnum)
1896
 
  stream-name)
1897
 
 
1898
 
;; (closedp stream) checks if a stream is closed.. how to do this in common
1899
 
;; lisp!!
1900
 
 
1901
 
(defun cleanup ()
1902
 
  #+never-clean-up-dont-know-how-to-close
1903
 
  (dolist (v *stream-alist*)
1904
 
    (if (closedp (instream-stream v))
1905
 
        (setq *stream-alist* (delete v *stream-alist*)))))
1906
 
 
1907
 
(defun get-instream (str)
1908
 
  (or (dolist (v *stream-alist*)
1909
 
        (cond ((eq str (instream-stream v))
1910
 
               (return v))))
1911
 
      (let (name errset)
1912
 
        (errset (setq name (namestring str)))
1913
 
      (car (setq *stream-alist*
1914
 
                 (cons  (make-instream :stream str :stream-name name) *stream-alist*))))))
1915
 
 
1916
 
 
1917
 
 
1918
 
(defun newline (str ch) ch
1919
 
  (let ((in (get-instream str)))
1920
 
    (setf (instream-line in) (the fixnum (+ 1 (instream-line in)))))
1921
 
  ;; if the next line begins with '(', then record all cons's eg arglist )
1922
 
  ;(setq *at-newline*  (if (eql (peek-char nil str nil) #\() :all t))
1923
 
  (values))
1924
 
 
1925
 
) ; end #-gcl
 
1866
(eval-when (:compile-toplevel :execute :load-toplevel)
 
1867
 
 
1868
  (defvar *stream-alist* nil)
 
1869
 
 
1870
  (defun stream-name (path)
 
1871
    (let ((tem (errset (namestring (pathname path)))))
 
1872
      (car tem)))
 
1873
 
 
1874
  (defun instream-name (instr)
 
1875
    (or (instream-stream-name instr)
 
1876
        (stream-name (instream-stream instr))))
 
1877
 
 
1878
  (defstruct instream
 
1879
    stream
 
1880
    (line 0 :type fixnum)
 
1881
    stream-name)
 
1882
 
 
1883
;; (closedp stream) checks if a stream is closed.
 
1884
;; how to do this in common lisp!!
 
1885
 
 
1886
  (defun cleanup ()
 
1887
    #+never-clean-up-dont-know-how-to-close
 
1888
    (dolist (v *stream-alist*)
 
1889
      (if (closedp (instream-stream v))
 
1890
          (setq *stream-alist* (delete v *stream-alist*)))))
 
1891
 
 
1892
  (defun get-instream (str)
 
1893
    (or (dolist (v *stream-alist*)
 
1894
          (cond ((eq str (instream-stream v))
 
1895
                 (return v))))
 
1896
        (let (name errset)
 
1897
          (errset (setq name (namestring str)))
 
1898
          (car (setq *stream-alist*
 
1899
                     (cons  (make-instream :stream str :stream-name name)
 
1900
                            *stream-alist*))))))
 
1901
 
 
1902
 
 
1903
 
 
1904
  (defun newline (str ch) ch
 
1905
         (let ((in (get-instream str)))
 
1906
           (setf (instream-line in) (the fixnum (+ 1 (instream-line in)))))
 
1907
        ;; if the next line begins with '(',
 
1908
        ;; then record all cons's eg arglist )
 
1909
        ;;(setq *at-newline*  (if (eql (peek-char nil str nil) #\() :all t))
 
1910
         (values)))                                     ; end #-gcl
 
1911
 
 
1912
#+gcl
 
1913
(deff newline (symbol-function 'si::newline))
1926
1914
 
1927
1915
(defun find-stream (stream)
1928
1916
   (dolist (v *stream-alist*)