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 | |
61 | and right precedences control operator stacking behaviour. The function is | |
62 | 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." | |
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 | |
91 | minprec restriction.") | |
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 | |
167 | equal to PREC. This is used when a new operator is pushed, to ensure that | |
168 | higher-precedence operators snarf their arguments." | |
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 | |
180 | left-precedence, then operators with higher precedence are flushed (see | |
181 | `flushops'). If the operator has no left-precedence, the operator is invoked immediately." | |
182 | (let ((lp (op-lprec op))) | |
183 | (when lp | |
184 | (flushops lp))) | |
185 | (if (op-rprec op) | |
186 | (push op *opstk*) | |
187 | (funcall (op-func op)))) | |
188 | ||
189 | ;;;-------------------------------------------------------------------------- | |
190 | ;;; The main parser. | |
191 | ||
192 | (defun infix-done () | |
193 | "Signal that `parse-infix' has reached the end of an expression. This is | |
194 | primarily used by the `)' handler function if it finds there are no | |
195 | parentheses." | |
196 | (throw 'infix-done nil)) | |
197 | ||
198 | (defun parse-infix (&optional minprec) | |
199 | "Parses an infix expression and return the resulting Lisp form. This is | |
200 | the heart of the whole thing. | |
201 | ||
202 | Expects a token to be ready in *token*; leaves *token* as the first token | |
203 | which couldn't be parsed. | |
204 | ||
205 | The syntax parsed by this function doesn't fit nicely into a BNF, since we | |
206 | parsing is effected by the precedences of the various operators. We have | |
207 | low-precedence prefix operators such as `not', for example." | |
208 | (flet ((lookup (items) | |
209 | (dolist (item items (values nil nil)) | |
210 | (let ((op (get *token* (car item)))) | |
211 | (when op (return (values op (cdr item)))))))) | |
212 | (let ((*valstk* nil) | |
213 | (*opstk* nil) | |
214 | (*paren-depth* 0) | |
215 | (state :operand)) | |
216 | (catch 'infix-done | |
217 | (loop | |
218 | (ecase state | |
219 | (:operand | |
220 | (when (eq *token* eof) | |
221 | (error "operand expected; found eof")) | |
222 | (typecase *token* | |
223 | (symbol | |
224 | (multiple-value-bind (op newstate) | |
225 | (lookup '((prefix . :operand) | |
226 | (operand . :operator))) | |
227 | (etypecase op | |
228 | (null | |
229 | (pushval *token*) | |
230 | (get-token) | |
231 | (setf state :operator)) | |
232 | (function | |
233 | (funcall op) | |
234 | (setf state newstate)) | |
235 | (operator | |
236 | (get-token) | |
237 | (pushop op))))) | |
238 | (t | |
239 | (pushval *token*) | |
240 | (get-token) | |
241 | (setf state :operator)))) | |
242 | (:operator | |
243 | (typecase *token* | |
244 | (symbol | |
245 | (multiple-value-bind (op newstate) | |
246 | (lookup '((infix . :operand) | |
247 | (postfix . :operator))) | |
248 | (etypecase op | |
249 | (null | |
250 | (return)) | |
251 | (function | |
252 | (funcall op)) | |
253 | (operator | |
254 | (when (and minprec | |
255 | (zerop *paren-depth*) | |
256 | (op-lprec op) | |
257 | (< (op-lprec op) minprec)) | |
258 | (return)) | |
259 | (get-token) | |
260 | (pushop op))) | |
261 | (setf state newstate))) | |
262 | (t | |
263 | (return))))))) | |
264 | (flushops most-negative-fixnum) | |
265 | (assert (and (consp *valstk*) | |
266 | (null (cdr *valstk*)))) | |
267 | (car *valstk*)))) | |
268 | ||
269 | ;;;-------------------------------------------------------------------------- | |
270 | ;;; Machinery for defining operators. | |
271 | ||
272 | (defmacro defopfunc (op kind &body body) | |
273 | "Defines a magical operator. The operator's name is the symbol OP. The | |
274 | KIND must be one of the symbols `infix', `prefix' or `postfix'. The body is | |
275 | evaluated when the operator is parsed, and must either push appropriate | |
276 | things on the operator stack or do its own parsing and push a result on the | |
277 | value stack." | |
278 | `(progn | |
279 | (setf (get ',op ',kind) | |
280 | (lambda () ,@body)) | |
281 | ',op)) | |
282 | ||
283 | (defmacro definfix (op prec &body body) | |
284 | "Defines an infix operator. The operator's name is the symbol OP. The | |
285 | operator's precedence is specified by PREC, which may be one of the | |
286 | following: | |
287 | ||
288 | * PREC -- equivalent to (:lassoc PREC) | |
289 | * (:lassoc PREC) -- left-associative with precedence PREC | |
290 | * (:rassoc PREC) -- right-associative with precedence PREC | |
291 | * (LPREC . RPREC) -- independent left- and right-precedences | |
292 | * (LPREC RPREC) -- synonym for the dotted form | |
293 | ||
294 | In fact, (:lassoc PREC) is the same as (PREC . PREC), and (:rassoc PREC) is | |
295 | the same as (PREC . (1- PREC)). | |
296 | ||
297 | The BODY is evaluated when the operator's arguments are fully resolved. It | |
298 | should pop off two arguments and push one result. Nobody will check that | |
299 | this is done correctly." | |
300 | (multiple-value-bind | |
301 | (lprec rprec) | |
302 | (flet ((bad () | |
303 | (error "bad precedence spec ~S" prec))) | |
304 | (cond ((integerp prec) | |
305 | (values prec prec)) | |
306 | ((not (consp prec)) | |
307 | (bad)) | |
308 | ((and (integerp (car prec)) | |
309 | (integerp (cdr prec))) | |
310 | (values (car prec) (cdr prec))) | |
311 | ((or (not (consp (cdr prec))) | |
312 | (not (integerp (cadr prec))) | |
313 | (not (null (cddr prec)))) | |
314 | (bad)) | |
315 | ((integerp (car prec)) | |
316 | (values (car prec) (cadr prec))) | |
317 | ((eq (car prec) :lassoc) | |
318 | (values (cadr prec) (cadr prec))) | |
319 | ((eq (car prec) :rassoc) | |
320 | (values (cadr prec) (1- (cadr prec)))) | |
321 | (t | |
322 | (bad)))) | |
323 | `(progn | |
324 | (setf (get ',op 'infix) | |
325 | (make-operator :name ',op | |
326 | :lprec ,lprec :rprec ,rprec | |
327 | :func (lambda () ,@body))) | |
328 | ',op))) | |
329 | ||
330 | (eval-when (:compile-toplevel :load-toplevel) | |
331 | (defun do-defunary (kind op prec body) | |
332 | (unless (integerp prec) | |
333 | (error "bad precedence spec ~S" prec)) | |
334 | `(progn | |
335 | (setf (get ',op ',kind) | |
336 | (make-operator :name ',op | |
337 | ,(ecase kind | |
338 | (prefix :rprec) | |
339 | (postfix :lprec)) ,prec | |
340 | :func (lambda () ,@body))) | |
341 | ',op))) | |
342 | (defmacro defprefix (op prec &body body) | |
343 | "Defines a prefix operator. The operator's name is the symbol OP. The | |
344 | operator's (right) precedence is PREC. The body is evaluated with the | |
345 | operator's argument is fully determined. It should pop off one argument and | |
346 | push one result." | |
347 | (do-defunary 'prefix op prec body)) | |
348 | (defmacro defpostfix (op prec &body body) | |
349 | "Defines a postfix operator. The operator's name is the symbol OP. The | |
350 | operator's (left) precedence is PREC. The body is evaluated with the | |
351 | operator's argument is fully determined. It should pop off one argument and | |
352 | push one result." | |
353 | (do-defunary 'postfix op prec body)) | |
354 | ||
355 | ;;;-------------------------------------------------------------------------- | |
356 | ;;; Infrastructure for operator definitions. | |
357 | ||
358 | (defun delim (delim &key (requiredp t)) | |
359 | "Parse DELIM, and read the next token. Returns t if the DELIM was found, | |
360 | or nil if not (and requiredp was nil)." | |
361 | (cond ((eq *token* delim) (get-token) t) | |
362 | (requiredp (error "expected `~(~A~)'; found ~S" delim *token*)) | |
363 | (t nil))) | |
364 | ||
365 | (defun errfunc (&rest args) | |
366 | "Returns a function which reports an error. Useful when constructing | |
367 | operators by hand." | |
368 | (lambda () (apply #'error args))) | |
369 | ||
370 | (defun binop-apply (name) | |
371 | "Apply the Lisp binop NAME to the top two items on the value stack; i.e., | |
372 | if the top two items are Y and X, then we push (NAME X Y)." | |
373 | (let ((y (popval)) (x (popval))) | |
374 | (pushval (list name x y)))) | |
375 | ||
376 | (defun binop-apply-append (name) | |
377 | "As for `binop-apply' but if the second-from-top item on the stack has the | |
378 | form (NAME SOMETHING ...) then fold the top item into the form rather than | |
379 | buidling another." | |
380 | (let ((y (popval)) (x (popval))) | |
381 | (pushval (if (and (consp x) (eq (car x) name)) | |
382 | (append x (list y)) | |
383 | (list name x y))))) | |
384 | ||
385 | (defun unop-apply (name) | |
386 | "Apply the Lisp unop NAME to the top item on the value stack; i.e., if the | |
387 | top item is X, then push (NAME X)." | |
388 | (pushval (list name (popval)))) | |
389 | (defun unop-apply-toggle (name) | |
390 | "As for `unop-apply', but if the top item has the form (NAME X) already, | |
391 | then push just X." | |
392 | (let ((x (popval))) | |
393 | (pushval (if (and (consp x) | |
394 | (eq (car x) name) | |
395 | (consp (cdr x)) | |
396 | (null (cddr x))) | |
397 | (cadr x) | |
398 | (list name x))))) | |
399 | ||
400 | (defun strip-progn (form) | |
401 | "Return a version of FORM suitable for putting somewhere where there's an | |
402 | implicit `progn'. If FORM has the form (PROGN . FOO) then return FOO, | |
403 | otherwise return (FORM)." | |
404 | (if (and (consp form) | |
405 | (eq (car form) 'progn)) | |
406 | (cdr form) | |
407 | (list form))) | |
408 | ||
409 | (defun parse-expr-list () | |
410 | "Parse a list of expressions separated by commas." | |
411 | (let ((stuff nil)) | |
412 | (loop | |
413 | (push (parse-infix 0) stuff) | |
414 | (unless (delim '|,| :requiredp nil) | |
415 | (return))) | |
416 | (nreverse stuff))) | |
417 | ||
418 | (defun parse-ident-list () | |
419 | "Parse a list of symbols separated by commas." | |
420 | (let ((stuff nil)) | |
421 | (loop | |
422 | (unless (symbolp *token*) | |
423 | (error "expected symbol; found ~S" *token*)) | |
424 | (push *token* stuff) | |
425 | (get-token) | |
426 | (unless (delim '|,| :requiredp nil) | |
427 | (return))) | |
428 | (nreverse stuff))) | |
429 | ||
430 | ;;;-------------------------------------------------------------------------- | |
431 | ;;; Various simple operators. | |
432 | ||
433 | (definfix |,| (:lassoc -1) (binop-apply-append 'progn)) | |
434 | ||
435 | (definfix or (:lassoc 10) (binop-apply-append 'or)) | |
436 | (definfix and (:lassoc 15) (binop-apply-append 'and)) | |
437 | ||
438 | (defprefix not 19 (unop-apply-toggle 'not)) | |
439 | ||
440 | (definfix == (:lassoc 20) (binop-apply-append '=)) | |
441 | (definfix /= (:lassoc 20) (binop-apply-append '/=)) | |
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 eq (:lassoc 20) (binop-apply-append 'eq)) | |
447 | (definfix eql (:lassoc 20) (binop-apply-append 'eql)) | |
448 | (definfix equal (:lassoc 20) (binop-apply-append 'equal)) | |
449 | (definfix equalp (:lassoc 20) (binop-apply-append 'equalp)) | |
450 | ||
451 | (definfix \| (:lassoc 30) (binop-apply-append 'logior)) | |
452 | (definfix xor (:lassoc 30) (binop-apply-append 'logxor)) | |
453 | (definfix & (:lassoc 35) (binop-apply-append 'logand)) | |
454 | ||
455 | (definfix << (:lassoc 40) (binop-apply 'ash)) | |
456 | (definfix >> (:lassoc 40) (unop-apply-toggle '-) (binop-apply 'ash)) | |
457 | ||
458 | (definfix + (:lassoc 50) (binop-apply-append '+)) | |
459 | (definfix - (:lassoc 50) (binop-apply-append '-)) | |
460 | ||
461 | (definfix * (:lassoc 60) (binop-apply-append '*)) | |
462 | (definfix / (:lassoc 60) (binop-apply '/)) | |
463 | (definfix // (:lassoc 60) (binop-apply 'floor)) | |
464 | (definfix % (:lassoc 60) (binop-apply 'mod)) | |
465 | ||
466 | (definfix ^ (:rassoc 70) (binop-apply 'expt)) | |
467 | ||
468 | (definfix = (120 . 5) (binop-apply 'setf)) | |
469 | (definfix += (120 . 5) (binop-apply 'incf)) | |
470 | (definfix -= (120 . 5) (binop-apply 'decf)) | |
471 | ||
472 | (defprefix + 100 nil) | |
473 | (defprefix - 100 (unop-apply-toggle '-)) | |
474 | (defprefix ~ 100 (unop-apply-toggle 'lognot)) | |
475 | ||
476 | (defprefix ++ 100 (unop-apply 'incf)) | |
477 | (defprefix -- 100 (unop-apply 'decf)) | |
478 | ||
479 | ;;(defpostfix ! 110 (unop-apply 'factorial)) | |
480 | ||
481 | (defopfunc @ operand | |
482 | "An escape to the standard Lisp reader." | |
483 | (pushval (read *stream* t nil t)) | |
484 | (get-token)) | |
485 | ||
486 | ;;;-------------------------------------------------------------------------- | |
487 | ;;; Parentheses, for grouping and function-calls. | |
488 | ||
489 | (defun push-paren (right) | |
490 | "Pushes a funny parenthesis operator. Since this operator has no left | |
491 | precedence, and very low right precedence, it is pushed over any stack of | |
492 | operators and can only be popped by magic or end-of-file. In the latter | |
493 | case, cause an error." | |
494 | (pushop (make-operator :name right | |
495 | :lprec nil :rprec -1000 | |
496 | :func (errfunc "missing `~A'" right))) | |
497 | (incf *paren-depth*) | |
498 | (get-token)) | |
499 | ||
500 | (defun pop-paren (right) | |
501 | "Pops a parenthesis. If there are no parentheses, maybe they belong to the | |
502 | caller's syntax. Otherwise, pop off operators above the current funny | |
503 | parenthesis operator, and then remove it." | |
504 | (when (zerop *paren-depth*) | |
505 | (infix-done)) | |
506 | (flushops -999) | |
507 | (assert *opstk*) | |
508 | (unless (eq (op-name (car *opstk*)) right) | |
509 | (error "spurious `~A'" right)) | |
510 | (assert (plusp *paren-depth*)) | |
511 | (decf *paren-depth*) | |
512 | (pop *opstk*) | |
513 | (get-token)) | |
514 | ||
515 | (defopfunc |(| prefix (push-paren '\))) | |
516 | (defopfunc |)| postfix (pop-paren '\))) | |
517 | (defopfunc |{| prefix (push-paren '\})) | |
518 | (defopfunc |}| postfix (pop-paren '\})) | |
519 | ||
520 | (defopfunc |(| postfix | |
521 | (get-token) | |
522 | (pushval (cons (popval) (and (not (eq *token* '|)|)) (parse-expr-list)))) | |
523 | (delim '|)|)) | |
524 | ||
525 | ;;;-------------------------------------------------------------------------- | |
526 | ;;; Various bits of special syntax. | |
527 | ||
528 | (defopfunc if operand | |
529 | "Parse an `if' form. Syntax: | |
530 | ||
531 | IF ::= `if' CONDITION `then' CONSEQUENCE [`else' ALTERNATIVE] | |
532 | ||
533 | We parse this into an `if' where sensible, or into a `cond' if we see an | |
534 | `else if' pair. The usual `dangling else' rule is followed." | |
535 | (get-token) | |
536 | (let (cond cons) | |
537 | (setf cond (parse-infix)) | |
538 | (delim 'then) | |
539 | (setf cons (parse-infix 0)) | |
540 | (if (not (eq *token* 'else)) | |
541 | (pushval (list 'if cond cons)) | |
542 | (progn | |
543 | (get-token) | |
544 | (cond ((not (eq *token* 'if)) | |
545 | (pushval (list 'if cond cons (parse-infix 0)))) | |
546 | (t | |
547 | (let ((clauses nil)) | |
548 | (flet ((clause (cond cons) | |
549 | (push (cons cond (strip-progn cons)) clauses))) | |
550 | (clause cond cons) | |
551 | (loop | |
552 | (get-token) | |
553 | (setf cond (parse-infix)) | |
554 | (delim 'then) | |
555 | (setf cons (parse-infix 0)) | |
556 | (clause cond cons) | |
557 | (unless (eq *token* 'else) (return)) | |
558 | (get-token) | |
559 | (if (eq *token* 'if) | |
560 | (get-token) | |
561 | (progn | |
562 | (clause t (parse-infix 0)) | |
563 | (return)))) | |
564 | (pushval (cons 'cond (nreverse clauses))))))))))) | |
565 | ||
566 | (defun do-letlike (kind) | |
567 | "Parse a `let' form. Syntax: | |
568 | ||
569 | LET ::= `let' | `let*' VARS `in' EXPR | |
570 | VARS ::= VAR | VARS `,' VAR | |
571 | VAR ::= NAME [`=' VALUE] | |
572 | ||
573 | Translates into the obvious Lisp code." | |
574 | (let ((clauses nil) name value) | |
575 | (get-token) | |
576 | (loop | |
577 | (unless (symbolp *token*) | |
578 | (error "symbol expected, found ~S" *token*)) | |
579 | (setf name *token*) | |
580 | (get-token) | |
581 | (if (eq *token* '=) | |
582 | (progn | |
583 | (get-token) | |
584 | (setf value (parse-infix 0)) | |
585 | (push (list name value) clauses)) | |
586 | (push name clauses)) | |
587 | (unless (eq *token* '|,|) | |
588 | (return)) | |
589 | (get-token)) | |
590 | (delim 'in) | |
591 | (pushval `(,kind ,(nreverse clauses) ,@(strip-progn (parse-infix 0)))))) | |
592 | (defopfunc let operand (do-letlike 'let)) | |
593 | (defopfunc let* operand (do-letlike 'let*)) | |
594 | ||
595 | (defopfunc when operand | |
596 | (get-token) | |
597 | (pushval `(when ,(parse-infix) | |
598 | ,@(progn (delim 'do) (strip-progn (parse-infix 0)))))) | |
599 | ||
600 | (defopfunc unless operand | |
601 | (get-token) | |
602 | (pushval `(unless ,(parse-infix) | |
603 | ,@(progn (delim 'do) (strip-progn (parse-infix 0)))))) | |
604 | ||
605 | (defopfunc loop operand | |
606 | (get-token) | |
607 | (pushval `(loop ,@(progn (strip-progn (parse-infix 0)))))) | |
608 | ||
609 | (defopfunc multiple-value-bind operand | |
610 | (get-token) | |
611 | (pushval `(multiple-value-bind | |
612 | ,(parse-ident-list) | |
613 | ,(progn (delim '=) (parse-infix)) | |
614 | ,@(progn (delim 'in) (strip-progn (parse-infix 0)))))) | |
615 | ||
616 | (defopfunc multiple-value-setq operand | |
617 | (get-token) | |
618 | (pushval `(multiple-value-setq | |
619 | ,(parse-ident-list) | |
620 | ,(progn (delim '=) (parse-infix 0))))) | |
621 | ||
622 | ;;;-------------------------------------------------------------------------- | |
623 | ;;; Parsing function bodies and lambda lists. | |
624 | ||
625 | (defun parse-lambda-list () | |
626 | "Parse an infix-form lambda list and return the Lisp equivalent." | |
627 | (flet ((ampersand-symbol-p (thing) | |
628 | (and (symbolp thing) | |
629 | (let ((name (symbol-name thing))) | |
630 | (plusp (length name)) | |
631 | (char= (char name 0) #\&)))) | |
632 | (get-lambda-token () | |
633 | (default-get-token) | |
634 | (when (or (eq *token* '&) | |
635 | (eq *token* '|(|)) | |
636 | (unread-char #\& *stream*) | |
637 | (setf *token* (read *stream* t nil t))))) | |
638 | (let ((args nil)) | |
639 | (let ((*get-token* #'get-lambda-token)) | |
640 | (delim '|(|) | |
641 | (unless (eq *token* '|)|) | |
642 | (tagbody | |
643 | loop | |
644 | (cond ((ampersand-symbol-p *token*) | |
645 | (push *token* args) | |
646 | (get-token) | |
647 | (when (eq *token* '|)|) | |
648 | (go done)) | |
649 | (delim '|,| :requiredp nil) | |
650 | (go loop)) | |
651 | ((symbolp *token*) | |
652 | (let ((name *token*)) | |
653 | (get-token) | |
654 | (if (delim '= :requiredp nil) | |
655 | (push (list name (parse-infix 0)) args) | |
656 | (push name args)))) | |
657 | (t | |
658 | (push *token* args) | |
659 | (get-token))) | |
660 | (when (delim '|,| :requiredp nil) | |
661 | (go loop)) | |
662 | done))) | |
663 | (delim '|)|) | |
664 | (nreverse args)))) | |
665 | ||
666 | (defun parse-func-name () | |
667 | "Parse a function name and return its Lisp equivalent." | |
668 | (cond ((delim '|(| :requiredp nil) | |
669 | (prog1 (parse-infix) (delim '|)|))) | |
670 | (t (prog1 *token* (get-token))))) | |
671 | ||
672 | (defopfunc lambda operand | |
673 | (get-token) | |
674 | (pushval `(lambda ,(parse-lambda-list) ,@(strip-progn (parse-infix 0))))) | |
675 | ||
676 | (defun do-defunlike (kind) | |
677 | "Process a defun-like form." | |
678 | (get-token) | |
679 | (pushval `(,kind ,(parse-func-name) ,(parse-lambda-list) | |
680 | ,@(strip-progn (parse-infix 0))))) | |
681 | ||
682 | (defopfunc defun operand (do-defunlike 'defun)) | |
683 | (defopfunc defmacro operand (do-defunlike 'defmacro)) | |
684 | ||
685 | (defun do-fletlike (kind) | |
686 | "Process a flet-like form." | |
687 | (get-token) | |
688 | (let ((clauses nil)) | |
689 | (loop | |
690 | (push `(,(parse-func-name) ,(parse-lambda-list) | |
691 | ,@(strip-progn (parse-infix 0))) | |
692 | clauses) | |
693 | (unless (delim '|,| :requiredp nil) | |
694 | (return))) | |
695 | (delim 'in) | |
696 | (pushval `(,kind ,(nreverse clauses) ,@(strip-progn (parse-infix 0)))))) | |
697 | ||
698 | (defopfunc flet operand (do-fletlike 'flet)) | |
699 | (defopfunc labels operand (do-fletlike 'labels)) | |
700 | ||
701 | ;;;-------------------------------------------------------------------------- | |
702 | ;;; User-interface stuff. | |
703 | ||
704 | (defun read-infix (&optional (*stream* *standard-input*) &key (delim eof)) | |
705 | "Reads an infix expression from STREAM and returns the corresponding Lisp. | |
706 | Requires the expression to be delimited properly by DELIM (by default | |
707 | end-of-file)." | |
708 | (let (*token*) | |
709 | (prog2 | |
710 | (get-token) | |
711 | (parse-infix) | |
712 | (unless (eq *token* delim) | |
713 | (error "expected ~S; found ~S" delim *token*))))) | |
714 | ||
715 | (defun install-infix-reader (&optional (char #\$)) | |
716 | "Installs a macro character `$ INFIX... $' for translating infix notation | |
717 | to Lisp forms. You also want to (use-package :infix-keywords) if you do | |
718 | this." | |
719 | (let ((delim (intern (string #\$) 'infix-keywords))) | |
720 | (set-macro-character char (lambda (stream ch) | |
721 | (declare (ignore ch)) | |
722 | (read-infix stream :delim delim))))) | |
723 | ||
724 | ;;;-------------------------------------------------------------------------- | |
725 | ;;; Testing things. | |
726 | ||
727 | (defun test-infix (string) | |
728 | (with-input-from-string (in string) | |
729 | (read-infix in))) | |
730 | ||
731 | (defun test-tokenize (string &optional (get-token #'get-token)) | |
732 | (with-input-from-string (*stream* string) | |
733 | (loop with *token* = nil | |
734 | do (funcall get-token) | |
735 | until (eq *token* eof) | |
736 | collect *token*))) | |
737 | ||
738 | (defun testrig (what run tests) | |
739 | (loop with ok = t | |
740 | with error = nil | |
741 | for (input . output) in tests | |
742 | for result = (handler-case (funcall run input) | |
743 | (error (err) | |
744 | (setf error (format nil "~A" err)) | |
745 | 'fail)) | |
746 | unless (equal result output) | |
747 | do (format t "~&~ | |
748 | *** ~S test failure | |
749 | input = ~S | |
750 | result = ~:[~S~*~;~*error ~A~] | |
751 | expected = ~S~%" | |
752 | what | |
753 | input | |
754 | (eq result 'fail) result error | |
755 | output) | |
756 | (setf ok nil) | |
757 | finally (return ok))) | |
758 | ||
759 | #+notdef | |
760 | (testrig "tokenize" #'test-tokenize | |
761 | '(("++z" . (++ z)) | |
762 | ("z++" . (z++)) | |
763 | ("z ++" . (z ++)) | |
764 | ("-5" . (- 5)) | |
765 | ("&optional" . (& optional)) | |
766 | ("(4)" . (|(| 4 |)|)))) | |
767 | ||
768 | #+notdef | |
769 | (testrig "infix" #'test-infix | |
770 | '(("5" . 5) | |
771 | ("-5" . (- 5)) | |
772 | ("-" . fail) | |
773 | ("1 + 1" . (+ 1 1)) | |
774 | ("(1" . fail) | |
775 | ("1)" . fail) | |
776 | ("1 + 2 + 3" . (+ 1 2 3)) | |
777 | ("++x" . (incf x)) | |
778 | ("x += 5" . (incf x 5)) | |
779 | ("1 << 5" . (ash 1 5)) | |
780 | ("1 >> 5" . (ash 1 (- 5))) | |
781 | ("1 & 5" . (logand 1 5)) | |
782 | ("lambda (x, y) x + y" . (lambda (x y) (+ x y))) | |
783 | ("lambda (x, y) (x += y, x - 1)" . (lambda (x y) (incf x y) (- x 1))) | |
784 | ("lambda (x, &optional y = 1) x - y" . | |
785 | (lambda (x &optional (y 1)) (- x y))) | |
786 | ("foo(x, y)" . (foo x y)) | |
787 | ("if a == b then x + y" . (if (= a b) (+ x y))) | |
788 | ("if a == b then x + y else x - y" . (if (= a b) (+ x y) (- x y))) | |
789 | ("if a == b then x + y else if a == -b then x - y" . | |
790 | (cond ((= a b) (+ x y)) ((= a (- b)) (- x y)))) | |
791 | ("let x = 1 in x ^ 4" . (let ((x 1)) (expt x 4))) | |
792 | ("x ^ y ^ z" . (expt x (expt y z))) | |
793 | ("a < b and not b < c or c > d" . | |
794 | (or (and (< a b) (not (< b c))) (> c d))) | |
795 | ("cdr(x) = nil" . (setf (cdr x) nil)) | |
796 | ("labels foo (x) x + 1, bar (x) x - 1 in foo(bar(y))". | |
797 | (labels ((foo (x) (+ x 1)) (bar (x) (- x 1))) (foo (bar y)))) | |
798 | ("defun foo (x) x - 6" . | |
799 | (defun foo (x) (- x 6))) | |
800 | ("multiple-value-bind x, y, z = values(4, 6, 8) in x + y + z" . | |
801 | (multiple-value-bind (x y z) (values 4 6 8) (+ x y z))))) | |
802 | ||
803 | ;;;-------------------------------------------------------------------------- | |
804 | ;;; Debugging guff. | |
805 | ||
806 | #+notdef | |
807 | (flet ((dotrace (func) | |
808 | (and func | |
809 | (trace :function func | |
810 | :encapsulate nil | |
811 | :print-all *token* | |
812 | :print-all *opstk* | |
813 | :print-all *valstk*)))) | |
814 | (untrace) | |
815 | (dolist (s '(if \( \) \:)) | |
816 | (dolist (p '(infix prefix postfix)) | |
817 | (let ((op (get s p))) | |
818 | (dotrace (etypecase op | |
819 | (function op) | |
820 | (operator (op-func op)) | |
821 | (null nil)))))) | |
822 | (dolist (f '(read-infix parse-infix binop-apply unop-apply pushval popval | |
823 | pushop flushops push-paren get-token)) | |
824 | (dotrace f))) | |
825 | ||
826 | ;;;-------------------------------------------------------------------------- |