#:g1: CODASYLなインスタンス

Posted 2020-12-07 18:39:35 GMT

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

allocate-instanceでカスタマイズしたいような場面について考えていますが、

あたりがある気がしていますが、今回は、インスタンス群の組織化で考えてみたいと思います。

CODASYL Set

論理・代数・データベースという本を読んでいて、昔のデータベースの構成方法にCODASYL Setというのがあることを知ったのですが、これはナビゲーショナルデータベースや、ネットワーク型データモデルの先駆けらしいです。

親子関係にあるオブジェクトでリンクトリストを作る感じですが、インスタンス群を組織化するのに隠しスロットが使えそうなので試してみましょう。

オブジェクトはownerとmemberに分かれ、ownerが作る循環リストにメンバーが接続していくという感じです。

CODASYL Setのシンプルな構成は、循環する一方向リストですが、追加や検索の便宜を図ってownerへのポインタと前後のポインタを持つことが多いそうなので、そういう構成で書いてみます。

(defpackage "c247a8da-b119-500b-b556-47ff40b1347a" 
  (:use c2cl slotted-objects))

(in-package "c247a8da-b119-500b-b556-47ff40b1347a")

(defclass codasyl-class (slotted-class)
  ((owner :accessor codasyl-class-owner :initform nil :initarg :owner)))

#+lispworks
(defmethod clos:process-a-class-option ((class codasyl-class) (name (eql :owner)) value)
  (unless (and value (null (cdr value)))
    (error "codasyl-class: :owner must have a single value."))
  `(,name ,(car value)))

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

(defclass codasyl-element ()
  ((slots :accessor codasyl-element-slots :initarg :slots)
   (owner :accessor codasyl-element-owner :initarg :owner :initform nil)
   (next :accessor codasyl-element-next :initform nil)
   (prev :accessor codasyl-element-prev :initform nil)))

(defmethod allocate-instance ((class codasyl-class) &rest initargs)
  (let* ((slots (make-instance 'codasyl-element
                               :slots (make-sequence 'vector 
                                                     (length (class-slots class))
                                                     :initial-element (make-unbound-marker))))
         (instance (allocate-slotted-instance (class-wrapper class) slots)))
    (setf (codasyl-element-owner slots) instance)
    (setf (codasyl-element-prev slots) instance)
    (setf (codasyl-element-next slots) instance)
    instance))

(defmethod slot-value-using-class ((class codasyl-class) instance (slotd slot-definition))
  (elt (codasyl-element-slots (instance-slots instance))
       (slot-definition-location slotd)))

(defmethod (setf slot-value-using-class) (value (class codasyl-class) instance (slotd slot-definition))
  (setf (elt (codasyl-element-slots (instance-slots instance))
             (slot-definition-location slotd))
        value))

(defun find-last-codasyl-element (owner)
  (loop :for elt := (codasyl-element-next (instance-slots owner)) :then (codasyl-element-next (instance-slots elt))
        :when (eq (codasyl-element-next (instance-slots elt)) owner)
        :return elt))

(defmethod initialize-instance :after ((instance codasyl-object) &rest initargs)
  (let ((slot-data (instance-slots instance)))
    (let ((default-owner (codasyl-element-owner slot-data))
          (new-owner (codasyl-class-owner (class-of instance))))
      ;; if instance is member type
      (and (codasyl-class-owner (class-of instance))
           (unless (eq default-owner new-owner)
             ;; set the new owner
             (setf (codasyl-element-owner slot-data) new-owner)
             (let ((last (find-last-codasyl-element (codasyl-element-owner slot-data))))
               ;; concatenate the new member
               (setf (codasyl-element-prev slot-data) last)
               (setf (codasyl-element-next (instance-slots last)) instance)
               (setf (codasyl-element-next slot-data) new-owner)))))))

(defun walk-codasyl-members (owner fn)
  (loop :for e := (codasyl-element-next (instance-slots owner)) :then (codasyl-element-next (instance-slots e))
        :until (eq e owner)
        :do (funcall fn e)))

(defun map-codasyl-members (owner fn)
  (loop :for e := (codasyl-element-next (instance-slots owner)) :then (codasyl-element-next (instance-slots e))
        :until (eq e owner)
        :collect (funcall fn e)))

循環構造を作るので無駄に長くなりました……。

試してみる

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

(defclass member-foo (codasyl-object)
  ((a :initform 0)
   (b :initform 1)
   (c :initform 2))
  (:metaclass codasyl-class)
  (:owner (class-prototype (find-class 'owner-foo))))

;; 10個生成する
(dotimes (i 10)
  (make-instance 'member-foo))
;; 
(map-codasyl-members (codasyl-class-owner (find-class 'member-foo))
                     (lambda (m)
                       (with-slots (a b c) m
                         (list a b c))))
→ ((0 1 2) (0 1 2) (0 1 2) (0 1 2) (0 1 2) (0 1 2) (0 1 2) (0 1 2) (0 1 2) (0 1 2))

まとめ

1970年代のリソース環境では、循環リストにする価値はあったんだと思いますが、普通のリストにすれば結構単純化できそうです。
要素を別途リストで管理すれば良いのですが、今回のポイントは要素内に隠しスロットで前後および親へのポインタを持つということでしょうか。

Linuxのリスト実装の構造体のトリックがありますが、今回のようなクラスを定義してmixinして使うとリストが作れる的なクラスも実現できたりしそうです。

参考

■

HTML generated by 3bmd in LispWorks 7.0.0

comments powered by Disqus