#:g1

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

以前、LW Dylan TranslatorというLispWorks上のDylanのシミュレーターのソースコードを眺めた時に、内部関数を使ってスロットをnilでfillしていたのが印象に残っていたのですが、未束縛スロットの扱いが面倒なので、とりあえず:initform nilしておくというコードもたまに見掛けたりもするので、そこそこ常套句なのかもしれません。
ということで、今回は、allocate-instanceでスロットのデフォルト値をnilにしてみましょう。

(defpackage "cafc9fa3-5687-537e-839a-424c9b589974"
  (:use c2cl slotted-objects))
(cl:in-package "cafc9fa3-5687-537e-839a-424c9b589974")

(defclass default-to-nil-class (slotted-class)
  ())

(defmethod allocate-instance :around ((class default-to-nil-class) &key &allow-other-keys)
  (let ((instance (call-next-method)))
    (fill (instance-slots instance) nil)
    instance))

これで下記のような動作になります。

(defclass foo (slotted-object)
  ((a :initform 'a)
   b
   c)
  (:metaclass default-to-nil-class))
(describe (make-instance 'foo))
⇒
#<foo 40203E71A3> is a foo
a      a
b      nil
c      nil

当然ですが、明示的に設定したnilなのか、暗黙のnilなのか区別が付かなくなるので、その辺りは注意です。
そう考えると、取扱が面倒ではありますが未束縛値で埋めておくというのは妥当ではありますね。

■

HTML generated by 3bmd in LispWorks 7.0.0

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

これまで、スロットのストレージを二次元配列にしてみたり、構造体にしてみたりと妙なことを試してきましたが、標準的なスロットストレージを持つオブジェクト(standard-object等)とのchange-classでの相互運用を考慮した場合、スロットストレージも伸展や縮退をサポートする必要があります。
この辺りを司るのは、change-classの下請けのupdate-instance-for-different-classになりますが、滅多に使わない機能というか、私個人もメソッド定義する必要に遭遇したことがありません。

それはさておき、とりあえずの例として、スロットストレージが拡張された、a-class、b-classと、標準構成の三つのクラスを定義したとします。

(defpackage "fd84d50c-3573-5d37-aed2-73e7d98bb52d"
  (:use c2cl slotted-objects))

(cl:in-package "fd84d50c-3573-5d37-aed2-73e7d98bb52d")

(defclass a-class (slotted-class)
  ())

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

(defclass b-class (slotted-class)
  ())
(defclass b-object (slotted-object)
  ()
  (:metaclass a-class))

(defmethod allocate-instance ((class a-class) &key &allow-other-keys)
  (allocate-slotted-instance (class-wrapper class)
                          (make-array `(2 ,(length (class-slots class)))
                                      :initial-element (make-unbound-marker))))

(defmethod allocate-instance ((class b-class) &key &allow-other-keys)
  (allocate-slotted-instance (class-wrapper class)
                          (make-array `(4 ,(length (class-slots class)))
                                      :initial-element (make-unbound-marker))))

(defmethod slot-value-using-class ((class a-class) instance (slotd slot-definition))
  (aref (instance-slots instance) 0 (slot-definition-location slotd)))

(defmethod (setf slot-value-using-class) (value (class a-class) instance (slotd slot-definition))
  (setf (aref (instance-slots instance) 0 (slot-definition-location slotd))
        value))

(defmethod slot-value-using-class ((class b-class) instance (slotd slot-definition))
  (aref (instance-slots instance) 1 (slot-definition-location slotd)))

(defmethod (setf slot-value-using-class) (value (class b-class) instance (slotd slot-definition))
  (setf (aref (instance-slots instance) 1 (slot-definition-location slotd))
        value))

とりあえず、インスタンスのクラスを変更することがなければ、別段このままでも問題ありません。

(defclass foo (a-object)
  ((a :initform 0)
   (b :initform 1)
   (c :initform 2))
  (:metaclass a-class))

(defclass bar (b-object)
  ((a :initform 4)
   (b :initform 5)
   (c :initform 6))
  (:metaclass b-class))

(defclass baz (standard-object)
  ((a :initform 7)
   (b :initform 8)
   (c :initform 9)))

(progn
  (describe (make-instance 'foo))
  (describe (make-instance 'bar))
  (describe (make-instance 'baz)))
#<foo 402005E1FB> is a foo
a      0
b      1
c      2
#<bar 402005E59B> is a bar
a      4
b      5
c      6
#<baz 402005E8D3> is a baz
a      7
b      8
c      9

しかし、change-classするとなると、インスタンスのストレージが違うので、違いを吸収するメソッドをupdate-instance-for-different-classに定義してやる必要があります。

拡張→標準の移行

standard-objectにchange-classする分には拡張したスロットストレージが削られることになるので、特に難しいことはありません。

(defmethod update-instance-for-different-class
           ((pre slotted-object) (cur standard-object) &key &allow-other-keys)
  (dolist (slotd (class-slots (class-of cur)))
    (let ((slot-name (slot-definition-name slotd)))
      (when (slot-exists-p pre slot-name)
        (setf (slot-value cur slot-name)
              (slot-value pre slot-name))))))

標準→拡張の移行

standard-objectから拡張したものにchange-classする分には拡張したスロットストレージを使うことになるので、ストレージのアロケートをして、新しいストレージ側に値をコピーする必要があります。

ストレージのアロケーションをメタクラスで切り替えたいとすると、allocate-instanceの下請けとして共通のメソッドを定義するのが良さそうです。

今回は、allocate-slot-storageというメソッドを定義して使うことにしてみました。

(defgeneric allocate-slot-storage (class size initial-value))

(defmethod allocate-slot-storage ((class a-class) size initial-value)
  (make-array `(2 ,size) :initial-element initial-value))

(defmethod allocate-slot-storage ((class b-class) size initial-value)
  (make-array `(4 ,size) :initial-element initial-value))
;; ... allocate-instanceの書き換えは略 ...

(defmethod update-instance-for-different-class
           ((pre standard-object) (cur slotted-object) &key &allow-other-keys)
  (let ((cur-class (class-of cur)))
    (setf (instance-slots cur)
          (allocate-slot-storage cur-class
                                 (length (class-slots cur-class))
                                 (make-unbound-marker)))
    (dolist (slotd (class-slots cur-class))
      (let ((slot-name (slot-definition-name slotd)))
        (when (slot-exists-p pre slot-name)
          (setf (slot-value cur slot-name)
                (slot-value pre slot-name)))))))

拡張→拡張の移行

標準→拡張と内容は同じなのですが、このパターンも用意しておく必要があります。

(defmethod update-instance-for-different-class
           ((pre slotted-object) (cur slotted-object) &key &allow-other-keys)
  (let ((cur-class (class-of cur)))
    (setf (instance-slots cur)
          (allocate-slot-storage cur-class
                                 (length (class-slots cur-class))
                                 (make-unbound-marker)))
    (dolist (slotd (class-slots cur-class))
      (let ((slot-name (slot-definition-name slotd)))
        (when (slot-exists-p pre slot-name)
          (setf (slot-value cur slot-name)
                (slot-value pre slot-name)))))))

なお、基本的に拡張への移行は、新しくインスタンスのストレージを確保する部分だけなので、update-instance-for-different-classの:beforeメソッドで、ストレージの置き換えを定義するだけで良いのかもしれません。
このあたりの参考資料が見付けられないので良く分からず……。

以上で相互変換が可能になります。

(progn
  (progn
    ;; slotted-object → standard-object
    (describe (change-class (make-instance 'foo) 'baz))
    (describe (change-class (make-instance 'bar) 'baz))
    (describe (change-class (make-instance 'baz) 'baz)))
  (progn
    ;; standard-object → slotted-object
    (describe (change-class (make-instance 'bar) 'foo))
    (describe (change-class (make-instance 'baz) 'foo)))
  (progn
    ;; slotted-object → slotted-object
    (describe (change-class (make-instance 'foo) 'bar))
    (describe (change-class (make-instance 'bar) 'bar))))
#<baz 402005EC43> is a baz
a      0
b      1
c      2
#<baz 402005F163> is a baz
a      4
b      5
c      6
#<baz 402005F64B> is a baz
a      7
b      8
c      9
#<foo 402005FB33> is a foo
a      4
b      5
c      6
#<foo 4020060073> is a foo
a      7
b      8
c      9
#<bar 4020060583> is a bar
a      0
b      1
c      2
#<bar 4020230B2B> is a bar
a      4
b      5
c      6

まとめ

allocate-なんとかのメソッドを上手い感じに命名してまとめたいところなのですが難しい……。
一応今回は、Closetteを参考に命名してみました。

■

HTML generated by 3bmd in LispWorks 7.0.0

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

完全なるネタ切れですが、今回はアンドゥ可能なスロットを実現してみたいと思います。
以前に紹介した履歴付きスロットと似たような感じですが、こちらは限定された回数スロットの状態をアンドゥできることをメインに考えます!

動作と仕様

仕様としては、どこかのスロットが変更された場合、スロット全部を保存することにします。
内部では、16セットのスロットを二次元配列で表現したものと現在の位置を、オブジェクトのストレージとします。

また、ユーティリティとしてundo-slotsとreset-slotsも用意してみます。

(defclass foo (undoable-slots-object)
  ((a :initform 0)
   (b :initform 1)
   (c :initform 2))
  (:metaclass undoable-slots-class))

(defparameter *foo* (make-instance 'foo))

(describe *foo*)
#<foo 4020002193> is a foo
a      0
b      1
c      2
;; 乱数を任意のスロットに代入 x 15回
(dotimes (i 15)
  (setf (slot-value *foo* (elt #(a b c) (mod i 3)))
        (random 1000)))
;; 15回状態を戻す
(dotimes (i 15)
  (describe (undo-slots *foo*)))
#<foo 4020002193> is a foo
a      930
b      743
c      626
#<foo 4020002193> is a foo
a      930
b      365
c      626
#<foo 4020002193> is a foo
a      571
b      365
c      626
#<foo 4020002193> is a foo
a      571
b      365
c      695
#<foo 4020002193> is a foo
a      571
b      92
c      695
#<foo 4020002193> is a foo
a      895
b      92
c      695
#<foo 4020002193> is a foo
a      895
b      92
c      905
#<foo 4020002193> is a foo
a      895
b      139
c      905
#<foo 4020002193> is a foo
a      841
b      139
c      905
#<foo 4020002193> is a foo
a      841
b      139
c      859
#<foo 4020002193> is a foo
a      841
b      342
c      859
#<foo 4020002193> is a foo
a      10
b      342
c      859
#<foo 4020002193> is a foo
a      10
b      342
c      2
#<foo 4020002193> is a foo
a      10
b      1
c      2
#<foo 4020002193> is a foo
a      0
b      1
c      2
nil

実装

(defpackage "955b5b51-173a-50c3-82f6-7add63d9b29a" 
  (:use c2cl slotted-objects))

(cl:in-package "955b5b51-173a-50c3-82f6-7add63d9b29a")

(defconstant undo-limit 16.)

(defclass undoable-slots-storage ()
  ((slots :initarg :slots :accessor undoable-slots-storage-slots)
   (history# :initform 0 :accessor undoable-slots-storage-history#)))

(defclass undoable-slots-class (slotted-class)
  ()
  (:metaclass standard-class))

(defclass undoable-slots-object (slotted-object)
  ()
  (:metaclass undoable-slots-class))

(defmethod allocate-instance ((class undoable-slots-class) &key &allow-other-keys)
  (allocate-slotted-instance (class-wrapper class)
                          (make-instance 'undoable-slots-storage
                                         :slots (make-array `(,undo-limit ,(length (class-slots class)))
                                                            :initial-element (make-unbound-marker)))))

(defclass undoable-slots-object (slotted-object)
  ()
  (:metaclass undoable-slots-class))

(defmethod slot-value-using-class ((class undoable-slots-class) instance (slotd slot-definition))
  (let ((storage (instance-slots instance)))
    (aref (undoable-slots-storage-slots storage)
          (undoable-slots-storage-history# storage)
          (slot-definition-location slotd))))

(defmethod (setf slot-value-using-class) (value (class undoable-slots-class) instance (slotd slot-definition))
  (let* ((storage (instance-slots instance))
         (curpos (mod (undoable-slots-storage-history# storage) undo-limit))
         (loc (slot-definition-location slotd)))
    (flet ((backup ()
             (dotimes (idx (length (class-slots class)))
               (let ((new (mod (1+ curpos) undo-limit))
                     (old curpos))
                 (setf (aref (undoable-slots-storage-slots storage) new idx)
                       (aref (undoable-slots-storage-slots storage) old idx)))))
           (incpos ()
             (setf (undoable-slots-storage-history# storage)
                   (mod (1+ curpos) undo-limit))))
      (backup)
      (incpos)
      (setf (aref (undoable-slots-storage-slots storage)
                  (undoable-slots-storage-history# storage)
                  loc)
            value))))

(defmethod initialize-slot-from-initarg ((class undoable-slots-class) instance slotd initargs)
  (let ((slot-initargs (slot-definition-initargs slotd)))
    (loop :for (initarg value) :on initargs :by #'cddr
          :do (when (member initarg slot-initargs)
                (let ((storage (instance-slots instance)))
                  (setf (aref (undoable-slots-storage-slots storage)
                              (undoable-slots-storage-history# storage)
                              (slot-definition-location slotd))
                        value))
                (return T)))))

(defmethod initialize-slot-from-initfunction ((class undoable-slots-class) instance slotd)
  (let ((initfun (slot-definition-initfunction slotd)))
    (unless (not initfun)
      (let ((storage (instance-slots instance)))
        (setf (aref (undoable-slots-storage-slots storage)
                    (undoable-slots-storage-history# storage)
                    (slot-definition-location slotd))
              (funcall initfun))))))

(defun undo-slots (obj)
  (let ((storage (instance-slots obj)))
    (setf (undoable-slots-storage-history# storage)
          (mod (1- (undoable-slots-storage-history# storage)) undo-limit)))
  obj)

(defun reset-slots (obj)
  (let ((storage (instance-slots obj)))
    (setf (undoable-slots-storage-history# storage)
          0))
  obj)

■

HTML generated by 3bmd in LispWorks 7.0.0

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

何かallocate-instanceネタがないか、隠しスロットの応用がないか、と探しまわっていますが、そういえば、defstructにはスロットの:read-onlyオプションがあるのに、defclassにはないなと思ったので、隠しスロットで実装してみました。

動作

(defclass foo (acl-slots-object)
  ((a :initform 0 :read-only T :accessor foo-a)
   (b :initform 1 :read-only nil)
   (c :initform 2 :read-only T))
  (:metaclass acl-slots-class))

(mapcar #'slot-definition-read-only-p (class-slots (find-class 'foo)))
→ (t nil t)

(let ((obj (make-instance 'foo)))
  (with-slots (a b c) obj
    (list a b c)))
→ (0 1 2)

(let ((obj (make-instance 'foo)))
  (with-slots (a b c) obj
    (setq b 100)
    (list a b c)))
→ (0 100 2)

(let ((obj (make-instance 'foo)))
  (with-slots (a b c) obj
    (setq a 100)
    (list a b c)))
!!! Cannot assign to read only slot a of #<foo 40201234EB>

(let ((obj (make-instance 'foo)))
  (setf (foo-a obj) 8))
!!! Cannot assign to read only slot a of #<foo 402020F6C3>

ここまで書いて試してみて、クラスの属性としてスロットにリードオンリー属性を付けるだけならインスタンスに隠しスロットを付ける意味がないという致命的なことに気付いてしまったので、インスタンス生成時にも個別に指定できるようにしてみました。

(make-instance 'bar :read-onlys '(:b))のように:read-onlys引数で該当するスロットの:initargを指定します。

(defclass bar (acl-slots-object)
  ((a :read-only T :initform 0 :initarg :a :reader bar-a)
   (b :read-only nil :initform 1 :initarg :b :accessor bar-b)
   (c :read-only T :initform 2 :initarg :c))
  (:metaclass acl-slots-class))

(let ((obj (make-instance 'bar)))
  (setf (bar-b obj) 42))
→ 42

(let ((obj (make-instance 'bar :read-onlys '(:b))))
  (setf (bar-b obj) 42))
!!! Cannot assign to read only slot b of #<bar 402009983B>

まとめ

あと九個もネタが捻り出せない。

実装

(defpackage "3d5973f5-7755-5daf-a825-d623a03a4d53" (:use c2cl slotted-objects))

(cl:in-package "3d5973f5-7755-5daf-a825-d623a03a4d53")

(defconstant slot-dim 0)

(defconstant acl-dim 1)

(defclass acl-slots-class (slotted-class)
  ()
  (:metaclass standard-class))

(defmethod allocate-instance ((class acl-slots-class) &rest initargs)
  (allocate-slotted-instance (class-wrapper class)
                          (make-array `(2 ,(length (class-slots class)))
                                      :initial-element (make-unbound-marker))))

(defclass acl-slots-object (slotted-object)
  ()
  (:metaclass acl-slots-class))

(defmethod slot-value-using-class ((class acl-slots-class) instance (slotd slot-definition))
  (aref (instance-slots instance)
        slot-dim
        (slot-definition-location slotd)))

(defmethod (setf slot-value-using-class) (value (class acl-slots-class) instance (slotd slot-definition))
  (let* ((slots (instance-slots instance))
         (loc (slot-definition-location slotd)))
    (when (aref slots acl-dim loc)
      (error "Cannot assign to read only slot ~S of ~S" (slot-definition-name slotd) instance))
    (setf (aref slots slot-dim loc) value)))

(defun slot-read-only-p (instance slot-name)
  (aref (instance-slots instance)
        acl-dim
        (slot-definition-location
         (find slot-name (class-slots (class-of instance))
               :key #'slot-definition-name))))

(defclass acl-slots-slot-definition (standard-slot-definition)
  ((attributes :initform nil
               :initarg :read-only 
               :accessor slot-definition-read-only-p)))

(defclass direct-acl-slots-slot-definition (standard-direct-slot-definition acl-slots-slot-definition)
  ())

(defmethod direct-slot-definition-class ((class acl-slots-class) &rest initargs)
  (find-class 'direct-acl-slots-slot-definition))

(defclass effective-acl-slots-slot-definition (standard-effective-slot-definition acl-slots-slot-definition)
  ())

(defmethod effective-slot-definition-class ((class acl-slots-class) &rest initargs)
  (find-class 'effective-acl-slots-slot-definition))

(defmethod compute-effective-slot-definition ((class acl-slots-class)
                                              name
                                              direct-slot-definitions)
  (let ((effective-slotd (call-next-method)))
    (dolist (slotd direct-slot-definitions)
      (when (typep slotd 'acl-slots-slot-definition)
        (setf (slot-definition-read-only-p effective-slotd) 
              (slot-definition-read-only-p slotd))
        (return)))
    effective-slotd))

(defmethod initialize-slot-from-initarg ((class acl-slots-class) instance slotd initargs)
  (let ((slot-initargs (slot-definition-initargs slotd)))
    (loop :for (initarg value) :on initargs :by #'cddr
          :do (when (member initarg slot-initargs)
                (setf (aref (instance-slots instance) slot-dim (slot-definition-location slotd))
                      value)
                (return T)))))

(defmethod initialize-slot-from-initfunction ((class acl-slots-class) instance slotd)
  (let ((initfun (slot-definition-initfunction slotd)))
    (unless (not initfun)
      (setf (aref (instance-slots instance) slot-dim (slot-definition-location slotd))
            (funcall initfun)))))

(defmethod shared-initialize :after ((instance acl-slots-object) slot-names &key read-onlys &allow-other-keys)
  (let* ((class (class-of instance))
         (slots (class-slots class)))
    (dolist (s slots)
      (setf (aref (instance-slots instance) acl-dim (slot-definition-location s))
            (slot-definition-read-only-p s))
      (when (intersection read-onlys (slot-definition-initargs s))
        (setf (aref (instance-slots instance) acl-dim (slot-definition-location s))
              T)))))

■

HTML generated by 3bmd in LispWorks 7.0.0

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

Java等では、インスタンス化不可な抽象クラスを定義したり、抽象クラスでメソッドの実装を強制したりできますが、Common Lispだとmixinクラスのインスタンス化はマナーとしてしない程度です。さらに、メソッドの実装を強制については、そもそも総称関数なのでクラスが統治の単位でもありません。

また、オブジェクト指向システムがとても動的なので、チェックがコンパイル時ではなく、実行時によってしまうというのもいま一つなところです。

とはいえ、MOPのインスタンス生成プロトコルにフックを掛けてインスタンス化を抑止することは可能で、そのフックのポイントがallocate-instanceからclass-prototypeあたりになります。

allocate-instanceでメソッド実装の強制

まあ、allocate-instanceにメソッド実装の強制という責務はないのですが、インスタンスが生成されるポイントなのでフックを掛けるのがこのあたりになってしまいます。

とりあえず:abstract-methodsオプションにメソッドを指定してクラスに該当するメソッドが実装されているかをチェックするのをallocate-instance :beforeに仕掛けます。

(defpackage "0cbdbd51-5be8-57c3-9b14-9473f74c8a61" (:use c2cl))

(cl:in-package "0cbdbd51-5be8-57c3-9b14-9473f74c8a61")

(defclass enforcing-abstract-methods-class (standard-class)
  ((abstract-methods :initform '() :accessor class-abstract-methods)
   (direct-abstract-methods :initform '()
                            :reader class-direct-abstract-methods
                            :initarg :abstract-methods)))

(defmethod finalize-inheritance :after ((class enforcing-abstract-methods-class))
  (setf (class-abstract-methods class)
        (remove-duplicates
         (loop :for c :in (class-precedence-list class)
               :when (typep c 'enforcing-abstract-methods-class)
               :append (mapcar #'eval (class-direct-abstract-methods c)))
         :from-end T)))

(defmethod allocate-instance :before ((class enforcing-abstract-methods-class)
                                      &key &allow-other-keys)
  (dolist (gf (class-abstract-methods class))
    (or (some (lambda (x)
                (find class (method-specializers x)))
              (generic-function-methods gf))
        (error "Can't instantiate abstract class ~S with abstract methods ~S."
               class
               gf))))

ついでに、インスタンス化不可なabstract-classも定義します。
こちらは、以前ブログで紹介したものになります。

• #:g1: Common Lispで抽象クラス

一応仕組みを解説すると、abstract-classを:metaclassに指定した場合、class-prototype :aroundとallocate-instanceの組み合わせがエラーになりますが、抽象クラスのサブクラスがstandard-class等を:metaclassに指定すれば、通常ルートでインスタンス生成が実行されるのでエラーにならない、という流れです。

(defclass abstract-class (standard-class) 
  ())

(defmethod validate-superclass ((class abstract-class) (superclass standard-class)) 
  T)

(defmethod validate-superclass ((class standard-class) (superclass abstract-class)) 
  T)

(defvar *outside-abstract-class* nil)

(defmethod allocate-instance ((class abstract-class) &key &allow-other-keys)
  (unless *outside-abstract-class*
    (error "There was an attempt to make an instance of abstract class ~S" (class-name class))))

(defmethod class-prototype :around ((class abstract-class))
  (let ((*outside-abstract-class* T))
    (call-next-method)))

試してみる

;; 抽象クラス
(defclass foo ()
  (a b c)
  (:metaclass abstract-class))

;; インスタンス化できない
(make-instance 'foo)
!!! There was an attempt to make an instance of abstract class foo

;; 実装するメソッド
(defgeneric ztesch (x))
(defgeneric bazola (x y))
;; メソッド実装強制クラス
(defclass bar (foo)
  ()
  (:metaclass enforcing-abstract-methods-class)
  (:abstract-methods #'ztesch #'bazola))
;; インスタンス化できない
(make-instance 'bar)
!!! Can't instantiate abstract class #<enforcing-abstract-methods-class bar 41C00A64F3> with abstract methods #<common-lisp:standard-generic-function ztesch 41E001C3FC>.
;; 抽象クラス+メソッド実装強制メタクラス
(defclass abstract-class-enforcing-abstract-methods-class (abstract-class enforcing-abstract-methods-class)
  ())

;; 抽象クラス+メソッド実装強制クラス(が抽象クラスを継承)
(defclass baz (foo)
  ()
  (:metaclass abstract-class-enforcing-abstract-methods-class)
  (:abstract-methods #'ztesch #'bazola))

;; インスタンス化できない(なお実装を強制されたメソッドが空の場合、抽象クラス側のエラーとなる)
(make-instance 'baz)
!!! Can't instantiate abstract class #<abstract-class-enforcing-abstract-methods-class baz 42205DAC5B> with abstract methods #<common-lisp:standard-generic-function ztesch 424001B494>.
;; 抽象クラス+メソッド実装強制クラス(が抽象クラスを継承)のサブクラス
(defclass quux (baz)
  ()
  (:metaclass enforcing-abstract-methods-class))

(finalize-inheritance (find-class 'quux))

;; 実装が強制されたメソッドの確認
(class-abstract-methods (find-class 'quux))
→ (#<common-lisp:standard-generic-function ztesch 41E001C3FC> #<common-lisp:standard-generic-function bazola 41E001C434>) 
;; メソッドが実装されていないのでエラー
(make-instance 'quux)
!!! Can't instantiate abstract class #<enforcing-abstract-methods-class quux 40201AD06B> with abstract methods #<common-lisp:standard-generic-function ztesch 41E001C3FC>.
;; メソッドの実装
(defmethod ztesch ((q quux))
  (with-slots (a b c) q
    (setq a 0 b 1 c 2))
  q)

(defmethod bazola ((x integer) (y quux))
  (with-slots (a b c) y
    (* x (+ a b c))))

;; インスタンス化できた 
(bazola 10 (ztesch (make-instance 'quux)))
→ 30

まとめ

今回は抽象クラスとメソッド実装の強制を別々に定義してメタクラスのmixinとしました。
メソッド実装が強制されるという感覚にいま一つ馴染がないのですが、Common Lispにどうなるのが正しいのかは色々コードを書いてみないと分からなさそうです……。

■

HTML generated by 3bmd in LispWorks 7.0.0

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

折り返しを過ぎましたが、完全にネタ切れなのでallocate-instanceでウェブを検索したりしていますが、allocate-instance関係で以前から不思議に思っていたことを思い出したので調べてみました。

allocate-instanceがCLtL2に定義されていない

そもそも、CLtL2(Common Lisp the Language 2nd Ed.)は、ANSI Common Lisp規格成立までの中間報告書なので、ANSI CL規格からみて不備があってもしょうがないのですが、CLtL2中にはallocate-instanceの名前だけは出現するものの、項目を立てて定義が解説されてはいません。

この辺りが謎だったのですが、どうも単純に考慮漏れだったようで、CLtL2の出版時まで、処理系内部の関数なのか外部APIなのかで揺れていたようです。

オブジェクトをアロケートする手続きはどんな処理系でも備えているのは確かなのですが、外部API仕様として確立する必要が出たのは、make-load-formでユーザー定義の手続きの中にallocate-instanceを含まざるを得ないことが判明したからだったようです。

• Issue ALLOCATE-INSTANCE Writeup

また、ANSI規格のallocate-instanceにstructure-classの定義があるのが謎だったのですが、これもmake-load-formの為だと考えれば納得です。

• Standard Generic Function ALLOCATE-INSTANCE

まとめ

いつもながらANSI CLは細かいところまで良く考えられていると感心します。 また、CLtL2はANSI CL規格の補助資料として参照するに留めるのが吉だと改めて思いました(が人気の根強いことよ)

参考

• Proposed de facto standard subset of metaobjects

■

HTML generated by 3bmd in LispWorks 7.0.0

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

今回もECLOSの拡張のアイデアが元ネタですが、ECLOSにはattributed-classという再帰的な属性を持つクラスが紹介されているので、属性を隠しスロットに格納するという方法で定義してみました。

• LispM.de > docs > Publications > Common Lisp
  • ECLOS Metaclass library
  • Extended CLOS
• Advances in Object-Oriented Metalevel Architectures and Reflection
  • Why the MOP should the mopped
    • Google Booksの該当個所

動作

実際の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

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

アドベントカレンダー折り返し地点で既にネタがブチ切れなのですが、どうにかネタを捻り出していきたいと思います。

今回は、スロットのストレージをOSのファイルとして読み書きしてみることにしました。

“objstore”ディレクトリの直下がクラス名、次にインスタンスのディレクトリがあり、その直下にスロットのファイルが配置されます。
アロケートのタイミングでファイルの読み書きをしなくても、スロットの読み書きでフックをかければ似たようなことはできるのですが、ファイルの確保はallocate-instanceが担当する方が素直かなと思いました。
一応論理パスを利用してファイル名との直接のマッピングは避けています。

非常に簡易的な永続化の方法ですが、案外使えるかも?

実装

(defpackage "8a202ea6-99d1-523d-969b-dbf5fb19ffa5" 
  (:use c2cl slotted-objects))

(cl:in-package "8a202ea6-99d1-523d-969b-dbf5fb19ffa5")

(setf (logical-pathname-translations "objstore")
      `(("**;*.*.*" "/tmp/**/*.*")))

(defclass file-slots-class (slotted-class) ())

(defclass file-slots-objects (slotted-object) 
  ()
  (:metaclass file-slots-class))

(defun openo (path)
  (open path
        :direction :output
        :if-does-not-exist :create
        :if-exists :supersede))

(defmethod allocate-instance ((class file-slots-class) &rest initargs)
  (allocate-slotted-instance (class-wrapper class)
                          (let* ((instance-name (gensym (string (class-name class))))
                                 (files (mapcar (lambda (s)
                                                  (ensure-directories-exist
                                                   (make-pathname :host "objstore"
                                                                  :directory 
                                                                  `(:absolute ,(string (class-name class)) ,(string instance-name))
                                                                  :name (string (slot-definition-name s)))))
                                                (class-slots class))))
                            (dolist (f files files)
                              (with-open-stream (out (openo f))
                                (print nil out))))))

(defmethod slot-value-using-class ((class file-slots-class) instance (slotd slot-definition))
  (with-open-file (in (elt (instance-slots instance) (slot-definition-location slotd)))
    (read in)))

(defmethod (setf slot-value-using-class) (value (class file-slots-class) instance (slotd slot-definition))
  (with-open-stream (out (openo (elt (instance-slots instance) (slot-definition-location slotd))))
    (print value out)
    (terpri out)
    value))

動作

(defclass foo (file-slots-objects)
  ((a :initform 0)
   (b :initform 1)
   (c :initform 2))
  (:metaclass file-slots-class))

(defclass bar (foo)
  ((d :initform 3))
  (:metaclass file-slots-class))

(let ((obj (make-instance 'bar)))
  (setf (slot-value obj 'd)
        "こんにちは"))

$ ls /tmp/bar
bar17928740
$ cat /tmp/bar/*/*
0 
1 
2 
"こんにちは"

■

HTML generated by 3bmd in LispWorks 7.0.0

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

このブログで度々取り上げているECLOSというMOPの拡張にlazy-classという初期化をアクセス時まで遅延させる機能があるのですが、今回はこの遅延初期化を二次元配列で実装してみようと思います。

• LispM.de > docs > Publications > Common Lisp
  • ECLOS Metaclass library
  • Extended CLOS
• Advances in Object-Oriented Metalevel Architectures and Reflection
  • Why the MOP should the mopped
    • Google Booksの該当個所

遅延初期化の仕様

(defclass foo (lazy-init-object)
  ((a :initform 0 :initialization :read)
   (b :initform 1 :initialization :access)
   (c :initform 2))
  (:metaclass lazy-init-class))

こんな感じに:initializationでスロット読み取り時(:read)や、スロット更新時(:access)が指定された場合、その時まで初期化は遅延されます。

本家ECLOSでは、さらにスロット間の初期化順序の関係性を記述することが可能ですが、論文の記述だけだと若干挙動が不明なのと、かなり複雑になるので、今回は初期化タイミングの機能に絞ります。

実装

今回実装した遅延の仕組みは非常に単純で、二次元配列で隠しスロットを付加し、そこに初期化関数のクロージャーを詰め、指定のタイミングで呼び出すだけです。
詰め込みにはshared-initializeを使いますが、安易にshared-initializeの中でslot-value-using-classを呼ぶと無限ループするので注意しましょう。自分はこのパターンを良くやってしまいます(自分だけか)
大したことはしていないのですが、スロットにオプションを追加すると長くなります……。

(defpackage "2fa9989a-2db4-50b0-953d-4285ca2aaa88" 
  (:use c2cl slotted-objects))

(cl:in-package "2fa9989a-2db4-50b0-953d-4285ca2aaa88")

(defclass lazy-init-class (slotted-class)
  ())

#+lispworks
(defmethod clos:process-a-slot-option 
           ((class lazy-init-class) option value already-processed-options slot)
  (if (eq option :initialization)
      (list* :initialization value already-processed-options)
      (call-next-method)))

(defclass lazy-init-object (slotted-object)
  ()
  (:metaclass slotted-class))

(defconstant slot-dim 0)

(defconstant init-dim 1)

(defmethod allocate-instance ((class lazy-init-class) &rest initargs)
  (declare (ignore initargs))
  (allocate-slotted-instance (class-wrapper class)
                          (make-array `(2 ,(length (class-slots class)))
                                      :initial-element (make-unbound-marker))))

(defclass lazy-init-slot-definition (slot-definition)
  ((initialization :initform nil
                   :accessor slot-definition-initialization
                   :initarg :initialization)))

(defclass lazy-init-direct-slot-definition (standard-direct-slot-definition lazy-init-slot-definition)
  ())

(defmethod direct-slot-definition-class ((class lazy-init-class) &rest initargs)
  (find-class 'lazy-init-direct-slot-definition))

(defclass lazy-init-effective-slot-definition (standard-effective-slot-definition lazy-init-slot-definition)
  ())

(defmethod effective-slot-definition-class ((class lazy-init-class) &rest initargs)
  (find-class 'lazy-init-effective-slot-definition))

(defmethod compute-effective-slot-definition ((class lazy-init-class) name direct-slot-definitions)
  (declare (ignore name))
  (let ((eslotd (call-next-method)))
    (dolist (dslotd direct-slot-definitions)
      (when (typep dslotd (find-class 'lazy-init-slot-definition))
        (setf (slot-definition-initialization eslotd) 
              (slot-definition-initialization dslotd))))
    eslotd))

(defmethod initialize-slot-from-initarg ((class lazy-init-class) instance slotd initargs)
  (let ((slot-initargs (slot-definition-initargs slotd)))
    (loop :for (initarg value) :on initargs :by #'cddr
          :do (when (member initarg slot-initargs)
                (setf (aref (instance-slots instance) slot-dim (slot-definition-location slotd))
                      value)
                (return T)))))

(defmethod initialize-slot-from-initfunction ((class lazy-init-class) instance slotd)
  (let ((initfun (slot-definition-initfunction slotd)))
    (unless (not initfun)
      (setf (aref (instance-slots instance) slot-dim (slot-definition-location slotd))
            (funcall initfun)))))

(defmethod shared-initialize ((instance lazy-init-object) slot-names &rest initargs)
  (let* ((class (class-of instance))
         (slotds (class-slots class)))
    (dolist (slotd slotds)
      (setf (aref (instance-slots instance) init-dim (slot-definition-location slotd))
            (lambda ()
              (unless (initialize-slot-from-initarg class instance slotd initargs)
                (when (or (eq T slot-names)
                          (member (slot-definition-name slotd) slot-names))
                  (initialize-slot-from-initfunction class instance slotd))))))
    ;; eager init
    (dolist (slotd slotds)
      (when (null (slot-definition-initialization slotd))
        (let ((slots (instance-slots instance))
              (loc (slot-definition-location slotd)))
          (funcall (aref slots init-dim loc))
          (setf (aref slots init-dim loc) nil)))))
  instance)

(defmethod slot-value-using-class ((class lazy-init-class) instance (slotd slot-definition))
  (let ((loc (slot-definition-location slotd))
        (slots (instance-slots instance)))
    (case (slot-definition-initialization slotd)
      ((:read)
       (when (aref slots init-dim loc) 
         (funcall (aref slots init-dim loc))
         (setf (aref slots init-dim loc) nil)))
      (otherwise nil))
    (aref slots slot-dim loc)))

(defmethod (setf slot-value-using-class) (value (class lazy-init-class) instance (slotd slot-definition))
  (let ((loc (slot-definition-location slotd))
        (slots (instance-slots instance)))
    (case (slot-definition-initialization slotd)
      ((:read :access)
       (when (aref slots init-dim loc) 
         (funcall (aref slots init-dim loc))
         (setf (aref slots init-dim loc) nil)))
      (otherwise nil))
    (setf (aref slots slot-dim loc) value)))

動作

(defclass foo (lazy-init-object)
  ((a :initform 0 :initialization :read)
   (b :initform 1 :initialization :access)
   (c :initform 2))
  (:metaclass lazy-init-class))

(let ((obj (make-instance 'foo)))
  (instance-slots obj)) ;スロットデータの中身を覗いてみる
→
#2A((#<Slot Unbound Marker> #<Slot Unbound Marker> 2)
    (#<Closure 1 subfunction of (method shared-initialize (lazy-init-object t)) 4060013B14>
     #<Closure 1 subfunction of (method shared-initialize (lazy-init-object t)) 4060013B3C>
     #<Closure 1 subfunction of (method shared-initialize (lazy-init-object t)) 4060013B64>))  
(let ((obj (make-instance 'foo)))
  (with-slots (a b c) obj a b c)
  (instance-slots obj)) 
→
#2A((0 #<Slot Unbound Marker> 2)
    (nil #<Closure 1 subfunction of (method shared-initialize (lazy-init-object t)) 406001227C> nil)) ; :read で初期化された

(let ((obj (make-instance 'foo)))
  (with-slots (a b c) obj 
    a 
    (setq b 42)
    c)
  (instance-slots obj))
→
#2A((0 42 2) (nil nil nil)) ; :readと:access で初期化された

まとめ

スロット初期化の遅延ですが、個人的には遅延させたい局面に遭遇したことがないので、いまいちぴんと来ません。大きなリソースを割り付けたい場合などにはできるだけ遅延させると効率が良いのかも。

メタクラスの定義やスロット定義では似たようなものを毎度書くので、defmetaclassのようなものを定義して使っている人もいます。

Eric L. Peterson氏のdefmetaclassは、なかなか良い圧縮具合と使い勝手っぽいので真似してみたいところですが、全部のパターンがマクロで上手く纏められるかというと、そうでもないのがなんとも悩ましい。

参考

• Dynamic Persistent Metadata : A Metaobject Protocol Based Approach to Increasing Power in Knowledge Representation

■

HTML generated by 3bmd in LispWorks 7.0.0

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

毎度ネタ切れになると、先人の活用事例を参考にしたりライブラリ紹介をしたりしていますが、allocate-instanceに限っては、ほとんど事例がない様子。

メソッドコンビネーションでさえそこそこ事例はあったのに……。

とはいえ、とりあえず一つは見付けたので、そちらの紹介をしてみます。
しかし、どうも実験的なものらしく、プロジェクトのゴミ箱フォルダに入っています。

compact-class

今回紹介するのは、いつも妙なものを作っているhu.dwimの皆さんのhu.dwim.utilの中のcompact-classです。

• hu.dwim.util: compact-class

スロット内容をコンパクトな表現に変換するようですが、とりあえず動作を説明すると、

(defclass foo ()
  ((a :initform nil :allocation :compact :type boolean)
   (b :initform nil :allocation :compact :type boolean)
   (c :initform nil :allocation :compact :type boolean)
   (d :initform nil :allocation :compact :type boolean))
  (:metaclass compact-class))
(let ((obj (make-instance 'foo)))
  (setf (slot-value obj 'a) T)
  (setf (slot-value obj 'b) T)
  (with-slots (a b c d) obj
    (list a b c d
          (instance-slots obj))))
→ (t t nil nil #(3)) 

—のように:allocation :compactを指定するとboolean型のスロット群の(t t nil nil)のコンパクトな表現として、#(3)が格納されます。

(t t nil nil) 反転→ (nil nil t t) → #b0011 → 3

という具合になります。

対応している型と圧縮/解凍の手順ですが、スロットのリーダー/ライターの関数を生成する部分に書いてあります。
ちなみに、SBCLに特化した記述になっていますが、現在のSBCLでは動かないようです。

(def function make-compact-slot-reader (slot)
  (bind ((compact-word-offset (compact-word-offset-of slot))
         (compact-bits-offset (compact-bits-offset-of slot))
         (compact-bit-size (compact-bit-size-of slot))
         (type (slot-definition-type slot)))
    (declare (type (integer 0 #.(integer-length most-positive-fixnum)) compact-bit-size compact-bits-offset)
             (type fixnum compact-word-offset))
    (flet ((%slot-value (instance)
             (declare #.(optimize-declaration))
             (the fixnum (ldb (byte compact-bit-size compact-bits-offset)
                              (the fixnum (standard-instance-access instance compact-word-offset))))))
      (declare (inline %slot-value))
      (cond ((subtypep type 'boolean)
             (lambda (instance)
               (declare #.(optimize-declaration))
               (= (%slot-value instance) 1)))
            ((subtypep type 'integer)
             (lambda (instance)
               (declare #.(optimize-declaration))
               (%slot-value instance)))
            ((subtypep type 'base-char)
             (lambda (instance)
               (declare #.(optimize-declaration))
               (code-char (%slot-value instance))))
            ((subtypep type 'single-float)
             (lambda (instance)
               (declare #.(optimize-declaration))
               #+sbcl (sb-vm::make-single-float (%slot-value instance))))
            ((and (subtypep type 'simple-base-string)
                  (consp type))
             (lambda (instance)
               (declare #.(optimize-declaration))
               (iter (with value = (%slot-value instance))
                     (with string = (make-string (second type)))
                     (for index :from 0 :below (the fixnum (second type)))
                     (for position :initially 0 :then (+ 7 position))
                     (declare (type fixnum index position))
                     (setf (aref string index) (code-char (ldb (byte 7 position) value)))
                     (finally (return string)))))
            (t
             (aif (type-instance-count-upper-bound type)
                  (bind ((instance-list (type-instance-list type)))
                    (lambda (instance)
                      (elt instance-list (%slot-value instance))))
                  (error "Unknown compact type ~A" type)))))))

まとめ

今回は、hu.dwim.utilのcompact-classを紹介してみました。
結構アグレッシブで面白いと思います。

■

HTML generated by 3bmd in LispWorks 7.0.0