CLに中間記法を導入するリードマクロ。http://my.opera.com/zeptometer/blog/2011/03/27/cl

infix.lisp

(defvar operators '( (||) (&&) (^) (&) (== !=) (< <= > >=) (>>> >> <<) (+ -) (* / %))   "演算子。優先順位の低い順にグループ分け。")
(defvar clfunction '((|| or) (&& and) (^ logxor) (& logand) (== =) (!= (lambda (x y) (not (= x y)))) (< <) (<= <=) (> >) (>= >=) (>>> (lambda (x y) (ash x (- y))))(>> (lambda (x y) (lsh x (- y)))) (<< lsh)  (+ +) (- -) (* *) (/ /) (% mod) (^ expt)) "演算子と関数の対応表")

(defun single (x)
  (and (consp x) (null (cdr x))))

(defun operatorp (op)
  (some (lambda (x) (member op x)) operators))

(defun infixp (exp)
  "expが中間記法の時、tを返す"
  (and (consp exp)
       (not (operatorp (car exp)))
       (operatorp (cadr exp))
       (or (infixp (cddr exp))
	   (single (cddr exp)))))

(defun op-cl (op)
  "opに対応するCL関数を返す"
  (cadr (assoc op clfunction)))

(defun devide-infix (exp ops)
  "ops中の演算子でexpを分割する。複数出てくる場合は最後のものを。
   三つの値を返す。
   1: 演算子
   2: 演算子より前の式
   3: 演算子より後の式

   Example:
   (devide-infix '(1 + 2 * 3 - 3) '(+ -))
    -> -
       (1 + 2 * 3)
       (3)"
  (labels ((rec (exp ops after)
	     (if (member (car exp) ops)
		 (values (car exp) (reverse (cdr exp)) after)
		 (rec (cdr exp) ops (cons (car exp) after)))))
    (if (some (lambda (x) (member x exp)) ops)
	(rec (reverse exp) ops nil))))

(defun infix-polish (exp)
  "中間記法の式を普通のS式(ポーランド記法)に変換する。"
  (if (infixp exp)
      (dolist (ops operators)
	(when (some (lambda (op) (member op exp)) ops)
	  (multiple-value-bind (op bef af) (devide-infix exp ops)
	    (return (list (op-cl op) (infix-polish bef) (infix-polish af))))))
      (let ((x (car exp)))
	(if (infixp x)
	    (infix-polish x)
	    x))))

(defmacro infix (&rest exp)
  "中間記法用マクロ"
  (infix-polish exp))

(set-macro-character #\} (get-macro-character #\)))

(set-macro-character #\{
		     (lambda (stream char)
		       (declare (ignore char))
		       (cons 'infix (read-delimited-list #\} stream t))))