;;; 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.
#:++ #:--
#:<< #:>>
#:if #:then #:else
- #:let #:let* #:in))
+ #:let #:let* #:in
+ #:bind))
(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))
+ (:use #:common-lisp #:infix-keywords))
(in-package #:infix)
;;;--------------------------------------------------------------------------
;;; Data structures.
+(export '(operator operatorp
+ op-name op-lprec op-rprec op-func))
(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)))
+ 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 :read-only t)
+ (lprec nil :type (or fixnum null) :read-only t)
+ (rprec nil :type (or fixnum null) :read-only t)
+ (func (lambda () nil)
+ :type #-ecl (function () t) #+ecl function
+ :read-only t))
;;;--------------------------------------------------------------------------
;;; Global parser state.
"Value stack. Contains (partially constructed) Lisp forms.")
(defvar *opstk* nil
"Operator stack. Contains operator objects.")
+(export '*token*)
(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.")
+ minprec restriction.")
;;;--------------------------------------------------------------------------
;;; The tokenizer.
-(defconstant eof (cons :eof nil)
- "A magical object which `get-token' returns at end-of-file.")
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (let ((value (cons :eof nil)))
+ (unless (and (boundp 'eof)
+ (equal (symbol-value 'eof) value))
+ (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*."
((#\newline) (go top))
(t (go comment)))))))
+(export '*get-token*)
(defvar *get-token* #'default-get-token
"The current tokenizing function.")
+(export 'get-token)
(defun get-token ()
"Read a token, and store it in *token*. Indirects via *get-token*."
(funcall *get-token*))
;;;--------------------------------------------------------------------------
;;; Stack manipulation.
+(export 'pushval)
(defun pushval (val)
"Push VAL onto the value stack."
(push val *valstk*))
+(export 'popval)
(defun popval ()
"Pop a value off the value stack and return it."
(pop *valstk*))
+(export 'flushops)
(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))
(pop *opstk*)
(funcall (op-func head)))))
+(export 'pushop)
(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)))
;;;--------------------------------------------------------------------------
;;; The main parser.
+(export 'infix-done)
(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))
+(export 'parse-infix)
(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))))
;;;--------------------------------------------------------------------------
;;; Machinery for defining operators.
+(export 'defopfunc)
(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))
+ (lambda () ,@body))
',op))
+(export 'definfix)
(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 ()
(postfix :lprec)) ,prec
:func (lambda () ,@body)))
',op)))
+
+(export 'defprefix)
(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))
+
+(export 'defpostfix)
(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))
+(export 'delim)
+(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)))
+(export 'errfunc)
(defun errfunc (&rest args)
"Returns a function which reports an error. Useful when constructing
-operators by hand."
+ operators by hand."
(lambda () (apply #'error args)))
+(export 'binop-apply)
(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))))
+(export 'binop-apply-append)
(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))
(list name x y)))))
+(export 'unop-apply)
(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))))
+
+(export 'unop-apply-toggle)
(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)
(cadr x)
(list name x)))))
+(export 'strip-progn)
(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)
(list form)))
+(export 'parse-expr-list)
(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)
+ (unless (delim '|,| nil)
(return)))
(nreverse stuff)))
+(export 'parse-ident-list)
(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*))
+ (error "expected symbol; found ~S" *token*))
(push *token* stuff)
(get-token)
- (unless (delim '|,| :requiredp nil)
+ (unless (delim '|,| nil)
(return)))
(nreverse stuff)))
;;;--------------------------------------------------------------------------
;;; Parentheses, for grouping and function-calls.
+(export 'push-paren)
(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)))
(incf *paren-depth*)
(get-token))
+(export 'pop-paren)
(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 ((loopy ()
+ (let ((ids (parse-ident-list))
+ (valform (progn (delim '=) (parse-infix 0)))
+ (body (if (delim '|,| nil)
+ (loopy)
+ (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 (loopy)))))
;;;--------------------------------------------------------------------------
;;; 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)))))
-
+
(defopfunc lambda operand
(get-token)
(pushval `(lambda ,(parse-lambda-list) ,@(strip-progn (parse-infix 0)))))
(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))))))
;;;--------------------------------------------------------------------------
;;; User-interface stuff.
+(export 'read-infix)
(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)))))
+(export 'install-infix-reader)
+(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 (&rest 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.
~mdw / lisp / blobdiff