#:g1

allocate-instanceが関係してくるプロトコルを眺める: MCS篇

Posted 2020-12-21 20:53:44 GMT

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

前回に引き続き、allocate-instanceが関係してくるInstance Structure Protocol(ISP)周りを中心に色々なCLOS MOP系の処理系で確認していきたいと思います。

今回は、MCSのallocate-instance周りを眺めます。
まず、MCSですが、The Meta Class Systemの略で、ObjVlispの流れをくみつつCLOSとの互換性も高いシステムです。

MOPも大体同じような構成になっていますが、MCSの方がシンプルでありつつ抽象クラスやmixinクラス等も用意されていて色々整理されているようにも見えます。

Object Creation and Initialization

  • allocate-instance
  • make-instance
  • initialize-instance
  • change-class
  • change-class-using-class

さてまず、インスタンスの構成ですが、isitslotsという二つの部分からなる構造体で表現されています。isitというのはCLOSの実装でいうとwrapperですが、クラスメタオブジェクトを一つ含んだリストで表現されていて、wrapperとclassのオブジェクトがほぼ一本化されています。

インスタンスのストレージは標準ではベクタです。 スロットストレージへは、mcs%-slots、wrapperの取り出しは、mcs%-isitで行えます。
CLOS MOPと異なる点として、スロット名から、スロットストレージの位置を割り出す関数がクラスの中に格納されている点で、標準では、general-slot-position関数が、class-slot-accessorに格納されています。

Instance Structure Protocol

  • slot-exists-p
  • slot-boundp
  • slot-makunbound
  • slot-value
  • mcs%slot-value
  • (setf slot-value)
  • mcs%set-slot-value
  • mcs%set-slot-value-low
  • compute-slots
  • mcs%local-slot-indexed
  • mcs%local-slot-indexed-low

スロットストレージの並び順は、CLと同様compute-slotsで確定するようです。 スロットの位置を計算する関数がクラスに含まれているので、slot-definition-locationは存在せず、%slot-location-ofが位置計算用関数を呼び出して計算します。

CLのstandard-instance-accessに相当するものは、mcs%local-slot-indexed-lowになりますが、slot unboundのサポートありのmcs%local-slot-indexedも用意されています。

CLと違ってslot-valueはマクロになっており、slot-value-using-系メソッドはなく、mcs%slot-valueに展開か、メソッド内部での最適化として、mcs%local-slot-indexed-lowを用いたアクセスになるよう展開するようです(なお実装ではそこまで最適化されていない)

mcs%slot-valueは、上述のスロット位置を名前から割り出す関数を呼び出して、インスタンスのストレージを添字でアクセスします。
なお、-lowが掴ないものは、slot unboundをサポートせずslot missingのみサポートします。

まとめ

MCSではslot-value-using-classが省略されていますが、その代わりにクラスがスロット名→ストレージの位置の変換関数を保持するというのが面白いと思いました。
この辺りの方式の違いをそのうち比較してみたいところです。


HTML generated by 3bmd in LispWorks 7.0.0

allocate-instanceが関係してくるプロトコルを眺める: Common Lisp篇

Posted 2020-12-20 17:40:41 GMT

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

ネタ切れも甚しいのでallocate-instanceが関係してくるInstance Structure Protocol(ISP)周りを中心に色々なCLOS MOP系の処理系で確認していきたいと思います。

まずは、本家Common Lispです。

Instance Structure Protocol

  • CLOS MOP: Instance Structure Protocol

  • slot-exists-p

  • slot-boundp

    • slot-boundp-using-class
  • slot-makunbound

    • slot-makunbound-using-class
  • slot-value

    • slot-value-using-class
  • (setf slot-value)

    • (setf slot-value-using-class)
  • compute-slots :around

  • slot-definition-location

  • standard-instance-access

  • funcallable-standard-class

  • funcallable-standard-instance-access

