infix to prefix function and reader macro in Common Lisp

infix.lisp

;;;; infix to prefix function and reader macro

;; BSD 2-Clause License
;;
;; Copyright (c) 2021, Frank Buss
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are met:
;;
;; 1. Redistributions of source code must retain the above copyright notice, this
;;    list of conditions and the following disclaimer.
;;
;; 2. Redistributions in binary form must reproduce the above copyright notice,
;;    this list of conditions and the following disclaimer in the documentation
;;    and/or other materials provided with the distribution.
;;
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

;; usage example with the infix function:
;;
;;   CL-USER > (infix "1+2")
;;   (+ 1 2)
;;
;;   CL-USER > (infix "99*x^5-0.1*x^2+abc*sin(x^(y-1))")
;;   (+ (- (* 99 (EXPT X 5)) (* 0.1 (EXPT X 2))) (* ABC (SIN (EXPT X (- Y 1)))))
;;
;; using the reader macro #i to convert it at compile time:
;;
;;   CL-USER > (loop for x from 0 to 3 collect #i "2*x^2+3*x-5")
;;   (-5 0 9 22)

(defmacro defun-eval-recursive (function next-function char-function-list)
  `(defun ,function (stream)
     (let ((value (,next-function stream)))
       (loop do
             (let ((c (peek-char t stream nil nil)))
               (if c
                   (cond
                    ,@(loop for (char function) in char-function-list collect
                            `((char= c ,char)
                              (read-char stream)
                              (setf value
                                    `(,',function ,value
                                                  ,(,next-function stream)))))
                    (t (loop-finish)))
                 (loop-finish))))
       value)))

(defun-eval-recursive eval-infix eval-product ((#\+ +) (#\- -)))

(defun-eval-recursive eval-product eval-expt ((#\* *) (#\/ /)))

(defun-eval-recursive eval-expt eval-unary ((#\^ expt)))

(defun eval-unary (stream)
  (if (check-char stream #\-)
      `(- ,(eval-primary stream))
    (eval-primary stream)))

(defun eval-primary (stream)
  (if (check-char stream #\()
      (let ((value (eval-infix stream)))
        (expect stream #\))
        value)
    (let ((symbol-string
           (with-output-to-string (out)
             (loop for c = (peek-char nil stream nil nil) do
                   (unless (and c (or (alphanumericp c)
                                      (char= c #\.)))
                     (loop-finish))
                   (write-char c out)
                   (read-char stream)))))
      (with-input-from-string (s symbol-string)
        (let ((symbol (read s)))
          (if (and (alphanumericp (elt symbol-string 0))
                   (check-char stream #\())
              (let ((function-argument (eval-infix stream)))
                (expect stream #\))
                `(, symbol ,function-argument))
            symbol))))))

(defun expect (stream char)
  (unless (check-char stream char)
    (error (format nil "~a expected" char))))

(defun check-char (stream char)
  (let ((c (peek-char t stream nil nil)))
    (when (and c (char= c char))
      (read-char stream))))

(defun infix (string)
  (with-input-from-string (s string)
    (eval-infix s)))

(defun read-infix (stream subchar arg)
  (declare (ignore subchar arg))
  (expect stream #\")
  (prog1
      (eval-infix stream)
    (expect stream #\")))

(set-dispatch-macro-character #\# #\i #'read-infix)

(defun test ()
  (let ((tests '(("1" 1)
                 ("1+2" (+ 1 2))
                 ("-1+(-2*3)" (+ (- 1) (* (- 2) 3)))
                 ("2+3*4/5^x" (+ 2 (/ (* 3 4) (expt 5 x))))
                 ("1.5e2*10 + cos(x)" (+ (* 150.0 10) (cos x))))))
    (loop for (string expected) in tests do
          (assert (equalp (infix string) expected)))))