safely.lisp: SAFE-COPY shouldn't make two copies under CLisp.

[lisp] / infix.lisp

diff --git a/infix.lisp b/infix.lisp
index f71758c..a77f51e 100644 (file)
--- a/infix.lisp
+++ b/infix.lisp
@@ -11,12 +11,12 @@
 ;;; 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.
 ;;; 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.
 ;;; 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.
 ;;; 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.


@@ -34,7 +34,8 @@
           #:++ #:--
           #:<< #:>>
           #:if #:then #:else
           #:++ #:--
           #:<< #:>>
           #:if #:then #:else

-          #:let #:let* #:in))
+          #:let #:let* #:in
+          #:bind))

 
 (defpackage #:infix
   (:use #:common-lisp #:infix-keywords)
 
 (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
 (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))
   (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.
 
 ;;;--------------------------------------------------------------------------
 ;;; Global parser state.


@@ -88,13 +89,17 @@ 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
   "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.
 
 
 ;;;--------------------------------------------------------------------------
 ;;; 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*."
 
 (defun default-get-token ()
   "Read a token from *stream* and store it in *token*."


@@ -164,8 +169,8 @@ minprec restriction.")
 
 (defun flushops (prec)
   "Flush out operators on the operator stack with precedecnce higher than or
 
 (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))
   (loop
     (when (null *opstk*)
       (return))


@@ -177,8 +182,9 @@ higher-precedence operators snarf their arguments."
 
 (defun pushop (op)
   "Push the operator OP onto the stack.  If the operator has a
 
 (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)))
   (let ((lp (op-lprec op)))
     (when lp
       (flushops lp)))


@@ -191,20 +197,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
 
 (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
   (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))))
   (flet ((lookup (items)
           (dolist (item items (values nil nil))
             (let ((op (get *token* (car item))))


@@ -271,10 +277,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
 
 (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))
   `(progn
      (setf (get ',op ',kind)
            (lambda () ,@body))


@@ -282,21 +288,21 @@ value stack."
 
 (defmacro definfix (op prec &body body)
   "Defines an infix operator.  The operator's name is the symbol OP.  The
 
 (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 ()
   (multiple-value-bind
       (lprec rprec)
       (flet ((bad ()


@@ -341,42 +347,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
        ',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
   (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.
 
   (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,
   "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
   (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.,
   (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
   (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))
   (let ((y (popval)) (x (popval)))
     (pushval (if (and (consp x) (eq (car x) name))
                 (append x (list y))


@@ -384,11 +390,12 @@ buidling another."
 
 (defun unop-apply (name)
   "Apply the Lisp unop NAME to the top item on the value stack; i.e., if the
 
 (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))))
   (pushval (list name (popval))))

+

 (defun unop-apply-toggle (name)
   "As for `unop-apply', but if the top item has the form (NAME X) already,
 (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)
   (let ((x (popval)))
     (pushval (if (and (consp x)
                      (eq (car x) name)


@@ -399,8 +406,8 @@ then push just X."
 
 (defun strip-progn (form)
   "Return a version of FORM suitable for putting somewhere where there's an
 
 (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)
   (if (and (consp form)
           (eq (car form) 'progn))
       (cdr form)


@@ -411,7 +418,7 @@ otherwise return (FORM)."
   (let ((stuff nil))
     (loop
       (push (parse-infix 0) stuff)
   (let ((stuff nil))
     (loop
       (push (parse-infix 0) stuff)

-      (unless (delim '|,| :requiredp nil)
+      (unless (delim '|,| nil)

        (return)))
     (nreverse stuff)))
 
        (return)))
     (nreverse stuff)))
 


@@ -423,7 +430,7 @@ otherwise return (FORM)."
         (error "expected symbol; found ~S" *token*))
       (push *token* stuff)
       (get-token)
         (error "expected symbol; found ~S" *token*))
       (push *token* stuff)
       (get-token)

-      (unless (delim '|,| :requiredp nil)
+      (unless (delim '|,| nil)

        (return)))
     (nreverse stuff)))
 
        (return)))
     (nreverse stuff)))
 


@@ -488,9 +495,9 @@ otherwise return (FORM)."
 
 (defun push-paren (right)
   "Pushes a funny parenthesis operator.  Since this operator has no left
 
 (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)))
   (pushop (make-operator :name right
                         :lprec nil :rprec -1000
                         :func (errfunc "missing `~A'" right)))


@@ -499,8 +506,8 @@ case, cause an error."
 
 (defun pop-paren (right)
   "Pops a parenthesis.  If there are no parentheses, maybe they belong to the
 
 (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)
   (when (zerop *paren-depth*)
     (infix-done))
   (flushops -999)


@@ -528,10 +535,10 @@ parenthesis operator, and then remove it."
 (defopfunc if operand
   "Parse an `if' form.  Syntax:
 
 (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))
   (get-token)
   (let (cond cons)
     (setf cond (parse-infix))


@@ -566,11 +573,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:
 
 (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
   (let ((clauses nil) name value)
     (get-token)
     (loop


@@ -604,20 +611,22 @@ Translates into the obvious Lisp code."
 
 (defopfunc loop operand
   (get-token)
 
 (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.
 
 ;;;--------------------------------------------------------------------------
 ;;; Parsing function bodies and lambda lists.


@@ -646,18 +655,18 @@ Translates into the obvious Lisp code."
                    (get-token)
                    (when (eq *token* '|)|)
                      (go done))
                    (get-token)
                    (when (eq *token* '|)|)
                      (go done))

-                   (delim '|,| :requiredp nil)
+                   (delim '|,| nil)

                    (go loop))
                   ((symbolp *token*)
                    (let ((name *token*))
                      (get-token)
                    (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)))
                          (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 '|)|)
               (go loop))
           done)))
       (delim '|)|)


@@ -665,10 +674,10 @@ Translates into the obvious Lisp code."
 
 (defun parse-func-name ()
   "Parse a function name and return its Lisp equivalent."
 
 (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)))))
         (prog1 (parse-infix) (delim '|)|)))
        (t (prog1 *token* (get-token)))))

-        
+

 (defopfunc lambda operand
   (get-token)
   (pushval `(lambda ,(parse-lambda-list) ,@(strip-progn (parse-infix 0)))))
 (defopfunc lambda operand
   (get-token)
   (pushval `(lambda ,(parse-lambda-list) ,@(strip-progn (parse-infix 0)))))


@@ -690,7 +699,7 @@ Translates into the obvious Lisp code."
       (push `(,(parse-func-name) ,(parse-lambda-list)
               ,@(strip-progn (parse-infix 0)))
            clauses)
       (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))))))
        (return)))
     (delim 'in)
     (pushval `(,kind ,(nreverse clauses) ,@(strip-progn (parse-infix 0))))))


@@ -703,8 +712,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.
 
 (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)
   (let (*token*)
     (prog2
        (get-token)


@@ -712,14 +721,27 @@ end-of-file)."
       (unless (eq *token* delim)
        (error "expected ~S; found ~S" delim *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)))))
+(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.
 
 ;;;--------------------------------------------------------------------------
 ;;; Testing things.


@@ -797,8 +819,14 @@ this."
      (labels ((foo (x) (+ x 1)) (bar (x) (- x 1))) (foo (bar y))))
     ("defun foo (x) x - 6" .
      (defun foo (x) (- x 6)))
      (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.
 
 ;;;--------------------------------------------------------------------------
 ;;; Debugging guff.