2008/01/04

Common Lisp : slot-missing と undefined-function

slot-missing は存在しないスロットにアクセスした場合に呼ばれるジェネリックファンクションで、error を投げるように定義されています。
これを使ってスロットがない場合の振舞いをプログラムできます。
1番目の引数がクラス。
2番目の引数がインスタンス(オブジェクト)。
3番目の引数がスロット名。
4番目の引数は参照の場合は slot-value、設定の場合は setf。
5番目の引数は setf の場合の設定値です。

次のコードでは、クラス a の slot-value は *value* の値を返し、クラス b の (setf slot-value) は *value* に値を設定しています。

(defvar *value* nil)

(defclass a ()
())

(defclass b (a)
())

(defmethod slot-missing ((class (eql (find-class 'a))) instance slot-name
(operation (eql 'slot-value)) &optional new-value)
*value*)

(defmethod slot-missing ((class (eql (find-class 'b))) instance slot-name
(operation (eql 'setf)) &optional new-value)
(setf *value* new-value))

(let ((a (make-instance 'a))
(b (make-instance 'b)))
(print *value*) ;nil
(print (setf (slot-value b 'スロット名) "値いち")) ;"値いち"
(print *value*) ;"値いち"
(print (slot-value a 'なまえ)) ;"値いち"
(print (ignore-errors (slot-value 'b 'なまえ))) ;nil
(print (ignore-errors (setf (slot-value a 'スロット名) "値に")))) ;nil

さて、スロットがない場合はこれでいいのですが、関数がない場合はどうすればいいのでしょう?
関数がない場合は undefined-function コンディションが error 関数により通知されるようです(SBCLでは)。
この undefined-function を補足することはできるのですが、それが通知された場所からリスタートする方法が分かりませんでした。
restart-bind と handler-bind でなんとかなるかなぁ、と思って次のようなコードでごにょごにょしてみたのですがうまくいきません。
foo が定義されていない状態で "a", "b", "c" と print したいのです。
error ではなく ceeror で undefined-function を通知してくれないものでしょうか。
(restart-bind ((ole-dispatch
#'(lambda (&optional x)
(p 'restart x)
(setf (symbol-function x) #'print)
(p (symbol-function x))
(symbol-function x))))
(handler-bind ((undefined-function
#'(lambda (c)
(p 'handler c (cell-error-name c))
(invoke-restart 'ole-dispatch (cell-error-name c)))))
(print "a")
(foo "b")
(print "c")))

うまくいけば OLE の invoke を隠蔽できるのにな。

0 件のコメント: