;;; 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
/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)))
+ (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
;;;--------------------------------------------------------------------------
;;; 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
(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
;;;--------------------------------------------------------------------------
;;; 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."
(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.
;;;--------------------------------------------------------------------------
;;; 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
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
(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."
(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
;;;--------------------------------------------------------------------------
;;; 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."
(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)."
(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
(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)."
(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."
(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,
(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
(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
(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
(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
+(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 #\$) 'infix-keywords)))
- (set-macro-character char (lambda (stream ch)
- (declare (ignore ch))
- (read-infix stream :delim delim)))))
+ (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