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.
28 ;;; Should probably handle this more dynamically at compile-time.
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 ;;; See if /parsed-thing/ can be interpreted
51 ;;; in any way. If so, call success-fn, then
52 ;;; finish interpreting.
53 (defun interpret-parsed
54 (parsed-thing &optional
(success-fn #'values
))
55 (declare (special *last-read
*))
56 (multn-if-last-read);< Check for implied multiplication.
57 (if (symbolp parsed-thing
)
58 (when (boundp parsed-thing
)
59 (let ((val (symbol-value parsed-thing
)))
62 ;; A symbol representing a function
63 ;; was read, change scope.
65 (symbol-function val
))
66 (setq *last-read
* val
))))
68 ;; The reader thinks it's something other
69 ;; than a symbol, parser doesn't need to worry.
71 (setq *last-read
* parsed-thing
))))
73 ;;; An invalid symbol was read,
74 ;;; could be something like "34x"
75 (defun parse-compact (&optional sym
&aux arrlen
)
76 (declare (special *parse-next
* *last-read
*))
78 ;; Must create *parse-next* from a symbol
79 (let ((sym-str (symbol-name sym
)))
80 (setq arrlen
(length sym-str
)
83 :element-type
'character
84 :fill-pointer
(1- arrlen
)
85 :displaced-to sym-str
)))
86 (setq arrlen
(length *parse-next
*)))
88 :for index
:from
(fill-pointer *parse-next
*) :downto
1
91 (setf (fill-pointer *parse-next
*) index
)
93 (let ((*package
* (find-package :lineal.client-vars
)))
94 (read-from-string *parse-next
*))
96 ;; We found valid input.
99 (setf *parse-next
* nil
)
101 (fill-pointer *parse-next
*) arrlen
103 (make-array (- arrlen index
)
104 :element-type
'character
106 :displaced-to
*parse-next
*
107 :displaced-index-offset index
)))))
108 (when successp
(return)))
110 ;; Nothing matched; quit trying.
111 (setf (fill-pointer *parse-next
*) arrlen
)
112 (signal 'unbound-variable
:name
*parse-next
*)))
115 ;;; Everything in the file calls this
116 ;;; read function on the infix stream.
117 (defun read-next-infix ()
118 (declare (special *unwind-rank-fn
* *last-read
*
119 *parse-strm
* *parse-next
*))
120 (if *parse-next
* (parse-compact)
123 (let ((*package
* (find-package
124 :lineal.client-vars
)))
125 ;; Sometimes an exception is thrown and
126 ;; control breaks to the current "read loop"
127 (setq this-read
(read *parse-strm
*)))
129 ;; Did not just read an operator.
133 (lambda () (setf successp t
)))
135 ;; We have no idea wtf was just read.
136 (parse-compact this-read
)))
139 (declare (ignore condit
))
140 ;; Don't check for unclosed parentheses,
142 (funcall *unwind-rank-fn
*
143 +base-rank
+ *last-read
*)))))
145 ;;; This is a generic construct for a closure
146 ;;; which will be stored as *unwind-rank-fn*
147 (defmacro opern-climber-lambda
148 ((this-rank op-rank val
) . body
)
149 `(lambda (,op-rank
,val
)
151 ;; A prefixed operator (see function below)
152 ;; was parsed last, unary-pre-opern.
154 ,this-rank
(the function
,op-rank
)))
156 (declare (type (integer 0 ,+vip-rank
+) ,op-rank
))
159 ;;; When something like 2 + -3 is encountered,
160 ;;; the negative is what this function deals with.
161 (defun unary-pre-opern (prev-rank this-op-fn
)
162 (declare (special *unwind-rank-fn
*))
163 (let ((prev-unwind-rank-fn *unwind-rank-fn
*)
167 (opern-climber-lambda
168 (prev-rank op-rank val
)
169 (if (and (< prev-rank op-rank
)
170 (< +multn-rank
+ op-rank
))
171 (progn (setq *unwind-rank-fn
*
174 (funcall prev-unwind-rank-fn op-rank
175 (funcall this-op-fn val
))))
176 *unwind-rank-fn
* this-unwind-rank-fn
)
177 (throw 'fn-scope
(values))))
179 ;;; A binary operator is parsed.
180 (defun parsed-opern (this-rank this-op-fn
)
181 (declare (special *unwind-rank-fn
* *last-read
*))
183 (funcall *unwind-rank-fn
* this-op-fn nil
))
184 (let* ((args (cons (funcall *unwind-rank-fn
*
185 this-rank
*last-read
*)
188 (prev-unwind-rank-fn *unwind-rank-fn
*)
193 (opern-climber-lambda
194 (this-rank op-rank val
)
196 ((= this-rank op-rank
)
198 *unwind-rank-fn
* this-unwind-rank-fn
200 tail
(cdr (rplacd tail
(cons val nil
))))
201 (throw 'fn-scope
(values)))
202 ((< this-rank op-rank
)
203 (setq *unwind-rank-fn
* this-unwind-rank-fn
)
206 (rplacd tail
(cons val nil
))
207 (funcall prev-unwind-rank-fn op-rank
208 (apply this-op-fn args
)))))
209 *unwind-rank-fn
* this-unwind-rank-fn
)
212 (defun open-paren-after-whitespace-peekp ()
213 (declare (special *parse-strm
* *parse-next
*))
215 (do () ((not (char= #\Space
(peek-char nil
*parse-strm
*)))
216 (char= #\
( (peek-char nil
*parse-strm
*)))
217 (read-char *parse-strm
*))))
219 (defun closed-paren-peekp ()
220 (declare (special *parse-strm
* *parse-next
*))
222 (char= #\
) (peek-char nil
*parse-strm
*))))
224 (defun parse-function-scope (this-fn)
225 (declare (special *unwind-rank-fn
* *last-read
*))
226 (when (open-paren-after-whitespace-peekp)
227 ;; User chose to enclose the
228 ;; argument(s) in parentheses.
231 (if (consp *last-read
*)
232 (apply this-fn
*last-read
*)
233 (funcall this-fn
*last-read
*)))
234 (return-from parse-function-scope
(values)))
235 (when (closed-paren-peekp)
236 ;; Using notation like (f*g)(x)
238 (setq *last-read
* this-fn
)
239 (return-from parse-function-scope
(values)))
240 (let ((prev-unwind-rank-fn *unwind-rank-fn
*)
245 (opern-climber-lambda
246 (+fn-rank
+ op-rank val
)
248 ((< op-rank
+fn-rank
+)
249 ;; Breaking from parens or program.
250 (funcall prev-unwind-rank-fn
251 op-rank
(if (consp val
)
253 (funcall this-fn val
))))
254 ((= op-rank
+fn-rank
+)
255 ;; Return from the function scope.
256 (setq *unwind-rank-fn
* prev-unwind-rank-fn
257 *last-read
* (if (consp val
)
259 (funcall this-fn val
)))
260 (throw 'break-fn-scope
(values)))
261 (t ;V Stay in the function scope.V
262 (setq *unwind-rank-fn
* this-unwind-rank-fn
)
264 *unwind-rank-fn
* this-unwind-rank-fn
)
270 (funcall *unwind-rank-fn
*
271 +fn-rank
+ *last-read
*)))
273 ;;; "read-eval" loop used by process-infix-from-stream
274 ;;; and open-paren-reader
275 (defun parse-infix ()
276 (declare (special *unwind-rank-fn
* *last-read
*))
277 (let ((prev-unwind-rank-fn *unwind-rank-fn
*)
282 (opern-climber-lambda
283 (+paren-rank
+ op-rank val
)
285 ((< op-rank
+paren-rank
+)
286 (funcall prev-unwind-rank-fn
288 ((= op-rank
+paren-rank
+)
289 ;; Closing paren encountered.
290 (setq *unwind-rank-fn
* prev-unwind-rank-fn
292 (throw 'break-paren-scope
(values)))
294 (setq *unwind-rank-fn
* this-unwind-rank-fn
)
296 *unwind-rank-fn
* this-unwind-rank-fn
)
302 (read-next-infix))))))
304 (defun open-paren-reader (strm ch
)
305 (declare (ignore strm ch
))
307 (catch 'break-paren-scope
311 ;;; Unwind the operation stack.
312 ;;; When the paren closure is reached,
313 ;;; *last-read* is set to the value calculated within
314 ;;; the parenthesis and 'break-paren-scope is thrown.
315 (defun close-paren-reader (strm ch
)
316 (declare (ignore strm ch
)
317 (special *unwind-rank-fn
* *last-read
*))
318 (funcall *unwind-rank-fn
*
319 +paren-rank
+ *last-read
*))
321 ;;; If *last-read* is nil, an operator
322 ;;; was read last, we can't logically
323 ;;; break from a function in that case.
324 (defun space-reader (strm ch
)
325 (declare (ignore strm ch
)
326 (special *last-read
*))
328 (throw 'break-fn-scope
(values))))
330 (defun comma-reader (strm ch
)
331 (declare (ignore strm ch
)
332 (special *unwind-rank-fn
* *last-read
*))
333 (let* ((lis (cons (funcall *unwind-rank-fn
*
334 +comma-rank
+ *last-read
*)
337 (prev-unwind-rank-fn *unwind-rank-fn
*)
342 (opern-climber-lambda
343 (+comma-rank
+ op-rank val
)
345 ((= +comma-rank
+ op-rank
)
351 (cdr (rplacd tail
(cons val nil
))))
352 (throw 'break-fn-scope
(values)))
353 ((< +comma-rank
+ op-rank
)
354 ;todo: figure out what this does
355 (setq *unwind-rank-fn
*
358 (t (rplacd tail
(cons val nil
))
359 (funcall prev-unwind-rank-fn op-rank
361 *unwind-rank-fn
* this-unwind-rank-fn
)
364 (defun set-opern-reader (ch this-rank this-op-fn
)
368 (declare (ignore strm ch
))
369 (parsed-opern this-rank this-op-fn
))))
371 (defparameter *infix-readtable
* (copy-readtable))
373 (let ((*readtable
* *infix-readtable
*))
374 (setf (readtable-case *readtable
*) :preserve
)
375 (set-macro-character #\
( #'open-paren-reader
)
376 (set-macro-character #\
) #'close-paren-reader
)
377 (set-macro-character #\Space
#'space-reader
)
378 (set-macro-character #\
, #'comma-reader
)
379 (set-opern-reader #\
+ +addn-rank
+ #'addn
)
380 (set-opern-reader #\-
+subtrn-rank
+ #'subtrn
)
381 (set-opern-reader #\
* +multn-rank
+ #'multn
)
382 (set-opern-reader #\
/ +divisn-rank
+ #'divisn
)
383 (set-opern-reader #\^
+exptn-rank
+ #'exptn
))
385 (defun process-infix-from-stream (strm)
386 (let ((*readtable
* *infix-readtable
*)
387 (*parse-strm
* strm
);< Stream to parse.
388 *parse-next
*;< Temporary buffer if we overparsed.
390 (lambda (op-rank val
)
391 (declare (ignore op-rank
))
392 (throw 'end-result val
)))
395 *parse-strm
* *parse-next
*
396 *unwind-rank-fn
* *last-read
*))
403 (declare (ignore condit
))
405 nil
"Likely too many parens! ~
406 (as if there were such a thing)~%"))
409 (format nil
"I don't understand: ~A~%"
410 (cell-error-name condit
)))
414 nil
"Evaluation flopped, perhaps bad input?~%~
415 Debug info: ~A~%" condit
)))))
417 (defun process-input-from-stream
418 (strm &optional
(infixp t
))
419 (let ((*read-default-float-format
* 'double-float
)
421 (if infixp
(process-infix-from-stream strm
)
422 (process-prefix-from-stream strm
))))
424 (defun process-input-from-string
425 (text &optional
(infixp t
))
426 (with-input-from-string (strm text
)
427 (process-input-from-stream strm infixp
)))