通常の順序で算術式を書けるようにするマクロ +α

最近読んでた本。
LISP〈1〉 (情報処理シリーズ)
LISP〈2〉 (情報処理シリーズ)
この２巻のほうで、通常の順序で書いた算術式を解釈する方法が解説されている。演習問題として単項演算を導入せよというのがあったので、やってみた。ついでに大小評価を連鎖できたり、積の記号（アスタリスク）を省略できたりという機能も追加してある。
inf-to-pre がメインで、中間記法を前置記法に組み替える関数。ここから出発して、inf-aux と inf-iter が再帰的にパースしていく。前者は算術式スタックのトップが演算項であることを期待し、後者は演算子であることを期待する。期待された種類のものが来なかった場合、例外処理をする。前者の場合は単項演算に出会ったとき（直後の項と結びつける）、後者の場合は積の記号が省略されているとき（アスタリスクを追加して再読）がそれにあたる。
inf-iter は、算術式スタックで期待通り演算子に出会うと、演算子スタックのトップと優先順位を比べ、スタックに積むか、演算項のトップ２つを結びつけるかする。このとき演算子が右結合か左結合かによって使う比較演算子が変わる。
算術式スタックが空になったら、演算子スタックが空になるまで演算項スタックを消費して、結果を返す。

(defparameter *unary-operators*
  '(- ~ not sin cos tan))

(defparameter *binary-operators*
  '(or and == != < > <= >= = + - * / % ^))

(defparameter *right-to-left-operators*  '(=))

(defparameter *weight-limit* 10)

(defun unary (obj)
  (member obj *unary-operators*))

(defun right-to-left-p (operator)
  (member operator *right-to-left-operators*))

(defun weight (operator)
  (case operator
    (or 0)
    (and 1)
    ((== != < > <= >=) 2)
    (= 3)
    ((+ -) 4)
    ((* / %) 5)
    (^ 6)
    (t *weight-limit*)))

(defun opcode-1 (unary-operator)
  (case unary-operator
    (~ 'not)
    (t unary-operator)))

(defun opcode-2 (binary-operator)
  (case binary-operator
    (== 'arith-eq)
    (!= 'arith-ne)
    (< 'arith-lt)
    (> 'arith-gt)
    (<= 'arith-le)
    (>= 'arith-ge)
    (= 'setf)
    (% 'mod)
    (^ 'expt)
    (t binary-operator)))

(defmacro arith (arithmetic-expression)
  (inf-to-pre arithmetic-expression))

(defun inf-to-pre (ae)
  (if (atom ae)
      ae
      (inf-aux ae nil nil)))

(defun inf-aux (ae operators operands)
  (let ((top (car ae)))
    (if (unary top)
        (inf-iter (cddr ae)
                  operators
                  (cons (list (opcode-1 top)
                              (inf-to-pre (cadr ae)))
                        operands))
        (inf-iter (cdr ae)
                  operators
                  (cons (inf-to-pre (car ae))
                        operands)))))

(defun inf-iter (ae operators operands)
  (cond ((and (null ae) (null operators))
         (car operands))
        ((and ae
              (or (listp (car ae))
                  (= (weight (car ae)) *weight-limit*)))
         (inf-iter (cons '* ae) operators operands))
        ((and ae
              (or (null operators)
                  (let ((op (car ae)))
                    (if (right-to-left-p op)
                        (>= (weight op)
                            (weight (car operators)))
                        (> (weight op)
                           (weight (car operators)))))))
         (inf-aux (cdr ae)
                  (cons (car ae) operators)
                  operands))
        (t (inf-iter ae
                     (cdr operators)
                     (cons (list (opcode-2 (car operators))
                                 (cadr operands)
                                 (car operands))
                           (cddr operands))))))

(defun arith-lt (left right) (if (and left (<  left right)) right))
(defun arith-gt (left right) (if (and left (>  left right)) right))
(defun arith-le (left right) (if (and left (<= left right)) right))
(defun arith-ge (left right) (if (and left (>= left right)) right))
(defun arith-eq (left right) (if (and left (=  left right)) right))
(defun arith-ne (left right) (if (and left (/= left right)) right))

使用例：

CL-USER> (inf-to-pre '(y = fx = a x ^ 2 + b x + c))
(SETF Y (SETF FX (+ (+ (* A (EXPT X 2)) (* B X)) C)))
CL-USER> (inf-to-pre '(sin x ^ 2 + cos x ^ 2))
(+ (EXPT (SIN X) 2) (EXPT (COS X) 2))
CL-USER> (arith (3.1 < pi < sqrt 10 < 3.2))
3.2