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