;;; -*-lisp-*-
;;;
;;; Infix-to-S-exp translation
;;;
;;; (c) 2006 Mark Wooding
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; 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.

;;;--------------------------------------------------------------------------
;;; Packages.

(defpackage #:infix-keywords
  (:use #:common-lisp)
  (:export #:|(| #:|)| #:{ #:} #:|,| #:@ #:|$| #:& #:\| #:~
	   #:and #:or #:not #:xor
	   #:== #:/= #:< #:<= #:> #:>= #:eq #:eql #:equal #:equalp
	   #:+ #:- #:* #:/ #:// #:% #:^ #:= #:!
	   #:+= #:-= #:*= #:%= #:&= #:\|= #:xor= #:<<= #:>>=
	   #:++ #:--
	   #:<< #:>>
	   #:if #:then #:else
	   #: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))

(in-package #:infix)

;;;--------------------------------------------------------------------------
;;; Data structures.

(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."
  (name nil :type symbol)
  (lprec nil :type (or fixnum null))
  (rprec nil :type (or fixnum null))
  (func (lambda () nil) :type (function () t)))

;;;--------------------------------------------------------------------------
;;; Global parser state.

(defvar *stream* nil
  "The parser input stream.  Bound automatically by `read-infix'.")

;;;--------------------------------------------------------------------------
;;; State for one level of `parse-infix'.

(defvar *valstk* nil
  "Value stack.  Contains (partially constructed) Lisp forms.")
(defvar *opstk* nil
  "Operator stack.  Contains operator objects.")
(defvar *token* nil
  "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.")

;;;--------------------------------------------------------------------------
;;; The tokenizer.

(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*."
  (flet ((whitespacep (ch)
	   (member ch '(#\newline #\space #\tab #\page)))
	 (self-delim-p (ch)
	   (member ch '(#\; #\, #\: #\( #\) #\@ #\$ #\[ #\] #\{ #\})))
	 (macro-char-p (ch)
	   (member ch '(#\# #\| #\\ #\" #\' #\`)))
	 (done (token)
	   (setf *token* token)
	   (return-from default-get-token)))
    (let (ch)
      (tagbody
       top
	 (setf ch (read-char *stream* nil nil t))
	 (cond ((null ch) (done eof))
	       ((whitespacep ch) (go top))
	       ((eql ch #\;) (go comment))
	       ((self-delim-p ch) (done (intern (string ch)
						'infix-keywords)))
	       ((or (macro-char-p ch) (alphanumericp ch)) (go read))
	       (t (go read-sym)))
       read
	 (unread-char ch *stream*)
	 (done (read *stream* t nil t))
       read-sym
	 (done (intern (with-output-to-string (out)
			 (write-char ch out)
			 (loop
			   (setf ch (read-char *stream* nil nil t))
			   (cond ((or (null ch)
				      (whitespacep ch))
				  (return))
				 ((or (self-delim-p ch)
				      (macro-char-p ch)
				      (alphanumericp ch))
				  (unread-char ch *stream*)
				  (return))
				 (t
				  (write-char ch out)))))
		       'infix-keywords))

       comment
	 (case (setf ch (read-char *stream* nil nil t))
	   ((nil) (done eof))
	   ((#\newline) (go top))
	   (t (go comment)))))))

(defvar *get-token* #'default-get-token
  "The current tokenizing function.")

(defun get-token ()
  "Read a token, and store it in *token*.  Indirects via *get-token*."
  (funcall *get-token*))

;;;--------------------------------------------------------------------------
;;; Stack manipulation.

(defun pushval (val)
  "Push VAL onto the value stack."
  (push val *valstk*))

(defun popval ()
  "Pop a value off the value stack and return it."
  (pop *valstk*))

(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."
  (loop
    (when (null *opstk*)
      (return))
    (let ((head (car *opstk*)))
      (when (> prec (op-rprec head))
	(return))
      (pop *opstk*)
      (funcall (op-func head)))))

(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."
  (let ((lp (op-lprec op)))
    (when lp
      (flushops lp)))
  (if (op-rprec op)
      (push op *opstk*)
      (funcall (op-func op))))

;;;--------------------------------------------------------------------------
;;; The main parser.

(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))

(defun parse-infix (&optional minprec)
  "Parses an infix expression and return the resulting Lisp form.  This is
   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.

   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))))
	       (when op (return (values op (cdr item))))))))
    (let ((*valstk* nil)
	  (*opstk* nil)
	  (*paren-depth* 0)
	  (state :operand))
      (catch 'infix-done
	(loop
	  (ecase state
	    (:operand
	     (when (eq *token* eof)
	       (error "operand expected; found eof"))
	     (typecase *token*
	       (symbol
		(multiple-value-bind (op newstate)
		    (lookup '((prefix . :operand)
			      (operand . :operator)))
		  (etypecase op
		    (null
		     (pushval *token*)
		     (get-token)
		     (setf state :operator))
		    (function
		     (funcall op)
		     (setf state newstate))
		    (operator
		     (get-token)
		     (pushop op)))))
	       (t
		(pushval *token*)
		(get-token)
		(setf state :operator))))
	    (:operator
	     (typecase *token*
	       (symbol
		(multiple-value-bind (op newstate)
		    (lookup '((infix . :operand)
			      (postfix . :operator)))
		  (etypecase op
		    (null
		     (return))
		    (function
		     (funcall op))
		    (operator
		     (when (and minprec
				(zerop *paren-depth*)
				(op-lprec op)
				(< (op-lprec op) minprec))
		       (return))
		     (get-token)
		     (pushop op)))
		  (setf state newstate)))
	       (t
		(return)))))))
      (flushops most-negative-fixnum)
      (assert (and (consp *valstk*)
		   (null (cdr *valstk*))))
      (car *valstk*))))

;;;--------------------------------------------------------------------------
;;; Machinery for defining operators.

(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."
  `(progn
     (setf (get ',op ',kind)
           (lambda () ,@body))
    ',op))

(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:

     * 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)).

   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 ()
	       (error "bad precedence spec ~S" prec)))
	(cond ((integerp prec)
	       (values prec prec))
	      ((not (consp prec))
	       (bad))
	      ((and (integerp (car prec))
		    (integerp (cdr prec)))
	       (values (car prec) (cdr prec)))
	      ((or (not (consp (cdr prec)))
		   (not (integerp (cadr prec)))
		   (not (null (cddr prec))))
	       (bad))
	      ((integerp (car prec))
	       (values (car prec) (cadr prec)))
	      ((eq (car prec) :lassoc)
	       (values (cadr prec) (cadr prec)))
	      ((eq (car prec) :rassoc)
	       (values (cadr prec) (1- (cadr prec))))
	      (t
	       (bad))))
    `(progn
       (setf (get ',op 'infix)
	     (make-operator :name ',op
			    :lprec ,lprec :rprec ,rprec
			    :func (lambda () ,@body)))
       ',op)))

(eval-when (:compile-toplevel :load-toplevel)
  (defun do-defunary (kind op prec body)
    (unless (integerp prec)
      (error "bad precedence spec ~S" prec))
    `(progn
       (setf (get ',op ',kind)
	     (make-operator :name ',op
			    ,(ecase kind
			       (prefix :rprec)
			       (postfix :lprec)) ,prec
			    :func (lambda () ,@body)))
       ',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."
  (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."
  (do-defunary 'postfix op prec body))

;;;--------------------------------------------------------------------------
;;; Infrastructure for operator definitions.

(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)."
  (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."
  (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)."
  (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."
  (let ((y (popval)) (x (popval)))
    (pushval (if (and (consp x) (eq (car x) name))
		 (append x (list y))
		 (list name x 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)."
  (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."
  (let ((x (popval)))
    (pushval (if (and (consp x)
		      (eq (car x) name)
		      (consp (cdr x))
		      (null (cddr x)))
		 (cadr x)
		 (list name 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)."
  (if (and (consp form)
	   (eq (car form) 'progn))
      (cdr form)
      (list form)))

(defun parse-expr-list ()
  "Parse a list of expressions separated by commas."
  (let ((stuff nil))
    (loop
      (push (parse-infix 0) stuff)
      (unless (delim '|,| nil)
	(return)))
    (nreverse stuff)))

(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*))
      (push *token* stuff)
      (get-token)
      (unless (delim '|,| nil)
	(return)))
    (nreverse stuff)))

;;;--------------------------------------------------------------------------
;;; Various simple operators.

(definfix |,| (:lassoc -1) (binop-apply-append 'progn))

(definfix or (:lassoc 10) (binop-apply-append 'or))
(definfix and (:lassoc 15) (binop-apply-append 'and))

(defprefix not 19 (unop-apply-toggle 'not))

(definfix == (:lassoc 20) (binop-apply-append '=))
(definfix /= (:lassoc 20) (binop-apply-append '/=))
(definfix < (:lassoc 20) (binop-apply-append '<))
(definfix <= (:lassoc 20) (binop-apply-append '<=))
(definfix >= (:lassoc 20) (binop-apply-append '>=))
(definfix > (:lassoc 20) (binop-apply-append '>))
(definfix eq (:lassoc 20) (binop-apply-append 'eq))
(definfix eql (:lassoc 20) (binop-apply-append 'eql))
(definfix equal (:lassoc 20) (binop-apply-append 'equal))
(definfix equalp (:lassoc 20) (binop-apply-append 'equalp))

(definfix \| (:lassoc 30) (binop-apply-append 'logior))
(definfix xor (:lassoc 30) (binop-apply-append 'logxor))
(definfix & (:lassoc 35) (binop-apply-append 'logand))

(definfix << (:lassoc 40) (binop-apply 'ash))
(definfix >> (:lassoc 40) (unop-apply-toggle '-) (binop-apply 'ash))

(definfix + (:lassoc 50) (binop-apply-append '+))
(definfix - (:lassoc 50) (binop-apply-append '-))

(definfix * (:lassoc 60) (binop-apply-append '*))
(definfix / (:lassoc 60) (binop-apply '/))
(definfix // (:lassoc 60) (binop-apply 'floor))
(definfix % (:lassoc 60) (binop-apply 'mod))

(definfix ^ (:rassoc 70) (binop-apply 'expt))

(definfix = (120 . 5) (binop-apply 'setf))
(definfix += (120 . 5) (binop-apply 'incf))
(definfix -= (120 . 5) (binop-apply 'decf))

(defprefix + 100 nil)
(defprefix - 100 (unop-apply-toggle '-))
(defprefix ~ 100 (unop-apply-toggle 'lognot))

(defprefix ++ 100 (unop-apply 'incf))
(defprefix -- 100 (unop-apply 'decf))

;;(defpostfix ! 110 (unop-apply 'factorial))

(defopfunc @ operand
  "An escape to the standard Lisp reader."
  (pushval (read *stream* t nil t))
  (get-token))

;;;--------------------------------------------------------------------------
;;; Parentheses, for grouping and function-calls.

(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."
  (pushop (make-operator :name right
			 :lprec nil :rprec -1000
			 :func (errfunc "missing `~A'" right)))
  (incf *paren-depth*)
  (get-token))

(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."
  (when (zerop *paren-depth*)
    (infix-done))
  (flushops -999)
  (assert *opstk*)
  (unless (eq (op-name (car *opstk*)) right)
    (error "spurious `~A'" right))
  (assert (plusp *paren-depth*))
  (decf *paren-depth*)
  (pop *opstk*)
  (get-token))

(defopfunc |(| prefix (push-paren '\)))
(defopfunc |)| postfix (pop-paren '\)))
(defopfunc |{| prefix (push-paren '\}))
(defopfunc |}| postfix (pop-paren '\}))

(defopfunc |(| postfix
  (get-token)
  (pushval (cons (popval) (and (not (eq *token* '|)|)) (parse-expr-list))))
  (delim '|)|))

;;;--------------------------------------------------------------------------
;;; Various bits of special syntax.

(defopfunc if operand
  "Parse an `if' form.  Syntax:

     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."
  (get-token)
  (let (cond cons)
    (setf cond (parse-infix))
    (delim 'then)
    (setf cons (parse-infix 0))
    (if (not (eq *token* 'else))
	(pushval (list 'if cond cons))
	(progn
	  (get-token)
	  (cond ((not (eq *token* 'if))
		 (pushval (list 'if cond cons (parse-infix 0))))
		(t
		 (let ((clauses nil))
		   (flet ((clause (cond cons)
			    (push (cons cond (strip-progn cons)) clauses)))
		     (clause cond cons)
		     (loop
		       (get-token)
		       (setf cond (parse-infix))
		       (delim 'then)
		       (setf cons (parse-infix 0))
		       (clause cond cons)
		       (unless (eq *token* 'else) (return))
		       (get-token)
		       (if (eq *token* 'if)
			   (get-token)
			   (progn
			     (clause t (parse-infix 0))
			     (return))))
		     (pushval (cons 'cond (nreverse clauses)))))))))))

(defun do-letlike (kind)
  "Parse a `let' form.  Syntax:

     LET ::= `let' | `let*' VARS `in' EXPR
     VARS ::= VAR | VARS `,' VAR
     VAR ::= NAME [`=' VALUE]

   Translates into the obvious Lisp code."
  (let ((clauses nil) name value)
    (get-token)
    (loop
      (unless (symbolp *token*)
	(error "symbol expected, found ~S" *token*))
      (setf name *token*)
      (get-token)
      (if (eq *token* '=)
	  (progn
	    (get-token)
	    (setf value (parse-infix 0))
	    (push (list name value) clauses))
	  (push name clauses))
      (unless (eq *token* '|,|)
	(return))
      (get-token))
    (delim 'in)
    (pushval `(,kind ,(nreverse clauses) ,@(strip-progn (parse-infix 0))))))
(defopfunc let operand (do-letlike 'let))
(defopfunc let* operand (do-letlike 'let*))

(defopfunc when operand
  (get-token)
  (pushval `(when ,(parse-infix)
	      ,@(progn (delim 'do) (strip-progn (parse-infix 0))))))

(defopfunc unless operand
  (get-token)
  (pushval `(unless ,(parse-infix)
	      ,@(progn (delim 'do) (strip-progn (parse-infix 0))))))

(defopfunc loop operand
  (get-token)
  (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.

(defun parse-lambda-list ()
  "Parse an infix-form lambda list and return the Lisp equivalent."
  (flet ((ampersand-symbol-p (thing)
	   (and (symbolp thing)
		(let ((name (symbol-name thing)))
		  (plusp (length name))
		  (char= (char name 0) #\&))))
	 (get-lambda-token ()
	   (default-get-token)
	   (when (or (eq *token* '&)
		     (eq *token* '|(|))
	     (unread-char #\& *stream*)
	     (setf *token* (read *stream* t nil t)))))
    (let ((args nil))
      (let ((*get-token* #'get-lambda-token))
	(delim '|(|)
	(unless (eq *token* '|)|)
	  (tagbody
	   loop
	     (cond ((ampersand-symbol-p *token*)
		    (push *token* args)
		    (get-token)
		    (when (eq *token* '|)|)
		      (go done))
		    (delim '|,| nil)
		    (go loop))
		   ((symbolp *token*)
		    (let ((name *token*))
		      (get-token)
		      (if (delim '= nil)
			  (push (list name (parse-infix 0)) args)
			  (push name args))))
		   (t
		    (push *token* args)
		    (get-token)))
	     (when (delim '|,| nil)
	       (go loop))
	   done)))
      (delim '|)|)
      (nreverse args))))

(defun parse-func-name ()
  "Parse a function name and return its Lisp equivalent."
  (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)))))

(defun do-defunlike (kind)
  "Process a defun-like form."
  (get-token)
  (pushval `(,kind ,(parse-func-name) ,(parse-lambda-list)
	      ,@(strip-progn (parse-infix 0)))))

(defopfunc defun operand (do-defunlike 'defun))
(defopfunc defmacro operand (do-defunlike 'defmacro))

(defun do-fletlike (kind)
  "Process a flet-like form."
  (get-token)
  (let ((clauses nil))
    (loop
      (push `(,(parse-func-name) ,(parse-lambda-list)
	       ,@(strip-progn (parse-infix 0)))
	    clauses)
      (unless (delim '|,| nil)
	(return)))
    (delim 'in)
    (pushval `(,kind ,(nreverse clauses) ,@(strip-progn (parse-infix 0))))))

(defopfunc flet operand (do-fletlike 'flet))
(defopfunc labels operand (do-fletlike 'labels))

;;;--------------------------------------------------------------------------
;;; User-interface stuff.

(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)."
  (let (*token*)
    (prog2
	(get-token)
	(parse-infix)
      (unless (eq *token* delim)
	(error "expected ~S; found ~S" delim *token*)))))

(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.

(defun test-infix (string)
  (with-input-from-string (in string)
    (read-infix in)))

(defun test-tokenize (string &optional (get-token #'get-token))
  (with-input-from-string (*stream* string)
    (loop with *token* = nil
	  do (funcall get-token)
	  until (eq *token* eof)
	  collect *token*)))

(defun testrig (what run tests)
  (loop with ok = t
	with error = nil
	for (input . output) in tests
	for result = (handler-case (funcall run input)
		       (error (err)
			 (setf error (format nil "~A" err))
			 'fail))
	unless (equal result output)
	do (format t "~&~
*** ~S test failure
    input    = ~S
    result   = ~:[~S~*~;~*error ~A~]
    expected = ~S~%"
		   what
		   input
		   (eq result 'fail) result error
		   output)
	   (setf ok nil)
	   finally (return ok)))

#+notdef
(testrig "tokenize" #'test-tokenize
  '(("++z" . (++ z))
    ("z++" . (z++))
    ("z ++" . (z ++))
    ("-5" . (- 5))
    ("&optional" . (& optional))
    ("(4)" . (|(| 4 |)|))))

#+notdef
(testrig "infix" #'test-infix
  '(("5" . 5)
    ("-5" . (- 5))
    ("-" . fail)
    ("1 + 1" . (+ 1 1))
    ("(1" . fail)
    ("1)" . fail)
    ("1 + 2 + 3" . (+ 1 2 3))
    ("++x" . (incf x))
    ("x += 5" . (incf x 5))
    ("1 << 5" . (ash 1 5))
    ("1 >> 5" . (ash 1 (- 5)))
    ("1 & 5" . (logand 1 5))
    ("lambda (x, y) x + y" . (lambda (x y) (+ x y)))
    ("lambda (x, y) (x += y, x - 1)" . (lambda (x y) (incf x y) (- x 1)))
    ("lambda (x, &optional y = 1) x - y" .
     (lambda (x &optional (y 1)) (- x y)))
    ("foo(x, y)" . (foo x y))
    ("if a == b then x + y" . (if (= a b) (+ x y)))
    ("if a == b then x + y else x - y" . (if (= a b) (+ x y) (- x y)))
    ("if a == b then x + y else if a == -b then x - y" .
     (cond ((= a b) (+ x y)) ((= a (- b)) (- x y))))
    ("let x = 1 in x ^ 4" . (let ((x 1)) (expt x 4)))
    ("x ^ y ^ z" . (expt x (expt y z)))
    ("a < b and not b < c or c > d" .
     (or (and (< a b) (not (< b c))) (> c d)))
    ("cdr(x) = nil" . (setf (cdr x) nil))
    ("labels foo (x) x + 1, bar (x) x - 1 in foo(bar(y))".
     (labels ((foo (x) (+ x 1)) (bar (x) (- x 1))) (foo (bar y))))
    ("defun foo (x) x - 6" .
     (defun foo (x) (- x 6)))
    ("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.

#+notdef
(flet ((dotrace (func)
	 (and func
	      (trace :function func
		     :encapsulate nil
		     :print-all *token*
		     :print-all *opstk*
		     :print-all *valstk*))))
  (untrace)
  (dolist (s '(if \( \) \:))
    (dolist (p '(infix prefix postfix))
      (let ((op (get s p)))
	(dotrace (etypecase op
		   (function op)
		   (operator (op-func op))
		   (null nil))))))
  (dolist (f '(read-infix parse-infix binop-apply unop-apply pushval popval
	       pushop flushops push-paren get-token))
    (dotrace f)))

;;;--------------------------------------------------------------------------