ISPで列挙されているのは、スロットアクセス系の関数/メソッドになり、allocate-instance等は埒外です。
ます、関係してくる順序としては、スロットストレージの並び順がcompute-slots :aroundで確定し、インスタンスのストレージとスロットの位置が確定します。それに伴なって、slot-definition-locationの値も決まり、standard-instance-accessでのアクセスの添字も決まる、という感じです。

slot-valueの下請けが、slot-value-using-classで、更に下請けが、standard-instance-accessとされていますが、処理系によっては、slot-valueからインスタンスのストレージに直通の場合もあるようです(LispWorksでスロットアクセスの最適化が有効になっている場合など)

standard-instance-accessは、インスタンスのストレージに添字でアクセスする低レベルの関数ですが、standard-と付いていることから判るように、standard-objectを想定しています。
standard-objectとはインスタンスのストレージ構成が違う場合には使えないと考えた方が良いでしょう。

Class finalization protocol

継承関係の確定のプロトコルですが、インスタンスがアロケートされる前に確定している必要があるとされており、allocate-instanceが呼ばれる前にclass-finalized-pで調べて確定していなければ、finalize-inheritanceが呼ばれるとされています。

この判定のタイミングですが、Robert Strandh先生によれば、allocate-instanceの引数のinitargsは確定後の計算結果になるので呼ばれる前に確定している筈としていてPCLでも、make-instancefinalize-inheritanceを呼んでいると註記していますが、PCL系であるSBCL等では、allocate-instanceの中で呼ばれています(ensure-class-finalized経由)。

大抵の処理系では、finalize-inheritanceを呼んでいるので、実際のところ必須なのかそうでないのか。ちなみに自分はStrandh先生を信じて今回のアドベントカレンダでは呼ばないスタイルで通しました。

Object Creation and Initialization

  • make-instance
  • shared-initialize
  • change-class
  • update-instance-for-different-class
  • update-instance-for-redefined-class

あたりですが、インスタンスストレージの構成が標準と異なる場合は、初期化/再初期化の手続を別途記述する必要が出てきます。
また、標準的な構成とカスタマイズしたものとでchange-classする場合は、インスタンスストレージの確保も別途記述する必要も出てきます。
大抵は、上記メソッドと標準メソッドコンビネーションでどうにかできますが、もしかしたら、標準から外れる場合は、Dependent maintenance protocolでストレージ形式の修正をしたりした方が良いのかもしれません。

まとめ

関係プロトコルをざっと眺めてみましたが、allocate-instanceをカスタマイズする例がほとんどないですね。
思えば、allocate-instanceのカスタマイズは、大抵は初期の文献に見付かるのですが何故なのか(共通仕様をまとめるのが難しいとか?)


HTML generated by 3bmd in LispWorks 7.0.0

virtual slotをallocate-instanceレベルで考えてみる

Posted 2020-12-19 21:12:58 GMT

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

MOPの応用として、仮想的なアロケーションの場所を指定する例があります。

大抵は、スロットの:allocation指定で、:virtual等を指定するという感じですが、allocate-instance内でどうにかできないか考えてみます。 allocate-instance内でどうにかするという縛りなので、スロットストレージに関数を詰めて呼び出すという作戦で実行時にデータを取得できるようにしてみます。

(defpackage "f53e7180-1934-50c0-9c43-7c6a79b7a5e2" 
  (:use c2cl slotted-objects))

(cl:in-package "f53e7180-1934-50c0-9c43-7c6a79b7a5e2")

(defclass virtual-class (slotted-class) ())

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

(defmethod allocate-slot-storage ((class virtual-class) size initial-value) (let ((storage (make-sequence 'vector size)) (fctns (make-sequence 'vector size))) (dotimes (index size fctns) (setf (elt fctns index) (let ((index index)) (lambda (op value) (case op (:get (elt storage index)) (:set (setf (elt storage index) value)))))))))

