先日、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の値を持たせていません。
(アロケーション〜初期化周りを実装するにあたって必要になりそうではあります。)

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

上記では、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))))

書き出したコードを実際にコンパイルしたりロードしたりで実行してみます。

(progn
  (format T "~2&================ :execute~%")
  (load "tem:ew.lisp" :verbose nil)
  (format T "~2&================ :compile-toplevel~%")
  (compile-file "tem:ew.lisp" :verbose nil :print nil)
  (format T "~2&================ :load-toplevel~%")
  (load "tem:ew" :verbose nil :print nil))

結果の確認

上記の結果を評価タイミングごとに眺めていきます。
なお、-toplevelと付いていることからも想像できるように、:compile-とload-はトップレベルに置かれないと評価されません。
また、eval-whenの中はトップレベルなので、入れ子にしてもトップレベル扱いです。

:execute

executeは、実行時の評価です。
式をevalしたり、コンパイルしていないソースファイルをloadした場合のフェイズといえるでしょう。

================ :execute
(progn)
(4 (:compile-toplevel :execute))
(5 (:compile-toplevel :execute :load-toplevel))
(6 (:execute))
(7 (:execute :load-toplevel))
(eval-when (:execute))
(4 (:compile-toplevel :execute))
(5 (:compile-toplevel :execute :load-toplevel))
(6 (:execute))
(7 (:execute :load-toplevel))

トップレベルの式、もしくは :executeが含まれたeval-whenの中だけ評価されているのが分かります。

:compile-toplevel

:compile-toplevelは、コンパイル時です。eval-whenの直下のフォームと入れ子になった:executeが評価されます。
ややこしいのが、コンパイル時には、eval-whenの:load-toplevel指定の中身も見る(=コンパイルする)ことですが、中身は見ますが、内側に:compile-toplevelを指定しないとコンパイル時には評価されません。

================ :compile-toplevel
(progn)
(1 (:compile-toplevel))
(2 (:compile-toplevel :load-toplevel))
(4 (:compile-toplevel :execute))
(5 (:compile-toplevel :execute :load-toplevel))
(eval-when (:compile-toplevel))
(4 (:compile-toplevel :execute))
(5 (:compile-toplevel :execute :load-toplevel))
(6 (:execute))
(7 (:execute :load-toplevel))
(eval-when (:load-toplevel))
(1 (:compile-toplevel))
(2 (:compile-toplevel :load-toplevel))
(4 (:compile-toplevel :execute))
(5 (:compile-toplevel :execute :load-toplevel))

:load-toplevel

:load-toplevelは、コンパイル済みのファイルであるfaslをロードした場合の評価フェイズです。
ロードというと色々ややこしいので、以降、fasloadと呼びます。
fasloadの場合は、:load-toplevelを入れ子にすれば、:load-toplevelの中は評価しますが、:executeの中身はみません。
上述のように:compile-toplevelは入れ子にしても機能しますが、それはコンパイル時に評価されるものなのでfasload時には評価されません。

================ :load-toplevel
(progn)
(2 (:compile-toplevel :load-toplevel))
(3 (:load-toplevel))
(5 (:compile-toplevel :execute :load-toplevel))
(7 (:execute :load-toplevel))
(eval-when (:load-toplevel))
(2 (:compile-toplevel :load-toplevel))
(3 (:load-toplevel))
(5 (:compile-toplevel :execute :load-toplevel))
(7 (:execute :load-toplevel))

応用の考察

マクロ展開時限定で何かを評価するには

マクロはコンパイル時に展開されますが、実行時でも展開される可能性はある(インタプリタ動作の場合)ので下記のようになるでしょうか。
fasloadではコンパイル済みの筈なので、マクロ展開が起きることはありません。

(eval-when (:compile-toplevel :execute)
  ....)

マクロ展開時限定で何かしたいことがあれば……ですが。

defpackageのシンボル汚染問題を解消する

defpackage展開用のパッケージを作成して、コンパイル時のみの評価とすれば、fasload時には展開用のパッケージは存在しなくても良いことになります。

;;; tem:zzz.lisp ファイル
(in-package :cl-user)
(eval-when (:compile-toplevel)
  (defpackage "bfa90b48-5531-5245-9256-8dfb8d9119f3" (:use :cl))
  (in-package "bfa90b48-5531-5245-9256-8dfb8d9119f3"))
(defpackage foo
  (:use cl)
  (:intern a b c))

(compile-file "tem:zzz")
(delete-package "bfa90b48-5531-5245-9256-8dfb8d9119f3")
(load "tem:zzz")
(list (find-symbol "A" :cl-user)
      (find-symbol "B" :cl-user)
      (find-symbol "C" :cl-user)
      (find-symbol "A" :foo))
→ (nil nil nil foo::a) 

良く考えれば、コンパイル時にdefpackageによって使われたシンボルも、別のイメージにfasloadした時には居なくても良いので、cl-userで書いたのと大した違いはないですね。
そう考えると、defpackageのシンボル汚染問題もコンパイル時のイメージ限定なのかなと。

まとめ

はまり所としては、

• :load-toplevelの中の:compile-toplevelがコンパイル時に評価されるというのがややこしい
• loadという関数名と、:load-toplevelという名前が誤解を招く
  • loadでlispファイルを読み込めば:execute
  • loadでfaslファイルを読み込めば:load-toplevel

位でしょうか。

昔のLispでは、faslを読むのにはfasloadという専用関数が使われ、コンパイルしていないファイルにはloadを使ったりしていたようですが、Common Lispでloadに一本化されたようですね。

以上、eval-whenの考察でした。

■

HTML generated by 3bmd in LispWorks 7.0.0

伝説の処理系であるNILですが、先日ソースが発掘され、Software Preservation Groupで公開されたようです。ありがたや!

• NIL (New Implementation of Lisp), S-1 Lisp

このブログでもNILについて何度か記事を書いていますが、要約すれば、MITがMACLISPの後継として作ったLISP処理系で、Common Lispの先祖の一つでありつつ後にNILもCommon Lisp化した処理系です(ややこしい)

NILの概要については、

• #:g1: レトロLisp探検: NIL

あたりが一番まとまった記事かなと思います。

ソースを眺める

早速ソースを眺めてみましたが、雑感をメモしておこうかなと思います。

• LOOPが多用されている。
  • プリミティブなものもLOOPで書かれている(CAR、CDR、MAPCAR…)
  • 本当に多用されているが、LOOPのメンテナであるGSB氏が書いているからかもしれない。
• FEATUREPがある
• Flavorsが組み込み
  • Lisp Machine Lisp、MACLISPの実装ともちょっと違うっぽい
• ハッシュテーブルがFlavorsで実装されている
  • Lisp Machine Lispも同じく(Flavorsよりハッシュテーブルの方が後で導入されたから?)
• IOもFlavors実装が中心
  • Lisp Machine Lispも同じく
• #Tがある(真値)
• 謎の *パッケージがある。
  • 読みは“STAR”らしい。システムの定数が多い。用途未詳。
• 階層パッケージが標準(Lisp Machine Lispと同様)
• FLEXURESがある(スペシャル変数のクロージャー)
• Extendの定義がある(Flavorsとも違うOOPS)
• Patch Systemがある。
• CGOLが内蔵されている
  • MACSYMAユーザーを意識してだろうか
• TAGBODYの定義でタグ環境の表現にFlavorsが使われている
• パッケージはattribute list(-*- ... -*-でお馴染み)で指定するらしい
• コンパイラの名前は H らしい。
  • "This is NIL including the H compiler"
• NIL版のEmacsであるSteveが同梱
• LSBが同梱(MACLISP系処理系のポータブルレイヤー&文書化システム)
• デモプログラムにMYCIN、OPS5、YAQ(Prolog)、FRL(フレーム言語)が同梱
• (lisp-implementation-type) → "NIL, MIT Common Lisp" らしい

副次的ですが、これまで謎だったLSBシステムのコードが発掘されたというのは結構嬉しいです。

全体的なコードに印象ですが、Lispマシングループとは一味違いつつ、MACLISP寄りでありつつもちょっと違う、という感じでしょうか。

等々、他にも沢山面白そうなところはありますが、今後じっくり眺めていきたいと思います。

関連記事

• #:g1: NILの商用版が存在していた!
• #:g1: S-1 Lisp ≡ S-1 Common Lisp ≡ S-1 NIL
• #:g1: NILのマニュアル発見!

■

HTML generated by 3bmd in LispWorks 7.0.0

• competitive:リストをハッシュテーブルのキーにする時は衝突に注意

こちらのエントリーを読んでいて、本筋とはちょっと関係ないのですが、リストに対してのsxhashの返り値が特定の長さからは同じ値を返すということについて興味を持ったので手元の処理系で調べてみました。

調べるのに使ったコードは、下記のようなものです

