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
 238 (defun open-paren-after-whitespace-peekp ()
 239   (declare (special *parse-strm* *parse-next*))
 240   (unless *parse-next*
 241     (do () ((not (char= #\Space (peek-char nil *parse-strm*)))
 242             (char=  #\( (peek-char nil *parse-strm*)))
 243       (read-char *parse-strm*))))
 244
 245 (defun closed-paren-peekp ()
 246   (declare (special *parse-strm* *parse-next*))
 247   (unless *parse-next*
 248     (char= #\) (peek-char nil *parse-strm*))))
 249
 250 (defun parse-function-scope (this-fn)
 251   (declare (special *unwind-rank-fn* *last-read*))
 252   (when (open-paren-after-whitespace-peekp)
 253     ;; User chose to enclose the
 254     ;; argument(s) in parentheses.
 255     (read-next-infix)
 256     (setq *last-read*
 257           (if (consp *last-read*)
 258             (apply this-fn *last-read*)
 259             (funcall this-fn *last-read*)))
 260     (return-from parse-function-scope (values)))
 261   (when (closed-paren-peekp)
 262     ;; Using notation like (f*g)(x)
 263     ;; (unimplemented)
 264     (setq *last-read* this-fn)
 265     (return-from parse-function-scope (values)))
 266   (let ((prev-unwind-rank-fn *unwind-rank-fn*)
 267         this-unwind-rank-fn)
 268     (setq
 269       *last-read* nil
 270       this-unwind-rank-fn
 271       (opern-climber-lambda
 272         (+fn-rank+ op-rank val)
 273         (cond
 274           ((< op-rank +fn-rank+)
 275            ;; Breaking from parens or program.
 276            (funcall prev-unwind-rank-fn
 277                     op-rank (if (consp val)
 278                               (apply this-fn val)
 279                               (funcall this-fn val))))
 280           ((= op-rank +fn-rank+)
 281            ;; Return from the function scope.
 282            (setq *unwind-rank-fn* prev-unwind-rank-fn
 283                  *last-read* (if (consp val)
 284                                (apply this-fn val)
 285                                (funcall this-fn val)))
 286            (throw 'break-fn-scope (values)))
 287           (t ;V Stay in the function scope.V
 288             (setq *unwind-rank-fn* this-unwind-rank-fn)
 289             val)))
 290       *unwind-rank-fn* this-unwind-rank-fn)
 291     (catch
 292       'break-fn-scope
 293       (do () (nil)
 294         (catch 'fn-scope
 295                (read-next-infix))))
 296     (funcall *unwind-rank-fn*
 297              +fn-rank+ *last-read*)))
 298
 299 ;;; "read-eval" loop used by process-infix-from-stream
 300 ;;; and open-paren-reader
 301 (defun parse-infix ()
 302   (declare (special *unwind-rank-fn* *last-read*))
 303   (let ((prev-unwind-rank-fn *unwind-rank-fn*)
 304         this-unwind-rank-fn)
 305     (setq
 306       *last-read* nil
 307       this-unwind-rank-fn
 308       (opern-climber-lambda
 309         (+paren-rank+ op-rank val)
 310         (cond
 311           ((< op-rank +paren-rank+)
 312            (funcall prev-unwind-rank-fn
 313                     op-rank val))
 314           ((= op-rank +paren-rank+)
 315            ;; Closing paren encountered.
 316            (setq *unwind-rank-fn* prev-unwind-rank-fn
 317                  *last-read* val)
 318            (throw 'break-paren-scope (values)))
 319           (t
 320             (setq *unwind-rank-fn* this-unwind-rank-fn)
 321             val)))
 322       *unwind-rank-fn* this-unwind-rank-fn)
 323     (do () (nil)
 324       (catch
 325         'break-fn-scope
 326         (catch
 327           'fn-scope
 328           (read-next-infix))))))
 329
 330 (defun open-paren-reader (strm ch)
 331   (declare (ignore strm ch))
 332   (multn-if-last-read)
 333   (catch 'break-paren-scope
 334          (parse-infix))
 335   nil)
 336
 337 ;;; Unwind the operation stack.
 338 ;;; When the paren closure is reached,
 339 ;;; *last-read* is set to the value calculated within
 340 ;;; the parenthesis and 'break-paren-scope is thrown.
 341 (defun close-paren-reader (strm ch)
 342   (declare (ignore strm ch)
 343            (special *unwind-rank-fn* *last-read*))
 344   (funcall *unwind-rank-fn*
 345            +paren-rank+ *last-read*))
 346
 347 ;;; If *last-read* is nil, an operator
 348 ;;; was read last, we can't logically
 349 ;;; break from a function in that case.
 350 (defun space-reader (strm ch)
 351   (declare (ignore strm ch)
 352            (special *last-read*))
 353   (when *last-read*
 354     (throw 'break-fn-scope (values))))
 355
 356 (defun comma-reader (strm ch)
 357   (declare (ignore strm ch)
 358            (special *unwind-rank-fn* *last-read*))
 359   (let* ((lis (cons (funcall *unwind-rank-fn*
 360                              +comma-rank+ *last-read*)
 361                     nil))
 362          (tail lis)
 363          (prev-unwind-rank-fn *unwind-rank-fn*)
 364          this-unwind-rank-fn)
 365     (setq
 366       *last-read* nil
 367       this-unwind-rank-fn
 368       (opern-climber-lambda
 369         (+comma-rank+ op-rank val)
 370         (cond
 371           ((= +comma-rank+ op-rank)
 372            (setq
 373              *unwind-rank-fn*
 374              this-unwind-rank-fn
 375              *last-read* nil
 376              tail
 377              (cdr (rplacd tail (cons val nil))))
 378            (throw 'break-fn-scope (values)))
 379           ((< +comma-rank+ op-rank)
 380            ;todo: figure out what this does
 381            (setq *unwind-rank-fn*
 382                  this-unwind-rank-fn)
 383            val)
 384           (t (rplacd tail (cons val nil))
 385              (funcall prev-unwind-rank-fn op-rank
 386                       lis))))
 387       *unwind-rank-fn* this-unwind-rank-fn)
 388     nil))
 389
 390 (defun set-opern-reader (ch this-rank this-op-fn)
 391   (set-macro-character
 392     ch
 393     (lambda (strm ch)
 394       (declare (ignore strm ch))
 395       (parsed-opern this-rank this-op-fn))))
 396
 397 (defparameter *infix-readtable* (copy-readtable))
 398
 399 (let ((*readtable* *infix-readtable*))
 400     (setf (readtable-case *readtable*) :preserve)
 401     (set-macro-character #\( #'open-paren-reader)
 402     (set-macro-character #\) #'close-paren-reader)
 403     (set-macro-character #\Space #'space-reader)
 404     (set-macro-character #\, #'comma-reader)
 405     (set-opern-reader #\+ +addn-rank+ #'addn)
 406     (set-opern-reader #\- +subtrn-rank+ #'subtrn)
 407     (set-opern-reader #\* +multn-rank+ #'multn)
 408     (set-opern-reader #\/ +divisn-rank+ #'divisn)
 409     (set-macro-character #\! #'factorial-reader)
 410     (set-opern-reader #\^ +exptn-rank+ #'exptn))
 411
 412 (defun process-infix-from-stream (strm)
 413   (let ((*readtable* *infix-readtable*)
 414         (*parse-strm* strm);< Stream to parse.
 415         *parse-next*;< Temporary buffer if we overparsed.
 416         (*unwind-rank-fn*
 417           (lambda (op-rank val)
 418             (declare (ignore op-rank))
 419             (throw 'end-result val)))
 420         *last-read*)
 421     (declare (special
 422                *parse-strm* *parse-next*
 423                *unwind-rank-fn* *last-read*))
 424     (handler-case
 425       (catch 'over-ex
 426              (catch 'end-result
 427                     (parse-infix)))
 428       (control-error
 429         (condit)
 430         (declare (ignore condit))
 431         (format
 432           nil "Likely too many parens! ~
 433           (as if there were such a thing)~%"))
 434       (unbound-variable
 435         (condit)
 436         (format nil "I don't understand: ~A~%"
 437                 (cell-error-name condit)))
 438       (error
 439         (condit)
 440         (format
 441           nil "Evaluation flopped, perhaps bad input?~%~
 442           Debug info: ~A~%" condit)))))
 443
 444 (defun process-input-from-stream
 445   (strm &optional (infixp t))
 446   (let ((*read-default-float-format* 'double-float)
 447         (*read-eval* nil))
 448     (if infixp (process-infix-from-stream strm)
 449       (process-prefix-from-stream strm))))
 450
 451 (defun process-input-from-string
 452   (text &optional (infixp t))
 453   (with-input-from-string (strm text)
 454     (process-input-from-stream strm infixp)))
 455