2 ;;;; I suggest you move along to another file,
3 ;;;; this one is terribly coded and in constant change.
4 ;;;; But if you care to look around - good luck.
6 ;;;; Heavily commented so I remember what happens here.
9 ; An ordered stack of operations is build up as closures,
10 ; each hold an accumulated value. When an operator of lesser
11 ; "rank" (see rank constants below) is encountered, the stack unwinds
12 ; recursively, passing the encountered rank and the accumulated
13 ; value for the operation.
15 ; Obviously there are different scopes where these operations apply,
16 ; namely "paren" and "function" scopes. Both scopes have their own
17 ; "read-eval" loop which terminate by the usual stack unwind and
18 ; a thrown symbol corresponding to the scope:
19 ; 'break-paren scope and 'break-fn-scope
21 ; The order of events and the way the termination is handled
22 ; is DIFFERENT between the two. Function scope is notably more
23 ; complex because I don't require ONE function parameter to be
24 ; enclosed in parentheses, multiple parameters require them.
26 ;;; Define variables as constant integers
27 (defmacro enumerate-constants
(&rest syms
&aux
(v 0))
33 (setf (values k v
) (values-list k
)))
34 (prog1 `(defconstant ,k
,v
)
38 ;V Set precedence ranks.V
50 +vip-rank
+);< Virtually infinite precedence.
53 (defun multn-if-last-read ()
54 (declare (special *last-read
*))
56 ;; Implicit multiplication, two
57 ;; values were seperated by a space.
59 (parsed-opern +multn-rank
+ 'multn
))))
61 ;;; See if /parsed-thing/ can be interpreted
62 ;;; in any way. If so, call success-fn, then
63 ;;; finish interpreting.
64 (defun interpret-parsed
65 (parsed-thing &optional
(success-fn #'values
))
66 (declare (special *last-read
*))
67 (multn-if-last-read);< Check for implied multiplication.
68 (if (symbolp parsed-thing
)
69 (when (boundp parsed-thing
)
70 (let ((val (symbol-value parsed-thing
)))
73 ;; A symbol representing a function
74 ;; was read, change scope.
75 (parse-function-scope val
) ;(symbol-function val)
76 (setq *last-read
* parsed-thing
))))
78 ;; The reader thinks it's something other
79 ;; than a symbol, parser doesn't need to worry.
81 (setq *last-read
* parsed-thing
))))
83 ;;; An invalid symbol was read,
84 ;;; could be something like "34x"
85 (defun parse-compact (&optional sym
&aux arrlen
)
86 (declare (special *parse-next
* *last-read
*))
88 ;; Must create *parse-next* from a symbol
89 (let ((sym-str (symbol-name sym
)))
90 (setq arrlen
(length sym-str
)
93 :element-type
'character
94 :fill-pointer
(1- arrlen
)
95 :displaced-to sym-str
)))
96 (setq arrlen
(length *parse-next
*)))
98 :for index
:from
(fill-pointer *parse-next
*) :downto
1
101 (setf (fill-pointer *parse-next
*) index
)
103 (let ((*package
* (find-package :lineal.client-vars
)))
104 (read-from-string *parse-next
*))
106 ;; We found valid input.
109 (setf *parse-next
* nil
)
111 (fill-pointer *parse-next
*) arrlen
113 (make-array (- arrlen index
)
114 :element-type
'character
116 :displaced-to
*parse-next
*
117 :displaced-index-offset index
)))))
118 (when successp
(return)))
120 ;; Nothing matched; quit trying.
121 (setf (fill-pointer *parse-next
*) arrlen
)
122 (signal 'unbound-variable
:name
*parse-next
*)))
125 ;;; Everything in the file calls this
126 ;;; read function on the infix stream.
127 (defun read-next-infix ()
128 (declare (special *unwind-rank-fn
* *last-read
*
129 *parse-strm
* *parse-next
*))
130 (if *parse-next
* (parse-compact)
133 (let ((*package
* (find-package
134 :lineal.client-vars
)))
135 ;; Sometimes an exception is thrown and
136 ;; control breaks to the current "read loop"
137 (setq this-read
(read *parse-strm
*)))
139 ;; Did not just read an operator.
143 (lambda () (setf successp t
)))
145 ;; We have no idea wtf was just read.
146 (parse-compact this-read
)))
149 (declare (ignore condit
))
150 ;; Don't check for unclosed parentheses,
152 (funcall *unwind-rank-fn
*
153 +base-rank
+ *last-read
*)))))
155 ;;; This is a generic construct for a closure
156 ;;; which will be stored as *unwind-rank-fn*
157 (defmacro opern-climber-lambda
158 ((this-rank op-rank val
) . body
)
159 `(lambda (,op-rank
,val
)
161 ;; A prefixed operator (see function below)
162 ;; was parsed last, unary-pre-opern.
164 ,this-rank
(the function
,op-rank
)))
166 (declare (type (integer 0 ,+vip-rank
+) ,op-rank
))
169 ;;; When something like 2 + -3 is encountered,
170 ;;; the negative is what this function deals with.
171 (defun unary-pre-opern (prev-rank this-op-fn
)
172 (declare (special *unwind-rank-fn
*))
173 (let ((prev-unwind-rank-fn *unwind-rank-fn
*)
177 (opern-climber-lambda
178 (prev-rank op-rank val
)
179 (if (and (< prev-rank op-rank
)
180 (< +multn-rank
+ op-rank
))
181 (progn (setq *unwind-rank-fn
*
184 (funcall prev-unwind-rank-fn op-rank
185 (list this-op-fn val
))))
186 *unwind-rank-fn
* this-unwind-rank-fn
)
187 (throw 'fn-scope
(values))))
189 ;;; A binary operator is parsed.
190 (defun parsed-opern (this-rank this-op-fn
)
191 (declare (special *unwind-rank-fn
* *last-read
*))
193 (funcall *unwind-rank-fn
* this-op-fn nil
))
194 (let* ((args (cons (funcall *unwind-rank-fn
*
195 this-rank
*last-read
*)
198 (prev-unwind-rank-fn *unwind-rank-fn
*)
203 (opern-climber-lambda
204 (this-rank op-rank val
)
206 ((= this-rank op-rank
)
208 *unwind-rank-fn
* this-unwind-rank-fn
210 tail
(setf (cdr tail
) (cons val nil
)))
211 (throw 'fn-scope
(values)))
212 ((< this-rank op-rank
)
213 (setq *unwind-rank-fn
* this-unwind-rank-fn
)
216 (rplacd tail
(cons val nil
))
217 (funcall prev-unwind-rank-fn op-rank
218 (cons this-op-fn args
)))))
219 *unwind-rank-fn
* this-unwind-rank-fn
)
222 ;;; Parse an exclaimation point character.
223 (defun factorial-reader (c strm
)
224 (declare (ignore c strm
)
225 (special *unwind-rank-fn
* *last-read
*))
227 ;; Make sure any negatives are applied.
228 (funcall *unwind-rank-fn
*
229 'lineal.overload
::over-factorial nil
))
231 (list 'lineal.overload
::factorial
232 (funcall *unwind-rank-fn
*
233 +factorial-rank
+ *last-read
*)))
236 ;;; Specialized function to gobble whitespace
237 ;;; and return true if the terminating char
238 ;;; is an opening parenthesis.
239 (defun open-paren-after-whitespace-peekp ()
240 (declare (special *parse-strm
* *parse-next
*))
242 (do () ((not (char= #\Space
(peek-char nil
*parse-strm
*)))
243 (char= #\
( (peek-char nil
*parse-strm
*)))
244 (read-char *parse-strm
*))))
246 (defun closed-paren-peekp ()
247 (declare (special *parse-strm
* *parse-next
*))
249 (char= #\
) (peek-char nil
*parse-strm
*))))
251 ;;; A function was read, passed as /this-fn/,
252 ;;; its arguments have yet to be parsed.
253 (defun parse-function-scope (this-fn)
254 (declare (special *unwind-rank-fn
* *last-read
* *parse-strm
*))
255 (when (open-paren-after-whitespace-peekp)
256 ;; User chose to enclose the
257 ;; argument(s) in parentheses.
258 (read-char *parse-strm
*)
261 (if (consp *last-read
*)
262 ;V (apply this-fn *last-read*) V
263 (cons this-fn
*last-read
*)
264 ;V (funcall this-fn *last-read*) V
265 (list this-fn
*last-read
*)))
266 (return-from parse-function-scope
(values)))
267 (when (closed-paren-peekp)
268 ;; Using notation like (f*g)(x)
270 (setq *last-read
* this-fn
)
271 (return-from parse-function-scope
(values)))
272 (let ((prev-unwind-rank-fn *unwind-rank-fn
*)
277 (opern-climber-lambda
278 (+fn-rank
+ op-rank val
)
280 ((< op-rank
+fn-rank
+)
281 ;; Breaking from parens or program.
282 (funcall prev-unwind-rank-fn
283 op-rank
(if (consp val
)
285 (list this-fn val
))))
286 ((= op-rank
+fn-rank
+)
287 ;; Return from the function scope.
288 (setq *unwind-rank-fn
* prev-unwind-rank-fn
289 *last-read
* (if (consp val
)
292 (throw 'break-fn-scope
(values)))
293 (t ;V Stay in the function scope.V
294 (setq *unwind-rank-fn
* this-unwind-rank-fn
)
296 *unwind-rank-fn
* this-unwind-rank-fn
)
302 (funcall *unwind-rank-fn
*
303 +fn-rank
+ *last-read
*)))
305 ;;; "read-eval" loop used by process-infix-from-stream
306 ;;; and open-paren-reader
307 (defun parse-infix ()
308 (declare (special *unwind-rank-fn
* *last-read
*))
309 (let ((prev-unwind-rank-fn *unwind-rank-fn
*)
314 (opern-climber-lambda
315 (+paren-rank
+ op-rank val
)
317 ((< op-rank
+paren-rank
+)
318 (funcall prev-unwind-rank-fn
320 ((= op-rank
+paren-rank
+)
321 ;; Closing paren encountered.
322 (setq *unwind-rank-fn
* prev-unwind-rank-fn
324 (throw 'break-paren-scope
(values)))
326 (setq *unwind-rank-fn
* this-unwind-rank-fn
)
328 *unwind-rank-fn
* this-unwind-rank-fn
)
334 (read-next-infix))))))
336 (defun paren-scope (paramsp)
337 (declare (special *last-read
*))
339 (catch 'break-paren-scope
341 (when (and (not paramsp
) (consp *last-read
*))
342 ;; Convert the list into a tuple
343 ;; since it's not a function's parameters.
345 (cons 'lineal.overload
::over-vcat
*last-read
*))))
347 ;;; A parenthesis has been opened!
348 (defun open-paren-reader (strm ch
)
349 (declare (ignore strm ch
))
353 ;;; Unwind the operation stack.
354 ;;; When the paren closure is reached,
355 ;;; *last-read* is set to the value calculated within
356 ;;; the parenthesis and 'break-paren-scope is thrown.
357 (defun close-paren-reader (strm ch
)
358 (declare (ignore strm ch
)
359 (special *unwind-rank-fn
* *last-read
*))
360 (funcall *unwind-rank-fn
*
361 +paren-rank
+ *last-read
*))
363 ;;; Much like open-paren-reader
364 ;;; but creates a row matrix.
365 ;;; (uses close-paren-reader
366 ;;; for closed brackets)
367 (defun open-bracket-reader (strm ch
)
368 (declare (ignore strm ch
)
369 (special *last-read
*))
371 (catch 'break-paren-scope
373 (when (consp *last-read
*)
375 (cons 'lineal.overload
::over-cat
*last-read
*)))
378 ;;; If *last-read* is nil, an operator
379 ;;; was read last, we can't logically
380 ;;; break from a function in that case.
381 (defun space-reader (strm ch
)
382 (declare (ignore strm ch
)
383 (special *last-read
*))
385 (throw 'break-fn-scope
(values))))
387 (defun comma-reader (strm ch
)
388 (declare (ignore strm ch
)
389 (special *unwind-rank-fn
* *last-read
*))
390 (let* ((lis (cons (funcall *unwind-rank-fn
*
391 +comma-rank
+ *last-read
*)
394 (prev-unwind-rank-fn *unwind-rank-fn
*)
399 (opern-climber-lambda
400 (+comma-rank
+ op-rank val
)
402 ((= +comma-rank
+ op-rank
)
408 (cdr (rplacd tail
(cons val nil
))))
409 (throw 'break-fn-scope
(values)))
410 ((< +comma-rank
+ op-rank
)
411 ;todo: figure out what this does
412 (setq *unwind-rank-fn
*
415 (t (rplacd tail
(cons val nil
))
416 (funcall prev-unwind-rank-fn op-rank
418 *unwind-rank-fn
* this-unwind-rank-fn
)
421 (defun set-opern-reader (ch this-rank this-op-fn
)
425 (declare (ignore strm ch
))
426 (parsed-opern this-rank this-op-fn
))))
428 (defparameter *infix-readtable
* (copy-readtable))
430 (let ((*readtable
* *infix-readtable
*))
431 (setf (readtable-case *readtable
*) :preserve
)
432 (set-macro-character #\
( #'open-paren-reader
)
433 (set-macro-character #\
) #'close-paren-reader
)
434 (set-macro-character #\
[ #'open-bracket-reader
)
435 (set-macro-character #\
] #'close-paren-reader
)
436 (set-macro-character #\Space
#'space-reader
)
437 (set-macro-character #\
, #'comma-reader
)
438 (set-opern-reader #\
+ +addn-rank
+ 'addn
)
439 (set-opern-reader #\-
+subtrn-rank
+ 'subtrn
)
440 (set-opern-reader #\
* +multn-rank
+ 'multn
)
441 (set-opern-reader #\
/ +divisn-rank
+ 'divisn
)
442 (set-macro-character #\
! #'factorial-reader
)
443 (set-opern-reader #\^
+exptn-rank
+ 'exptn
))
445 (defun parse-infix-from-stream (strm)
446 (let ((*readtable
* *infix-readtable
*)
447 (*parse-strm
* strm
);< Stream to parse.
448 *parse-next
*;< Temporary buffer if we overparsed.
450 (lambda (op-rank val
)
451 (declare (ignore op-rank
))
452 (throw 'end-result val
)))
455 *parse-strm
* *parse-next
*
456 *unwind-rank-fn
* *last-read
*))
463 (declare (ignore condit
))
465 nil
"Likely too many parens! ~
466 (as if there were such a thing)~%"))
469 (format nil
"I don't understand: ~A~%"
470 (cell-error-name condit
)))
474 nil
"Evaluation flopped, perhaps bad input?~%~
475 Debug info: ~A~%" condit
)))))
477 (defun process-infix-from-stream (strm)
478 (eval-parsed (parse-infix-from-stream strm
)))
480 (defun process-input-from-stream
481 (strm &optional
(infixp t
))
482 (let ((*read-default-float-format
* 'double-float
)
484 (if infixp
(process-infix-from-stream strm
)
485 (process-prefix-from-stream strm
))))
487 (defun process-input-from-string
488 (text &optional
(infixp t
))
489 (with-input-from-string (strm text
)
490 (process-input-from-stream strm infixp
)))