3 ;;; Infix-to-S-exp translation
5 ;;; (c) 2006 Mark Wooding
8 ;;;----- Licensing notice ---------------------------------------------------
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.
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.
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.
24 ;;;--------------------------------------------------------------------------
27 (defpackage #:infix-keywords
29 (:export #:|(| #:|)| #:{ #:} #:|,| #:@ #:|$| #:& #:\| #:~
30 #:and #:or #:not #:xor
31 #:== #:/= #:< #:<= #:> #:>= #:eq #:eql #:equal #:equalp
32 #:+ #:- #:* #:/ #:// #:% #:^ #:= #:!
33 #:+= #:-= #:*= #:%= #:&= #:\|= #:xor= #:<<= #:>>=
40 (:use #:common-lisp #:infix-keywords)
41 (:export #:operator #:operatorp
42 #:*token* #:get-token #:*get-token*
43 #:pushval #:popval #:flushops #:pushop
44 #:infix-done #:parse-infix
45 #:defopfunc #:definfix #:defprefix #:defpostfix
46 #:infix #:prefix #:postfix #:operand
48 #:binop-apply #:binop-apply-append
49 #:unop-apply #:unop-apply-toggle
51 #:read-infix #:install-infix-reader))
55 ;;;--------------------------------------------------------------------------
58 (defstruct (operator (:predicate operatorp)
60 "An operator object. The name serves mainly for documentation. The left
61 and right precedences control operator stacking behaviour. The function
62 is called when this operator is popped off the stack.
64 If the left precedence is not nil, then operators currently on the stack
65 whose /right/-precedence is greater than or equal to this operator's
66 /left/-precedence are popped before this operator can be pushed. If the
67 right precedence is nil, then this operator is not in fact pushed, but
68 processed immediately."
69 (name nil :type symbol)
70 (lprec nil :type (or fixnum null))
71 (rprec nil :type (or fixnum null))
72 (func (lambda () nil) :type (function () t)))
74 ;;;--------------------------------------------------------------------------
75 ;;; Global parser state.
78 "The parser input stream. Bound automatically by `read-infix'.")
80 ;;;--------------------------------------------------------------------------
81 ;;; State for one level of `parse-infix'.
84 "Value stack. Contains (partially constructed) Lisp forms.")
86 "Operator stack. Contains operator objects.")
88 "The current token. Could be any Lisp object.")
89 (defvar *paren-depth* 0
90 "Depth of parentheses in the current `parse-infix'. Used to override the
91 minprec restriction.")
93 ;;;--------------------------------------------------------------------------
96 (defconstant eof (cons :eof nil)
97 "A magical object which `get-token' returns at end-of-file.")
99 (defun default-get-token ()
100 "Read a token from *stream* and store it in *token*."
101 (flet ((whitespacep (ch)
102 (member ch '(#\newline #\space #\tab #\page)))
104 (member ch '(#\; #\, #\: #\( #\) #\@ #\$ #\[ #\] #\{ #\})))
106 (member ch '(#\# #\| #\\ #\" #\' #\`)))
109 (return-from default-get-token)))
113 (setf ch (read-char *stream* nil nil t))
114 (cond ((null ch) (done eof))
115 ((whitespacep ch) (go top))
116 ((eql ch #\;) (go comment))
117 ((self-delim-p ch) (done (intern (string ch)
119 ((or (macro-char-p ch) (alphanumericp ch)) (go read))
122 (unread-char ch *stream*)
123 (done (read *stream* t nil t))
125 (done (intern (with-output-to-string (out)
128 (setf ch (read-char *stream* nil nil t))
132 ((or (self-delim-p ch)
135 (unread-char ch *stream*)
138 (write-char ch out)))))
142 (case (setf ch (read-char *stream* nil nil t))
144 ((#\newline) (go top))
145 (t (go comment)))))))
147 (defvar *get-token* #'default-get-token
148 "The current tokenizing function.")
151 "Read a token, and store it in *token*. Indirects via *get-token*."
152 (funcall *get-token*))
154 ;;;--------------------------------------------------------------------------
155 ;;; Stack manipulation.
158 "Push VAL onto the value stack."
162 "Pop a value off the value stack and return it."
165 (defun flushops (prec)
166 "Flush out operators on the operator stack with precedecnce higher than or
167 equal to PREC. This is used when a new operator is pushed, to ensure that
168 higher-precedence operators snarf their arguments."
172 (let ((head (car *opstk*)))
173 (when (> prec (op-rprec head))
176 (funcall (op-func head)))))
179 "Push the operator OP onto the stack. If the operator has a
180 left-precedence, then operators with higher precedence are flushed (see
181 `flushops'). If the operator has no left-precedence, the operator is
182 invoked immediately."
183 (let ((lp (op-lprec op)))
188 (funcall (op-func op))))
190 ;;;--------------------------------------------------------------------------
194 "Signal that `parse-infix' has reached the end of an expression. This is
195 primarily used by the `)' handler function if it finds there are no
197 (throw 'infix-done nil))
199 (defun parse-infix (&optional minprec)
200 "Parses an infix expression and return the resulting Lisp form. This is
201 the heart of the whole thing.
203 Expects a token to be ready in *token*; leaves *token* as the first token
204 which couldn't be parsed.
206 The syntax parsed by this function doesn't fit nicely into a BNF, since we
207 parsing is effected by the precedences of the various operators. We have
208 low-precedence prefix operators such as `not', for example."
209 (flet ((lookup (items)
210 (dolist (item items (values nil nil))
211 (let ((op (get *token* (car item))))
212 (when op (return (values op (cdr item))))))))
221 (when (eq *token* eof)
222 (error "operand expected; found eof"))
225 (multiple-value-bind (op newstate)
226 (lookup '((prefix . :operand)
227 (operand . :operator)))
232 (setf state :operator))
235 (setf state newstate))
242 (setf state :operator))))
246 (multiple-value-bind (op newstate)
247 (lookup '((infix . :operand)
248 (postfix . :operator)))
256 (zerop *paren-depth*)
258 (< (op-lprec op) minprec))
262 (setf state newstate)))
265 (flushops most-negative-fixnum)
266 (assert (and (consp *valstk*)
267 (null (cdr *valstk*))))
270 ;;;--------------------------------------------------------------------------
271 ;;; Machinery for defining operators.
273 (defmacro defopfunc (op kind &body body)
274 "Defines a magical operator. The operator's name is the symbol OP. The
275 KIND must be one of the symbols `infix', `prefix' or `postfix'. The body
276 is evaluated when the operator is parsed, and must either push appropriate
277 things on the operator stack or do its own parsing and push a result on
280 (setf (get ',op ',kind)
284 (defmacro definfix (op prec &body body)
285 "Defines an infix operator. The operator's name is the symbol OP. The
286 operator's precedence is specified by PREC, which may be one of the
289 * PREC -- equivalent to (:lassoc PREC)
290 * (:lassoc PREC) -- left-associative with precedence PREC
291 * (:rassoc PREC) -- right-associative with precedence PREC
292 * (LPREC . RPREC) -- independent left- and right-precedences
293 * (LPREC RPREC) -- synonym for the dotted form
295 In fact, (:lassoc PREC) is the same as (PREC . PREC), and (:rassoc PREC)
296 is the same as (PREC . (1- PREC)).
298 The BODY is evaluated when the operator's arguments are fully resolved.
299 It should pop off two arguments and push one result. Nobody will check
300 that this is done correctly."
304 (error "bad precedence spec ~S" prec)))
305 (cond ((integerp prec)
309 ((and (integerp (car prec))
310 (integerp (cdr prec)))
311 (values (car prec) (cdr prec)))
312 ((or (not (consp (cdr prec)))
313 (not (integerp (cadr prec)))
314 (not (null (cddr prec))))
316 ((integerp (car prec))
317 (values (car prec) (cadr prec)))
318 ((eq (car prec) :lassoc)
319 (values (cadr prec) (cadr prec)))
320 ((eq (car prec) :rassoc)
321 (values (cadr prec) (1- (cadr prec))))
325 (setf (get ',op 'infix)
326 (make-operator :name ',op
327 :lprec ,lprec :rprec ,rprec
328 :func (lambda () ,@body)))
331 (eval-when (:compile-toplevel :load-toplevel)
332 (defun do-defunary (kind op prec body)
333 (unless (integerp prec)
334 (error "bad precedence spec ~S" prec))
336 (setf (get ',op ',kind)
337 (make-operator :name ',op
340 (postfix :lprec)) ,prec
341 :func (lambda () ,@body)))
343 (defmacro defprefix (op prec &body body)
344 "Defines a prefix operator. The operator's name is the symbol OP. The
345 operator's (right) precedence is PREC. The body is evaluated with the
346 operator's argument is fully determined. It should pop off one argument
347 and push one result."
348 (do-defunary 'prefix op prec body))
349 (defmacro defpostfix (op prec &body body)
350 "Defines a postfix operator. The operator's name is the symbol OP. The
351 operator's (left) precedence is PREC. The body is evaluated with the
352 operator's argument is fully determined. It should pop off one argument
353 and push one result."
354 (do-defunary 'postfix op prec body))
356 ;;;--------------------------------------------------------------------------
357 ;;; Infrastructure for operator definitions.
359 (defun delim (delim &key (requiredp t))
360 "Parse DELIM, and read the next token. Returns t if the DELIM was found,
361 or nil if not (and requiredp was nil)."
362 (cond ((eq *token* delim) (get-token) t)
363 (requiredp (error "expected `~(~A~)'; found ~S" delim *token*))
366 (defun errfunc (&rest args)
367 "Returns a function which reports an error. Useful when constructing
369 (lambda () (apply #'error args)))
371 (defun binop-apply (name)
372 "Apply the Lisp binop NAME to the top two items on the value stack; i.e.,
373 if the top two items are Y and X, then we push (NAME X Y)."
374 (let ((y (popval)) (x (popval)))
375 (pushval (list name x y))))
377 (defun binop-apply-append (name)
378 "As for `binop-apply' but if the second-from-top item on the stack has the
379 form (NAME SOMETHING ...) then fold the top item into the form rather than
381 (let ((y (popval)) (x (popval)))
382 (pushval (if (and (consp x) (eq (car x) name))
386 (defun unop-apply (name)
387 "Apply the Lisp unop NAME to the top item on the value stack; i.e., if the
388 top item is X, then push (NAME X)."
389 (pushval (list name (popval))))
391 (defun unop-apply-toggle (name)
392 "As for `unop-apply', but if the top item has the form (NAME X) already,
395 (pushval (if (and (consp x)
402 (defun strip-progn (form)
403 "Return a version of FORM suitable for putting somewhere where there's an
404 implicit `progn'. If FORM has the form (PROGN . FOO) then return FOO,
405 otherwise return (FORM)."
406 (if (and (consp form)
407 (eq (car form) 'progn))
411 (defun parse-expr-list ()
412 "Parse a list of expressions separated by commas."
415 (push (parse-infix 0) stuff)
416 (unless (delim '|,| :requiredp nil)
420 (defun parse-ident-list ()
421 "Parse a list of symbols separated by commas."
424 (unless (symbolp *token*)
425 (error "expected symbol; found ~S" *token*))
428 (unless (delim '|,| :requiredp nil)
432 ;;;--------------------------------------------------------------------------
433 ;;; Various simple operators.
435 (definfix |,| (:lassoc -1) (binop-apply-append 'progn))
437 (definfix or (:lassoc 10) (binop-apply-append 'or))
438 (definfix and (:lassoc 15) (binop-apply-append 'and))
440 (defprefix not 19 (unop-apply-toggle 'not))
442 (definfix == (:lassoc 20) (binop-apply-append '=))
443 (definfix /= (:lassoc 20) (binop-apply-append '/=))
444 (definfix < (:lassoc 20) (binop-apply-append '<))
445 (definfix <= (:lassoc 20) (binop-apply-append '<=))
446 (definfix >= (:lassoc 20) (binop-apply-append '>=))
447 (definfix > (:lassoc 20) (binop-apply-append '>))
448 (definfix eq (:lassoc 20) (binop-apply-append 'eq))
449 (definfix eql (:lassoc 20) (binop-apply-append 'eql))
450 (definfix equal (:lassoc 20) (binop-apply-append 'equal))
451 (definfix equalp (:lassoc 20) (binop-apply-append 'equalp))
453 (definfix \| (:lassoc 30) (binop-apply-append 'logior))
454 (definfix xor (:lassoc 30) (binop-apply-append 'logxor))
455 (definfix & (:lassoc 35) (binop-apply-append 'logand))
457 (definfix << (:lassoc 40) (binop-apply 'ash))
458 (definfix >> (:lassoc 40) (unop-apply-toggle '-) (binop-apply 'ash))
460 (definfix + (:lassoc 50) (binop-apply-append '+))
461 (definfix - (:lassoc 50) (binop-apply-append '-))
463 (definfix * (:lassoc 60) (binop-apply-append '*))
464 (definfix / (:lassoc 60) (binop-apply '/))
465 (definfix // (:lassoc 60) (binop-apply 'floor))
466 (definfix % (:lassoc 60) (binop-apply 'mod))
468 (definfix ^ (:rassoc 70) (binop-apply 'expt))
470 (definfix = (120 . 5) (binop-apply 'setf))
471 (definfix += (120 . 5) (binop-apply 'incf))
472 (definfix -= (120 . 5) (binop-apply 'decf))
474 (defprefix + 100 nil)
475 (defprefix - 100 (unop-apply-toggle '-))
476 (defprefix ~ 100 (unop-apply-toggle 'lognot))
478 (defprefix ++ 100 (unop-apply 'incf))
479 (defprefix -- 100 (unop-apply 'decf))
481 ;;(defpostfix ! 110 (unop-apply 'factorial))
484 "An escape to the standard Lisp reader."
485 (pushval (read *stream* t nil t))
488 ;;;--------------------------------------------------------------------------
489 ;;; Parentheses, for grouping and function-calls.
491 (defun push-paren (right)
492 "Pushes a funny parenthesis operator. Since this operator has no left
493 precedence, and very low right precedence, it is pushed over any stack of
494 operators and can only be popped by magic or end-of-file. In the latter
495 case, cause an error."
496 (pushop (make-operator :name right
497 :lprec nil :rprec -1000
498 :func (errfunc "missing `~A'" right)))
502 (defun pop-paren (right)
503 "Pops a parenthesis. If there are no parentheses, maybe they belong to the
504 caller's syntax. Otherwise, pop off operators above the current funny
505 parenthesis operator, and then remove it."
506 (when (zerop *paren-depth*)
510 (unless (eq (op-name (car *opstk*)) right)
511 (error "spurious `~A'" right))
512 (assert (plusp *paren-depth*))
517 (defopfunc |(| prefix (push-paren '\)))
518 (defopfunc |)| postfix (pop-paren '\)))
519 (defopfunc |{| prefix (push-paren '\}))
520 (defopfunc |}| postfix (pop-paren '\}))
522 (defopfunc |(| postfix
524 (pushval (cons (popval) (and (not (eq *token* '|)|)) (parse-expr-list))))
527 ;;;--------------------------------------------------------------------------
528 ;;; Various bits of special syntax.
530 (defopfunc if operand
531 "Parse an `if' form. Syntax:
533 IF ::= `if' CONDITION `then' CONSEQUENCE [`else' ALTERNATIVE]
535 We parse this into an `if' where sensible, or into a `cond' if we see an
536 `else if' pair. The usual `dangling else' rule is followed."
539 (setf cond (parse-infix))
541 (setf cons (parse-infix 0))
542 (if (not (eq *token* 'else))
543 (pushval (list 'if cond cons))
546 (cond ((not (eq *token* 'if))
547 (pushval (list 'if cond cons (parse-infix 0))))
550 (flet ((clause (cond cons)
551 (push (cons cond (strip-progn cons)) clauses)))
555 (setf cond (parse-infix))
557 (setf cons (parse-infix 0))
559 (unless (eq *token* 'else) (return))
564 (clause t (parse-infix 0))
566 (pushval (cons 'cond (nreverse clauses)))))))))))
568 (defun do-letlike (kind)
569 "Parse a `let' form. Syntax:
571 LET ::= `let' | `let*' VARS `in' EXPR
572 VARS ::= VAR | VARS `,' VAR
573 VAR ::= NAME [`=' VALUE]
575 Translates into the obvious Lisp code."
576 (let ((clauses nil) name value)
579 (unless (symbolp *token*)
580 (error "symbol expected, found ~S" *token*))
586 (setf value (parse-infix 0))
587 (push (list name value) clauses))
589 (unless (eq *token* '|,|)
593 (pushval `(,kind ,(nreverse clauses) ,@(strip-progn (parse-infix 0))))))
594 (defopfunc let operand (do-letlike 'let))
595 (defopfunc let* operand (do-letlike 'let*))
597 (defopfunc when operand
599 (pushval `(when ,(parse-infix)
600 ,@(progn (delim 'do) (strip-progn (parse-infix 0))))))
602 (defopfunc unless operand
604 (pushval `(unless ,(parse-infix)
605 ,@(progn (delim 'do) (strip-progn (parse-infix 0))))))
607 (defopfunc loop operand
609 (pushval `(loop ,@(progn (strip-progn (parse-infix 0))))))
611 (defopfunc multiple-value-bind operand
613 (pushval `(multiple-value-bind
615 ,(progn (delim '=) (parse-infix))
616 ,@(progn (delim 'in) (strip-progn (parse-infix 0))))))
618 (defopfunc multiple-value-setq operand
620 (pushval `(multiple-value-setq
622 ,(progn (delim '=) (parse-infix 0)))))
624 ;;;--------------------------------------------------------------------------
625 ;;; Parsing function bodies and lambda lists.
627 (defun parse-lambda-list ()
628 "Parse an infix-form lambda list and return the Lisp equivalent."
629 (flet ((ampersand-symbol-p (thing)
631 (let ((name (symbol-name thing)))
632 (plusp (length name))
633 (char= (char name 0) #\&))))
636 (when (or (eq *token* '&)
638 (unread-char #\& *stream*)
639 (setf *token* (read *stream* t nil t)))))
641 (let ((*get-token* #'get-lambda-token))
643 (unless (eq *token* '|)|)
646 (cond ((ampersand-symbol-p *token*)
649 (when (eq *token* '|)|)
651 (delim '|,| :requiredp nil)
654 (let ((name *token*))
656 (if (delim '= :requiredp nil)
657 (push (list name (parse-infix 0)) args)
662 (when (delim '|,| :requiredp nil)
668 (defun parse-func-name ()
669 "Parse a function name and return its Lisp equivalent."
670 (cond ((delim '|(| :requiredp nil)
671 (prog1 (parse-infix) (delim '|)|)))
672 (t (prog1 *token* (get-token)))))
674 (defopfunc lambda operand
676 (pushval `(lambda ,(parse-lambda-list) ,@(strip-progn (parse-infix 0)))))
678 (defun do-defunlike (kind)
679 "Process a defun-like form."
681 (pushval `(,kind ,(parse-func-name) ,(parse-lambda-list)
682 ,@(strip-progn (parse-infix 0)))))
684 (defopfunc defun operand (do-defunlike 'defun))
685 (defopfunc defmacro operand (do-defunlike 'defmacro))
687 (defun do-fletlike (kind)
688 "Process a flet-like form."
692 (push `(,(parse-func-name) ,(parse-lambda-list)
693 ,@(strip-progn (parse-infix 0)))
695 (unless (delim '|,| :requiredp nil)
698 (pushval `(,kind ,(nreverse clauses) ,@(strip-progn (parse-infix 0))))))
700 (defopfunc flet operand (do-fletlike 'flet))
701 (defopfunc labels operand (do-fletlike 'labels))
703 ;;;--------------------------------------------------------------------------
704 ;;; User-interface stuff.
706 (defun read-infix (&optional (*stream* *standard-input*) &key (delim eof))
707 "Reads an infix expression from STREAM and returns the corresponding Lisp.
708 Requires the expression to be delimited properly by DELIM (by default
714 (unless (eq *token* delim)
715 (error "expected ~S; found ~S" delim *token*)))))
717 (defun install-infix-reader (&optional (char #\$))
718 "Installs a macro character `$ INFIX... $' for translating infix notation
719 to Lisp forms. You also want to (use-package :infix-keywords) if you do
721 (let ((delim (intern (string #\$) 'infix-keywords)))
722 (set-macro-character char (lambda (stream ch)
723 (declare (ignore ch))
724 (read-infix stream :delim delim)))))
726 ;;;--------------------------------------------------------------------------
729 (defun test-infix (string)
730 (with-input-from-string (in string)
733 (defun test-tokenize (string &optional (get-token #'get-token))
734 (with-input-from-string (*stream* string)
735 (loop with *token* = nil
736 do (funcall get-token)
737 until (eq *token* eof)
740 (defun testrig (what run tests)
743 for (input . output) in tests
744 for result = (handler-case (funcall run input)
746 (setf error (format nil "~A" err))
748 unless (equal result output)
752 result = ~:[~S~*~;~*error ~A~]
756 (eq result 'fail) result error
759 finally (return ok)))
762 (testrig "tokenize" #'test-tokenize
767 ("&optional" . (& optional))
768 ("(4)" . (|(| 4 |)|))))
771 (testrig "infix" #'test-infix
778 ("1 + 2 + 3" . (+ 1 2 3))
780 ("x += 5" . (incf x 5))
781 ("1 << 5" . (ash 1 5))
782 ("1 >> 5" . (ash 1 (- 5)))
783 ("1 & 5" . (logand 1 5))
784 ("lambda (x, y) x + y" . (lambda (x y) (+ x y)))
785 ("lambda (x, y) (x += y, x - 1)" . (lambda (x y) (incf x y) (- x 1)))
786 ("lambda (x, &optional y = 1) x - y" .
787 (lambda (x &optional (y 1)) (- x y)))
788 ("foo(x, y)" . (foo x y))
789 ("if a == b then x + y" . (if (= a b) (+ x y)))
790 ("if a == b then x + y else x - y" . (if (= a b) (+ x y) (- x y)))
791 ("if a == b then x + y else if a == -b then x - y" .
792 (cond ((= a b) (+ x y)) ((= a (- b)) (- x y))))
793 ("let x = 1 in x ^ 4" . (let ((x 1)) (expt x 4)))
794 ("x ^ y ^ z" . (expt x (expt y z)))
795 ("a < b and not b < c or c > d" .
796 (or (and (< a b) (not (< b c))) (> c d)))
797 ("cdr(x) = nil" . (setf (cdr x) nil))
798 ("labels foo (x) x + 1, bar (x) x - 1 in foo(bar(y))".
799 (labels ((foo (x) (+ x 1)) (bar (x) (- x 1))) (foo (bar y))))
800 ("defun foo (x) x - 6" .
801 (defun foo (x) (- x 6)))
802 ("multiple-value-bind x, y, z = values(4, 6, 8) in x + y + z" .
803 (multiple-value-bind (x y z) (values 4 6 8) (+ x y z)))))
805 ;;;--------------------------------------------------------------------------
809 (flet ((dotrace (func)
811 (trace :function func
815 :print-all *valstk*))))
817 (dolist (s '(if \( \) \:))
818 (dolist (p '(infix prefix postfix))
819 (let ((op (get s p)))
820 (dotrace (etypecase op
822 (operator (op-func op))
824 (dolist (f '(read-infix parse-infix binop-apply unop-apply pushval popval
825 pushop flushops push-paren get-token))
828 ;;;--------------------------------------------------------------------------