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

infix.lisp

(defpackage :infix
  (:use :cl)
  (:export #:operators
	   #:operator-clfunction
	   #:arfunction
	   #:arfunction-clfunction))

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

(defvar arfunction '((sqrt 1) (sin 1) (cos 1) (tan 1) (log 2) (+ 1) (- 1)) "算術関数とその引数の一覧")
(defvar arfunction-clfunction '((sqrt sqrt) (sin sin) (cos cos) (tan tan) (log log) (+ +) (- -)) "算術関数とCL関数の対応表")

(defvar stack nil)

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

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

(defun arfunctionp (ar)
  (cadr (assoc ar arfunction)))

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

(defun ar-cl (ar)
  (cadr (assoc ar arfunction-clfunction)))

(defun applyar (exp)
  (labels ((rec (exp loaded)
	     (cond ((null exp) 
		       (reverse loaded))
		   ((single exp) 
		       (rec nil (cons (car exp)loaded)))
		   ((arfunctionp (car exp)) 
		       (multiple-value-bind (exp* rest) (loadar exp)
			 (rec (cons exp* rest) loaded)))
		   ((and (not (arfunctionp (car exp))) 
			 (operatorp (cadr exp)))
		       (rec (cddr exp) (list* (cadr exp) (car exp) loaded))))))
    (rec exp nil)))

(defun loadar (exp)
  (destructuring-bind (ar &rest rest) exp
    (push (list (ar-cl ar)) stack)
    (dotimes (i (arfunctionp ar))
      (if (arfunctionp (car rest))
	  (multiple-value-bind (exp* rest*) (loadar rest)
	    (push exp* (car stack))
	    (setf rest rest*))
	  (push (pop rest) (car stack))))
    (values (reverse (pop stack)) rest)))

(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 (single exp)
      (car 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))))))))

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

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

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