(defmethod slot-value-using-class ((class virtual-class) instance (slotd slot-definition)) (funcall (elt (instance-slots instance) (slot-definition-location slotd)) :get 'ignore))

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

微妙に使い勝手が悪いですが、とりあえず下記のように書けます。 スロット読み出しが発生すると、スロットストレージに詰められたクロージャーが呼ばれ、値を計算します。

(defclass 56nyan (virtual-object)
  ((name)
   (code :initarg :item-code)
   (price))
  (:metaclass virtual-class))

(defun get-56nyan-page (code) (babel:octets-to-string (drakma:http-request (format nil "https://www.56nyan.com/fs/goronyan/~A" code) :force-binary T) :encoding :cp932))

(defmethod allocate-slot-storage ((class (eql (find-class '56nyan))) size initial-value) (let* ((fcns (call-next-method)) (slotds (class-slots class))) (labels ((name->loc (name) (slot-definition-location (find name slotds :key #'slot-definition-name))) (slot-fctn (name) (elt fcns (name->loc name))) ((setf slot-fctn) (fctn name) (setf (elt fcns (name->loc name)) fctn)) (code () (funcall (elt fcns (name->loc 'code)) :get nil))) (setf (slot-fctn 'name) (lambda (op value) (declare (ignore value)) (case op (:get (plump:attribute (elt (clss:select "meta[property=og:title]" (plump:parse (get-56nyan-page (code)))) 0) "content")) (:set nil)))) (setf (slot-fctn 'price) (lambda (op value) (declare (ignore value)) (case op (:get (plump:text (elt (clss:select ".itemPrice" (plump:parse (get-56nyan-page (code)))) 0))) (:set nil))))) fcns))

実行してみる

allocate-instanceレベルで実現する意義を考えてみましたが、change-classしても値がスムースに移行可能なのではないでしょうか。

(defclass 56nyan-static ()
  ((name)
   (code :initarg :item-code)
   (price)))

(let ((obj (make-instance '56nyan :code "7e003-001"))) (change-class obj '56nyan-static) (describe obj)) ⇒ #<56nyan-static 42000B7D3B> is a 56nyan-static name "アカナ グラスランド キャット 340g (42341) 【正規品】" code "7e003-001" price "1,093円"

まとめ

そもそも、Common Lispの場合、スロットのリーダ/ライタでメソッドコンビネーションが使えるので、Virtual Slotsのようなものはあまり必要ないような気もします。

ちなみに、今回のchange-classの用法ですが、Common Lisp Proメーリングリストのchange-classの議論で、とりあえずデータをロードして、change-classで正規化するのが便利、という用例紹介をちょっと真似してみました(今回は正規化してませんが)

自分も以前、change-classの使い方として試してみたことがあった気がしますが、こういう応用も無くはないのかなと思います。


HTML generated by 3bmd in LispWorks 7.0.0

allocate-instanceでスロットのデフォルト値をnilにする

Posted 2020-12-19 10:56:17 GMT

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

以前、LW Dylan TranslatorというLispWorks上のDylanのシミュレーターのソースコードを眺めた時に、内部関数を使ってスロットをnilfillしていたのが印象に残っていたのですが、未束縛スロットの扱いが面倒なので、とりあえず: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

スロットストレージの拡張と標準オブジェクトとのコンパチビリティの確保について

Posted 2020-12-17 19:59:09 GMT

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

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

それはさておき、とりあえずの例として、スロットストレージが拡張された、a-classb-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-objectchange-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

アンドゥ可能なスロット

Posted 2020-12-16 23:30:16 GMT

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

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

動作と仕様

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

また、ユーティリティとしてundo-slotsreset-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

リードオンリーなスロット

Posted 2020-12-15 19:11:45 GMT

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でメソッド実装の強制

Posted 2020-12-14 15:00:00 GMT

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も定義します。
こちらは、以前ブログで紹介したものになります。

一応仕組みを解説すると、abstract-class:metaclassに指定した場合、class-prototype :aroundallocate-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がCLtL2で定義されていない謎

Posted 2020-12-13 17:11:41 GMT

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を含まざるを得ないことが判明したからだったようです。

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

まとめ

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

参考


HTML generated by 3bmd in LispWorks 7.0.0

隠しスロットで再帰的な属性付きスロット

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

Older entries (2376 remaining)