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