#:g1: Allegro CLのfixed-indexスロット再現リベンジ

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)

実装について

実装

(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

comments powered by Disqus