#:g1: クロージャーなインスタンス

allocate-instance Advent Calendar 2020 4日目の記事です。

インスタンスのストレージをカスタマイズするといっても大抵はスロット付きオブジェクトの値を参照する/設定する、のが基本操作なので、大体の操作をまとめてGitHubに置いてみました。

• g000001: slotted-objects

インスタンスの中身をクロージャーにしてみる

On Lispや、Let Over Lambdaでは、Common Lispのオブジェクト指向システムは使わず、クロージャーとハッシュテーブルだったりマクロを組合せて「オブジェクト指向システムを越えた!」みたいなことをやっていますが、今回は、逆を行ってクロージャーをインスタンスの中身にしてみます。
ちなみに、Common Lispでは、オブジェクト指向システムは普通に使うので、On Lisp、Let Over Lambdaみたいな偏った本だけ読むのではなく、Quicklisp等で流通している皆のコードを読んでみましょう。普通に皆、defclassしています。

上記slotted-objectsとしてまとめたコードを使えば、スロット付きオブジェクトをインスタンスの中身に設定するには、文末のコードのようにallocate-instanceとslot-value-using-classあたりを定義すれば実現できます。

まとめ

インスタンスの中身を関数にすると、リダイレクト等の動的な操作は幾らでも可能になりますが、それはオブジェクトのアロケート時にすることかといわれると微妙です。

実装

(defpackage "72e97df3-26b8-5ff7-b134-8d9338d93e41" 
  (:use :c2cl :slotted-objects))

(in-package "72e97df3-26b8-5ff7-b134-8d9338d93e41")

(defclass closure-class (slotted-class) ())

(defclass closure-object (slotted-object) 
  ()
  (:metaclass closure-class))

(defmethod allocate-instance ((class closure-class) &rest initargs)
  (allocate-slotted-instance (class-wrapper class)
                          (let* ((slotds (class-slots class))
                                 (slot-names (mapcar #'slot-definition-name slotds)))
                            (eval
                             `(let (,@(mapcar (lambda (s)
                                                `(,s (make-unbound-marker)))
                                              slot-names))
                                (lambda (set/get slot val)
                                  (ecase set/get
                                    ((:get)
                                     (ecase slot
                                       ,@(mapcar (lambda (d n)
                                                   `((,d) ,n))
                                                 slotds
                                                 slot-names)))
                                    ((:set)
                                     (ecase slot
                                       ,@(mapcar (lambda (d n)
                                                   `((,d) (setq ,n val)))
                                                 slotds
                                                 slot-names))))))))))

(defmethod slot-value-using-class ((class closure-class) instance (slotd slot-definition))
  (funcall (instance-slots instance) :get slotd nil))

(defmethod (setf slot-value-using-class)
           (value (class closure-class) instance (slotd slot-definition))
  (funcall (instance-slots instance) :set slotd value))

動作

(defclass foo (slotted-object)
  ((a :initform 0)
   (b :initform 1)
   (c :initform 2))
  (:metaclass closure-class))
(describe
 (make-instance 'foo))
#<foo 4020386BEB> is a foo
a      0
b      1
c      2

(let ((o (make-instance 'foo)))
  (let ((slot-a  (find 'a (class-slots (find-class 'foo)) :key #'slot-definition-name)))
    (funcall (instance-slots o) :set slot-a 100)
    (describe o)))
#<foo 4020083683> is a foo
a      100
b      1
c      2

■

HTML generated by 3bmd in LispWorks 7.0.0