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