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

infix.lisp

(defpackage :infix
  (:use :cl)
  (:export #:add-operator
	   #:add-infix-function
	   #:install-default-operators-and-infix-functions))

(in-package :infix)

(defconstant leastpriority 20)

(defconstant default-operators 
  '((1 ** expt right)
    (2 *)
    (2 /)
    (2 % mod)
    (3 +)
    (3 -)
    (4 >> (lambda (x y) (ash x (- y))))
    (4 << ash)
    (5 <)
    (5 <=)
    (5 >)
    (5 >=)
    (6 == =)
    (6 != (lambda (x y) (not (= x y))))
    (7 & logand)
    (8 ^ logxor)
    (9 \| logior)
    (10 && and)
    (11 || or)
    (12 = setf right)
    (12 += incf right)
    (12 -= decf right)))

(defconstant default-infix-functions
  '((sqrt 1)
    (sin 1)
    (cos 1)
    (tan 1)
    (log 2)
    (loge 1 log)
    (log10 1 (lambda (x) (log x 10)))
    (+ 1)
    (- 1)
    (! 1 not)
    (~ 1 lognot)))


(defvar operators nil   "演算子。優先順位の低い順にグループ分け。")
(defvar operator-clfunction nil "演算子と関数の対応表")

(defvar arfunction nil "算術関数とその引数の一覧")
(defvar arfunction-clfunction nil "算術関数とCL関数の対応表")

(defvar stack nil)

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

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

(defun arfunctionp (ar)
  (cdr (assoc ar arfunction)))

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

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

(defun applyar (exp)
  "算術関数を普通のポーランド記法の形にする
   (applyar '(sqrt a + sin cos b))
   ->  '((sqrt a) + (sin (cos b)))"
  (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)
  "applyar補助関数
   (loadar '(sqrt a + sin cos b))
   -> (sqrt a)
      (+ sin cos b)"
  (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)
  "(cdr ops)中の演算子でexpを分割する。(car ops)にある結合を用いる。
   三つの値を返す。
   1: 演算子
   2: 演算子より前の式
   3: 演算子より後の式

   Example:
   (devide-infix '(1 + 2 * 3 - 3) '(left + -))
    -> -
       (1 + 2 * 3)
       (3)"
  (destructuring-bind (direction &rest ops*) ops
    (labels ((rec (exp ops* stack)
	       (if (member (car exp) ops*)
		   (ecase direction
		     (left (values (car exp) (reverse (cdr exp)) stack))
		     (right (values (car exp) (reverse stack) (cdr exp))))
		   (rec (cdr exp) ops* (cons (car exp) stack)))))
      (ecase direction
	(left (rec (reverse exp) ops* nil))
	(right (rec exp ops* nil))))))

(defun infix-polish (exp)
  "中間記法の式を普通のS式(ポーランド記法)に変換する。"
  (if (single exp)
      (car exp)
      (dolist (ops operators)
	(when (some (lambda (op) (member op exp)) (cdr 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)
  "中間記法用マクロ。
   applyarしてinfix-polishする"
  (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))))

(defun add-operator (priority op &optional cl-name (direction 'left))
  (unless cl-name
    (setq cl-name op))
  (push op (cdr (nth (ecase direction
		       (left (- (* 2 leastpriority) (* 2 priority)))
		       (right (- (* 2 leastpriority) (1+ (* 2 priority))))) operators)))
  (push (cons op cl-name) operator-clfunction))

(defun add-infix-function (fun num &optional cl-name)
  (unless cl-name
    (setf cl-name fun))
  (push (cons fun num) arfunction)
  (push (cons fun cl-name) arfunction-clfunction))

(defun initialize ()
  (setf operators (make-list (* 2 leastpriority) :initial-element nil))
  (setf operator-clfunction nil)
  (setf arfunction nil)
  (setf arfunction-clfunction nil)
  (dotimes (i leastpriority)
    (push 'left (nth (* 2 i) operators))
    (push 'right (nth (1+ (* 2 i)) operators))))

(defun install-default-operators-and-infix-functions ()
  (initialize)
  (mapcar #'(lambda (x) (apply #'add-operator x)) default-operators)
  (mapcar #'(lambda (x) (apply #'add-infix-function x)) default-infix-functions)
  t)

;ロード時に読み込む
(install-default-operators-and-infix-functions)