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