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 (in-package :lineal)
  27
  28 ;;; Define variables as constant integers
  29 (defmacro enumerate-constants (&rest syms &aux (v 0))
  30   (declare (integer v))
  31   (cons 'progn
  32         (mapcar
  33           (lambda (k)
  34             (unless (symbolp k)
  35               (setf (values k v) (values-list k)))
  36             (prog1 `(defconstant ,k ,v)
  37               (incf v)))
  38           syms)))
  39
  40 ;V Set precedence ranks.V
  41 (enumerate-constants
  42   +base-rank+
  43   +paren-rank+
  44   +comma-rank+
  45   +fn-rank+
  46   +addn-rank+
  47   +subtrn-rank+
  48   +multn-rank+
  49   +divisn-rank+
  50   +factorial-rank+
  51   +exptn-rank+
  52   +vip-rank+);< Virtually infinite precedence.
  53
  54 ;;; a b = a*b
  55 (defun multn-if-last-read ()
  56   (declare (special *last-read*))
  57   (when *last-read*
  58     ;; Implicit multiplication, two
  59     ;; values were seperated by a space.
  60     (catch 'fn-scope
  61            (parsed-opern +multn-rank+ #'multn))))
  62
  63 ;;; See if /parsed-thing/ can be interpreted
  64 ;;; in any way. If so, call success-fn, then
  65 ;;; finish interpreting.
  66 (defun interpret-parsed
  67   (parsed-thing &optional (success-fn #'values))
  68   (declare (special *last-read*))
  69   (multn-if-last-read);< Check for implied multiplication.
  70   (if (symbolp parsed-thing)
  71     (when (boundp parsed-thing)
  72       (let ((val (symbol-value parsed-thing)))
  73         (funcall success-fn)
  74         (if (symbolp val)
  75           ;; A symbol representing a function
  76           ;; was read, change scope.
  77           (parse-function-scope
  78             (symbol-function val))
  79           (setq *last-read* val))))
  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                    (funcall 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                      (apply 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         (lineal.overload::factorial
 235           (funcall *unwind-rank-fn*
 236                    +factorial-rank+ *last-read*)))
 237   nil)
 238
 239
 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 (defun parse-function-scope (this-fn)
 253   (declare (special *unwind-rank-fn* *last-read*))
 254   (when (open-paren-after-whitespace-peekp)
 255     ;; User chose to enclose the
 256     ;; argument(s) in parentheses.
 257     (read-next-infix)
 258     (setq *last-read*
 259           (if (consp *last-read*)
 260             (apply this-fn *last-read*)
 261             (funcall this-fn *last-read*)))
 262     (return-from parse-function-scope (values)))
 263   (when (closed-paren-peekp)
 264     ;; Using notation like (f*g)(x)
 265     ;; (unimplemented)
 266     (setq *last-read* this-fn)
 267     (return-from parse-function-scope (values)))
 268   (let ((prev-unwind-rank-fn *unwind-rank-fn*)
 269         this-unwind-rank-fn)
 270     (setq
 271       *last-read* nil
 272       this-unwind-rank-fn
 273       (opern-climber-lambda
 274         (+fn-rank+ op-rank val)
 275         (cond
 276           ((< op-rank +fn-rank+)
 277            ;; Breaking from parens or program.
 278            (funcall prev-unwind-rank-fn
 279                     op-rank (if (consp val)
 280                               (apply this-fn val)
 281                               (funcall this-fn val))))
 282           ((= op-rank +fn-rank+)
 283            ;; Return from the function scope.
 284            (setq *unwind-rank-fn* prev-unwind-rank-fn
 285                  *last-read* (if (consp val)
 286                                (apply this-fn val)
 287                                (funcall this-fn val)))
 288            (throw 'break-fn-scope (values)))
 289           (t ;V Stay in the function scope.V
 290             (setq *unwind-rank-fn* this-unwind-rank-fn)
 291             val)))
 292       *unwind-rank-fn* this-unwind-rank-fn)
 293     (catch
 294       'break-fn-scope
 295       (do () (nil)
 296         (catch 'fn-scope
 297                (read-next-infix))))
 298     (funcall *unwind-rank-fn*
 299              +fn-rank+ *last-read*)))
 300
 301 ;;; "read-eval" loop used by process-infix-from-stream
 302 ;;; and open-paren-reader
 303 (defun parse-infix ()
 304   (declare (special *unwind-rank-fn* *last-read*))
 305   (let ((prev-unwind-rank-fn *unwind-rank-fn*)
 306         this-unwind-rank-fn)
 307     (setq
 308       *last-read* nil
 309       this-unwind-rank-fn
 310       (opern-climber-lambda
 311         (+paren-rank+ op-rank val)
 312         (cond
 313           ((< op-rank +paren-rank+)
 314            (funcall prev-unwind-rank-fn
 315                     op-rank val))
 316           ((= op-rank +paren-rank+)
 317            ;; Closing paren encountered.
 318            (setq *unwind-rank-fn* prev-unwind-rank-fn
 319                  *last-read* val)
 320            (throw 'break-paren-scope (values)))
 321           (t
 322             (setq *unwind-rank-fn* this-unwind-rank-fn)
 323             val)))
 324       *unwind-rank-fn* this-unwind-rank-fn)
 325     (do () (nil)
 326       (catch
 327         'break-fn-scope
 328         (catch
 329           'fn-scope
 330           (read-next-infix))))))
 331
 332 (defun open-paren-reader (strm ch)
 333   (declare (ignore strm ch))
 334   (multn-if-last-read)
 335   (catch 'break-paren-scope
 336          (parse-infix))
 337   nil)
 338
 339 ;;; Unwind the operation stack.
 340 ;;; When the paren closure is reached,
 341 ;;; *last-read* is set to the value calculated within
 342 ;;; the parenthesis and 'break-paren-scope is thrown.
 343 (defun close-paren-reader (strm ch)
 344   (declare (ignore strm ch)
 345            (special *unwind-rank-fn* *last-read*))
 346   (funcall *unwind-rank-fn*
 347            +paren-rank+ *last-read*))
 348
 349 ;;; If *last-read* is nil, an operator
 350 ;;; was read last, we can't logically
 351 ;;; break from a function in that case.
 352 (defun space-reader (strm ch)
 353   (declare (ignore strm ch)
 354            (special *last-read*))
 355   (when *last-read*
 356     (throw 'break-fn-scope (values))))
 357
 358 (defun comma-reader (strm ch)
 359   (declare (ignore strm ch)
 360            (special *unwind-rank-fn* *last-read*))
 361   (let* ((lis (cons (funcall *unwind-rank-fn*
 362                              +comma-rank+ *last-read*)
 363                     nil))
 364          (tail lis)
 365          (prev-unwind-rank-fn *unwind-rank-fn*)
 366          this-unwind-rank-fn)
 367     (setq
 368       *last-read* nil
 369       this-unwind-rank-fn
 370       (opern-climber-lambda
 371         (+comma-rank+ op-rank val)
 372         (cond
 373           ((= +comma-rank+ op-rank)
 374            (setq
 375              *unwind-rank-fn*
 376              this-unwind-rank-fn
 377              *last-read* nil
 378              tail
 379              (cdr (rplacd tail (cons val nil))))
 380            (throw 'break-fn-scope (values)))
 381           ((< +comma-rank+ op-rank)
 382            ;todo: figure out what this does
 383            (setq *unwind-rank-fn*
 384                  this-unwind-rank-fn)
 385            val)
 386           (t (rplacd tail (cons val nil))
 387              (funcall prev-unwind-rank-fn op-rank
 388                       lis))))
 389       *unwind-rank-fn* this-unwind-rank-fn)
 390     nil))
 391
 392 (defun set-opern-reader (ch this-rank this-op-fn)
 393   (set-macro-character
 394     ch
 395     (lambda (strm ch)
 396       (declare (ignore strm ch))
 397       (parsed-opern this-rank this-op-fn))))
 398
 399 (defparameter *infix-readtable* (copy-readtable))
 400
 401 (let ((*readtable* *infix-readtable*))
 402     (setf (readtable-case *readtable*) :preserve)
 403     (set-macro-character #\( #'open-paren-reader)
 404     (set-macro-character #\) #'close-paren-reader)
 405     (set-macro-character #\Space #'space-reader)
 406     (set-macro-character #\, #'comma-reader)
 407     (set-opern-reader #\+ +addn-rank+ #'addn)
 408     (set-opern-reader #\- +subtrn-rank+ #'subtrn)
 409     (set-opern-reader #\* +multn-rank+ #'multn)
 410     (set-opern-reader #\/ +divisn-rank+ #'divisn)
 411     (set-macro-character #\! #'factorial-reader)
 412     (set-opern-reader #\^ +exptn-rank+ #'exptn))
 413
 414 (defun process-infix-from-stream (strm)
 415   (let ((*readtable* *infix-readtable*)
 416         (*parse-strm* strm);< Stream to parse.
 417         *parse-next*;< Temporary buffer if we overparsed.
 418         (*unwind-rank-fn*
 419           (lambda (op-rank val)
 420             (declare (ignore op-rank))
 421             (throw 'end-result val)))
 422         *last-read*)
 423     (declare (special
 424                *parse-strm* *parse-next*
 425                *unwind-rank-fn* *last-read*))
 426     (handler-case
 427       (catch 'over-ex
 428              (catch 'end-result
 429                     (parse-infix)))
 430       (control-error
 431         (condit)
 432         (declare (ignore condit))
 433         (format
 434           nil "Likely too many parens! ~
 435           (as if there were such a thing)~%"))
 436       (unbound-variable
 437         (condit)
 438         (format nil "I don't understand: ~A~%"
 439                 (cell-error-name condit)))
 440       (error
 441         (condit)
 442         (format
 443           nil "Evaluation flopped, perhaps bad input?~%~
 444           Debug info: ~A~%" condit)))))
 445
 446 (defun process-input-from-stream
 447   (strm &optional (infixp t))
 448   (let ((*read-default-float-format* 'double-float)
 449         (*read-eval* nil))
 450     (if infixp (process-infix-from-stream strm)
 451       (process-prefix-from-stream strm))))
 452
 453 (defun process-input-from-string
 454   (text &optional (infixp t))
 455   (with-input-from-string (strm text)
 456     (process-input-from-stream strm infixp)))
 457