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