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