+Negatives work after a comma

[lineal.git] / src / infix-parser.lisp

;;;; Here is the dreaded infix parser.
;;;; Heavily commented so I remember what happens here.
;
; General setup:
; An ordered stack of operations is build up as closures,
; each hold an accumulated value. When an operator of lesser
; "rank" (see rank constants below) is encountered, the stack unwinds
; recursively, passing the encountered rank and the accumulated
; value for the operation.
;
; Obviously there are different scopes where these operations apply,
; namely "paren" and "function" scopes. Both scopes have their own
; "read-eval" loop which terminate by the usual stack unwind and
; a thrown symbol corresponding to the scope:
; 'break-paren scope and 'break-fn-scope
;
; The order of events and the way the termination is handled
; is DIFFERENT between the two. Function scope is notably more
; complex because I don't require ONE function parameter to be
; enclosed in parentheses, multiple parameters require them.
;
; TODO: overhaul parser to read 2a as 2*a
; This will be a big change, optionally giving functions
; control of the reader to parse their arguments.

(in-package :lineal)

;V Set precedence ranks.V
(defconstant +base-rank+ 0)
(defconstant +paren-rank+ 1)
(defconstant +comma-rank+ 2)
(defconstant +fn-rank+ 3)
(defconstant +addn-rank+ 4)
(defconstant +subtrn-rank+ 5)
(defconstant +multn-rank+ 6)
(defconstant +divisn-rank+ 7)
(defconstant +exptn-rank+ 8)
(defconstant +vip-rank+ 9);< Virtually infinite precedence.

