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