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 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 not)
    (~ 1 lognot)))

(defclass infix-function ()
  ((type
    :initarg :type
    :accessor infix-function-type)
   (clname 
    :initarg :clname
    :accessor infix-function-clname)
   (numarg
    :initarg :numarg
    :accessor infix-function-numarg)
   (priority
    :initarg :priority
    :initform 7
    :accessor infix-function-priority)
   (direction
    :initarg :direction
    :accessor infix-function-direction)))

(defconstant leastpriority 20)

(defvar *operators-priority* (make-hash-table :test #'equal)  "優先順位毎の演算子")

(defvar *operators* (make-hash-table) "演算子と算術関数のデータ")

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

(defun operatorp (op)
  (multiple-value-bind (op* win) (gethash op *operators*)
	(and win (eq (infix-function-type op*) :operator))))

(defun ifunctionp (op)
  (multiple-value-bind (op* win) (gethash op *operators*)
	(and win (eq (infix-function-type op*) :ifunction))))

(defun getnumarg (op)
  (infix-function-numarg (gethash op *operators*)))

(defun getclname (op)
  (infix-function-clname (gethash op *operators*)))

(defun apply-ifunction (exp)
  "算術関数を普通のポーランド記法の形にする
   (apply-ifunction '(sqrt a + sin cos b))
   ->  '((sqrt a) + (sin (cos b)))"
  (let ((stack nil))
    (dolist (i (nreverse exp))
      (if (ifunctionp i)
	  (let ((polish))
	    (push (getclname i) polish)
	    (dotimes (j (getnumarg i))
	      (push (pop stack) polish))
	    (push (nreverse polish) stack))
	  (push i stack)))
    stack))


(defun devide-infix (exp ops direction)
  "ops中の演算子でexpを分割する。directionの結合を用いる。
   三つの値を返す。
   1: 演算子
   2: 演算子より前の式
   3: 演算子より後の式

   Example:
   (devide-infix '(1 + 2 * 3 - 3) '(left + -))
    -> -
       (1 + 2 * 3)
       (3)"
  (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)
      (do ((priority 20    (- priority (ecase dir (:left 0) (:right 1))))
	   (dir      :left (ecase dir (:left :right) (:right :left))))
	  ((zerop priority) nil)
	  (let ((ops (gethash `(,priority ,dir) *operators-priority*)))
	    (when (some (lambda (op) (member op exp)) ops)
	      (multiple-value-bind (op bef af) (devide-infix exp ops dir)
		(return (list (getclname op) (infix-polish bef) (infix-polish af)))))))))

(defmacro infix (&rest exp)
  "中間記法用マクロ。
   applyarしてinfix-polishする"
  (infix-polish (apply-ifunction 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 clname (direction :left))
  (unless clname
    (setf clname op))
  (setf (gethash op *operators*) 
	(make-instance 'infix-function 
		       :type :operator 
		       :clname clname 
		       :numarg 2 
		       :priority priority 
		       :direction direction))
  (push op (gethash `(,priority ,direction) *operators-priority*)))

(defun add-ifunction (fun numarg &optional clname)
  (unless clname
    (setf clname fun))
  (setf (gethash fun *operators*)
	(make-instance 'infix-function
		       :type :ifunction
		       :clname clname
		       :numarg numarg
		       :priority nil
		       :direction nil)))

(defun initialize ()
  "演算子及び算術関数に関するデータを初期化する"
  (clrhash *operators-priority*)
  (clrhash *operators*))

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

(install-default-operators-and-infix-functions)