Posted 2020-12-12 18:31:25 GMT
allocate-instance Advent Calendar 2020 13日目の記事です。
今回もECLOSの拡張のアイデアが元ネタですが、ECLOSにはattributed-classという再帰的な属性を持つクラスが紹介されているので、属性を隠しスロットに格納するという方法で定義してみました。
実際のECLOSのattributed-classがどういう仕様と実装になっているかは資料が少なく良く分からないのですが、どうもスロットも属性も同じ構造を持つようです。
そうなると、属性の方に再帰的に定義クラスのオブジェクトを詰めれば良さそう、ということで、defclassのスロット定義に再帰的にdefclassの定義を詰めてみることにしました。
割と安直ですが、ECLOSの挙動も大体一緒なので実際にこういう構成かもしれません。
(defclass foo (attributed-object)
((x :initform 'x
:attributes
((a :initform 'a
:attributes
((u :initform "u")))
(b :initform (list 0 1))
c))
(y :initform 'y))
(:metaclass attributed-class)
(:default-attributes
((da :initform 'unknown))))
(let ((obj (make-instance 'foo)))
`((,(slot-value obj 'x)
(list ,(slot-value (slot-attribute obj 'x) 'a)
,(slot-value (slot-attribute (slot-attribute obj 'x) 'a) 'u))
,(slot-value (slot-attribute obj 'x) 'b))
,(list (slot-value obj 'y)
(slot-value (slot-attribute obj 'y) 'da))))
→ ((x (list a "u") (0 1)) (y unknown))
(attribute-value (make-instance 'foo) 'x 'a 'u)
→ "u"
(defpackage "0003c1b3-31ed-5d6d-b58a-6d45c62acc5c"
(:use c2cl slotted-objects))
(cl:in-package "0003c1b3-31ed-5d6d-b58a-6d45c62acc5c")
(defclass attributed-class (slotted-class)
((default-attributes :initform 'nil
:initarg :default-attributes
:accessor class-default-attributes))
(:metaclass standard-class))
(defmethod allocate-instance ((class attributed-class) &rest initargs)
(allocate-slotted-instance (class-wrapper class)
(make-array `(2 ,(length (class-slots class)))
:initial-element (make-unbound-marker))))
(defclass attributed-object (slotted-object)
()
(:metaclass attributed-class))
(defun find-named-slot-using-class (class slot-name &optional (no-error-p nil))
#+lispworks
(flet ((wrapper-slot-names (wrapper)
(elt wrapper 4)))
(let ((wrapper (class-wrapper class))
(pos nil))
(cond ((setq pos (position slot-name (elt wrapper 1)))
(elt (wrapper-slot-names wrapper) pos))
(no-error-p nil)
(T (error "~A is not the name of a slotd." slot-name)))))
#-(or lispworks)
(cond ((loop :for slotd :in (class-slots class)
:thereis (and (eq slot-name (slot-definition-name slotd))
slotd)))
(no-error-p nil)
(t (error "~A is not the name of a slotd." slot-name))))
(defconstant slot-dim 0)
(defconstant attribute-dim 1)
(defmethod slot-value-using-class ((class attributed-class) instance (slotd slot-definition))
(aref (instance-slots instance)
slot-dim
(slot-definition-location slotd)))
(defmethod (setf slot-value-using-class) (value (class attributed-class) instance (slotd slot-definition))
(setf (aref (instance-slots instance)
slot-dim
(slot-definition-location slotd))
value))
(defgeneric slot-attribute-using-class (class instance slotd))
(defmethod slot-attribute-using-class ((class attributed-class) instance (slotd slot-definition))
(aref (instance-slots instance)
attribute-dim
(slot-definition-location slotd)))
(defgeneric (setf slot-attribute-using-class) (val class instance slotd))
(defmethod (setf slot-attribute-using-class) (value (class attributed-class) instance (slotd slot-definition))
(setf (aref (instance-slots instance)
attribute-dim
(slot-definition-location slotd))
value))
(defun slot-attribute (instance slot-name)
(let ((class (class-of instance)))
(slot-attribute-using-class class
instance
(find-named-slot-using-class class slot-name))))
(defun (setf slot-attribute) (value instance slot-name)
(let ((class (class-of instance)))
(setf (slot-attribute-using-class class
instance
(find-named-slot-using-class class slot-name))
value)))
(defclass attributed-slot-definition (standard-slot-definition)
((attributes :initform nil
:initarg :attributes
:accessor attributed-slot-definition-attributes)))
(defclass direct-slot/attribute-definition (standard-direct-slot-definition attributed-slot-definition)
())
(defmethod direct-slot-definition-class ((class attributed-class) &rest initargs)
(find-class 'direct-slot/attribute-definition))
#+lispworks
(defmethod clos:process-a-slot-option ((class attributed-class) option value
already-processed-options slot)
(if (eq option :attributes)
(list* :attributes
`(let ((c (defclass ,(gensym (format nil
"ATTRIBUTED-CLASS.A-"
(string (car slot))))
(attributed-object)
,value
(:metaclass attributed-class))))
(finalize-inheritance c)
c)
already-processed-options)
(call-next-method)))
#+lispworks
(defmethod clos:process-a-class-option ((class attributed-class)
(name (eql :default-attributes))
value)
(unless (and value (null (cdr value)))
(error "attributed-class :default-attributes must have a single value."))
(list name
`(let ((c (defclass ,(gensym "DEFAULT-ATTRIBUTES-") (attributed-object)
,(car value)
(:metaclass attributed-class))))
(finalize-inheritance c)
c)))
(defclass effective-slot/attribute-definition (standard-effective-slot-definition attributed-slot-definition)
())
(defmethod effective-slot-definition-class
((class attributed-class) &rest initargs)
(find-class 'effective-slot/attribute-definition))
(defmethod compute-effective-slot-definition ((class attributed-class)
name
direct-slot-definitions)
(let ((effective-slotd (call-next-method)))
(dolist (slotd direct-slot-definitions)
(when (typep slotd 'attributed-slot-definition)
(setf (attributed-slot-definition-attributes effective-slotd)
(attributed-slot-definition-attributes slotd))
(return)))
effective-slotd))
(defmethod shared-initialize :after ((instance attributed-object) slot-names &rest initargs)
(let* ((class (class-of instance))
(slots (class-slots class))
(default-attributes (class-default-attributes class)))
(dolist (s slots)
(let ((attr (attributed-slot-definition-attributes s)))
(if attr
(setf (slot-attribute-using-class class instance s)
(make-instance (attributed-slot-definition-attributes s)))
(and default-attributes
(setf (slot-attribute-using-class class instance s)
(make-instance default-attributes))))))))
(defun attribute-value (instance &rest names)
(let ((ans instance))
(mapl (lambda (n)
(if (cdr n)
(setq ans (slot-attribute ans (car n)))
(setq ans (slot-value ans (car n)))))
names)
ans))
スロットの方で再帰的に展開させるとXMLみたいな感じでしょうか。
DOMの表現はノードと属性とで別クラスになっていることが多いですが、attributed-classのようなクラスであれば一本化できそうです。
■
HTML generated by 3bmd in LispWorks 7.0.0