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