reader-macro-parser.lisp

;; expression ::= term [ +|- expression ].
;; term ::= factor [ *|/ term ].
;; factor ::= simple [ ^ factor ].
;; simple ::= variable | literal | '(' expression ')' .

(defun parse-expression (stream)
  (let ((term (parse-term stream)))
    (if (find (peek-char t stream nil) "+-")
        (let ((op (intern (string (read-char stream))))
              (expression (parse-expression stream)))
          `(,op ,term ,expression))
        term)))

(defun parse-term (stream)
  (let ((factor (parse-factor stream)))
    (if (find (peek-char t stream nil) "*/")
        (let ((op (intern (string (read-char stream))))
              (term (parse-term stream)))
          `(,op ,factor ,term))
        factor)))

(defun parse-factor (stream)
  (let ((simple (parse-simple stream)))
    (if (find (peek-char t stream nil) "^")
        (let ((op (intern (string (read-char stream))))
              (factor (parse-factor stream)))
          `(,op ,simple ,factor))
        simple)))

(defun parse-simple (stream)
  (let ((peeked (peek-char t stream nil)))
    (cond
      ((find peeked "(")
       (read-char stream)
       (prog1 (parse-expression stream)
         (if (find (peek-char t stream nil) ")")
             (read-char stream)
             (error "Invalid character '~C' ; expected a closing parenthesis."
                    (read-char stream)))))
      ((find peeked "+-0123456789")
       (let ((buffer (make-array 80 :element-type 'character :fill-pointer 0 :adjustable t)))
         (vector-push (read-char stream) buffer)
         (loop
           :for digit := (peek-char nil stream nil)
           :while (find digit "0123456789")
           :do (vector-push-extend (read-char stream) buffer (length buffer)))
         (parse-integer buffer)))
      ((alphanumericp peeked)
       (let ((buffer (make-array 80 :element-type 'character :fill-pointer 0 :adjustable t)))
         (vector-push (read-char stream) buffer)
         (loop
           :for peeked := (peek-char nil stream nil)
           :while (or (alphanumericp peeked) (find peeked "-_.$"))
           :do (vector-push-extend (read-char stream) buffer (length buffer)))
         (intern (funcall (ecase (readtable-case *readtable*)
                            (:upcase   (function string-upcase))
                            (:downcase (function string-downcase))
                            (:preserve (function identity))
                            (:invert   (lambda (name)
                                         (funcall (cond
                                                    ((and (some (function upper-case-p) name)
                                                          (notany (function lower-case-p) name))
                                                     (function string-downcase))
                                                    ((and (some (function upper-case-p) name)
                                                          (notany (function lower-case-p) name))
                                                     (function string-upcase))
                                                    (t
                                                     (function identity)))
                                                  name))))
                          buffer)))))))

;; (untrace parse-expression parse-term parse-factor parse-simple)
(assert (equalp (with-input-from-string (in "a*x^2 + (b1+b2)*x + (c1+(c2/c3)+c3)")
                  (parse-expression in))
                '(+ (* a (^ x 2)) (+ (* (+ b1 b2) x) (+ c1 (+ (/ c2 c3) c3))))))

(defun read-infix-expression (stream ch)
  (declare (ignore ch))
  (prog1 (parse-expression stream)
    (let ((terminator  (peek-char t stream nil)))
      (cond
        ((find terminator "}")
         (read-char stream))
        ((null terminator)
         (error "end-of-file while reading an infix expression/"))
        (t
         (error "Superfluous character after infix expression '~C'"
                (read-char stream)))))))

(set-macro-character #\{ (quote read-infix-expression) nil *readtable*)
(assert (equalp '{a*x^2 + (b1+b2)*x + (c1+(c2/c3)+c3)}
                '(+ (* a (^ x 2)) (+ (* (+ b1 b2) x) (+ c1 (+ (/ c2 c3) c3))))))