Common Lispでもたまに列挙型が欲しいことがありますが、そもそも列挙型はある要素の集合のことを指すようで、連続的な整数の一連の別名というわけではない様子。

• Wikipedia:列挙型

そういった場合は、型記述子memberで記述できるのですが、

(typep 'a '(member a b c))
→ t 

大抵の場合は、数値の連続に別名が付いたものが欲しかったりするので、memberでは数値との対応が実現できません。

連続した数値に別名を付与しつつ、これらと組み合わせて使うことが多いcase系の構文でも使い勝手良いものをと考えると、シンボルマクロで数値に別名を付与しつつ型の宣言もつけたらどうかと思い試してみました。

具体的には下記のようになります。

(deftype foo () '(eql 0))
(define-symbol-macro foo 0)
(typep foo 'foo)
→ t 

少し規模が大き目なものの場合、

(macrolet ((defenum (&rest args)
             `(progn
                ,@(loop :for idx :from 1
                        :for name :in args
                        :collect `(progn
                                    (define-symbol-macro ,name ,idx)
                                    (deftype ,name () '(eql ,idx)))))))
  (defenum H He Li Be B C N O F Ne Na Mg Al Si P S Cl
           Ar K Ca Sc Ti V Cr Mn Fe Co Ni Cu Zn Ga Ge As Se Br
           Kr Rb Sr Y Zr Nb Mo Tc Ru Rh Pd Ag Cd In Sn Sb Te I
           Xe Cs Ba La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb
           Lu Hf Ta W Re Os Ir Pt Au Hg Tl Pb Bi Po At Rn Fr Ra
           Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr Rf Db Sg
           Bh Hs Mt Ds Rg Cn Nh Fl Mc Lv Ts Og))

(typecase F
  ((or F Cl Br I At Ts) 'yes)
  (T 'no))
→ yes 

(deftype Halogens ()
  (list 'member F Cl Br I At Ts))

(typecase F
  (Halogens 'yes)
  (T 'no))
→ yes

ちなみに、定数宣言して、caseと#.の組み合わせを使うというのを目にしたことはありますが、#.を書くのが面倒だったり、評価タイミングを考えたりする必要があったりで、あまり使い勝手は良くないという印象です。

(case .F
  ((#.F #.Cl #.Br #.I #.At #.Ts) 'yes)
  (otherwise 'no))
→ yes 

まとめ

cl-enumerationのようなライブラリもありますが、一般的な言語の所謂enumとは微妙に目指すところが違うようです。

• #:g1: cl-enumerationの紹介

Common Lispだけで完結している場合には、あまり必要にならないのですが、既存のデータ定義を取り込んだり、別言語のコードを流用したりする場合に、enum欲しいなあとなることが多いですね。

■

HTML generated by 3bmd in LispWorks 7.0.0

• オブジェクト指向には、カメラがやっとついたころのガラケーのイメージがある

こちらの記事を読んで、自分が考えているオブジェクト指向とは随分違う何かがC++やJavaのオブジェクト指向プログラミングなんだなあと思いましたが、それと同時に、パラダイムがどうこうというより特定のパラダイムやシステムに囚われてしまう状況では、そこから抜け出すには、既存のものを捨てて他のパラダイムに移行せざるを得ないと考えてしまうのかもなあと感じました。

Common Lispはマルチパラダイムですが、

• 手続き/命令型(gotoもあり)
• 関数型/適用型/式指向
• とても動的なオブジェクト指向システム
• メタプログラミング(eval、マクロetc)

あたりが組込み機能です。

データがコードなため、メタプログラミングが容易で、組み込み言語のDSLで、Prologや、プロダクションシステム等を組込んで使ったりすることも可能です。 まあ、DSLが元言語とどこまで違和感なく連携するかはまた別の話ではありますが。

goto廃止論争が華やかだった時代も、マクロで構文を拡張できるLispは、gotoを廃止するということもなく、goを直接手書きしないような構文をマクロで言語標準機能として構築して迂回。
オブジェクト指向システムはSmalltalkの影響下で二三の実装がありましたが、最終的には総称関数という関数呼び出しにメッセージ送信を融合したような形式に収める、などなど、色々なパラダイムを吸収してきてはいますが、オブジェクト指向システムをほぼ使わずに書くことも可能ですし、関数がファーストクラスなので関数型的に書くことも容易です。
もともと対話環境が強力ですが、対話形式でも使えますし、バッチ形式でも使えます。 様々なパラダイムを強力なメタプログラミング機構がゆるくまとめているところもあるかもしれません。

こういうCommon Lispみたいな逃げ場が沢山ある言語が流行ると嬉しいですね。

■

HTML generated by 3bmd in LispWorks 7.0.0

• Swiftで大量のメンバ変数があるclassやstructのinitを自動生成する。

こちらの記事を目にして、IDEでコードを自動生成するのって格好良いと思ったので、Common Lispだとどうなるか考えてみました。

とりあえず構造体の場合は何もしなくてもコンストラクタのinitargがスロット名に応じて決定されてしまうので、何もしなくてもOKです。
勝手に決まってしまうことについては賛否がありますが、便利な局面は多いかと思います。

(defstruct codable-struct)
(defstruct (sample-struct (:include codable))
  int
  title
  body
  thumbnail-url
  tags
  categories
  created-at
  updated-at
  comment
  favoritedp
  bookmarkedp
  url)
(make-sample-struct :int 0
                    :title "title"
                    :body "body"
                    :thumbnail-url "https://example.com/image.jpg"
                    :tags '("tag")
                    :categories "cat"
                    :created-at 0
                    :updated-at 0
                    :comment "comment"
                    :favoritedp nil
                    :bookmarkedp nil
                    :url "https://example.com")
→ #S(sample-struct :int 0
                   :title "title"
                   :body "body"
                   :thumbnail-url "https://example.com/image.jpg"
                   :tags ("tag")
                   :categories "cat"
                   :created-at 0
                   :updated-at 0
                   :comment "comment"
                   :favoritedp nil
                   :bookmarkedp nil
                   :url "https://example.com")

クラスの場合は、構造体と違って全部指定してやらないといけません。
定義していない初期化のためのキーワード(:initarg)を指定しない場合はもちろんエラーです。

(defclass codable () 
  ())
(defclass sample-class (codable)
  (int
   title
   body
   thumbnail-url
   tags
   categories
   created-at
   updated-at
   comment
   favoritedp
   bookmarkedp
   url))
(make-instance 'sample-class)
→ #<sample-class 402018AA93>
(make-instance 'sample-class 
               :int 0
               :title "title"
               :body "body"
               :thumbnail-url "https://example.com/image.jpg"
               :tags '("tag")
               :categories "cat"
               :created-at 0
               :updated-at 0
               :comment "comment"
               :favoritedp nil
               :bookmarkedp nil
               :url "https://example.com")
→ #<error>

初期化手続きを生成してみる

Common Lispだとコンストラクタのコードを生成するようなことはマクロで実現してしまうのですが、IDEが補完してくれるのが格好良いという話なので、IDE側でコードを生成して挿入したいところです。

ということで、initialize-instanceのコードを生成して、エディタのコマンドで挿入してみることにしました。

(let* ((keys (mapcar (lambda (s)
                       (let ((s (slot-definition-name s)))
                         `(,s nil ,(intern (format nil "~A?" (string s))))))
                     (class-slots (find-class 'sample-class)))))
  `(defmethod initialize-instance ((obj sample-class) &key ,@keys)
     (let ((obj (call-next-method)))
       ,@(mapcar (lambda (k)
                   (destructuring-bind (name init namep)
                                       k
                     (declare (ignore init))
                     `(and ,namep (setf (slot-value obj ',name) ,name))))
                 keys)
       obj)))

した結果をエディタ(LispWorksのHemlock)からバッファに挿入します。
パッケージとシンボルの扱いのあれこれがあるので大分ごちゃごちゃになりました。

(defcommand "Generate Memberwise Initializer" (p)
     "Generate Memberwise Initializer"
     "Generate Memberwise Initializer"
  (declare (ignore p))
  (let ((def (current-top-level-definition-maybe)))
    (if (and (listp def)
             (eq (first def) 'defclass))
        (progn
          (end-of-defun-command 1)
          (insert-string
           (current-point)
           (with-output-to-string (out)
             (pprint 
              (let ((.class-name. (second def)))
                (declare (special editor::.class-name.))
                (eval
                 (read-from-string 
                  "(let* ((keys (mapcar (lambda (s)
                                       (let ((s (slot-definition-name s)))
                                         `(,s nil ,(intern (format nil \"~A?\" (string s))))))
                                     (class-slots (find-class editor::.class-name.)))))
                  `(defmethod initialize-instance ((obj sample-class) &key ,@keys)
                     (let ((obj (call-next-method)))
                       ,@(mapcar (lambda (k)
                                   (destructuring-bind (name init namep)
                                                       k
                                     (declare (ignore init))
                                     `(and ,namep (setf (slot-value obj ',name) ,name))))
                                 keys)
                       obj)))")))
              out))))
        (message "~S is not a defclass" def))))

これで、defclassの上で、“Generate Memberwise Initializer” します。

(defmethod initialize-instance
  ((obj sample-class)
   &key
   (int nil int?)
   (title nil title?)
   (body nil body?)
   (thumbnail-url nil thumbnail-url?)
   (tags nil tags?)
   (categories nil categories?)
   (created-at nil created-at?)
   (updated-at nil updated-at?)
   (comment nil comment?)
   (favoritedp nil favoritedp?)
   (bookmarkedp nil bookmarkedp?)
   (url nil url?))
  (let ((obj (call-next-method)))
    (and int? (setf (slot-value obj 'int) int))
    (and title? (setf (slot-value obj 'title) title))
    (and body? (setf (slot-value obj 'body) body))
    (and thumbnail-url? (setf (slot-value obj 'thumbnail-url) thumbnail-url))
    (and tags? (setf (slot-value obj 'tags) tags))
    (and categories? (setf (slot-value obj 'categories) categories))
    (and created-at? (setf (slot-value obj 'created-at) created-at))
    (and updated-at? (setf (slot-value obj 'updated-at) updated-at))
    (and comment? (setf (slot-value obj 'comment) comment))
    (and favoritedp? (setf (slot-value obj 'favoritedp) favoritedp))
    (and bookmarkedp? (setf (slot-value obj 'bookmarkedp) bookmarkedp))
    (and url? (setf (slot-value obj 'url) url))
    obj))

defclassで定義した挙動とは厳密には違いますが、こんな感じに初期化できるようになりました。

(make-instance 'sample-class 
               :int 0
               :title "title"
               :body "body"
               :thumbnail-url "https://example.com/image.jpg"
               :tags '("tag")
               :categories "cat"
               :created-at 0
               :updated-at 0
               :comment "comment"
               :favoritedp nil
               :bookmarkedp nil
               :url "https://example.com")
→ #<sample-class 4020240C13>
#||
int                0
title              "title"
body               "body"
thumbnail-url      "https://example.com/image.jpg"
tags               ("tag")
categories         "cat"
created-at         0
updated-at         0
comment            "comment"
favoritedp         nil
bookmarkedp        nil
url                "https://example.com"
||#

スロット定義を生成してみる

初期化手続きの生成はどうもいまひとつな気がするので、スロット定義を自動生成する方法を試してみます。

とりあえず、

• クラスを定義
• クラスのスロット定義からスロット名を抜き出し:initargを生成
• コードを置き換え

としてみます。

クラスのスロット定義からスロット名を抜き出し:initargを生成するのはこのようになります。

(defun add-initargs (class-name)
  (dolist (s (class-direct-slots (find-class class-name)))
    (setf (slot-definition-initargs s)
          (list (intern (string (string (slot-definition-name s)))
                        :keyword))))
  (reinitialize-instance (find-class class-name)))

次にdefclassフォームの生成

(defun gen-defclass (class-name)
  (let ((class (find-class class-name)))
    `(defclass ,(class-name class)
               (,@(mapcar #'class-name (class-direct-superclasses class)))
       ,(mapcar (lambda (s)
                  (append (list (slot-definition-name s))
                          (mapcan (lambda (i)
                                    (list :initarg i))
                                  (slot-definition-initargs s))))
                (class-direct-slots class))
       (:documentation ,(documentation class 'type))
       (:metaclass ,(class-name (class-of class)))
       (:default-initargs ,@(class-default-initargs class)))))

エディタのコマンドにまとめる

(defcommand "Generate Memberwise Initializer" (p)
     "Generate Memberwise Initializer"
     "Generate Memberwise Initializer"
  (declare (ignore p))
  (let ((def (current-top-level-definition-maybe)))
    (if (and (listp def)
             (string-equal (first def) 'defclass))
        (let ((*package* (get-buffer-current-package (current-buffer))))
          (add-initargs (print (second def)))
          (let ((dc (gen-defclass (second def))))
            (end-of-defun-command 1)
            (insert-form-at-point (current-point) 
                                  dc))
          (values))
        (message "~S is not a defclass" def))))

これで、コマンド実行でスロット名がキーワードパッケージになった:initargが追加されたdefclassがバッファに挿入されます。
ちなみに、:initarg以外も処理する必要がありますが今回は面倒なので省略します……。

(defclass sample-class (codable)
  ((int :initarg :int)
   (title :initarg :title)
   (body :initarg :body)
   (thumbnail-url :initarg :thumbnail-url)
   (tags :initarg :tags)
   (categories :initarg :categories)
   (created-at :initarg :created-at)
   (updated-at :initarg :updated-at)
   (comment :initarg :comment)
   (favoritedp :initarg :favoritedp)
   (bookmarkedp :initarg :bookmarkedp)
   (url :initarg :url))
  (:documentation nil)
  (:metaclass standard-class)
  (:default-initargs))

まとめ

色々考えてみましたが、defclassの派生マクロを作る方が楽だなと思いました。

マクロを基準に考えると、IDE側の方は展開したコードから元のコードへ戻す知識が失われるという欠点があり、マクロは派生した構文の使い方をおぼえるのが手間という欠点があります。

プログラム生成の知識をIDEが持つのかマクロが持つのかの違いでしかないと考えれば、プロジェクトごとに派生した定義構文があっても別に良いのかなと思ったりしました。

■

HTML generated by 3bmd in LispWorks 7.0.0

LispWorks IDEの紹介

LispWorksの特長

LispWorksを他のCommon Lispの処理系と比較した場合の特徴としては、Lisp処理系とIDEが密に連携している点です。

1989年のHarlequinのLispWorksの紹介によると、言語処理系の設計に先行してIDEの設計をしたとありますが、この辺りがLispWorksがIDE然としてしている所以ではないでしょうか。

• comp.lang.lisp: Summary: Lucid vs. Allegro

LispWorks
=========
...
The Approach
By designing the programming environment before the underlying language system,
Harlequin has engineered an unrivalled degree of internal cohesion into the
product. Programming tools are firmly embedded in the environment and both are
supported by sophisticated facilities for compilation and interpretation,
together with unobtrusive ephemeral garbage collection. The whole package is
written in Lisp to enhance consistency, maintainability and extensibility.

Lispマシンの環境も単なるLisp処理系ではなくIDEを指向していましたが、その後に擡頭してくる安価なUnixワークステーション上でのCommon Lisp環境もLispマシンを手本とし、IDEとしての完成度を追求していました。
似たような文化の言語にはSmalltalkがありますが、Common Lispの方は、Smalltalkと違って時代が下るにつれ処理系の言語処理系のコア以外の部分がどんどん落ちてしまい、Emacs+Common Lisp処理系(SLIME)というLispマシン以前に近いところまで遡ってしまいました。
その点では、LispWorksはIDEとしてのCommon Lisp環境として生き残った数少ない例かなと思います。
類似のものには、MCLがありましたが、2009年にIDEとしては終焉を迎えています。

LispWorksのIDEで便利な機能をピックアップして紹介

LispWorksのIDEの詳細な解説はマニュアルにゆずるとして、便利な機能をピックアップして紹介してみます。

インスペクタの履歴機能

Tools > Inspectorからインスペクタを開けます。

下記のように*inspect-through-gui* Tの状態でinspectを使うとinspectの実行履歴が、Previous、Nextボタンで参照できます。

(setq *inspect-through-gui* T)
(defun foo-loop (n)
  (dotimes (i n)
    (inspect (* i 8))))
(foo-loop 8)

オブジェクトの状態変化の追跡等に非常に便利です。

関数呼び出しの一覧

Definitions > Function Calls で呼び出しをツリー構造で眺めることが可能です。
所謂、who-calls、calls-whoの機能なのですが、GUIの操作でソースの参照も簡便に実現されているため、ソース参照M-x .およびM-x ,の発展版としても利用可能です。

ステップ実行

GUI画面でステップ実行が可能です。
現在メジャーな開発環境であるSBCL+SLIME等ではステップ実行は苦手としているためか、ステップ実行自体がCommon Lispでは無理という印象がありますが、LispWorksでは普通にGUIから対話的に操作可能です。

ブレイクポイントの設定

Common Lispの関数でいうと(break)ですが、LispWorksでは、IDEとして統合されていて、メニューや、エディタのM-x Toggle Breakpointで該当箇所に印をつけることで、(break)をコードに差し込まなくともブレイクすることが可能です。他の言語のIDEとしてもメジャーな機能かと思います。

ブレイクした後は、IDEのデバッガでリスタートや脱出、値の調査が可能です。

また、インスタンスオブジェクトのスロットのアクセスにもブレイクポイントを仕掛けることが可能です。こちらはインスペクタからブレイクポイントとその種類を設定可能ですがデバッグには便利でしょう。

アウトプットブラウザ

主に印字出力の確認ですが、LispWorksをSLIME的に使うのであれば、エディタ+アウトプットブラウザのウィンドウの二枚開きか、エディタ+リスナーの二枚開きという感じになります。
アウトプットブラウザにはプリントの結果やマクロ展開やtimeの結果が上から下へ流れて表示されます。

コンパイラ警告ブラウザ

コンパイラの警告を一覧でみることができるブラウザです。
エラーメッセージをクリックしてエラー箇所の関数にジャンプし修正、等が可能です。

トレースブラウザ

Common Lispでいう(trace)をGUIから操作できるようにしたものです。
テキスト表示とそれほど違いはありませんが、視認性と操作性は向上しているかと思います。

オブジェクトのクリップボード

テキストのコピペのクリップボード機能のようにオブジェクトをクリップボードに保存し、任意の場所に貼り付けることが可能です。

リスナー上でmake-instanceしたオブジェクトを保存しておき、インスペクタで変化を確認したり、値を設定したりするのに便利です。

ツール間のリンク機能

結果の確認ツールとして、リスナー(REPL)や、インスペクタが活躍しますが、ツール間でリンクすることにより、あるツールの結果をインスペクタやリスナーと同期させることが可能です。

マニュアルに紹介されている例では、クラスブラウザでクラスを眺めつつ、Tools Cloneでクラスブラウザを複製し、主になるクラスブラウザとEdit > Link fromでリンクし、サブの方は同期したスロット定義を眺める、という使い方が紹介されています。

リスナーとの連携は、リスナー上の*変数を仲介した連携が主で、インスペクタとリンクすることにより、リスナーの*変数が更新される度にインスペクタのオブジェクトも更新される、ということが可能です。

ちなみに、エディタともリンク可能ですが、バッファオブジェクトが共有されるため、いまいち使いどころが難しくなっています。もしかしたら、バッファオブジェクト経由でのエディタの一括編集の実行等で活躍できたりするのかもしれません。

統合された定義の取消し機能

def系の構文の上でM-x Undefineコマンドを実行することにより、定義を取り消すことが可能です。
特に便利なのは、defmethodの場合ですが,定義のメソッドだけ削除してくれるところが便利でしょう。
このためLispWorks上では、総称関数をfmakunboundして一式を再定義するようなことは皆無です。

また、定義系の構文がIDEと統合されていて拡張可能なため、任意の定義構文用のUndefine操作をユーザーが設定可能です。

エディタ

エディタはこのブログでも何度か紹介していますが、元は、Spice LispのHemlockというEmacsのCommon Lisp実装です。
この記事もLispWorksのHemlockで書いていますが、Emacsとしてもそこそこ普通に使えます。
ユーザー定義のコマンド等は、当然ながらCommon Lispで拡張を書きますが、LispWorksの機能をフルに活用できるのがメリットでしょうか。

まとめ

ざっと、普段使っていて便利なLispWorks IDEの機能を紹介してみました。
細かい便利機能は沢山あるので、機会があればまた紹介してみたいと思います。

■

HTML generated by 3bmd in LispWorks 7.0.0

LispWorksのKnowledgeWorksでは、オブジェクトシステムと組み込みPrologが統合されています。
Prologの複合項(構造体)に相当するものをオブジェクトや構造体で表現しますが、この知識ベースクラスのオブジェクトや構造体はワーキングメモリという場所に蓄積されます。

ワーキングメモリに蓄積されたオブジェクトは、(class名 ?obj スロット名 ?slot ...)という形式でパターンマッチで問い合わせ可能になります。

読み込んだJSONや、plistで表現したデータ、ORMでSQLで問い合わせした結果のオブジェクト等、様々な形式のデータをワーキングメモリに格納し、Prologで問い合わせするのが割合に便利なのですが、今回は、LispWorksではなくPAIPrologのようなものでも似たようなことができないか試してみたいと思います。

ウェブページのスクレイピングを組み込みPrologで

今回は、ウェブページのスクレイピングをPrologの問い合わせでやってみます。
利用する組み込みPrologは、PAIPrologですが、単一化がeqlだったり、オブジェクトを項として登録するのに結局改造しないといけなかったので、実験用にPAIPrologからフォークして別パッケージを作成してみました。

• g000001 / zrpaiprolog

(ql:quickload '(clss plump dexador zrpaiprolog))
(defpackage "d7aba921-29b4-5320-acaa-13531caa1f16"
  (:use c2cl zrlog)
  (:shadowing-import-from zrlog ignore debug symbol))
(cl:in-package "d7aba921-29b4-5320-acaa-13531caa1f16")

Prologの項を登録する

今回、DOMオブジェクトにはplumpを利用します。
plump:elementが基本となるオブジェクトなので、plump:elementという名前とオブジェクトを項として登録するadd-object-clauseというものを定義し、オブジェクト生成時のフックに登録します。

(defmethod initialize-instance :after ((obj plump:element) &rest initargs)
  (add-object-clause 'plump:element obj))

add-object-clauseは、PAIPrologのadd-clauseを少し改造しただけのものです。
項が増えるとシンボルにぶら下がる情報が多くなり過ぎる気がしますが、とりあえず実験なのでこれでよしとします。

(defun add-object-clause (name obj &key asserta)
  (let ((pred name))
    (assert (and (symbolp pred) (not (variable-p pred))))
    (pushnew pred *db-predicates*)
    (pushnew pred *uncompiled*)
    (setf (get pred 'clauses)
      (if asserta
          (nconc (list (list (list name obj))) (get-clauses pred))
          (nconc (get-clauses pred) (list (list (list name obj))))))
    pred))

これで、ウェブページを取得し、plump:parseした時点でPrologの項が登録されます。

(plump:parse (dex:get "https://www.shop-shimamura.com/disp/itemlist/001002001/"))
→ #<plump-dom:root 4250272873>

CSS Selectorでの問い合わせ的にするために、問い合わせのユーティリティとして、ノードの"class"属性を根の方向に探索するclass-namedというのを定義してみます。
なお、子→親の方向で検索するのは、要素を項としている都合上です。

(defun class-named (class node)
  (typecase node
    (plump:root NIL)
    (T (cond ((plump:attribute node "class")
              (and (equal class (plump:attribute node "class"))
                   node))
             (T (and (class-named class (plump:parent node))
                     node))))))

これでこんな風に書けます。

(prolog
  (plump::element ?elt)
  (is ?tag (plump:tag-name ?elt))
  (= ?tag "img")
  (is ?ans (class-named "card__thumb" ?elt))
  (is T (not (null ?ans)))
  (lisp (format T
                "~A: ~A~%" 
                (plump:attribute ?ans "alt")
                (plump:attribute ?ans "src"))))
▻ メンズ　ワッフルトレーナー（SEASON REASON）: https://img.shop-shimamura.com/items/images/01/0120800000660/01_0120800000660_111_l.jpg
▻ メンズ　ワッフルトレーナー（SEASON REASON）: https://img.shop-shimamura.com/items/images/01/0120800000660/01_0120800000660_113_l.jpg
▻ メンズ　ワッフルトレーナー（SEASON REASON）: https://img.shop-shimamura.com/items/images/01/0120800000660/01_0120800000660_215_l.jpg
▻ メンズ　トレーナー（SEASON REASON）: https://img.shop-shimamura.com/items/images/01/0120800000659/01_0120800000659_111_l.jpg
▻ メンズ　トレーナー（SEASON REASON）: https://img.shop-shimamura.com/items/images/01/0120800000659/01_0120800000659_113_l.jpg
▻ メンズ　トレーナー（SEASON REASON）: https://img.shop-shimamura.com/items/images/01/0120800000659/01_0120800000659_214_l.jpg
▻ メンズ　トレーナー（SEASON REASON）: https://img.shop-shimamura.com/items/images/01/0120800000659/01_0120800000659_305_l.jpg
▻ メンズ　プルパーカ（SEASON REASON）: https://img.shop-shimamura.com/items/images/01/0120800000657/01_0120800000657_312_l.jpg
▻ メンズ　プルパーカ（SEASON REASON）: https://img.shop-shimamura.com/items/images/01/0120800000657/01_0120800000657_305_l.jpg
▻ メンズ　プルパーカ（SEASON REASON）: https://img.shop-shimamura.com/items/images/01/0120800000657/01_0120800000657_307_l.jpg
▻ メンズ裏毛プルパーカ（呪術廻戦）: https://img.shop-shimamura.com/items/images/01/0128200004027/01_0128200004027_213_l.jpg
▻ メンズ裏毛プルパーカ（呪術廻戦）: https://img.shop-shimamura.com/items/images/01/0128200004026/01_0128200004026_212_l.jpg
▻ キャラクタートレーナー(呪術廻戦): https://img.shop-shimamura.com/items/images/01/0123200005469/01_0123200005469_212_l.jpg
▻ キャラクタートレーナー(呪術廻戦): https://img.shop-shimamura.com/items/images/01/0123200005468/01_0123200005468_213_l.jpg
▻ キャラクタートレーナー(にゃんこ大戦争): https://img.shop-shimamura.com/items/images/01/0123200005379/01_0123200005379_213_l.jpg
▻ キャラクタートレーナー(にゃんこ大戦争): https://img.shop-shimamura.com/items/images/01/0123200005378/01_0123200005378_212_l.jpg
▻ キャラクターパーカ(にゃんこ大戦争): https://img.shop-shimamura.com/items/images/01/0123200005377/01_0123200005377_211_l.jpg
▻ メンズ裏毛トレーナー（ブラッククローバー）: https://img.shop-shimamura.com/items/images/01/0128200004042/01_0128200004042_112_l.jpg
▻ メンズ裏毛プルパーカ（ブラッククローバー）: https://img.shop-shimamura.com/items/images/01/0128200004041/01_0128200004041_211_l.jpg
▻ メンズ裏毛プルパーカ（ブラッククローバー）: https://img.shop-shimamura.com/items/images/01/0128200004040/01_0128200004040_213_l.jpg
▻ しまむらロゴパーカ: https://img.shop-shimamura.com/items/images/01/0123200005278/01_0123200005278_201_l.jpg
▻ しまむらロゴトレーナー: https://img.shop-shimamura.com/items/images/01/0123200005277/01_0123200005277_212_l.jpg
→ nil

clssでCSS Selectorで書くと

(clss:select ".card__thumb img")

一行ですが、CSS Selectorの細かい規則を覚えるのも大変ですし、組み込みPrologで一本化できると嬉しいと思いたい。

木構造オブジェクトの問い合わせ言語は様々あるのですが、これをどうにか組み込みPrologで一本化できないか今後も探っていきたいと思います。
とりあえずは、PrologでJSON等の木構造の問い合わせをどうやっているか調査した方が良いかもしれない……。

■

HTML generated by 3bmd in LispWorks 7.0.0

恒例になっているので今年も振り返りのまとめを書きます。

Lisp的進捗

昨年は自分的にMOPブームでしたが、今年はMOPでプログラミングできる知識が大体揃って来た感じで、実際のプログラムでも普通に活用できたりするようになりました。
といっても大した応用ではないのですが、普通の道具になった、位のところです。

CLOS MOPだと大別すると、

• メタクラスの定義
• メタクラスの継承関係の処理(デフォルトの挙動、メタクラスのmixin時の挙動の定義等々)
• スロット定義
• オブジェクトの(再)初期化
• スロットへのアクセス方法

位が大きなトピックで他は上記の組み合わせか、細々としたところなので、クックブック的な感じでまとめておくと便利かなと思ったりしています。

ブログ

今年書いた記事は62記事でした。
まあまあ書いた方だとは思いますが、ネタ自体はストックが100記事分位はあるので、一旦全部出し切りたいところです。

LispWorks

LispWorksを購入してから五年半経過しましたが、すっかりSLIME+SBCLの環境よりLispWorksで書く方が楽になってしまいました。
単なる慣れというところもありますが、IDEとしてはSLIME+SBCLより統合されていて便利なところが多いです。まあもちろんエディタ単体ではHemlock(LispWorksのエディタ)よりGNU Emacsの方が高機能ですが。

仕事では、LispWorksで社内アプリ(Macのデスクトップアプリ)を量産していて、直近の業務で必要なツールを作成していていつの間にか20種類位になりました。
エンジニアでない人にGitHubを使ってもらうのに、GUIで簡単なラッパーを作成したり、社内業務のオートメーションでLispWorksが使えそうなところを見付けたら即投入しています。
Unixのシェルスクリプト、Google Apps Script、等々オートメーションのツールはありますが、手早く書捨てのGUIのアプリを作成できるという点では割とLispWorksは良いと思っています。

2021年の方向性

Lisp界隈もだいぶ盛り下がってきた感じで、当ブログももう誰も読んでない感じになってきました。
盛り上げる方法は多分ないのですが、文章のアウトプットは好きな方なので、ニッチなネタを垂れ流していきたいと思います。

また、13年位Lispコミュニティを眺めていますが、いまだLispに関する知識が1980年代な人を多く目にするのが不思議です。
恐らく古い書籍の情報をソースにしたものが再生成されているのではないかと思うのですが、このような傾向をアップデートすべく、2021年はWikipedia等の化石化した情報も更新したりすることにも取り組んでみようかなと思います(がWikipediaの更新は手間がかかる)

過去のまとめ

• #:g1: 2019年振り返り
• #:g1: 2018年振り返り
• #:g1: 2017年振り返り
• #:g1: 2016年振り返り
• #:g1: 2015年振り返り
• #:g1: 2014年振り返り
• #:g1: 2013年振り返り
• #:g1: 2012年振り返り
• #:g1: 2011年を振り返る
• #:g1: 2010年を振り返る
• #:g1: 2009年を振り返る
• #:g1: 今年一年をふりかえる

■

HTML generated by 3bmd in LispWorks 7.0.0

いつものようにCommon Lisp情報を求めてインターネットを徘徊していたのですが、ECLのマニュアルににCRSというのがあるのが気になって調べてみました。

• What is ECL

  ECL is based on a Common Runtime Support (CRS) which provides basic facilities for memory management, dynamic loading and dumping of binary images, support for multiple threads of execution.

CRS(Common Runtime Support)

ECLのマニュアルの説明では、CRSは、メモリ管理やスレッド等の実行時に必要なものがモジュール化されたものという感じですが、CRSはECLとも独立した存在のようで、CRSについて別途論文も書かれていました。

• Multilanguage Interoperability(1991)

こちらの論文を読むと、CRSとはCを中間言語として、実行時に必要な言語機能をモジュール化したり、データ形式を統一したものだったようで、CRSを基盤にCや、Lisp、Prologの環境が構築可能で、それぞれの言語が双方向に呼び出し可能な仕組みだったようです。

;;; Prolog機能を使ったCommon Lispのコード例
(defun reverse (x y) 
  (trail-mark)
  (or (and (get-nil x) ;reverse([],[]). 
           (get-nil y)
           (success))
      (trail-restore)
      (let (x1 x2 (y2 (make-variable)))
        (and 
         (get-cons x)
         (unify-variable x1)
         (unify-variable x2)
         (goals
          (reverse x2 y2) ; :- reverse(X2,Y2), 
          (concat y2 (list x1) y)))))
  (trail-unmark))

この論文の後ろの方に出てくるCommon Lispの処理系はECLではなく、Delphi Common Lisp(DCL)というECLの作者であるAttardi先生が1985年に起業したイタリアのベンチャーが販売していた商用処理系なのですが、古いECLのソースを確認すると、ECLは元々はこのDCLのCLOS部やCRS部分がECoLispとしてGPLライセンスで公開されたもののようです。

• ECoLisp: Compiles Lisp into C(1994)

ECoLisp(Embeddable Common Lispの略)の略でECLとしていたものが、いつのまにかEmbeddable Common Lispの略でECLになったらしいのですが、別にECoLispのままでも良かったような……。

• The Embeddable Common Lisp, ACM Lisp

This is ECoLisp (ECL), an Embeddable Common Lisp implementation
Copyright (c) 1990, 1991, 1993 Giuseppe Attardi
Authors:
  KCL:             Taiichi Yuasa and Masami Hagiya
  Dynamic loader:   William F. Schelter
  Conservative GC:  William F. Schelter
  Top-level, trace, stepper:  Giuseppe Attardi
  Compiler:        Giuseppe Attardi
  CLOS:             Giuseppe Attardi with excepts from PCL by Gregor Kiczales
  Multithread:     Giuseppe Attardi, Stefano Diomedi, Tito Flagella
  Unification:     Giuseppe Attardi, Mauro Gaspari

なお、現状資料が見当たらないので推測に過ぎませんが、KCLにマルチスレッドやCLOS、X11のGUIを付けて商用化されたものがDCLで、ECLは、それをCRSとAKCLをベースに構築しなおしたものなのかなと考えています。

CRSとPrologは何処へ

ECoLisp 0.12をSunOSのエミュレータでビルドして確認してみましたが、この頃までは、CRS部はまだ独立していますが、既にユニフィケーション部はほぼ残骸だけとなり、上記のLispからProlog機能を使うようなコードは書けなくなっています。

CLOS部もPortable CommonLoops(PCL)とは独立の実装で、class-prototypeの代わりに、先にmetaclassクラスを作っておくという独自方式でしたが、徐々にAMOP準拠に書き換えられた様子。
とはいえ、まだ結構な量が健在です。

まとめ

折角面白い機能であったCRSとProlog連携でしたが、どうも1990年代中盤には、ECLのコードからも削除されつつあり利用できなくなっていたようです。残念!

Poplogも共通の言語基盤を通して、Common LispとProlog、ML、Pop-11が連携しますが、あまりこういうのは流行らないのでしょうか。割合に面白いと思うのですが……。

なお、今回始めて知りましたが、Attardi先生は、元々はHewitt先生の元でアクター理論を研究していた方だったようです。
Delphi Common Lispも1980年代中後半にCLOSとX11上のGUI、マルチスレッド機能が使えたワークステーション上の処理系ということで大分時代を先取りしていたようですね。

■

HTML generated by 3bmd in LispWorks 7.0.0

Lispの調べ物をしてインターネットを彷徨っていたところ、井田昌之先生が公開されている歴史的資料のページに辿り着きました。

• 井田昌之 公式ページ Dr. Masayuki IDA official portfolio

なんとCommon Lisp系を中心として歴史的な資料が満載ではないですか。
下記にLisp系の資料を抜粋したリンクを適当なコメントと共に並べてみます。

1973

1970年代は、Lisp 1.5 との出会いから、Intel 8080上で動くLispマシンである、ALPS/Iの開発を中心に研究されていたようです。
所謂マイコンといわれていたCPU上でLispを動かす研究としてはかなり初期の取り組みではないでしょうか。

• 197312Lisp1.5ProgrammersManual8thprinting

1976

• 197606カリキュレーションBit資料
• 197611IPSJ大会363
• 197611IPSJ大会364

1977

• 197709箱入り娘パズルの解法IPSJ全国大会
• 197710ALPS1機能IPSJ全国大会
• 197710IPSJ大会214
• 197710SYM02-1

1978

• 197808IPSJ大会2B8
• 197811Lispマシン製作奮戦記Bit

1979

• 197903LispマシンALPS1
• 197903SYM07-1
• 197903コンパクトな処理系が可能な連想情報モデル
• 197903連想情報モデル経営工学会誌
• 197911AdaptableLispMachineIEEECS
• 197911IEEECSConfAnAdaptableLispMachine

1981

1980年代前半は、ALPS/Iの開発と並行して当時擡頭してきたAIマシン(Lispマシン)も研究されていたようです。

• 198109LMICADRmachine

1984

• 198403SYM27-2
• 198408LMILambdaTechSummary
• 198409Lisp05コンパイラの設計
• 198410人工知能新聞記事
• 198412ALPS3の構想

1985

1984年にCommon Lispが登場しますが、それまでのマイコンLispの研究をバックグラウンドに、Common Lispのサブセットを検討されたり、Common Lispのオブジェクトシステムについて研究をされていたようです。

• 198506CommonLispいくつかの話題
• 198507HowtoObtainPCL
• 198508PICON日本語概要LMI
• 198509Lispコンテスト記号処理研究会
• 198509PersonalLispSystemComputersandIEFlorida
• 198511SYM34-4
• 198512InterpretationofCommonLoops
• 198512OOFacilitiesPrinciplesJSSSAnnualConf

1986

• 198601CommonLispパネル
• 198603CLOS原案WOOC86
• 198603PICONLMIOverview
• 198603SYM36-7
• 198604ISOTC97SC22N197NWIproposal
• 198605CommonLisp仕様の現在の論点とその方向
• 198608CommonLispCoreSummary
• 198608日仏ラウンドテーブル協力依頼
• 198609DiscriminatingEvalAnnualConfJSSST
• 198611SYM39-6
• 198611対談高度情報化社会
• 198612AAAI86会議報告
• 198612ICLispRelease
• 198612ISOTC97SC22N276AGRecommendations
• 198612日経オブジェクト指向ハード開発

1987

1986年あたりから電子メールを基盤とした議論について等も研究されている様子、また、ISO版Lispについての議論が盛り上がりつつあったことが判ります。

• 198701JISLisp現状認識と私見
• 198701LispandFP会議報告2
• 198702JeidaLisp技術動向調査計画
• 198703ANSIX3J13CommonLispアラカルト
• 198707CommonLoopsソフトウェア科学会
• 198708電子メール討論
• 198711JohnTeeter対談Bit
• 1987SymbolicsS-SystemLeaflet
• 1987SymbolicsS-SystemLeaflet2
• 1987SymbolicsS-Systemリーフレット

1988

ANSI CLに取り込まれる予定のCLOSがかなりまとまった頃で、CLOS的にはかなり熱い時期だったようです。

• 198801CommonLisp文字オブジェクト
• 198801SYM44-2
• 198803AMEXオーソライザーズアシスタント概要
• 198803ARTOverview
• 198808Jeida視察団報告
• 198808MacIvoryReaflet
• 198808MacIvoryRelease
• 198810CLOSワークショップ予稿集
• 198810SymbolicsIVORYArchitecture
• 198810チャートテスト教材原図Lisp
• 198810チャート型性格診断Lispプログラム

1989

• 198901CLOS仕様書共立出版採択分
• 198901CLOS概説
• 198906Lisp3rdED表紙サイン入り
• 198911SYM53-2

1990

ネットワーク透過なウィンドウツールキットであるYYonXの研究、ヨーロッパで擡頭してきた米国Common Lispへの対抗馬であるEuLisp等が熱い時期だったようです。
ワークステーション文化も花盛りという感もあり、キャンパスネットワーク等の研究もされていたようです。

• 199003Europal90-An-Overview-of-YY-and-YYonX
• 199003Europal招待講演
• 199003IPSJ全国大会YYoX
• 199003YYandYYoXEuropal
• 199004InterAI手探りの国際化
• 199008EULispDefinition
• 1990YY電子図書館孫悟空事例

1991

• 199101SYM58-2
• 199101YYカラーグラフィック機構
• 199102TR90004AnOverviewofYYandYYonX
• 199102YYandYYonX
• 199103ICEERL91PaloAlto
• 199103SYM59-2
• 199105青山学報情報センタ

1992

• 199203SYM64-6
• 199205CommonLispとXWindow共立出版

1993

• 199311SeminarPosterCMU

1994

• 199411ICERL91Record

1995

この辺りからLisp関連の研究は一段落され、当時擡頭してきたJavaの方に研究の軸足を移された様子。
また自由ソフトウェア運動の紹介等もされていたようです。

Emacsでは、レキシカルスコープは遅いのでダイナミックスコープを採用した、というのが通説ですが、この下記のインタビューではレキシカルスコープは速度と名前の競合回避には良いが、実装が簡単なのでダイナミックスコープを採用したとありますね。
レキシカルスコープは遅い説はどこが出所だったかな(History of T)だったような。

• 199505GNUEmacsLispRMS
• 199505RMSGNUEmacsLisp講演記事Bit
• 199512SchemePastPresentandFuture

1996

• 199604Scheme過去現在未来1
• 199605Scheme過去現在未来2
• 199606Emacs解剖学1
• 199607Emacs解剖学2
• 199608Emacs解剖学3
• 199609Emacs解剖学4
• 199610Emacs解剖学5
• 199611Emacs解剖学6
• 199612Emacs解剖学7

1997

• 199701Emacs解剖学8
• 199702Emacs解剖学9
• 199703Emacs解剖学完

2001

• 200102JavaOne98報告記草稿Webサイト
• 200109ANSIX3J13標準作成合意過程

2002

• 200201ANSIX3J13標準作成合意過程2

まとめ

まだまだ資料を全部は読み込めていないのですが、1980年代後半のCLOS系の資料や、Lispの国際規格化での各国の思惑等が伺える資料はかなり貴重だと思います。

■

HTML generated by 3bmd in LispWorks 7.0.0

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

アドベントカレンダーも参加者が少ないと最後に総括エントリーという必殺技を使ってエントリーを埋めることができます。

オブジェクトのアロケーションなら原理は簡単なので、ニッチすぎるアドベントカレンダーでも参加者もそこそこいたりするかなと思いましたが、結局一人で完走ということになりました。

なんとなくですが、最後まで何故allocate-instanceに着目したのかが判らない、という感じだったかもしれません。

私としては、アドベントカレンダー開幕で書いたとおり、スロットストレージにベクタ以外が使うというアイデアがあまり活用されていないところに着目したわけですが、活用されないだけあったアイデアであることを証明してしまったのかもしれません。

また、Common Lispではアロケートより後のプロトコルでできることが強力で、オブジェクトのIDとクラス情報だけあれば後はどうとでもできるのがallocate-instanceをいじる意義を低下させている気がします。

実際の活用例でいうと、オブジェクトの永続化あたりでallocate-instanceの話も少し出てきたりもしますが、allocate-instanceは基本的にオブジェクトIDの割り付け程度かなと思います。

やりのこしたこと

振り返ってみると、allocate-instanceのinitargsを活用する例を追求しなかったのが若干悔まれます。
といっても、allocate-instanceにストレージの種類を伝える程度な気はしますが。

あとはハッシュテーブルのストレージがベクタであることを利用して、先頭をオブジェクトのストレージにして、残りをハッシュテーブルにするというのを考えましたが、別に一本にする必要もないかなというところです。

他にも、どうしようもないアイデアはありますが、そのうち試してブログに書いてみたいと思います。

さて、次にアドベントカレンダーを企画した際にはさらにニッチなところを攻めたいと思います。
次回までごきげんよう!

■

HTML generated by 3bmd in LispWorks 7.0.0

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

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

今回は、Tiny CLOSのallocate-instance周りを眺めます。
Tiny CLOSは、CLOS風のオブジェクトシステムを採用しているSchemeではTiny CLOSかその派生が採用されていることが多いようです。
作者が、CLOSおよびに参照実装であったPortable CommonLoopsに深く関わり、AMOPの著者でもあるKiczales先生というのもポイントが高いかもしれません。

大体の構成は、先日紹介したKiczales先生が1990年代前半に考えていた新しいInstance Structure Protocolの構成と同一のようです。

• Tiny CLOS MOPが本家CLOS MOPの進化版だった件

Object Creation and Initialization

• allocate-instance
• make
• initialize

Tiny CLOSでのインスタンスの構成ですが、instance-tag、classという先頭二つの部分と後半のスロット要素からなるベクタ表現されています。ベクタにしたかったというより、1992年のSchemeに構造体がないので、こういう構成にしたのかもしれません。
CLOSの実装でいうwrapper部は、そのままクラスメタオブジェクトの表現です。

ベクタ一本の表現なので、スロット部のベクタだけ取り出すようなことはなく、基本的に先頭2つのオフセットでアクセスする感じになります。

なお、Tiny CLOSはScheme(Common Lisp版もある)の実装なので、allocate-instanceの中身をいじれますが、OOPSが融合している処理系ではC等の実装言語レベルに直結していることが多いようで、安直に下請け関数がアロケートするスロットストレージをベクタからハッシュにすげかえてみる、等のことはやりにくいようです。
なお、Common LispでもECL等がそういう実装になっています。

Instance Structure Protocol

• slot-ref
• slot-set!
• lookup-slot-info
• compute-getter-and-setter

スロットストレージの並び順は、CLと同様compute-slotsで確定するようです。
スロットの名前と位置の変換は、compute-getter-and-setterでゲッターとセッターのクロージャー生成する際にクロージャーの中に位置が埋め込まれる方式です。
slot-ref内で、lookup-slot-infoによりこのgetters-n-setters情報からゲッター/セッターを取り出してオブジェクトに適用、という流れになっています。

まとめ

Tiny CLOSは、スロット名とスロット位置変換の仕組みとして、位置情報を含んだゲッター/セッターをクラスメタオブジェクト内にまとめて管理、という方式のようです。
CLOS系OOPSそれぞれ微妙に違いますが、位置情報をクロージャーに閉じ込める方式の方が若干速いかなとは思います。
アクセサを定義すれば、標準のケースでは最適化された場合、スロットストレージへの直接アクセスになると思うので、Common Lispでは速度にこだわるなら、slot-valueは使うなというところなのでしょうか。この辺りどこかでそんな文献読んだことがある気がするのですが思い出せない……。

■

HTML generated by 3bmd in LispWorks 7.0.0

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

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

今回は、TELOSのallocate-instance周りを眺めます。
TELOSは、EuLispのオブジェクトシステムで、EuLispもCommon Lispより簡潔な作りを指向しています。
EuLispとCommon Lispとの目立った違いは、EuLispがLisp1であることで、クラスの表記も他のシンボルと競合しないように、<foo>のように表記する慣習があります。

ちなみに、ISLISPは、EuLispの影響下にあるので、Lisp2なのに<foo>と表記します。

• 過去記事: #:g1: Telos in Common Lispの紹介

Object Creation and Initialization

• allocate
• make
• initialize

まず、インスタンスの構成ですが、class、slotsという二つの部分からなるprimitive-class構造体で表現されています。CLOSの実装でいうとwrapper部は、そのままクラスメタオブジェクトで表現されています。

インスタンスのストレージは標準でベクタ。 スロットストレージへは、primitive-class-slots、wrapperの取り出しは、primitive-class-ofで行えますが、クラスそのものなので別に必要ないかも?
CLOS MOPと異なる点としては、クラスがスロット数を保持するclass-instance-lengthを有します。

Instance Structure Protocol

• slot-value
• (setf slot-value)
• primitive-slot-value
• (setf primitive-slot-value)
• slot-value-using-slot
• find-slot
• slot-reader
• slot-writer
• compute-slots
• primitive-ref
• setter-primitive-ref
• primitive-find-slot-position

スロットストレージの並び順は、CLと同様compute-slotsで確定するようです。 CLOSのslot-definitionに相当する<slot>クラスがあり、class-slotsに格納されていますが、スロットの位置を計算するには、primitive-find-slot-positionを使います。
特に最適化はされておらず、class-slotsの中を順に探しているだけです。

(primitive-find-slot-position <simple-class> 'c (class-slots <foo>) 0)
→ 2

CLのstandard-instance-accessに相当するものは、primitive-refになります。 slot-valueの中で、標準のメタクラスかどうかを判定するようになっており、標準であれば、slot-value-using-slotが、スロットのslot-reader/writerを呼び出しを値を取り出します。
slot-readerは最終的にはprimitive-refを呼びます。

slot-valueは

(slot-value-using-slot (find-slot (class-of obj) name)
                       obj)

と展開されるので、何もしなければ、find-slotが探索してスロット名→スロット位置の変換をするので遅いですが総称関数なので(find-slot obj 'a)等を特定化して定義してやれば高速化はできそうです。

まとめ

CLOS系OOPSでスロット名からスロットの位置を割り出す方法にそれぞれ色々と工夫があるようです。
アクセサに比べてslot-valueの方がプリミティブな雰囲気があり、速度もアクセサより速そうな印象がありますが、MOPの仕組みからして、スロットの位置割り出しが計算済みの分アクセサの方が速いですね。

■

HTML generated by 3bmd in LispWorks 7.0.0

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

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

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

• 過去記事: #:g1: mcsの紹介

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

Object Creation and Initialization

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

さてまず、インスタンスの構成ですが、isit、slotsという二つの部分からなる構造体で表現されています。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 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

• CLOS MOP: Class finalization protocol

• class-finalized-p

• finalize-inheritance

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

• CLOS MOP: allocate-instance

この判定のタイミングですが、Robert Strandh先生によれば、allocate-instanceの引数のinitargsは確定後の計算結果になるので呼ばれる前に確定している筈としていてPCLでも、make-instanceがfinalize-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

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

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

• STklos: 8.2.1.4 Virtual Slots
• LispWorks User Guide and Reference Manual > 18.4 Implementation of virtual slots

大抵は、スロットの: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 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

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

以前、初期MOPの文献で、隠しスロットの実例としてスロットにfacetをつけるというのを紹介しましたが、こちらの例では隠しスロットは、本スロットと交代の並びで追加されるので、本スロットの位置×2で位置を求めたりしていました。

• MOPで隠しスロットの実現

しかし、ストレージを一次元配列ではなく、多次元配列にしてしまえば、値のインデックスはそのままで指定の次元アクセスすれば対応した場所にアクセスできて便利なのではないかと思ったので、試してみました。

(defpackage "493c1b0d-ff75-5a3a-9872-43d488f33914"
  (:use c2cl slotted-objects))

(in-package "493c1b0d-ff75-5a3a-9872-43d488f33914")

(defclass faceted-slot-class (slotted-class) 
  ())

(defclass faceted-slot-object (slotted-object) 
  ()
  (:metaclass faceted-slot-class))

(defconstant slot-dim 0)

(defconstant facet-dim 1)

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

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

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

(defun facet-missing (instance facet-name)
  (error "The facet ~S is missing from the object ~S" facet-name instance))

(defun slot-facet (instance slot-name)
  (aref (instance-slots instance) 
        facet-dim
        (slot-definition-location 
         (or (find slot-name (class-slots (class-of instance)) :key #'slot-definition-name)
             (facet-missing instance slot-name)))))

(defun (setf slot-facet) (value instance slot-name)
  (setf (aref (instance-slots instance) 
              facet-dim
              (slot-definition-location 
               (or (find slot-name (class-slots (class-of instance)) :key #'slot-definition-name)
                   (facet-missing instance slot-name))))
        value))

動作

(defclass zot (faceted-slot-object)
  ((a :initform 42)
   (b :initform 43)
   (c :initform 44))
  (:metaclass faceted-slot-class))
(describe (make-instance 'zot))
⇒
#<zot 41601B9CD3> is a zot
a      42
b      43
c      44
;;; facetに値を設定
(let ((o (make-instance 'zot)))
  (setf (slot-facet o 'a) 'facet-a)
  (setf (slot-facet o 'b) 'facet-b)
  (setf (slot-facet o 'c) 'facet-c)
  (mapcar (lambda (s)
            (list (slot-value o s)
                  (slot-facet o s)))
          '(a b c)))
→ ((42 facet-a) (43 facet-b) (44 facet-c)) 

まとめ

やはりスロットに一対一で対応するような隠しスロットには一本のベクタで配置を工夫するよりは、多次元配列の方が安直に実装できます。
スロットにフラグを持たせる場所としては便利そうですが、さて実用的にはどうなのか……。

■

HTML generated by 3bmd in LispWorks 7.0.0

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

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

• インスタンスに隠しスロットのような付加情報を持たせたいが、付加情報は外のAPIからは見えて欲しくない
• アロケートする場所を工夫したい(空間効率etc)
• (外部API的には)余計なスロットを追加しないでインスタンス群を組織化したい

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

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)))