mdw@git.distorted.org.uk Git - lisp/blob - infix.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Infix-to-S-exp translation
   4 ;;;
   5 ;;; (c) 2006 Mark Wooding
   6 ;;;
   7
   8 ;;;----- Licensing notice ---------------------------------------------------
   9 ;;;
  10 ;;; This program is free software; you can redistribute it and/or modify
  11 ;;; it under the terms of the GNU General Public License as published by
  12 ;;; the Free Software Foundation; either version 2 of the License, or
  13 ;;; (at your option) any later version.
  14 ;;;
  15 ;;; This program is distributed in the hope that it will be useful,
  16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;;; GNU General Public License for more details.
  19 ;;;
  20 ;;; You should have received a copy of the GNU General Public License
  21 ;;; along with this program; if not, write to the Free Software Foundation,
  22 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  23
  24 ;;;--------------------------------------------------------------------------
  25 ;;; Packages.
  26
  27 (defpackage #:infix-keywords
  28   (:use #:common-lisp)
  29   (:export #:|(| #:|)| #:{ #:} #:|,| #:@ #:|$| #:& #:\| #:~
  30            #:and #:or #:not #:xor
  31            #:== #:/= #:< #:<= #:> #:>= #:eq #:eql #:equal #:equalp
  32            #:+ #:- #:* #:/ #:// #:% #:^ #:= #:!
  33            #:+= #:-= #:*= #:%= #:&= #:\|= #:xor= #:<<= #:>>=
  34            #:++ #:--
  35            #:<< #:>>
  36            #:if #:then #:else
  37            #:let #:let* #:in
  38            #:bind))
  39
  40 (defpackage #:infix
  41   (:use #:common-lisp #:infix-keywords))
  42
  43 (in-package #:infix)
  44
  45 ;;;--------------------------------------------------------------------------
  46 ;;; Data structures.
  47
  48 (export '(operator operatorp
  49           op-name op-lprec op-rprec op-func))
  50 (defstruct (operator (:predicate operatorp)
  51                      (:conc-name op-))
  52   "An operator object.  The name serves mainly for documentation.  The left
  53    and right precedences control operator stacking behaviour.  The function
  54    is called when this operator is popped off the stack.
  55
  56    If the left precedence is not nil, then operators currently on the stack
  57    whose /right/-precedence is greater than or equal to this operator's
  58    /left/-precedence are popped before this operator can be pushed.  If the
  59    right precedence is nil, then this operator is not in fact pushed, but
  60    processed immediately."
  61   (name nil :type symbol :read-only t)
  62   (lprec nil :type (or fixnum null) :read-only t)
  63   (rprec nil :type (or fixnum null) :read-only t)
  64   (func (lambda () nil)
  65         :type #-ecl (function () t) #+ecl function
  66         :read-only t))
  67
  68 ;;;--------------------------------------------------------------------------
  69 ;;; Global parser state.
  70
  71 (defvar *stream* nil
  72   "The parser input stream.  Bound automatically by `read-infix'.")
  73
  74 ;;;--------------------------------------------------------------------------
  75 ;;; State for one level of `parse-infix'.
  76
  77 (defvar *valstk* nil
  78   "Value stack.  Contains (partially constructed) Lisp forms.")
  79 (defvar *opstk* nil
  80   "Operator stack.  Contains operator objects.")
  81 (export '*token*)
  82 (defvar *token* nil
  83   "The current token.  Could be any Lisp object.")
  84 (defvar *paren-depth* 0
  85   "Depth of parentheses in the current `parse-infix'.  Used to override the
  86    minprec restriction.")
  87
  88 ;;;--------------------------------------------------------------------------
  89 ;;; The tokenizer.
  90
  91 (eval-when (:compile-toplevel :load-toplevel :execute)
  92   (let ((value (cons :eof nil)))
  93     (unless (and (boundp 'eof)
  94                  (equal (symbol-value 'eof) value))
  95       (defconstant eof (cons :eof nil)
  96         "A magical object which `get-token' returns at end-of-file."))))
  97
  98 (defun default-get-token ()
  99   "Read a token from *stream* and store it in *token*."
 100   (flet ((whitespacep (ch)
 101            (member ch '(#\newline #\space #\tab #\page)))
 102          (self-delim-p (ch)
 103            (member ch '(#\; #\, #\: #\( #\) #\@ #\$ #\[ #\] #\{ #\})))
 104          (macro-char-p (ch)
 105            (member ch '(#\# #\| #\\ #\" #\' #\`)))
 106          (done (token)
 107            (setf *token* token)
 108            (return-from default-get-token)))
 109     (let (ch)
 110       (tagbody
 111        top
 112          (setf ch (read-char *stream* nil nil t))
 113          (cond ((null ch) (done eof))
 114                ((whitespacep ch) (go top))
 115                ((eql ch #\;) (go comment))
 116                ((self-delim-p ch) (done (intern (string ch)
 117                                                 'infix-keywords)))
 118                ((or (macro-char-p ch) (alphanumericp ch)) (go read))
 119                (t (go read-sym)))
 120        read
 121          (unread-char ch *stream*)
 122          (done (read *stream* t nil t))
 123        read-sym
 124          (done (intern (with-output-to-string (out)
 125                          (write-char ch out)
 126                          (loop
 127                            (setf ch (read-char *stream* nil nil t))
 128                            (cond ((or (null ch)
 129                                       (whitespacep ch))
 130                                   (return))
 131                                  ((or (self-delim-p ch)
 132                                       (macro-char-p ch)
 133                                       (alphanumericp ch))
 134                                   (unread-char ch *stream*)
 135                                   (return))
 136                                  (t
 137                                   (write-char ch out)))))
 138                        'infix-keywords))
 139
 140        comment
 141          (case (setf ch (read-char *stream* nil nil t))
 142            ((nil) (done eof))
 143            ((#\newline) (go top))
 144            (t (go comment)))))))
 145
 146 (export '*get-token*)
 147 (defvar *get-token* #'default-get-token
 148   "The current tokenizing function.")
 149
 150 (export 'get-token)
 151 (defun get-token ()
 152   "Read a token, and store it in *token*.  Indirects via *get-token*."
 153   (funcall *get-token*))
 154
 155 ;;;--------------------------------------------------------------------------
 156 ;;; Stack manipulation.
 157
 158 (export 'pushval)
 159 (defun pushval (val)
 160   "Push VAL onto the value stack."
 161   (push val *valstk*))
 162
 163 (export 'popval)
 164 (defun popval ()
 165   "Pop a value off the value stack and return it."
 166   (pop *valstk*))
 167
 168 (export 'flushops)
 169 (defun flushops (prec)
 170   "Flush out operators on the operator stack with precedecnce higher than or
 171    equal to PREC.  This is used when a new operator is pushed, to ensure that
 172    higher-precedence operators snarf their arguments."
 173   (loop
 174     (when (null *opstk*)
 175       (return))
 176     (let ((head (car *opstk*)))
 177       (when (> prec (op-rprec head))
 178         (return))
 179       (pop *opstk*)
 180       (funcall (op-func head)))))
 181
 182 (export 'pushop)
 183 (defun pushop (op)
 184   "Push the operator OP onto the stack.  If the operator has a
 185    left-precedence, then operators with higher precedence are flushed (see
 186    `flushops').  If the operator has no left-precedence, the operator is
 187    invoked immediately."
 188   (let ((lp (op-lprec op)))
 189     (when lp
 190       (flushops lp)))
 191   (if (op-rprec op)
 192       (push op *opstk*)
 193       (funcall (op-func op))))
 194
 195 ;;;--------------------------------------------------------------------------
 196 ;;; The main parser.
 197
 198 (export 'infix-done)
 199 (defun infix-done ()
 200   "Signal that `parse-infix' has reached the end of an expression.  This is
 201    primarily used by the `)' handler function if it finds there are no
 202    parentheses."
 203   (throw 'infix-done nil))
 204
 205 (export 'parse-infix)
 206 (defun parse-infix (&optional minprec)
 207   "Parses an infix expression and return the resulting Lisp form.  This is
 208    the heart of the whole thing.
 209
 210    Expects a token to be ready in *token*; leaves *token* as the first token
 211    which couldn't be parsed.
 212
 213    The syntax parsed by this function doesn't fit nicely into a BNF, since we
 214    parsing is effected by the precedences of the various operators.  We have
 215    low-precedence prefix operators such as `not', for example."
 216   (flet ((lookup (items)
 217            (dolist (item items (values nil nil))
 218              (let ((op (get *token* (car item))))
 219                (when op (return (values op (cdr item))))))))
 220     (let ((*valstk* nil)
 221           (*opstk* nil)
 222           (*paren-depth* 0)
 223           (state :operand))
 224       (catch 'infix-done
 225         (loop
 226           (ecase state
 227             (:operand
 228              (when (eq *token* eof)
 229                (error "operand expected; found eof"))
 230              (typecase *token*
 231                (symbol
 232                 (multiple-value-bind (op newstate)
 233                     (lookup '((prefix . :operand)
 234                               (operand . :operator)))
 235                   (etypecase op
 236                     (null
 237                      (pushval *token*)
 238                      (get-token)
 239                      (setf state :operator))
 240                     (function
 241                      (funcall op)
 242                      (setf state newstate))
 243                     (operator
 244                      (get-token)
 245                      (pushop op)))))
 246                (t
 247                 (pushval *token*)
 248                 (get-token)
 249                 (setf state :operator))))
 250             (:operator
 251              (typecase *token*
 252                (symbol
 253                 (multiple-value-bind (op newstate)
 254                     (lookup '((infix . :operand)
 255                               (postfix . :operator)))
 256                   (etypecase op
 257                     (null
 258                      (return))
 259                     (function
 260                      (funcall op))
 261                     (operator
 262                      (when (and minprec
 263                                 (zerop *paren-depth*)
 264                                 (op-lprec op)
 265                                 (< (op-lprec op) minprec))
 266                        (return))
 267                      (get-token)
 268                      (pushop op)))
 269                   (setf state newstate)))
 270                (t
 271                 (return)))))))
 272       (flushops most-negative-fixnum)
 273       (assert (and (consp *valstk*)
 274                    (null (cdr *valstk*))))
 275       (car *valstk*))))
 276
 277 ;;;--------------------------------------------------------------------------
 278 ;;; Machinery for defining operators.
 279
 280 (export 'defopfunc)
 281 (defmacro defopfunc (op kind &body body)
 282   "Defines a magical operator.  The operator's name is the symbol OP.  The
 283    KIND must be one of the symbols `infix', `prefix' or `postfix'.  The body
 284    is evaluated when the operator is parsed, and must either push appropriate
 285    things on the operator stack or do its own parsing and push a result on
 286    the value stack."
 287   `(progn
 288      (setf (get ',op ',kind)
 289            (lambda () ,@body))
 290     ',op))
 291
 292 (export 'definfix)
 293 (defmacro definfix (op prec &body body)
 294   "Defines an infix operator.  The operator's name is the symbol OP.  The
 295    operator's precedence is specified by PREC, which may be one of the
 296    following:
 297
 298      * PREC -- equivalent to (:lassoc PREC)
 299      * (:lassoc PREC) -- left-associative with precedence PREC
 300      * (:rassoc PREC) -- right-associative with precedence PREC
 301      * (LPREC . RPREC) -- independent left- and right-precedences
 302      * (LPREC RPREC) -- synonym for the dotted form
 303
 304    In fact, (:lassoc PREC) is the same as (PREC . PREC), and (:rassoc PREC)
 305    is the same as (PREC . (1- PREC)).
 306
 307    The BODY is evaluated when the operator's arguments are fully resolved.
 308    It should pop off two arguments and push one result.  Nobody will check
 309    that this is done correctly."
 310   (multiple-value-bind
 311       (lprec rprec)
 312       (flet ((bad ()
 313                (error "bad precedence spec ~S" prec)))
 314         (cond ((integerp prec)
 315                (values prec prec))
 316               ((not (consp prec))
 317                (bad))
 318               ((and (integerp (car prec))
 319                     (integerp (cdr prec)))
 320                (values (car prec) (cdr prec)))
 321               ((or (not (consp (cdr prec)))
 322                    (not (integerp (cadr prec)))
 323                    (not (null (cddr prec))))
 324                (bad))
 325               ((integerp (car prec))
 326                (values (car prec) (cadr prec)))
 327               ((eq (car prec) :lassoc)
 328                (values (cadr prec) (cadr prec)))
 329               ((eq (car prec) :rassoc)
 330                (values (cadr prec) (1- (cadr prec))))
 331               (t
 332                (bad))))
 333     `(progn
 334        (setf (get ',op 'infix)
 335              (make-operator :name ',op
 336                             :lprec ,lprec :rprec ,rprec
 337                             :func (lambda () ,@body)))
 338        ',op)))
 339
 340 (eval-when (:compile-toplevel :load-toplevel)
 341   (defun do-defunary (kind op prec body)
 342     (unless (integerp prec)
 343       (error "bad precedence spec ~S" prec))
 344     `(progn
 345        (setf (get ',op ',kind)
 346              (make-operator :name ',op
 347                             ,(ecase kind
 348                                (prefix :rprec)
 349                                (postfix :lprec)) ,prec
 350                             :func (lambda () ,@body)))
 351        ',op)))
 352
 353 (export 'defprefix)
 354 (defmacro defprefix (op prec &body body)
 355   "Defines a prefix operator.  The operator's name is the symbol OP.  The
 356    operator's (right) precedence is PREC.  The body is evaluated with the
 357    operator's argument is fully determined.  It should pop off one argument
 358    and push one result."
 359   (do-defunary 'prefix op prec body))
 360
 361 (export 'defpostfix)
 362 (defmacro defpostfix (op prec &body body)
 363   "Defines a postfix operator.  The operator's name is the symbol OP.  The
 364    operator's (left) precedence is PREC.  The body is evaluated with the
 365    operator's argument is fully determined.  It should pop off one argument
 366    and push one result."
 367   (do-defunary 'postfix op prec body))
 368
 369 ;;;--------------------------------------------------------------------------
 370 ;;; Infrastructure for operator definitions.
 371
 372 (export 'delim)
 373 (defun delim (delim &optional (requiredp t))
 374   "Parse DELIM, and read the next token.  Returns t if the DELIM was found,
 375    or nil if not (and REQUIREDP was nil)."
 376   (cond ((eq *token* delim) (get-token) t)
 377         (requiredp (error "expected `~(~A~)'; found ~S" delim *token*))
 378         (t nil)))
 379
 380 (export 'errfunc)
 381 (defun errfunc (&rest args)
 382   "Returns a function which reports an error.  Useful when constructing
 383    operators by hand."
 384   (lambda () (apply #'error args)))
 385
 386 (export 'binop-apply)
 387 (defun binop-apply (name)
 388   "Apply the Lisp binop NAME to the top two items on the value stack; i.e.,
 389    if the top two items are Y and X, then we push (NAME X Y)."
 390   (let ((y (popval)) (x (popval)))
 391     (pushval (list name x y))))
 392
 393 (export 'binop-apply-append)
 394 (defun binop-apply-append (name)
 395   "As for `binop-apply' but if the second-from-top item on the stack has the
 396    form (NAME SOMETHING ...) then fold the top item into the form rather than
 397    buidling another."
 398   (let ((y (popval)) (x (popval)))
 399     (pushval (if (and (consp x) (eq (car x) name))
 400                  (append x (list y))
 401                  (list name x y)))))
 402
 403 (export 'unop-apply)
 404 (defun unop-apply (name)
 405   "Apply the Lisp unop NAME to the top item on the value stack; i.e., if the
 406    top item is X, then push (NAME X)."
 407   (pushval (list name (popval))))
 408
 409 (export 'unop-apply-toggle)
 410 (defun unop-apply-toggle (name)
 411   "As for `unop-apply', but if the top item has the form (NAME X) already,
 412    then push just X."
 413   (let ((x (popval)))
 414     (pushval (if (and (consp x)
 415                       (eq (car x) name)
 416                       (consp (cdr x))
 417                       (null (cddr x)))
 418                  (cadr x)
 419                  (list name x)))))
 420
 421 (export 'strip-progn)
 422 (defun strip-progn (form)
 423   "Return a version of FORM suitable for putting somewhere where there's an
 424    implicit `progn'.  If FORM has the form (PROGN . FOO) then return FOO,
 425    otherwise return (FORM)."
 426   (if (and (consp form)
 427            (eq (car form) 'progn))
 428       (cdr form)
 429       (list form)))
 430
 431 (export 'parse-expr-list)
 432 (defun parse-expr-list ()
 433   "Parse a list of expressions separated by commas."
 434   (let ((stuff nil))
 435     (loop
 436       (push (parse-infix 0) stuff)
 437       (unless (delim '|,| nil)
 438         (return)))
 439     (nreverse stuff)))
 440
 441 (export 'parse-ident-list)
 442 (defun parse-ident-list ()
 443   "Parse a list of symbols separated by commas."
 444   (let ((stuff nil))
 445     (loop
 446       (unless (symbolp *token*)
 447         (error "expected symbol; found ~S" *token*))
 448       (push *token* stuff)
 449       (get-token)
 450       (unless (delim '|,| nil)
 451         (return)))
 452     (nreverse stuff)))
 453
 454 ;;;--------------------------------------------------------------------------
 455 ;;; Various simple operators.
 456
 457 (definfix |,| (:lassoc -1) (binop-apply-append 'progn))
 458
 459 (definfix or (:lassoc 10) (binop-apply-append 'or))
 460 (definfix and (:lassoc 15) (binop-apply-append 'and))
 461
 462 (defprefix not 19 (unop-apply-toggle 'not))
 463
 464 (definfix == (:lassoc 20) (binop-apply-append '=))
 465 (definfix /= (:lassoc 20) (binop-apply-append '/=))
 466 (definfix < (:lassoc 20) (binop-apply-append '<))
 467 (definfix <= (:lassoc 20) (binop-apply-append '<=))
 468 (definfix >= (:lassoc 20) (binop-apply-append '>=))
 469 (definfix > (:lassoc 20) (binop-apply-append '>))
 470 (definfix eq (:lassoc 20) (binop-apply-append 'eq))
 471 (definfix eql (:lassoc 20) (binop-apply-append 'eql))
 472 (definfix equal (:lassoc 20) (binop-apply-append 'equal))
 473 (definfix equalp (:lassoc 20) (binop-apply-append 'equalp))
 474
 475 (definfix \| (:lassoc 30) (binop-apply-append 'logior))
 476 (definfix xor (:lassoc 30) (binop-apply-append 'logxor))
 477 (definfix & (:lassoc 35) (binop-apply-append 'logand))
 478
 479 (definfix << (:lassoc 40) (binop-apply 'ash))
 480 (definfix >> (:lassoc 40) (unop-apply-toggle '-) (binop-apply 'ash))
 481
 482 (definfix + (:lassoc 50) (binop-apply-append '+))
 483 (definfix - (:lassoc 50) (binop-apply-append '-))
 484
 485 (definfix * (:lassoc 60) (binop-apply-append '*))
 486 (definfix / (:lassoc 60) (binop-apply '/))
 487 (definfix // (:lassoc 60) (binop-apply 'floor))
 488 (definfix % (:lassoc 60) (binop-apply 'mod))
 489
 490 (definfix ^ (:rassoc 70) (binop-apply 'expt))
 491
 492 (definfix = (120 . 5) (binop-apply 'setf))
 493 (definfix += (120 . 5) (binop-apply 'incf))
 494 (definfix -= (120 . 5) (binop-apply 'decf))
 495
 496 (defprefix + 100 nil)
 497 (defprefix - 100 (unop-apply-toggle '-))
 498 (defprefix ~ 100 (unop-apply-toggle 'lognot))
 499
 500 (defprefix ++ 100 (unop-apply 'incf))
 501 (defprefix -- 100 (unop-apply 'decf))
 502
 503 ;;(defpostfix ! 110 (unop-apply 'factorial))
 504
 505 (defopfunc @ operand
 506   "An escape to the standard Lisp reader."
 507   (pushval (read *stream* t nil t))
 508   (get-token))
 509
 510 ;;;--------------------------------------------------------------------------
 511 ;;; Parentheses, for grouping and function-calls.
 512
 513 (export 'push-paren)
 514 (defun push-paren (right)
 515   "Pushes a funny parenthesis operator.  Since this operator has no left
 516    precedence, and very low right precedence, it is pushed over any stack of
 517    operators and can only be popped by magic or end-of-file.  In the latter
 518    case, cause an error."
 519   (pushop (make-operator :name right
 520                          :lprec nil :rprec -1000
 521                          :func (errfunc "missing `~A'" right)))
 522   (incf *paren-depth*)
 523   (get-token))
 524
 525 (export 'pop-paren)
 526 (defun pop-paren (right)
 527   "Pops a parenthesis.  If there are no parentheses, maybe they belong to the
 528    caller's syntax.  Otherwise, pop off operators above the current funny
 529    parenthesis operator, and then remove it."
 530   (when (zerop *paren-depth*)
 531     (infix-done))
 532   (flushops -999)
 533   (assert *opstk*)
 534   (unless (eq (op-name (car *opstk*)) right)
 535     (error "spurious `~A'" right))
 536   (assert (plusp *paren-depth*))
 537   (decf *paren-depth*)
 538   (pop *opstk*)
 539   (get-token))
 540
 541 (defopfunc |(| prefix (push-paren '\)))
 542 (defopfunc |)| postfix (pop-paren '\)))
 543 (defopfunc |{| prefix (push-paren '\}))
 544 (defopfunc |}| postfix (pop-paren '\}))
 545
 546 (defopfunc |(| postfix
 547   (get-token)
 548   (pushval (cons (popval) (and (not (eq *token* '|)|)) (parse-expr-list))))
 549   (delim '|)|))
 550
 551 ;;;--------------------------------------------------------------------------
 552 ;;; Various bits of special syntax.
 553
 554 (defopfunc if operand
 555   "Parse an `if' form.  Syntax:
 556
 557      IF ::= `if' CONDITION `then' CONSEQUENCE [`else' ALTERNATIVE]
 558
 559    We parse this into an `if' where sensible, or into a `cond' if we see an
 560    `else if' pair.  The usual `dangling else' rule is followed."
 561   (get-token)
 562   (let (cond cons)
 563     (setf cond (parse-infix))
 564     (delim 'then)
 565     (setf cons (parse-infix 0))
 566     (if (not (eq *token* 'else))
 567         (pushval (list 'if cond cons))
 568         (progn
 569           (get-token)
 570           (cond ((not (eq *token* 'if))
 571                  (pushval (list 'if cond cons (parse-infix 0))))
 572                 (t
 573                  (let ((clauses nil))
 574                    (flet ((clause (cond cons)
 575                             (push (cons cond (strip-progn cons)) clauses)))
 576                      (clause cond cons)
 577                      (loop
 578                        (get-token)
 579                        (setf cond (parse-infix))
 580                        (delim 'then)
 581                        (setf cons (parse-infix 0))
 582                        (clause cond cons)
 583                        (unless (eq *token* 'else) (return))
 584                        (get-token)
 585                        (if (eq *token* 'if)
 586                            (get-token)
 587                            (progn
 588                              (clause t (parse-infix 0))
 589                              (return))))
 590                      (pushval (cons 'cond (nreverse clauses)))))))))))
 591
 592 (defun do-letlike (kind)
 593   "Parse a `let' form.  Syntax:
 594
 595      LET ::= `let' | `let*' VARS `in' EXPR
 596      VARS ::= VAR | VARS `,' VAR
 597      VAR ::= NAME [`=' VALUE]
 598
 599    Translates into the obvious Lisp code."
 600   (let ((clauses nil) name value)
 601     (get-token)
 602     (loop
 603       (unless (symbolp *token*)
 604         (error "symbol expected, found ~S" *token*))
 605       (setf name *token*)
 606       (get-token)
 607       (if (eq *token* '=)
 608           (progn
 609             (get-token)
 610             (setf value (parse-infix 0))
 611             (push (list name value) clauses))
 612           (push name clauses))
 613       (unless (eq *token* '|,|)
 614         (return))
 615       (get-token))
 616     (delim 'in)
 617     (pushval `(,kind ,(nreverse clauses) ,@(strip-progn (parse-infix 0))))))
 618 (defopfunc let operand (do-letlike 'let))
 619 (defopfunc let* operand (do-letlike 'let*))
 620
 621 (defopfunc when operand
 622   (get-token)
 623   (pushval `(when ,(parse-infix)
 624               ,@(progn (delim 'do) (strip-progn (parse-infix 0))))))
 625
 626 (defopfunc unless operand
 627   (get-token)
 628   (pushval `(unless ,(parse-infix)
 629               ,@(progn (delim 'do) (strip-progn (parse-infix 0))))))
 630
 631 (defopfunc loop operand
 632   (get-token)
 633   (pushval `(loop ,@(strip-progn (parse-infix 0)))))
 634
 635 (defopfunc bind operand
 636   (labels ((loopy ()
 637             (let ((ids (parse-ident-list))
 638                   (valform (progn (delim '=) (parse-infix 0)))
 639                   (body (if (delim '|,| nil)
 640                             (loopy)
 641                             (progn
 642                               (delim 'in)
 643                               (strip-progn (parse-infix 0))))))
 644               (list (if (and ids (null (cdr ids)))
 645                         `(let ((,(car ids) ,valform)) ,@body)
 646                         `(multiple-value-bind ,ids ,valform ,@body))))))
 647     (get-token)
 648     (pushval (car (loopy)))))
 649
 650 ;;;--------------------------------------------------------------------------
 651 ;;; Parsing function bodies and lambda lists.
 652
 653 (defun parse-lambda-list ()
 654   "Parse an infix-form lambda list and return the Lisp equivalent."
 655   (flet ((ampersand-symbol-p (thing)
 656            (and (symbolp thing)
 657                 (let ((name (symbol-name thing)))
 658                   (plusp (length name))
 659                   (char= (char name 0) #\&))))
 660          (get-lambda-token ()
 661            (default-get-token)
 662            (when (or (eq *token* '&)
 663                      (eq *token* '|(|))
 664              (unread-char #\& *stream*)
 665              (setf *token* (read *stream* t nil t)))))
 666     (let ((args nil))
 667       (let ((*get-token* #'get-lambda-token))
 668         (delim '|(|)
 669         (unless (eq *token* '|)|)
 670           (tagbody
 671            loop
 672              (cond ((ampersand-symbol-p *token*)
 673                     (push *token* args)
 674                     (get-token)
 675                     (when (eq *token* '|)|)
 676                       (go done))
 677                     (delim '|,| nil)
 678                     (go loop))
 679                    ((symbolp *token*)
 680                     (let ((name *token*))
 681                       (get-token)
 682                       (if (delim '= nil)
 683                           (push (list name (parse-infix 0)) args)
 684                           (push name args))))
 685                    (t
 686                     (push *token* args)
 687                     (get-token)))
 688              (when (delim '|,| nil)
 689                (go loop))
 690            done)))
 691       (delim '|)|)
 692       (nreverse args))))
 693
 694 (defun parse-func-name ()
 695   "Parse a function name and return its Lisp equivalent."
 696   (cond ((delim '|(| nil)
 697          (prog1 (parse-infix) (delim '|)|)))
 698         (t (prog1 *token* (get-token)))))
 699
 700 (defopfunc lambda operand
 701   (get-token)
 702   (pushval `(lambda ,(parse-lambda-list) ,@(strip-progn (parse-infix 0)))))
 703
 704 (defun do-defunlike (kind)
 705   "Process a defun-like form."
 706   (get-token)
 707   (pushval `(,kind ,(parse-func-name) ,(parse-lambda-list)
 708               ,@(strip-progn (parse-infix 0)))))
 709
 710 (defopfunc defun operand (do-defunlike 'defun))
 711 (defopfunc defmacro operand (do-defunlike 'defmacro))
 712
 713 (defun do-fletlike (kind)
 714   "Process a flet-like form."
 715   (get-token)
 716   (let ((clauses nil))
 717     (loop
 718       (push `(,(parse-func-name) ,(parse-lambda-list)
 719                ,@(strip-progn (parse-infix 0)))
 720             clauses)
 721       (unless (delim '|,| nil)
 722         (return)))
 723     (delim 'in)
 724     (pushval `(,kind ,(nreverse clauses) ,@(strip-progn (parse-infix 0))))))
 725
 726 (defopfunc flet operand (do-fletlike 'flet))
 727 (defopfunc labels operand (do-fletlike 'labels))
 728
 729 ;;;--------------------------------------------------------------------------
 730 ;;; User-interface stuff.
 731
 732 (export 'read-infix)
 733 (defun read-infix (&optional (*stream* *standard-input*) &key (delim eof))
 734   "Reads an infix expression from STREAM and returns the corresponding Lisp.
 735    Requires the expression to be delimited properly by DELIM (by default
 736    end-of-file)."
 737   (let (*token*)
 738     (prog2
 739         (get-token)
 740         (parse-infix)
 741       (unless (eq *token* delim)
 742         (error "expected ~S; found ~S" delim *token*)))))
 743
 744 (export 'install-infix-reader)
 745 (defun install-infix-reader
 746     (&optional (start #\{) (end #\}) &key dispatch (readtable *readtable*))
 747   "Installs a macro character `{ INFIX... }' for translating infix notation
 748    to Lisp forms.  You also want to (use-package :infix-keywords) if you do
 749    this."
 750   (let ((delim (intern (string end) 'infix-keywords)))
 751     (flet ((doit (stream &rest noise)
 752              (declare (ignore noise))
 753              (read-infix stream :delim delim)))
 754       (if dispatch
 755           (set-dispatch-macro-character dispatch start #'doit readtable)
 756           (set-macro-character start #'doit nil readtable))
 757       (unless (or (eql start end)
 758                   (multiple-value-bind
 759                       (func nontermp)
 760                       (get-macro-character end readtable)
 761                     (and func (not nontermp))))
 762         (set-macro-character end (lambda (&rest noise)
 763                                    (declare (ignore noise))
 764                                    (error "Unexpected `~C'." end))
 765                              nil readtable)))))
 766
 767 ;;;--------------------------------------------------------------------------
 768 ;;; Testing things.
 769
 770 (defun test-infix (string)
 771   (with-input-from-string (in string)
 772     (read-infix in)))
 773
 774 (defun test-tokenize (string &optional (get-token #'get-token))
 775   (with-input-from-string (*stream* string)
 776     (loop with *token* = nil
 777           do (funcall get-token)
 778           until (eq *token* eof)
 779           collect *token*)))
 780
 781 (defun testrig (what run tests)
 782   (loop with ok = t
 783         with error = nil
 784         for (input . output) in tests
 785         for result = (handler-case (funcall run input)
 786                        (error (err)
 787                          (setf error (format nil "~A" err))
 788                          'fail))
 789         unless (equal result output)
 790         do (format t "~&~
 791 *** ~S test failure
 792     input    = ~S
 793     result   = ~:[~S~*~;~*error ~A~]
 794     expected = ~S~%"
 795                    what
 796                    input
 797                    (eq result 'fail) result error
 798                    output)
 799            (setf ok nil)
 800            finally (return ok)))
 801
 802 #+notdef
 803 (testrig "tokenize" #'test-tokenize
 804   '(("++z" . (++ z))
 805     ("z++" . (z++))
 806     ("z ++" . (z ++))
 807     ("-5" . (- 5))
 808     ("&optional" . (& optional))
 809     ("(4)" . (|(| 4 |)|))))
 810
 811 #+notdef
 812 (testrig "infix" #'test-infix
 813   '(("5" . 5)
 814     ("-5" . (- 5))
 815     ("-" . fail)
 816     ("1 + 1" . (+ 1 1))
 817     ("(1" . fail)
 818     ("1)" . fail)
 819     ("1 + 2 + 3" . (+ 1 2 3))
 820     ("++x" . (incf x))
 821     ("x += 5" . (incf x 5))
 822     ("1 << 5" . (ash 1 5))
 823     ("1 >> 5" . (ash 1 (- 5)))
 824     ("1 & 5" . (logand 1 5))
 825     ("lambda (x, y) x + y" . (lambda (x y) (+ x y)))
 826     ("lambda (x, y) (x += y, x - 1)" . (lambda (x y) (incf x y) (- x 1)))
 827     ("lambda (x, &optional y = 1) x - y" .
 828      (lambda (x &optional (y 1)) (- x y)))
 829     ("foo(x, y)" . (foo x y))
 830     ("if a == b then x + y" . (if (= a b) (+ x y)))
 831     ("if a == b then x + y else x - y" . (if (= a b) (+ x y) (- x y)))
 832     ("if a == b then x + y else if a == -b then x - y" .
 833      (cond ((= a b) (+ x y)) ((= a (- b)) (- x y))))
 834     ("let x = 1 in x ^ 4" . (let ((x 1)) (expt x 4)))
 835     ("x ^ y ^ z" . (expt x (expt y z)))
 836     ("a < b and not b < c or c > d" .
 837      (or (and (< a b) (not (< b c))) (> c d)))
 838     ("cdr(x) = nil" . (setf (cdr x) nil))
 839     ("labels foo (x) x + 1, bar (x) x - 1 in foo(bar(y))".
 840      (labels ((foo (x) (+ x 1)) (bar (x) (- x 1))) (foo (bar y))))
 841     ("defun foo (x) x - 6" .
 842      (defun foo (x) (- x 6)))
 843     ("bind x = 3 in x - 2" . (let ((x 3)) (- x 2)))
 844     ("bind x, y = values(1, 2),
 845            z = 3,
 846            docs, decls, body = parse-body(body) in complicated" .
 847      (multiple-value-bind (x y) (values 1 2)
 848        (let ((z 3))
 849          (multiple-value-bind (docs decls body) (parse-body body)
 850            complicated))))))
 851
 852 ;;;--------------------------------------------------------------------------
 853 ;;; Debugging guff.
 854
 855 #+notdef
 856 (flet ((dotrace (func)
 857          (and func
 858               (trace :function func
 859                      :encapsulate nil
 860                      :print-all *token*
 861                      :print-all *opstk*
 862                      :print-all *valstk*))))
 863   (untrace)
 864   (dolist (s '(if \( \) \:))
 865     (dolist (p '(infix prefix postfix))
 866       (let ((op (get s p)))
 867         (dotrace (etypecase op
 868                    (function op)
 869                    (operator (op-func op))
 870                    (null nil))))))
 871   (dolist (f '(read-infix parse-infix binop-apply unop-apply pushval popval
 872                pushop flushops push-paren get-token))
 873     (dotrace f)))
 874
 875 ;;;--------------------------------------------------------------------------