#: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 #-ecl (function () t) #+ecl function))
+ (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
((#\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
(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.
+(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)."
(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))
(return)))
(nreverse stuff)))
+(export 'parse-ident-list)
(defun parse-ident-list ()
"Parse a list of symbols separated by commas."
(let ((stuff nil))
;;;--------------------------------------------------------------------------
;;; 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
;;;--------------------------------------------------------------------------
;;; 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*)))))
+(export 'install-infix-reader)
(defun install-infix-reader
(&optional (start #\{) (end #\}) &key dispatch (readtable *readtable*))
"Installs a macro character `{ INFIX... }' for translating infix notation
(func nontermp)
(get-macro-character end readtable)
(and func (not nontermp))))
- (set-macro-character end (lambda (noise)
+ (set-macro-character end (lambda (&rest noise)
(declare (ignore noise))
(error "Unexpected `~C'." end))
nil readtable)))))
~mdw / lisp / blobdiff