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.
76 (symbol-function val
))
77 (setq *last-read
* val
))))
79 ;; The reader thinks it's something other
80 ;; than a symbol, parser doesn't need to worry.
82 (setq *last-read
* parsed-thing
))))
84 ;;; An invalid symbol was read,
85 ;;; could be something like "34x"
86 (defun parse-compact (&optional sym
&aux arrlen
)
87 (declare (special *parse-next
* *last-read
*))
89 ;; Must create *parse-next* from a symbol
90 (let ((sym-str (symbol-name sym
)))
91 (setq arrlen
(length sym-str
)
94 :element-type
'character
95 :fill-pointer
(1- arrlen
)
96 :displaced-to sym-str
)))
97 (setq arrlen
(length *parse-next
*)))
99 :for index
:from
(fill-pointer *parse-next
*) :downto
1
102 (setf (fill-pointer *parse-next
*) index
)
104 (let ((*package
* (find-package :lineal.client-vars
)))
105 (read-from-string *parse-next
*))
107 ;; We found valid input.
110 (setf *parse-next
* nil
)
112 (fill-pointer *parse-next
*) arrlen
114 (make-array (- arrlen index
)
115 :element-type
'character
117 :displaced-to
*parse-next
*
118 :displaced-index-offset index
)))))
119 (when successp
(return)))
121 ;; Nothing matched; quit trying.
122 (setf (fill-pointer *parse-next
*) arrlen
)
123 (signal 'unbound-variable
:name
*parse-next
*)))
126 ;;; Everything in the file calls this
127 ;;; read function on the infix stream.
128 (defun read-next-infix ()
129 (declare (special *unwind-rank-fn
* *last-read
*
130 *parse-strm
* *parse-next
*))
131 (if *parse-next
* (parse-compact)
134 (let ((*package
* (find-package
135 :lineal.client-vars
)))
136 ;; Sometimes an exception is thrown and
137 ;; control breaks to the current "read loop"
138 (setq this-read
(read *parse-strm
*)))
140 ;; Did not just read an operator.
144 (lambda () (setf successp t
)))
146 ;; We have no idea wtf was just read.
147 (parse-compact this-read
)))
150 (declare (ignore condit
))
151 ;; Don't check for unclosed parentheses,
153 (funcall *unwind-rank-fn
*
154 +base-rank
+ *last-read
*)))))
156 ;;; This is a generic construct for a closure
157 ;;; which will be stored as *unwind-rank-fn*
158 (defmacro opern-climber-lambda
159 ((this-rank op-rank val
) . body
)
160 `(lambda (,op-rank
,val
)
162 ;; A prefixed operator (see function below)
163 ;; was parsed last, unary-pre-opern.
165 ,this-rank
(the function
,op-rank
)))
167 (declare (type (integer 0 ,+vip-rank
+) ,op-rank
))
170 ;;; When something like 2 + -3 is encountered,
171 ;;; the negative is what this function deals with.
172 (defun unary-pre-opern (prev-rank this-op-fn
)
173 (declare (special *unwind-rank-fn
*))
174 (let ((prev-unwind-rank-fn *unwind-rank-fn
*)
178 (opern-climber-lambda
179 (prev-rank op-rank val
)
180 (if (and (< prev-rank op-rank
)
181 (< +multn-rank
+ op-rank
))
182 (progn (setq *unwind-rank-fn
*
185 (funcall prev-unwind-rank-fn op-rank
186 (funcall this-op-fn val
))))
187 *unwind-rank-fn
* this-unwind-rank-fn
)
188 (throw 'fn-scope
(values))))
190 ;;; A binary operator is parsed.
191 (defun parsed-opern (this-rank this-op-fn
)
192 (declare (special *unwind-rank-fn
* *last-read
*))
194 (funcall *unwind-rank-fn
* this-op-fn nil
))
195 (let* ((args (cons (funcall *unwind-rank-fn
*
196 this-rank
*last-read
*)
199 (prev-unwind-rank-fn *unwind-rank-fn
*)
204 (opern-climber-lambda
205 (this-rank op-rank val
)
207 ((= this-rank op-rank
)
209 *unwind-rank-fn
* this-unwind-rank-fn
211 tail
(setf (cdr tail
) (cons val nil
)))
212 (throw 'fn-scope
(values)))
213 ((< this-rank op-rank
)
214 (setq *unwind-rank-fn
* this-unwind-rank-fn
)
217 (rplacd tail
(cons val nil
))
218 (funcall prev-unwind-rank-fn op-rank
219 (apply this-op-fn args
)))))
220 *unwind-rank-fn
* this-unwind-rank-fn
)
223 ;;; Parse an exclaimation point character.
224 (defun factorial-reader (c strm
)
225 (declare (ignore c strm
)
226 (special *unwind-rank-fn
* *last-read
*))
228 ;; Make sure any negatives are applied.
229 (funcall *unwind-rank-fn
*
230 #'lineal.overload
::over-factorial nil
))
232 (lineal.overload
::factorial
233 (funcall *unwind-rank-fn
*
234 +factorial-rank
+ *last-read
*)))
237 ;;; Specialized function to gobble whitespace
238 ;;; and return true if the terminating char
239 ;;; is an opening parenthesis.
240 (defun open-paren-after-whitespace-peekp ()
241 (declare (special *parse-strm
* *parse-next
*))
243 (do () ((not (char= #\Space
(peek-char nil
*parse-strm
*)))
244 (char= #\
( (peek-char nil
*parse-strm
*)))
245 (read-char *parse-strm
*))))
247 (defun closed-paren-peekp ()
248 (declare (special *parse-strm
* *parse-next
*))
250 (char= #\
) (peek-char nil
*parse-strm
*))))
252 ;;; A function was read, passed as /this-fn/,
253 ;;; its arguments have yet to be parsed.
254 (defun parse-function-scope (this-fn)
255 (declare (special *unwind-rank-fn
* *last-read
* *parse-strm
*))
256 (when (open-paren-after-whitespace-peekp)
257 ;; User chose to enclose the
258 ;; argument(s) in parentheses.
259 (read-char *parse-strm
*)
262 (if (consp *last-read
*)
263 (apply this-fn
*last-read
*)
264 (funcall this-fn
*last-read
*)))
265 (return-from parse-function-scope
(values)))
266 (when (closed-paren-peekp)
267 ;; Using notation like (f*g)(x)
269 (setq *last-read
* this-fn
)
270 (return-from parse-function-scope
(values)))
271 (let ((prev-unwind-rank-fn *unwind-rank-fn
*)
276 (opern-climber-lambda
277 (+fn-rank
+ op-rank val
)
279 ((< op-rank
+fn-rank
+)
280 ;; Breaking from parens or program.
281 (funcall prev-unwind-rank-fn
282 op-rank
(if (consp val
)
284 (funcall this-fn val
))))
285 ((= op-rank
+fn-rank
+)
286 ;; Return from the function scope.
287 (setq *unwind-rank-fn
* prev-unwind-rank-fn
288 *last-read
* (if (consp val
)
290 (funcall this-fn val
)))
291 (throw 'break-fn-scope
(values)))
292 (t ;V Stay in the function scope.V
293 (setq *unwind-rank-fn
* this-unwind-rank-fn
)
295 *unwind-rank-fn
* this-unwind-rank-fn
)
301 (funcall *unwind-rank-fn
*
302 +fn-rank
+ *last-read
*)))
304 ;;; "read-eval" loop used by process-infix-from-stream
305 ;;; and open-paren-reader
306 (defun parse-infix ()
307 (declare (special *unwind-rank-fn
* *last-read
*))
308 (let ((prev-unwind-rank-fn *unwind-rank-fn
*)
313 (opern-climber-lambda
314 (+paren-rank
+ op-rank val
)
316 ((< op-rank
+paren-rank
+)
317 (funcall prev-unwind-rank-fn
319 ((= op-rank
+paren-rank
+)
320 ;; Closing paren encountered.
321 (setq *unwind-rank-fn
* prev-unwind-rank-fn
323 (throw 'break-paren-scope
(values)))
325 (setq *unwind-rank-fn
* this-unwind-rank-fn
)
327 *unwind-rank-fn
* this-unwind-rank-fn
)
333 (read-next-infix))))))
335 (defun paren-scope (paramsp)
336 (declare (special *last-read
*))
338 (catch 'break-paren-scope
340 (when (and (not paramsp
) (consp *last-read
*))
341 ;; Convert the list into a tuple
342 ;; since it's not a function's parameters.
344 (lineal.overload
::vcat-list
*last-read
*))))
346 ;;; A parenthesis has been opened!
347 (defun open-paren-reader (strm ch
)
348 (declare (ignore strm ch
))
352 ;;; Unwind the operation stack.
353 ;;; When the paren closure is reached,
354 ;;; *last-read* is set to the value calculated within
355 ;;; the parenthesis and 'break-paren-scope is thrown.
356 (defun close-paren-reader (strm ch
)
357 (declare (ignore strm ch
)
358 (special *unwind-rank-fn
* *last-read
*))
359 (funcall *unwind-rank-fn
*
360 +paren-rank
+ *last-read
*))
362 ;;; Much like open-paren-reader
363 ;;; but creates a row matrix.
364 ;;; (uses close-paren-reader
365 ;;; for closed brackets)
366 (defun open-bracket-reader (strm ch
)
367 (declare (ignore strm ch
)
368 (special *last-read
*))
370 (catch 'break-paren-scope
372 (when (consp *last-read
*)
374 (lineal.overload
::cat-list
*last-read
*)))
377 ;;; If *last-read* is nil, an operator
378 ;;; was read last, we can't logically
379 ;;; break from a function in that case.
380 (defun space-reader (strm ch
)
381 (declare (ignore strm ch
)
382 (special *last-read
*))
384 (throw 'break-fn-scope
(values))))
386 (defun comma-reader (strm ch
)
387 (declare (ignore strm ch
)
388 (special *unwind-rank-fn
* *last-read
*))
389 (let* ((lis (cons (funcall *unwind-rank-fn
*
390 +comma-rank
+ *last-read
*)
393 (prev-unwind-rank-fn *unwind-rank-fn
*)
398 (opern-climber-lambda
399 (+comma-rank
+ op-rank val
)
401 ((= +comma-rank
+ op-rank
)
407 (cdr (rplacd tail
(cons val nil
))))
408 (throw 'break-fn-scope
(values)))
409 ((< +comma-rank
+ op-rank
)
410 ;todo: figure out what this does
411 (setq *unwind-rank-fn
*
414 (t (rplacd tail
(cons val nil
))
415 (funcall prev-unwind-rank-fn op-rank
417 *unwind-rank-fn
* this-unwind-rank-fn
)
420 (defun set-opern-reader (ch this-rank this-op-fn
)
424 (declare (ignore strm ch
))
425 (parsed-opern this-rank this-op-fn
))))
427 (defparameter *infix-readtable
* (copy-readtable))
429 (let ((*readtable
* *infix-readtable
*))
430 (setf (readtable-case *readtable
*) :preserve
)
431 (set-macro-character #\
( #'open-paren-reader
)
432 (set-macro-character #\
) #'close-paren-reader
)
433 (set-macro-character #\
[ #'open-bracket-reader
)
434 (set-macro-character #\
] #'close-paren-reader
)
435 (set-macro-character #\Space
#'space-reader
)
436 (set-macro-character #\
, #'comma-reader
)
437 (set-opern-reader #\
+ +addn-rank
+ #'addn
)
438 (set-opern-reader #\-
+subtrn-rank
+ #'subtrn
)
439 (set-opern-reader #\
* +multn-rank
+ #'multn
)
440 (set-opern-reader #\
/ +divisn-rank
+ #'divisn
)
441 (set-macro-character #\
! #'factorial-reader
)
442 (set-opern-reader #\^
+exptn-rank
+ #'exptn
))
444 (defun process-infix-from-stream (strm)
445 (let ((*readtable
* *infix-readtable
*)
446 (*parse-strm
* strm
);< Stream to parse.
447 *parse-next
*;< Temporary buffer if we overparsed.
449 (lambda (op-rank val
)
450 (declare (ignore op-rank
))
451 (throw 'end-result val
)))
454 *parse-strm
* *parse-next
*
455 *unwind-rank-fn
* *last-read
*))
462 (declare (ignore condit
))
464 nil
"Likely too many parens! ~
465 (as if there were such a thing)~%"))
468 (format nil
"I don't understand: ~A~%"
469 (cell-error-name condit
)))
473 nil
"Evaluation flopped, perhaps bad input?~%~
474 Debug info: ~A~%" condit
)))))
476 (defun process-input-from-stream
477 (strm &optional
(infixp t
))
478 (let ((*read-default-float-format
* 'double-float
)
480 (if infixp
(process-infix-from-stream strm
)
481 (process-prefix-from-stream strm
))))
483 (defun process-input-from-string
484 (text &optional
(infixp t
))
485 (with-input-from-string (strm text
)
486 (process-input-from-stream strm infixp
)))