X-Git-Url: https://git.distorted.org.uk/~mdw/lisp/blobdiff_plain/874125c4ed0e20db258c57732c396060075d5557..fe0f07ea19b36ce1abc1ec305d0203323cbf2316:/infix.lisp diff --git a/infix.lisp b/infix.lisp index f71758c..9c77afe 100644 --- a/infix.lisp +++ b/infix.lisp @@ -34,7 +34,8 @@ #:++ #:-- #:<< #:>> #:if #:then #:else - #:let #:let* #:in)) + #:let #:let* #:in + #:bind)) (defpackage #:infix (:use #:common-lisp #:infix-keywords) @@ -58,18 +59,18 @@ (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. @@ -88,7 +89,7 @@ processed immediately." "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. @@ -164,8 +165,8 @@ minprec restriction.") (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)) @@ -177,8 +178,9 @@ higher-precedence operators snarf their arguments." (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))) @@ -191,20 +193,20 @@ left-precedence, then operators with higher precedence are flushed (see (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)))) @@ -271,10 +273,10 @@ low-precedence prefix operators such as `not', for example." (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)) @@ -282,21 +284,21 @@ value stack." (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 () @@ -341,42 +343,42 @@ this is done correctly." ',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)) @@ -384,11 +386,12 @@ buidling another." (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) @@ -399,8 +402,8 @@ then push just X." (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) @@ -411,7 +414,7 @@ otherwise return (FORM)." (let ((stuff nil)) (loop (push (parse-infix 0) stuff) - (unless (delim '|,| :requiredp nil) + (unless (delim '|,| nil) (return))) (nreverse stuff))) @@ -423,7 +426,7 @@ otherwise return (FORM)." (error "expected symbol; found ~S" *token*)) (push *token* stuff) (get-token) - (unless (delim '|,| :requiredp nil) + (unless (delim '|,| nil) (return))) (nreverse stuff))) @@ -488,9 +491,9 @@ otherwise return (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))) @@ -499,8 +502,8 @@ case, cause an error." (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) @@ -528,10 +531,10 @@ parenthesis operator, and then remove it." (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)) @@ -566,11 +569,11 @@ We parse this into an `if' where sensible, or into a `cond' if we see an (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 @@ -604,20 +607,22 @@ Translates into the obvious Lisp code." (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. @@ -646,18 +651,18 @@ Translates into the obvious Lisp code." (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 '|)|) @@ -665,7 +670,7 @@ Translates into the obvious Lisp code." (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))))) @@ -690,7 +695,7 @@ Translates into the obvious Lisp code." (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)))))) @@ -703,8 +708,8 @@ Translates into the obvious Lisp code." (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) @@ -712,14 +717,27 @@ end-of-file)." (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. @@ -797,8 +815,14 @@ this." (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.