2 ;;;; Here is the dreaded infix parser.
3 ;;;; Heavily commented so I remember what happens here.
6 ; An ordered stack of operations is build up as closures,
7 ; each hold an accumulated value. When an operator of lesser
8 ; "rank" (see rank constants below) is encountered, the stack unwinds
9 ; recursively, passing the encountered rank and the accumulated
10 ; value for the operation.
12 ; Obviously there are different scopes where these operations apply,
13 ; namely "paren" and "function" scopes. Both scopes have their own
14 ; "read-eval" loop which terminate by the usual stack unwind and
15 ; a thrown symbol corresponding to the scope:
16 ; 'break-paren scope and 'break-fn-scope
18 ; The order of events and the way the termination is handled
19 ; is DIFFERENT between the two. Function scope is notably more
20 ; complex because I don't require ONE function parameter to be
21 ; enclosed in parentheses, multiple parameters require them.
23 ; TODO: overhaul parser to read 2a as 2*a
24 ; This will be a big change, optionally giving functions
25 ; control of the reader to parse their arguments.
29 ;V Set precedence ranks.V
30 (defconstant +base-rank
+ 0)
31 (defconstant +paren-rank
+ 1)
32 (defconstant +comma-rank
+ 2)
33 (defconstant +fn-rank
+ 3)
34 (defconstant +addn-rank
+ 4)
35 (defconstant +subtrn-rank
+ 5)
36 (defconstant +multn-rank
+ 6)
37 (defconstant +divisn-rank
+ 7)
38 (defconstant +exptn-rank
+ 8)
39 (defconstant +vip-rank
+ 9);< Virtually infinite precedence.
42 (defun multn-if-last-read ()
43 (declare (special *last-read
*))
45 ;; Implicit multiplication, two
46 ;; values were seperated by a space.
48 (parsed-opern +multn-rank
+ #'multn
))))
50 ;;; Everything in the file calls this
51 ;;; read function on the infix stream.
52 (defun read-next-infix (strm)
53 (declare (special *unwind-rank-fn
* *last-read
*))
56 (let ((*package
* (find-package
57 :lineal.client-vars
)))
58 ;; Actually read from the stream,
59 ;; sometimes an exception is thrown and
60 ;; control breaks to the current "read loop"
61 (setq this-read
(read strm
)))
63 ;; Did not just read an operator.
64 (multn-if-last-read);< Check for implied multiplication.
65 (if (symbolp this-read
)
66 (let ((val (symbol-value this-read
)))
67 ;; Don't bother checking boundp,
68 ;; there's a condition catch in
69 ;; process-infix-from-stream
71 ;; A symbol representing a function
72 ;; was read, change scope.
74 strm
(symbol-function val
))
75 (setq *last-read
* val
)))
76 (setq *last-read
* this-read
))))
79 (declare (ignore condit
))
80 ;; Don't check for unclosed parentheses,
82 (funcall *unwind-rank-fn
*
83 +base-rank
+ *last-read
*))))
85 ;;; This is a generic construct for a closure
86 ;;; which will be stored as *unwind-rank-fn*
87 (defmacro opern-climber-lambda
88 ((this-rank op-rank val
) . body
)
89 `(lambda (,op-rank
,val
)
91 ;; A prefixed operator (see function below)
92 ;; was parsed last, unary-pre-opern.
94 ,this-rank
(the function
,op-rank
)))
96 (declare (type (integer 0 ,+vip-rank
+) ,op-rank
))
99 ;;; When something like 2 + -3 is encountered,
100 ;;; the negative is what this function deals with.
101 (defun unary-pre-opern (prev-rank this-op-fn
)
102 (declare (special *unwind-rank-fn
*))
103 (let ((prev-unwind-rank-fn *unwind-rank-fn
*)
107 (opern-climber-lambda
108 (prev-rank op-rank val
)
109 (if (and (< prev-rank op-rank
)
110 (< +multn-rank
+ op-rank
))
111 (progn (setq *unwind-rank-fn
*
114 (funcall prev-unwind-rank-fn op-rank
115 (funcall this-op-fn val
))))
116 *unwind-rank-fn
* this-unwind-rank-fn
)
117 (throw 'fn-scope
(values))))
119 ;;; A binary operator is parsed.
120 (defun parsed-opern (this-rank this-op-fn
)
121 (declare (special *unwind-rank-fn
* *last-read
*))
123 (funcall *unwind-rank-fn
* this-op-fn nil
))
124 (let* ((args (cons (funcall *unwind-rank-fn
*
125 this-rank
*last-read
*)
128 (prev-unwind-rank-fn *unwind-rank-fn
*)
133 (opern-climber-lambda
134 (this-rank op-rank val
)
136 ((= this-rank op-rank
)
138 *unwind-rank-fn
* this-unwind-rank-fn
140 tail
(cdr (rplacd tail
(cons val nil
))))
141 (throw 'fn-scope
(values)))
142 ((< this-rank op-rank
)
143 (setq *unwind-rank-fn
* this-unwind-rank-fn
)
146 (rplacd tail
(cons val nil
))
147 (funcall prev-unwind-rank-fn op-rank
148 (apply this-op-fn args
)))))
149 *unwind-rank-fn
* this-unwind-rank-fn
)
152 (defun parse-function-scope (strm this-fn
)
153 (declare (special *unwind-rank-fn
* *last-read
*))
154 (do () ((not (char= #\Space
(peek-char nil strm
))))
156 (when (char= #\
( (peek-char nil strm
))
157 ;; User chose to enclose the
158 ;; argument(s) in parentheses.
159 (read-next-infix strm
)
161 (if (consp *last-read
*)
162 (apply this-fn
*last-read
*)
163 (funcall this-fn
*last-read
*)))
164 (return-from parse-function-scope
(values)))
165 (when (char= #\
) (peek-char nil strm
))
166 ;; Using notation like (f*g)(x)
168 (setq *last-read
* this-fn
)
169 (return-from parse-function-scope
(values)))
170 (let ((prev-unwind-rank-fn *unwind-rank-fn
*)
175 (opern-climber-lambda
176 (+fn-rank
+ op-rank val
)
178 ((< op-rank
+fn-rank
+)
179 ;; Breaking from parens or program.
180 (funcall prev-unwind-rank-fn
181 op-rank
(if (consp val
)
183 (funcall this-fn val
))))
184 ((= op-rank
+fn-rank
+)
185 ;; Return from the function scope.
186 (setq *unwind-rank-fn
* prev-unwind-rank-fn
187 *last-read
* (if (consp val
)
189 (funcall this-fn val
)))
190 (throw 'break-fn-scope
(values)))
191 (t ;V Stay in the function scope.V
192 (setq *unwind-rank-fn
* this-unwind-rank-fn
)
194 *unwind-rank-fn
* this-unwind-rank-fn
)
199 (read-next-infix strm
))))
200 (funcall *unwind-rank-fn
*
201 +fn-rank
+ *last-read
*)))
203 ;;; "read-eval" loop used by process-infix-from-stream
204 ;;; and open-paren-reader
205 (defun parse-infix (strm)
206 (declare (special *unwind-rank-fn
* *last-read
*))
207 (let ((prev-unwind-rank-fn *unwind-rank-fn
*)
212 (opern-climber-lambda
213 (+paren-rank
+ op-rank val
)
215 ((< op-rank
+paren-rank
+)
216 (funcall prev-unwind-rank-fn
218 ((= op-rank
+paren-rank
+)
219 ;; Closing paren encountered.
220 (setq *unwind-rank-fn
* prev-unwind-rank-fn
222 (throw 'break-paren-scope
(values)))
224 (setq *unwind-rank-fn
* this-unwind-rank-fn
)
226 *unwind-rank-fn
* this-unwind-rank-fn
)
232 (read-next-infix strm
))))))
234 (defun open-paren-reader (strm ch
)
235 (declare (ignore ch
))
237 (catch 'break-paren-scope
241 ;;; Unwind the operation stack.
242 ;;; When the paren closure is reached,
243 ;;; *last-read* is set to the value calculated within
244 ;;; the parenthesis and 'break-paren-scope is thrown.
245 (defun close-paren-reader (strm ch
)
246 (declare (ignore strm ch
)
247 (special *unwind-rank-fn
* *last-read
*))
248 (funcall *unwind-rank-fn
*
249 +paren-rank
+ *last-read
*))
251 ;;; If *last-read* is nil, an operator
252 ;;; was read last, we can't logically
253 ;;; break from a function in that case.
254 (defun space-reader (strm ch
)
255 (declare (ignore strm ch
)
256 (special *last-read
*))
258 (throw 'break-fn-scope
(values))))
260 (defun comma-reader (strm ch
)
261 (declare (ignore strm ch
)
262 (special *unwind-rank-fn
* *last-read
*))
263 (let* ((lis (cons (funcall *unwind-rank-fn
*
264 +comma-rank
+ *last-read
*)
267 (prev-unwind-rank-fn *unwind-rank-fn
*)
272 (opern-climber-lambda
273 (+comma-rank
+ op-rank val
)
275 ((= +comma-rank
+ op-rank
)
281 (cdr (rplacd tail
(cons val nil
))))
282 (throw 'break-fn-scope
(values)))
283 ((< +comma-rank
+ op-rank
)
284 ;todo: figure out what this does
285 (setq *unwind-rank-fn
*
288 (t (rplacd tail
(cons val nil
))
289 (funcall prev-unwind-rank-fn op-rank
291 *unwind-rank-fn
* this-unwind-rank-fn
)
294 (defun set-opern-reader (ch this-rank this-op-fn
)
298 (declare (ignore strm ch
))
299 (parsed-opern this-rank this-op-fn
))))
301 (defparameter *infix-readtable
* (copy-readtable))
303 (let ((*readtable
* *infix-readtable
*))
304 (setf (readtable-case *readtable
*) :preserve
)
305 (set-macro-character #\
( #'open-paren-reader
)
306 (set-macro-character #\
) #'close-paren-reader
)
307 (set-macro-character #\Space
#'space-reader
)
308 (set-macro-character #\
, #'comma-reader
)
309 (set-opern-reader #\
+ +addn-rank
+ #'addn
)
310 (set-opern-reader #\-
+subtrn-rank
+ #'subtrn
)
311 (set-opern-reader #\
* +multn-rank
+ #'multn
)
312 (set-opern-reader #\
/ +divisn-rank
+ #'divisn
)
313 (set-opern-reader #\^
+exptn-rank
+ #'exptn
))
316 (defun process-infix-from-stream (strm)
317 (let ((*readtable
* *infix-readtable
*)
319 (lambda (op-rank val
)
320 (declare (ignore op-rank
))
321 (throw 'end-result val
)))
323 (declare (special *unwind-rank-fn
* *last-read
*))
330 (declare (ignore condit
))
332 nil
"Likely too many parens! ~
333 (as if there were such a thing)~%"))
337 nil
"Evaluation flopped, perhaps bad input?~%~
338 Debug info: ~A~%" condit
)))))
340 (defun process-input-from-stream
341 (strm &optional
(infixp t
))
342 (let ((*read-default-float-format
* 'double-float
)
344 (if infixp
(process-infix-from-stream strm
)
345 (process-prefix-from-stream strm
))))
347 (defun process-input-from-string
348 (text &optional
(infixp t
))
349 (with-input-from-string (strm text
)
350 (process-input-from-stream strm infixp
)))