+;;; -*-lisp-*-
+;;;
+;;; Infix-to-S-exp translation
+;;;
+;;; (c) 2006 Mark Wooding
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+;;;--------------------------------------------------------------------------
+;;; Packages.
+
+(defpackage #:infix-keywords
+ (:use #:common-lisp)
+ (:export #:|(| #:|)| #:{ #:} #:|,| #:@ #:|$| #:& #:\| #:~
+ #:and #:or #:not #:xor
+ #:== #:/= #:< #:<= #:> #:>= #:eq #:eql #:equal #:equalp
+ #:+ #:- #:* #:/ #:// #:% #:^ #:= #:!
+ #:+= #:-= #:*= #:%= #:&= #:\|= #:xor= #:<<= #:>>=
+ #:++ #:--
+ #:<< #:>>
+ #:if #:then #:else
+ #:let #:let* #:in))
+
+(defpackage #:infix
+ (:use #:common-lisp #:infix-keywords)
+ (:export #:operator #:operatorp
+ #:*token* #:get-token #:*get-token*
+ #:pushval #:popval #:flushops #:pushop
+ #:infix-done #:parse-infix
+ #:defopfunc #:definfix #:defprefix #:defpostfix
+ #:infix #:prefix #:postfix #:operand
+ #:delim #:errfunc
+ #:binop-apply #:binop-apply-append
+ #:unop-apply #:unop-apply-toggle
+ #:strip-progn
+ #:read-infix #:install-infix-reader))
+
+(in-package #:infix)
+
+;;;--------------------------------------------------------------------------
+;;; Data structures.
+
+(defstruct (operator (:predicate operatorp)
+ (:conc-name op-))
+ "An operator object. The name serves mainly for documentation. The left
+and right precedences control operator stacking behaviour. The function is
+called when this operator is popped off the stack.
+
+If the left precedence is not nil, then operators currently on the stack
+whose /right/-precedence is greater than or equal to this operator's
+/left/-precedence are popped before this operator can be pushed. If the
+right precedence is nil, then this operator is not in fact pushed, but
+processed immediately."
+ (name nil :type symbol)
+ (lprec nil :type (or fixnum null))
+ (rprec nil :type (or fixnum null))
+ (func (lambda () nil) :type (function () t)))
+
+;;;--------------------------------------------------------------------------
+;;; Global parser state.
+
+(defvar *stream* nil
+ "The parser input stream. Bound automatically by `read-infix'.")
+
+;;;--------------------------------------------------------------------------
+;;; State for one level of `parse-infix'.
+
+(defvar *valstk* nil
+ "Value stack. Contains (partially constructed) Lisp forms.")
+(defvar *opstk* nil
+ "Operator stack. Contains operator objects.")
+(defvar *token* nil
+ "The current token. Could be any Lisp object.")
+(defvar *paren-depth* 0
+ "Depth of parentheses in the current `parse-infix'. Used to override the
+minprec restriction.")
+
+;;;--------------------------------------------------------------------------
+;;; The tokenizer.
+
+(defconstant eof (cons :eof nil)
+ "A magical object which `get-token' returns at end-of-file.")
+
+(defun default-get-token ()
+ "Read a token from *stream* and store it in *token*."
+ (flet ((whitespacep (ch)
+ (member ch '(#\newline #\space #\tab #\page)))
+ (self-delim-p (ch)
+ (member ch '(#\; #\, #\: #\( #\) #\@ #\$ #\[ #\] #\{ #\})))
+ (macro-char-p (ch)
+ (member ch '(#\# #\| #\\ #\" #\' #\`)))
+ (done (token)
+ (setf *token* token)
+ (return-from default-get-token)))
+ (let (ch)
+ (tagbody
+ top
+ (setf ch (read-char *stream* nil nil t))
+ (cond ((null ch) (done eof))
+ ((whitespacep ch) (go top))
+ ((eql ch #\;) (go comment))
+ ((self-delim-p ch) (done (intern (string ch)
+ 'infix-keywords)))
+ ((or (macro-char-p ch) (alphanumericp ch)) (go read))
+ (t (go read-sym)))
+ read
+ (unread-char ch *stream*)
+ (done (read *stream* t nil t))
+ read-sym
+ (done (intern (with-output-to-string (out)
+ (write-char ch out)
+ (loop
+ (setf ch (read-char *stream* nil nil t))
+ (cond ((or (null ch)
+ (whitespacep ch))
+ (return))
+ ((or (self-delim-p ch)
+ (macro-char-p ch)
+ (alphanumericp ch))
+ (unread-char ch *stream*)
+ (return))
+ (t
+ (write-char ch out)))))
+ 'infix-keywords))
+
+ comment
+ (case (setf ch (read-char *stream* nil nil t))
+ ((nil) (done eof))
+ ((#\newline) (go top))
+ (t (go comment)))))))
+
+(defvar *get-token* #'default-get-token
+ "The current tokenizing function.")
+
+(defun get-token ()
+ "Read a token, and store it in *token*. Indirects via *get-token*."
+ (funcall *get-token*))
+
+;;;--------------------------------------------------------------------------
+;;; Stack manipulation.
+
+(defun pushval (val)
+ "Push VAL onto the value stack."
+ (push val *valstk*))
+
+(defun popval ()
+ "Pop a value off the value stack and return it."
+ (pop *valstk*))
+
+(defun flushops (prec)
+ "Flush out operators on the operator stack with precedecnce higher than or
+equal to PREC. This is used when a new operator is pushed, to ensure that
+higher-precedence operators snarf their arguments."
+ (loop
+ (when (null *opstk*)
+ (return))
+ (let ((head (car *opstk*)))
+ (when (> prec (op-rprec head))
+ (return))
+ (pop *opstk*)
+ (funcall (op-func head)))))
+
+(defun pushop (op)
+ "Push the operator OP onto the stack. If the operator has a
+left-precedence, then operators with higher precedence are flushed (see
+`flushops'). If the operator has no left-precedence, the operator is invoked immediately."
+ (let ((lp (op-lprec op)))
+ (when lp
+ (flushops lp)))
+ (if (op-rprec op)
+ (push op *opstk*)
+ (funcall (op-func op))))
+
+;;;--------------------------------------------------------------------------
+;;; The main parser.
+
+(defun infix-done ()
+ "Signal that `parse-infix' has reached the end of an expression. This is
+primarily used by the `)' handler function if it finds there are no
+parentheses."
+ (throw 'infix-done nil))
+
+(defun parse-infix (&optional minprec)
+ "Parses an infix expression and return the resulting Lisp form. This is
+the heart of the whole thing.
+
+Expects a token to be ready in *token*; leaves *token* as the first token
+which couldn't be parsed.
+
+The syntax parsed by this function doesn't fit nicely into a BNF, since we
+parsing is effected by the precedences of the various operators. We have
+low-precedence prefix operators such as `not', for example."
+ (flet ((lookup (items)
+ (dolist (item items (values nil nil))
+ (let ((op (get *token* (car item))))
+ (when op (return (values op (cdr item))))))))
+ (let ((*valstk* nil)
+ (*opstk* nil)
+ (*paren-depth* 0)
+ (state :operand))
+ (catch 'infix-done
+ (loop
+ (ecase state
+ (:operand
+ (when (eq *token* eof)
+ (error "operand expected; found eof"))
+ (typecase *token*
+ (symbol
+ (multiple-value-bind (op newstate)
+ (lookup '((prefix . :operand)
+ (operand . :operator)))
+ (etypecase op
+ (null
+ (pushval *token*)
+ (get-token)
+ (setf state :operator))
+ (function
+ (funcall op)
+ (setf state newstate))
+ (operator
+ (get-token)
+ (pushop op)))))
+ (t
+ (pushval *token*)
+ (get-token)
+ (setf state :operator))))
+ (:operator
+ (typecase *token*
+ (symbol
+ (multiple-value-bind (op newstate)
+ (lookup '((infix . :operand)
+ (postfix . :operator)))
+ (etypecase op
+ (null
+ (return))
+ (function
+ (funcall op))
+ (operator
+ (when (and minprec
+ (zerop *paren-depth*)
+ (op-lprec op)
+ (< (op-lprec op) minprec))
+ (return))
+ (get-token)
+ (pushop op)))
+ (setf state newstate)))
+ (t
+ (return)))))))
+ (flushops most-negative-fixnum)
+ (assert (and (consp *valstk*)
+ (null (cdr *valstk*))))
+ (car *valstk*))))
+
+;;;--------------------------------------------------------------------------
+;;; Machinery for defining operators.
+
+(defmacro defopfunc (op kind &body body)
+ "Defines a magical operator. The operator's name is the symbol OP. The
+KIND must be one of the symbols `infix', `prefix' or `postfix'. The body is
+evaluated when the operator is parsed, and must either push appropriate
+things on the operator stack or do its own parsing and push a result on the
+value stack."
+ `(progn
+ (setf (get ',op ',kind)
+ (lambda () ,@body))
+ ',op))
+
+(defmacro definfix (op prec &body body)
+ "Defines an infix operator. The operator's name is the symbol OP. The
+operator's precedence is specified by PREC, which may be one of the
+following:
+
+ * PREC -- equivalent to (:lassoc PREC)
+ * (:lassoc PREC) -- left-associative with precedence PREC
+ * (:rassoc PREC) -- right-associative with precedence PREC
+ * (LPREC . RPREC) -- independent left- and right-precedences
+ * (LPREC RPREC) -- synonym for the dotted form
+
+In fact, (:lassoc PREC) is the same as (PREC . PREC), and (:rassoc PREC) is
+the same as (PREC . (1- PREC)).
+
+The BODY is evaluated when the operator's arguments are fully resolved. It
+should pop off two arguments and push one result. Nobody will check that
+this is done correctly."
+ (multiple-value-bind
+ (lprec rprec)
+ (flet ((bad ()
+ (error "bad precedence spec ~S" prec)))
+ (cond ((integerp prec)
+ (values prec prec))
+ ((not (consp prec))
+ (bad))
+ ((and (integerp (car prec))
+ (integerp (cdr prec)))
+ (values (car prec) (cdr prec)))
+ ((or (not (consp (cdr prec)))
+ (not (integerp (cadr prec)))
+ (not (null (cddr prec))))
+ (bad))
+ ((integerp (car prec))
+ (values (car prec) (cadr prec)))
+ ((eq (car prec) :lassoc)
+ (values (cadr prec) (cadr prec)))
+ ((eq (car prec) :rassoc)
+ (values (cadr prec) (1- (cadr prec))))
+ (t
+ (bad))))
+ `(progn
+ (setf (get ',op 'infix)
+ (make-operator :name ',op
+ :lprec ,lprec :rprec ,rprec
+ :func (lambda () ,@body)))
+ ',op)))
+
+(eval-when (:compile-toplevel :load-toplevel)
+ (defun do-defunary (kind op prec body)
+ (unless (integerp prec)
+ (error "bad precedence spec ~S" prec))
+ `(progn
+ (setf (get ',op ',kind)
+ (make-operator :name ',op
+ ,(ecase kind
+ (prefix :rprec)
+ (postfix :lprec)) ,prec
+ :func (lambda () ,@body)))
+ ',op)))
+(defmacro defprefix (op prec &body body)
+ "Defines a prefix operator. The operator's name is the symbol OP. The
+operator's (right) precedence is PREC. The body is evaluated with the
+operator's argument is fully determined. It should pop off one argument and
+push one result."
+ (do-defunary 'prefix op prec body))
+(defmacro defpostfix (op prec &body body)
+ "Defines a postfix operator. The operator's name is the symbol OP. The
+operator's (left) precedence is PREC. The body is evaluated with the
+operator's argument is fully determined. It should pop off one argument and
+push one result."
+ (do-defunary 'postfix op prec body))
+
+;;;--------------------------------------------------------------------------
+;;; Infrastructure for operator definitions.
+
+(defun delim (delim &key (requiredp t))
+ "Parse DELIM, and read the next token. Returns t if the DELIM was found,
+or nil if not (and requiredp was nil)."
+ (cond ((eq *token* delim) (get-token) t)
+ (requiredp (error "expected `~(~A~)'; found ~S" delim *token*))
+ (t nil)))
+
+(defun errfunc (&rest args)
+ "Returns a function which reports an error. Useful when constructing
+operators by hand."
+ (lambda () (apply #'error args)))
+
+(defun binop-apply (name)
+ "Apply the Lisp binop NAME to the top two items on the value stack; i.e.,
+if the top two items are Y and X, then we push (NAME X Y)."
+ (let ((y (popval)) (x (popval)))
+ (pushval (list name x y))))
+
+(defun binop-apply-append (name)
+ "As for `binop-apply' but if the second-from-top item on the stack has the
+form (NAME SOMETHING ...) then fold the top item into the form rather than
+buidling another."
+ (let ((y (popval)) (x (popval)))
+ (pushval (if (and (consp x) (eq (car x) name))
+ (append x (list y))
+ (list name x y)))))
+
+(defun unop-apply (name)
+ "Apply the Lisp unop NAME to the top item on the value stack; i.e., if the
+top item is X, then push (NAME X)."
+ (pushval (list name (popval))))
+(defun unop-apply-toggle (name)
+ "As for `unop-apply', but if the top item has the form (NAME X) already,
+then push just X."
+ (let ((x (popval)))
+ (pushval (if (and (consp x)
+ (eq (car x) name)
+ (consp (cdr x))
+ (null (cddr x)))
+ (cadr x)
+ (list name x)))))
+
+(defun strip-progn (form)
+ "Return a version of FORM suitable for putting somewhere where there's an
+implicit `progn'. If FORM has the form (PROGN . FOO) then return FOO,
+otherwise return (FORM)."
+ (if (and (consp form)
+ (eq (car form) 'progn))
+ (cdr form)
+ (list form)))
+
+(defun parse-expr-list ()
+ "Parse a list of expressions separated by commas."
+ (let ((stuff nil))
+ (loop
+ (push (parse-infix 0) stuff)
+ (unless (delim '|,| :requiredp nil)
+ (return)))
+ (nreverse stuff)))
+
+(defun parse-ident-list ()
+ "Parse a list of symbols separated by commas."
+ (let ((stuff nil))
+ (loop
+ (unless (symbolp *token*)
+ (error "expected symbol; found ~S" *token*))
+ (push *token* stuff)
+ (get-token)
+ (unless (delim '|,| :requiredp nil)
+ (return)))
+ (nreverse stuff)))
+
+;;;--------------------------------------------------------------------------
+;;; Various simple operators.
+
+(definfix |,| (:lassoc -1) (binop-apply-append 'progn))
+
+(definfix or (:lassoc 10) (binop-apply-append 'or))
+(definfix and (:lassoc 15) (binop-apply-append 'and))
+
+(defprefix not 19 (unop-apply-toggle 'not))
+
+(definfix == (:lassoc 20) (binop-apply-append '=))
+(definfix /= (:lassoc 20) (binop-apply-append '/=))
+(definfix < (:lassoc 20) (binop-apply-append '<))
+(definfix <= (:lassoc 20) (binop-apply-append '<=))
+(definfix >= (:lassoc 20) (binop-apply-append '>=))
+(definfix > (:lassoc 20) (binop-apply-append '>))
+(definfix eq (:lassoc 20) (binop-apply-append 'eq))
+(definfix eql (:lassoc 20) (binop-apply-append 'eql))
+(definfix equal (:lassoc 20) (binop-apply-append 'equal))
+(definfix equalp (:lassoc 20) (binop-apply-append 'equalp))
+
+(definfix \| (:lassoc 30) (binop-apply-append 'logior))
+(definfix xor (:lassoc 30) (binop-apply-append 'logxor))
+(definfix & (:lassoc 35) (binop-apply-append 'logand))
+
+(definfix << (:lassoc 40) (binop-apply 'ash))
+(definfix >> (:lassoc 40) (unop-apply-toggle '-) (binop-apply 'ash))
+
+(definfix + (:lassoc 50) (binop-apply-append '+))
+(definfix - (:lassoc 50) (binop-apply-append '-))
+
+(definfix * (:lassoc 60) (binop-apply-append '*))
+(definfix / (:lassoc 60) (binop-apply '/))
+(definfix // (:lassoc 60) (binop-apply 'floor))
+(definfix % (:lassoc 60) (binop-apply 'mod))
+
+(definfix ^ (:rassoc 70) (binop-apply 'expt))
+
+(definfix = (120 . 5) (binop-apply 'setf))
+(definfix += (120 . 5) (binop-apply 'incf))
+(definfix -= (120 . 5) (binop-apply 'decf))
+
+(defprefix + 100 nil)
+(defprefix - 100 (unop-apply-toggle '-))
+(defprefix ~ 100 (unop-apply-toggle 'lognot))
+
+(defprefix ++ 100 (unop-apply 'incf))
+(defprefix -- 100 (unop-apply 'decf))
+
+;;(defpostfix ! 110 (unop-apply 'factorial))
+
+(defopfunc @ operand
+ "An escape to the standard Lisp reader."
+ (pushval (read *stream* t nil t))
+ (get-token))
+
+;;;--------------------------------------------------------------------------
+;;; Parentheses, for grouping and function-calls.
+
+(defun push-paren (right)
+ "Pushes a funny parenthesis operator. Since this operator has no left
+precedence, and very low right precedence, it is pushed over any stack of
+operators and can only be popped by magic or end-of-file. In the latter
+case, cause an error."
+ (pushop (make-operator :name right
+ :lprec nil :rprec -1000
+ :func (errfunc "missing `~A'" right)))
+ (incf *paren-depth*)
+ (get-token))
+
+(defun pop-paren (right)
+ "Pops a parenthesis. If there are no parentheses, maybe they belong to the
+caller's syntax. Otherwise, pop off operators above the current funny
+parenthesis operator, and then remove it."
+ (when (zerop *paren-depth*)
+ (infix-done))
+ (flushops -999)
+ (assert *opstk*)
+ (unless (eq (op-name (car *opstk*)) right)
+ (error "spurious `~A'" right))
+ (assert (plusp *paren-depth*))
+ (decf *paren-depth*)
+ (pop *opstk*)
+ (get-token))
+
+(defopfunc |(| prefix (push-paren '\)))
+(defopfunc |)| postfix (pop-paren '\)))
+(defopfunc |{| prefix (push-paren '\}))
+(defopfunc |}| postfix (pop-paren '\}))
+
+(defopfunc |(| postfix
+ (get-token)
+ (pushval (cons (popval) (and (not (eq *token* '|)|)) (parse-expr-list))))
+ (delim '|)|))
+
+;;;--------------------------------------------------------------------------
+;;; Various bits of special syntax.
+
+(defopfunc if operand
+ "Parse an `if' form. Syntax:
+
+ IF ::= `if' CONDITION `then' CONSEQUENCE [`else' ALTERNATIVE]
+
+We parse this into an `if' where sensible, or into a `cond' if we see an
+`else if' pair. The usual `dangling else' rule is followed."
+ (get-token)
+ (let (cond cons)
+ (setf cond (parse-infix))
+ (delim 'then)
+ (setf cons (parse-infix 0))
+ (if (not (eq *token* 'else))
+ (pushval (list 'if cond cons))
+ (progn
+ (get-token)
+ (cond ((not (eq *token* 'if))
+ (pushval (list 'if cond cons (parse-infix 0))))
+ (t
+ (let ((clauses nil))
+ (flet ((clause (cond cons)
+ (push (cons cond (strip-progn cons)) clauses)))
+ (clause cond cons)
+ (loop
+ (get-token)
+ (setf cond (parse-infix))
+ (delim 'then)
+ (setf cons (parse-infix 0))
+ (clause cond cons)
+ (unless (eq *token* 'else) (return))
+ (get-token)
+ (if (eq *token* 'if)
+ (get-token)
+ (progn
+ (clause t (parse-infix 0))
+ (return))))
+ (pushval (cons 'cond (nreverse clauses)))))))))))
+
+(defun do-letlike (kind)
+ "Parse a `let' form. Syntax:
+
+ LET ::= `let' | `let*' VARS `in' EXPR
+ VARS ::= VAR | VARS `,' VAR
+ VAR ::= NAME [`=' VALUE]
+
+Translates into the obvious Lisp code."
+ (let ((clauses nil) name value)
+ (get-token)
+ (loop
+ (unless (symbolp *token*)
+ (error "symbol expected, found ~S" *token*))
+ (setf name *token*)
+ (get-token)
+ (if (eq *token* '=)
+ (progn
+ (get-token)
+ (setf value (parse-infix 0))
+ (push (list name value) clauses))
+ (push name clauses))
+ (unless (eq *token* '|,|)
+ (return))
+ (get-token))
+ (delim 'in)
+ (pushval `(,kind ,(nreverse clauses) ,@(strip-progn (parse-infix 0))))))
+(defopfunc let operand (do-letlike 'let))
+(defopfunc let* operand (do-letlike 'let*))
+
+(defopfunc when operand
+ (get-token)
+ (pushval `(when ,(parse-infix)
+ ,@(progn (delim 'do) (strip-progn (parse-infix 0))))))
+
+(defopfunc unless operand
+ (get-token)
+ (pushval `(unless ,(parse-infix)
+ ,@(progn (delim 'do) (strip-progn (parse-infix 0))))))
+
+(defopfunc loop operand
+ (get-token)
+ (pushval `(loop ,@(progn (strip-progn (parse-infix 0))))))
+
+(defopfunc multiple-value-bind operand
+ (get-token)
+ (pushval `(multiple-value-bind
+ ,(parse-ident-list)
+ ,(progn (delim '=) (parse-infix))
+ ,@(progn (delim 'in) (strip-progn (parse-infix 0))))))
+
+(defopfunc multiple-value-setq operand
+ (get-token)
+ (pushval `(multiple-value-setq
+ ,(parse-ident-list)
+ ,(progn (delim '=) (parse-infix 0)))))
+
+;;;--------------------------------------------------------------------------
+;;; Parsing function bodies and lambda lists.
+
+(defun parse-lambda-list ()
+ "Parse an infix-form lambda list and return the Lisp equivalent."
+ (flet ((ampersand-symbol-p (thing)
+ (and (symbolp thing)
+ (let ((name (symbol-name thing)))
+ (plusp (length name))
+ (char= (char name 0) #\&))))
+ (get-lambda-token ()
+ (default-get-token)
+ (when (or (eq *token* '&)
+ (eq *token* '|(|))
+ (unread-char #\& *stream*)
+ (setf *token* (read *stream* t nil t)))))
+ (let ((args nil))
+ (let ((*get-token* #'get-lambda-token))
+ (delim '|(|)
+ (unless (eq *token* '|)|)
+ (tagbody
+ loop
+ (cond ((ampersand-symbol-p *token*)
+ (push *token* args)
+ (get-token)
+ (when (eq *token* '|)|)
+ (go done))
+ (delim '|,| :requiredp nil)
+ (go loop))
+ ((symbolp *token*)
+ (let ((name *token*))
+ (get-token)
+ (if (delim '= :requiredp nil)
+ (push (list name (parse-infix 0)) args)
+ (push name args))))
+ (t
+ (push *token* args)
+ (get-token)))
+ (when (delim '|,| :requiredp nil)
+ (go loop))
+ done)))
+ (delim '|)|)
+ (nreverse args))))
+
+(defun parse-func-name ()
+ "Parse a function name and return its Lisp equivalent."
+ (cond ((delim '|(| :requiredp nil)
+ (prog1 (parse-infix) (delim '|)|)))
+ (t (prog1 *token* (get-token)))))
+
+(defopfunc lambda operand
+ (get-token)
+ (pushval `(lambda ,(parse-lambda-list) ,@(strip-progn (parse-infix 0)))))
+
+(defun do-defunlike (kind)
+ "Process a defun-like form."
+ (get-token)
+ (pushval `(,kind ,(parse-func-name) ,(parse-lambda-list)
+ ,@(strip-progn (parse-infix 0)))))
+
+(defopfunc defun operand (do-defunlike 'defun))
+(defopfunc defmacro operand (do-defunlike 'defmacro))
+
+(defun do-fletlike (kind)
+ "Process a flet-like form."
+ (get-token)
+ (let ((clauses nil))
+ (loop
+ (push `(,(parse-func-name) ,(parse-lambda-list)
+ ,@(strip-progn (parse-infix 0)))
+ clauses)
+ (unless (delim '|,| :requiredp nil)
+ (return)))
+ (delim 'in)
+ (pushval `(,kind ,(nreverse clauses) ,@(strip-progn (parse-infix 0))))))
+
+(defopfunc flet operand (do-fletlike 'flet))
+(defopfunc labels operand (do-fletlike 'labels))
+
+;;;--------------------------------------------------------------------------
+;;; User-interface stuff.
+
+(defun read-infix (&optional (*stream* *standard-input*) &key (delim eof))
+ "Reads an infix expression from STREAM and returns the corresponding Lisp.
+Requires the expression to be delimited properly by DELIM (by default
+end-of-file)."
+ (let (*token*)
+ (prog2
+ (get-token)
+ (parse-infix)
+ (unless (eq *token* delim)
+ (error "expected ~S; found ~S" delim *token*)))))
+
+(defun install-infix-reader (&optional (char #\$))
+ "Installs a macro character `$ INFIX... $' for translating infix notation
+to Lisp forms. You also want to (use-package :infix-keywords) if you do
+this."
+ (let ((delim (intern (string #\$) 'infix-keywords)))
+ (set-macro-character char (lambda (stream ch)
+ (declare (ignore ch))
+ (read-infix stream :delim delim)))))
+
+;;;--------------------------------------------------------------------------
+;;; Testing things.
+
+(defun test-infix (string)
+ (with-input-from-string (in string)
+ (read-infix in)))
+
+(defun test-tokenize (string &optional (get-token #'get-token))
+ (with-input-from-string (*stream* string)
+ (loop with *token* = nil
+ do (funcall get-token)
+ until (eq *token* eof)
+ collect *token*)))
+
+(defun testrig (what run tests)
+ (loop with ok = t
+ with error = nil
+ for (input . output) in tests
+ for result = (handler-case (funcall run input)
+ (error (err)
+ (setf error (format nil "~A" err))
+ 'fail))
+ unless (equal result output)
+ do (format t "~&~
+*** ~S test failure
+ input = ~S
+ result = ~:[~S~*~;~*error ~A~]
+ expected = ~S~%"
+ what
+ input
+ (eq result 'fail) result error
+ output)
+ (setf ok nil)
+ finally (return ok)))
+
+#+notdef
+(testrig "tokenize" #'test-tokenize
+ '(("++z" . (++ z))
+ ("z++" . (z++))
+ ("z ++" . (z ++))
+ ("-5" . (- 5))
+ ("&optional" . (& optional))
+ ("(4)" . (|(| 4 |)|))))
+
+#+notdef
+(testrig "infix" #'test-infix
+ '(("5" . 5)
+ ("-5" . (- 5))
+ ("-" . fail)
+ ("1 + 1" . (+ 1 1))
+ ("(1" . fail)
+ ("1)" . fail)
+ ("1 + 2 + 3" . (+ 1 2 3))
+ ("++x" . (incf x))
+ ("x += 5" . (incf x 5))
+ ("1 << 5" . (ash 1 5))
+ ("1 >> 5" . (ash 1 (- 5)))
+ ("1 & 5" . (logand 1 5))
+ ("lambda (x, y) x + y" . (lambda (x y) (+ x y)))
+ ("lambda (x, y) (x += y, x - 1)" . (lambda (x y) (incf x y) (- x 1)))
+ ("lambda (x, &optional y = 1) x - y" .
+ (lambda (x &optional (y 1)) (- x y)))
+ ("foo(x, y)" . (foo x y))
+ ("if a == b then x + y" . (if (= a b) (+ x y)))
+ ("if a == b then x + y else x - y" . (if (= a b) (+ x y) (- x y)))
+ ("if a == b then x + y else if a == -b then x - y" .
+ (cond ((= a b) (+ x y)) ((= a (- b)) (- x y))))
+ ("let x = 1 in x ^ 4" . (let ((x 1)) (expt x 4)))
+ ("x ^ y ^ z" . (expt x (expt y z)))
+ ("a < b and not b < c or c > d" .
+ (or (and (< a b) (not (< b c))) (> c d)))
+ ("cdr(x) = nil" . (setf (cdr x) nil))
+ ("labels foo (x) x + 1, bar (x) x - 1 in foo(bar(y))".
+ (labels ((foo (x) (+ x 1)) (bar (x) (- x 1))) (foo (bar y))))
+ ("defun foo (x) x - 6" .
+ (defun foo (x) (- x 6)))
+ ("multiple-value-bind x, y, z = values(4, 6, 8) in x + y + z" .
+ (multiple-value-bind (x y z) (values 4 6 8) (+ x y z)))))
+
+;;;--------------------------------------------------------------------------
+;;; Debugging guff.
+
+#+notdef
+(flet ((dotrace (func)
+ (and func
+ (trace :function func
+ :encapsulate nil
+ :print-all *token*
+ :print-all *opstk*
+ :print-all *valstk*))))
+ (untrace)
+ (dolist (s '(if \( \) \:))
+ (dolist (p '(infix prefix postfix))
+ (let ((op (get s p)))
+ (dotrace (etypecase op
+ (function op)
+ (operator (op-func op))
+ (null nil))))))
+ (dolist (f '(read-infix parse-infix binop-apply unop-apply pushval popval
+ pushop flushops push-paren get-token))
+ (dotrace f)))
+
+;;;--------------------------------------------------------------------------
~mdw / lisp / commitdiff