先日、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))))))

まとめ

案外ほとんどMOP的な要素を使わずにマクロのみで実現できてしまいましたが、スコープ的なものを扱うのでマクロの方が得意なのかもしれません。

ちなみに、スロットの:initfunctionは、ANSI Common Lispの規格にはなく、MOPで規定されているものですが、まあこれくらいは良しとしましょう。

さてこれを今後MOP的にして行きたいと思います。

■

HTML generated by 3bmd in LispWorks 7.0.0

前回は、全面的なマクロから、ensure-classを使って若干のMOP利用へと進めましたが、今回は、ensure-class-using-classを利用して、もう一歩進めてみたいと思います。

ensure-class-using-class を利用してみる

ensure-classは関数ということもあり、プロトコルを成しているメソッド群をカスタマイズするという感じではありませんが、ensure-classの下請けのensure-class-using-classは、standard-classをカスタマイズしたメタクラスでディスパッチさせることが可能です。

(defpackage d34ab7fb-8666-4f9c-ac95-833380ffefee 
  (:use :c2mop :cl)
  (:shadowing-import-from :c2mop
   :defmethod :standard-class :defgeneric 
   :standard-generic-function :funcallable-standard-class))
(in-package d34ab7fb-8666-4f9c-ac95-833380ffefee)
(defun slot-name-conc (prefix name)
  (let ((pkg (etypecase prefix
               ((or null string) *package*)
               (symbol (symbol-package prefix)))))
    (intern (concatenate 'string (string prefix) (string name)) pkg)))
(defclass conc-name-class (standard-class)
  ((conc-name :initarg :conc-name :accessor class-conc-name)))
(defmethod validate-superclass ((class conc-name-class) (super standard-class))
  T)

上記では、standard-classメタクラスのサブクラスとしてconc-name-classメタクラスを定義してみています。

これで、ensure-class-using-classがディスパッチできるようになります。

(defmethod ensure-class-using-class ((class conc-name-class) name
                                     &rest initargs
                                     &key (conc-name (concatenate 'string (string name) ".") conc-name-sup?)
                                          direct-slots
                                     &allow-other-keys)
  (when conc-name-sup?
    (setq conc-name (car conc-name)))
  (setq direct-slots
        (loop :for s :in direct-slots
              :collect (destructuring-bind (&key name readers writers &allow-other-keys) 
                                           s
                         (let ((aname (slot-name-conc conc-name name)))
                           `(:name ,name
                             :readers (,aname ,@readers)
                             :writers ((setf ,aname) ,@writers))))))
  (let ((class (apply #'call-next-method class name :direct-slots direct-slots
                      initargs)))
    (setf (class-conc-name class) conc-name)
    class))

ensure-classと同じく、ensure-class-using-classが取るキーワード引数は、defclassのクラスオプションが渡ってきますので、以上で下記のように書けます。

(defclass foo ()
  (x 
   y 
   (z :accessor z))
  (:metaclass conc-name-class)
  (:conc-name foo.))
(let ((qqq (make-instance 'foo)))
  (with-slots (x y z) qqq
    (setq x 42 y 43 z 44))
  (incf (foo.z qqq))
  (list (foo.x qqq)
        (foo.y qqq)
        (foo.z qqq)))
→ (42 43 45) 

マクロ的なアプローチの問題点として

• defclassの派生構文ができてしまう

というのがありましたが、:metaclassを一々指定するのは面倒臭いもののdefclassの標準構文に収まりました。
また、

• マクロ内でdefclassのオプションを解析するのがめんどくさい

というのもensure-classが正規化して渡してくれるので、ensure-classよりはすっきりします。

しかし今度もあまりMOP的でない?

しかし、上記のコードを眺めると判るように前回とさして変化ありません。
アクセサの名前に接頭辞を付けるのだから、MOP的にするなら、スロット定義メタオブジェクトをあれこれするのが筋なのではないか、ということになります。

ということで、スロット定義のプロトコルをカスタマイズしてみます。

(defclass conc-name-direct-slot-definition (standard-direct-slot-definition)
  ((conc-name :initform nil :initarg :conc-name)))
(defmethod direct-slot-definition-class ((class conc-name-class) &rest initargs)
  (find-class 'conc-name-direct-slot-definition))
(defmethod initialize-instance :around ((sd conc-name-direct-slot-definition) &rest args &key name conc-name)
  (let ((aname (slot-name-conc conc-name name))
        (inst (call-next-method)))
    (pushnew aname (slot-definition-readers sd) :test #'equal)
    (pushnew `(setf ,aname) (slot-definition-writers sd) :test #'equal)
    inst))
(defmethod ensure-class-using-class ((class conc-name-class) name
                                     &rest initargs
                                     &key (default-conc-name (concatenate 'string (string name) ".") default-conc-name-sup?)
                                          direct-slots
                                     &allow-other-keys)
  (when default-conc-name-sup?
    (setq default-conc-name (car default-conc-name)))
  (apply #'call-next-method 
         class
         name
         :default-conc-name default-conc-name
         :direct-slots (mapcar (lambda (s)
                                 (if (getf s :conc-name)
                                     s
                                     (list* :conc-name default-conc-name s)))
                               direct-slots)
         initargs))

解説すると、まずデフォルトのstandard-direct-slot-definitionをカスタマイズするために、conc-name-direct-slot-definitionを定義します。
conc-name-direct-slot-definitionの中では、指定された接頭辞をもとにアクセサ名を生成します。
スロット定義では、:conc-nameで接頭辞を指定しますが、スロット定義メタオブジェクトを生成する時のキーワード引数はdefclassのスロットのキーワード引数が正規化されたものになりますので、単純に:conc-nameを追加しておけばOKです。

次に、このスロット定義を呼び出すために、direct-slot-definition-classが返すクラスをconc-name-direct-slot-definitionに設定します。
direct-slot-definition-classが返すクラスでスロット定義を生成するプロトコルなので、スロット定義のサブクラスを作ってカスタマイズしても、これに設定しないと有効にできません。

また、クラス定義の方で指定する接頭辞とスロットで指定する接頭辞を区別したいので、クラス定義の方は、default-conc-nameと変更します。

(defclass conc-name-class (standard-class)
  ((conc-name :initarg :default-conc-name :accessor class-conc-name)))

これでこんな感じに書けます

(defclass bar ()
  ((x :conc-name bar=) 
   (y :conc-name bar_) 
   (z :accessor z))
  (:default-conc-name bar.)
  (:metaclass conc-name-class))
(let ((qqq (make-instance 'bar)))
  (with-slots (x y z) qqq
    (setq x 42 y 43 z 44))
  (incf (bar.z qqq))
  (list (bar=x qqq)
        (bar_y qqq)
        (bar.z qqq)))
→ (42 43 45) 

スロットごとに接頭辞を付けて便利なことがあるかは不明ですが、スロット定義のプロトコルに従ったお蔭でおまけ的に別個に指定できたりします。

まとめ

以上、マクロだけでの実現からMOP的なものまでを順に考えてきましたが、MOPの方は作法を憶えるのが面倒臭いです。
まあしかし、MOPの作法は一応標準化されていますので、俺マクロの使い方を憶えるよりは、ましだったりするかもしれません。

■

HTML generated by 3bmd in LispWorks 7.0.0

長くなりそうなので数回に分けた記事にしようと思っていましたが、前回の記事を書くなかで自分の中では問題は解決してしまったので、続きを書くのをすっかり忘れていました。

それはさておき、前回は、お題を全部マクロで実現した訳ですが、今回は若干MOPよりです。
といっても、MOPが定めている便利ユーティリティを利用するのみでメタオブジェクトをあれこれという訳ではありません。 「マクロだけでがんばる」から「MOPだけでがんばる」の方向に進めて行き、丁度良い落とし所はどの辺りかを探っていければ良いなと考えています。

ensure-class を利用してみる

前回は、defclassのラッパーという感じでしたが、今回はMOPが定めるdefclassを組み立てるための関数であるensure-classを利用します。
ensure-classは、defclassを組み立てるための関数ともいえますし、ensure-classをお化粧したのがdefclassともいえるでしょう。
(setf (fdefinition 'foo) ...)と(defun foo (...) ...)のような関係と考えるとわかりやすいかと思います。

コードは長いので後ろに置きますが、ensure-classを使えばこんな感じのものに構成できます。

(defclass/conc-name foo ()
  (x 
   y 
   (z :accessor z))
  (:conc-name foo.))
;;; マクロ展開
===>
(eval-when (:compile-toplevel :load-toplevel :execute)
  (ensure-class 'foo
                :direct-superclasses 'nil
                :direct-slots '((:name x :writers ((setf foo.x)) :readers (foo.x))
                                (:name y :writers ((setf foo.y)) :readers (foo.y))
                                (:name z :writers ((setf z) (setf foo.z)) :readers (z foo.z)))
                :direct-default-initargs 'nil))
(let ((qqq (make-instance 'foo)))
  (with-slots (x y z) qqq
    (setq x 42 y 43 z 44))
  (incf (foo.z qqq))
  (list (foo.x qqq)
        (foo.y qqq)
        (foo.z qqq)))
→ (42 43 45) 

前回の問題点として

• defclassの派生構文ができてしまう
• マクロ内でdefclassのオプションを解析するのがめんどくさい

の二点がありましたが、ensure-classを使っても別段問題は解消されていません。
ensure-classを使った場合、:accessorは、:writerと:readerの組み合わせとして正規化する必要があるので、見通しが若干良くなるのかも、というところです。

オプションの解析部分をより拡張性のあるものにすれば(例えば総称関数にする等)、汎用的な構文として綺麗にまとめられるかもしれません。

既にこの辺りが落とし所な気はしますが、次回はさらにMOP的にすべくensure-class-using-classの活用を考えてみます。

付録: ensure-class を使ってみた場合の定義例

(defpackage 05d2b99b-651a-4352-ba04-47593339a944 
  (:use :c2mop :cl)
  (:shadowing-import-from :c2mop :defmethod :standard-class :defgeneric :standard-generic-function))
(in-package 05d2b99b-651a-4352-ba04-47593339a944)
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun canonicalize-slots (slots)
    (labels ((canonicalize-slot (slot)
               (typecase slot
                 ((and symbol (not null)) (list slot))
                 (T slot))))
      (mapcar #'canonicalize-slot slots)))
  (defun slot-name-conc (prefix name)
    (let ((pkg (etypecase prefix
                 ((or null string) *package*)
                 (symbol (symbol-package prefix)))))
      (intern (concatenate 'string (string prefix) (string name)) pkg)))
  (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 (lambda () ,v)) :into initform
          :when (eq k :writer) :collect v :into writers
          :when (eq k :reader) :collect v :into readers
          :when (eq k :accessor) :collect v :into readers :collect `(setf ,v) :into writers
          :finally (return
                    `(:name ,name
                      ,@initform
                      :writers ,writers
                      :readers ,readers)))))
(defmacro defclass/conc-name (name superclasses slots &rest class-options)
  (let* ((conc-name (concatenate 'string (string name) "-"))
         (class-options (loop :for opt :in class-options
                              :if (eq :conc-name (car opt))
                              :do (when (cadr opt)
                                    (setq conc-name (cadr opt)))
                              :else :collect opt)))
    `(eval-when (:compile-toplevel :load-toplevel :execute)
       (ensure-class ',name
                     :direct-superclasses '(,@superclasses)
                     :direct-slots '(,@(loop :for s :in (canonicalize-slots slots)
                                             :for aname := (slot-name-conc conc-name (car s))
                                             :collect (process-a-slot `(,@s :accessor ,aname))))
                     :direct-default-initargs '(,@class-options)))))

■

HTML generated by 3bmd in LispWorks 7.0.0

オブジェクト指向システムを拡張する際に、痒い所に微妙に手が届かない気がするMOPと、なんでもできるけど安易なメタプログラミングも嫌だなあというマクロで使い分けに迷うことはないでしょうか。

例えばですが、defstructにはアクセサを自動で生成する機能があり、この機能については善し悪しがありますが、defclassで同様のアクセサの自動生成を実装するとします。
さて、こういう場合、MOPで実現するのが良いのか、マクロでやっつけてしまえば良いのか微妙に悩んだりしないでしょうか(自分だけ?)

defclassでアクセサの生成をするということは、定義時には名前が確定しているということで、マクロが担当するのが良い気もします。
しかしクラスに関することなので、MOPを使った方が既存の構文の枠組みで拡張できたりもしそうです。

どっちもどっちなのですが、とりあえずはマクロで書いてみました。
defclass/conc-nameは、defcassに展開されるマクロですが、:conc-nameでアクセサの接頭辞を指定できます。

(defclass/conc-name foo ()
  (x 
   y 
   (z :accessor z))
  (:conc-name foo.))

;;; マクロ展開
===>
(defclass foo ()
  ((x :accessor foo.x)
   (y :accessor foo.y)
   (z :accessor z :accessor foo.z)))

(let ((qqq (make-instance 'foo)))
  (with-slots (x y z) qqq
    (setq x 42 y 43 z 44))
  (incf (foo.z qqq))
  (list (foo.x qqq)
        (foo.y qqq)
        (foo.z qqq)))
→ (42 43 45) 

defclass/conc-name定義

(defun canonicalize-slots (slots)
  (labels ((canonicalize-slot (slot)
             (typecase slot
               ((and symbol (not null)) (list slot))
               (T slot))))
    (mapcar #'canonicalize-slot slots)))
(defun slot-name-conc (prefix name)
  (let ((pkg (etypecase prefix
               ((or null string) *package*)
               (symbol (symbol-package prefix)))))
    (intern (concatenate 'string (string prefix) (string name)) pkg)))
(defun ->conc-name (name)
  (etypecase name
    (null "")
    (symbol (string name))
    (string name)))
(defmacro defclass/conc-name (name superclasses slots &rest class-options)
  (let* ((conc-name-p nil)
         (conc-name (concatenate 'string (string name) "-"))
         (class-options (loop :for opt :in class-options
                              :if (eq :conc-name (car opt))
                              :do (setq conc-name-p T
                                        conc-name (->conc-name (cadr opt)))
                              :else :collect opt)))
    `(defclass ,name (,@superclasses)
       (,@(loop :for s :in (canonicalize-slots slots)
                :when conc-name-p
                :do (setf (cdr (last s)) 
                          (list :accessor (slot-name-conc conc-name (car s))))
                :collect s))
       ,@class-options)))

マクロで実装してみた感想

マクロで書いた場合ですが、今回の場合は、

• defclassの派生構文ができてしまう
• マクロ内でdefclassのオプションを解析するのがめんどくさい

等々が問題かなと感じます。

defclassのオプションを解析するのがめんどくさいのは、defclassの作法に従おうとした結果で、その方が、使い手も類推できて良かろうという判断なのですが、どうせ拡張された構文なので解析しやすそうな構成にすることも可能かなとは思います。
defstructの作法に近付けるなら、

(defclass/conc-name (foo (:conc-name foo.)) ()
  (x 
   y 
   (z :accessor z)))

のようにできるかもしれません。
問題は、defclass/conc-nameはdefstructの作法で書くという情報の取扱がめんどう(使う側の人が色々憶えないといけない)ということです。

利用者の負担を減らすということでは、構文乗っ取り型マクロにしてしまう手もなくはありませんが、どうなんでしょう。

(with-conc-name foo.
  (defclass foo ()
    (x 
     y 
     (z :accessor z))))
;; or
(with-accessor-options ((:conc-name foo.)
                        (:foo opt))
  (defclass foo ()
    (x 
     y 
     (z :accessor z))))
...

この場合は、見掛け上defclassが本体に見えますがwith-conc-nameがdefclassフォームを引数として処理することになります。

トリッキーですが派生構文を処理する場合には、defclass/conc-nameのような新しい名前を導入せずに既存の作法を継承できるので、一番スマートな方法だったりするかもしれません。

次回はMOPの作法で考えてみます。

■

HTML generated by 3bmd in LispWorks 7.0.0

たまにCommon Lisp標準が利用するキーワードシンボル一覧が欲しい時がありますが、どこにあるんでしょうか。

とりあえずのところは、HyperSpecのインデックスが利用できると思います。

• Common Lisp HyperSpec: Index

しかし、どこかにキーワードシンボルだけまとめたものがありそうなのですが……。

少し探しても見当らなかったので、HyperSpecを参考に逆引きCommon Lispに記事を作成してみました。

• Common Lisp標準が利用するキーワードシンボル一覧

ちなみに、HyperSpecのものは記事からインデックスを自動生成かなにかをしているようでタイポがあったり、コード例に使われているだけのキーワードシンボルも計上されているようです。

まとめ

エディタの補完機能まわりをカスタマイズしているときに関数が利用するキーワードだけを補完して欲しいのですが、まずは補完対象の一覧が欲しいなと思って、ここに至ります。
ひょっとしたら、ANSI Common Lisp規格票には掲載されていたりするかもと思い確認してみましたが、こちらにも無いようです。うーむ。

■

HTML generated by 3bmd in LispWorks 7.0.0

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

Lisp的進捗

ここ数年マニアックなLispネタでアドベントカレンダーを開催することで、色々調べたりしてLispのマイナー機能に詳しくなるというのをやっていました。
2017年はお休みしたのですが、若干の悔いが残ったので、2018年は、setfとメソッドコンビネーションネタでやってみました。
毎回これ以上はないなという所まで掘り下げられるので良い勉強になります(多分)。

メソッドコンビネーションに関しては、まだ掘り下げて書けることがありそうなので、そのうちちょっと書いてみたいと思います。

ブログ

今年書いた記事は72記事だったようです。
アドベントカレンダーで50記事位書いたのを除けば、大体二週間に一記事書いたり書かなかったりというところです。
近年、ブログを書く人も大分少なくなりましたが、2019年もそこそこ書いていきたいと思います。

LispWorks

LispWorksを購入してから早三年半ですが、持ち前の吝嗇根性からLispWorksを使い倒すべくメインに使い続けています。

ちなみに、以前は、SBCLをメインに使っていました。
SBCLはコンパイラ優秀で、実行速度からいうとほぼ最速の処理系で、ユーザーも一番多く、その上自由ソフトな処理系ということもあり、これ以外の選択はないだろうという感じでもあるのですが、GUIツールキット、Common Lispと統合された開発環境、出荷機能まで一通り揃っている完成度の高い処理系というとLispWorks、Allegro CL、MCL位しかありません。
Allegro CLは個人で使うにはお値段が謎、MCLはPPC Macと共に過去のものになってしまった等で、現実的な統合環境としてはLispWorks位かなと思います。

また、職場の社内ツールをLispWorksで作成してみたところ、色々な条件がたまたま上手くはまり、現在もLispWorksで開発が進んでいます。

• 社内にLispWorksユーザーがたまたま二人いた
• MacでGUIのアプリが必要だったので、LispWorksのCAPIに詳しい人がプロトタイプを作ってみたら手早くできちゃった

というところで、まさに偶然ですが、折角の機会なので活用していきたいところです。
ちなみに開発は同僚にお任せしているので、たまに思い付きの機能追加をしてみたりする以外では私はほとんど開発してません😺

2019年やってみたいこと

ここ二三年でLispマシンのエミュレータも、CADR、LMI Lambda、Symbolics Open Genera、TI Explorer、等一通り出揃いましたが、あまりキャッチアップできてないので2019年は力を入れようかなと思っています。

あと年末には、コンディションシステムアドベントカレンダーを開催したいので、色々準備しておきたいところです。

過去のまとめ

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

《 Lisp SETF Advent Calendar 2018 25日目 》

メソッドコンビネーションでアドベントカレンダーを開催することを決めてから、もう一品と考えてsetfアドベントカレンダーを開催してみましたが、後半はネタを捻り出すのがきつかったです。

よくよく考えれば、ただの代入機構なので、話題が広げられる余地はあまりないのですが、ファーストクラスの参照を持つLISP方言についてもうちょっと掘り下げて書けたかもしれません(といっても一回分位だと思いますが)

setfアドベントカレンダーのを書いたお蔭で、setfの定義構文の使い分けについて、きっちり把握できたのは収穫かなと思います。

-完-

■

HTML generated by 3bmd in LispWorks 7.0.0

《 Lisp メソッドコンビネーション Advent Calendar 2018 25目 》

メソッドコンビネーションでアドベントカレンダーは無謀かなと思いましたが、果してそれなりに無謀でした。

このアドベントカレンダーでの収穫は、eshamsterさんに define-method-combinationの詳細な解説を書いて頂けたことかなと思います。
今後define-method-combinationを書く際には参照することも多くなるのではないでしょうか。

• define-method-combinationを理解する
• 小ネタ: define-method-combinationで遊ぶ

メソッドコンビネーションについて分かったこと

私的にメソッドコンビネーションについて分かったことを纏めると

• define-method-combinationは、Common Lispには珍しく細部仕様の詰めが甘いらしい
• :aroundはメソッド周囲をletで囲むような使い方をするもので、:afterや、:beforeとは一線を画す(ので同じ感覚で多用するものではなさそう)
• 割とカジュアルに定義して使うことを考えていたらしい(New flavorsあたりの論文では)
• メソッドの分別の単位はメソッド修飾子。なのでクラスの継承関係とは別個に構成可能。かと思えば、メソッドコンビネーションにメソッドを参加させるためにmixinするようなことも行われていたらしい。
• メソッドの組織化全般に使える

位でしょうか。

メソッドコンビネーションは、まだまだ開拓の余地があると思いますので、今後、さらに活用されることを期待しています。

-完-

■

HTML generated by 3bmd in LispWorks 7.0.0

《 Lisp メソッドコンビネーション Advent Calendar 2018 24目 》

前回、MOPでのメソッドコンビネーションAPIの実現は、紆余曲折ありつつ、曖昧なところを残しているらしい、と書きました。
今回は、ANSI CLでは取り入れられなかったMOP仕様の草案である X3J13-88-003R の 1988-03-11 版にメソッドコンビネーションのAPIについての記述があったので、それを実際に動かしてみて、どのような設計方針であったのかを探ります。

なお、X3J13-88-003R の 1988-03-11版はTeXをPDFにしたものがこちらにありますので、適宜参照してください。

• Common Lisp Object System Specification: 3. Metaobject Protocol (1988-03-11)

下準備

シンボル名の競合がありそうなので、専用のパッケージを作成します。

(defpackage X3J13-88-003R
  (:use :cl :c2mop)
  (:shadowing-import-from :c2mop
   :defmethod :standard-class :defgeneric :standard-generic-function)
  (:shadow :define-method-combination))
(in-package :X3J13-88-003R)

メソッドコンビネーションクラスの定義

method-combinationのサブクラスにstandard-method-combinationとsimple-method-combinationが標準で用意されています。
ただ使い分けについてはいまいちはっきりしません。
とりあえず記述をそのままコードにしています。

(defclass x3j13-88-003r-method-combination (method-combination)
  ((name
    :initarg :name
    :reader method-combination-name)
   (order
    :initarg :order
    :reader method-combination-order)
   (operator
    :initarg :operator
    :reader method-combination-operator)
   (identity-with-one-argument
    :initarg :identity-with-one-argument
    :reader method-combination-identity-with-one-argument)
   (documentation 
    :initarg :documentation))
  (:default-initargs
   :name nil
   :order :most-specific-first
   :operator nil
   :identity-with-one-argument nil
   :documentation nil))
(defclass standard-method-combination (x3j13-88-003r-method-combination)
  ())
(defclass simple-method-combination (x3j13-88-003r-method-combination)
  ())
(defclass short-form-method-combination (simple-method-combination) ())

ここでは、x3j13-88-003r-method-combinationをmethod-combinationのサブクラスにしていますが、恐らくこの定義が、method-combinationの定義になる予定だったのでしょう。

ANSI CLのdefine-method-combinationで指定するようなオプションが、method-combinationの方で定義されていることが分かります。

メソッドコンビネーションオブジェクトのメソッド

メソッドコンビネーション名からメソッドコンビネーションオブジェクトを引いてくるのにmethod-combination-objectを定義します。
AMOPのfind-method-combinationとほぼ同じですが、こちらは総称関数は指定しません。
中身のコードは大体想像で書いています。

(defgeneric method-combination-object (name options))
(defmethod method-combination-object ((name (eql nil)) options)
  (class-prototype 'standard-method-combination))
(defmethod method-combination-object ((name (eql nil)) options)
  (class-prototype 'standard-method-combination))
(defmethod method-combination-object 
           ((name (eql 'standard-method-combination)) options)
  (class-prototype 'standard-method-combination))

define-method-combinationの定義

define-method-combinationは、名前を指定するだけでmethod-combination-objectを簡便に定義できるような位置付けになっています。

short-form-method-combinationが決め打ちになっているのですが、意図的なものなのか間違いなのかははっきりしません。

(defmacro define-method-combination (name &key (documentation nil)
                                          (operator name)
                                          (identity-with-one-argument nil))
  `(defmethod method-combination-object
              ((name (eql ',name))
               options)
     (apply (lambda (&optional (order ':most-specific-first))
              (check-type order (member :most-specific-first
                                        :most-specific-last))
              (make-instance 'short-form-method-combination
                             :name ',name
                             :order order
                             :documentation ',documentation
                             :operator ',operator
                             :identity-with-one-argument
                             ',identity-with-one-argument))
            options)))

メソッド呼び出しのフォームを作るユーティリティ

make-method-callというユーティリティがあったようですが、このインターフェイスではメソッドの引数を上手く取り扱えないということで廃止になったようです。

ユーティリティが何もない現在は結局ベタ書している状況ですが、このmake-method-callを使っても大抵は問題はなさそうではあります。

なお、このコードも使用例から想像して書いています。

(defun make-method-call (method-list &key operator identity-with-one-argument)
  (case operator
    (:call-next-method `(call-method ,(car method-list)
                                     ,(cdr method-list)))
    (ohterwise `(,operator 
                 ,@(loop :for m :in method-list :collect `(call-method ,m))))))

大体これくらいの定義ですが、これだけでもメソッドコンビネーションが定義できます。

compute-effective-method

define-method-combinationは、メソッドコンビネーションオブジェクトに名前を付けて登録する程度の役割になっていましたが、代りにcompute-effective-methodが式の組み立てのメインになります。

(defmethod compute-effective-method (generic-function
                                     (mc short-form-method-combination)
                                     methods)
  (let ((primary-methods (remove (list (slot-value mc 'name))
                                 methods :key #'method-qualifiers
                                 :test-not #'equal))
        (around-methods (remove '(:around)
                                methods :key #'method-qualifiers
                                :test-not #'equal)))
    (when (eq (slot-value mc 'order) ':most-specific-last)
      (setq primary-methods (reverse primary-methods)))
    (dolist (method (set-difference methods
                                    (union primary-methods around-methods)))
      (error "The qualifiers of ~S, ~:S, are not ~S or ~S"
             method (method-qualifiers method)
             (list (slot-value mc 'name)) '(:around)))
    (make-method-call `(,@around-methods
                        (make-method 
                         ,(make-method-call primary-methods
                                            :operator (slot-value mc 'operator)
                                            :identity-with-one-argument
                                            (slot-value mc 'identity-with-one-argument))))
                      :operator :call-next-method)))

メソッドを定義してみる

ではメソッドを定義して動作を確認してみましょう。
総称関数の:method-combination指定が構文チェックでエラーになったりするのでensure-generic-functionを直に使ってみます。

(define-method-combination foo :operator :call-next-method)
(ensure-generic-function 
 'zot 
 :lambda-list '(x)
 :method-combination (method-combination-object 'foo nil))
;; ≡ (defgeneric zot (x))
;;
;;    (setf (generic-function-method-combination #'zot)
;;          (method-combination-object 'foo nil))

(defmethod zot foo (x) (list :p x))
(defmethod zot foo ((x integer)) (list :p 'integer (call-next-method)))
(defmethod zot :around (x) 
  (list :around (call-next-method)))

(zot 8)
→ (:around (:p integer (:p 8))) 

• メソッドコンビネーション展開

(compute-effective-method #'zot 
                          (method-combination-object 'foo nil)
                          (compute-applicable-methods #'zot (list 8)))
→
(call-method
 #<standard-method zot (:around) (t) 41E012FF53>
 ((make-method
   (call-method
    #<standard-method zot (foo) (integer) 41E012FCDB>
    (#<standard-method zot (foo) (t) 41E01306C3>))))) 

上手く動いているようです。

まとめ

以上、X3J13 88-003Rでの定義でしたが、それなりにすっきり纏まっている気がします。
define-method-combinationの:argumentsオプションについては触れられていないのですが、compute-discriminating-functionの祖先の定義お眺める限りは、compute-discriminating-functionがcompute-effective-methodの内容を元に関数オブジェクトを生成する際、総称関数の引数と連結するスコープを差し込むつもりだったのかなと想像しています。

(generic-function (gf-args ...)
  ((lambda (args ...) ;;; define-method-combination の :arguments
     ,@effective-method)
   gf-args ...))

謎が多い、define-method-combinationまわりですが、MOPベースだったら、もうちょっとカスタマイズされたメソッドコンビネーションも活用されていたかもしれません(そうでもないか)

■

HTML generated by 3bmd in LispWorks 7.0.0

《 Lisp SETF Advent Calendar 2018 24日目 》

これまでも何度かget-setf-expansionや、define-setf-expanderを利用する例を取り上げてきましたが、返り値が5つもあります。
そのお蔭で、多値の何番目がなんの役割だったか毎度調べたりしていますが、これだとちょっと面倒なので、専用構文を作って開発環境のシンタックス補完等の恩恵に与る作戦を考えました。

まずは、get-setf-expansionですが、キーワード引数ならぬ、キーワード多値で値を返すことにしてみました。

(defun get-setf-expansion* (place &optional env)
  (multiple-value-bind (vars vals store-vars writer-form reader-form)
                       (get-setf-expansion place env)
    (values :vars vars
            :vals vals
            :store-vars store-vars
            :writer-form writer-form
            :reader-form reader-form)))

• 素のget-setf-expansion

(get-setf-expansion '(ldb bytespec i))
→ (#:g255423) 
   (bytespec) 
   (#:g255424) 
   (let ((#:|Store-Var-255422| (dpb #:g255424 #:g255423 i)))
     (setq i #:|Store-Var-255422|)
     #:g255424) 
   (ldb #:g255423 i) 

• 拡張したget-setf-expansion*

(get-setf-expansion* '(ldb bytespec i))
→ :vars 
   (#:g255429) 
   :vals 
   (bytespec) 
   :store-vars 
   (#:g255430) 
   :writer-form 
   (let ((#:|Store-Var-255428| (dpb #:g255430 #:g255429 i)))
     (setq i #:|Store-Var-255428|)
     #:g255430) 
   :reader-form 
   (ldb #:g255429 i) 

返り値に注釈が付けば、位置とその役割を忘れても大丈夫です。

次に、このキーワード多値を受ける構文を考えてみました。

(defmacro setf-expansion-bind 
          ((&key vars vals store-vars writer-form reader-form)
           setf-expansion-form
           &body body)
  (loop :for (k . v) :in `((:vars . ,vars)
                           (:vals . ,vals)
                           (:store-vars . ,store-vars)
                           (:writer-form . ,writer-form)
                           (:reader-form . ,reader-form))
        :when v :collect `((,k ,v)) :into key-args
        :finally (return 
                  `(macrolet ((setf-expansion-values (&key vars vals store-vars writer-form reader-form)
                                `(values ,vars ,vals ,store-vars ,writer-form ,reader-form)))
                     (multiple-value-call 
                         (lambda (&key ,@key-args &allow-other-keys) 
                           ,@body)
                       ,setf-expansion-form)))))

ボディの中では、setf-expansion-valuesオペレーターで注釈付きで多値を記述できるようにしてあります。

(setf-expansion-bind (:vars vars 
                      :vals vals
                      :store-vars store-vars
                      :writer-form writer-form
                      :reader-form reader-form)
                     (get-setf-expansion* '(ldb bytespec i))
  (setf-expansion-values :vars vars 
                         :vals vals
                         :store-vars store-vars
                         :writer-form writer-form
                         :reader-form reader-form))
→ (#:g255477) 
   (bytespec) 
   (#:g255478) 
   (let ((#:|Store-Var-255476| (dpb #:g255478 #:g255477 i)))
     (setq i #:|Store-Var-255476|)
     #:g255478) 
   (ldb #:g255477 i) 

記述は面倒ですが、たまにしか使わないのとキーワードによる注釈が付くので扱いやすい気がします。
ごちゃごちゃしたキーワード引数はSLIME等でまとめて補完可能なので手打ちする必要はありません。

まとめ

今回は、構文定義 & IDEでの補完 の組み合わせで考えてみましたが、get-setf-expansionのフォームをmultiple-value-bindのフォームで包むような補完ができるIDEの拡張を作ってみても良いかなと思ったりしています。

■

HTML generated by 3bmd in LispWorks 7.0.0

《 Lisp SETF Advent Calendar 2018 23日目 》

あと三回setfネタで記事を書かないといけないのですが、何が書けるでしょうか。

とりあえず、今回はsetfのような代入構文をさらに便利にしたような構文を紹介してみたいと思います。

自己代入系

これまで自己代入系の定義構文を紹介したりしましたが、都度定義するのではなく、汎用的なものを定義して使う、というパターンです。

Gauche: update!

(update! place proc)という形式ですが、incfみたいなものは、

(let ((x (list 0)))
  (update! (car x) (lambda (v) (+ v 1))) 
  x)
→ (1)

と書けます。
define-modify-macroで一々定義するよりずっと良いですね。

Arc: zap

Gaucheのupdate!とほぼ同じです。引数の順番と名前が違う位です。

(let x (list 0)
  (zap (fn (v) (+ v 1))
       (car x)) 
  x)
→ (1)

TAO/ELIS: !!

以前も紹介しましたが、TAOの!!は自己代入専用の構文です。
!で印を付けた場所に書き戻せます。

(let ((x (list 0)))
  (!!(lambda (v) (+ v 1)) !(car x))
  x)
≡
(let ((x (list 0)))
  (!!1+ !(car x))
  x)

その他便利なユーティリティ

私見ではPaul Graham氏は面白い代入系ユーティリティを定義しているので、2、3眺めてみます。

Arc: pull

Common Lispのremove-ifとsetf`を組合せた感じです。

(let x '(1 100 2 50 3) 
  (pull [< _ 10] x) x)
→ ((100 50) foo) 

pushend

pushは先頭に追加なので末尾に追加したい場合に使えます

(let ((x (list 0 1 2)))
  (pushend 100 x)
  x)
→ (0 1 2 100) 

merge-into

述語で場所を探してマージします。

(let ((x (list 0 1 2 0 0 0 8 2 -1)))
  (merge-into x 5 #'<)
  x)
→ (0 1 2 0 0 0 5 8 2 -1) 

元定義は下記のような感じですが、define-modify-macroでlambda式を取れるのは処理系拡張なので、可搬的に書くならdefmacroで定義する必要があるでしょう。

しかしdefine-modify-macro版だとpushendの定義のnconcがすっぽ抜け問題が発生しそうな見た目が気持ち悪いですが、define-modify-macroの展開ではplaceに代入し直されるので大丈夫です。

;;; http://lib.store.yahoo.net/lib/paulgraham/utx.lisp

(define-modify-macro pushend (obj)
  (lambda (place obj)
    (nconc place (list obj))))
(define-modify-macro merge-into (obj fn)
  (lambda (place obj fn)
    (merge 'list place (list obj) fn)))