Posted 2019-12-11 17:12:32 GMT
先日書いたAllegro CLのfixed-indexスロットアクセスを真似してみるの記事では、任意の値でslot-definition-loction
を確定させる術を分かっていなかったので、中途半端なことになっていました。
compute-slots :around
を使った確定方法が分かったのでリベンジします。
(<defclass> foo ()
((a :initarg :a fixed-index 2 :accessor foo-a)
(b :initarg :b fixed-index 4 :accessor foo-b)
(c :initarg :c :accessor foo-c))
(:metaclass fixed-index-slot-class))(mapcar (lambda (s)
(list (slot-definition-name s)
(slot-definition-location s)))
(class-slots <foo>))
→ ((c 0) (a 2) (b 4))
(let ((foo (a 'foo)))
(setf (foo-a foo) 'a)
(setf (foo-b foo) 'b)
(setf (foo-c foo) 'c)
(std-instance-slots foo))
→ #(c #<Slot Unbound Marker> a #<Slot Unbound Marker> b)
slot-value-using-class
がいつものごとくLispWorks依存です(AMOP準拠でない)
なおかつ遅そうです。(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :closer-mop))
(defpackage "506dccfc-1d3a-5b8c-9203-948447c433b4" (:use :c2cl))
(in-package "506dccfc-1d3a-5b8c-9203-948447c433b4")
;; utils
(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (fdefinition 'a) #'make-instance)
(defun fintern (package control-string &rest args)
(with-standard-io-syntax
(intern (apply #'format nil control-string args)
(or package *package*))))
(defmacro <defclass> (name supers slots &rest class-options)
`(defconstant ,(fintern (symbol-package name) "<~A>" name)
(defclass ,name ,supers ,slots ,@class-options))))
(<defclass> fixed-index-slot-class (standard-class)
())
(defmethod validate-superclass ((c fixed-index-slot-class) (s standard-class))
T)
(<defclass> fixed-index-slot-definition (standard-slot-definition)
((fixed-index :initform nil
:initarg fixed-index
:accessor slot-definition-fixed-index)))
(<defclass> fixed-index-direct-slot-definition
(fixed-index-slot-definition standard-direct-slot-definition)
())
(<defclass> fixed-index-effective-slot-definition
(fixed-index-slot-definition standard-effective-slot-definition)
())
(defmethod direct-slot-definition-class ((c fixed-index-slot-class) &rest initargs)
(declare (ignore initargs))
<fixed-index-direct-slot-definition>)
(defmethod effective-slot-definition-class ((c fixed-index-slot-class) &rest initargs)
(declare (ignore initargs))
<fixed-index-effective-slot-definition>)
(defmethod compute-effective-slot-definition ((class fixed-index-slot-class) name direct-slot-definitions)
(declare (ignore name))
(let ((effective-slotd (call-next-method)))
(dolist (slotd direct-slot-definitions)
(when (typep slotd <fixed-index-slot-definition>)
#-allegro (setf (slot-definition-fixed-index effective-slotd)
(slot-definition-fixed-index slotd))
#+allegro (setf (slot-value effective-slotd 'excl::location)
(slot-definition-fixed-index slotd))
(return)))
effective-slotd))
(defmethod allocate-instance ((class fixed-index-slot-class) &rest initargs)
(let* ((class (clos::ensure-class-finalized class))
(slotds (class-slots class))
(max-index (loop :for s :in slotds :maximize (slot-definition-location s))))
(sys:alloc-fix-instance (clos::class-wrapper class)
(sys:alloc-g-vector$fixnum (1+ max-index)
clos::*slot-unbound*))))
(defmethod compute-slots :around ((class fixed-index-slot-class))
(let* ((slotds (call-next-method))
(indecies (mapcan (lambda (s)
(and (slot-definition-fixed-index s)
(list (slot-definition-fixed-index s))))
slotds))
(free-indecies (loop :for i :from 0 :to (apply #'max indecies)
:unless (find i indecies) :collect i)))
(dolist (s slotds)
(if (slot-definition-fixed-index s)
(setf (slot-definition-location s)
(slot-definition-fixed-index s))
(setf (slot-definition-location s)
(pop free-indecies))))
(sort (copy-list slotds) #'< :key #'slot-definition-location)))
(defun standard-instance-boundp (instance index)
(not (eq clos::*slot-unbound* (standard-instance-access instance index))))
(defmethod slot-value-using-class
((class fixed-index-slot-class) instance slot-name)
(let* ((slotd (find slot-name (class-slots class)
:key #'slot-definition-name))
(loc (slot-definition-location slotd)))
(cond ((not slotd)
(slot-missing class instance slot-name 'slot-makunbound))
((null (standard-instance-boundp instance loc))
(slot-unbound class instance slot-name))
(T
(standard-instance-access instance loc)))))
(defmethod (setf slot-value-using-class)
(val (class fixed-index-slot-class) instance slot-name)
(let* ((slotd (find slot-name (class-slots class)
:key #'slot-definition-name))
(loc (slot-definition-location slotd)))
(if (not slotd)
(slot-missing class instance slot-name 'slot-makunbound)
(setf (standard-instance-access instance loc) val))))
(declaim (inline std-instance-slots))
(defun std-instance-slots (inst)
#+allegro (excl::std-instance-slots inst)
#+sbcl (sb-pcl::std-instance-slots inst)
#+lispworks (clos::standard-instance-static-slots inst))
インスタンスのスロットをベクタ上に任意に配置したり、ハッシュテーブルにしてみたり、ということができることは分かりましたが、標準から逸れたことをすると、どうもスロットのアクセス周りを全部書かないといけないっぽいですね。
■
HTML generated by 3bmd in LispWorks 7.0.0