Posted 2019-12-04 20:14:19 GMT
最近はECLOSを再現して遊んでいますが、今回は、self-referent-classというメタクラスを再現してみます。
なお、self-referent-classについては、ECLOSの論文に詳しいので参照してください。
説明はあるとはいえ、マニュアルや仕様書ではないので、実際実装してみようとすると良くわからないところはありますが、インスタンスの初期化時に他のスロットを参照できること=自己参照、ということのようです。 論文の解説によれば、大体下記のような挙動になります。
selfという変数で参照可能(slot-name self)という形式で自身の式より左側のスロットを参照可能creatorやparentの機能なのか判然としない(defclass horizontal-line (self-referent-object)
((x1 :accessor x1 :initarg :x1 :type real)
(x2 :accessor x2 :initarg :x2 :type real)
(y :accessor y :initarg :y :type real)
(point1 :initform (make-point (x1 self)
(y self)))
(point2 :initform (make-point (x2 self)
(y self))))
(:metaclass self-referent-class))(set' obj (make-instance 'horizontal-line :x1 1 :x2 2 :y 3))
(slot-value obj 'x1)
→ 1
(slot-value obj 'x2)
→ 2
(slot-value obj 'point1)
→ (1 3)
(slot-value obj 'point2)
→ (2 3)
論文にはCommon LispのMOPについて問題点が何点も指摘されていますが、スロット定義のinitfunctionが引数を取らないことも指摘しています。
この指摘の中で、この問題を回避するためにスペシャル変数経由で渡していると書いてあるのですが、だとすると、shared-initializeの中のスロット初期化関数にスペシャル変数経由でselfを渡しているのでしょう。
shared-initializeの:aroundを使ってスペシャル変数の囲いはこんな風に書けるでしょう。
(defmethod shared-initialize :around ((instance self-referent-object) slot-names &rest initargs)
(let ((*self-referent-object-self* instance))
(declare (special *self-referent-object-self*))
(call-next-method)))あとは、initfunctionを
(lambda (&aux (self *self-referent-object-self*))
(declare (special *self-referent-object-self*))
...)のようなものに差し替えればOKです。
(slot-name self)のような形式は、スロット名の局所関数を作成し、ensure-class-using-classの周りに展開されるようにすれば良さそうです。
以上で、想像される展開は下記のようになります。
(eval-when (:compile-toplevel :load-toplevel :execute)
(flet ((x1 (self) (slot-value self 'x1))
(x2 (self) (slot-value self 'x2))
(y (self) (slot-value self 'y))
(point1 (self) (slot-value self 'point1))
(point2 (self) (slot-value self 'point2)))
(def:def (lisp:defclass horizontal-line)
(clos::ensure-class-without-lod 'horizontal-line
:metaclass
'self-referent-class
:direct-slots
(list (list :name 'x1
:readers '(x1)
:writers '((setf x1))
:initargs '(:x1)
:type 'real)
(list :name 'x2
:readers '(x2)
:writers '((setf x2))
:initargs '(:x2)
:type 'real)
(list :name 'y
:readers '(y)
:writers '((setf y))
:initargs '(:y)
:type 'real)
(list :name 'point1
:initform
'(make-point (x1 self) (y self))
:initfunction
#'(lambda (&aux (self zreclos.meta::*self-referent-object-self*))
(declare (special zreclos.meta::*self-referent-object-self*))
(make-point (x1 self) (y self))))
(list :name 'point2
:initform
'(make-point (x2 self) (y self))
:initfunction
#'(lambda (&aux (self zreclos.meta::*self-referent-object-self*))
(declare (special zreclos.meta::*self-referent-object-self*))
(make-point (x2 self) (y self)))))
:direct-superclasses '(self-referent-object)
:location
(def:location)))))defclassがメタクラスに応じて任意の展開にディスパッチされると便利なのですが、LispWorksだとexpand-defclassというのがあるので、ここに展開メソッドを追加してやることでdefclassの兄弟マクロを定義せずに済みました。
このexpand-defclassですが、X3J13-88-003Rにあるのと同じ大体同じインターフェイスです。
他にもスロットのオプションの展開等にもLispWorksには便利なメソッドがあるので使ってみました(非公開APIですが)
ちなみに、これらはclass-prototypeをディスパッチに利用するのですが、昔からこういう使い方は或る種の定番だったようです。
などなどですが、ベタベタにLispWorks依存になっています。
(defclass self-referent-class (standard-class)
()
(:metaclass standard-class))
(defmethod validate-superclass ((c self-referent-class)
(s standard-class))
T)
(defun make-creator-function-form (slot-form)
(let ((name (car slot-form)))
`(,name (self) (slot-value self ',name))))
(defmethod clos::expand-defclass
((prototype self-referent-class) metaclass name superclasses slots class-options)
(destructuring-bind (eval-when opts &body body)
(call-next-method)
`(,eval-when ,opts
(flet (,@(mapcar #'make-creator-function-form slots))
,@body))))
(defclass self-referent-object (standard-object)
()
(:metaclass self-referent-class))
(defmethod shared-initialize :around ((instance self-referent-object) slot-names &rest initargs)
(let ((*self-referent-object-self* instance))
(declare (special *self-referent-object-self*))
(call-next-method)))
;; from alexandria
(defun flatten (tree)
"Traverses the tree in order, collecting non-null leaves into a list."
(let (list)
(labels ((traverse (subtree)
(when subtree
(if (consp subtree)
(progn
(traverse (car subtree))
(traverse (cdr subtree)))
(push subtree list)))))
(traverse tree))
(nreverse list)))
(defun non-trivial-initform-initfunction-p (initform)
#+lispworks7.1
(loop :for (name ntifif) :on (flatten initform)
:thereis (and (eq 'hcl:lambda-name name)
(eq 'clos::non-trivial-initform-initfunction ntifif)))
#+lispworks7.0
(let ((x initform))
(and (consp x)
(eq 'function (car x))
(eq 'lambda (caadr x)))))
(defgeneric make-sr-class-initfunction-form (class ifform))
(defmethod make-sr-class-initfunction-form ((class self-referent-class)
ifform)
(if (non-trivial-initform-initfunction-p ifform)
(destructuring-bind (function (lambda arg &body body))
ifform
(declare (ignore arg))
`(,function (,lambda (&aux (self *self-referent-object-self*))
(declare (special *self-referent-object-self*))
,@body)))
ifform))
(defmethod clos::canonicalize-defclass-slot
((prototype self-referent-class) slot)
(let* ((plist (copy-list (cdr (call-next-method))))
(ifform (getf plist :initfunction)))
(if (getf plist :initform)
(progn
(remf plist :initfunction)
`(list ,@plist
:initfunction ,(make-sr-class-initfunction-form prototype
ifform)))
(progn
`(list ,@plist)))))
expand-defclassは便利なのでLispWorks限らず他でも使いたいところですが、このあたりは統一されてないんですよねえ。
■
HTML generated by 3bmd in LispWorks 7.0.0