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