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