(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))
"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))
;;;--------------------------------------------------------------------------
(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)."
+ 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)
(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
(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)
(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."
+ 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))