src/infix-parser.lisp

   1
   2 ;;;; I suggest you move along to another file,
   3 ;;;; this one is terribly coded and in constant change.
   4 ;;;; But if you care to look around - good luck.
   5
   6 ;;;; Heavily commented so I remember what happens here.
   7 ;
   8 ; General setup:
   9 ; An ordered stack of operations is build up as closures,
  10 ; each hold an accumulated value. When an operator of lesser
  11 ; "rank" (see rank constants below) is encountered, the stack unwinds
  12 ; recursively, passing the encountered rank and the accumulated
  13 ; value for the operation.
  14 ;
  15 ; Obviously there are different scopes where these operations apply,
  16 ; namely "paren" and "function" scopes. Both scopes have their own
  17 ; "read-eval" loop which terminate by the usual stack unwind and
  18 ; a thrown symbol corresponding to the scope:
  19 ; 'break-paren scope and 'break-fn-scope
  20 ;
  21 ; The order of events and the way the termination is handled
  22 ; is DIFFERENT between the two. Function scope is notably more
  23 ; complex because I don't require ONE function parameter to be
  24 ; enclosed in parentheses, multiple parameters require them.
  25
  26 ;;; Define variables as constant integers
  27 (defmacro enumerate-constants (&rest syms &aux (v 0))
  28   (declare (integer v))
  29   (cons 'progn
  30         (mapcar
  31           (lambda (k)
  32             (unless (symbolp k)
  33               (setf (values k v) (values-list k)))
  34             (prog1 `(defconstant ,k ,v)
  35               (incf v)))
  36           syms)))
  37
  38 ;V Set precedence ranks.V
  39 (enumerate-constants
  40   +base-rank+
  41   +paren-rank+
  42   +comma-rank+
  43   +fn-rank+
  44   +addn-rank+
  45   +subtrn-rank+
  46   +multn-rank+
  47   +divisn-rank+
  48   +factorial-rank+
  49   +exptn-rank+
  50   +vip-rank+);< Virtually infinite precedence.
  51
  52 ;;; a b = a*b
  53 (defun multn-if-last-read ()
  54   (declare (special *last-read*))
  55   (when *last-read*
  56     ;; Implicit multiplication, two
  57     ;; values were seperated by a space.
  58     (catch 'fn-scope
  59            (parsed-opern +multn-rank+ 'multn))))
  60
  61 ;;; See if /parsed-thing/ can be interpreted
  62 ;;; in any way. If so, call success-fn, then
  63 ;;; finish interpreting.
  64 (defun interpret-parsed
  65   (parsed-thing &optional (success-fn #'values))
  66   (declare (special *last-read*))
  67   (multn-if-last-read);< Check for implied multiplication.
  68   (if (symbolp parsed-thing)
  69     (when (boundp parsed-thing)
  70       (let ((val (symbol-value parsed-thing)))
  71         (funcall success-fn)
  72         (if (symbolp val)
  73           ;; A symbol representing a function
  74           ;; was read, change scope.
  75           (parse-function-scope val) ;(symbol-function val)
  76           (setq *last-read* parsed-thing))))
  77     (progn
  78       ;; The reader thinks it's something other
  79       ;; than a symbol, parser doesn't need to worry.
  80       (funcall success-fn)
  81       (setq *last-read* parsed-thing))))
  82
  83 ;;; An invalid symbol was read,
  84 ;;; could be something like "34x"
  85 (defun parse-compact (&optional sym &aux arrlen)
  86   (declare (special *parse-next* *last-read*))
  87   (if sym
  88     ;; Must create *parse-next* from a symbol
  89     (let ((sym-str (symbol-name sym)))
  90       (setq arrlen (length sym-str)
  91             *parse-next*
  92             (make-array arrlen
  93                         :element-type 'character
  94                         :fill-pointer (1- arrlen)
  95                         :displaced-to sym-str)))
  96     (setq arrlen (length *parse-next*)))
  97   (loop
  98     :for index :from (fill-pointer *parse-next*) :downto 1
  99     :do
 100     (let (successp)
 101       (setf (fill-pointer *parse-next*) index)
 102       (interpret-parsed
 103         (let ((*package* (find-package :lineal.client-vars)))
 104           (read-from-string *parse-next*))
 105         (lambda ()
 106           ;; We found valid input.
 107           (setf successp t)
 108           (if (= index arrlen)
 109             (setf *parse-next* nil)
 110             (setf
 111               (fill-pointer *parse-next*) arrlen
 112               *parse-next*
 113               (make-array (- arrlen index)
 114                           :element-type 'character
 115                           :fill-pointer t
 116                           :displaced-to *parse-next*
 117                           :displaced-index-offset index)))))
 118       (when successp (return)))
 119     :finally
 120     ;; Nothing matched; quit trying.
 121     (setf (fill-pointer *parse-next*) arrlen)
 122     (signal 'unbound-variable :name *parse-next*)))
 123
 124
 125 ;;; Everything in the file calls this
 126 ;;; read function on the infix stream.
 127 (defun read-next-infix ()
 128   (declare (special *unwind-rank-fn* *last-read*
 129                     *parse-strm* *parse-next*))
 130   (if *parse-next* (parse-compact)
 131     (handler-case
 132       (let (this-read)
 133         (let ((*package* (find-package
 134                            :lineal.client-vars)))
 135           ;; Sometimes an exception is thrown and
 136           ;; control breaks to the current "read loop"
 137           (setq this-read (read *parse-strm*)))
 138         (when (and this-read
 139                    ;; Did not just read an operator.
 140                    (let (successp)
 141                      (interpret-parsed
 142                        this-read
 143                        (lambda () (setf successp t)))
 144                      (not successp)))
 145           ;; We have no idea wtf was just read.
 146           (parse-compact this-read)))
 147       (end-of-file
 148         (condit)
 149         (declare (ignore condit))
 150         ;; Don't check for unclosed parentheses,
 151         ;; be like the TI-83
 152         (funcall *unwind-rank-fn*
 153                  +base-rank+ *last-read*)))))
 154
 155 ;;; This is a generic construct for a closure
 156 ;;; which will be stored as *unwind-rank-fn*
 157 (defmacro opern-climber-lambda
 158   ((this-rank op-rank val) . body)
 159   `(lambda (,op-rank ,val)
 160      (unless ,val
 161        ;; A prefixed operator (see function below)
 162        ;; was parsed last, unary-pre-opern.
 163        (unary-pre-opern
 164          ,this-rank (the function ,op-rank)))
 165      (locally
 166        (declare (type (integer 0 ,+vip-rank+) ,op-rank))
 167        ,@body)))
 168
 169 ;;; When something like 2 + -3 is encountered,
 170 ;;; the negative is what this function deals with.
 171 (defun unary-pre-opern (prev-rank this-op-fn)
 172   (declare (special *unwind-rank-fn*))
 173   (let ((prev-unwind-rank-fn *unwind-rank-fn*)
 174         this-unwind-rank-fn)
 175     (setq
 176       this-unwind-rank-fn
 177       (opern-climber-lambda
 178         (prev-rank op-rank val)
 179         (if (and (< prev-rank op-rank)
 180                  (< +multn-rank+ op-rank))
 181           (progn (setq *unwind-rank-fn*
 182                        this-unwind-rank-fn)
 183                  val)
 184           (funcall prev-unwind-rank-fn op-rank
 185                    (list this-op-fn val))))
 186       *unwind-rank-fn* this-unwind-rank-fn)
 187     (throw 'fn-scope (values))))
 188
 189 ;;; A binary operator is parsed.
 190 (defun parsed-opern (this-rank this-op-fn)
 191   (declare (special *unwind-rank-fn* *last-read*))
 192   (unless *last-read*
 193     (funcall *unwind-rank-fn* this-op-fn nil))
 194   (let* ((args (cons (funcall *unwind-rank-fn*
 195                               this-rank *last-read*)
 196                      nil))
 197          (tail args)
 198          (prev-unwind-rank-fn *unwind-rank-fn*)
 199          this-unwind-rank-fn)
 200     (setq
 201       *last-read* nil
 202       this-unwind-rank-fn
 203       (opern-climber-lambda
 204         (this-rank op-rank val)
 205         (cond
 206           ((= this-rank op-rank)
 207            (setq
 208              *unwind-rank-fn* this-unwind-rank-fn
 209              *last-read* nil
 210              tail (setf (cdr tail) (cons val nil)))
 211            (throw 'fn-scope (values)))
 212           ((< this-rank op-rank)
 213            (setq *unwind-rank-fn* this-unwind-rank-fn)
 214            val)
 215           (t
 216             (rplacd tail (cons val nil))
 217             (funcall prev-unwind-rank-fn op-rank
 218                      (cons this-op-fn args)))))
 219       *unwind-rank-fn* this-unwind-rank-fn)
 220     nil))
 221
 222 ;;; Parse an exclaimation point character.
 223 (defun factorial-reader (c strm)
 224   (declare (ignore c strm)
 225            (special *unwind-rank-fn* *last-read*))
 226   (unless *last-read*
 227     ;; Make sure any negatives are applied.
 228     (funcall *unwind-rank-fn*
 229              'lineal.overload::over-factorial nil))
 230   (setq *last-read*
 231         (list 'lineal.overload::factorial
 232               (funcall *unwind-rank-fn*
 233                        +factorial-rank+ *last-read*)))
 234   nil)
 235
 236 ;;; Specialized function to gobble whitespace
 237 ;;; and return true if the terminating char
 238 ;;; is an opening parenthesis.
 239 (defun open-paren-after-whitespace-peekp ()
 240   (declare (special *parse-strm* *parse-next*))
 241   (unless *parse-next*
 242     (do () ((not (char= #\Space (peek-char nil *parse-strm*)))
 243             (char=  #\( (peek-char nil *parse-strm*)))
 244       (read-char *parse-strm*))))
 245
 246 (defun closed-paren-peekp ()
 247   (declare (special *parse-strm* *parse-next*))
 248   (unless *parse-next*
 249     (char= #\) (peek-char nil *parse-strm*))))
 250
 251 ;;; A function was read, passed as /this-fn/,
 252 ;;; its arguments have yet to be parsed.
 253 (defun parse-function-scope (this-fn)
 254   (declare (special *unwind-rank-fn* *last-read* *parse-strm*))
 255   (when (open-paren-after-whitespace-peekp)
 256     ;; User chose to enclose the
 257     ;; argument(s) in parentheses.
 258     (read-char *parse-strm*)
 259     (paren-scope t)
 260     (setq *last-read*
 261           (if (consp *last-read*)
 262             ;V (apply this-fn *last-read*) V
 263             (cons this-fn *last-read*)
 264             ;V (funcall this-fn *last-read*) V
 265             (list this-fn *last-read*)))
 266     (return-from parse-function-scope (values)))
 267   (when (closed-paren-peekp)
 268     ;; Using notation like (f*g)(x)
 269     ;; (unimplemented)
 270     (setq *last-read* this-fn)
 271     (return-from parse-function-scope (values)))
 272   (let ((prev-unwind-rank-fn *unwind-rank-fn*)
 273         this-unwind-rank-fn)
 274     (setq
 275       *last-read* nil
 276       this-unwind-rank-fn
 277       (opern-climber-lambda
 278         (+fn-rank+ op-rank val)
 279         (cond
 280           ((< op-rank +fn-rank+)
 281            ;; Breaking from parens or program.
 282            (funcall prev-unwind-rank-fn
 283                     op-rank (if (consp val)
 284                               (cons this-fn val)
 285                               (list this-fn val))))
 286           ((= op-rank +fn-rank+)
 287            ;; Return from the function scope.
 288            (setq *unwind-rank-fn* prev-unwind-rank-fn
 289                  *last-read* (if (consp val)
 290                                (cons this-fn val)
 291                                (list this-fn val)))
 292            (throw 'break-fn-scope (values)))
 293           (t ;V Stay in the function scope.V
 294             (setq *unwind-rank-fn* this-unwind-rank-fn)
 295             val)))
 296       *unwind-rank-fn* this-unwind-rank-fn)
 297     (catch
 298       'break-fn-scope
 299       (do () (nil)
 300         (catch 'fn-scope
 301                (read-next-infix))))
 302     (funcall *unwind-rank-fn*
 303              +fn-rank+ *last-read*)))
 304
 305 ;;; "read-eval" loop used by process-infix-from-stream
 306 ;;; and open-paren-reader
 307 (defun parse-infix ()
 308   (declare (special *unwind-rank-fn* *last-read*))
 309   (let ((prev-unwind-rank-fn *unwind-rank-fn*)
 310         this-unwind-rank-fn)
 311     (setq
 312       *last-read* nil
 313       this-unwind-rank-fn
 314       (opern-climber-lambda
 315         (+paren-rank+ op-rank val)
 316         (cond
 317           ((< op-rank +paren-rank+)
 318            (funcall prev-unwind-rank-fn
 319                     op-rank val))
 320           ((= op-rank +paren-rank+)
 321            ;; Closing paren encountered.
 322            (setq *unwind-rank-fn* prev-unwind-rank-fn
 323                  *last-read* val)
 324            (throw 'break-paren-scope (values)))
 325           (t
 326             (setq *unwind-rank-fn* this-unwind-rank-fn)
 327             val)))
 328       *unwind-rank-fn* this-unwind-rank-fn)
 329     (do () (nil)
 330       (catch
 331         'break-fn-scope
 332         (catch
 333           'fn-scope
 334           (read-next-infix))))))
 335
 336 (defun paren-scope (paramsp)
 337   (declare (special *last-read*))
 338   (multn-if-last-read)
 339   (catch 'break-paren-scope
 340          (parse-infix))
 341   (when (and (not paramsp) (consp *last-read*))
 342     ;; Convert the list into a tuple
 343     ;; since it's not a function's parameters.
 344     (setq *last-read*
 345           (cons 'lineal.overload::over-vcat *last-read*))))
 346
 347 ;;; A parenthesis has been opened!
 348 (defun open-paren-reader (strm ch)
 349   (declare (ignore strm ch))
 350   (paren-scope nil)
 351   nil)
 352
 353 ;;; Unwind the operation stack.
 354 ;;; When the paren closure is reached,
 355 ;;; *last-read* is set to the value calculated within
 356 ;;; the parenthesis and 'break-paren-scope is thrown.
 357 (defun close-paren-reader (strm ch)
 358   (declare (ignore strm ch)
 359            (special *unwind-rank-fn* *last-read*))
 360   (funcall *unwind-rank-fn*
 361            +paren-rank+ *last-read*))
 362
 363 ;;; Much like open-paren-reader
 364 ;;; but creates a row matrix.
 365 ;;; (uses close-paren-reader
 366 ;;;  for closed brackets)
 367 (defun open-bracket-reader (strm ch)
 368   (declare (ignore strm ch)
 369            (special *last-read*))
 370   (multn-if-last-read)
 371   (catch 'break-paren-scope
 372          (parse-infix))
 373   (when (consp *last-read*)
 374     (setq *last-read*
 375           (cons 'lineal.overload::over-cat *last-read*)))
 376   nil)
 377
 378 ;;; If *last-read* is nil, an operator
 379 ;;; was read last, we can't logically
 380 ;;; break from a function in that case.
 381 (defun space-reader (strm ch)
 382   (declare (ignore strm ch)
 383            (special *last-read*))
 384   (when *last-read*
 385     (throw 'break-fn-scope (values))))
 386
 387 (defun comma-reader (strm ch)
 388   (declare (ignore strm ch)
 389            (special *unwind-rank-fn* *last-read*))
 390   (let* ((lis (cons (funcall *unwind-rank-fn*
 391                              +comma-rank+ *last-read*)
 392                     nil))
 393          (tail lis)
 394          (prev-unwind-rank-fn *unwind-rank-fn*)
 395          this-unwind-rank-fn)
 396     (setq
 397       *last-read* nil
 398       this-unwind-rank-fn
 399       (opern-climber-lambda
 400         (+comma-rank+ op-rank val)
 401         (cond
 402           ((= +comma-rank+ op-rank)
 403            (setq
 404              *unwind-rank-fn*
 405              this-unwind-rank-fn
 406              *last-read* nil
 407              tail
 408              (cdr (rplacd tail (cons val nil))))
 409            (throw 'break-fn-scope (values)))
 410           ((< +comma-rank+ op-rank)
 411            ;todo: figure out what this does
 412            (setq *unwind-rank-fn*
 413                  this-unwind-rank-fn)
 414            val)
 415           (t (rplacd tail (cons val nil))
 416              (funcall prev-unwind-rank-fn op-rank
 417                       lis))))
 418       *unwind-rank-fn* this-unwind-rank-fn)
 419     nil))
 420
 421 (defun set-opern-reader (ch this-rank this-op-fn)
 422   (set-macro-character
 423     ch
 424     (lambda (strm ch)
 425       (declare (ignore strm ch))
 426       (parsed-opern this-rank this-op-fn))))
 427
 428 (defparameter *infix-readtable* (copy-readtable))
 429
 430 (let ((*readtable* *infix-readtable*))
 431     (setf (readtable-case *readtable*) :preserve)
 432     (set-macro-character #\( #'open-paren-reader)
 433     (set-macro-character #\) #'close-paren-reader)
 434     (set-macro-character #\[ #'open-bracket-reader)
 435     (set-macro-character #\] #'close-paren-reader)
 436     (set-macro-character #\Space #'space-reader)
 437     (set-macro-character #\, #'comma-reader)
 438     (set-opern-reader #\+ +addn-rank+ 'addn)
 439     (set-opern-reader #\- +subtrn-rank+ 'subtrn)
 440     (set-opern-reader #\* +multn-rank+ 'multn)
 441     (set-opern-reader #\/ +divisn-rank+ 'divisn)
 442     (set-macro-character #\! #'factorial-reader)
 443     (set-opern-reader #\^ +exptn-rank+ 'exptn))
 444
 445 (defun parse-infix-from-stream (strm)
 446   (let ((*readtable* *infix-readtable*)
 447         (*parse-strm* strm);< Stream to parse.
 448         *parse-next*;< Temporary buffer if we overparsed.
 449         (*unwind-rank-fn*
 450           (lambda (op-rank val)
 451             (declare (ignore op-rank))
 452             (throw 'end-result val)))
 453         *last-read*)
 454     (declare (special
 455                *parse-strm* *parse-next*
 456                *unwind-rank-fn* *last-read*))
 457     (handler-case
 458       (catch 'over-ex
 459              (catch 'end-result
 460                     (parse-infix)))
 461       (control-error
 462         (condit)
 463         (declare (ignore condit))
 464         (format
 465           nil "Likely too many parens! ~
 466           (as if there were such a thing)~%"))
 467       (unbound-variable
 468         (condit)
 469         (format nil "I don't understand: ~A~%"
 470                 (cell-error-name condit)))
 471       (error
 472         (condit)
 473         (format
 474           nil "Evaluation flopped, perhaps bad input?~%~
 475           Debug info: ~A~%" condit)))))
 476
 477 (defun process-infix-from-stream (strm)
 478   (eval-parsed (parse-infix-from-stream strm)))
 479
 480 (defun process-input-from-stream
 481   (strm &optional (infixp t))
 482   (let ((*read-default-float-format* 'double-float)
 483         (*read-eval* nil))
 484     (if infixp (process-infix-from-stream strm)
 485       (process-prefix-from-stream strm))))
 486
 487 (defun process-input-from-string
 488   (text &optional (infixp t))
 489   (with-input-from-string (strm text)
 490     (process-input-from-stream strm infixp)))
 491