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 ;;; Define variables as constant integers
29 (defmacro enumerate-constants
(&rest syms
&aux
(v 0))
35 (setf (values k v
) (values-list k
)))
36 (prog1 `(defconstant ,k
,v
)
40 ;V Set precedence ranks.V
51 +vip-rank
+);< Virtually infinite precedence.
54 (defun multn-if-last-read ()
55 (declare (special *last-read
*))
57 ;; Implicit multiplication, two
58 ;; values were seperated by a space.
60 (parsed-opern +multn-rank
+ #'multn
))))
62 ;;; See if /parsed-thing/ can be interpreted
63 ;;; in any way. If so, call success-fn, then
64 ;;; finish interpreting.
65 (defun interpret-parsed
66 (parsed-thing &optional
(success-fn #'values
))
67 (declare (special *last-read
*))
68 (multn-if-last-read);< Check for implied multiplication.
69 (if (symbolp parsed-thing
)
70 (when (boundp parsed-thing
)
71 (let ((val (symbol-value parsed-thing
)))
74 ;; A symbol representing a function
75 ;; was read, change scope.
77 (symbol-function val
))
78 (setq *last-read
* val
))))
80 ;; The reader thinks it's something other
81 ;; than a symbol, parser doesn't need to worry.
83 (setq *last-read
* parsed-thing
))))
85 ;;; An invalid symbol was read,
86 ;;; could be something like "34x"
87 (defun parse-compact (&optional sym
&aux arrlen
)
88 (declare (special *parse-next
* *last-read
*))
90 ;; Must create *parse-next* from a symbol
91 (let ((sym-str (symbol-name sym
)))
92 (setq arrlen
(length sym-str
)
95 :element-type
'character
96 :fill-pointer
(1- arrlen
)
97 :displaced-to sym-str
)))
98 (setq arrlen
(length *parse-next
*)))
100 :for index
:from
(fill-pointer *parse-next
*) :downto
1
103 (setf (fill-pointer *parse-next
*) index
)
105 (let ((*package
* (find-package :lineal.client-vars
)))
106 (read-from-string *parse-next
*))
108 ;; We found valid input.
111 (setf *parse-next
* nil
)
113 (fill-pointer *parse-next
*) arrlen
115 (make-array (- arrlen index
)
116 :element-type
'character
118 :displaced-to
*parse-next
*
119 :displaced-index-offset index
)))))
120 (when successp
(return)))
122 ;; Nothing matched; quit trying.
123 (setf (fill-pointer *parse-next
*) arrlen
)
124 (signal 'unbound-variable
:name
*parse-next
*)))
127 ;;; Everything in the file calls this
128 ;;; read function on the infix stream.
129 (defun read-next-infix ()
130 (declare (special *unwind-rank-fn
* *last-read
*
131 *parse-strm
* *parse-next
*))
132 (if *parse-next
* (parse-compact)
135 (let ((*package
* (find-package
136 :lineal.client-vars
)))
137 ;; Sometimes an exception is thrown and
138 ;; control breaks to the current "read loop"
139 (setq this-read
(read *parse-strm
*)))
141 ;; Did not just read an operator.
145 (lambda () (setf successp t
)))
147 ;; We have no idea wtf was just read.
148 (parse-compact this-read
)))
151 (declare (ignore condit
))
152 ;; Don't check for unclosed parentheses,
154 (funcall *unwind-rank-fn
*
155 +base-rank
+ *last-read
*)))))
157 ;;; This is a generic construct for a closure
158 ;;; which will be stored as *unwind-rank-fn*
159 (defmacro opern-climber-lambda
160 ((this-rank op-rank val
) . body
)
161 `(lambda (,op-rank
,val
)
163 ;; A prefixed operator (see function below)
164 ;; was parsed last, unary-pre-opern.
166 ,this-rank
(the function
,op-rank
)))
168 (declare (type (integer 0 ,+vip-rank
+) ,op-rank
))
171 ;;; When something like 2 + -3 is encountered,
172 ;;; the negative is what this function deals with.
173 (defun unary-pre-opern (prev-rank this-op-fn
)
174 (declare (special *unwind-rank-fn
*))
175 (let ((prev-unwind-rank-fn *unwind-rank-fn
*)
179 (opern-climber-lambda
180 (prev-rank op-rank val
)
181 (if (and (< prev-rank op-rank
)
182 (< +multn-rank
+ op-rank
))
183 (progn (setq *unwind-rank-fn
*
186 (funcall prev-unwind-rank-fn op-rank
187 (funcall this-op-fn val
))))
188 *unwind-rank-fn
* this-unwind-rank-fn
)
189 (throw 'fn-scope
(values))))
191 ;;; A binary operator is parsed.
192 (defun parsed-opern (this-rank this-op-fn
)
193 (declare (special *unwind-rank-fn
* *last-read
*))
195 (funcall *unwind-rank-fn
* this-op-fn nil
))
196 (let* ((args (cons (funcall *unwind-rank-fn
*
197 this-rank
*last-read
*)
200 (prev-unwind-rank-fn *unwind-rank-fn
*)
205 (opern-climber-lambda
206 (this-rank op-rank val
)
208 ((= this-rank op-rank
)
210 *unwind-rank-fn
* this-unwind-rank-fn
212 tail
(cdr (rplacd tail
(cons val nil
))))
213 (throw 'fn-scope
(values)))
214 ((< this-rank op-rank
)
215 (setq *unwind-rank-fn
* this-unwind-rank-fn
)
218 (rplacd tail
(cons val nil
))
219 (funcall prev-unwind-rank-fn op-rank
220 (apply this-op-fn args
)))))
221 *unwind-rank-fn
* this-unwind-rank-fn
)
224 (defun open-paren-after-whitespace-peekp ()
225 (declare (special *parse-strm
* *parse-next
*))
227 (do () ((not (char= #\Space
(peek-char nil
*parse-strm
*)))
228 (char= #\
( (peek-char nil
*parse-strm
*)))
229 (read-char *parse-strm
*))))
231 (defun closed-paren-peekp ()
232 (declare (special *parse-strm
* *parse-next
*))
234 (char= #\
) (peek-char nil
*parse-strm
*))))
236 (defun parse-function-scope (this-fn)
237 (declare (special *unwind-rank-fn
* *last-read
*))
238 (when (open-paren-after-whitespace-peekp)
239 ;; User chose to enclose the
240 ;; argument(s) in parentheses.
243 (if (consp *last-read
*)
244 (apply this-fn
*last-read
*)
245 (funcall this-fn
*last-read
*)))
246 (return-from parse-function-scope
(values)))
247 (when (closed-paren-peekp)
248 ;; Using notation like (f*g)(x)
250 (setq *last-read
* this-fn
)
251 (return-from parse-function-scope
(values)))
252 (let ((prev-unwind-rank-fn *unwind-rank-fn
*)
257 (opern-climber-lambda
258 (+fn-rank
+ op-rank val
)
260 ((< op-rank
+fn-rank
+)
261 ;; Breaking from parens or program.
262 (funcall prev-unwind-rank-fn
263 op-rank
(if (consp val
)
265 (funcall this-fn val
))))
266 ((= op-rank
+fn-rank
+)
267 ;; Return from the function scope.
268 (setq *unwind-rank-fn
* prev-unwind-rank-fn
269 *last-read
* (if (consp val
)
271 (funcall this-fn val
)))
272 (throw 'break-fn-scope
(values)))
273 (t ;V Stay in the function scope.V
274 (setq *unwind-rank-fn
* this-unwind-rank-fn
)
276 *unwind-rank-fn
* this-unwind-rank-fn
)
282 (funcall *unwind-rank-fn
*
283 +fn-rank
+ *last-read
*)))
285 ;;; "read-eval" loop used by process-infix-from-stream
286 ;;; and open-paren-reader
287 (defun parse-infix ()
288 (declare (special *unwind-rank-fn
* *last-read
*))
289 (let ((prev-unwind-rank-fn *unwind-rank-fn
*)
294 (opern-climber-lambda
295 (+paren-rank
+ op-rank val
)
297 ((< op-rank
+paren-rank
+)
298 (funcall prev-unwind-rank-fn
300 ((= op-rank
+paren-rank
+)
301 ;; Closing paren encountered.
302 (setq *unwind-rank-fn
* prev-unwind-rank-fn
304 (throw 'break-paren-scope
(values)))
306 (setq *unwind-rank-fn
* this-unwind-rank-fn
)
308 *unwind-rank-fn
* this-unwind-rank-fn
)
314 (read-next-infix))))))
316 (defun open-paren-reader (strm ch
)
317 (declare (ignore strm ch
))
319 (catch 'break-paren-scope
323 ;;; Unwind the operation stack.
324 ;;; When the paren closure is reached,
325 ;;; *last-read* is set to the value calculated within
326 ;;; the parenthesis and 'break-paren-scope is thrown.
327 (defun close-paren-reader (strm ch
)
328 (declare (ignore strm ch
)
329 (special *unwind-rank-fn
* *last-read
*))
330 (funcall *unwind-rank-fn
*
331 +paren-rank
+ *last-read
*))
333 ;;; If *last-read* is nil, an operator
334 ;;; was read last, we can't logically
335 ;;; break from a function in that case.
336 (defun space-reader (strm ch
)
337 (declare (ignore strm ch
)
338 (special *last-read
*))
340 (throw 'break-fn-scope
(values))))
342 (defun comma-reader (strm ch
)
343 (declare (ignore strm ch
)
344 (special *unwind-rank-fn
* *last-read
*))
345 (let* ((lis (cons (funcall *unwind-rank-fn
*
346 +comma-rank
+ *last-read
*)
349 (prev-unwind-rank-fn *unwind-rank-fn
*)
354 (opern-climber-lambda
355 (+comma-rank
+ op-rank val
)
357 ((= +comma-rank
+ op-rank
)
363 (cdr (rplacd tail
(cons val nil
))))
364 (throw 'break-fn-scope
(values)))
365 ((< +comma-rank
+ op-rank
)
366 ;todo: figure out what this does
367 (setq *unwind-rank-fn
*
370 (t (rplacd tail
(cons val nil
))
371 (funcall prev-unwind-rank-fn op-rank
373 *unwind-rank-fn
* this-unwind-rank-fn
)
376 (defun set-opern-reader (ch this-rank this-op-fn
)
380 (declare (ignore strm ch
))
381 (parsed-opern this-rank this-op-fn
))))
383 (defparameter *infix-readtable
* (copy-readtable))
385 (let ((*readtable
* *infix-readtable
*))
386 (setf (readtable-case *readtable
*) :preserve
)
387 (set-macro-character #\
( #'open-paren-reader
)
388 (set-macro-character #\
) #'close-paren-reader
)
389 (set-macro-character #\Space
#'space-reader
)
390 (set-macro-character #\
, #'comma-reader
)
391 (set-opern-reader #\
+ +addn-rank
+ #'addn
)
392 (set-opern-reader #\-
+subtrn-rank
+ #'subtrn
)
393 (set-opern-reader #\
* +multn-rank
+ #'multn
)
394 (set-opern-reader #\
/ +divisn-rank
+ #'divisn
)
395 (set-opern-reader #\^
+exptn-rank
+ #'exptn
))
397 (defun process-infix-from-stream (strm)
398 (let ((*readtable
* *infix-readtable
*)
399 (*parse-strm
* strm
);< Stream to parse.
400 *parse-next
*;< Temporary buffer if we overparsed.
402 (lambda (op-rank val
)
403 (declare (ignore op-rank
))
404 (throw 'end-result val
)))
407 *parse-strm
* *parse-next
*
408 *unwind-rank-fn
* *last-read
*))
415 (declare (ignore condit
))
417 nil
"Likely too many parens! ~
418 (as if there were such a thing)~%"))
421 (format nil
"I don't understand: ~A~%"
422 (cell-error-name condit
)))
426 nil
"Evaluation flopped, perhaps bad input?~%~
427 Debug info: ~A~%" condit
)))))
429 (defun process-input-from-stream
430 (strm &optional
(infixp t
))
431 (let ((*read-default-float-format
* 'double-float
)
433 (if infixp
(process-infix-from-stream strm
)
434 (process-prefix-from-stream strm
))))
436 (defun process-input-from-string
437 (text &optional
(infixp t
))
438 (with-input-from-string (strm text
)
439 (process-input-from-stream strm infixp
)))