九年ほど前からSchemeのSRFIをCommon Lispに移植する遊びをしていますが、久々にコピペ移植してみました。
前回SRFI 118を移植したのは、2005-01-02のようなので、実に五年ぶり。

• SRFI-118の紹介 & Common Lispへ移植

今回移植したのは、SRFI 175: ASCII character libraryで、ASCIIを扱うライブラリのようで、現時点でファイナルになっているものでは一番番号が大きいものです。

• SRFI 175: ASCII character library
• g000001 / SRFI 175 for CL: ASCII character library

導入

Ultralispに登録してみたので、

(ql-dist:install-dist "http://dist.ultralisp.org/")

してあれば、

(ql:quickload :srfi-175)

でインストール可能です。

動作

ASCIIに関して操作したいことは大体網羅されているので、必要な時には便利に使えるのではないでしょうか。

(ascii-downcase #\G)
→ #\g 
(ascii-alphabetic? #\1)
→ nil 
(remove-if #'ascii-whitespace? "foo bar baz")
→ "foobarbaz" 

まとめ

SRFIの移植については、Scheme→Common Lispなコンパチレイヤーがあると楽なのでボチボチ作ってみたりしていますが、このあたりも作り込むとコピペが捗りそうです。

• g000001 / RnRS Compatibility Package for Common Lisp

このrnrs-compatでは関数とマクロで変換していますが、トランスレータでの一括変換も試してみたいところ。

■

HTML generated by 3bmd in LispWorks 7.0.0

今年は移植したSRFIでもQuicklispに登録してみようかなと思って、Quicklispに三つ四つ登録してみましたが、「登録するは良いけどユーザーいるの?(大意)」という質問がありました。
SRFIのCommon Lispへの移植は90近くあるのですが、いうまでもなくどれも誰得なものなので、まあそうだよなーなど思ったりしていましたが、こういう誰得なものにはUltralispが合っていると思うと教えてもらったので、Ultralispに登録してみることにしました。

• Ultralisp

Ultralispは、Quicklispの仕組みを利用していて、“dist”の一つという位置付けです。

(ql-dist:install-dist "http://dist.ultralisp.org/" :prompt nil)

で利用できるようになりますが、登録後には“dist”が増えていることが確認できます。

(ql-dist:all-dists)
→ (#<ql-dist:dist quicklisp 2019-12-27> #<ql-dist:dist ultralisp 20200126195012>)

Ultralispの売りは、“dist”を五分毎に更新するので、登録から利用までが非常に早いのと、GitHubのリポジトリを管理画面からポチポチ登録すれば、登録は完了という手軽さのようです。

ちなみに別段Quicklisp本家が俺んちルールでやっているということではなく、各distには管理者がいて、Quicklispのデフォルトの“quicklisp” distにも管理者のポリシーがある、ということで適宜棲み分けするのが宜しかろうというところでしょうか。

暗黙のポリシーも含めてリストにするとこんな感じでしょうか。

現状、Common Lisp界はSBCL一強になりつつありますが、SBCLでビルドできなければ、“quicklisp” distには載らないんだよなーというのは、まあまあ耳にする話だったので、そういう点も“ultralisp”と“quicklisp”の棲み分けの基準になるかもしれません。

また、Ultralispの登録の手軽さを活かして、とりあえずUltralispに登録して暫く運用し、手応えがあったらQuicklispに申請するというのも良さそうです。

Ultralisp使用感とまとめ

特に“quicklisp” distと変わらないですが、手軽に早く登録できるので、複数環境で自作ライブラリを利用するのはかなり手軽になります。
その代わりといってはなんですが、登録レポジトリのコードを壊しちゃたりした場合でも、素早くそのまま流れていくので注意が必要かなと思います。
(素早く修正すれば良いとはいえ)

こんなUltralispなので登録ライブラリはQuicklispのデフォルトより多いんだろうと思いきや現在1253ということでquicklispの約1800より少ないようです。
“quicklisp” distから“ultralisp” distへの取り込みも進んでいるようなのでそのうち包含するのかもしれません。

ちなみにそもそものきっかけになったSRFIのCommon Lisp移植版ですが、ボチボチUltralispに登録しています。
srfi-2やsrfi-19等便利なものも案外あるので折角なのでUltralisp経由で活用していきたいと思います。

■

HTML generated by 3bmd in LispWorks 7.1.2

毎年振り返りのまとめを書いているので、今回も書きます。

Lisp的進捗

今年は何故か自分の中ではMOPブームが到来し、後半は特にMOP的な拡張をして遊んでいました。
ECLOSを始めとして、1990年代にはMOPの拡張が色々と試行錯誤されていたようなので、これを暫く追試して行こうかなと思います。
どうもMOPは学習の取っ掛かりがないという印象があり、どう学んでいったら良いのか良く分からない状況が自分も長く続きましたが、結局のところ沢山書けば色々憶えてくるようです。
とりあえず役に立つ応用を考えたりするのは後回しで量を書いていれば段々見通しが付いてくるように思えました。
思えばマクロもナンセンスなものを沢山書いていましたし、自分はとりあえず量を書かないことには身に付かない質かもしれません。
Common LispのMOPも中途半端だったり発展途中(で四半世紀進歩がない)だったりするので、その辺りの状況もまとめてみたいと考えています。

ブログ

今年書いた記事は38記事でした。
年々記事の量が減っていますが、ネタがない訳ではなく記事にするのが面倒というところです。
世間的にもLispの記事を目にすることは大分少なくなりました。大分ブログというツールも廃れた感がありますが、2020年はもうちょっと書いていきたいと思います。

LispWorks

LispWorksを購入してから早四年半。
それまでSBCL+SLIMEをメインに使っていましたが、購入を機にLispWorksのIDEメインとしました。 しかし、いまだにSLIMEで便利だった機能を越えられていないところがあります。
LispWorksの方が便利なところも多いのですが、2020年は両者の良いとこ取りな環境を構築していきたいところです。

LispWorksでの職場の社内ツール作りもあいかわらず継続していて、利用者もアプリの種類も増えました。
折角なのでLispWorksのCommmon SQLやKnowledgeWorksの機能も使ってみていますが、デザインは古いもののそこそこ便利に使えています。
DBや推論機能はメタクラスが定義されており、これらをmixinして連携させるのが楽しいといえば楽しいです。

ウェブ屋さんが沢山在籍する職場では何かGUIのツールを作成するとなれば、ウェブアプリになると思いますが、そうでなければ、LispWorksみたいなアプリ作成機能もそこそこ有用かなと思います。
特に社内でしか使わないとなれば、ウェブアプリのメンテもそこそこ面倒なので。

2020年やってみたいこと

2019年の計画では、コンディションシステムアドベントカレンダーを開催したいと思っていましたが、ちょっと試しにQiitaを退会してみたら、記事がごっそり消えてしまったので、アドベントカレンダーを開催するのがめんどうになってしまい2019年はスキップしてしまいました。
コンディションシステムやMOPは今後も深追いしていきたい所存です。

また、1980年代のエキスパートシステムブームとLispについて大体見通しが付いてきたので、2020年は、第二次AIブームでのLispの活躍とは何だったのか等々まとめてみたいと考えています。

過去のまとめ

• #: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

コメントをS式で書く方式のcommentは、古くはMACLISPに、最近だとClojureにありますが、中身を無視してnil(MACLISPだと'comment)を返すシンプルなフォームです。

(comment 0 1 2)
→ nil

commentの中身もS式として成立していないといけないのですが、動いているコードをコメントアウトする分には大抵問題になることはないでしょう。

Common Lispで書くとするとこんな感じになります。

(defmacro comment (&body body)
  (declare (ignore body))
  nil)

S式コメントには一つ問題があり、nil等の値を残してしまうので、commentを残す場所には配慮する必要があります。

(vector (list 42))
→ #((42)) 
(vector (comment (list 42)))
→ #(nil) 

ここで一捻りして、nilではなく(values)を置いてみるとどうでしょうか。

(defmacro comment (&body body)
  (declare (ignore body))
  '(values))

(values)は0個の返り値を返しますが、Common Lispの場合は値が評価される場所ではnilとなります。
つまり、nilと書いた場合と大差ないのですが、

(vector (comment (list 42)))
→ #(nil) 

#.を付けると、痕跡を消すことができます。

(vector #.(comment (list 42)))
→ #() 

リーダーマクロの書法の一つとして、値を出力したくない場合は、(values)を使うというのがあるのですが、これを利用した格好です。

まとめ

#.(comment ...)だとちょっと長いので、普段は、(comment ...)で書き、必要になったら#.を足す、という使い方をすれば、そこそこ便利に使えるかもしれません。

■

HTML generated by 3bmd in LispWorks 7.0.0

構造体の配列を作成する方法として、

• 構造体を配列に配置する(AoS: Array of Structures)
• 配列の構造体を作る(SoA: Structure of Arrays)

があるようですが、SoAの方が効率が良いらしいです。

• The SoA Vector – Part 1: Optimizing the Traversal of a Collection

Common Lispでいうと、インスタンスの配列を作成するか、インスタンスのスロットを配列にするかになりますが、MOP細工でインスタンスのスロットは配列にはせずに通常のままでSoAな構成にしてみよう、というのが今回の趣旨です。

• クラスメタオブジェクトにインスタンスのスロットを配列として保持し、
• allocate-instanceでスロットの配列に配置。
• インデックスはインスタンスのデータ部が空き地なのでここに格納

といった風に構成してみました。
LispWorks依存ですが、standard-objectの構造はメジャーどころは大体一緒なので移植は簡単だと思います。

動作

(defclass 🐱 (soa-object)
  ((a :initform 0 :type bit :initarg :a)
   (b :initform #\. :type character :initarg :b)
   (c :initform nil :type boolean :initarg :c))
  (:metaclass soa-class)
  (:pool-size 0))
(instance# (class-prototype (find-class '🐱)))
→ 0 
(class-slot-vectors (find-class '🐱))
→ ((a . #*) (b . "") (c . #())) 
(set '🐱 (make-instance '🐱 :a 0 :b #\- :c T))
→ #<🐱 40201E2BFB> 
(mapcar (lambda (s)
          (cons (car s)
                (elt (cdr s) (instance# 🐱))))
        (class-slot-vectors (find-class '🐱)))
→ ((a . 0) (b . #\-) (c . t)) 

(dotimes (i 100)
  (make-instance '🐱 :a 1 :b #\. :c nil))
→ nil 
(class-slot-vectors (find-class '🐱))
→ ((a . #*001111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111)
    (b . "-....................................................................................................")
    (c
     . #(nil t nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
         nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
         nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
         nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil))) 
(with-slots (a b c)
            (make-instance '🐱 :a 1 :b #\. :c nil)
  (list a b c))
→ (1 #\. nil) 

実装

堅牢性に難ありですが、概念実証くらいにはなるかなというところです。

(defpackage "e477e14c-8275-5c00-82d3-82f8adcd1567"
  (:use :c2cl))

(in-package "e477e14c-8275-5c00-82d3-82f8adcd1567")

(defclass soa-class (standard-class)
  ((pool-size :initform 256 :accessor instance-pool-size :initarg :pool-size)
   (instance-index :initform 0 :accessor instance-index)
   (slot-vectors :initform nil :accessor class-slot-vectors)))

(defmethod validate-superclass ((c soa-class)
                                (s standard-class))
  T)

(defclass soa-object ()
  ()
  (:metaclass Soa-class))

(defun instance# (soa-object)
  (clos::%svref Soa-object 1))

(defmethod allocate-instance ((class soa-class) &rest initargs)
  (let* ((class (clos::ensure-class-finalized class)))
    (prog1
      (sys:alloc-fix-instance (clos::class-wrapper class) 
                              (instance-index class))
      (incf (instance-index class)))))

(defmethod shared-initialize ((instance soa-object) slot-names &rest initargs)
  (flet ((initialize-slot-from-initarg (class instance slotd)
           (let ((slot-initargs (slot-definition-initargs slotd))
                 (name (slot-definition-name slotd)))
             (loop :for (initarg value) :on initargs :by #'cddr
                   :do (when (member initarg slot-initargs)
                         (setf (slot-value-using-class class instance name)
                               value)
                         (return t)))))
         (initialize-slot-from-initfunction (class instance slotd)
           (let ((initfun (slot-definition-initfunction slotd))
                 (name (slot-definition-name slotd)))
             (unless (not initfun)
               (setf (slot-value-using-class class instance name)
                     (funcall initfun))))))
    (let ((class (class-of instance)))
      (dolist (slotd (class-slots class))
        (unless (initialize-slot-from-initarg class instance slotd)
          (when (or (eq t slot-names)
                    (member (slot-definition-name slotd) slot-names))
            (initialize-slot-from-initfunction class instance slotd)))))
    instance))

(defun soa-instance-access (class obj key)
  (elt (cdr (assoc key (class-slot-vectors class))) 
       (instance# obj)))

(defun (setf soa-instance-access) (val class obj key)
  (when (> (instance# obj)
           (1- (instance-pool-size class)))
    (setf (instance-pool-size class)
          (1+ (instance# obj)))
    (dolist (slot (class-slot-vectors class))
      (adjust-array (cdr slot)
                    (instance-pool-size class))))
  (setf (elt (cdr (assoc key (class-slot-vectors class))) 
             (instance# obj))
        val))

(defmethod slot-value-using-class ((c Soa-class) inst slot-name)
  (soa-instance-access c inst slot-name))

(defmethod (setf slot-value-using-class) (newvalue (c Soa-class) inst slot-name)
  (setf (soa-instance-access c inst slot-name) newvalue))

(defmethod ensure-class-using-class :after ((class soa-class) name &rest initargs &key)
  (when (consp (instance-pool-size class))
    (setf (instance-pool-size class)
          (car (instance-pool-size class))))
  (setf (class-slot-vectors class)
        (mapcar (lambda (s)
                  (cons (slot-definition-name s)
                        (make-array (instance-pool-size class)
                                    :element-type (or (slot-definition-type s) T)
                                    :adjustable T
                                    :initial-element (funcall (slot-definition-initfunction s)))))
                (class-slots class))))

まとめ

Common LispはC風に効率よく構造体を配列に詰められないのか、等々の質問はたまにみかけるのですが、今回のように高次のデータ構造的に記述して低次のデータ構造にマッピングする方法もなくはないかなとは思います。
直截的な回答としてはFFIでメモリの塊をいじる方法などになりそうですが。

■

HTML generated by 3bmd in LispWorks 7.0.0

先日書いたAllegro CLのfixed-indexスロットアクセスを真似してみるの記事では、任意の値でslot-definition-loctionを確定させる術を分かっていなかったので、中途半端なことになっていました。
compute-slots :aroundを使った確定方法が分かったのでリベンジします。

動作

(<defclass> foo ()
  ((a :initarg :a fixed-index 2 :accessor foo-a)
   (b :initarg :b fixed-index 4 :accessor foo-b)
   (c :initarg :c :accessor foo-c))
  (:metaclass fixed-index-slot-class))
(mapcar (lambda (s)
          (list (slot-definition-name s)
                (slot-definition-location s)))
        (class-slots <foo>)) 
→ ((c 0) (a 2) (b 4)) 
(let ((foo (a 'foo)))
  (setf (foo-a foo) 'a)
  (setf (foo-b foo) 'b)
  (setf (foo-c foo) 'c)
  (std-instance-slots foo))
→ #(c #<Slot Unbound Marker> a #<Slot Unbound Marker> b) 

実装について

• インデックスが指定されていないスロットは、先頭から空いている番地に差し込みます。
• slot-value-using-classがいつものごとくLispWorks依存です(AMOP準拠でない) なおかつ遅そうです。

実装

(eval-when (:compile-toplevel :load-toplevel :execute)
  (ql:quickload :closer-mop))

(defpackage "506dccfc-1d3a-5b8c-9203-948447c433b4" (:use :c2cl))

(in-package "506dccfc-1d3a-5b8c-9203-948447c433b4")

;; utils
(eval-when (:compile-toplevel :load-toplevel :execute)
  (setf (fdefinition 'a) #'make-instance)
  (defun fintern (package control-string &rest args)
    (with-standard-io-syntax
      (intern (apply #'format nil control-string args)
              (or package *package*))))
  (defmacro <defclass> (name supers slots &rest class-options)
    `(defconstant ,(fintern (symbol-package name) "<~A>" name)
       (defclass ,name ,supers ,slots ,@class-options))))

(<defclass> fixed-index-slot-class (standard-class)
  ())

(defmethod validate-superclass ((c fixed-index-slot-class) (s standard-class))
  T)

(<defclass> fixed-index-slot-definition (standard-slot-definition)
  ((fixed-index :initform nil
                :initarg fixed-index
                :accessor slot-definition-fixed-index)))

(<defclass> fixed-index-direct-slot-definition
            (fixed-index-slot-definition standard-direct-slot-definition)
  ())

(<defclass> fixed-index-effective-slot-definition
            (fixed-index-slot-definition standard-effective-slot-definition)
  ())

(defmethod direct-slot-definition-class ((c fixed-index-slot-class) &rest initargs)
  (declare (ignore initargs))
  <fixed-index-direct-slot-definition>)

(defmethod effective-slot-definition-class ((c fixed-index-slot-class) &rest initargs)
  (declare (ignore initargs))
  <fixed-index-effective-slot-definition>)

(defmethod compute-effective-slot-definition ((class fixed-index-slot-class) name direct-slot-definitions)
  (declare (ignore name))
  (let ((effective-slotd (call-next-method)))
    (dolist (slotd direct-slot-definitions)
      (when (typep slotd <fixed-index-slot-definition>)
        #-allegro (setf (slot-definition-fixed-index effective-slotd)
            (slot-definition-fixed-index slotd))
    #+allegro (setf (slot-value effective-slotd 'excl::location)
            (slot-definition-fixed-index slotd))
        (return)))
    effective-slotd))

(defmethod allocate-instance ((class fixed-index-slot-class) &rest initargs)
  (let* ((class (clos::ensure-class-finalized class))
         (slotds (class-slots class))
         (max-index (loop :for s :in slotds :maximize (slot-definition-location s))))
    (sys:alloc-fix-instance (clos::class-wrapper class)
                            (sys:alloc-g-vector$fixnum (1+ max-index)
                                                       clos::*slot-unbound*))))

(defmethod compute-slots :around ((class fixed-index-slot-class))
  (let* ((slotds (call-next-method))
         (indecies (mapcan (lambda (s)
                             (and (slot-definition-fixed-index s)
                                  (list (slot-definition-fixed-index s))))
                           slotds))
         (free-indecies (loop :for i :from 0 :to (apply #'max indecies)
                              :unless (find i indecies) :collect i)))
    (dolist (s slotds)
      (if (slot-definition-fixed-index s)
          (setf (slot-definition-location s)
                (slot-definition-fixed-index s))
          (setf (slot-definition-location s)
                (pop free-indecies))))
    (sort (copy-list slotds) #'< :key #'slot-definition-location)))
 
(defun standard-instance-boundp (instance index)
  (not (eq clos::*slot-unbound* (standard-instance-access instance index))))

(defmethod slot-value-using-class 
           ((class fixed-index-slot-class) instance slot-name)
  (let* ((slotd (find slot-name (class-slots class) 
                     :key #'slot-definition-name))
         (loc (slot-definition-location slotd)))
    (cond ((not slotd)
           (slot-missing class instance slot-name 'slot-makunbound))
          ((null (standard-instance-boundp instance loc))
           (slot-unbound class instance slot-name))
          (T 
           (standard-instance-access instance loc)))))

(defmethod (setf slot-value-using-class) 
           (val (class fixed-index-slot-class) instance slot-name)
  (let* ((slotd (find slot-name (class-slots class) 
                     :key #'slot-definition-name))
         (loc (slot-definition-location slotd)))
    (if (not slotd)
        (slot-missing class instance slot-name 'slot-makunbound)
        (setf (standard-instance-access instance loc) val))))

(declaim (inline std-instance-slots))
(defun std-instance-slots (inst)
  #+allegro (excl::std-instance-slots inst)
  #+sbcl (sb-pcl::std-instance-slots inst)
  #+lispworks (clos::standard-instance-static-slots inst))

まとめ

インスタンスのスロットをベクタ上に任意に配置したり、ハッシュテーブルにしてみたり、ということができることは分かりましたが、標準から逸れたことをすると、どうもスロットのアクセス周りを全部書かないといけないっぽいですね。

■

HTML generated by 3bmd in LispWorks 7.0.0

ここ最近、standard-instance-accessでインスタンス内部のベクタに直接アクセスするようなことを試していましたが、インデックスを求める方法があやふやでした。
compute-slotsで並んだ順で確定するのは分かっていたのですが、並び順ということは飛び飛びにはできないわけで、どうしたものかと考えていましたが、compute-slotsの説明を良く読んだら、compute-slotsのプライマリメソッドでスロット定義を並べて、compute-slotsの:aroundメソッドでslot-definition-locationの内容を確定するようなことが書いてあります。

• CLOS-MOP/compute-slots

In the final step, the location for each effective slot definition is
set. This is done by specified around-methods; portable methods cannot
take over this behavior. For more information on the slot definition
locations, see the section ``Instance Structure Protocol.''

ということでSBCLのMOP実装を確認してみましたが、やはり:aroundでlocationを設定していました。なるほど。

compute-slotsの:aroundを乗っ取るには、さらなる:aroundを定義するしかないわけですが、どうも可搬性のためにはいじってはいけない場所のようです。

とはいえ、インデックスの設定方法が分かったので、試しに今回は、X3J13-88-003R-DRAFTのコード例にあるfaceted-slot-classを動かしてみたいと思います。

faceted-slot-class

• X3J13-88-003R-DRAFT/index-in-instance

X3J13-88-003Rのドラフトにはindex-in-instanceというAPIが存在していて、スロット名からインデックスを算出する仕組みになっていたようです。

このindex-in-instanceの利用例として、0、2、4…をスロット、1、3、5…をファセットとして配置するメタクラスを定義しています。

動作は下記のようになります。

(defclass zot ()
  ((a :initform 42)
   (b :initform 43)
   (c :initform 44))
  (:metaclass faceted-slot-class))
(let ((o (make-instance 'zot)))
  (values
   (with-slots (a b c) o
     (list a b c))
   (loop :for index :from 0 :repeat (compute-instance-size (class-of o))
         :collect (standard-instance-access o index))))
→ (42 43 44) 
   (42 #<Slot Unbound Marker> 43 #<Slot Unbound Marker> 44 #<Slot Unbound Marker>) 
;;; ファセットに値を設定
(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)
  (values
   (with-slots (a b c) o
     (list a b c))
   (loop :for index :from 0 :repeat (compute-instance-size (class-of o))
         :collect (standard-instance-access o index))))
→ (42 43 44) 
   (42 facet-a 43 facet-b 44 facet-c) 

実装

ということで実装ですが、元のコードのAPIをできるだけ残したかったのですが、どうもコンセプトコードのようで実際に動かすと色々矛盾がある様子。
その辺りは適当に辻褄を合せました。
しかし、辻褄が合わないところもあり、

• compute-slotの中でindex-in-instanceを使って綺麗にカスタマイズしたいが、index-in-instanceが使うスロット情報は遡ればcompute-slotを利用するので循環が発生する

等は、index-in-instanceの内容をcompute-slotの中にベタ書きで展開することで回避しています。

以下、LispWorks依存なコードです。
LispWorks標準のslot-value-using-classは、スロットのインデックスが隙間無く並んでいることを前提としていて、疎な配置にすると動作がおかしくなるので、自前で定義しています。

(ql:quickload :closer-mop)

(defpackage "2f1cccc9-c776-5726-9e68-91d2d9042169" (:use :c2cl))

(in-package "2f1cccc9-c776-5726-9e68-91d2d9042169")

(defgeneric index-in-instance (class description))

(defmethod index-in-instance ((class cl:standard-class) description)
  (typecase description
    (symbol
     (position description (class-slots class)
               :key #'slot-definition-name))
    (T (error "Don't understand the description ~S." description))))

(defgeneric compute-instance-size (class))

(defmethod compute-instance-size ((class cl:standard-class))
  (length (class-slots class)))

(defclass faceted-slot-class (standard-class) ())

(defmethod validate-superclass ((c faceted-slot-class) (s standard-class))
  T)

(defmethod compute-instance-size ((class faceted-slot-class))
  (* 2 (call-next-method)))

(defmethod allocate-instance ((class faceted-slot-class) &rest initargs)
  (let ((class (clos::ensure-class-finalized class)))
    (sys:alloc-fix-instance (clos::class-wrapper class)
                            (sys:alloc-g-vector$fixnum (compute-instance-size class)
                                                       clos::*slot-unbound*))))

(defmethod index-in-instance ((class faceted-slot-class) description)
  (cond ((symbolp description)
         (let ((index (call-next-method)))
           (and index (* 2 index))))
        ((and (consp description)
              (eq (car description) 'facet))
         (1+ (index-in-instance class (cadr description))))
        (T
         (error "Don't understand the description ~S." description))))

(defun standard-instance-access* (instance description trap not-bound-function missing-function)
  (declare (ignore trap))
  (let* ((class (class-of instance))
         (index (index-in-instance class description)))
    (cond ((null index)
           (funcall missing-function instance description))
      ((not (numberp index))
       (slot-value index 'value))
          ((null (standard-instance-boundp instance index))
           (funcall not-bound-function instance description))
          (T
           (standard-instance-access instance index)))))

(defun (setf standard-instance-access*) (val instance description trap not-bound-function missing-function)
  (declare (ignore trap not-bound-function))
  (let* ((class (class-of instance))
         (index (index-in-instance class description)))
    (cond ((null index)
           (funcall missing-function instance description))
      ((not (numberp index))
       (slot-value index 'value))
          (T
           (setf (standard-instance-access instance index) val)))))

(defun standard-instance-boundp (instance index)
  (not (eq clos::*slot-unbound* (standard-instance-access instance index))))

(defun slot-facet (instance slot-name)
  (standard-instance-access* instance
                             (list 'facet slot-name)
                             nil
                             #'facet-unbound
                             #'facet-missing))

(defun (setf slot-facet) (new-value instance slot-name)
  (setf (standard-instance-access* instance
                                   (list 'facet slot-name)
                                   nil
                                   #'facet-unbound
                                   #'facet-missing)
        new-value))

(defun facet-unbound (instance facet)
  (error "The facet ~S is unbound in the object ~S" (cadr facet) instance))

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

(defmethod compute-slots :around ((class faceted-slot-class))
  (let ((slotds (call-next-method)))
    (dolist (s slotds)
      ;; Base case
      (setf (slot-definition-location s)
            (* 2 (position s slotds))))
    slotds))
(defmethod slot-value-using-class ((class faceted-slot-class) instance slot-name)
  (let ((index (index-in-instance class slot-name)))
    (cond ((null index)
           (slot-missing class instance slot-name 'slot-makunbound))
      ((not (numberp index))
       (slot-value index 'value))
          ((null (standard-instance-boundp instance index))
           (slot-unbound class instance slot-name))
          (T 
           (standard-instance-access instance index)))))

まとめ

index-in-instanceは、class-slotsとslot-definition-nameとslot-definition-locationの組み合わせとも大差ないともいえますが、index-in-instanceの方がスロット名とインデックスの関係が明確になる上にカスタマイズしやすそうな気もします。
今回の例では、index-in-instanceを呼びまくっていますが、ちょっと遅そうなので、クラスにインデックスを保持させる方が良いかもしれません。

■

HTML generated by 3bmd in LispWorks 7.0.0

表題の通りなのですが、Clozure CLのマニュアルのソースを眺めていて、こんな記述をみつけました。

• doc/manual/implementation.ccldoc

(item "r13 is used to hold the TCR on PPC32 systems; it's not used on PPC64."))
(item #:|r14 (symbolic name loc-pc) is used to copy "pc-locative" values between main memory and special-purpose PPC registers (LR and CTR) used intern function-call and return instructions.|)

一応解説すると、マニュアルは文字列のリストで記述されていて、文字列の表記には文字列でもシンボルでも使えるようにしてあるので、ダブルクォートのエスケープが面倒な時にはシンボルで記述する(上記の例ではインターンを嫌ってか自由シンボル)ということです。

上記の例ではマクロ展開時の処理ですが、実行時ならば、

(string '|"""foo "bar" baz"""|)
→ "\"\"\"foo \"bar\" baz\"\"\"" 

となり、リード時処理なら文字列を直に書いているのと同一です。

#.(string '|"""foo "bar" baz"""|)
≡ "\"\"\"foo \"bar\" baz\"\"\"" 

個人的には以前から思い付きでやっていたことなのですが、自分以外にもこんなことしている人をみつけた記念に記事にしてみました。

■

HTML generated by 3bmd in LispWorks 7.0.0

最近はECLOSを再現して遊んでいますが、今回は、self-referent-classというメタクラスを再現してみます。

なお、self-referent-classについては、ECLOSの論文に詳しいので参照してください。

• 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の該当個所

挙動を確認してみる

説明はあるとはいえ、マニュアルや仕様書ではないので、実際実装してみようとすると良くわからないところはありますが、インスタンスの初期化時に他のスロットを参照できること=自己参照、ということのようです。 論文の解説によれば、大体下記のような挙動になります。

• 初期化時に自己のインスタンスをselfという変数で参照可能
• (slot-name self)という形式で自身の式より左側のスロットを参照可能
  • しかしこれがcreatorやparentの機能なのか判然としない

(defclass horizontal-line (self-referent-object)
  ((x1 :accessor x1 :initarg :x1 :type real)
   (x2 :accessor x2 :initarg :x2 :type real)
   (y :accessor y :initarg :y :type real)
   (point1 :initform (make-point (x1 self)
                                 (y self)))
   (point2 :initform (make-point (x2 self)
                                 (y self))))
  (:metaclass self-referent-class))
(set' obj (make-instance 'horizontal-line :x1 1 :x2 2 :y 3))
(slot-value obj 'x1)
→ 1 
(slot-value obj 'x2)
→ 2 
(slot-value obj 'point1)
→ (1 3) 
(slot-value obj 'point2)
→ (2 3) 

実装のヒント

論文にはCommon LispのMOPについて問題点が何点も指摘されていますが、スロット定義のinitfunctionが引数を取らないことも指摘しています。
この指摘の中で、この問題を回避するためにスペシャル変数経由で渡していると書いてあるのですが、だとすると、shared-initializeの中のスロット初期化関数にスペシャル変数経由でselfを渡しているのでしょう。

shared-initializeの:aroundを使ってスペシャル変数の囲いはこんな風に書けるでしょう。

(defmethod shared-initialize :around ((instance self-referent-object) slot-names &rest initargs)
  (let ((*self-referent-object-self* instance))
    (declare (special *self-referent-object-self*))
    (call-next-method)))

あとは、initfunctionを

(lambda (&aux (self *self-referent-object-self*)) 
  (declare (special *self-referent-object-self*))
  ...)

のようなものに差し替えればOKです。

(slot-name self)のような形式は、スロット名の局所関数を作成し、ensure-class-using-classの周りに展開されるようにすれば良さそうです。

以上で、想像される展開は下記のようになります。

(eval-when (:compile-toplevel :load-toplevel :execute)
  (flet ((x1 (self) (slot-value self 'x1))
         (x2 (self) (slot-value self 'x2))
         (y (self) (slot-value self 'y))
         (point1 (self) (slot-value self 'point1))
         (point2 (self) (slot-value self 'point2)))
    (def:def (lisp:defclass horizontal-line)
      (clos::ensure-class-without-lod 'horizontal-line
                                      :metaclass
                                      'self-referent-class
                                      :direct-slots
                                      (list (list :name 'x1
                                                  :readers '(x1)
                                                  :writers '((setf x1))
                                                  :initargs '(:x1)
                                                  :type 'real)
                                            (list :name 'x2
                                                  :readers '(x2)
                                                  :writers '((setf x2))
                                                  :initargs '(:x2)
                                                  :type 'real)
                                            (list :name 'y
                                                  :readers '(y)
                                                  :writers '((setf y))
                                                  :initargs '(:y)
                                                  :type 'real)
                                            (list :name 'point1
                                                  :initform
                                                  '(make-point (x1 self) (y self))
                                                  :initfunction
                                                  #'(lambda (&aux (self zreclos.meta::*self-referent-object-self*))
                                                      (declare (special zreclos.meta::*self-referent-object-self*))
                                                      (make-point (x1 self) (y self))))
                                            (list :name 'point2
                                                  :initform
                                                  '(make-point (x2 self) (y self))
                                                  :initfunction
                                                  #'(lambda (&aux (self zreclos.meta::*self-referent-object-self*))
                                                      (declare (special zreclos.meta::*self-referent-object-self*))
                                                      (make-point (x2 self) (y self)))))
                                      :direct-superclasses '(self-referent-object)
                                      :location
                                      (def:location)))))

実装してみる

defclassがメタクラスに応じて任意の展開にディスパッチされると便利なのですが、LispWorksだとexpand-defclassというのがあるので、ここに展開メソッドを追加してやることでdefclassの兄弟マクロを定義せずに済みました。

このexpand-defclassですが、X3J13-88-003Rにあるのと同じ大体同じインターフェイスです。

• expand-defmacro

他にもスロットのオプションの展開等にもLispWorksには便利なメソッドがあるので使ってみました(非公開APIですが) ちなみに、これらはclass-prototypeをディスパッチに利用するのですが、昔からこういう使い方は或る種の定番だったようです。

などなどですが、ベタベタにLispWorks依存になっています。

(defclass self-referent-class (standard-class)
  ()
  (:metaclass standard-class))

(defmethod validate-superclass ((c self-referent-class)
                                (s standard-class))
  T)

(defun make-creator-function-form (slot-form)
  (let ((name (car slot-form)))
    `(,name (self) (slot-value self ',name))))

(defmethod clos::expand-defclass 
           ((prototype self-referent-class) metaclass name superclasses slots class-options)
  (destructuring-bind (eval-when opts &body body)
                      (call-next-method)
    `(,eval-when ,opts
       (flet (,@(mapcar #'make-creator-function-form slots))
         ,@body))))

(defclass self-referent-object (standard-object) 
  ()
  (:metaclass self-referent-class))

(defmethod shared-initialize :around ((instance self-referent-object) slot-names &rest initargs)
  (let ((*self-referent-object-self* instance))
    (declare (special *self-referent-object-self*))
    (call-next-method)))
;; from alexandria
(defun flatten (tree)
  "Traverses the tree in order, collecting non-null leaves into a list."
  (let (list)
    (labels ((traverse (subtree)
               (when subtree
                 (if (consp subtree)
                     (progn
                       (traverse (car subtree))
                       (traverse (cdr subtree)))
                     (push subtree list)))))
      (traverse tree))
    (nreverse list)))

(defun non-trivial-initform-initfunction-p (initform)
  #+lispworks7.1
  (loop :for (name ntifif) :on (flatten initform)
        :thereis (and (eq 'hcl:lambda-name name)
                      (eq 'clos::non-trivial-initform-initfunction ntifif)))
  #+lispworks7.0
  (let ((x initform))
    (and (consp x)
         (eq 'function (car x))
         (eq 'lambda (caadr x)))))

(defgeneric make-sr-class-initfunction-form (class ifform))

(defmethod make-sr-class-initfunction-form ((class self-referent-class)
                                            ifform)
  (if (non-trivial-initform-initfunction-p ifform)
      (destructuring-bind (function (lambda arg &body body))
                          ifform
        (declare (ignore arg))
        `(,function (,lambda (&aux (self *self-referent-object-self*)) 
                             (declare (special *self-referent-object-self*))
                             ,@body)))
      ifform))

(defmethod clos::canonicalize-defclass-slot
           ((prototype self-referent-class) slot)
  (let* ((plist (copy-list (cdr (call-next-method))))
         (ifform (getf plist :initfunction)))
    (if (getf plist :initform)
        (progn
          (remf plist :initfunction)
          `(list ,@plist 
                 :initfunction ,(make-sr-class-initfunction-form prototype
                                                                 ifform)))
        (progn
          `(list ,@plist)))))

まとめ

expand-defclassは便利なのでLispWorks限らず他でも使いたいところですが、このあたりは統一されてないんですよねえ。

■

HTML generated by 3bmd in LispWorks 7.0.0

昨日リリースされたSBCL 1.5.9にcaseのジャンプテーブル最適化が入ったようなので早速どんなものか試してみたいと思います。

• SBCL All News:1.5.9

とりあえず若干わざとらしいものを試してみます。
caseのキーに0から511までの数値をシャッフルしたものを指定して分岐し、さらに二段目のcaseで元に戻すのを5回繰り返すのを1000繰り返してみます。

(defconstant nbranch 512)
;; alexandria
(defun shuffle (sequence &key (start 0) end)
  "Returns a random permutation of SEQUENCE bounded by START and END.
Original sequece may be destructively modified, and share storage with
the original one. Signals an error if SEQUENCE is not a proper
sequence."
  (declare (type fixnum start)
           (type (or fixnum null) end))
  (etypecase sequence
    (list
     (let* ((end (or end (length sequence)))
            (n (- end start)))
       (do ((tail (nthcdr start sequence) (cdr tail)))
           ((zerop n))
         (rotatef (car tail) (car (nthcdr (random n) tail)))
         (decf n))))
    (vector
     (let ((end (or end (length sequence))))
       (loop for i from start below end
             do (rotatef (aref sequence i)
                         (aref sequence (+ i (random (- end i))))))))
    (sequence
     (let ((end (or end (length sequence))))
       (loop for i from (- end 1) downto start
             do (rotatef (elt sequence i)
                         (elt sequence (+ i (random (- end i)))))))))
  sequence)
(defmacro casetabletest (x)
  (let ((xy (loop :for x :across (shuffle
                  (let ((vec (make-sequence 'vector nbranch)))
                    (dotimes (i nbranch vec)
                                      (setf (elt vec i) i))))
                  :for i :from 0 :collect (list i x))))
    `(case (case ,x
         ,@xy
         (otherwise -1))
       ,@(mapcar #'reverse xy)
       (otherwise -1))))
(defun casetest (&aux (n 0))
  (dotimes (i nbranch n)
    (incf n (casetabletest
         (casetabletest
          (casetabletest
           (casetabletest
        (casetabletest i))))))))
(compile 'casetest)
(time (dotimes (i 1000)
    (casetest)))

SBCL 1.5.8

t% /l/sbcl/1.5.8/bin/sbcl --no-sysinit --no-userinit --load /tmp/case.lisp --quit 
This is SBCL 1.5.8, an implementation of ANSI Common Lisp.
More information about SBCL is available at <http://www.sbcl.org/>.
SBCL is free software, provided as is, with absolutely no warranty.
It is mostly in the public domain; some portions are provided under
BSD-style licenses.  See the CREDITS and COPYING files in the
distribution for more information.
Evaluation took:
  1.986 seconds of real time
  1.990000 seconds of total run time (1.990000 user, 0.000000 system)
  100.20% CPU
  6,537,459,720 processor cycles
  0 bytes consed

SBCL 1.5.9

t% /l/sbcl/1.5.9/bin/sbcl --no-sysinit --no-userinit --load /tmp/case.lisp --quit 
This is SBCL 1.5.9, an implementation of ANSI Common Lisp.
More information about SBCL is available at <http://www.sbcl.org/>.
SBCL is free software, provided as is, with absolutely no warranty.
It is mostly in the public domain; some portions are provided under
BSD-style licenses.  See the CREDITS and COPYING files in the
distribution for more information.
Evaluation took:
  0.056 seconds of real time
  0.060000 seconds of total run time (0.060000 user, 0.000000 system)
  107.14% CPU
  184,341,012 processor cycles
  0 bytes consed

この極端な例では35倍も速くなっています。
まあこんなことはそうそうないですが!

ちなみに類似の最適化を実施するClozure CLでも同じ位のスピードが出るようです。

t% /l/ccl/1.11.5/lx86cl64 -n -l /tmp/case.lisp -e '(quit)'
(DOTIMES (I 1000) (CASETEST))
took 55,783 microseconds (0.055783 seconds) to run.
During that period, and with 8 available CPU cores,
     60,000 microseconds (0.060000 seconds) were spent in user mode
          0 microseconds (0.000000 seconds) were spent in system mode

発動ルールを探る

上記の例では最適化が発動しましたが、caseのジャンプテーブル化ではそんなに大きなテーブルは作らないことがほとんどなので、SBCLではどういう縛りがあるか確認してみます。

発動ルールは、src/compiler/ir2opt.lispのshould-use-jump-table-pの中に記述されているようで、

• キーの最大値から最小値を引いたもの+1がテーブルサイズ
• テーブルサイズは分岐の数の二倍が上限

のようです。

(defun should-use-jump-table-p (chain &aux (choices (car chain)))
  ;; Dup keys could exist. REMOVE-DUPLICATES from-end can handle that:
  ;;  "the one occurring earlier in sequence is discarded, unless from-end
  ;;   is true, in which case the one later in sequence is discarded."
  (let ((choices (remove-duplicates choices :key #'car :from-end t))) 
    ;; Convert to multiway only if at least 4 key comparisons would be needed.
    (unless (>= (length choices) 4)
      (return-from should-use-jump-table-p nil))
    (let ((values (mapcar #'car choices)))
      (cond ((every #'fixnump values)) ; ok
            ((every #'characterp values)   
             (setq values (mapcar #'sb-xc:char-code values)))
            (t
             (return-from should-use-jump-table-p nil)))
      (let* ((min (reduce #'min values))
             (max (reduce #'max values))
             (table-size (1+ (- max min )))
             (size-limit (* (length values) 2)))
        ;; Don't waste too much space, e.g. {5,6,10,20} would require 16 words
        ;; for 4 entries, which is excessive.
        (when (and (<= table-size size-limit)
                   (can-encode-jump-table-p min max))
          ;; Return the new choices
          (cons choices (cdr chain)))))))

上記ルールからすると、一つ置きで配置された整数のキーは最適化されますが、二つ置きだとルールから外れるので最適化されないことが分かります。
一応試してみましょう。

(defun foo2 (x)
  (declare (type fixnum x))
  #.`(case x
       ,@(loop :for i :from 0 :by 2 :repeat 10
               :collect (list i i))
       (otherwise -1)))

; disassembly for FOO2
; Size: 110 bytes. Origin: #x52DF52DA                         ; FOO2
; 2DA:       498B4510         MOV RAX, [R13+16]               ; thread.binding-stack-pointer
; 2DE:       488945F8         MOV [RBP-8], RAX
; 2E2:       4C8BDB           MOV R11, RBX
; 2E5:       4983FB24         CMP R11, 36
; 2E9:       774E             JNBE L10
; 2EB:       488D0526FFFFFF   LEA RAX, [RIP-218]              ; = #x52DF5218
; 2F2:       42FF2498         JMP QWORD PTR [RAX+R11*4]
; 2F6: L0:   BA04000000       MOV EDX, 4
; 2FB: L1:   488BE5           MOV RSP, RBP
; 2FE:       F8               CLC
; 2FF:       5D               POP RBP
; 300:       C3               RET
; 301: L2:   BA08000000       MOV EDX, #x8                    ; is_lisp_thread
; 306:       EBF3             JMP L1
; 308: L3:   BA0C000000       MOV EDX, 12
; 30D:       EBEC             JMP L1
; 30F: L4:   BA10000000       MOV EDX, 16
; 314:       EBE5             JMP L1
; 316: L5:   BA14000000       MOV EDX, 20
; 31B:       EBDE             JMP L1
; 31D: L6:   BA18000000       MOV EDX, 24
; 322:       EBD7             JMP L1
; 324: L7:   BA1C000000       MOV EDX, 28
; 329:       EBD0             JMP L1
; 32B: L8:   BA20000000       MOV EDX, 32
; 330:       EBC9             JMP L1
; 332: L9:   BA24000000       MOV EDX, 36
; 337:       EBC2             JMP L1
; 339: L10:  48C7C2FEFFFFFF   MOV RDX, -2
; 340:       EBB9             JMP L1
; 342: L11:  31D2             XOR EDX, EDX
; 344:       EBB5             JMP L1
; 346:       CC10             INT3 16                         ; Invalid argument count trap

(defun foo3 (x)
  (declare (type fixnum x))
  #.`(case x
       ,@(loop :for i :from 0 :by 3 :repeat 10
               :collect (list i i))
       (otherwise -1)))

; disassembly for FOO3
; Size: 154 bytes. Origin: #x52DF53CE                         ; FOO3
; 3CE:       498B5D10         MOV RBX, [R13+16]               ; thread.binding-stack-pointer
; 3D2:       48895DF8         MOV [RBP-8], RBX
; 3D6:       4885C0           TEST RAX, RAX
; 3D9:       0F8483000000     JEQ L9
; 3DF:       4883F806         CMP RAX, 6
; 3E3:       750B             JNE L1
; 3E5:       BA06000000       MOV EDX, 6
; 3EA: L0:   488BE5           MOV RSP, RBP
; 3ED:       F8               CLC
; 3EE:       5D               POP RBP
; 3EF:       C3               RET
; 3F0: L1:   4883F80C         CMP RAX, 12
; 3F4:       7507             JNE L2
; 3F6:       BA0C000000       MOV EDX, 12
; 3FB:       EBED             JMP L0
; 3FD: L2:   4883F812         CMP RAX, 18
; 401:       7507             JNE L3
; 403:       BA12000000       MOV EDX, 18
; 408:       EBE0             JMP L0
; 40A: L3:   4883F818         CMP RAX, 24
; 40E:       7507             JNE L4
; 410:       BA18000000       MOV EDX, 24
; 415:       EBD3             JMP L0
; 417: L4:   4883F81E         CMP RAX, 30
; 41B:       7507             JNE L5
; 41D:       BA1E000000       MOV EDX, 30
; 422:       EBC6             JMP L0
; 424: L5:   4883F824         CMP RAX, 36
; 428:       7507             JNE L6
; 42A:       BA24000000       MOV EDX, 36
; 42F:       EBB9             JMP L0
; 431: L6:   4883F82A         CMP RAX, 42
; 435:       7507             JNE L7
; 437:       BA2A000000       MOV EDX, 42
; 43C:       EBAC             JMP L0
; 43E: L7:   4883F830         CMP RAX, 48
; 442:       7507             JNE L8
; 444:       BA30000000       MOV EDX, 48
; 449:       EB9F             JMP L0
; 44B: L8:   4883F836         CMP RAX, 54
; 44F:       48C7C2FEFFFFFF   MOV RDX, -2
; 456:       41BB36000000     MOV R11D, 54
; 45C:       490F44D3         CMOVEQ RDX, R11
; 460:       EB88             JMP L0
; 462: L9:   31D2             XOR EDX, EDX
; 464:       EB84             JMP L0
; 466:       CC10             INT3 16                         ; Invalid argument count trap

まとめ

SBCLのcaseのジャンプテーブル化は、キーをそこそこ密に配置する必要がある様子。
ちなみに、caseの最適化と本記事では書いてきましたが、Clozure CLと同じく、コンパイラが最適化で実施するので、Lispのレベルではifの組み合わせが最適化のルールに合致していれば発動します。

SBCLには最近細かい最適化が入ってきていますが今後も地味に速くなって行きそうです。

関連記事

• #:g1: Common Lispと多方向分岐の最適化
• #:g1: Common Lispで多方向分岐の最適化がされない場合にどうするか

■

HTML generated by 3bmd in LispWorks 7.0.0

ECLOSのlazy-classというのを再現してみようかなと思っているのですが、このlazy-slotには初期化のタイミングが、通常の初期化時と、スロット読み取り時直前とで二通りで選択可能です。
lazy-classには、他にも初期化の依存関係を記述する機能があるのですが、とりあえずそれは置いて、初期化タイミングだけ切り出して実現方法を考えてみました。
上手く行けば、初期化の依存関係を記述する機能と、初期化タイミングの指定は後でmixinできるでしょう。

あれこれ考えて作成してみましたが、下記のように動作します。

(defconstant <i@robj>
  (defclass i@robj (initialize-at-read-object)
    ((a :initform 'a :initialize-at-read-p T)
     (b :initform 'b :accessor b)
     (c :initform 'c :accessor c))
    (:metaclass initialize-at-read-class)))
(class-slots <i@robj>)
→ (#<initialize-at-read-effective-slot-definition a 402023D19B>
    #<initialize-at-read-effective-slot-definition b 402023D37B>
    #<initialize-at-read-effective-slot-definition c 402023D3EB>) 
(class-initialize-at-read-slots <i@robj>)
→ (#<initialize-at-read-effective-slot-definition a 4020235393>) 
(let ((o (make-instance <i@robj>)))
  (list (slot-boundp o 'a)
        (slot-value o 'a)
        (slot-value o 'b)
        (slot-value o 'c)))
→ (nil a b c) 

実装した内容としては、

• 読み取り時初期化のスロットをclass-initialize-at-read-slotsとして取得することにする
• 読み取り時初期化のスロットはshared-initializeでは初期化を飛す
• 読み取り時初期化のスロットは、初回の読み取りは未束縛のため、slot-unboundが起動されるので、ここで初期化する
• スロットの初期化を条件によりスキップしないといけないのでshared-initializeを置き換え

位です。

実現したいことは単純なので、どうにかコードを圧縮したいところですが、MOPのコードはどうも長くなってしまいますね。
まあ、そんなに頻繁に書くものでもないので長くても良いのか……。

今回の場合は、slot-unboundを使ってスロットの初期化をすれば良いので、クラスごとに定義することにはなるもののMOPをカスタマイズしなくてもslot-unboundの定義だけすれば、正味五六行の追加で済みそうではあります。

(eval-when (:compile-toplevel :load-toplevel :execute)
  (ql:quickload :closer-mop))

(defpackage "a86f7ecc-112d-5ccb-9280-20798a2e36b4" 
  (:use :c2cl))

(in-package "a86f7ecc-112d-5ccb-9280-20798a2e36b4")
;; utils
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun package-symbolconc (package-spec &rest frobs)
    (values
     (intern
      (with-standard-io-syntax
        (with-output-to-string (out)
          (dolist (elt frobs)
            (unless (typep elt '(or symbol string fixnum character))
              (error "The value ~A is not of type (OR SYMBOL STRING FIXNUM CHARACTER)."
                     elt))
            (princ elt out))))
      package-spec)))
  (defun symbolconc (&rest frobs)
    (declare (dynamic-extent frobs))
    (apply #'package-symbolconc *package* frobs)))

(defclass initialize-at-read-class (standard-class)
  ((initialize-at-read-slots :initform nil
                             :accessor class-initialize-at-read-slots))
  (:metaclass standard-class))

(defclass initialize-at-read-object (standard-object)
  ()
  (:metaclass initialize-at-read-class))

(defmethod validate-superclass ((c initialize-at-read-class) (s standard-class))
  T)

(macrolet
    ((defslotd (name)
       (let ((class  (symbolconc name '-class))
             (slotd  (symbolconc name '-slot-definition))
             (dslotd (symbolconc name '-direct-slot-definition))
             (eslotd (symbolconc name '-effective-slot-definition))
             (slotp  (symbolconc 'slot-definition- name '-p)))
         `(progn
            (defclass ,slotd (standard-slot-definition)
              ((,(symbolconc name '-p) 
                :initform nil
                :accessor ,slotp
                :initarg ,(package-symbolconc :keyword name '-p))))
            (defclass ,dslotd (,slotd standard-direct-slot-definition)
              ())
            (defclass ,eslotd (,slotd standard-effective-slot-definition)
              ())
            (defmethod direct-slot-definition-class ((class ,class) &rest initargs)
              (declare (ignore initargs))
              (find-class ',dslotd))
            (defmethod effective-slot-definition-class ((class ,class) &rest initargs)
              (declare (ignore initargs))
              (find-class ',eslotd))
            (defmethod compute-effective-slot-definition ((class ,class) name direct-slot-definitions)
              (declare (ignore name))
              (let ((eslotd (call-next-method)))
                (dolist (dslotd direct-slot-definitions)
                  (when (typep dslotd (find-class ',slotd))
                    (setf (,slotp eslotd) (,slotp dslotd))
                    (return)))
                eslotd))
            (defmethod slot-unbound ((class ,class) 
                                     (instance ,(symbolconc name '-object))
                                     name)
              (let ((slotd (find name 
                                 (,(symbolconc 'class- name '-slots) class)
                                 :key #'slot-definition-name)))
                (let ((result (funcall (slot-definition-initfunction slotd))))
                  (setf (slot-value instance name) result)
                  result)))
            (defmethod compute-slots :around ((class ,class))
              (let ((slots (call-next-method)))
                (setf (,(symbolconc 'class- name '-slots) class)
                      (remove-if-not #',slotp slots))
                slots))))))
  (defslotd initialize-at-read))

(defun initialize-slot-from-initarg (class instance slotd initargs)
  (let ((slot-initargs (slot-definition-initargs slotd)))
    (loop :for (initarg value) :on initargs :by #'cddr
          :do (when (and (member initarg slot-initargs)
                         (not (slot-definition-initialize-at-read-p slotd)))
                (setf (slot-value-using-class class instance slotd)
                      value)
                (return t)))))

(defun initialize-slot-from-initfunction (class instance slotd)
  (let ((initfun (slot-definition-initfunction slotd)))
    (unless (or (not initfun)
                (slot-boundp-using-class class instance slotd))
      (unless (slot-definition-initialize-at-read-p slotd)
        (setf (slot-value-using-class class instance slotd)
              (funcall initfun))))))

(defmethod shared-initialize ((instance initialize-at-read-object) slot-names &rest initargs)
  (let* ((class (class-of instance)))
    (dolist (slotd (class-slots class))
      (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))))
    instance))

■

HTML generated by 3bmd in LispWorks 7.0.0

前回は、ECLOSが提供するdefclassの:metaclassオプション省略時のメタクラスの自動算出について書きましたが、今回はTiny CLOSの流れを汲むSTklos系のメタクラスメタクラスの自動算出です。

Tiny CLOSが動くScheme処理系は結構あるようですが、より処理系と統合されたり構文が改良されたりしているのがSTklos系のようです。

• STklos
• Guile
• Gauche
• Sagitarius

上記あたりがSTklos系のようですが、Tiny CLOSの系譜をいまいち把握できていないので外しているかもしれません。
上記の継承関係は、

(defclass stklos (tiny-clos clos dylan) ())
(defclass guile (stklos) ())
(defclass gauche (stklos guile) ())
(defclass sagitarius (gauche) ())

っぽいですが。

とりあえず、今回のメタクラスの自動算出に関しては、上記処理系で共通なのでSTklos系ということにしましょう。

STklosメタクラスの自動算出アルゴリズム

Gauche: 7.5.1 クラスのインスタンシエーション等に解説されていますが、

1. define-classに:metaclassが明示されていればそれを使う
2. 指定がなければ
   • ダイレクトスーパークラスのメタクラスのクラス順位リスト中を調べて
   • メタクラスが一つに定まればそれを使う
   • 複数なら、その複数のメタクラスをスーパークラスとするメタクラスを生成して使う

となります。

メタクラスのクラス順位リスト中をどう調べるのかは、コードは簡単なので詳細はコードを眺めた方が早いでしょう。
下記は、GuileのコードをCommon Lispに移植したものです。

オリジナルではクラス名をgensymで生成していますが、下記ではスーパークラス名のリストを名前としてみています。

(defpackage "d65706d7-0478-5a48-b39b-0dd8c0ff2563"
  (:use :c2cl))

(in-package "d65706d7-0478-5a48-b39b-0dd8c0ff2563")

(let ((table-of-metas '()))
  (defun ensure-metaclass-with-supers (meta-supers)
    (let ((entry (assoc meta-supers table-of-metas :test #'equal)))
      (if entry
          ;; Found a previously created metaclass
          (cdr entry)
          ;; Create a new meta-class which inherit from "meta-supers"
          (let* ((name (mapcar #'class-name meta-supers))
                 (new (make-instance 'standard-class 
                                     :name name
                                     :direct-superclasses meta-supers
                                     :direct-slots '())))
            (setf (find-class name) new)
            (push (cons meta-supers new) table-of-metas)
            new)))))

(defun ensure-metaclass (supers)
  (if (endp supers)
      (find-class 'standard-class)
      (let* ((all-metas (mapcar #'class-of supers))
             (all-cpls  (mapcan (lambda (m)
                                  (copy-list (cdr (class-precedence-list m))))
                                all-metas))
             (needed-metas '()))
        ;; Find the most specific metaclasses.  The new metaclass will be
        ;; a subclass of these.
        (mapc
         (lambda (meta)
           (when (and (not (member meta all-cpls))
                      (not (member meta needed-metas)))
             (setq needed-metas (append needed-metas (list meta)))))
         all-metas)
        ;; Now return a subclass of the metaclasses we found.
        (if (endp (cdr needed-metas))
            (car needed-metas)  ; If there's only one, just use it.
            (ensure-metaclass-with-supers needed-metas)))))

(defpackage stklos 
  (:use)
  (:export defclass))

(defmacro stklos:defclass (name superclasses slots &rest class-options)
  (let* ((metaclass (ensure-metaclass (mapcar (lambda (s)
                                                (or (find-class s nil)
                                                    (make-instance 'standard-class :name s)))
                                              superclasses)))
         (metaclass (case (class-name metaclass)
                      (forward-referenced-class (find-class 'standard-class))
                      (otherwise metaclass))))
    (clos::expand-defclass (class-prototype metaclass)
                           (class-name metaclass)
                           name
                           superclasses
                           slots
                           class-options)))

動作確認

定義できたので動作を確認していきます。

(defclass a-class (standard-class) ())
(defclass b-class (standard-class) ())
(defclass c-class (a-class b-class) ())
(defmethod validate-superclass ((c a-class) (s standard-class)) T)
(defmethod validate-superclass ((c b-class) (s standard-class)) T)
(defconstant <a>
  (defclass a ()
    ()
    (:metaclass a-class)))
(defconstant <b>
  (defclass b ()
    ()
    (:metaclass b-class)))

前回と同じく、a-class、b-class、c-classとメタクラスを定義し、a-classをメタクラスとしたa、b-classをメタクラスとしたbを作成します。

ここで、

(defclass c (a b)
  ())

とした場合に、cのメタクラスがどのように求まるかを確認してみます。

(ensure-metaclass (list <a> <b>))
→ #<standard-class (a-class b-class) 42E014EC0B> 

ECLOSではc-classが算出されましたが、STklosでは新たにメタクラスが生成されています。
なお、一度生成されたメタクラスはensure-metaclass-with-supersが保持していて、同様のメタクラスの組み合わせが既に存在すれば、それが使われるので重複して生成することはありません。

(defconstant <c>
  (stklos:defclass c (a b)
    ()))
(defconstant <d>
  (stklos:defclass d (a b)
    ()))
(class-name (class-of <c>))
→ (a-class b-class) 
(class-name (class-of <d>))
→ (a-class b-class) 
(eq (class-of <c>) (class-of <d>))
→ t 
(find-class (class-name (class-of <d>)))
→ #<standard-class (a-class b-class) 42E014EC0B> 

まとめ

今回は、STklos系のメタクラスの自動算出を眺めてみました。
メタクラスのサブクラス方向を探しに行くECLOSとは違って、STklosは継承の最下層になっているメタクラスを集め、複数なら合成して返す、という感じでした。

ちょっと試してみた感じでは、開発時のようにクラスの再定義や削除、同じ定義が別名で定義されたり(実際には名前を付け替えているつもり)が頻発する環境だと、ECLOSが探索するサブクラスのメンテナンスがなおざりになることが多いので、算出された結果も開発者の直感からすると古い情報に基いてしまったりすることがあるようです。
まあ、正しくクラスを削除、再定義すれば良いのでそういうユーティリティを充実させるのも良いかもしれません。

STklos系は、動的にメタクラスを生成するのと、クラス順位リストがサブクラスに比べてきっちり更新されるので、トラブルらしいトラブルには遭遇していません。

さて、どちらの方式が便利なのか……。 しばらく両方の方式を日々比較検討試していきたいと思います。

■

HTML generated by 3bmd in LispWorks 7.0.0

うまいタイトルが考えつかなかったので、「ECLOSのメタクラス継承」というタイトルになりましたが、ECLOSが提供するdefclassの:metaclassオプション省略時のメタクラスの自動算出についてです。

なお、ECLOSについては、

• LispM.de > docs > Publications > Common Lisp
  • ECLOS Metaclass library
  • Extended CLOS

に詳しいので参照してください。

ECLOSのメタクラスの自動算出アルゴリズム

Common Lispでは、カスタマイズしたメタクラスをdefclassで利用する際には明示的に:metaclassを指定しないといけないのですが、結構めんどうです。
上記文献によれば、ECLOSは、

1. defclassに:metaclassがあればそれを使う
2. 指定がなければ、
   • ダイレクトスーパークラスの集合をSとする。
   • それらのメタクラスの集合をM(S)とする。
   • Sの要素のサブクラス関係の推移閉包の集合をM*(S)とする。
   • M*(S)の要素の共通部分をTとする。
   • Tがサブクラス関係の木を成していれば、その根を、さもなくば、standard-classをメタクラスとする

というアルゴリズムでこの問題を解決します。

いまいち解釈に自信がありませんが、とりあえずそのままコードにしてみました。
推移閉包を求めるコードは、Tiny CLOSのものが手頃だったので、これを利用しています。

(defpackage "31f04d2f-2dc5-523c-a129-1478406e4677" 
  (:use :c2cl))

(in-package "31f04d2f-2dc5-523c-a129-1478406e4677")

(defun build-transitive-closure (get-follow-ons)
  (lambda (x)
    (labels ((track (result pending)
               (if (endp pending)
                   result
                   (let ((next (car pending)))
                     (if (member next result)
                         (track result (cdr pending))
                         (track (cons next result)
                                (append (funcall get-follow-ons next)
                                        (cdr pending))))))))
      (track '() (list x)))))
  
(defun compute-metaclass (dsupers &key (default-metaclass-name nil))
  (block nil
    ;;Let C be a class, if
    ;;a) the definition of C includes a (:metaclass M) option then M is the metaclass of C.
    (when default-metaclass-name
      (return (find-class default-metaclass-name)))
    (when (endp dsupers)
      (return (find-class 'standard-class)))
    ;;b) let S be the set of direct superclasses of C 
    (let* ((| S | dsupers)
           (| M(S) | (mapcar #'class-of | S |))
           ;;and let M*(S) be the set of transitive closures of the subclass relation applied to the elements of M(S)
           (| M*(S) | (mapcar (build-transitive-closure #'class-direct-subclasses) | M(S) |))
           ;;and let T be the intersection of the sets composing M*(S)
           (| T | (reduce #'intersection | M*(S) |)))
      ;;then if T forms a tree according to the subclass relation 
      (if (and (not (null | T |))
               (every #'subtypep | T | (cdr | T |)))
          ;;then the root of T is the metaclass of C
          (car (reverse | T |))
          ;;otherwise STANDARD-CLASS is the metaclass of C.
          (find-class 'standard-class)))))

(defpackage eclos 
  (:use)
  (:export defclass))

(defun ensure-class-soft (name)
  (or (find-class name nil)
      (make-instance 'standard-class :name name)))

#+lispworks
(defmacro eclos:defclass (name superclasses slots &rest class-options)
  (let* ((metaclass-name (cadr (find :metaclass class-options :key #'car)))
         (metaclass (compute-metaclass (mapcar #'ensure-class-soft superclasses)
                                       :default-metaclass-name  metaclass-name))
         (metaclass (case (class-name metaclass)
                      (forward-referenced-class (find-class 'standard-class))
                      (otherwise metaclass))))
    (clos::expand-defclass (class-prototype metaclass)
                           (class-name metaclass)
                           name
                           superclasses
                           slots
                           class-options)))

動作確認

さて、定義できたので動作を確認していきます。

(defclass a-class (standard-class) ())
(defclass b-class (standard-class) ())
(defclass c-class (a-class b-class) ())
(defmethod validate-superclass ((c a-class) (s standard-class)) T)
(defmethod validate-superclass ((c b-class) (s standard-class)) T)
(defconstant <a>
  (defclass a ()
    ()
    (:metaclass a-class)))
(defconstant <b>
  (defclass b ()
    ()
    (:metaclass b-class)))

a-class、b-class、c-classとメタクラスを定義し、a-classをメタクラスとしたa、b-classをメタクラスとしたbを作成します。

ここで、

(defclass c (a b)
  ())

とした場合に、cのメタクラスが適切に求まれば良いのですが、上記で定義したcompute-metaclassで確認してみます。

(compute-metaclass (list <a> <b>))
→ #<lisp:standard-class c-class 4160314BC3> 
;; c-classを削除
(progn
  (reinitialize-instance (find-class 'c-class) :direct-superclasses nil)
  (setf (find-class 'c-class) nil))
;; メタクラスが求まらなかったので、デフォルト値のstandard-classを返す
(compute-metaclass (list <a> <b>))
→ #<lisp:standard-class standard-class 41A0997013> 
;; メタクラス再作成
(defclass c-class (b-class a-class) ())
→ #<lisp:standard-class c-class 40202BE5AB> 
(compute-metaclass (list <a> <b>))
→ #<lisp:standard-class c-class 40202BE5AB> 

とりあえず大丈夫そうなので、eclos:defclassを使ってcを定義してみます。

(eclos:defclass c (a b)
  ())
→ #<c-class c 402072C593> 

まとめ

以上の動作をみて分かるように、メタクラスを多重継承する場合は、予め多重継承したメタクラスを用意しておく必要がありますが、用意さえしておけば勝手に見付けてくれるのが便利といえば便利かもしれません。
メタクラス継承の自動算出は、STklos、Guile、Gauche等のSTklos系OOPSでも行なわれています。
ECLOSとは異なったアルゴリズムが使われているので、次回はそちらを眺めたりCommon Lispで実装してみます。

■

HTML generated by 3bmd in LispWorks 7.0.0

前回はとりあえず、インスタンスのアクセスにslot-valueを使わないようなメタクラスを定義してみたりしましたが、slot-value排除を推進してインスタンスの初期化にも細工してみたいと思います。
slot-value経由でのアクセスの廃止=カプセル化という応用で考えてみます。

encapsulated-class

本当はインスタンスの初期化からもslot-valueを排除したかったのですが、気付いたらslot-valueを自作していた感があったので、slot-valueは初期化メソッドの内部でしか利用させないという制限を付けることにしました。
制限の手段としては安直にクラスに class-encapsulated-pを定義して管理します。
slot-value...系はclass-slotsの情報を元に動作することになるので、大元のclass-slotsに制限を掛けてやることにします。
今回は、class-encapsulated-p が Tの時はclass-slotsがエラーを発するようにしてみました。

encapsulated-object

オブジェクトの初期化をカスタマイズするには、standard-objectを派生させる必要があるので、encapsulated-objectを定義し、これの初期化をカスタマイズします。

カプセル化と継承についての問題で、アクセス制限をどう継承するか、というものがあるようですが、今回は継承側の勝手に任せることにしました。

ということでこんな動きになりました。

;; utils
(eval-when (:compile-toplevel :load-toplevel :execute)
  (setf (fdefinition 'a) #'make-instance))
(defconstant <zot>
  (defclass zot (encapsulated-object)
    ((a :initform 0 :accessor zot.a))
    (:encapsulated-p T)
    (:metaclass encapsulated-class)))
(class-encapsulated-p <zot>)
→ T
(slot-value (a <zot>) 'a)
!!! Illegal reflective access: #<encapsulated-class zot 4120259C13>.
(zot.a (a <zot>))
→ 0
(defconstant <quux>
  (defclass quux (zot)
    ((x :initform 42)
     (y :initform 42)
     (z :initform 42))
    (:encapsulated-p nil)
    (:metaclass encapsulated-class)))
(class-encapsulated-p <quux>)
→ nil
(with-slots (a x y z) (a <quux>)
  (list a x y z))
→ (0 42 42 42)

定義

• shared-initializeの定義はSBCLのものを参考にしました。

(cl:in-package cl-user)
(load "via-accessor-class")
(eval-when (:compile-toplevel :load-toplevel :execute)
  (ql:quickload :closer-mop)
  (when (find-package "a6acd6f5-46a2-51bf-83be-8596ac2d2f35")
    (delete-package "a6acd6f5-46a2-51bf-83be-8596ac2d2f35")))
(defpackage "a6acd6f5-46a2-51bf-83be-8596ac2d2f35"
  (:use :c2cl))
(in-package "a6acd6f5-46a2-51bf-83be-8596ac2d2f35")
(defmacro in-syntax (name)
  `(progn
     (defvar ,(intern name) (copy-readtable nil))
     (setq *readtable* ,(intern name))))
(defmacro local-prefix-setup ()
  `(set-macro-character #\~ (lambda (srm chr)
                              (declare (ignore chr))
                              (intern (concatenate 'string 
                                                   (string 'encapsulated-)
                                                   (string (read srm)))))))
(in-syntax "a6acd6f5-46a2-51bf-83be-8596ac2d2f35")
(local-prefix-setup)
(define-condition illegal-reflective-access (simple-error)
  ()
  (:report (lambda (condition stream)
             (format stream
                     "Illegal reflective access: ~{~S~}."
                     (simple-condition-format-arguments condition)))))

(defclass ~class (|3d0ecf39-dd6c-53f5-9672-58d5f5408cc6|:via-accessor-class)
  ((~p :initform T
       :initarg :encapsulated-p
       :accessor class-encapsulated-p)))
(defmethod ensure-class-using-class :around ((class ~class) name
                                             &rest initargs
                                             &key (~p T ~p-sup?))
  (if (and ~p-sup? (consp ~p))
      (apply #'call-next-method class name :encapsulated-p (car ~p) initargs)
      (call-next-method)))
(defmethod validate-superclass ((class ~class) (super standard-class))
  T)
(defmethod class-slots :around ((class ~class))
  (if (class-encapsulated-p class)
      (error 'illegal-reflective-access :format-arguments (list class))
      (call-next-method)))
(defclass ~object (standard-object)
  ())
(defmethod shared-initialize ((instance ~object) slot-names &rest initargs)
  (flet ((initialize-slot-from-initarg (class instance slotd)
           (let ((slot-initargs (slot-definition-initargs slotd)))
             (loop :for (initarg value) :on initargs :by #'cddr
                   :do (when (member initarg slot-initargs)
                         (setf (slot-value-using-class class instance slotd)
                               value)
                         (return t)))))
         (initialize-slot-from-initfunction (class instance slotd)
           (let ((initfun (slot-definition-initfunction slotd)))
             (unless (or (not initfun)
                         (slot-boundp-using-class class instance slotd))
               (setf (slot-value-using-class class instance slotd)
                     (funcall initfun))))))
    (let* ((class (class-of instance))
           (encapsulated-p (class-encapsulated-p class)))
      (unwind-protect
          (progn
            (setf (class-encapsulated-p class) nil)
            (loop :for slotd :in (class-slots class)
                  :unless (initialize-slot-from-initarg class instance slotd)
                  :do (when (or (eq t slot-names)
                                (member (slot-definition-name slotd) slot-names))
                        (initialize-slot-from-initfunction class instance slotd))))
        (setf (class-encapsulated-p class)
              encapsulated-p)))
    instance))
(defmethod finalize-inheritance :around ((class ~class))
  (let ((encapsulated-p (class-encapsulated-p class)))
    (unwind-protect
        (progn
          (setf (class-encapsulated-p class) nil)
          (call-next-method))
      (setf (class-encapsulated-p class)
            encapsulated-p))))

まとめ

slot-value排除の応用としてカプセル化も考えつつも、初期化でのslot-valueの扱いは日和るという中途半端な考察で、slot-valueを排除するのはなかなか面倒ということが分かっただけでした。

今回は、アクセス制限については、class-slotsでの制御としましたが、スロットをカスタマイズする方法もありそうです。

ちなみに、カプセル化の方法として、自由(uninterened)シンボルを使うというのがあるらしいですが、秘匿効果としては微妙な気がしています。
Pythonの命名規約の__foo__みたいなものでしょうか。

;;; importすれば簡単にシンボルは捕捉できる
(defclass foo ()
  (#:a #:b #:c))
(class-slots (find-class 'foo))
→ (#<standard-effective-slot-definition #:a 40201BF60B>
    #<standard-effective-slot-definition #:b 40201BF673>
    #<standard-effective-slot-definition #:c 40201BF6DB>) 
(mapc (lambda (s)
        (shadowing-import (slot-definition-name s)))
      (class-slots (find-class 'foo)))
→ (#<standard-effective-slot-definition a 417024825B>
    #<standard-effective-slot-definition b 4170248753>
    #<standard-effective-slot-definition c 4170248C63>) 
(setf (slot-value (make-instance 'foo) 'a) 42)
→ 42 

■

HTML generated by 3bmd in LispWorks 7.1.2

オブジェクトへのアクセスは、slot-valueを使わず、アクセサ経由でを心掛けようとは良くいわれますが、今回は、MOPでslot-valueを回避できないかを探る試みです。

MOPには、standard-instance-accessのようなものがあるので、アクセスはstandard-instance-accessを直接使ってしまえば良かろうと思って下記のようなものを書いてみました。

アクセサがstandard-instance-accessでアクセスするインデックスを保持できれば良いだけなのですが、class-slots実行以降でしかインデックスは確定しないので、アクセサが別途インデックスを保持するように拡張し、インデックス確定後にアクセサに値を格納することにしました。

(in-package cl-user)
(eval-when (:compile-toplevel :load-toplevel :execute)
  (ql:quickload :closer-mop)
  (when (find-package "3d0ecf39-dd6c-53f5-9672-58d5f5408cc6")
    (delete-package "3d0ecf39-dd6c-53f5-9672-58d5f5408cc6")))
(defpackage "3d0ecf39-dd6c-53f5-9672-58d5f5408cc6"
  (:use :c2cl))
(in-package "3d0ecf39-dd6c-53f5-9672-58d5f5408cc6")
(eval-when (:compile-toplevel :load-toplevel :execute)
  (macrolet ((in-syntax (name)
               `(progn
                  (defvar ,(intern name) (copy-readtable nil))
                  (setq *readtable* ,(intern name))))
             (via-accessor-prefix-setup ()
               `(set-macro-character #\~ (lambda (srm chr)
                                           (declare (ignore chr))
                                           (intern (concatenate 'string 
                                                                (string 'via-accessor-)
                                                                (string (read srm))))))))
    (in-syntax "3d0ecf39-dd6c-53f5-9672-58d5f5408cc6")
    (via-accessor-prefix-setup)))
;; utils
(eval-when (:compile-toplevel :load-toplevel :execute)
  (setf (fdefinition 'a) #'make-instance)
  (defun fintern (package control-string &rest args)
    (with-standard-io-syntax
      (intern (apply #'format nil control-string args)
              (or package *package*))))
  (defmacro <defclass> (name supers slots &rest class-options)
    `(defconstant ,(fintern (symbol-package name) "<~A>" name)
       (defclass ,name ,supers ,slots ,@class-options)))
  #+lispworks
  (editor:setup-indent "<defclass>" 2 2 10)
  'eval-when)
(defclass ~class (standard-class)
  ())
(defmethod validate-superclass ((class ~class) (super standard-class))
  T)
(defclass ~accessor-method (standard-accessor-method)
  ((slot-location :initarg :slot-location 
                  :accessor ~accessor-method-location)))
(defclass ~reader-method (~accessor-method standard-reader-method) 
  ())
(defclass ~writer-method (~accessor-method standard-writer-method) 
  ())
(defun ~reader-method-function-maker (method)
  #+(or lispworks ccl)
  (lambda (arg &rest next-methods)
    (declare (ignore next-methods))
    (funcall (lambda (instance)
               (standard-instance-access instance 
                                         (~accessor-method-location method)))
             arg))
  #+(or sbcl)
  (lambda (args next-methods)
    (declare (ignore next-methods))
    (apply (lambda (instance)
             (standard-instance-access instance 
                                       (~accessor-method-location method)))
           args)))
(defmethod initialize-instance ((method ~reader-method) &rest initargs)
  (apply #'call-next-method 
         method
         :function (~reader-method-function-maker method)
         initargs))
(defun ~writer-method-function-maker (method)
  #+(or lispworks ccl)
  (lambda (val arg &rest next-methods)
    (declare (ignore next-methods))
    (funcall (lambda (val instance)
               (setf (standard-instance-access instance 
                                               (~accessor-method-location method))
                     val))
             val
             arg))
  #+(or sbcl)
  (lambda (args next-methods)
    (declare (ignore next-methods))
    (apply (lambda (val instance)
             (setf (standard-instance-access instance 
                                             (~accessor-method-location method))
                   val))
           args)))
(defmethod initialize-instance ((method ~writer-method) &rest initargs)
  (apply #'call-next-method 
         method
         :function (~writer-method-function-maker method)
         initargs))
(defmethod reader-method-class ((class ~class) direct-slot &rest args)
  (declare (ignore args direct-slot))
  (find-class '~reader-method))
(defmethod writer-method-class ((class ~class) direct-slot &rest args)
  (declare (ignore args direct-slot))
  (find-class '~writer-method))
(defmethod finalize-inheritance :after ((class ~class))
  (let ((esds (class-slots class)))
    (dolist (dsd (class-direct-slots class))
      (dolist (reader (slot-definition-readers dsd))
    (let ((meth (find-method (ensure-generic-function reader :lambda-list '(x))
                 nil
                 (list class)
                 nil)))
      (when meth
            (setf (~accessor-method-location meth)
          (slot-definition-location
           (find (slot-definition-name dsd)
             esds
             :key #'slot-definition-name))))))
      (dolist (writer (slot-definition-writers dsd))
        (let ((meth (find-method (ensure-generic-function writer :lambda-list '(val x))
                 nil
                 (list (find-class T) class)
                 nil)))
      (when meth
        (setf (~accessor-method-location meth)
          (slot-definition-location
           (find (slot-definition-name dsd)
             esds
             :key #'slot-definition-name)))))))))
(defmethod shared-initialize :after ((class ~class) slot-names &rest initargs)
  (declare (ignore slot-names initargs))
  (finalize-inheritance class))

おまけに速くなるのだろうか……

理屈では間接参照のslot-valueと違って直接参照のstandard-instance-accessの方が速くなる筈ですがどうでしょう。
さすがに処理系もslot-valueでのアクセスの最適化はしていると思いますが……。

(<defclass> foo ()
  ((a :initform 0 :accessor .a)
   (b :initform 1)
   (c :initform 2 :accessor .c))
  (:metaclass ~class))
(<defclass> bar (foo)
  ((d :initform 3 :accessor .d))
  (:metaclass ~class))

読み出し速度

LispWorksだと今回の方式の方が若干速くなることもあったりなかったり。 ちなみにSBCL等だと余計なことをするよりslot-valueの方が速いようです……。

(time
 (let ((obj (a <foo>)))
   (dotimes (i (expt 10 6))
     (slot-value obj 'a))))
User time    =        1.240
System time  =        0.000
Elapsed time =        1.242
Allocation   = 1296014992 bytes
0 Page faults
Calls to %EVAL    18000041
(time
 (let ((obj (a <foo>)))
   (dotimes (i (expt 10 6))
     (.a obj))))
User time    =        1.100
System time  =        0.000
Elapsed time =        1.095
Allocation   = 1296011632 bytes
0 Page faults
Calls to %EVAL    17000041

書き込み速度

LispWorksだと読み出し同様、今回の方式の方が若干速くなることもあったりなかったり。 ちなみにSBCL等でも若干速くなるかも。

(time
 (let ((obj (a <foo>)))
   (dotimes (i (expt 10 6))
     (setf (slot-value obj 'a) 42))))
User time    =        7.260
System time  =        0.000
Elapsed time =        7.259
Allocation   = 3126471872 bytes
0 Page faults
Calls to %EVAL    20000041
(time
 (let ((obj (a <foo>)))
   (dotimes (i (expt 10 6))
     (setf (.a obj) 42))))
User time    =        6.020
System time  =        0.060
Elapsed time =        6.074
Allocation   = 3118472872 bytes
0 Page faults
Calls to %EVAL    22000041

今回のまとめ

明示的にstandard-instance-accessを使うようにしても、slot-value経由より遅くなることもあるようなので、もう少し詰めて対策しないと御利益はなさそうです。
標準のオブジェクトへのアクセスは処理系が結構最適化しているのですが、ユーザー定義のメタクラス等の派生物は標準から外れるので処理系が用意している最適化の適用外になってしまうことも多いようです。

なお今回は、アクセス方法でslot-valueを外す試みでしたが、インスタンス初期化まわりでもslot-valueは使われています。
どうもslot-valueを排除するのは簡単な話ではなさそう。

〜インスタンス生成篇へつづく〜

■

HTML generated by 3bmd in LispWorks 7.1.2

;|# はかしこい

どうもiterateのバグを踏んでしまったようなのでソースを眺めていましたが、コード中の ;|# を目にしてこれは賢いなと以前から思っていたことを思い出しました。

• https://gitlab.common-lisp.net/iterate/iterate/blob/master/iterate.lisp#L538

#|
;; Optionally set up Slime so that C-c C-c works with #L
#+#.(cl:when (cl:find-package "SWANK") '(:and))
(unless (assoc "ITERATE" swank:*readtable-alist* :test #'string=)
  (bind ((*readtable* (copy-readtable *readtable*)))
    (enable-sharpL-reader)
    (push (cons "ITERATE" *readtable*) swank:*readtable-alist*)))
;|#

賢いというのは、#|を;でコメントアウトしさえすれば、後ろの|#のメンテナンス(つまり消す)はしなくても良いというところ。

#|
(list 0 1 2)
;|#

(list 0 1 2)を復活したくなった →

;#|
(list 0 1 2)
;|#

Quicklisp中にどれくらい含まれているか検索してみましたが、iterateの他は、clazy、teepeedee2、で使われているくらいのようです。
案外少ないかも?

このブログはteepeedee2で運用されていますが、;|#は、teepeedee2のソースで最初に目にした気がします。

■

HTML generated by 3bmd in LispWorks 7.1.2

Common Lispのパッケージは名前を持ち、その名前は文字列となっています。
さて、それでは長さ0の文字列の場合、どのような挙動になるでしょうか。

ざっと調べてみました。

Allegro CLと、Lucid CLは、(find-package "")でkeywordパッケージを返してきます。
パッケージ名の部分が空であればkeywordパッケージとする、という解釈もそれはそれで整合性がありそうではあります。

リーダーの読み取りの挙動が違っているのかと思いましたが、ちょっと調べてみたら、Allegro CLもLucid CLもニックネームに""が指定されているだけでした。

(package-nicknames :keyword)
→ ("")

ANSI CL規格を確認してみると、keywordパッケージのニックネームはnoneとなっていて拡張の余地がありそうな記述もないので、処理系の独自拡張ということになりそうです。

• 11.1.2 Standardized Packages

まとめ

なかなか面白い処理系拡張です。

(intern "X" "KEYWORD")
→ :x 
   :external 

よりも、

(intern "X" "")
→ :x 
   :external 

の方が直感的な気がしなくもありません。

(rename-package :keyword :keyword '(""))

によってお手軽に実現できますが、""パッケージが使えなくなるので注意しましょう(そんなパッケージ名使われないか)

■

HTML generated by 3bmd in LispWorks 7.1.2

先日、RedditでAllegro CLのstandard-objectのスロットのアクセスを高速化するオプションについての投稿があり、記事を読んでみたのですが、

• Fixed Indices Speed up Slot Access in Allegro CL

第一感としては、何故standard-instance-accessを使わないのだろうか、というところでした。

それとは別にfixed-indexを新機能として紹介していますが、どうも以前にみたことあるなと思ったので、古いAllegro CL 4.3(1996)を確認してみましたが、やはり存在しました。 (パッケージは、clos→exclで移動した模様)
昔からの隠し機能が公になった、というところなのかもしれません。

;;; Allegro CL 4.3
(defclass foo ()
  ((a :initarg :a clos::fixed-index 2 :accessor foo-a)
   (b :initarg :b clos::fixed-index 3 :accessor foo-b)
   (c :initarg :c :accessor foo-c)))
(defvar *foo-inst* (make-instance 'foo :a 1 :b 2 :c 3))
(defvar *vec* (clos::std-instance-slots *foo-inst*))
USER(13): *vec*
#(3 CLOS::..SLOT-UNBOUND.. 1 2)
...

fixed-index系 と standard-instance-access 系は何が違うのか

fixed-index指定は、オブジェクトのスロットの値を保持しているベクタの位置を直に指定するもので、それに加えて、指定されたfixed-indexの最大値とスロットの総数で大きい方をバックエンドのベクタのサイズにするようです。
指定されていない空き地は#<unbound-marker>のようなもので埋まります。

Allegro CLでもAMOPのstandard-instance-accessと slot-definition-locationはサポートしており、fixed-indexの値とも連動しています。
fixed-indexが簡単に実装できないか、standard-instance-access & slot-definition-location 系の処理系を眺めてみましたが、大抵はスロット数のサイズのベクタを隙間なく並べ、先頭から番号を振るようです。

fixed-indexを真似してみる

スロットの値を保持するベクタの確保の方法が難という感じですが、とりあえずLispWorks等で真似できるか試してみます。

(ql:quickload :closer-mop))
(defpackage "4fef36ee-23f6-5dff-beb9-070053d5dbbb" (:use :c2cl))
(in-package "4fef36ee-23f6-5dff-beb9-070053d5dbbb")
;; utils
(eval-when (:compile-toplevel :load-toplevel :execute)
  (setf (fdefinition 'a) #'make-instance)
  (defun fintern (package control-string &rest args)
    (with-standard-io-syntax
      (intern (apply #'format nil control-string args)
              (or package *package*))))
  (defmacro <defclass> (name supers slots &rest class-options)
    `(defconstant ,(fintern (symbol-package name) "<~A>" name)
       (defclass ,name ,supers ,slots ,@class-options))))
(<defclass> fixed-index-slot-class (standard-class)
  ())
(defmethod validate-superclass ((c fixed-index-slot-class) (s standard-class))
  T)
(<defclass> fixed-index-slot-definition (standard-slot-definition)
  ((fixed-index :initform nil
                :initarg fixed-index
                :accessor slot-definition-fixed-index)))
(<defclass> fixed-index-direct-slot-definition
            (fixed-index-slot-definition standard-direct-slot-definition)
  ())
(defmethod direct-slot-definition-class ((c fixed-index-slot-class) &rest initargs)
  (declare (ignore initargs))
  <fixed-index-direct-slot-definition>)
(defmethod compute-effective-slot-definition ((class fixed-index-slot-class) name direct-slot-definitions)
  (declare (ignore name))
  (let ((effective-slotd (call-next-method)))
    (dolist (slotd direct-slot-definitions)
      (when (typep slotd <fixed-index-slot-definition>)
        (setf (slot-definition-location effective-slotd)
              (slot-definition-fixed-index slotd))
        (return)))
    effective-slotd))
(defmethod compute-slots ((class fixed-index-slot-class))
  (let* ((slots (call-next-method)))
    (loop :for idx :from 0 :repeat (length slots) 
          :do (let* ((s (find idx slots :key #'slot-definition-location)))
                (unless s
                  (let ((s (find-if (lambda (x) (null (slot-definition-location x)))
                                    slots)))
                    (when s
                      (setf (slot-definition-location s)
                idx))))))
    (sort (copy-list slots) #'< :key #'slot-definition-location)))

ちなみに、 effective-slot-definition-class周りを定義していませんが、スロットの順番を指定するだけなので、effective-slotはfixed-indexの値を持たせていません。
(アロケーション〜初期化周りを実装するにあたって必要になりそうではあります。)

再現しようとした結果: 飛び飛びに値を保持するベクタをバックエンドにする方法が分からない

→ 方法が分かったので別記事を書きました: Allegro CLのfixed-indexスロット再現リベンジ

上記では、fixed-indexでスロット群の並び順を指定することはできたのですが、LispWorksではアロケーションされたベクタをAllegro CLのfixed-indexの要件を満すように読み書きする方法が分からず仕舞でした。
SBCLはソースが読めるので、そのうち確認してみたいところ。

とりあえず、Allegro CLのfixed-index記事の御題目としては高速化が目的のようなので、速度を計測してみます。

(<defclass> foo ()
  ((a :initarg :a fixed-index 1 :accessor foo-a)
   (b :initarg :b fixed-index 2 :accessor foo-b)
   (c :initarg :c :accessor foo-c))
  (:metaclass fixed-index-slot-class))

;; test
(defparameter *foo-inst* (a <foo> :a 1 :b 2 :c 3))
(declaim (inline std-instance-slots))
(defun std-instance-slots (inst)
  #+allegro (excl::std-instance-slots inst)
  #+sbcl (sb-pcl::std-instance-slots inst)
  #+lispworks (clos::standard-instance-static-slots inst))
(declaim (simple-vector std-instance-slots))
(defparameter *vec* (std-instance-slots *foo-inst*))
(locally
  (declare (optimize (safety 1) (space 1) (speed 3) (debug 0)
                     (compilation-speed 0)))
  (defun p1 () (dotimes (i 10000000) (signum (foo-a *foo-inst*))))
  (defun p2 () (dotimes (i 10000000) (signum (slot-value *foo-inst* 'a))))
  (defun p3 () (dotimes (i 10000000) (signum (svref *vec* 1))))
  (defun p4 () (dotimes (i 10000000) (signum (svref (std-instance-slots *foo-inst*) 1))))
  (defun p5 () (dotimes (i 10000000) (signum (standard-instance-access *foo-inst* 1))))
  )
(progn
  (time (p1))
  (time (p2))
  (time (p3))
  (time (p4))
  (time (p5))
  )

LispWorksの場合

LispWorksではバックエンドのベクタをアクセスする方法がstandard-instance-accessなので、Allegro CLの記事のようにバックエンドをベクタを直接取り出してアクセスしたのとほぼ同一な結果になります。
standard-instance-accessがアクセサの60倍強となりAllegro CLの記事の御題目と似たものとなりました。

Timing the evaluation of (p1)
User time    =        1.870
System time  =        0.000
Elapsed time =        1.868
Allocation   = 10816 bytes
0 Page faults
; (top-level-form 15)
Timing the evaluation of (p2)
User time    =        1.630
System time  =        0.000
Elapsed time =        1.619
Allocation   = 17584 bytes
0 Page faults
; (top-level-form 15)
Timing the evaluation of (p3)
User time    =        0.030
System time  =        0.000
Elapsed time =        0.033
Allocation   = 13184 bytes
0 Page faults
; (top-level-form 15)
Timing the evaluation of (p4)
User time    =        0.040
System time  =        0.000
Elapsed time =        0.035
Allocation   = 0 bytes
0 Page faults
; (top-level-form 15)
Timing the evaluation of (p5)
User time    =        0.040
System time  =        0.000
Elapsed time =        0.039
Allocation   = 0 bytes
0 Page faults

SBCLの場合

SBCLでは、アクセサもslot-valueも standard-instance-accessでのアクセスと同等まで最適化されるので、どれも速いという結果になりました。
良く考えればこれが理想では?

Evaluation took: (p1)
  0.050 seconds of real time
  0.050000 seconds of total run time (0.050000 user, 0.000000 system)
  100.00% CPU
  163,816,326 processor cycles
  0 bytes consed
Evaluation took: (p2)
  0.044 seconds of real time
  0.050000 seconds of total run time (0.050000 user, 0.000000 system)
  113.64% CPU
  145,140,144 processor cycles
  0 bytes consed
Evaluation took: (p3)
  0.020 seconds of real time
  0.020000 seconds of total run time (0.020000 user, 0.000000 system)
  100.00% CPU
  68,159,274 processor cycles
  1,712 bytes consed
Evaluation took: (p4)
  0.022 seconds of real time
  0.020000 seconds of total run time (0.020000 user, 0.000000 system)
  90.91% CPU
  71,779,470 processor cycles
  0 bytes consed
Evaluation took: (p5)
  0.021 seconds of real time
  0.020000 seconds of total run time (0.020000 user, 0.000000 system)
  95.24% CPU
  69,904,809 processor cycles
  0 bytes consed

まとめ

Allegro CLのfixed-index機能は面白いとは思うのですが、高速化ということに限っては、SBCLのように何も指定しなくても、 standard-instance-access を使ったのと同等の所まで最適化してくれる方が望ましいでしょう。
fixed-indexでは、特定の位置に特定のデータを配置したものをクラスを跨いで同一のアクセス方法で処理できたりしそうなので、もっと他の使い方があるのでは……、などと思ったり……。

■

HTML generated by 3bmd in LispWorks 7.0.0

Common Lispでは、実行時、コンパイル時、リード時、その他色々なタイミングでの評価を活用しますが、その制御に専ら使われるのが、eval-whenです。

といっても、大抵eval-whenを使わないか、(:compile-toplevel :execute :load-toplevel)を全部付けるかです。

実際の所は全部盛りを知っていれば問題ないのですが、入れ子になった場合や、全部盛り以外の組み合わせの挙動を確認してみようかなと思います。

指定の組み合わせを眺めてみる

こんな感じのコードで、適当なファイルに組み合わせを書き出します。

(setf (logical-pathname-translations "tem")
      '(("**;*.*.*" "/tmp/**/*.*")))
(with-open-file (*standard-output* "tem:ew.lisp"
                 :direction :output
                 :if-does-not-exist :create
                 :if-exists :supersede)
  (pprint
   (cons
    'progn
    (loop :for w :in '((progn)
                       (eval-when (:execute))
                       (eval-when (:compile-toplevel))
                       (eval-when (:load-toplevel)))
          :collect `(,@w 
                     (eval-when (:compile-toplevel :execute :load-toplevel)
                       (prin1 ',w)
                       (terpri))
                     ,@(loop :for i :from 0
                             :for x :in '(nil
                                          (:compile-toplevel)
                                          (:compile-toplevel :load-toplevel)
                                          (:load-toplevel)
                                          (:compile-toplevel :execute)
                                          (:compile-toplevel :execute :load-toplevel)
                                          (:execute)
                                          (:execute :load-toplevel))
                             :collect `(eval-when ,x
                                         (prin1 '(,i ,x))
                                         (terpri))))))))

書き出した内容

(progn
  (progn
    (eval-when (:compile-toplevel :execute :load-toplevel) (prin1 '(progn)) (terpri))
    (eval-when nil (prin1 '(0 nil)) (terpri))
    (eval-when (:compile-toplevel) (prin1 '(1 (:compile-toplevel))) (terpri))
    (eval-when (:compile-toplevel :load-toplevel) (prin1 '(2 (:compile-toplevel :load-toplevel))) (terpri))
    (eval-when (:load-toplevel) (prin1 '(3 (:load-toplevel))) (terpri))
    (eval-when (:compile-toplevel :execute) (prin1 '(4 (:compile-toplevel :execute))) (terpri))
    (eval-when (:compile-toplevel :execute :load-toplevel)
      (prin1 '(5 (:compile-toplevel :execute :load-toplevel)))
      (terpri))
    (eval-when (:execute) (prin1 '(6 (:execute))) (terpri))
    (eval-when (:execute :load-toplevel) (prin1 '(7 (:execute :load-toplevel))) (terpri)))
  (eval-when (:execute)
    (eval-when (:compile-toplevel :execute :load-toplevel) (prin1 '(eval-when (:execute))) (terpri))
    (eval-when nil (prin1 '(0 nil)) (terpri))
    (eval-when (:compile-toplevel) (prin1 '(1 (:compile-toplevel))) (terpri))
    (eval-when (:compile-toplevel :load-toplevel) (prin1 '(2 (:compile-toplevel :load-toplevel))) (terpri))
    (eval-when (:load-toplevel) (prin1 '(3 (:load-toplevel))) (terpri))
    (eval-when (:compile-toplevel :execute) (prin1 '(4 (:compile-toplevel :execute))) (terpri))
    (eval-when (:compile-toplevel :execute :load-toplevel)
      (prin1 '(5 (:compile-toplevel :execute :load-toplevel)))
      (terpri))
    (eval-when (:execute) (prin1 '(6 (:execute))) (terpri))
    (eval-when (:execute :load-toplevel) (prin1 '(7 (:execute :load-toplevel))) (terpri)))
  (eval-when (:compile-toplevel)
    (eval-when (:compile-toplevel :execute :load-toplevel) (prin1 '(eval-when (:compile-toplevel))) (terpri))
    (eval-when nil (prin1 '(0 nil)) (terpri))
    (eval-when (:compile-toplevel) (prin1 '(1 (:compile-toplevel))) (terpri))
    (eval-when (:compile-toplevel :load-toplevel) (prin1 '(2 (:compile-toplevel :load-toplevel))) (terpri))
    (eval-when (:load-toplevel) (prin1 '(3 (:load-toplevel))) (terpri))
    (eval-when (:compile-toplevel :execute) (prin1 '(4 (:compile-toplevel :execute))) (terpri))
    (eval-when (:compile-toplevel :execute :load-toplevel)
      (prin1 '(5 (:compile-toplevel :execute :load-toplevel)))
      (terpri))
    (eval-when (:execute) (prin1 '(6 (:execute))) (terpri))
    (eval-when (:execute :load-toplevel) (prin1 '(7 (:execute :load-toplevel))) (terpri)))
  (eval-when (:load-toplevel)
    (eval-when (:compile-toplevel :execute :load-toplevel) (prin1 '(eval-when (:load-toplevel))) (terpri))
    (eval-when nil (prin1 '(0 nil)) (terpri))
    (eval-when (:compile-toplevel) (prin1 '(1 (:compile-toplevel))) (terpri))
    (eval-when (:compile-toplevel :load-toplevel) (prin1 '(2 (:compile-toplevel :load-toplevel))) (terpri))
    (eval-when (:load-toplevel) (prin1 '(3 (:load-toplevel))) (terpri))
    (eval-when (:compile-toplevel :execute) (prin1 '(4 (:compile-toplevel :execute))) (terpri))
    (eval-when (:compile-toplevel :execute :load-toplevel)
      (prin1 '(5 (:compile-toplevel :execute :load-toplevel)))
      (terpri))
    (eval-when (:execute) (prin1 '(6 (:execute))) (terpri))
    (eval-when (:execute :load-toplevel) (prin1 '(7 (:execute :load-toplevel))) (terpri))))