#:++ #:--
#:<< #:>>
#:if #:then #:else
- #:let #:let* #:in))
+ #:let #:let* #:in
+ #:bind))
(defpackage #:infix
(:use #:common-lisp #:infix-keywords)
(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."
+ 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)))
+ (func (lambda () nil) :type #-ecl (function () t) #+ecl function))
;;;--------------------------------------------------------------------------
;;; Global parser state.
"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.")
+ minprec restriction.")
;;;--------------------------------------------------------------------------
;;; The tokenizer.
(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."
+ 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))
(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."
+ 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)))
(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."
+ 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.
+ 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.
+ 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."
+ 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))))
(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."
+ 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))
(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:
+ 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
+ * 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)).
+ 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."
+ 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 ()
',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."
+ 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."
+ 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))
+(defun delim (delim &optional (requiredp t))
"Parse DELIM, and read the next token. Returns t if the DELIM was found,
-or nil if not (and requiredp was nil)."
+ 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."
+ 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)."
+ 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."
+ 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))
(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)."
+ 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."
+ then push just X."
(let ((x (popval)))
(pushval (if (and (consp x)
(eq (car x) name)
(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)."
+ 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)
(let ((stuff nil))
(loop
(push (parse-infix 0) stuff)
- (unless (delim '|,| :requiredp nil)
+ (unless (delim '|,| nil)
(return)))
(nreverse stuff)))
(error "expected symbol; found ~S" *token*))
(push *token* stuff)
(get-token)
- (unless (delim '|,| :requiredp nil)
+ (unless (delim '|,| nil)
(return)))
(nreverse stuff)))
(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."
+ 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)))
(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."
+ 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)
(defopfunc if operand
"Parse an `if' form. Syntax:
- IF ::= `if' CONDITION `then' CONSEQUENCE [`else' ALTERNATIVE]
+ 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."
+ 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))
(defun do-letlike (kind)
"Parse a `let' form. Syntax:
- LET ::= `let' | `let*' VARS `in' EXPR
- VARS ::= VAR | VARS `,' VAR
- VAR ::= NAME [`=' VALUE]
+ LET ::= `let' | `let*' VARS `in' EXPR
+ VARS ::= VAR | VARS `,' VAR
+ VAR ::= NAME [`=' VALUE]
-Translates into the obvious Lisp code."
+ Translates into the obvious Lisp code."
(let ((clauses nil) name value)
(get-token)
(loop
(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)))))
+ (pushval `(loop ,@(strip-progn (parse-infix 0)))))
+
+(defopfunc bind operand
+ (labels ((loop ()
+ (let ((ids (parse-ident-list))
+ (valform (progn (delim '=) (parse-infix 0)))
+ (body (if (delim '|,| nil)
+ (loop)
+ (progn
+ (delim 'in)
+ (strip-progn (parse-infix 0))))))
+ (list (if (and ids (null (cdr ids)))
+ `(let ((,(car ids) ,valform)) ,@body)
+ `(multiple-value-bind ,ids ,valform ,@body))))))
+ (get-token)
+ (pushval (car (loop)))))
;;;--------------------------------------------------------------------------
;;; Parsing function bodies and lambda lists.
(get-token)
(when (eq *token* '|)|)
(go done))
- (delim '|,| :requiredp nil)
+ (delim '|,| nil)
(go loop))
((symbolp *token*)
(let ((name *token*))
(get-token)
- (if (delim '= :requiredp nil)
+ (if (delim '= nil)
(push (list name (parse-infix 0)) args)
(push name args))))
(t
(push *token* args)
(get-token)))
- (when (delim '|,| :requiredp nil)
+ (when (delim '|,| nil)
(go loop))
done)))
(delim '|)|)
(defun parse-func-name ()
"Parse a function name and return its Lisp equivalent."
- (cond ((delim '|(| :requiredp nil)
+ (cond ((delim '|(| nil)
(prog1 (parse-infix) (delim '|)|)))
(t (prog1 *token* (get-token)))))
(push `(,(parse-func-name) ,(parse-lambda-list)
,@(strip-progn (parse-infix 0)))
clauses)
- (unless (delim '|,| :requiredp nil)
+ (unless (delim '|,| nil)
(return)))
(delim 'in)
(pushval `(,kind ,(nreverse clauses) ,@(strip-progn (parse-infix 0))))))
(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)."
+ Requires the expression to be delimited properly by DELIM (by default
+ end-of-file)."
(let (*token*)
(prog2
(get-token)
(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)))))
+(defun install-infix-reader
+ (&optional (start #\{) (end #\}) &key dispatch (readtable *readtable*))
+ "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 end) 'infix-keywords)))
+ (flet ((doit (stream &rest noise)
+ (declare (ignore noise))
+ (read-infix stream :delim delim)))
+ (if dispatch
+ (set-dispatch-macro-character dispatch start #'doit readtable)
+ (set-macro-character start #'doit nil readtable))
+ (unless (or (eql start end)
+ (multiple-value-bind
+ (func nontermp)
+ (get-macro-character end readtable)
+ (and func (not nontermp))))
+ (set-macro-character end (lambda (noise)
+ (declare (ignore noise))
+ (error "Unexpected `~C'." end))
+ nil readtable)))))
;;;--------------------------------------------------------------------------
;;; Testing things.
(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)))))
+ ("bind x = 3 in x - 2" . (let ((x 3)) (- x 2)))
+ ("bind x, y = values(1, 2),
+ z = 3,
+ docs, decls, body = parse-body(body) in complicated" .
+ (multiple-value-bind (x y) (values 1 2)
+ (let ((z 3))
+ (multiple-value-bind (docs decls body) (parse-body body)
+ complicated))))))
;;;--------------------------------------------------------------------------
;;; Debugging guff.