(loop :for i :from 0 :when (= (sxhash (make-list i)) (sxhash '#0=(nil . #0#))) :return i)

各処理系でリストの sxhash のハッシュ値が区別できなくなる地点

興味本位で、CADR system 78のLisp Machine Lisp(Common Lispの祖先)で試してみたところ、sxhashはどんな長さでも諦めないで計算してくれるようです。
また、循環リストを与えると停止しません。

Lisp Machine Lispと違って、Common Lispで上記のように特定の長さでハッシュ値の計算を打ち切ってしまうのは、sxhashが循環構造のオブジェクトについても停止することが要求されているからでしょう。

• HyperSpec: SXHASH

それにしても、ECLあたりは3つ目以降は区別できないのでリストをキーとして使うのは難しそうです。

まとめ

リストをハッシュテーブルのキーにしたいことは個人的にはこれまで無かったのですが、リストがキーになっているのを目にしない理由もなんとなく分かった気がします。

■

HTML generated by 3bmd in LispWorks 7.1.2

結論: macOSのLispWorks 7.1でgtkを使うにはfinkのgtk+2を使う

macOSのLispWorks 7.1をX11 gtk+2のGUIで使おうと色々と試行錯誤していましたが、finkのgtk+2であれば使えばどうにか使えることが分かりました。
何故finkなのかというと、

• brewでは、XQuartzのgtkが入るのでNG(LispWorksが対応していない)
• macportsのx11-gtkだとLispWorksのフォント周りがおかしくなるので使えない

ので消去法でfinkなのですが、他のパッケージシステムで上手く動かす方法を探求するのも骨が折れるので、finkを導入することで手を打つのが吉でしょう。
macOS版LispWorksのgtk版自体がおまけで付いてきているような感じなのですが、果してgtk版のユーザーっているのでしょうか。

LispWorks 7.1 macOS gtk + fink のセットアップ

macOS LispWorks 7.1/gtk のインストール

macOS版LispWorksのgtk版は、デフォルトではインストールされません。インストーラにgtk版インストールのオプションがあるので有効にしてインストールしましょう。

fink

finkも最近勢いがないようですが(昔からか)、現時点で最新のmacOS 10.14.6でも使えます。
ただ、brewやportsのような手軽さでインストールすることはできないようです。
下記のリンクを参考にソースインストールを実行しますが、インストールにはJDKが必要です(JREではなく)

• finkのダウンロード

JDKを導入した後に、配布されているhelper scriptを実行し、質問にポチポチ答えて行けば、一時間程でインストールできるでしょう。

gtk+2の導入

fink自体のアップデートもできたら、gtk+2のインストールします。

$ /sw/bin/fink install gtk+2

一発でOKですが、macOS 10.14だとバイナリ配布はしていないようなので、暫しビルドに時間が掛ります。

gtk版LispWorksの起動

$ LD_LIBRARY_PATH=/usr/lib:/sw/lib /Applications/LispWorks\ 7.1\ \(64-bit\)/lispworks-7-1-0-amd64-darwin-gtk

のように起動すればOKです。
デフォルトでは起動時にGUI起動してこないので、(env:start-environment)する必要があります。
自動起動したい場合は、初期化ファイルで、

#+(and macosx gtk)
(env:start-environment)

とでもしておけば良いでしょう。

まとめ

macOS版LispWorksをgtkについては、マニュアルにもlibgtk-quartzではなく、libgtk-x11を使えという注意書きがある程度で参考文献が殆どありません。
動いてしまえば、Linux等の通常のgtk版と変わりなく使えるので興味のある方は試してみてはいかがでしょうか。

■

HTML generated by 3bmd in LispWorks 7.1.2

Common Lispのdefpackageというかパッケージ関係の関数全般ですが、internやexportするシンボルの名前の表記にstring designatorが使えるので、

(defpackage "FOO" 
  (:use "CL")
  (:export "FOO" "BAR" "BAZ"))

とシンボル名を文字列で書かずにシンボルで書くことも可能です。

(defpackage foo
  (:use cl)
  (:export foo bar baz))

この場合、シンボル名が使われるので、

(defpackage #.(string 'foo) 
  (:use #.(string :cl))
  (:export . #.(mapcar #'string '(foo #:bar baz))))

のようなことになっていると考えれば良いでしょう。

このstring designatorでのシンボルの表記に各人割とこだわりがみられるので考察してみることにしました。

文字列そのまま

"FOO"、"BAR"等とそのまま書く流儀です。たまに通な人がこの方式で書いてることがあります。

メリットとされること

• 余計なシンボルがインターンされない

デメリットとされること

• リーダーの読み取りケースを変更した環境では上手い具合に馴染まない

しかし、そんな特殊な状況のことを考えてコーディングする必要ってあるんですかね?

シンボル

foo、bar等とそのまま書く流儀です。
一番すっきりしてて良さそうですが、案外少ないです

メリットとされること

• すっきりしている
• リーダーのケースの設定が変化しても良い感じに馴染む(と思われている)

デメリットとされること

• defpackageしたパッケージに余計なシンボルがインターンされる

defpackageは、大抵cl-userでされることが多いですが、cl-userは作業用パッケージなので、多少汚染されても良いんじゃないかという気もしますね。

キーワードシンボル

:foo、:bar等と書く流儀です。
よく見かける流儀です。

メリットとされること

• エディタで良い感じに色付けされる
• パッケージ系関数で一貫した記述ができる(defpackage :foo)、(make-package :foo) vs (defpackage #:foo)、(make-package '#:foo) 等々
• リーダーのケースの設定が変化しても良い感じに馴染む(と思われている)

デメリットとされること

• キーワードパッケージに余計なシンボルがインターンされる

キーワードパッケージが汚染されると開発環境のキーワード補完でゴミが補完されることが多くなるので、案外cl-userが汚染されるより嫌かもしれないですね。

自由(uninterned)シンボル

#:foo、#:bar等と書く流儀です。
これも割と見かける流儀です。 自由(uninterned)シンボルは、不要になったらGCされるので、細かいことを気にする人に好まれています。

メリットとされること

• 余計なシンボルがインターンされない
• エディタで良い感じに色付けされる
• リーダーのケースの設定が変化しても良い感じに馴染む(と思われている)

デメリットとされること

• #:がウザい

第四の方法を考えてみた

見た目がウザいので自由(uninterned)シンボルで書きたくない、パッケージも汚染したくない、というのを両立させるとしたら、一時パッケージを作成し、その中でdefpackageすれば良いでしょう。

(defpackage "FOO-META" (:use))
(in-package "FOO-META")
(cl:defpackage foo
  (:use cl)
  (:export foo bar baz))
(cl:in-package "CL-USER")
(delete-package "FOO-META")

SBCLならこんな風に書けたりもします。

foo-meta::
(cl:defpackage foo
  (:use cl)
  (:export foo bar baz))

まあ、でもめんどくさいですね。

まとめ

ファイルをロードする時に、暗黙のうちに*package*をcl-user、*readtable*を標準のリードテーブルであると仮定しているコードは、Quicklispの大半を占めますが、それに起因するバグも思いの外多いです(Quicklispのパッケージを1000パッケージ位ロードしてみると体験できます)

作業用パッケージ(とリードテーブル)を作成して、そこでdefpackageするのが吉なのかなあ等々考えていますが、作業用パッケージを作成するなら、余計なシンボルのインターンについても考えなくて良さそうですね。

ちなみにこの記事を書くにあたって、文字列、シンボル、キーワード、自由(uninterned)シンボルの大き目のリストを作成して読み取りの速度を計時してみましたが、大抵の処理系ではシンボルや文字列が速く、一番遅いのは自由(uninterned)シンボルのリストでした。
読み取りスピード的にも普通のシンボルで書くのが有利っぽいですが、極端なことをしない限りは有意な差にはならないでしょう。

以上、特にまとまりもない記事でした。

■

HTML generated by 3bmd in LispWorks 7.0.0

思えば、Common Lispでアリティ(引数の個数)の不整合でエラーを喰らうのは実行時が多い気がしますが、ANSI Common Lisp規格ではコンパイル時に弾くことってできないんでしょうか。

……と思ってHyperSpecにあたってみましたが、コンパイル時にアリティの不整合を検知した場合には、エラーにしてしまうコンパイラがあっても良さそうではありました。

• Common Lisp HyperSpec: 3.2.2.3 Semantic Constraints

Common Lispは動的言語なので、実行時でも関数等の再定義が可能ですが、上記の3.2.2.3 Semantic Constraintsを眺める限りでは、どちらかといえば、コンパイラ動作の方に重きを置いているように見え、再定義されなくても良い場合を幾つか挙げています。

逆に再定義が保証されることを主として考えるとすると、少なくともnotinline宣言がついてない場合の再定義は、関数が実行時に確実に置き換わることは期待できなさそうです。

また、コンパイラ/インタプリタ動作の整合性とは別に、アリティのチェックについても記載がありますが、エラーは、実行時もしくはコンパイル時に挙げるとあります。

• 3.5.1.1.1 Error Detection Time in Safe Calls

上記は、関数呼び出し時のエラーについての規定なので、基本的に実行時エラーだけで良さそうにも思えますが、マクロ展開等も考慮するとコンパイル時も含めないといけないのでしょうか。
ともあれ、safe callの観点からもコンパイル時に検出することも可能ではありそうです。

ちなみに、組み込み関数はsafe callの観点からすると、アリティの不整合はコンパイル時にエラーにできそうです。

• 3.5.1.1 Safe and Unsafe Calls

処理系の実際を確認する

呼出しのアリティに不整合があった場合にコンパイルエラーになっても良さそうではあるのですが、実際の処理系の挙動を確認してみました。

このようなファイルをコンパイルして、

(defun foo (x y)
  (list x y))
(defun bar (x y)
  (foo x))

下記のように実行してみます。

(bar 1 2)
>>> invalid number of arguments: 1

処理系のメジャーなところは一通り確認してみましたが、コンパイルエラーにする処理系はECLのみのようで、他は警告は出すもののコンパイルは通し、faslをloadして実行したら当然実行時エラーです。
まあ大体Common Lispってこんな感じの動作でしたね、というところ。
むしろECLの動作のほうが意外かもしれません。

アリティの不整合をコンパイルエラーにしたい

さて、規格上はコンパイル時にアリティの不整合を検出してエラーにしても良さそうだけれど、実際のところデフォルトでそういう挙動をする処理系は、殆ど存在していないことが分かりました。

コンパイル時でもなんでもできるCommon Lispなので、工夫はあれこれできそうですが、とりあえずコンパイラマクロを試してみましょう。
とりあえずは、何もしないコンパイラマクロを定義するのみですが、展開時に引数チェックでエラーになることが期待できます。

(defun foo (x y)
  (list x y))
(define-compiler-macro foo (x y)
  `(foo ,x ,y))
(defun bar (x y)
  (foo x))

軒並エラーになると予想していましたが、コンパイルが通ってしまうものもある様子。
これは、積極的にエラーにする他ないのかもしれません。
ということで下記のように書いてみました。

(eval-when (:compile-toplevel :load-toplevel :execute)
  (define-condition argument-mismatch (program-error)
    ((form :initarg :form :reader argument-mismatch-form)
     (text :initarg :text :reader argument-mismatch-text))
    (:report (lambda (c s)
               (format s
                       "~A:~%~S~%"
                       (argument-mismatch-text c)
                       (argument-mismatch-form c))))))
(defun foo (x y)
  (list x y))
(define-compiler-macro foo (&whole w &rest args)
  (etypecase (length args)
    ((eql 2) w)
    ((integer * 1)
     (error 'argument-mismatch :text "Too Few Arguments" :form w))
    ((integer 3 *)
     (error 'argument-mismatch :text "Too Many Arguments" :form w))))
(defun bar (x y)
  (foo x))

しかし、SBCL、Allegro CLはコンパイルを通す様子。

SBCLでは、トラップしたいなら、*break-on-signals*を設定しろと警告が出るので、SBCL、Allegro CL、CMUCLはそういうポリシーなのでしょう。

; caught WARNING:
;   Error during compiler-macroexpansion of (FOO X). Use *BREAK-ON-SIGNALS* to
;   intercept.
;   
;    Too Few Arguments:
;   (FOO X)

まとめ

Common Lispでアリティの不整合をコンパイルエラーにする方法を探ってみましたが、

• アリティの不整合のコンディションを作成
• *break-on-signals*に適宜設定
• コンパイラマクロで引数チェック

の組み合わせで大抵の処理系では実現できそうです。

ちなみに、型の不整合もチェックしたいところですが、SBCLであれば、今回のコンパイラマクロの手法を応用して、deftransformあたりを使えばできなくもなさそう。

■

HTML generated by 3bmd in LispWorks 7.0.0

先日、LISP 1.5をお題にした、n月刊ラムダノート Vol.1, No.2(2019) / LISP 1.5の風景（川合史朗）が刊行されましたが、この稀にしか来ないLISP 1.5の波に乗らざるを得ない!!ということで、レトロコンピューティング好きの私は、十二年前に書いたLISP 1.5のエミュレータの記事をアップデートすることにしました。
(そういえばそもそも私はレトロコンピューター熱が高じてLispを始めたのでした)

• 45年前の処理系 元祖LISP 1.5 を試してみる

上記記事ではエミュレータ関係のリンク切れ等が多くて、記事の内容を再現できない状態だったので、その辺りを修正しました。

なお、「LISP 1.5の風景」では、Gauche上にMeta*LISPというLISP 1.5の処理系を実装しつつLISPの原初を紐解いていくという内容なので、とてもお勧めです。

1960年の処理系 元祖LISP 1.5 を試してみる

先日は、PDP-1のエミュレータで、PDP-1 Lispを動かしてみましたが、やっぱり元祖である、LISP 1.5も動かしてみたいところ。
でも、さすがに、50年前のIBM7094の環境はかなり厳しいだろうと思いつつ、調べてみたら、なんとこれも簡単に動かせるようにまとめている方がいました。
約60年前の環境が再現できるというのは色々な意味で凄い。まず、データが保存されていて、今日のコンピュータで読めるってのが凄い。

lisp 1.5の環境がまとめられたファイルがあるのでダウンロードし、simhのibm7094で実行できるようにすればOKです。

手短にまとめると、準備するものとしては、

• SIMH (の中のibm7094のエミュレータである、i7094)
• Running Lisp 1.5 in the SIMH IBM 7094 emulator(lisp15.tar.gz)

が必要です。

simhのi7094は、Debian GNU/Linuxや、Ubuntuであれば、

$ sudo apt install simh

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

次にLISP 1.5環境の準備ですが、

$ tar xvf lisp15.tar.gz
$ cd lisp15
$ tar xvf utils-1.1.8.tar.gz
$ cd utils && make

とし、lisptape.iniの! txt2bcd -s %1 scratch/lisp.job.mtというのを、! utils/txt2bcd -s %1 scratch/lisp.job.mtに書き換えます。
(txt2bcdをパスの通った所に設置しても良いですが)

上記のファイルを揃えて設定すれば、IBM 7094でLISP 1.5のバッチジョブを流せます。
しかし、若干面倒なので、Emacsのcompileを使って、バッチ処理のシェルスクリプトを起動させてみることにしました。
とはいえ、適当なでっち上げなので、試したい方は各自作成されると良いと思います。
自分の環境では、lisp1.5:loadというcompileをラップした関数と、シェルスクリプトの組み合わせで*compilation*バッファに結果が表示されるようにしてみました。

バッチ用シェルスクリプト(load-lisp1.5)

#!/bin/sh
INFILE=$1
EMUDIR=/l/lisp-1.5 # lisp 1.5セットのディレクトリを指定
TEM=cur.job

cd $EMUDIR
pwd
[ -f sys.log ] && rm sys.log
printf "       TEST  FOO\n\n" > $TEM
cat $INFILE >> $TEM
printf "\n\nSTOP)))   )))   )))   )))\n       FIN      END OF LISP RUN\n" >> $TEM
i7094 lisptape.ini $TEM
cat sys.log

Emacsのcompile関数をラップしたバッチ処理を呼び出す関数

(defun lisp1.5:load ()
  (interactive)
  (let ((compile-command (concat "~/bin/load-lisp1.5 " (buffer-file-name))))
    (compile compile-command)))

これで若干対話的にコードが書けるようになったので、適当に試してみます。

reverseとmapcarを作ってみる

define ((
(r1 (lambda (m l)
      (cond ((null l) m)
        ((quote t) (r1 (cons (car l) m) (cdr l))))))
(reverse (lambda (u) (r1 () u)))
(mapcar (lambda (lst fn)
      (prog (l res)
         (setq l lst)
         again
         (cond ((null l) (return (reverse res))))
         (setq res (cons (fn (car l)) res))
         (setq l (cdr l))
         (go again))))
))
mapcar((1 2 3 4)
       (quote (lambda (x) (plus 10 x))))
cond(((quote t) (print (quote hello))))

今日からみると色々変ったところが多いのですが、まず、トップレベルで関数に外側の括弧が付いてなかったりします。
これは、evalquoteと呼ばれるらしいですが、evalで評価するか、applyで評価するかと考えれば良い、と The Evolution of Lisp に書いてました。ちなみにInterlispでは、evalquoteの形式でコーディングできます。
それで、マニュアルを見る限りではreverseは標準で付いてくるっぽいのですが、見付からないので作ってみました。
mapcarの引数の順番が関数とリストとで逆ですが、元々は、リスト→関数の順番だったようです。これまたInterlisp系では、伝統に則ってCommon Lisp(Maclisp系)とは逆です。

結果

MTA: unit is read only
LPT: creating new file
HALT instruction, PC: 10524 (TRA 10523)
Goodbye
             TAPE    SYSTMP,B3
   B3 IS NOW LISP SYSTMP.
             TAPE    SYSTAP,A4
   A4 IS NOW LISP SYSTAP.
             TAPE    SYSPOT,A3
   A3 IS NOW LISP SYSPOT.
             TAPE    SYSPPT,A7
   A7 IS NOW LISP SYSPPT.
             TEST  WHATEVER
  THE TIME ( 0/ 0  000.0) HAS COME, THE WALRUS SAID, TO TALK OF MANY THI
NGS .....   -LEWIS CARROLL-
 EVALQUOTE OPERATOR AS OF 1 MARCH 1961.    INPUT LISTS NOW BEING READ.

  THE TIME ( 0/ 0  000.0) HAS COME, THE WALRUS SAID, TO TALK OF MANY THI
NGS .....   -LEWIS CARROLL-
  FUNCTION   EVALQUOTE   HAS BEEN ENTERED, ARGUMENTS..
 DEFINE
 (((R1 (LAMBDA (M L) (COND ((NULL L) M) ((QUOTE T) (R1 (CONS (CAR L) M)
(CDR L)))))) (REVERSE (LAMBDA (U) (R1 NIL U))) (
 MAPCAR (LAMBDA (LST FN) (PROG (L RES) (SETQ L LST) AGAIN (COND ((NULL L
) (RETURN (REVERSE RES)))) (SETQ RES (CONS (FN (
 CAR L)) RES)) (SETQ L (CDR L)) (GO AGAIN))))))

 END OF EVALQUOTE, VALUE IS ..
 *TRUE*
  FUNCTION   EVALQUOTE   HAS BEEN ENTERED, ARGUMENTS..
 MAPCAR
 ((1 2 3 4) (QUOTE (LAMBDA (X) (PLUS 10 X))))

 END OF EVALQUOTE, VALUE IS ..
 (11 12 13 14)
  FUNCTION   EVALQUOTE   HAS BEEN ENTERED, ARGUMENTS..
 COND
 (((QUOTE T) (PRINT (QUOTE HELLO))))

 HELLO
 END OF EVALQUOTE, VALUE IS ..
 HELLO
  THE TIME ( 0/ 0  000.0) HAS COME, THE WALRUS SAID, TO TALK OF MANY THI
NGS .....   -LEWIS CARROLL-
 END OF EVALQUOTE OPERATOR
             FIN      END OF LISP RUN

なんでか知りませんが、ルイス・キャロルの文言が引用されてたりします。
若干わかりづらいですが、END OF EVALQUOTE, VALUE IS ..の後が評価結果です。なんとなく良い味を醸し出しています。
やっぱり手近に処理系があって手軽に試せるというのは良い！

PDFのマニュアルもあるので、これを見ながらLISP 1.5を探索してみるのも面白いと思います。

• LISP 1.5 Programmer's Manual

■

HTML generated by 3bmd in LispWorks 7.0.0

久々に2ch(5ch)のCommon Lispスレを眺めてみたら面白そうな質問が放置されているのをみつけました。

• 【入門】Common Lisp その11【質問よろず】/573

573デフォルトの名無しさん2019/06/15(土) 16:34:52.25ID:5WxVHbel
defmacroだとdestructuring bind?が使えて
(defmacro test ((a b &optional c) d)
(print (list a b c d))
nil)
(test (1 2) 4) => (1 2 NIL 4)
みたいに書けるけど、&optionalや&keyの後に書こうとしてもSBCLだとdefmacroを評価した時点でエラーになる
&restの後ろには一応書けるっぽい
必須引数と&restの所には書けるけど、&optionalと&keyの所には書けないという認識で良いのか？
もし&optionalの所に書けるなら書き方を教えてくれ 

若干質問の主語が不明瞭ですが、多分、&restや、&optionalや&keyの後に変数だけでなく再帰的な複合パタンが書けるのかという質問かなと思います。
端的にいうと規格で再帰的な複合パタンが利用できることが定義されているので、規格準拠の処理系なら書けます。

• 3.4.4.1.2 Lambda-list-directed Destructuring by Lambda Lists

試しに書いてみると、

(defmacro foo (&optional ((a &rest b &key ((^c (c &optional (d "d" d?))) '("c") c?)) '("a") a?))
  `'(,a ,b ,c ,a? ,c? ,d ,d?))
(foo)
→ ("a" nil "c" nil nil "d" nil) 
(foo (a ^c (c)))
→ (a (^c (c)) c t t "d" nil) 
(foo (a :c (c) :allow-other-keys T))
→ (a (:c (c) :allow-other-keys t) "c" t nil "d" nil) 

なお、&rest、&optionalや&keyで変数でなく複合パタンを指定した場合、省略時の値がパタンに適合していることに留意する必要があります。

■

HTML generated by 3bmd in LispWorks 7.0.0

Rubyは、Lispである、いや違う。Schemeこそ至高のLisp、いやLispじゃない等々、「○○がLispであるか、そうでないか」は自転車置場の議論ネタとしては定番です。
個人的にこの10年位、MACLISP系方言を中心に色々なLispを眺めてきましたが、LispかLispでないかの簡単な判断基準があると思いはじめました。

言語名にLispと入っていればLisp

簡単な判断基準とは、「言語名にLispと入っていればLisp」です。
馬鹿馬鹿しい程単純な理屈ですが、それなりに個人的には納得感があります。

LISP 1.5を本流とすれば、それを継承せんとする言語は、○○Lispと名乗ってきました。
そこから外れるということは、何らかの分派を表明せんがため、ということが多いように思います。

例えば、Schemeは、Planner→Conniver→(Plasma)→Scheme(→Racket)という命名の流れを踏襲したというのもありますが、全面的なレキシカルスコープの採用等、既存のLispから訣別し新しい流れを作るという点で別の名前になった意味はそれなりに大きかったでしょう(当初はそうでなくても)。
近頃だと、Schemeの流れでRacketが分派しましたが、PLT Schemeから、Racket Schemeにならずに、Racketになったのも、そういった意思表明であると思います。

Schemeと同じく、Algolとの融合を図ってレキシカルスコープの採用や、Algol構文を軸に据えたものにLISP 2がありますが、これはLISP 1.5の流れを分派というより上書きしようとしたと考えられるので、これはこれでLISPを冠した命名の流れでしょう。結局こちらのLISPの流れは成功しませんでしたが。

翻ってLISP 1.5→MACLISP(LISP 1.6)→Lisp Machine Lisp→Common Lisp & Emacs Lisp→ISLISPは、Lisp 1.5から続く資産を活用することに腐心して来たわけですし、実際コードもほぼ修正なしで動きます(Emacsはエディタに特化している所があるので若干苦しいですが)。

newLISPなどは若干変わり種ですが、古来のLispがサポートしていたもののCommon Lispで消滅したfexprをサポートするなど、Common Lispとはまた違った古来のLispを継承している所はあります。

また、ClojureがClojure Lispとしなかったのも、Lispをバックグラウンドとした新言語という意味でしょう。

まとめ

何より設計者、コミュニティがLispと名乗りたいと思って言語にLispと付けているからには、なんらかの設計思想の継承を意図しているのでしょうし、別の名前にするからには、なんらかの訣別があると思いますから、一つの線引きの基準になるでしょう。

ちなみに、類似の話として、Lisp系言語でないものについて「○○は本質的にLisp、いや違う」等の議論ネタがありますが、Lispがプログラミング言語の進化/発明においてあまりにも源流に近すぎるため、影響を排除することが難しく、極言すると同時代に誕生したFortranやAlgol以外、今時の主流のパラダイムのどんな言語にでも成立してしまうので、ほぼ意味がない話かなと思っています。

■

HTML generated by 3bmd in LispWorks 7.0.0

Sun(今やOracle)のSPARCプロセッサにはLisp向けにタグ命令が実装されている(いた)という話を耳にされたことはないでしょうか。

具体的には、TADDCC、TSUBCC系の命令で、タグ付きポインタの演算を支援する機能です(ちなみに残念ながら現在では非推奨の機能らしい)。

それはともかく、ウェブを検索したら、当時のLucidだったEric Benson氏がこの機能についての質問に回答していたメールをみつけました。

• Re: SPARC tagged data

Yes, the tagged arithmetic instructions were put in the SPARC architecture
for Lucid Common Lisp. If the low-order two bits of a Lisp object
reference are zero, it is a 30-bit immediate fixnum. If some of those
bits are non-zero, it may be a pointer to a floating point number or a
bignum (arbitrary-precision integer). Generic arithmetic is generally
optimized for the fixnum case, since the overwhelming majority of
arithmetic is performed on small integers. On many machines + is compiled
inline as

      Test low order two bits of first operand.
          If nonzero, use general case. (Operand could be a float or bignum.)
      Test low order two bits of second operand.
          If nonzero, use general case. (Operand could be a float or bignum.)
      Add two operands.
      If overflow, use general case. (Result is a bignum).

On the SPARC this is done as one instruction (TADDCC) followed by a
conditional branch rarely taken.

メールによると、SPARCのこの命令は、Lucid CLのために入ったらしいのですが、Lucidは、SunにCommon Lisp処理系をOEM提供しており、Sun Common Lispとして販売されていたりで、LucidとSunはかなり密接な関係でした。

時代的にも当時は第二次AIブーム末期で、エキスパートシステムやCAD等、高価なSymbolics等の専用マシン上で稼動していたLispベースのアプリケーションを比較的廉価なワークステーション上でも動したいというニーズも高かった頃です。

Lucid Common Lispではどう活用しているのか

Lucid CLのために命令が導入されたのはよしとして、実際にどんな感じで活用されていたのか確認してみましょう。

とりあえず、2引数のfixnumの足し算をコンパイルしてdisassembleしてみます。

> (proclaim '(optimize (compilation-speed 0) (speed 3) (safety 3)))
t
> (disassemble (compile nil '(lambda (x y) (declare (fixnum x y)) (the fixnum (+ x y)))))
;;; You are using the compiler in PRODUCTION mode (compilation-speed = 0)
;;; If you want shorter compile time at the expense of reduced optimization,
;;; you should use the development mode of the compiler, which can be obtained
;;; by evaluating (proclaim '(optimize (compilation-speed 3)))
;;; Generation of full safety checking code is enabled (safety = 3)
;;; Optimization of tail calls is enabled (speed = 3)

        cmp         %u0, 8
        tne         16
        taddcctv    %in0, %in1, %loc0
        move        %loc0, %in0
        jmpl        %0, %ra + 8
        restore     %0, 4, %u0
nil

taddcctv(Tagged Add, modify icc and Trap on Overflow)というのがお目当ての命令ですが、探してみてもどうも専らtaddccではなく、tv付きが使われるようです。

safety 0にしてみると、

> (proclaim '(optimize (compilation-speed 0) (speed 3) (safety 0))) 
t
> (disassemble (compile nil '(lambda (x y) (declare (fixnum x y)) (the fixnum (+ x y)))))
;;; You are using the compiler in PRODUCTION mode (compilation-speed = 0)
;;; If you want shorter compile time at the expense of reduced optimization,
;;; you should use the development mode of the compiler, which can be obtained
;;; by evaluating (proclaim '(optimize (compilation-speed 3)))
;;; Generation of runtime error checking code is disabled (safety = 0)
;;; Optimization of tail calls is enabled (speed = 3)

        taddcctv    %in0, %in1, %loc0
        move        %loc0, %in0
        jmpl        %0, %ra + 8
        restore     %0, 4, %u0
nil

となり、アリティのチェックが省略されるようです。

しかし、CMUCLでも活用されていた

さすがLucid CL用に用意されただけあるなと思いましたが、CMUCL 17fのdisassemble結果を眺めたりしていた所、CMUCLでも活用されているのをみつけてしまいました。

CMU Common Lisp 17f, running on sun4
Send bug reports and questions to cmucl-bugs@cs.cmu.edu.
Loaded subsystems:
    Python 1.0, target SPARCstation/Sun 4
    CLOS based on PCL version:  September 16 92 PCL (f)
* 
* (proclaim '(optimize (compilation-speed 0) (speed 3) (safety 3)))
EXTENSIONS::%UNDEFINED%
* (disassemble (compile nil '(lambda (x y) (declare (fixnum x y)) (the fixnum (+ x y)))))
Compiling LAMBDA (X Y): 
Compiling Top-Level Form: 
070BFCA8:       .ENTRY "LAMBDA (X Y)"(x y)   ; (FUNCTION (FIXNUM FIXNUM) FIXNUM)
      C0:       ADD   -18, %CODE
      C4:       ADD   %CFP, 32, %CSP
      C8:       CMP   %NARGS, 8              ; %NARGS = #:G1
      CC:       BNE   L0
      D0:       NOP
      D4:       TADDCCTV %ZERO, %A0          ; %A0 = #:G2
      D8:       TADDCCTV %ZERO, %A1          ; %A1 = #:G3
      DC:       TADDCCTV %A1, %A0            ; No-arg-parsing entry point
      E0:       MOVE  %CFP, %CSP
      E4:       MOVE  %OCFP, %CFP
      E8:       J     %LRA+5
      EC:       MOVE  %LRA, %CODE
      F0: L0:   UNIMP 10                     ; Error trap
      F4:       BYTE  #x04
      F5:       BYTE  #x19                   ; INVALID-ARGUMENT-COUNT-ERROR
      F6:       BYTE  #xFE, #xEB, #x01       ; NARGS
      F9:       .ALIGN 4
* (funcall (compile nil '(lambda (x y) (declare (fixnum x y)) (the fixnum (+ x y)))) most-positive-fixnum most-positive-fixnum)
Compiling LAMBDA (X Y): 
Compiling Top-Level Form: 
1073741822

しかし、Lucid CLと違うのは、safety 0にすると普通のaddになってしまう所。

(+ most-positive-fixnum most-positive-fixnum)が-2になってしまっています。

* (proclaim '(optimize (compilation-speed 0) (speed 3) (safety 0)))
EXTENSIONS::%UNDEFINED%
* (disassemble (compile nil '(lambda (x y) (declare (fixnum x y)) (the fixnum (+ x y)))))
Compiling LAMBDA (X Y): 
Compiling Top-Level Form: 
071A11F8:       .ENTRY "LAMBDA (X Y)"(x y)   ; (FUNCTION (FIXNUM FIXNUM) FIXNUM)
     210:       ADD   -18, %CODE
     214:       ADD   %CFP, 32, %CSP
     218:       ADD   %A1, %A0               ; No-arg-parsing entry point
     21C:       MOVE  %CFP, %CSP
     220:       MOVE  %OCFP, %CFP
     224:       J     %LRA+5
     228:       MOVE  %LRA, %CODE
     22C:       UNIMP 0
* (funcall (compile nil '(lambda (x y) (declare (fixnum x y)) (the fixnum (+ x y)))) most-positive-fixnum most-positive-fixnum)
Compiling LAMBDA (X Y): 
Compiling Top-Level Form: 
-2

Lucid CLでは、safety 0でもtaddcctvはそのままでbignumに切り替えます。

> (proclaim '(optimize (compilation-speed 0) (speed 3) (safety 0)))
t
> (disassemble (compile nil '(lambda (x y) (declare (fixnum x y)) (the fixnum (+ x y)))))
;;; You are using the compiler in PRODUCTION mode (compilation-speed = 0)
;;; If you want shorter compile time at the expense of reduced optimization,
;;; you should use the development mode of the compiler, which can be obtained
;;; by evaluating (proclaim '(optimize (compilation-speed 3)))
;;; Generation of runtime error checking code is disabled (safety = 0)
;;; Optimization of tail calls is enabled (speed = 3)

        taddcctv    %in0, %in1, %loc0
        move        %loc0, %in0
        jmpl        %0, %ra + 8
        restore     %0, 4, %u0
nil
> (funcall (compile nil '(lambda (x y) (declare (fixnum x y)) (the fixnum (+ x y)))) most-positive-fixnum most-positive-fixnum)
1073741822

この辺りの違いは、Lucid CLの方がtaddccを活用しているといえるのか、それとも処理系のポリシーの違いなのか。

まとめ

まとめらしいまとめはないですが、Common Lispの処理系のためにCPUに命令が追加されたと思うとSPARCが素晴らしいCPUに見えてきました。
(SPARCプロセッサも大分勢いが無くなってきましたが……)

■

HTML generated by 3bmd in LispWorks 7.0.0

以前にLucid Common Lispが動く環境を構築していたのですが、久し振りに起動してみようと思ったところ全く手順を忘れていたのでメモしておきたいと思います。

構築する環境

• SunOS 4.1.4/SPARC
• Lucid Common Lisp SunOS/SPARC版

用意するもの

• qemu 2.12.1
• Lucid CLのバイナリ
• Lucid Emacs

Lucid CLとLucid EmacsのSunOS/SPARC版は両方ともArchive Team: Various Lucid Packagesに含まれているので探してみましょう。

qemuの準備

qemu 3からvlanオプションが廃止されたようで、netdevオプションを使うことになりましたが、qemu-system-sparcで上手く指定できなかったので、しょうがなく2系統を使うことにしました。

ソースからは下記のようにオプションを指定してビルド可能です。

$ ./configure --target-list=sparc-softmmu
$ make

QEMU/SunOS 4.1.4のセットアップについては下記を参考にしました。

• QEMU/SunOS 4.1.4

Linux tapの設定

sudo modprobe tun 
sudo tunctl -t sunostap0 -u $USER
sudo ifconfig sunostap0 10.0.2.2 netmask 255.255.255.0

のようにしてtapを作成しておきます。
sunostap0というのは好きな名前でOKです。

qemuの起動

qemu-system-sparc -bios ss20_v2.25_rom -M SS-20 -nographic -boot d -hda  sunos414.img -m 512 -smp 2,cores=2 -cpu "TI SuperSparc 60" -net nic,vlan=0 -net tap,vlan=0,ifname=sunostap0,script=no,downscript=no

のようなオプションで起動します。

SunOS 4.1.4の起動

起動の手順がめんどうなので、expectでスクリプトを作成し、それで起動します。
私の手元では、何故かシングルユーザーで起動してからマルチユーザーにしないとおかしなことになりますが、とりあえずスルーすることにします。

#!/bin/sh
cd /vm/sunos-4.1.4
expect -c "
set timeout -1
spawn /vm/sunos-4.1.4/boot-sun4.sh 
expect \"ok \"
send \"setenv sbus-probe-list f\r\"
expect \"ok \"
send \"reset\r\"
expect \"ok \"
send \"boot disk0 -s\r\"
expect \"# \"
send \"ifconfig le0 10.0.2.15\r\"
send \"route add default 10.0.2.2 1\r\"
send \"\exit\r\"
expect \"Program terminated\"
send \"power-off\"
"

rshの設定

sshは存在しない時代ですが、rshは存在します。
telnetより便利なので、rshの設定をしておきます。

これまでの設定の場合、

$ rsh 10.0.2.15

で接続可能です。

X環境の設定

Lucid CLは、ターミナルでも使えますが、Lucid CL 4.0あたりだとLucid Emacsと組み合わせて使うことが想定されているようで、このLucid EmacsがX環境でしか起動しないので、Xの環境も構築することにします。
SunOSのウィンドウをリモートで表示したいのですが、昔と違ってセキュリティ周りが色々厳しくなっているので、色々と面倒なので、個別のVNCサーバを起動して、そこで表示させることにします。

#!/bin/sh
vncserver -geometry 1600x900 :41 -listen tcp
export DISPLAY=$(hostname):41.0
xhost +
openbox

上記では、41番ディスプレイを指定した例ですが、-listen tcpというのがミソで、明示的にこの指定がないとローカルからしか接続できません(リモートホストのアプリがディスプレイを開けない)

ILISPの設定

(require 'ilisp)
(setq cmulisp-program "/usr/local/bin/lisp")
(setq lucid-program "~/bin/xlt-ansi") 

この設定の場合、M-x run-ilispすると、Lucid CLかCMUCLかを選択して起動できます。

xltの起動

(xlt:xlt)

で起動します。
XLTは、クラスブラウザ、プロファイラ、Apropos、オブジェクトのクリップボード(xlt:*0*に代入される)、等々の機能があり、Emacsの開発環境を補助するようなGUIのユーティリティ集というところです。
Allegro CLだと、Allegro Composerという類似のツール集があります。
基本的にSymbolicsの使い勝手をUnix+Emacs上で再現するというのが、1990年代初頭の定番だった様子。

関連記事

• #:g1: Lucidの遺跡からCommon Lisp処理系を発掘する
• #:g1: Lispとエディタ (6)

■

HTML generated by 3bmd in LispWorks 7.0.0

Common Lispにおけるクラスメソッド

SmalltalkやRubyのようにクラスメソッドがある言語のコードをCommon Lispに移植したり、参考にして書いたりしているときに、クラスメソッドに相当する挙動が欲しくなったりするのですが、メタクラスの構成が違うので、そのまま書き写しただけでは、思ったような挙動にはなりません。

Common Lispでそのまま書き下すと大抵以下のようになりますが、

(defclass foo () ())
(defclass bar (foo) ())
(defmethod zot ((c (eql (find-class 'foo))))
  "zot")
(zot (find-class 'foo))
→ "zot" 
(zot (find-class 'bar))
!! No applicable methods

barクラスに対してはfooのクラスメソッドを起動しません。

Smalltalk/Rubyは、クラスごとにメタクラスが存在し、クラスの継承関係とメタクラスの継承関係は同様の構成になりますが、Common Lispでは、クラスメタオブジェクトのクラスをメタクラスと呼んでいるだけなので、同じメタクラスのクラスメタオブジェクト間に継承関係はありません。

Smalltalk/Ruby風のクラスメソッド的なものをどう実現するか

Common LispでもSmalltalk/Rubyのようにクラス生成時に継承関係と同じメタクラスを作ってしまうという方法が一つの解決策です。

以下のリンクは、shiroさんが以前にPython風のクラスメソッドが欲しいという質問に回答した例です

• https://gist.github.com/shirok/732333

class-prototypeを使う

クラスメソッドは、

• クラスの継承関係を利用する
• インスタンスを生成しなくても起動できる

というのがメリットですが、よくよく考えてみれば、クラスの継承関係を利用できて、インスタンスを生成しなくても起動できさえすれば問題は解決とすると、クラス定義ごとに存在するclass-prototypeを利用してディスパッチすれば良さそうです。

クラスメソッドのnewのようなものは以下のように書けるでしょう。

(defmethod new ((o foo))
  (make-instance (class-of (class-prototype (class-of o)))))
(defmethod new ((name symbol))
  (new (class-prototype (find-class name))))

(defclass foo () ())
(new 'foo)
→ #<foo 40200C8273> 
(new (class-prototype (find-class 'foo)))
→ #<foo 40200C87EB> 

上記例は大分持って回った感じですが、とりあえずclass-prototypeを経由すればOKです。

もうすこしクラスメソッド的な例を考える

もうすこしクラスメソッド的な例としてインスタンスの集合を扱う例を考えてみます。

(defclass instance-recording-class (standard-class)
  ((instance-record :initform '()
                    :accessor class-instance-record)))
(defmethod validate-superclass ((c instance-recording-class) (sc standard-class))
  T)
(defmethod make-instance :around ((class instance-recording-class) &rest initargs)
  (let ((inst (call-next-method)))
    (push inst (class-instance-record class))
    inst))

(defclass A ()
  ((x :initarg x))
  (:metaclass instance-recording-class))
(defclass B (A)
  ()
  (:metaclass instance-recording-class))
(dotimes (i 1000)
  (make-instance 'B 'x (random 100)))
(length (class-instance-record (find-class 'B)))
→ 1000 

(defun prototypep (instance)
  (eq instance (class-prototype (class-of instance))))
(deftype prototype ()
  `(satisfies prototypep))
(defmethod all ((x A))
  (check-type x prototype)
  (class-instance-record (class-of x)))
(defmethod all ((x symbol))
  (all (class-prototype (find-class x))))
(defmethod select ((x A) (selector function))
  (check-type x prototype)
  (loop :for i :in (class-instance-record (class-of x))
        :when (funcall selector i) :collect i))
(defmethod select ((x symbol) (selector function))
  (select (class-prototype (find-class x)) selector))
(length (all 'B))
→ 1000 
(length (select 'B (lambda (x) (evenp (slot-value x 'x)))))
→ 490 
(loop :repeat 10
      :for x :in (select 'B (lambda (x) (evenp (slot-value x 'x))))
      :collect (slot-value x 'x))
→ (66 92 38 60 74 80 10 20 76 86) 
(all (make-instance 'A))
!! The value #<a 4020099793> is not of type prototype.

生成されたインスタンスとプロトタイプが混ざるという潜在的な問題はあるので、上記では、prototype型を定義して弾いてみることにしました。

プロトタイプを利用しているので、集合に対する演算の度にインスタンスが生成されて母数が変化してしまうような問題もないことが分かるかと思います。

まとめ

Smalltalkでは、クラス生成時にクラスの継承関係保持したメタクラスが生成されますが、Common Lisp(MOP)では、クラス生成時に(当然ながら)継承関係を保持したプロトタイプが生成されます。
この関係を上手く利用すれば、Common Lispでのクラスメソッド問題も解決できそうな気がしていますがどうでしょう。

■

HTML generated by 3bmd in LispWorks 7.0.0

今回のMOP vs マクロは、defmethodのカスタマイズネタで比較してみたいと思います。

メソッド定義でselfを使いたい

Common Lispはマルチメソッドなので、シングルメソッドの言語のようなselfはありませんが、なんとなく気分で、

(defmethod foo ((self bar) x y) ...)

のように書いたりすることもあります。

このようにディスパッチは先頭一つでしか行なわない場合に、defmethod内部でselfも使えたら便利なんじゃないか、ということで、そのようなカスタマイズをしてみたいと思います。

マクロ篇

まずはマクロでの実現。とりあえず、安直に下記のように書いてみました。

(ql:quickload :closer-mop)
(defpackage "9ef5d5fa-900d-5269-8012-a9c0d39a1860" 
  (:use :c2cl))
(in-package "9ef5d5fa-900d-5269-8012-a9c0d39a1860")
(defmacro defgeneric-self (name (&rest args) &body body)
  (destructuring-bind (class name)
                      name
    `(defgeneric ,name (,class ,@args) ,@body)))
(defmacro defmethod-self (name (&rest args) &body body)
  (destructuring-bind (class name)
                      name
    `(defmethod ,name ((self ,class) ,@args) 
       (with-slots ,(mapcar #'slot-definition-name (class-slots (find-class class))) self
         ,@body))))

selfとなるインスタンスのクラスをどう指定するかですが、Flavors風に(defmethod (class name) ()...)としてみています。

また、defmethod内部では、selfとインスタンスのスロットがスロット名の変数でアクセスできるようにしたいので、with-slotsでボディを囲んでいます。

なお、マクロで実現といってもスロット名を取得したりする必要があるので、MOPを使う必要はあります。

試してみる

(defconstant <foo>
  (defclass foo () 
    ((a :initform nil)
     (b :initform nil)
     (c :initform nil))))
(finalize-inheritance <foo>)
(defmethod-self (foo frob) (a b c)
  (list self a b c))
(frob (make-instance <foo>) 0 1 2)
→ (#<foo 4020290013> nil nil nil) 

クラスのスロット名とメソッドの引数名が被った時にはクラスのスロットに遮蔽されてしまいますが、Flavorsもこんな動作なので良しとします。

MOP篇

(ql:quickload :closer-mop)
(defpackage "a16a6b7f-083d-52aa-a466-d22b941a23c8" 
  (:use :c2cl))
(in-package "a16a6b7f-083d-52aa-a466-d22b941a23c8")
(defclass self-generic-function (standard-generic-function)
  ()
  (:metaclass funcallable-standard-class))
(defmethod make-method-lambda 
           ((gf self-generic-function) (method standard-method) λxp env)
  (destructuring-bind (lambda (self &rest args) &body body)
                      λxp
    (call-next-method gf 
                      method
                      (let ((slot-names (mapcar #'slot-definition-name (class-slots (find-class self)))))
                        `(,lambda (,self ,@args)
                           (let ((self ,self))
                             (declare (ignorable self))
                             (with-slots ,slot-names self
                               (declare (ignorable ,@slot-names))
                               ,@body))))
                      env)))

メソッドのボディのコードをカスタマイズするには、make-method-lambdaが返す、lambda式を編集することになるようです。
ボディのコードをいじる用途には、ちょっと面倒なインターフェイスという印象。

試してみる

(defconstant <foo>
  (defclass foo () 
    ((a :initform nil)
     (b :initform nil)
     (c :initform nil))))
(defgeneric frob (foo a b c)
  (:generic-function-class self-generic-function))
(defmethod frob (foo a b c)
  (list self a b c))
(frob (make-instance <foo>) 0 1 2)
→ (#<foo 402028F48B> nil nil nil) 

やっていることはマクロ版と殆ど変わりありません。
第一引数のシンボルをクラス名にする必要があるという所が危ういですが、まあ良しとします。

マクロでお化粧することも可能ですが、そうするとMOPで書く意味があまりないなという気分になってしまいます。

(defmacro defgeneric-self (name (&rest args) &body body)
  (destructuring-bind (class name)
                      name
    `(defgeneric ,name (,class ,@args) ,@body
       (:generic-function-class self-generic-function))))
(defmacro defmethod-self (name (&rest args) &body body)
  (destructuring-bind (class name)
                      name
    `(defmethod ,name (,class ,@args) ,@body)))

(defgeneric-self (foo bar) ())
(defmethod-self (foo bar) ()
  (list self a b c))

まとめ

クラスの情報を得るのにMOPのイントロスペクション機能を使う必要はありますが、得た情報からコード生成をすることに関しては、マクロの方が単純で明解ですね。

■

HTML generated by 3bmd in LispWorks 7.0.0

今回のMOP vs マクロは、Gaucheのpropagatedスロット再現で比較してみたいと思います。

propagatedスロットについてはブログでの紹介記事に詳しいですが、合成した部品のスロットにアクセスする際に子コンポーネントのスロットが親のスロットとしてアクセスできる、というものです。

• Island Life: コンポジションに便利なpropagatedスロット

マクロ篇

そもそもGaucheのpropagatedスロットが想定している利用法からするとマクロで実現してみようというのは色々と無理があるのですが、色々捨てて挙動だけ同じにしました。

(defpackage "6401746F-BD45-5DB6-BD1D-B29A1EFA0494"
  (:use :c2cl))
(cl:in-package "6401746F-BD45-5DB6-BD1D-B29A1EFA0494")
(defmacro with-slots/propagation ((&rest specs) obj &body body)
  (etypecase specs
    (null
     `(with-slots () ,obj
        ,@body))
    ((cons atom null)
     (let ((_obj (gensym "_obj")))
       `(let ((,_obj ,obj))
          (with-slots (,(car specs)) ,_obj
            (with-slots/propagation (,@(cdr specs)) ,_obj
              ,@body)))))
    (cons
     (destructuring-bind (target-slot slots) (car specs)
       (let ((_obj (gensym "_obj")))
         `(let ((,_obj ,obj))
            (with-slots (,@slots) (slot-value ,_obj ',target-slot)
              (with-slots/propagation (,@(cdr specs)) ,_obj
                ,@body))))))))

(defclass rect ()
  ((width  :initform 0 :initarg :width)
   (height :initform 0 :initarg :height)))
(defclass viewport ()
  ((dimension :initform (make-instance 'rect))
   (width :initarg :width)
   (height :initarg :height)))
(let ((obj (make-instance 'viewport)))
  (with-slots/propagation ((dimension (width height))) obj
    (setq width 42 height 42))
  (describe (slot-value obj 'dimension)))
;>> #<rect 40200074CB> is a rect
;>> width       42
;>> height      42

当初の目的からは外れていますが、局所的にオブジェクトを合成したりするのには使えなくもないかも。
(暗黙の規約が多過ぎますが)

MOP篇

マクロでの実現はやりたいことの中身が全部外側に露出してしまっていますが、これをMOPで内側に収めます。

Gaucheでは、compute-get-n-setという便利なメソッドがあるので圧縮して記述できていますが、AMOP作法だと長くなります。
さらに、standard-instance-accessの利用でアクセス速度向上を狙ってみたので、より長くなりました。

(ql:quickload '(closer-mop))
(defpackage "5ADAD164-D620-594D-A9C7-8E192966CA64"
  (:use :c2cl))
(cl:in-package "5ADAD164-D620-594D-A9C7-8E192966CA64")
(defclass propagated-slot-class (standard-class) 
  ())
(defmethod validate-superclass ((c propagated-slot-class) (sc standard-class))
  T)
(defclass propagated-slot-definition (standard-slot-definition) 
  ((propagate-to :initform nil
                 :initarg :propagate
                 :initarg :propagate-to
                 :accessor propagated-slot-definition-propagate-to)
   (propagate-to# :initform nil
                  :accessor propagated-slot-definition-propagate-to#)))
(defmethod slot-definition-allocation ((slotd propagated-slot-definition))
  :propagated)
(defmethod (setf slot-definition-allocation) (allocation (slotd propagated-slot-definition))
  (unless (eq allocation :propagated)
    (error "Cannot change the allocation of a ~S"
           slotd))
  allocation)
(defconstant <propagated-direct-slot-definition>
  (defclass propagated-direct-slot-definition (standard-direct-slot-definition propagated-slot-definition)
    ()))
(defmethod direct-slot-definition-class ((class propagated-slot-class) &rest initargs)
  (if (eq (getf initargs :allocation) :propagated)
      <propagated-direct-slot-definition>
      (call-next-method)))
(defconstant <propagated-effective-slot-definition>
  (defclass propagated-effective-slot-definition (standard-effective-slot-definition propagated-slot-definition) 
    ()))
(defmethod effective-slot-definition-class ((class propagated-slot-class) &rest initargs)
  (if (eq :propagated (getf initargs :allocation))
      <propagated-effective-slot-definition>
      (call-next-method)))
(defmethod compute-effective-slot-definition ((class propagated-slot-class) name direct-slot-definitions)
  (declare (ignore name))
  (let ((effective-slotd (call-next-method)))
    (dolist (slotd direct-slot-definitions)
      (when (typep slotd 'propagated-slot-definition)
        (setf (propagated-slot-definition-propagate-to effective-slotd) 
              (propagated-slot-definition-propagate-to slotd))
        (return)))
    effective-slotd))
(defmethod finalize-inheritance :after ((class propagated-slot-class))
  (let ((slotds (class-slots class)))
    (dolist (sd slotds)
      (when (typep sd 'propagated-slot-definition)
        (setf (propagated-slot-definition-propagate-to# sd) 
              (slot-definition-location (find (propagated-slot-definition-propagate-to sd)
                                              slotds
                                              :key #'slot-definition-name)))))))
#-lispworks
(defmacro slot-foo (fctn class object slotd)
  (declare (ignore class))
  `(,fctn
    (standard-instance-access ,object
                              (propagated-slot-definition-propagate-to# slotd))
    (slot-definition-name ,slotd)))
#-lispworks
(progn
  (defmethod slot-value-using-class
             ((class propagated-slot-class) object (slotd propagated-slot-definition))
    (slot-foo slot-value class object slotd))
  (defmethod (setf slot-value-using-class)
             (value (class propagated-slot-class) object (slotd propagated-slot-definition))
    (setf (slot-foo slot-value class object slotd)
          value))
  (defmethod slot-boundp-using-class
             ((class propagated-slot-class) object (slotd propagated-slot-definition))
    (slot-foo slot-boundp class object slotd))
  (defmethod slot-makunbound-using-class
             ((class propagated-slot-class) object (slotd propagated-slot-definition))
    (slot-foo slot-makunbound class object slotd))
  (defmethod slot-exists-p-using-class
             ((class propagated-slot-class) object (slotd propagated-slot-definition))
    (slot-foo slot-exists-p class object slotd)))
;;; おまけ:LispWorksの場合

#+lispworks
(defmacro slot-foo (fctn class object slot-name)
  `(let ((slotd (find ,slot-name (class-slots ,class) :key #'slot-definition-name)))
     (if (typep slotd 'propagated-slot-definition)
         (,fctn
          (standard-instance-access ,object
                                    (propagated-slot-definition-propagate-to# slotd))
          ,slot-name)
       (call-next-method))))
#+lispworks
(progn
  (defmethod slot-value-using-class
             ((class propagated-slot-class) object slot-name)
    (slot-foo slot-value class object slot-name))
  (defmethod (setf slot-value-using-class)
             (value (class propagated-slot-class) object slot-name)
    (let ((slotd (find slot-name (class-slots class) :key #'slot-definition-name)))
      (if (typep slotd 'propagated-slot-definition)
          (setf (slot-value (standard-instance-access object
                                                      (propagated-slot-definition-propagate-to# slotd))
                            slot-name)
                value)
          (call-next-method))))
  (defmethod slot-boundp-using-class
             ((class propagated-slot-class) object slot-name)
    (slot-foo slot-boundp class object slot-name))
  (defmethod slot-makunbound-using-class
             ((class propagated-slot-class) object slot-name)
    (slot-foo slot-makunbound class object slot-name))
  (defmethod slot-exists-p-using-class
             ((class propagated-slot-class) object slot-name)
    (slot-foo slot-exists-p class object slot-name)))

試してみる

(defclass rect ()
  ((width  :initform 0 :initarg :width)
   (height :initform 0 :initarg :height)))
(defclass viewport ()
  ((dimension :initform (make-instance <rect>))
   (width     :allocation :propagated :propagate dimension
              :initarg :width)
   (height    :allocation :propagated :propagate dimension
              :initarg :height))
  (:metaclass propagated-slot-class))
(let ((vp (make-instance 'viewport' :width 42 :height 42)))
  (describe vp)
  (describe (slot-value vp 'dimension)))
;>> #<viewport 4020098D8B> is a viewport
;>> dimension      #<rect 4020098DBB>
;>> width          42
;>> height         42
;>> #<rect 4020098DBB> is a rect
;>> width       42
;>> height      42

速度比較

LispWorksだと素のインスタンス生成/スロットアクセスに比較して大体1.5倍程度の遅さで済んでいるようです。

(defclass c000001 ()
  ((x :initform 0)
   (y :initform 0)
   (z :initform 0)))
(let ((times 1000000)
      (ans 0))
  (time (dotimes (i times)
          (slot-value (make-instance 'viewport) 'width)))
  (time (dotimes (i times)
          (slot-value (make-instance 'c000001) 'x)))
  ans)
Evaluation took:
  0.686 seconds of real time
  0.680000 seconds of total run time (0.680000 user, 0.000000 system)
  99.13% CPU
  2,258,481,555 processor cycles
  95,986,800 bytes consed
Evaluation took:
  0.413 seconds of real time
  0.410000 seconds of total run time (0.410000 user, 0.000000 system)
  99.27% CPU
  1,360,213,671 processor cycles
  64,028,672 bytes consed

まとめ

今回は、マクロ向きのお題ではありませんでしたが、動作の内容はMOPの内側か外側かの違いだけではありました。

MOPで組む前に、マクロで適当に書いてみて動作を考える、というもの場合によっては、悪くないかもしれません。

■

HTML generated by 3bmd in LispWorks 7.0.0

Common Lispでお馴染のdefun。 ClojureだとdefnでCommon Lispと同じくデ(ィ)ファンと読むらしいですが、Jon L White氏によってMACLISPに導入されたのが、50年前の今日、1969-03-01でした。

• LISPNEWS(3/1/69)

3/1/69 JONL
 THE CURRENT VERSION OF LISP, "LISP 102", HAS
THE FOLLOWING AS-YET UNDOCUMENTED FEATURES:
    1)"DEFUN" IS AN FSUBR USED TO DEFINE
FUNCTIONS. EXAMPLES ARE
    (DEFUN ONECONS (X) (CONS 1 X))
WHICH IS EQUIVALENT TO 
    (DEFPROP ONECONS 
        (LAMBDA (X) (CONS 1 X)
     EXPR)
AND (DEFUN SMASH FEXPR (L) (RPLACD L NIL))
 IS EQUIVALENT TO
    (DEFPROP SMASH 
        (LAMBDA (L) (RPLACD L NIL))
     FEXPR)
THE NOVEL FEATURE OF "DEFUN" IS THAT ONE NEED
 NOT BE SO CONCERNED WITH BALANCING
PARENTHESES AT THE VERY END OF THE FUNCTION
DEFINITION, SINCE THE TYPE FLAG MAY BE 
OMITTED IF IT IS "EXPR", AND APPEARS NEAR 
THE FRONT OF THE "DEFUN" LIST IF IT IS SOME 
OTHER.  ALSO, THE "LAMBDA" NEED NOT BE 
DIRECTLY INSERTED.

defun誕生以前は、defpropでシンボルのexprや、fexpr、macroプロパティに関数定義をセットしていたようです。

ちなみに、defunとは別の流儀にdeがありますが、こちらは、MIT LISP 1.6(後のPDP-6 LISP/MACLISP)がスタンフォード大学に導入された後にdefunと同様の目的で考案されたものです。

defunは当初、通常の関数(expr)だけでなくマクロ等の各種関数を定義できました。
exprの定義は、defun foo (x)でfexprの定義はdefun foo fexpr (x)とし、同様にマクロは、defun foo macro (x)で定義可能です。
これらは、Common Lispの祖先のLisp Machine Lispで、各種専用構文に分岐します。

上述のStanford LISP 1.6の場合は、exprは、de、fexprは、df、マクロは、dmと二文字の専用構文となっていますが、defunの方は、先祖のdefpropの影響を引き摺ったのかもしれません。

50年も生き延びたdefun構文ですが、100歳まで生き残るでしょうか。

■

HTML generated by 3bmd in LispWorks 7.0.0

たまに、Common Lispの仕様では(lambda (x) ...)を関数の名前として定められている、というような話がされることがあります。
しかし、結論としては、ANSI Common Lisp規格では関数の名前ではありません。
今回は、その辺りを調べてまとめてみました。

ANSI Common Lisp規格での関数の名前

(lambda (x) ...)は、ANSI Common Lisp規格では、lambda expressionと呼びますが、その説明を読むとfunction nameが位置する場所にあるlambdaから始まるリスト、のように持って回った説明がされています。

とりあえず、lambda expressionの方は置いておいて、function nameの方を確認すると、シンボルもしくは、(setf シンボル)というリストがfunction nameとなっています。

Common Lisp(1984)での関数の名前

しかし、CLtL1でお馴染のCommon Lisp(1984)での記述を確認してみると、ANSI規格に比べると記述は曖昧で、関数名としてのシンボルと、ラムダ式を同一視しているような記述ではありました。

CLtL1: 5.2 Functions

There are two ways to indicate a function to be used in a function call form. One is to use a symbol that names the function. This use of symbols to name functions is completely independent of their use in naming special and lexical variables. The other way is to use a lambda-expression, which is a list whose first element is the symbol lambda. A lambda-expression is not a form; it cannot be meaningfully evaluated. Lambda-expressions and symbols, when used in programs as names of functions, can appear only as the first element of a function-call form, or as the second element of the function special form. Note that symbols and lambda-expressions are treated as names of functions in these two contexts. This should be distinguished from the treatment of symbols and lambda-expressions as function objects, that is, objects that satisfy the predicate functionp, as when giving such an object to apply or funcall to be invoked.

これはANSI規格へ向けての中間報告であるCLtL2(1990)でも同様です。

この記述をうけてか、竹内郁雄先生の1980年代の著作である「初めての人のためのLisp」11章の脚注にもこんな記述があります。

Common Lispではこのリストを，関数実体を表わす一種の"名前"と呼んでいます。

ちなみに、増補改訂版(2010)では、脚注から本文の先生の台詞に昇格して

Common Lispではこのリストを，関数実体を表わす一種の"名前"であるとしておる

となっています。 まあ、「一種の“名前”」となっているので、どうとでも解釈できそうです。

Common Lisp(1984)からANSI Common Lisp(1994)までに何が変化したのか

ANSI Common Lisp(1994)は、オブジェクト指向システムやコンディションシステムの追加等が目立つところですが、それまで曖昧だった概念や記述が大分整理されました。
function nameとlambda expressionが分離した背景については、Issue FUNCTION-NAME Writeupに記録があります。

まず、function nameについての整理があり、function、fdefinition、defun、fboundp、fmakunbound等々、関数の名前を取るものの整理がされ、(setf ...)が新しく関数名とされました。

これを推進して、lambda expressionを関数名として扱うかの提案が、FUNCTION-NAME:LARGEの12番にあります。

12. Declare that any lamba expression (i.e., a list whose car is LAMBDA and
    whose cdr is a well-formed lambda argument list and body) is a function
    name. 

lambda expressionが名前となれば、

(fmakunbound (lambda () ...))

のようなケースも考えていくことになると思うのですが、しかし、結局、lambda expressionが無名関数を表す慣習からすると、それをもって名前とするのは矛盾としています。
名は体を表すといいますが、lambda expressionは体が体を表してしまっているというところでしょうか。

Lambda expressions are often thought to denote "anonymous" functions, so
it may seem paradoxical to treat them as names.  The paradox is only
apparent, since the expression itself has the properties of a Lisp
function name: It is (typically) a cons tree which can be read, printed,
and stored in source files, and it denotes a well-defined Lisp function.

ここからどのような投票が行なわれ、どう決定されたかの資料はみあたらないのですが、12番の提案は採用されなかったのは確かで、function nameにlambda expressionは含まれることは無かった、ということでしょう。

まとめ

年配の方々はもうしょうがないと思いますが、若者はANSI Common Lisp規格を読みましょう。
また、CLtL2はCLtL1からANSI Common Lispまでの中間報告であり規格ではありませんので、CLtL1/2で得た知識は一度ANSI Common Lisp規格でどう変更された/されていないのかの確認をしましょう。

■

HTML generated by 3bmd in LispWorks 7.0.0

今回は前回に引き続きECLOSネタから、

• instance-recording-class (get to instances from their class, but allow their garbage collection).

でMOP vs マクロ比較をしてみたいと思います。

インスタンス生成を何らかの形で記録するというのはAMOPの3.1章にも出てくる定番ネタです。

この機能の実現は、インスタンス生成で使うmake-instanceに記録を行う関数のフックをかけてやればOKでしょう。
加えて、ECLOSではインスタンスを記録しつつもGCされたら消えるとのことなのですが、これは弱参照リストかなにかにすれば、これもOKでしょう。

ということで書いてみました。

MOPでの実装

LispWorksとSBCLで弱参照のシークエンスを物色してみましたが、弱参照の配列にしてみました。
LispWorksでは、weak-arrayというものがありadjustableなのですが、SBCLにはないので、結局make-weak-pointerで包んでいます。
trivial-garbageを利用すればいくらか可搬性は増すかもしれません。

(cl:in-package :cl-user)
(ql:quickload :closer-mop)
(defpackage "d5fc135c-3bcf-4976-9a9e-e6b92c12bd9d"
  (:use :c2cl :alexandria))
(in-package "d5fc135c-3bcf-4976-9a9e-e6b92c12bd9d")
(defun make-weak-vector (size &rest initargs)
  (declare (dynamic-extent initargs))
  #+lispworks (apply #'hcl:make-weak-vector size initargs)
  #+sbcl (apply #'make-array size :element-type 'sb-ext:weak-pointer initargs))
(defclass instance-recording-class (standard-class)
  ((instance-record :initform (make-weak-vector 0 :adjustable T :fill-pointer 0)
                    :accessor class-instance-record)))
(defmethod validate-superclass ((c instance-recording-class) (sc standard-class))
  T)
(defmethod make-instance :around ((class instance-recording-class) &rest initargs)
  (let* ((inst (call-next-method))
         #+sbcl (inst (sb-ext:make-weak-pointer inst)))
    (vector-push-extend inst (class-instance-record class))
    inst))
(defun reset-instance-record (class)
  (setf (class-instance-record class)
        (make-weak-vector 0 :adjustable T :fill-pointer 0)))

試してみる

(defconstant <zot> 
  (defclass zot () 
    ((a :initform 42))
    (:metaclass instance-recording-class)))
(dotimes (i 8)
  (make-instance <zot>))
(class-instance-record <zot>)
#+sbcl
→#(#<weak pointer: #<zot {10349DBA73}>> #<weak pointer: #<zot {10349ECDF3}>> #<weak pointer: #<zot {10349ECE63}>> #<weak pointer: #<zot {10349ECEE3}>>
        #<weak pointer: #<zot {10349ECF33}>> #<weak pointer: #<zot {10349ECFD3}>> #<weak pointer: #<zot {10349ED023}>> #<weak pointer: #<zot {10349ED073}>>)
#+lispworks
→ #(#<zot 4020034723> #<zot 4020034B43> #<zot 4020034EAB> #<zot 4020035213>
    #<zot 402003557B> #<zot 40200358E3> #<zot 4020035C4B> #<zot 4020035FB3>) 
#+lispworks (hcl:gc-all)
#+sbcl (sb-ext:gc :full t)
(class-instance-record <zot>)
#+sbcl
→ #(#<broken weak pointer> #<broken weak pointer> #<broken weak pointer> #<broken weak pointer> #<broken weak pointer> #<broken weak pointer>
       #<broken weak pointer> #<broken weak pointer>)
#+lispworks
→ #(nil nil nil nil nil nil nil nil) 
;; (clear-instance-record <zot>)

SBCLのほうはweak-pointerオブジェクトで包まれるのでちょっと扱いが面倒ですが、まあこんなものでしょう。

allocate-instanceにフックをかけるのでは駄目なのか

AMOPの例でもこういう記録系の拡張は、make-instanceにフックをかけますが、生成ならばallocate-instanceへのフックでも良さそうです。

両者で何が違うのか考えてみましたが、class-prototypeを実行するとプロトタイプの生成でallocate-instanceが呼ばれるので、クラスのプロトタイプインスタンスも含みたい場合はallocate-instanceの方が良いのでしょう。
恐らく、インスタンス記録系は、クラスのプロトタイプインスタンスは大抵除外して考えそうなので、make-instanceの方が自然かと思います。

allocate-instanceを利用した場合

(defmethod allocate-instance :around ((class instance-recording-class) &rest initargs)
  (let* ((inst (call-next-method))
         #+sbcl (inst (sb-ext:make-weak-pointer inst)))
    (vector-push-extend inst (class-instance-record class))
    inst))
(defconstant <bar> 
  (defclass bar () 
    ((a :initform 42))
    (:metaclass instance-recording-class)))
(class-instance-record <bar>)
→ #() 
(class-prototype <bar>)
→ #<bar 402008BEE3> 
(class-instance-record <bar>)
→ #(#<bar 402008BEE3>) 

マクロで考えてみた

あまりこういうのはマクロに向いていない気もしますが、比較のために書いてみました。

(defvar *instance-recording-table*
  (make-hash-table))
(defmacro with-instance-recording ((type) &body form)
  (with-unique-names (inst)
    `(let* ((,inst (progn ,@form))
            #+sbcl (,inst (sb-ext:make-weak-pointer ,inst)))
       #-sbcl (check-type ,inst ,type)
       #+sbcl (check-type (sb-ext:weak-pointer-value ,inst) ,type)
       (vector-push-extend ,inst
                           (or (gethash ',type *instance-recording-table*)
                               (setf (gethash ',type *instance-recording-table*)
                                     (make-weak-vector 0 :adjustable T :fill-pointer 0))))
       ,inst)))
(defun get-instance-record (type)
  (values (gethash type *instance-recording-table*)))
(defun reset-instance-record (type)
  (setf (gethash type *instance-recording-table*)
        (make-weak-vector 0 :adjustable T :fill-pointer 0)))

試してみる

(defclass quux ()
  ((x :initform 0)))
(dotimes (i 8)
  (with-instance-recording (quux) 
    (make-instance 'quux)))
(get-instance-record 'quux)
→ #(#<quux 40200A1413> #<quux 40200A26A3> #<quux 40200A351B> #<quux 40200A4393>
    #<quux 40200A520B> #<quux 40200A6083> #<quux 40200A6EFB> #<quux 40200A7D73>) 
(hcl:gc-all)
(get-instance-record 'quux)
→ #(nil nil nil nil nil nil nil nil) 

マクロなのでクラスオブジェクト以外にも使えます。
(というかそういう風に作っただけ)

(defstruct sss a b c)
(dotimes (i 8)
  (with-instance-recording (sss) 
    (make-sss)))
(get-instance-record 'sss)
→ #(#S(sss :a nil :b nil :c nil) #S(sss :a nil :b nil :c nil)
   #S(sss :a nil :b nil :c nil) #S(sss :a nil :b nil :c nil)
   #S(sss :a nil :b nil :c nil) #S(sss :a nil :b nil :c nil)
   #S(sss :a nil :b nil :c nil) #S(sss :a nil :b nil :c nil))  
(hcl:gc-all)
(get-instance-record 'sss)
→ #(nil nil nil nil nil nil nil nil) 

まとめ

インスタンスの記録についてMOPとマクロで比較してみましたが、元がMOP向きな問題だけにさすがにMOPの方がすっきりします。
しかし、実現している内容はマクロ版も大して変わらないので、あとは使い勝手がどうなるか、でしょうか。

■

HTML generated by 3bmd in LispWorks 7.0.0

前回のlet*-like slot initialization semanticsはマクロ主体での実装でしたが、今回はMOP主体でチャレンジです。

しかし、defclassが周囲のレキシカル変数を取り込むので何にせよ全体はマクロでまとめる他なさそうですが、そこは諦めます。

あれこれ試行錯誤しましたが、今回の方針は、

• let*風の逐次初期化を実行する関数を収めるスロットを付ける (direct-slot-definitionに追加)
• メタクラスにインスタンスの初期化をする関数を収めるスロットを付ける (class-let*-initfunction)
• compute-slotsでスロット構成を生成する際に、追加したスロットの初期化関数をまとめる
• まとめた関数をshared-initializeで呼ぶ

shared-initializeで呼ばれる関数ですが、下記のようなものを生成します。 初期化されるインスタンスを引数に取り、内部では、専らstandard-instance-accessを使って読み書きします。

(lambda (obj)
  (symbol-macrolet ((a (standard-instance-access obj 0))
                    (b (standard-instance-access obj 1)))
    (when (eq unbound-marker (standard-instance-access obj 0))
      (setf (standard-instance-access obj 0)
            (funcall #<Function 1 subfunction of (lw:top-level-form 1) 4060007E8C>
                     nil
                     nil)))
    (when (eq unbound-marker (standard-instance-access obj 1))
      (setf (standard-instance-access obj 1)
            (funcall #<Function 2 subfunction of (lw:top-level-form 1) 4060007E34>
                     a
                     nil)))
    (when (eq unbound-marker (standard-instance-access obj 2))
      (setf (standard-instance-access obj 2)
            (funcall #<Function 3 subfunction of (lw:top-level-form 1) 4060007DAC>
                     a
                     b)))))

そして、下記がMOPチャレンジ版のコードですが、大したことはしていないのに長くなりました。

(cl:in-package :cl-user)
(ql:quickload :closer-mop)
(defpackage :64d0b072-4e6b-44c3-b565-dcf8d4ca63e3
  (:use :c2cl)
  #+sbcl (:shadowing-import-from :cl :defmethod))
(cl:in-package :64d0b072-4e6b-44c3-b565-dcf8d4ca63e3)
(defconstant unbound-marker 
  (if (boundp 'unbound-marker)
      unbound-marker
      (gensym "unbound")))
(defclass let*-slot-class (standard-class) 
  ((let*-slots :initform nil :accessor class-let*-slots :initarg :let*-slots)
   (let*-initfunction :accessor class-let*-initfunction :initarg :let*-initfunction)))
(defmethod validate-superclass ((c let*-slot-class) (sc standard-class))
  T)
(defclass let*-standard-object (standard-object)
  ())
(defun process-a-slot (slot)
  (loop :with name := (car slot)
        :for (k v) :on (cdr slot) :by #'cddr
        :when (eq k :initform) 
        :append `(:initform ,v :initfunction (constantly unbound-marker)) :into initform
        :when (eq k :initarg) :collect v :into initargs
        :when (eq k :writer) :collect v :into writers
        :when (eq k :reader) :collect v :into readers
        :when (eq k :accessor) :collect v :into readers :and :collect `(setf ,v) :into writers
        :finally (return
                  `(:name ,name
                    :initargs ,initargs
                    ,@initform
                    :writers ,writers
                    :readers ,readers))))
(defclass let*-direct-slot-definition (standard-direct-slot-definition)
  ((let*-initfunction :initarg :let*-initfunction :accessor slot-definition-let*-initfunction)))
(defmethod direct-slot-definition-class ((class let*-slot-class) &rest initargs)
  (find-class 'let*-direct-slot-definition))
(defmethod compute-slots :around ((class let*-slot-class))
  (let* ((let*-slots (class-let*-slots class))
         (slots (call-next-method))
         (let*-slot#s (loop :for s :in let*-slots
                            :for pos := (position s slots :key #'slot-definition-name)
                            :when pos :collect (cons s pos))))
    (setf (class-let*-initfunction class)
          (compile nil
                   `(lambda (obj)
                      (symbol-macrolet (,@(loop :for s :in (butlast let*-slots)
                                                :collect `(,s (standard-instance-access obj ,(cdr (assoc s let*-slot#s))))))
                        ,@(loop :for s :in let*-slots
                                :for pos := (cdr (assoc s let*-slot#s))
                                :for argpos :from 0
                                :collect `(when (eq unbound-marker (standard-instance-access obj ,pos))
                                            (setf (standard-instance-access obj ,pos)
                                                  (funcall ,(slot-definition-let*-initfunction
                                                             (find s (class-direct-slots class) :key #'slot-definition-name))
                                                           ,@(replace (make-list (length (cdr let*-slots)))
                                                                      (subseq (butlast let*-slots) 0 argpos))))))))))
    slots))
(defmethod shared-initialize :after
           ((obj let*-standard-object) slot-names &rest initargs &key &allow-other-keys)
  (funcall (class-let*-initfunction (class-of obj)) obj))
(defmacro defclass* (name (&rest superclasses) (&rest slots) &rest class-options)
  (loop :with slot-names := (mapcar (lambda (x) (if (consp x) (car x) x))
                                    slots)
        :for s :in slots
        :for cs := (copy-list (process-a-slot s))
        :collect `(,@cs 
                   :let*-initfunction
                   (lambda (,@(butlast slot-names))
                     (declare (ignorable ,@(butlast slot-names)))
                     ,(getf cs :initform))) :into canonicalized-slots
        :finally (return 
                  `(eval-when (:compile-toplevel :load-toplevel :execute)
                     (ensure-class ',name
                                   :metaclass 'let*-slot-class
                                   :direct-superclasses (adjoin 'let*-standard-object
                                                                ',superclasses)
                                   :direct-slots (list ,@(mapcar (lambda (s) 
                                                                   (destructuring-bind (&key name
                                                                                             initargs
                                                                                             initform
                                                                                             initfunction
                                                                                             writers
                                                                                             readers
                                                                                             let*-initfunction
                                                                                             &allow-other-keys) 
                                                                                       s
                                                                     `(list :name ',name
                                                                            :initargs ',initargs
                                                                            :initform ',initform
                                                                            :initfunction ,initfunction
                                                                            :writers ',writers
                                                                            :readers ',readers
                                                                            :let*-initfunction ,let*-initfunction)))
                                                                 canonicalized-slots))
                                   :let*-slots ',slot-names
                                   ,@class-options)))))

動作

(defclass* qqq ()
  ((a :initform 42 :initarg :a)
   (b :initform a :initarg :b)
   (c :initform (+ a b) :initarg :c)))
(with-slots (a b c) (make-instance 'qqq)
  (list a b c))
;=>  (42 42 84)

(with-slots (a b c) (make-instance 'qqq :c 0)
  (list a b c))
;=>  (42 42 0)

(with-slots (a b c) (make-instance 'qqq :b 0)
  (list a b c))
;=>  (42 0 42)

(with-slots (a b c) (make-instance 'qqq :a 0)
  (list a b c))
;=>  (0 0 0)

(with-slots (a b c) (make-instance 'qqq :a 0 :b 1)
  (list a b c))
;=>  (0 1 1)

MOPにして良いことがあるのか

マクロ主体の場合は、スロットアクセスが名前参照ベースなので若干非効率効率ですが、MOPを使えば、standard-instance-access等の効率の良いアクセス方法が使えるので速くできるだろうということで、今回は、standard-instance-accessの利用を軸に組み立ててみました。

素のインスタンス生成〜初期化と比較して、マクロ版は、約1.8倍の時間のところをMOP版では、約1.3倍程度にまで抑えることができました。
まあもっと速くできそうではありますが……。

(defclass let-slot ()
  ((a :initform 42)
   (b :initform 42)
   (c :initform 42)))
(defclass* let*-slot ()
  ((a :initform 42 :initarg :a)
   (b :initform a :initarg :b)
   (c :initform (+ a b) :initarg :c)))
(dc07f5fa-62ee-40a1-ae1a-d1a0f87d19bb::defclass* let*-slot-macro ()
  ((a :initform 42 :initarg :a)
   (b :initform a :initarg :b)
   (c :initform (+ a b) :initarg :c)))

計時

(let ((cnt 1000000))
  (time 
   (dotimes (i cnt)
     (make-instance 'let-slot)))
  (time 
   (dotimes (i cnt)
     (make-instance 'let*-slot)))
  (time 
   (dotimes (i cnt)
     (make-instance 'let*-slot-macro))))
Timing the evaluation of (dotimes (i cnt) (make-instance 'let-slot))
User time    =        1.270
System time  =        0.000
Elapsed time =        1.258
Allocation   = 1352109704 bytes
0 Page faults
Calls to %EVAL    17000036
Timing the evaluation of (dotimes (i cnt) (make-instance 'let*-slot))
User time    =        1.660
System time  =        0.000
Elapsed time =        1.654
Allocation   = 1352029784 bytes
0 Page faults
Calls to %EVAL    17000036
Timing the evaluation of (dotimes (i cnt) (make-instance 'let*-slot-macro))
User time    =        2.260
System time  =        0.000
Elapsed time =        2.260
Allocation   = 1352020600 bytes
0 Page faults
Calls to %EVAL    17000036
nil

継承した場合にスロットのインデックスの位置関係はどうなるのか

具体的には下記のような場合に、standard-instance-accessが指す先がどのような構成になるのかを把握していないと使えないのですが、

(defclass A ()
  ((a :initform 0 :initarg :a)
   (b :initform 1 :initarg :b)
   (c :initform 2 :initarg :c)))
(defclass* B (A)
  ((x :initform 42 :initarg :x)
   (y :initform x :initarg :y)
   (z :initform (+ x y) :initarg :z)))
(with-slots (a b c x y z) (make-instance 'B :y 1)
  (list a b c x y z))
;=> (0 1 2 42 1 43) 

AMOPのInstance Structure Protocolの例では、compute-slotsの並び順で、standard-instance-accessのインデックスを決められる的なことが書いてあります。
実際に試してみると、継承した場合、上位クラスのスロット数分だけオフセットしたり(SBCL、LispWorks)名前とスロットの値が一致しなかったり(LispWorks)で、compute-slotsで並べた順がすなわちインデックスとはならない実装があるようです。

しょうがないので、結局名前からインデックスを求めるようにしましたが、私が何か勘違いをしているのか、もしくはこの仕様に準拠している処理系が少ないのか。

まとめ

これまでlet*風にスロットの逐次初期化を2パスで考えてみましたが、shared-initializeを差し替えてしまった方が素直なのかもしれません。
そのうち試してみようかなと思います。

■

HTML generated by 3bmd in LispWorks 7.0.0

MOP vs マクロなネタを探していますが、古えのメールに面白そうなものがあったので、これをどうにかMOP vs マクロの枠内で再現してみることにします。

• ANNOUNCE : ECLOS 3.3 (Metaclass library)

ちなみに、このECLOSですが、Metaclass libraryとあるように、MOP的なツールを纏めた商用ライブラリだったようです。
メタクラス関係だけで商品になってたというのが凄い。

告知メールによると主なアイテムは、

• self-referent class
• instance-recording-class (get to instances from their class, but allow their garbage collection).
• operating-class (implement recursive operations like copy-object, equal-object-p with suscint in-class specifications)
• lazy-class (establish inter-slot/access dependencies to avoid initializing slots until they are needed/make-sense)
• attributed-class (arbitrary-depth attributes in slots, great for frame-like programming)
• constrained-class (multi-way constraints and daemons can be stored in and refer transparently to slots).
• An enhanced Delta-Blue constraint solver with a higher-order architecture for dynamic update of constraint graphs (no propagate as if graph still unchanged semantics).
• let*-like slot initialization semantics

ですが、定番そうなものから何やら良く分からないものまであります。

今回は、このリストの中からlet*-like slot initialization semanticsをMOPとマクロで再現してみたいと思います。
例のごとくまずはマクロでの実現から始めます。

let*-like slot initialization semantics をマクロで書いてみる

まず、動作の確認ですが、詳細は不明なものの、多分let*のように上方のスロットの値が次のスロットで使えるということなのではないかと思います。

動作例を考えると、下記のようになるかと思いますが、やりたいことが単純な割には実現は面倒臭そうです。

(let ((z 42))
  (defclass* qqq ()
   ((a :initform z :initarg :a :initarg a)
    (b :initform a :initarg :b :initarg b)
    (c :initform (+ a b) :initarg :c :initarg c))))
(with-slots (a b c) (make-instance 'qqq)
  (list a b c))
;=>  (42 42 84)

(with-slots (a b c) (make-instance 'qqq :c 0)
  (list a b c))
;=>  (42 42 0)

(with-slots (a b c) (make-instance 'qqq :b 0)
  (list a b c))
;=>  (42 0 42)

(with-slots (a b c) (make-instance 'qqq :a 0)
  (list a b c))
;=>  (0 0 0)

(with-slots (a b c) (make-instance 'qqq :a 0 :b 1)
  (list a b c))
;=>  (0 1 1)

一応の解説ですが、上記のクラス定義フォームを素のdefclassで置き換えた場合、bとcスロットでaとbが未束縛でエラーになります。
変数zに関してはdefclassは外側の変数を取り込めるのでzはレキシカル変数になります。

(let ((z 42))
  (defclass ppp ()
   ((a :initform z :initarg :a :initarg a)
    (b :initform a :initarg :b :initarg b)
    (c :initform (+ a b) :initarg :c :initarg c))))
(make-instance 'ppp)
;!!! The variable a is unbound.

このlet*的な初期化構文のポイントは、let*的な順次初期化は、クラス定義時に行なわれるのではなく、インスタンス(再)初期化時に行なわれるということです。

マクロでどうするか考えてみる

あれこれ考えてみましたが、とりあえずスロットの初期化を2パスにするのが一番簡単そうなので、それで行くことにしました。

• スロットの:initfunctionに設定する関数でクロージャーを返すようにしインスタンス初期化まで評価を遅らせる
• インスタンス初期化時に、スロットの値が保留になっているかを調べて保留状態ならクロージャーを評価し値を設定

という所です。

マクロ展開を眺めるのが一番早いと思うのですが下記のような展開になります。

(defclass* qqq ()
  ((a :initform 42 :initarg :a)
   (b :initform a :initarg :b)
   (c :initform (+ a b) :initarg :c)))
===>
(eval-when (:compile-toplevel :load-toplevel :execute)
  (let ((#:a368281
         (lambda (obj)
           (with-slots (a b c) obj (declare (ignorable a b c)) 42)))
        (#:b368282
         (lambda (obj) (with-slots (a b c) obj (declare (ignorable a b c)) a)))
        (#:c368283
         (lambda (obj)
           (with-slots (a b c) obj (declare (ignorable a b c)) (+ a b)))))
    (ensure-class 'qqq
                  :direct-superclasses
                  (adjoin 'let*-standard-object 'nil)
                  :direct-slots
                  (list (list :name 'a :initargs '(:a) :initform '42 :initfunction (lambda () #:a368281) :writers 'nil :readers 'nil)
                        (list :name 'b :initargs '(:b) :initform 'a :initfunction (lambda () #:b368282) :writers 'nil :readers 'nil)
                        (list :name 'c :initargs '(:c) :initform '(+ a b) :initfunction (lambda () #:c368283) :writers 'nil :readers 'nil)))
    (defmethod initialize-let*-slots ((obj qqq))
      (let ((sname 'a))
        (when (slot-boundp obj sname)
          (let ((sval (slot-value obj sname)))
            (when (eq #:a368281 sval)
              (setf (slot-value obj sname) (funcall sval obj))))))
      (let ((sname 'b))
        (when (slot-boundp obj sname)
          (let ((sval (slot-value obj sname)))
            (when (eq #:b368282 sval)
              (setf (slot-value obj sname) (funcall sval obj))))))
      (let ((sname 'c))
        (when (slot-boundp obj sname)
          (let ((sval (slot-value obj sname)))
            (when (eq #:c368283 sval)
              (setf (slot-value obj sname) (funcall sval obj)))))))))

マクロ定義(およびクラス定義)

(cl:in-package :cl-user)
(ql:quickload :closer-mop)
(cl:defpackage :dc07f5fa-62ee-40a1-ae1a-d1a0f87d19bb
  (:use :c2cl))
(cl:in-package :dc07f5fa-62ee-40a1-ae1a-d1a0f87d19bb)
(defclass let*-standard-object (standard-object)
  ())
(defun process-a-slot (slot)
  (loop :with name := (car slot)
        :for (k v) :on (cdr slot) :by #'cddr
        :when (eq k :initform) 
        :append `(:initform ,v :initfunction ,(coerce `(lambda () ,v) 'function)) :into initform
        :when (eq k :initarg) :collect v :into initargs
        :when (eq k :writer) :collect v :into writers
        :when (eq k :reader) :collect v :into readers
        :when (eq k :accessor) :collect v :into readers :and :collect `(setf ,v) :into writers
        :finally (return
                  `(:name ,name
                    :initargs ,initargs
                    ,@initform
                    :writers ,writers
                    :readers ,readers))))
(defgeneric initialize-let*-slots (obj)) 
(defmethod shared-initialize :after
           ((obj let*-standard-object) slot-names &rest initargs &key &allow-other-keys)
  (initialize-let*-slots obj))
(defmacro defclass* (name (&rest superclasses) (&rest slots) &rest class-options)
  (loop :with slot-names := (mapcar (lambda (x) (if (consp x) (car x) x))
                                    slots)
        :for s :in slots
        :for cs := (copy-list (process-a-slot s))
        :for ifn := (gensym (string (getf cs :name)))
        :collect cs :into canonicalized-slots
        :collect `(,ifn (lambda (obj)
                          (with-slots (,@slot-names) obj
                            (declare (ignorable ,@slot-names))
                            ,(getf cs :initform)))) :into bvs
        :collect `(let ((sname ',(getf cs :name)))
                    (when (slot-boundp obj sname)
                      (let ((sval (slot-value obj sname)))
                        (when (eq ,ifn sval)
                          (setf (slot-value obj sname)
                                (funcall sval obj)))))) :into slot-init-forms
        :do (setf (getf cs :initfunction) 
                  `(lambda () ,ifn))
        :finally (return 
                  `(eval-when (:compile-toplevel :load-toplevel :execute)
                     (let (,@bvs)
                       (ensure-class ',name
                                     :direct-superclasses (adjoin 'let*-standard-object
                                                                  ',superclasses)
                                     :direct-slots (list
                                                    ,@(mapcar (lambda (s)
                                                                (destructuring-bind (&key name
                                                                                          initargs
                                                                                          initform
                                                                                          initfunction
                                                                                          writers
                                                                                          readers
                                                                                          &allow-other-keys) 
                                                                                    s
                                                                  `(list :name ',name
                                                                         :initargs ',initargs
                                                                         :initform ',initform
                                                                         :initfunction ,initfunction
                                                                         :writers ',writers
                                                                         :readers ',readers)))
                                                              canonicalized-slots))
                                     ,@class-options)
                       (defmethod initialize-let*-slots ((obj ,name))
                         ,@slot-init-forms))))))