From 874125c4ed0e20db258c57732c396060075d5557 Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Thu, 20 Apr 2006 15:00:08 +0100
Subject: [PATCH] infix: Reader macros for infix expressions.

---
 factorial.lisp |  49 ++++
 infix-ext.lisp |  46 ++++
 infix.lisp     | 826 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 mdw.asd        |   3 +
 4 files changed, 924 insertions(+)
 create mode 100644 factorial.lisp
 create mode 100644 infix-ext.lisp
 create mode 100644 infix.lisp

diff --git a/factorial.lisp b/factorial.lisp
new file mode 100644
index 0000000..0155e07
--- /dev/null
+++ b/factorial.lisp
@@ -0,0 +1,49 @@
+;;; -*-lisp-*-
+;;;
+;;; Compute factorials
+;;;
+;;; (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.
+
+(defpackage #:mdw.factorial
+  (:use #:common-lisp)
+  (:export #:factorial))
+(in-package #:mdw.factorial)
+
+(defun factorial (n)
+  "Compute a factorial.  This is a little bit optimized: we try to multiply
+values which are similar in size."
+  (when (minusp n)
+    (error "negative factorial argument ~A" n))
+  (let ((stack nil))
+    (do ((i 2 (1+ i)))
+	((> i n))
+      (let ((f i))
+	(loop
+	  (unless stack (return))
+	  (let ((top (car stack)))
+	    (when (< f top) (return))
+	    (setf f (* f top))
+	    (pop stack)))
+	(push f stack)))
+    (do ((stack stack (cdr stack))
+	 (a 1 (* a (car stack))))
+	((null stack) a))))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/infix-ext.lisp b/infix-ext.lisp
new file mode 100644
index 0000000..34d5981
--- /dev/null
+++ b/infix-ext.lisp
@@ -0,0 +1,46 @@
+;;; -*-lisp-*-
+;;;
+;;; Extensions for more infix operators
+;;;
+;;; (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.
+
+(defpackage #:infix-ext
+  (:use #:common-lisp #:mdw.base #:mdw.factorial #:infix-keywords #:infix))
+(in-package #:infix-ext)
+
+(defun assignop-apply (op)
+  (let ((y (popval))
+	(x (popval)))
+    (pushval (list 'update-place op x y))))
+
+(definfix *= (120 . 5) (assignop-apply '*))
+(definfix %= (120 . 5) (assignop-apply 'mod))
+(definfix //= (120 . 5) (assignop-apply 'floor))
+(definfix &= (120 . 5) (assignop-apply 'logand))
+(definfix \|= (120 . 5) (assignop-apply 'logior))
+(definfix <<= (120 . 5) (assignop-apply 'ash))
+(definfix >>= (120 . 5) (unop-apply-toggle '-) (assignop-apply '*))
+
+(defpostfix ++ 120 (unop-apply 'incf-after))
+(defpostfix -- 120 (unop-apply 'decf-after))
+
+(defpostfix ! 120 (unop-apply 'factorial))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/infix.lisp b/infix.lisp
new file mode 100644
index 0000000..f71758c
--- /dev/null
+++ b/infix.lisp
@@ -0,0 +1,826 @@
+;;; -*-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))
+
+(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 &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)."
+  (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 '|,| :requiredp 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 '|,| :requiredp 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 ,@(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)))))
+
+;;;--------------------------------------------------------------------------
+;;; 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 '|,| :requiredp nil)
+		    (go loop))
+		   ((symbolp *token*)
+		    (let ((name *token*))
+		      (get-token)
+		      (if (delim '= :requiredp nil)
+			  (push (list name (parse-infix 0)) args)
+			  (push name args))))
+		   (t
+		    (push *token* args)
+		    (get-token)))
+	     (when (delim '|,| :requiredp nil)
+	       (go loop))
+	   done)))
+      (delim '|)|)
+      (nreverse args))))
+
+(defun parse-func-name ()
+  "Parse a function name and return its Lisp equivalent."
+  (cond ((delim '|(| :requiredp 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 '|,| :requiredp 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 (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)))))
+
+;;;--------------------------------------------------------------------------
+;;; 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)))
+    ("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)))))
+
+;;;--------------------------------------------------------------------------
+;;; 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)))
+
+;;;--------------------------------------------------------------------------
diff --git a/mdw.asd b/mdw.asd
index 32ad40d..3ad147d 100644
--- a/mdw.asd
+++ b/mdw.asd
@@ -8,9 +8,12 @@
   :components ((:file "mdw-base")
 	       (:file "anaphora")
 	       (:file "sys-base")
+	       (:file "factorial")
 	       (:file "str")
 	       (:file "collect")
 	       (:file "unix")
 	       (:file "safely")
+	       (:file "infix")
+	       (:file "infix-ext")
 	       (:file "optparse"))
   :serial t)
-- 
2.11.0