;;; a b = a*b
(defun multn-if-last-read ()
  (declare (special *last-read*))
  (when *last-read*
    ;; Implicit multiplication, two
    ;; values were seperated by a space.
    (catch 'fn-scope
           (parsed-opern +multn-rank+ #'multn))))

;;; Everything in the file calls this
;;; read function on the infix stream.
(defun read-next-infix (strm)
  (declare (special *unwind-rank-fn* *last-read*))
  (handler-case
    (let (this-read)
      (let ((*package* (find-package
                         :lineal.client-vars)))
        ;; Actually read from the stream,
        ;; sometimes an exception is thrown and
        ;; control breaks to the current "read loop"
        (setq this-read (read strm)))
      (when this-read
        ;; Did not just read an operator.
        (multn-if-last-read);< Check for implied multiplication.
        (if (symbolp this-read)
          (let ((val (symbol-value this-read)))
            ;; Don't bother checking boundp,
            ;; there's a condition catch in
            ;; process-infix-from-stream
            (if (symbolp val)
              ;; A symbol representing a function
              ;; was read, change scope.
              (parse-function-scope
                strm (symbol-function val))
              (setq *last-read* val)))
          (setq *last-read* this-read))))
    (end-of-file
      (condit)
      (declare (ignore condit))
      ;; Don't check for unclosed parentheses,
      ;; be like the TI-83
      (funcall *unwind-rank-fn*
               +base-rank+ *last-read*))))

;;; This is a generic construct for a closure
;;; which will be stored as *unwind-rank-fn*
(defmacro opern-climber-lambda
  ((this-rank op-rank val) . body)
  `(lambda (,op-rank ,val)
     (unless ,val
       ;; A prefixed operator (see function below)
       ;; was parsed last, unary-pre-opern.
       (unary-pre-opern
         ,this-rank (the function ,op-rank)))
     (locally
       (declare (type (integer 0 ,+vip-rank+) ,op-rank))
       ,@body)))

;;; When something like 2 + -3 is encountered,
;;; the negative is what this function deals with.
(defun unary-pre-opern (prev-rank this-op-fn)
  (declare (special *unwind-rank-fn*))
  (let ((prev-unwind-rank-fn *unwind-rank-fn*)
        this-unwind-rank-fn)
    (setq
      this-unwind-rank-fn
      (opern-climber-lambda
        (prev-rank op-rank val)
        (if (and (< prev-rank op-rank)
                 (< +multn-rank+ op-rank))
          (progn (setq *unwind-rank-fn* 
                       this-unwind-rank-fn)
                 val)
          (funcall prev-unwind-rank-fn op-rank
                   (funcall this-op-fn val))))
      *unwind-rank-fn* this-unwind-rank-fn)
    (throw 'fn-scope (values))))

;;; A binary operator is parsed.
(defun parsed-opern (this-rank this-op-fn)
  (declare (special *unwind-rank-fn* *last-read*))
  (unless *last-read*
    (funcall *unwind-rank-fn* this-op-fn nil))
  (let* ((args (cons (funcall *unwind-rank-fn*
                              this-rank *last-read*)
                     nil))
         (tail args)
         (prev-unwind-rank-fn *unwind-rank-fn*)
         this-unwind-rank-fn)
    (setq
      *last-read* nil
      this-unwind-rank-fn
      (opern-climber-lambda
        (this-rank op-rank val)
        (cond
          ((= this-rank op-rank)
           (setq
             *unwind-rank-fn* this-unwind-rank-fn
             *last-read* nil
             tail (cdr (rplacd tail (cons val nil))))
           (throw 'fn-scope (values)))
          ((< this-rank op-rank)
           (setq *unwind-rank-fn* this-unwind-rank-fn)
           val)
          (t
            (rplacd tail (cons val nil))
            (funcall prev-unwind-rank-fn op-rank
                     (apply this-op-fn args)))))
      *unwind-rank-fn* this-unwind-rank-fn)
    nil))

(defun parse-function-scope (strm this-fn)
  (declare (special *unwind-rank-fn* *last-read*))
  (do () ((not (char= #\Space (peek-char nil strm))))
    (read-char strm))
  (when (char= #\( (peek-char nil strm))
    ;; User chose to enclose the
    ;; argument(s) in parentheses.
    (read-next-infix strm)
    (setq *last-read*
          (if (consp *last-read*)
            (apply this-fn *last-read*)
            (funcall this-fn *last-read*)))
    (return-from parse-function-scope (values)))
  (when (char= #\) (peek-char nil strm))
    ;; Using notation like (f*g)(x)
    ;; (unimplemented)
    (setq *last-read* this-fn)
    (return-from parse-function-scope (values)))
  (let ((prev-unwind-rank-fn *unwind-rank-fn*)
        this-unwind-rank-fn)
    (setq
      *last-read* nil
      this-unwind-rank-fn
      (opern-climber-lambda
        (+fn-rank+ op-rank val)
        (cond
          ((< op-rank +fn-rank+)
           ;; Breaking from parens or program.
           (funcall prev-unwind-rank-fn
                    op-rank (if (consp val)
                              (apply this-fn val)
                              (funcall this-fn val))))
          ((= op-rank +fn-rank+)
           ;; Return from the function scope.
           (setq *unwind-rank-fn* prev-unwind-rank-fn
                 *last-read* (if (consp val)
                               (apply this-fn val)
                               (funcall this-fn val)))
           (throw 'break-fn-scope (values)))
          (t ;V Stay in the function scope.V
            (setq *unwind-rank-fn* this-unwind-rank-fn)
            val)))
      *unwind-rank-fn* this-unwind-rank-fn)
    (catch
      'break-fn-scope
      (do () (nil)
        (catch 'fn-scope
               (read-next-infix strm))))
    (funcall *unwind-rank-fn*
             +fn-rank+ *last-read*)))

;;; "read-eval" loop used by process-infix-from-stream
;;; and open-paren-reader
(defun parse-infix (strm)
  (declare (special *unwind-rank-fn* *last-read*))
  (let ((prev-unwind-rank-fn *unwind-rank-fn*)
        this-unwind-rank-fn)
    (setq
      *last-read* nil
      this-unwind-rank-fn
      (opern-climber-lambda
        (+paren-rank+ op-rank val)
        (cond
          ((< op-rank +paren-rank+)
           (funcall prev-unwind-rank-fn
                    op-rank val))
          ((= op-rank +paren-rank+)
           ;; Closing paren encountered.
           (setq *unwind-rank-fn* prev-unwind-rank-fn
                 *last-read* val)
           (throw 'break-paren-scope (values)))
          (t
            (setq *unwind-rank-fn* this-unwind-rank-fn)
            val)))
      *unwind-rank-fn* this-unwind-rank-fn)
    (do () (nil)
      (catch
        'break-fn-scope
        (catch
          'fn-scope
          (read-next-infix strm))))))

(defun open-paren-reader (strm ch)
  (declare (ignore ch))
  (multn-if-last-read)
  (catch 'break-paren-scope
         (parse-infix strm))
  nil)

;;; Unwind the operation stack.
;;; When the paren closure is reached,
;;; *last-read* is set to the value calculated within
;;; the parenthesis and 'break-paren-scope is thrown.
(defun close-paren-reader (strm ch)
  (declare (ignore strm ch)
           (special *unwind-rank-fn* *last-read*))
  (funcall *unwind-rank-fn*
           +paren-rank+ *last-read*))

;;; If *last-read* is nil, an operator
;;; was read last, we can't logically
;;; break from a function in that case.
(defun space-reader (strm ch)
  (declare (ignore strm ch)
           (special *last-read*))
  (when *last-read*
    (throw 'break-fn-scope (values))))

(defun comma-reader (strm ch)
  (declare (ignore strm ch)
           (special *unwind-rank-fn* *last-read*))
  (let* ((lis (cons (funcall *unwind-rank-fn*
                             +comma-rank+ *last-read*)
                    nil))
         (tail lis)
         (prev-unwind-rank-fn *unwind-rank-fn*)
         this-unwind-rank-fn)
    (setq
      *last-read* nil
      this-unwind-rank-fn
      (opern-climber-lambda
        (+comma-rank+ op-rank val)
        (cond
          ((= +comma-rank+ op-rank)
           (setq
             *unwind-rank-fn*
             this-unwind-rank-fn
             *last-read* nil
             tail
             (cdr (rplacd tail (cons val nil))))
           (throw 'break-fn-scope (values)))
          ((< +comma-rank+ op-rank)
           ;todo: figure out what this does
           (setq *unwind-rank-fn*
                 this-unwind-rank-fn)
           val)
          (t (rplacd tail (cons val nil)) 
             (funcall prev-unwind-rank-fn op-rank
                      lis))))
      *unwind-rank-fn* this-unwind-rank-fn)
    nil))

(defun set-opern-reader (ch this-rank this-op-fn)
  (set-macro-character
    ch
    (lambda (strm ch)
      (declare (ignore strm ch))
      (parsed-opern this-rank this-op-fn))))

(defparameter *infix-readtable* (copy-readtable))

(let ((*readtable* *infix-readtable*))
    (setf (readtable-case *readtable*) :preserve)
    (set-macro-character #\( #'open-paren-reader)
    (set-macro-character #\) #'close-paren-reader)
    (set-macro-character #\Space #'space-reader)
    (set-macro-character #\, #'comma-reader)
    (set-opern-reader #\+ +addn-rank+ #'addn)
    (set-opern-reader #\- +subtrn-rank+ #'subtrn)
    (set-opern-reader #\* +multn-rank+ #'multn)
    (set-opern-reader #\/ +divisn-rank+ #'divisn)
    (set-opern-reader #\^ +exptn-rank+ #'exptn))


(defun process-infix-from-stream (strm)
  (let ((*readtable* *infix-readtable*)
        (*unwind-rank-fn*
          (lambda (op-rank val)
            (declare (ignore op-rank))
            (throw 'end-result val)))
        *last-read*)
    (declare (special *unwind-rank-fn* *last-read*))
    (handler-case
      (catch 'over-ex
             (catch 'end-result
                    (parse-infix strm)))
      (control-error
        (condit)
        (declare (ignore condit))
        (format
          nil "Likely too many parens! ~
          (as if there were such a thing)~%"))
      (error
        (condit)
        (format
          nil "Evaluation flopped, perhaps bad input?~%~
          Debug info: ~A~%" condit)))))

(defun process-input-from-stream
  (strm &optional (infixp t))
  (let ((*read-default-float-format* 'double-float)
        (*read-eval* nil))
    (if infixp (process-infix-from-stream strm)
      (process-prefix-from-stream strm))))

(defun process-input-from-string
  (text &optional (infixp t))
  (with-input-from-string (strm text)
    (process-input-from-stream strm infixp)))