Commit | Line | Data |
---|---|---|
874125c4 MW |
1 | ;;; -*-lisp-*- |
2 | ;;; | |
3 | ;;; Infix-to-S-exp translation | |
4 | ;;; | |
5 | ;;; (c) 2006 Mark Wooding | |
6 | ;;; | |
7 | ||
8 | ;;;----- Licensing notice --------------------------------------------------- | |
9 | ;;; | |
10 | ;;; This program is free software; you can redistribute it and/or modify | |
11 | ;;; it under the terms of the GNU General Public License as published by | |
12 | ;;; the Free Software Foundation; either version 2 of the License, or | |
13 | ;;; (at your option) any later version. | |
14 | ;;; | |
15 | ;;; This program is distributed in the hope that it will be useful, | |
16 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
18 | ;;; GNU General Public License for more details. | |
19 | ;;; | |
20 | ;;; You should have received a copy of the GNU General Public License | |
21 | ;;; along with this program; if not, write to the Free Software Foundation, | |
22 | ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. | |
23 | ||
24 | ;;;-------------------------------------------------------------------------- | |
25 | ;;; Packages. | |
26 | ||
27 | (defpackage #:infix-keywords | |
28 | (:use #:common-lisp) | |
29 | (:export #:|(| #:|)| #:{ #:} #:|,| #:@ #:|$| #:& #:\| #:~ | |
30 | #:and #:or #:not #:xor | |
31 | #:== #:/= #:< #:<= #:> #:>= #:eq #:eql #:equal #:equalp | |
32 | #:+ #:- #:* #:/ #:// #:% #:^ #:= #:! | |
33 | #:+= #:-= #:*= #:%= #:&= #:\|= #:xor= #:<<= #:>>= | |
34 | #:++ #:-- | |
35 | #:<< #:>> | |
36 | #:if #:then #:else | |
37 | #:let #:let* #:in)) | |
38 | ||
39 | (defpackage #:infix | |
40 | (:use #:common-lisp #:infix-keywords) | |
41 | (:export #:operator #:operatorp | |
42 | #:*token* #:get-token #:*get-token* | |
43 | #:pushval #:popval #:flushops #:pushop | |
44 | #:infix-done #:parse-infix | |
45 | #:defopfunc #:definfix #:defprefix #:defpostfix | |
46 | #:infix #:prefix #:postfix #:operand | |
47 | #:delim #:errfunc | |
48 | #:binop-apply #:binop-apply-append | |
49 | #:unop-apply #:unop-apply-toggle | |
50 | #:strip-progn | |
51 | #:read-infix #:install-infix-reader)) | |
52 | ||
53 | (in-package #:infix) | |
54 | ||
55 | ;;;-------------------------------------------------------------------------- | |
56 | ;;; Data structures. | |
57 | ||
58 | (defstruct (operator (:predicate operatorp) | |
59 | (:conc-name op-)) | |
60 | "An operator object. The name serves mainly for documentation. The left | |
0ff9df03 MW |
61 | and right precedences control operator stacking behaviour. The function |
62 | is called when this operator is popped off the stack. | |
63 | ||
64 | If the left precedence is not nil, then operators currently on the stack | |
65 | whose /right/-precedence is greater than or equal to this operator's | |
66 | /left/-precedence are popped before this operator can be pushed. If the | |
67 | right precedence is nil, then this operator is not in fact pushed, but | |
68 | processed immediately." | |
874125c4 MW |
69 | (name nil :type symbol) |
70 | (lprec nil :type (or fixnum null)) | |
71 | (rprec nil :type (or fixnum null)) | |
72 | (func (lambda () nil) :type (function () t))) | |
73 | ||
74 | ;;;-------------------------------------------------------------------------- | |
75 | ;;; Global parser state. | |
76 | ||
77 | (defvar *stream* nil | |
78 | "The parser input stream. Bound automatically by `read-infix'.") | |
79 | ||
80 | ;;;-------------------------------------------------------------------------- | |
81 | ;;; State for one level of `parse-infix'. | |
82 | ||
83 | (defvar *valstk* nil | |
84 | "Value stack. Contains (partially constructed) Lisp forms.") | |
85 | (defvar *opstk* nil | |
86 | "Operator stack. Contains operator objects.") | |
87 | (defvar *token* nil | |
88 | "The current token. Could be any Lisp object.") | |
89 | (defvar *paren-depth* 0 | |
90 | "Depth of parentheses in the current `parse-infix'. Used to override the | |
0ff9df03 | 91 | minprec restriction.") |
874125c4 MW |
92 | |
93 | ;;;-------------------------------------------------------------------------- | |
94 | ;;; The tokenizer. | |
95 | ||
96 | (defconstant eof (cons :eof nil) | |
97 | "A magical object which `get-token' returns at end-of-file.") | |
98 | ||
99 | (defun default-get-token () | |
100 | "Read a token from *stream* and store it in *token*." | |
101 | (flet ((whitespacep (ch) | |
102 | (member ch '(#\newline #\space #\tab #\page))) | |
103 | (self-delim-p (ch) | |
104 | (member ch '(#\; #\, #\: #\( #\) #\@ #\$ #\[ #\] #\{ #\}))) | |
105 | (macro-char-p (ch) | |
106 | (member ch '(#\# #\| #\\ #\" #\' #\`))) | |
107 | (done (token) | |
108 | (setf *token* token) | |
109 | (return-from default-get-token))) | |
110 | (let (ch) | |
111 | (tagbody | |
112 | top | |
113 | (setf ch (read-char *stream* nil nil t)) | |
114 | (cond ((null ch) (done eof)) | |
115 | ((whitespacep ch) (go top)) | |
116 | ((eql ch #\;) (go comment)) | |
117 | ((self-delim-p ch) (done (intern (string ch) | |
118 | 'infix-keywords))) | |
119 | ((or (macro-char-p ch) (alphanumericp ch)) (go read)) | |
120 | (t (go read-sym))) | |
121 | read | |
122 | (unread-char ch *stream*) | |
123 | (done (read *stream* t nil t)) | |
124 | read-sym | |
125 | (done (intern (with-output-to-string (out) | |
126 | (write-char ch out) | |
127 | (loop | |
128 | (setf ch (read-char *stream* nil nil t)) | |
129 | (cond ((or (null ch) | |
130 | (whitespacep ch)) | |
131 | (return)) | |
132 | ((or (self-delim-p ch) | |
133 | (macro-char-p ch) | |
134 | (alphanumericp ch)) | |
135 | (unread-char ch *stream*) | |
136 | (return)) | |
137 | (t | |
138 | (write-char ch out))))) | |
139 | 'infix-keywords)) | |
140 | ||
141 | comment | |
142 | (case (setf ch (read-char *stream* nil nil t)) | |
143 | ((nil) (done eof)) | |
144 | ((#\newline) (go top)) | |
145 | (t (go comment))))))) | |
146 | ||
147 | (defvar *get-token* #'default-get-token | |
148 | "The current tokenizing function.") | |
149 | ||
150 | (defun get-token () | |
151 | "Read a token, and store it in *token*. Indirects via *get-token*." | |
152 | (funcall *get-token*)) | |
153 | ||
154 | ;;;-------------------------------------------------------------------------- | |
155 | ;;; Stack manipulation. | |
156 | ||
157 | (defun pushval (val) | |
158 | "Push VAL onto the value stack." | |
159 | (push val *valstk*)) | |
160 | ||
161 | (defun popval () | |
162 | "Pop a value off the value stack and return it." | |
163 | (pop *valstk*)) | |
164 | ||
165 | (defun flushops (prec) | |
166 | "Flush out operators on the operator stack with precedecnce higher than or | |
0ff9df03 MW |
167 | equal to PREC. This is used when a new operator is pushed, to ensure that |
168 | higher-precedence operators snarf their arguments." | |
874125c4 MW |
169 | (loop |
170 | (when (null *opstk*) | |
171 | (return)) | |
172 | (let ((head (car *opstk*))) | |
173 | (when (> prec (op-rprec head)) | |
174 | (return)) | |
175 | (pop *opstk*) | |
176 | (funcall (op-func head))))) | |
177 | ||
178 | (defun pushop (op) | |
179 | "Push the operator OP onto the stack. If the operator has a | |
0ff9df03 MW |
180 | left-precedence, then operators with higher precedence are flushed (see |
181 | `flushops'). If the operator has no left-precedence, the operator is | |
182 | invoked immediately." | |
874125c4 MW |
183 | (let ((lp (op-lprec op))) |
184 | (when lp | |
185 | (flushops lp))) | |
186 | (if (op-rprec op) | |
187 | (push op *opstk*) | |
188 | (funcall (op-func op)))) | |
189 | ||
190 | ;;;-------------------------------------------------------------------------- | |
191 | ;;; The main parser. | |
192 | ||
193 | (defun infix-done () | |
194 | "Signal that `parse-infix' has reached the end of an expression. This is | |
0ff9df03 MW |
195 | primarily used by the `)' handler function if it finds there are no |
196 | parentheses." | |
874125c4 MW |
197 | (throw 'infix-done nil)) |
198 | ||
199 | (defun parse-infix (&optional minprec) | |
200 | "Parses an infix expression and return the resulting Lisp form. This is | |
0ff9df03 | 201 | the heart of the whole thing. |
874125c4 | 202 | |
0ff9df03 MW |
203 | Expects a token to be ready in *token*; leaves *token* as the first token |
204 | which couldn't be parsed. | |
874125c4 | 205 | |
0ff9df03 MW |
206 | The syntax parsed by this function doesn't fit nicely into a BNF, since we |
207 | parsing is effected by the precedences of the various operators. We have | |
208 | low-precedence prefix operators such as `not', for example." | |
874125c4 MW |
209 | (flet ((lookup (items) |
210 | (dolist (item items (values nil nil)) | |
211 | (let ((op (get *token* (car item)))) | |
212 | (when op (return (values op (cdr item)))))))) | |
213 | (let ((*valstk* nil) | |
214 | (*opstk* nil) | |
215 | (*paren-depth* 0) | |
216 | (state :operand)) | |
217 | (catch 'infix-done | |
218 | (loop | |
219 | (ecase state | |
220 | (:operand | |
221 | (when (eq *token* eof) | |
222 | (error "operand expected; found eof")) | |
223 | (typecase *token* | |
224 | (symbol | |
225 | (multiple-value-bind (op newstate) | |
226 | (lookup '((prefix . :operand) | |
227 | (operand . :operator))) | |
228 | (etypecase op | |
229 | (null | |
230 | (pushval *token*) | |
231 | (get-token) | |
232 | (setf state :operator)) | |
233 | (function | |
234 | (funcall op) | |
235 | (setf state newstate)) | |
236 | (operator | |
237 | (get-token) | |
238 | (pushop op))))) | |
239 | (t | |
240 | (pushval *token*) | |
241 | (get-token) | |
242 | (setf state :operator)))) | |
243 | (:operator | |
244 | (typecase *token* | |
245 | (symbol | |
246 | (multiple-value-bind (op newstate) | |
247 | (lookup '((infix . :operand) | |
248 | (postfix . :operator))) | |
249 | (etypecase op | |
250 | (null | |
251 | (return)) | |
252 | (function | |
253 | (funcall op)) | |
254 | (operator | |
255 | (when (and minprec | |
256 | (zerop *paren-depth*) | |
257 | (op-lprec op) | |
258 | (< (op-lprec op) minprec)) | |
259 | (return)) | |
260 | (get-token) | |
261 | (pushop op))) | |
262 | (setf state newstate))) | |
263 | (t | |
264 | (return))))))) | |
265 | (flushops most-negative-fixnum) | |
266 | (assert (and (consp *valstk*) | |
267 | (null (cdr *valstk*)))) | |
268 | (car *valstk*)))) | |
269 | ||
270 | ;;;-------------------------------------------------------------------------- | |
271 | ;;; Machinery for defining operators. | |
272 | ||
273 | (defmacro defopfunc (op kind &body body) | |
274 | "Defines a magical operator. The operator's name is the symbol OP. The | |
0ff9df03 MW |
275 | KIND must be one of the symbols `infix', `prefix' or `postfix'. The body |
276 | is evaluated when the operator is parsed, and must either push appropriate | |
277 | things on the operator stack or do its own parsing and push a result on | |
278 | the value stack." | |
874125c4 MW |
279 | `(progn |
280 | (setf (get ',op ',kind) | |
281 | (lambda () ,@body)) | |
282 | ',op)) | |
283 | ||
284 | (defmacro definfix (op prec &body body) | |
285 | "Defines an infix operator. The operator's name is the symbol OP. The | |
0ff9df03 MW |
286 | operator's precedence is specified by PREC, which may be one of the |
287 | following: | |
874125c4 | 288 | |
0ff9df03 MW |
289 | * PREC -- equivalent to (:lassoc PREC) |
290 | * (:lassoc PREC) -- left-associative with precedence PREC | |
291 | * (:rassoc PREC) -- right-associative with precedence PREC | |
292 | * (LPREC . RPREC) -- independent left- and right-precedences | |
293 | * (LPREC RPREC) -- synonym for the dotted form | |
874125c4 | 294 | |
0ff9df03 MW |
295 | In fact, (:lassoc PREC) is the same as (PREC . PREC), and (:rassoc PREC) |
296 | is the same as (PREC . (1- PREC)). | |
874125c4 | 297 | |
0ff9df03 MW |
298 | The BODY is evaluated when the operator's arguments are fully resolved. |
299 | It should pop off two arguments and push one result. Nobody will check | |
300 | that this is done correctly." | |
874125c4 MW |
301 | (multiple-value-bind |
302 | (lprec rprec) | |
303 | (flet ((bad () | |
304 | (error "bad precedence spec ~S" prec))) | |
305 | (cond ((integerp prec) | |
306 | (values prec prec)) | |
307 | ((not (consp prec)) | |
308 | (bad)) | |
309 | ((and (integerp (car prec)) | |
310 | (integerp (cdr prec))) | |
311 | (values (car prec) (cdr prec))) | |
312 | ((or (not (consp (cdr prec))) | |
313 | (not (integerp (cadr prec))) | |
314 | (not (null (cddr prec)))) | |
315 | (bad)) | |
316 | ((integerp (car prec)) | |
317 | (values (car prec) (cadr prec))) | |
318 | ((eq (car prec) :lassoc) | |
319 | (values (cadr prec) (cadr prec))) | |
320 | ((eq (car prec) :rassoc) | |
321 | (values (cadr prec) (1- (cadr prec)))) | |
322 | (t | |
323 | (bad)))) | |
324 | `(progn | |
325 | (setf (get ',op 'infix) | |
326 | (make-operator :name ',op | |
327 | :lprec ,lprec :rprec ,rprec | |
328 | :func (lambda () ,@body))) | |
329 | ',op))) | |
330 | ||
331 | (eval-when (:compile-toplevel :load-toplevel) | |
332 | (defun do-defunary (kind op prec body) | |
333 | (unless (integerp prec) | |
334 | (error "bad precedence spec ~S" prec)) | |
335 | `(progn | |
336 | (setf (get ',op ',kind) | |
337 | (make-operator :name ',op | |
338 | ,(ecase kind | |
339 | (prefix :rprec) | |
340 | (postfix :lprec)) ,prec | |
341 | :func (lambda () ,@body))) | |
342 | ',op))) | |
343 | (defmacro defprefix (op prec &body body) | |
344 | "Defines a prefix operator. The operator's name is the symbol OP. The | |
0ff9df03 MW |
345 | operator's (right) precedence is PREC. The body is evaluated with the |
346 | operator's argument is fully determined. It should pop off one argument | |
347 | and push one result." | |
874125c4 MW |
348 | (do-defunary 'prefix op prec body)) |
349 | (defmacro defpostfix (op prec &body body) | |
350 | "Defines a postfix operator. The operator's name is the symbol OP. The | |
0ff9df03 MW |
351 | operator's (left) precedence is PREC. The body is evaluated with the |
352 | operator's argument is fully determined. It should pop off one argument | |
353 | and push one result." | |
874125c4 MW |
354 | (do-defunary 'postfix op prec body)) |
355 | ||
356 | ;;;-------------------------------------------------------------------------- | |
357 | ;;; Infrastructure for operator definitions. | |
358 | ||
359 | (defun delim (delim &key (requiredp t)) | |
360 | "Parse DELIM, and read the next token. Returns t if the DELIM was found, | |
0ff9df03 | 361 | or nil if not (and requiredp was nil)." |
874125c4 MW |
362 | (cond ((eq *token* delim) (get-token) t) |
363 | (requiredp (error "expected `~(~A~)'; found ~S" delim *token*)) | |
364 | (t nil))) | |
365 | ||
366 | (defun errfunc (&rest args) | |
367 | "Returns a function which reports an error. Useful when constructing | |
0ff9df03 | 368 | operators by hand." |
874125c4 MW |
369 | (lambda () (apply #'error args))) |
370 | ||
371 | (defun binop-apply (name) | |
372 | "Apply the Lisp binop NAME to the top two items on the value stack; i.e., | |
0ff9df03 | 373 | if the top two items are Y and X, then we push (NAME X Y)." |
874125c4 MW |
374 | (let ((y (popval)) (x (popval))) |
375 | (pushval (list name x y)))) | |
376 | ||
377 | (defun binop-apply-append (name) | |
378 | "As for `binop-apply' but if the second-from-top item on the stack has the | |
0ff9df03 MW |
379 | form (NAME SOMETHING ...) then fold the top item into the form rather than |
380 | buidling another." | |
874125c4 MW |
381 | (let ((y (popval)) (x (popval))) |
382 | (pushval (if (and (consp x) (eq (car x) name)) | |
383 | (append x (list y)) | |
384 | (list name x y))))) | |
385 | ||
386 | (defun unop-apply (name) | |
387 | "Apply the Lisp unop NAME to the top item on the value stack; i.e., if the | |
0ff9df03 | 388 | top item is X, then push (NAME X)." |
874125c4 | 389 | (pushval (list name (popval)))) |
0ff9df03 | 390 | |
874125c4 MW |
391 | (defun unop-apply-toggle (name) |
392 | "As for `unop-apply', but if the top item has the form (NAME X) already, | |
0ff9df03 | 393 | then push just X." |
874125c4 MW |
394 | (let ((x (popval))) |
395 | (pushval (if (and (consp x) | |
396 | (eq (car x) name) | |
397 | (consp (cdr x)) | |
398 | (null (cddr x))) | |
399 | (cadr x) | |
400 | (list name x))))) | |
401 | ||
402 | (defun strip-progn (form) | |
403 | "Return a version of FORM suitable for putting somewhere where there's an | |
0ff9df03 MW |
404 | implicit `progn'. If FORM has the form (PROGN . FOO) then return FOO, |
405 | otherwise return (FORM)." | |
874125c4 MW |
406 | (if (and (consp form) |
407 | (eq (car form) 'progn)) | |
408 | (cdr form) | |
409 | (list form))) | |
410 | ||
411 | (defun parse-expr-list () | |
412 | "Parse a list of expressions separated by commas." | |
413 | (let ((stuff nil)) | |
414 | (loop | |
415 | (push (parse-infix 0) stuff) | |
416 | (unless (delim '|,| :requiredp nil) | |
417 | (return))) | |
418 | (nreverse stuff))) | |
419 | ||
420 | (defun parse-ident-list () | |
421 | "Parse a list of symbols separated by commas." | |
422 | (let ((stuff nil)) | |
423 | (loop | |
424 | (unless (symbolp *token*) | |
425 | (error "expected symbol; found ~S" *token*)) | |
426 | (push *token* stuff) | |
427 | (get-token) | |
428 | (unless (delim '|,| :requiredp nil) | |
429 | (return))) | |
430 | (nreverse stuff))) | |
431 | ||
432 | ;;;-------------------------------------------------------------------------- | |
433 | ;;; Various simple operators. | |
434 | ||
435 | (definfix |,| (:lassoc -1) (binop-apply-append 'progn)) | |
436 | ||
437 | (definfix or (:lassoc 10) (binop-apply-append 'or)) | |
438 | (definfix and (:lassoc 15) (binop-apply-append 'and)) | |
439 | ||
440 | (defprefix not 19 (unop-apply-toggle 'not)) | |
441 | ||
442 | (definfix == (:lassoc 20) (binop-apply-append '=)) | |
443 | (definfix /= (:lassoc 20) (binop-apply-append '/=)) | |
444 | (definfix < (:lassoc 20) (binop-apply-append '<)) | |
445 | (definfix <= (:lassoc 20) (binop-apply-append '<=)) | |
446 | (definfix >= (:lassoc 20) (binop-apply-append '>=)) | |
447 | (definfix > (:lassoc 20) (binop-apply-append '>)) | |
448 | (definfix eq (:lassoc 20) (binop-apply-append 'eq)) | |
449 | (definfix eql (:lassoc 20) (binop-apply-append 'eql)) | |
450 | (definfix equal (:lassoc 20) (binop-apply-append 'equal)) | |
451 | (definfix equalp (:lassoc 20) (binop-apply-append 'equalp)) | |
452 | ||
453 | (definfix \| (:lassoc 30) (binop-apply-append 'logior)) | |
454 | (definfix xor (:lassoc 30) (binop-apply-append 'logxor)) | |
455 | (definfix & (:lassoc 35) (binop-apply-append 'logand)) | |
456 | ||
457 | (definfix << (:lassoc 40) (binop-apply 'ash)) | |
458 | (definfix >> (:lassoc 40) (unop-apply-toggle '-) (binop-apply 'ash)) | |
459 | ||
460 | (definfix + (:lassoc 50) (binop-apply-append '+)) | |
461 | (definfix - (:lassoc 50) (binop-apply-append '-)) | |
462 | ||
463 | (definfix * (:lassoc 60) (binop-apply-append '*)) | |
464 | (definfix / (:lassoc 60) (binop-apply '/)) | |
465 | (definfix // (:lassoc 60) (binop-apply 'floor)) | |
466 | (definfix % (:lassoc 60) (binop-apply 'mod)) | |
467 | ||
468 | (definfix ^ (:rassoc 70) (binop-apply 'expt)) | |
469 | ||
470 | (definfix = (120 . 5) (binop-apply 'setf)) | |
471 | (definfix += (120 . 5) (binop-apply 'incf)) | |
472 | (definfix -= (120 . 5) (binop-apply 'decf)) | |
473 | ||
474 | (defprefix + 100 nil) | |
475 | (defprefix - 100 (unop-apply-toggle '-)) | |
476 | (defprefix ~ 100 (unop-apply-toggle 'lognot)) | |
477 | ||
478 | (defprefix ++ 100 (unop-apply 'incf)) | |
479 | (defprefix -- 100 (unop-apply 'decf)) | |
480 | ||
481 | ;;(defpostfix ! 110 (unop-apply 'factorial)) | |
482 | ||
483 | (defopfunc @ operand | |
484 | "An escape to the standard Lisp reader." | |
485 | (pushval (read *stream* t nil t)) | |
486 | (get-token)) | |
487 | ||
488 | ;;;-------------------------------------------------------------------------- | |
489 | ;;; Parentheses, for grouping and function-calls. | |
490 | ||
491 | (defun push-paren (right) | |
492 | "Pushes a funny parenthesis operator. Since this operator has no left | |
0ff9df03 MW |
493 | precedence, and very low right precedence, it is pushed over any stack of |
494 | operators and can only be popped by magic or end-of-file. In the latter | |
495 | case, cause an error." | |
874125c4 MW |
496 | (pushop (make-operator :name right |
497 | :lprec nil :rprec -1000 | |
498 | :func (errfunc "missing `~A'" right))) | |
499 | (incf *paren-depth*) | |
500 | (get-token)) | |
501 | ||
502 | (defun pop-paren (right) | |
503 | "Pops a parenthesis. If there are no parentheses, maybe they belong to the | |
0ff9df03 MW |
504 | caller's syntax. Otherwise, pop off operators above the current funny |
505 | parenthesis operator, and then remove it." | |
874125c4 MW |
506 | (when (zerop *paren-depth*) |
507 | (infix-done)) | |
508 | (flushops -999) | |
509 | (assert *opstk*) | |
510 | (unless (eq (op-name (car *opstk*)) right) | |
511 | (error "spurious `~A'" right)) | |
512 | (assert (plusp *paren-depth*)) | |
513 | (decf *paren-depth*) | |
514 | (pop *opstk*) | |
515 | (get-token)) | |
516 | ||
517 | (defopfunc |(| prefix (push-paren '\))) | |
518 | (defopfunc |)| postfix (pop-paren '\))) | |
519 | (defopfunc |{| prefix (push-paren '\})) | |
520 | (defopfunc |}| postfix (pop-paren '\})) | |
521 | ||
522 | (defopfunc |(| postfix | |
523 | (get-token) | |
524 | (pushval (cons (popval) (and (not (eq *token* '|)|)) (parse-expr-list)))) | |
525 | (delim '|)|)) | |
526 | ||
527 | ;;;-------------------------------------------------------------------------- | |
528 | ;;; Various bits of special syntax. | |
529 | ||
530 | (defopfunc if operand | |
531 | "Parse an `if' form. Syntax: | |
532 | ||
0ff9df03 | 533 | IF ::= `if' CONDITION `then' CONSEQUENCE [`else' ALTERNATIVE] |
874125c4 | 534 | |
0ff9df03 MW |
535 | We parse this into an `if' where sensible, or into a `cond' if we see an |
536 | `else if' pair. The usual `dangling else' rule is followed." | |
874125c4 MW |
537 | (get-token) |
538 | (let (cond cons) | |
539 | (setf cond (parse-infix)) | |
540 | (delim 'then) | |
541 | (setf cons (parse-infix 0)) | |
542 | (if (not (eq *token* 'else)) | |
543 | (pushval (list 'if cond cons)) | |
544 | (progn | |
545 | (get-token) | |
546 | (cond ((not (eq *token* 'if)) | |
547 | (pushval (list 'if cond cons (parse-infix 0)))) | |
548 | (t | |
549 | (let ((clauses nil)) | |
550 | (flet ((clause (cond cons) | |
551 | (push (cons cond (strip-progn cons)) clauses))) | |
552 | (clause cond cons) | |
553 | (loop | |
554 | (get-token) | |
555 | (setf cond (parse-infix)) | |
556 | (delim 'then) | |
557 | (setf cons (parse-infix 0)) | |
558 | (clause cond cons) | |
559 | (unless (eq *token* 'else) (return)) | |
560 | (get-token) | |
561 | (if (eq *token* 'if) | |
562 | (get-token) | |
563 | (progn | |
564 | (clause t (parse-infix 0)) | |
565 | (return)))) | |
566 | (pushval (cons 'cond (nreverse clauses))))))))))) | |
567 | ||
568 | (defun do-letlike (kind) | |
569 | "Parse a `let' form. Syntax: | |
570 | ||
0ff9df03 MW |
571 | LET ::= `let' | `let*' VARS `in' EXPR |
572 | VARS ::= VAR | VARS `,' VAR | |
573 | VAR ::= NAME [`=' VALUE] | |
874125c4 | 574 | |
0ff9df03 | 575 | Translates into the obvious Lisp code." |
874125c4 MW |
576 | (let ((clauses nil) name value) |
577 | (get-token) | |
578 | (loop | |
579 | (unless (symbolp *token*) | |
580 | (error "symbol expected, found ~S" *token*)) | |
581 | (setf name *token*) | |
582 | (get-token) | |
583 | (if (eq *token* '=) | |
584 | (progn | |
585 | (get-token) | |
586 | (setf value (parse-infix 0)) | |
587 | (push (list name value) clauses)) | |
588 | (push name clauses)) | |
589 | (unless (eq *token* '|,|) | |
590 | (return)) | |
591 | (get-token)) | |
592 | (delim 'in) | |
593 | (pushval `(,kind ,(nreverse clauses) ,@(strip-progn (parse-infix 0)))))) | |
594 | (defopfunc let operand (do-letlike 'let)) | |
595 | (defopfunc let* operand (do-letlike 'let*)) | |
596 | ||
597 | (defopfunc when operand | |
598 | (get-token) | |
599 | (pushval `(when ,(parse-infix) | |
600 | ,@(progn (delim 'do) (strip-progn (parse-infix 0)))))) | |
601 | ||
602 | (defopfunc unless operand | |
603 | (get-token) | |
604 | (pushval `(unless ,(parse-infix) | |
605 | ,@(progn (delim 'do) (strip-progn (parse-infix 0)))))) | |
606 | ||
607 | (defopfunc loop operand | |
608 | (get-token) | |
609 | (pushval `(loop ,@(progn (strip-progn (parse-infix 0)))))) | |
610 | ||
611 | (defopfunc multiple-value-bind operand | |
612 | (get-token) | |
613 | (pushval `(multiple-value-bind | |
614 | ,(parse-ident-list) | |
615 | ,(progn (delim '=) (parse-infix)) | |
616 | ,@(progn (delim 'in) (strip-progn (parse-infix 0)))))) | |
617 | ||
618 | (defopfunc multiple-value-setq operand | |
619 | (get-token) | |
620 | (pushval `(multiple-value-setq | |
621 | ,(parse-ident-list) | |
622 | ,(progn (delim '=) (parse-infix 0))))) | |
623 | ||
624 | ;;;-------------------------------------------------------------------------- | |
625 | ;;; Parsing function bodies and lambda lists. | |
626 | ||
627 | (defun parse-lambda-list () | |
628 | "Parse an infix-form lambda list and return the Lisp equivalent." | |
629 | (flet ((ampersand-symbol-p (thing) | |
630 | (and (symbolp thing) | |
631 | (let ((name (symbol-name thing))) | |
632 | (plusp (length name)) | |
633 | (char= (char name 0) #\&)))) | |
634 | (get-lambda-token () | |
635 | (default-get-token) | |
636 | (when (or (eq *token* '&) | |
637 | (eq *token* '|(|)) | |
638 | (unread-char #\& *stream*) | |
639 | (setf *token* (read *stream* t nil t))))) | |
640 | (let ((args nil)) | |
641 | (let ((*get-token* #'get-lambda-token)) | |
642 | (delim '|(|) | |
643 | (unless (eq *token* '|)|) | |
644 | (tagbody | |
645 | loop | |
646 | (cond ((ampersand-symbol-p *token*) | |
647 | (push *token* args) | |
648 | (get-token) | |
649 | (when (eq *token* '|)|) | |
650 | (go done)) | |
651 | (delim '|,| :requiredp nil) | |
652 | (go loop)) | |
653 | ((symbolp *token*) | |
654 | (let ((name *token*)) | |
655 | (get-token) | |
656 | (if (delim '= :requiredp nil) | |
657 | (push (list name (parse-infix 0)) args) | |
658 | (push name args)))) | |
659 | (t | |
660 | (push *token* args) | |
661 | (get-token))) | |
662 | (when (delim '|,| :requiredp nil) | |
663 | (go loop)) | |
664 | done))) | |
665 | (delim '|)|) | |
666 | (nreverse args)))) | |
667 | ||
668 | (defun parse-func-name () | |
669 | "Parse a function name and return its Lisp equivalent." | |
670 | (cond ((delim '|(| :requiredp nil) | |
671 | (prog1 (parse-infix) (delim '|)|))) | |
672 | (t (prog1 *token* (get-token))))) | |
673 | ||
674 | (defopfunc lambda operand | |
675 | (get-token) | |
676 | (pushval `(lambda ,(parse-lambda-list) ,@(strip-progn (parse-infix 0))))) | |
677 | ||
678 | (defun do-defunlike (kind) | |
679 | "Process a defun-like form." | |
680 | (get-token) | |
681 | (pushval `(,kind ,(parse-func-name) ,(parse-lambda-list) | |
682 | ,@(strip-progn (parse-infix 0))))) | |
683 | ||
684 | (defopfunc defun operand (do-defunlike 'defun)) | |
685 | (defopfunc defmacro operand (do-defunlike 'defmacro)) | |
686 | ||
687 | (defun do-fletlike (kind) | |
688 | "Process a flet-like form." | |
689 | (get-token) | |
690 | (let ((clauses nil)) | |
691 | (loop | |
692 | (push `(,(parse-func-name) ,(parse-lambda-list) | |
693 | ,@(strip-progn (parse-infix 0))) | |
694 | clauses) | |
695 | (unless (delim '|,| :requiredp nil) | |
696 | (return))) | |
697 | (delim 'in) | |
698 | (pushval `(,kind ,(nreverse clauses) ,@(strip-progn (parse-infix 0)))))) | |
699 | ||
700 | (defopfunc flet operand (do-fletlike 'flet)) | |
701 | (defopfunc labels operand (do-fletlike 'labels)) | |
702 | ||
703 | ;;;-------------------------------------------------------------------------- | |
704 | ;;; User-interface stuff. | |
705 | ||
706 | (defun read-infix (&optional (*stream* *standard-input*) &key (delim eof)) | |
707 | "Reads an infix expression from STREAM and returns the corresponding Lisp. | |
0ff9df03 MW |
708 | Requires the expression to be delimited properly by DELIM (by default |
709 | end-of-file)." | |
874125c4 MW |
710 | (let (*token*) |
711 | (prog2 | |
712 | (get-token) | |
713 | (parse-infix) | |
714 | (unless (eq *token* delim) | |
715 | (error "expected ~S; found ~S" delim *token*))))) | |
716 | ||
717 | (defun install-infix-reader (&optional (char #\$)) | |
718 | "Installs a macro character `$ INFIX... $' for translating infix notation | |
0ff9df03 MW |
719 | to Lisp forms. You also want to (use-package :infix-keywords) if you do |
720 | this." | |
874125c4 MW |
721 | (let ((delim (intern (string #\$) 'infix-keywords))) |
722 | (set-macro-character char (lambda (stream ch) | |
723 | (declare (ignore ch)) | |
724 | (read-infix stream :delim delim))))) | |
725 | ||
726 | ;;;-------------------------------------------------------------------------- | |
727 | ;;; Testing things. | |
728 | ||
729 | (defun test-infix (string) | |
730 | (with-input-from-string (in string) | |
731 | (read-infix in))) | |
732 | ||
733 | (defun test-tokenize (string &optional (get-token #'get-token)) | |
734 | (with-input-from-string (*stream* string) | |
735 | (loop with *token* = nil | |
736 | do (funcall get-token) | |
737 | until (eq *token* eof) | |
738 | collect *token*))) | |
739 | ||
740 | (defun testrig (what run tests) | |
741 | (loop with ok = t | |
742 | with error = nil | |
743 | for (input . output) in tests | |
744 | for result = (handler-case (funcall run input) | |
745 | (error (err) | |
746 | (setf error (format nil "~A" err)) | |
747 | 'fail)) | |
748 | unless (equal result output) | |
749 | do (format t "~&~ | |
750 | *** ~S test failure | |
751 | input = ~S | |
752 | result = ~:[~S~*~;~*error ~A~] | |
753 | expected = ~S~%" | |
754 | what | |
755 | input | |
756 | (eq result 'fail) result error | |
757 | output) | |
758 | (setf ok nil) | |
759 | finally (return ok))) | |
760 | ||
761 | #+notdef | |
762 | (testrig "tokenize" #'test-tokenize | |
763 | '(("++z" . (++ z)) | |
764 | ("z++" . (z++)) | |
765 | ("z ++" . (z ++)) | |
766 | ("-5" . (- 5)) | |
767 | ("&optional" . (& optional)) | |
768 | ("(4)" . (|(| 4 |)|)))) | |
769 | ||
770 | #+notdef | |
771 | (testrig "infix" #'test-infix | |
772 | '(("5" . 5) | |
773 | ("-5" . (- 5)) | |
774 | ("-" . fail) | |
775 | ("1 + 1" . (+ 1 1)) | |
776 | ("(1" . fail) | |
777 | ("1)" . fail) | |
778 | ("1 + 2 + 3" . (+ 1 2 3)) | |
779 | ("++x" . (incf x)) | |
780 | ("x += 5" . (incf x 5)) | |
781 | ("1 << 5" . (ash 1 5)) | |
782 | ("1 >> 5" . (ash 1 (- 5))) | |
783 | ("1 & 5" . (logand 1 5)) | |
784 | ("lambda (x, y) x + y" . (lambda (x y) (+ x y))) | |
785 | ("lambda (x, y) (x += y, x - 1)" . (lambda (x y) (incf x y) (- x 1))) | |
786 | ("lambda (x, &optional y = 1) x - y" . | |
787 | (lambda (x &optional (y 1)) (- x y))) | |
788 | ("foo(x, y)" . (foo x y)) | |
789 | ("if a == b then x + y" . (if (= a b) (+ x y))) | |
790 | ("if a == b then x + y else x - y" . (if (= a b) (+ x y) (- x y))) | |
791 | ("if a == b then x + y else if a == -b then x - y" . | |
792 | (cond ((= a b) (+ x y)) ((= a (- b)) (- x y)))) | |
793 | ("let x = 1 in x ^ 4" . (let ((x 1)) (expt x 4))) | |
794 | ("x ^ y ^ z" . (expt x (expt y z))) | |
795 | ("a < b and not b < c or c > d" . | |
796 | (or (and (< a b) (not (< b c))) (> c d))) | |
797 | ("cdr(x) = nil" . (setf (cdr x) nil)) | |
798 | ("labels foo (x) x + 1, bar (x) x - 1 in foo(bar(y))". | |
799 | (labels ((foo (x) (+ x 1)) (bar (x) (- x 1))) (foo (bar y)))) | |
800 | ("defun foo (x) x - 6" . | |
801 | (defun foo (x) (- x 6))) | |
802 | ("multiple-value-bind x, y, z = values(4, 6, 8) in x + y + z" . | |
803 | (multiple-value-bind (x y z) (values 4 6 8) (+ x y z))))) | |
804 | ||
805 | ;;;-------------------------------------------------------------------------- | |
806 | ;;; Debugging guff. | |
807 | ||
808 | #+notdef | |
809 | (flet ((dotrace (func) | |
810 | (and func | |
811 | (trace :function func | |
812 | :encapsulate nil | |
813 | :print-all *token* | |
814 | :print-all *opstk* | |
815 | :print-all *valstk*)))) | |
816 | (untrace) | |
817 | (dolist (s '(if \( \) \:)) | |
818 | (dolist (p '(infix prefix postfix)) | |
819 | (let ((op (get s p))) | |
820 | (dotrace (etypecase op | |
821 | (function op) | |
822 | (operator (op-func op)) | |
823 | (null nil)))))) | |
824 | (dolist (f '(read-infix parse-infix binop-apply unop-apply pushval popval | |
825 | pushop flushops push-paren get-token)) | |
826 | (dotrace f))) | |
827 | ||
828 | ;;;-------------------------------------------------------------------------- |