Common Lispには、prog1、prog2、prognとありますが、Lispは0オリジンなのに、(nth 0)な場所の値を返すprog1、(nth 1)な場所の値を返すprog2、って整合性がないなあ、一方Scheme畑では、美しく、begin0と命名する(Racket等)……という小話がありますが、なぜCommon Lispは1オリジン風なのでしょうか

;;; Welcome to Racket v7.8.
(begin0 0 1 2 3)
→ 0

A. 元々の数字はフォームのアリティだったから

Common Lispには、prog1、prog2、prognとありますが、Lisp 1.5まで遡ると、prog2しかありませんでした。
この時のprog2は、2つのフォームをとれるフォームで最後の値を返すものでした。

これが、PDP-6 Lisp(1966)で、prog2が可変長の引数を取れるように進化。値を返す場所は変更なし、ということで、「二番目のフォームの値を返す」もの、という感じになってしまいました。

• PDP-6 LISP

続いて、progn(1968あたり)、prog1(1977あたり)が続きます。

まとめ

可変長のフォームで、N番目のフォームの値を返す、というのは割合に発明だった気がしますが、命名則としてはねじれたことになってしまったようです。

■

HTML generated by 3bmd in LispWorks 7.0.0

以前、ANSI CL規格(INCITS 226-1994)の規格の更新について議論しているログを眺めたことがあったのですが、その中で、Jon L White氏が「loop にもっと括弧を」という意見を出していました。
この議論のログは確かウェブで参照できた筈ですが、今やまったく見付かりません。結構貴重な資料だと思いますが……。

loopをLispyに改善したものといえば、iterateだと思いますが、括弧をつけるだけなら、簡単な処理で実現できるなと思ったので試してみました。

(defmacro for (&rest body)
  `(loop 
    ,@(reduce (lambda (res b)
                (append res (->loop-clause b)))
              body
              :initial-value nil)))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun ->loop-clause (xpr)
    (case (find (car xpr) '(let) :test #'string-equal)
      (let (destructuring-bind (let &rest args)
                               xpr
             (declare (ignore let))
             `(for ,@args)))
      (otherwise xpr))))

要するにloopに余計な括弧を付与するだけですが、まあまあそれっぽくなります。

(for (let i :from 0)
     (let j :from 0)
     (repeat 16)
     (if (oddp i)
         :collect i :into es)
     (collect i :into is)
     (collect j :into js)
     (finally (return (list es is js))))
→ ((1 3 5 7 9 11 13 15)
    (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)
    (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15))

loopだと:do節の後にprognを補ったりしがちですが、括弧で囲むと範囲がはっきりするので安定感があります。

(for (repeat 5)
     (do (print 'hello-world)
         (terpri)))
▻ 
▻ hello-world 
▻ 
▻ hello-world 
▻ 
▻ hello-world 
▻ 
▻ hello-world 
▻ 
▻ hello-world 
→ nil

まとめ

もうちょっと凝ったことをしようと思ったら素直にiterateを使う方が良いとは思いますが、案外上手くいっちゃってる感。
もっとも、JonL氏がいう「もっと括弧を」、というのは恐らくiterateのようなものを指しているのだとは思いますので誤解なきよう。

■

HTML generated by 3bmd in LispWorks Personal Edition 7.1.2

setf可能な場所なのかどうかを確認したい、というのは、そもそもどういう動機からなのかというと、身近な例では、(setf nthcdr)等と書いた時に、

(let ((x (list 0 1 2 3 4)))
  (setf (nthcdr 1 x) (list 'a 'b 'c))
  x)
!Error: Undefined operator (setf nthcdr) in form ((setf nthcdr) #:|Store-Var-34450| #:g34451 #:g34452).

となってしまい、あれ、(setf nthcdr)って設定されてないんだっけ?というようなことを防止したい、というような動機です。

上記の場合、

(let ((x (list 0 1 2 3 4)))
  (setf (cdr (nthcdr 0 x)) (list 'a 'b 'c))
  x)
→ (0 a b c)

と書き直せば良いのですが。

考えられそうなアプローチ

• setfできそうな場所は全部setf対応しておく
• setfの展開を制御するユーティリティマクロで頑張ってみる
• 標準規格で定義されているsetfの場所以外のものは一切書かない

等々、色々ありますが、まず、setfして回るのは、処理系を改造することになるので、ちょっと嫌なのと、やるとしてもsetfの展開方法が処理系ごとに結構違っているので、setfを設定するコードの可搬性を担保するのが結構難しい。

次に、ユーティリティマクロで囲んだり、setfの類似品を作る的なところですが、この問題をコードウォークして解決するとしても、局所関数/マクロでsetfを定義できたりするので結構大変でしょう。

標準規格で定義されているsetfの場所以外のものは一切書かない、というのは若干寂しいですが、これはこれでありかなと思います。

標準の(setf place)を一覧にする

標準の(setf place)を全部把握したい、ということで、CLHS: 5.1.2 Kinds of Placesで定義されているものを、列記してみます。

変数名全部

これは問題ないでしょう

標準定義の関数フォーム形式

(setf bit)
(setf c[ad]+r) ;car cdr系全部
(setf char)
(setf class-name)
(setf compiler-macro-function)
(setf documentation)
(setf elt)
(setf fdefinition)
(setf fifth)
(setf fill-pointer)
(setf find-class)
(setf first ... tenth) ; firstからtenthまで
(setf rest)
(setf get)
(setf getf)
(setf gethash)
(setf ldb)
(setf logical-pathname-translations)
(setf macro-function)
(setf mask-field)
(setf nth)
(setf readtable-case)
(setf row-major-aref)
(setf sbit)
(setf schar)
(setf slot-value)
(setf subseq)
(setf svref)
(setf symbol-function)
(setf symbol-plist)
(setf symbol-value)

Apply との組み合わせ

上記に加えて、Applyのフォームと組合せ可能なものとして、aref、bit、sbitがあるので、

(setf (apply #'aref))
(setf (apply #'bit))
(setf (apply #'sbit))

Values との組み合わせ

上記の関数フォームに組合せ可能なものとして更にvalues

(setf values)

the との組み合わせ

さらに組合せ可能なものとして、the

(setf the)

setf系マクロ

decf pop pushnew incf push remf あたりのマクロですが、define-modify-macroで定義したように動くので、valuesと組合せて使うことは想定されていない様子。
LispWorksに至ってはエラーになります。

まとめ

標準の組み合わせだけでも、結構複雑な組み合わせは可能です。

(let ((ba (make-array '(4 4) 
                      :element-type 'bit 
                      :initial-element 1))
      (bb (make-array '(4 4) 
                      :element-type 'bit 
                      :initial-element 1)))
  (setf (values (the bit (apply #'bit ba '(0 0)))
                (the bit (apply #'bit bb '(0 0)))) 
        (values 0 0))
  (values ba bb))
→ #2A((0 1 1 1) (1 1 1 1) (1 1 1 1) (1 1 1 1))
  #2A((0 1 1 1) (1 1 1 1) (1 1 1 1) (1 1 1 1))

(let ((a (make-array '(4 4) :initial-element 0)))
  (incf (the integer (apply #'aref a '(1 1))))
  a)
→ #2A((0 0 0 0) (0 1 0 0) (0 0 0 0) (0 0 0 0))

便利なsetfマクロですが、あまり複雑なことはしない方が良いのかなと(月並)
ただ、(setf values)については、色々なソースを眺めていても、あまり活用されていない気がするので、もっと活用されても良いかなと思います。

■

HTML generated by 3bmd in LispWorks 7.0.0

LispWorksでコードを書いていて、

(let ((x 42)
      (x 69))
  x)
→ 42

みたいなものがエラーにならなかったので、コンパイラの最適化のバグか何かかと思って他の処理系でも試してみたところ、SBCLやCMUCL、ECLではエラーになるものの他の処理系では特にエラーにならないようです。

もしや規格上は問題ないのかと思ってHyperSpecを確認してみると、特に記載がない様子。

Common Lispはlambdaに展開される訳ではないので、lambdaでの重複チェックとは別になっているのかなと思い、lambdaも確認してみましたが、

((lambda (x x) x) 42 69)
→ 69

これもSBCLやCMUCL、ECL、CCL以外では、エラーにならない様子(CCLはこちらはエラーにするらしい)

λリストについても、重複については特に記載がない様子。

Scheme(R7RS)ではエラーと規定されているので、そういうものだと思っていましたが、実際の処理系で試してみると、Schemeの処理系でも動作はまちまちでした。
Scheme流の「エラーという定義だけど、どうエラーを処理するかは規定しない」ってやつでしょうか。

まとめ

束縛部の変数名の重複チェックが緩いのは、バグの元になるので、何らかの方法でユーザーに通知して欲しいですね。
マクロでコード生成するのが頻繁なLisp系言語では特にですが。
SBCLで虫取りが捗るのは、割とこういう類のチェックが充実しているというのもあると思います。

■

HTML generated by 3bmd in LispWorks Personal Edition 7.1.2

古えのLucid CLのソースを眺めていて、こんなコードに遭遇したのですが、これがなかなか味わい深い。
コードの作者はJonL氏。

(defun find-named-slot (slot-name slotds &optional (no-error-p nil))
  (cond ((loop for slotd in slotds
               thereis (and (eq slot-name (%slotd-name slotd))
                            slotd)))
        (no-error-p nil)
        (t (system-error hhctb))))

condの述語部の返り値を活用しているのですが、Franz Lispのifでいうthenretの活用です。

• thenret

実際に最近の処理系でも動くように書き直すと下記のようになるでしょうか。
(ついでにloopのthereisもfindに置き換え)

(ql:quickload "closer-mop")
(in-package c2cl)
(defun find-named-slot (slot-name slotds &optional (no-error-p nil))
  (cond ((find slot-name slotds :key #'slot-definition-name))
        (no-error-p nil)
        (t (error "How the hell can this be?!"))))

(defclass foo ()
  (a b c))

(find-named-slot 'a (class-slots (find-class 'foo)))
→ #<standard-effective-slot-definition a 411021F02B> 

(find-named-slot 'z (class-slots (find-class 'foo)))
>> Error: How the hell can this be?!

ちなみに、hhctbは、MACLISPのエラーコードで、“How the hell can this be?!”の略みたいです。
色々検索してもヒットしないので、もしかするとJonL氏以外使ってないんじゃないでしょうか。

上記をifの連鎖で書くと下記のようになります。

(defun find-named-slot (slot-name slotds &optional (no-error-p nil))
  (let ((slotd (find slot-name slotds :key #'slot-definition-name)))
    (if (not (null slotd))
        slotd
        (if no-error-p
            nil
            (error "How the hell can this be?!")))))

ifで書き直してみると、no-error-pのあたりも含めて、thenretだけでなくcondを上手く活用していることが分かります。

thenretに類似するところでは、orの返り値を活用するというのがありますが、慣れないと少し解読が難しいかも。

(defun find-named-slot (slot-name slotds &optional (no-error-p nil))
  (let ((slotd (find slot-name slotds :key #'slot-definition-name)))
    (or slotd
        (and (not no-error-p)
             (error "How the hell can this be?!")))))

ちなみにrmsのLispコードではこういうパタンが多用されています。

まとめ

伝統的なLispでの thenret は多値を返さない(せない)のですが、srfi-61では、多値を活かすことができる仕組みになっています。

(cond ((values 0 1) values => values)
      (else #f))

アナフォリックマクロのit、when-let等もthenretの文脈に近いものがありますが、慣れると結構活用できる気がします。

■

HTML generated by 3bmd in LispWorks Personal Edition 7.1.2

ボディ部にドキュメンテーション文字列しかない場合について、というのは具体的には、

(lambda (x) "λ[[x]]")
(defun foo (x)
  "λ[[x]]")

のような場合ですが、上記のように書いてしまうと、ドキュメンテーション文字列ではなくて、返り値(フォームの最後の値)となってしまいます。

(mapcar (lambda (x) "λ[[x]]")
        '(0 1 2 3))
→ ("λ[[x]]" "λ[[x]]" "λ[[x]]" "λ[[x]]")

(documentation 'foo 'function)
→ NIL

この場合、二通りの解決策があり、返り値として、nilを明示的に書く、空のdeclareを書くことで回避可能です。

(defun foo (x)
  "λ[[x]]"
  (declare))

(mapcar #'foo
        '(0 1 2 3))
→ (NIL NIL NIL NIL)

空のボディを生成してしまうのが悪いのでは?という話もありますが、マクロ等でコード生成した場合に意図せず生成されてしまうことは結構あります。

この場合、(declare)を入れておく方が、明示的にnilという値を入れるより生成するコードが簡単になるかなと思います。

以上、非常にニッチな話でした。

■

HTML generated by 3bmd in LispWorks Personal Edition 7.1.2

ちょっとした内容を単一ファイルに記述し、それをロードして実行させたいことは結構あります。
こういう場合には論理パスを使うのが便利だということを最近発見したので、それについて書きたいと思いますが、その前に一般的な方法も改めて考察してみましょう。

ASDFを使う

ASDFを使うまでもない、という感もあるのですが、Quickproject等、プロジェクトの雛形をさっと作れるツールがあるので、中身が1ファイルしかないといっても対した手間ではないでしょう。
実際Quicklispにも単一ファイル規模のプロジェクトは結構あります。

ただ、quicklispがセットアップできてなかったり、ASDFのシステムがうまく登録されてなかったりで、すったもんだすることは割とあります。

(ql:quickload 'foo)
(foo::main)

みたいなファイルを、lisp --load foo.lisp したりするわけですが、おや結局foo.lispはどこに置けば良いのだろう、などということにもなったりもします。

スクリプト化する

スクリプト実行と親和性の高いCLISPのような処理系では、手軽に#!スクリプトとしてまとめられます。

#!/usr/bin/clisp -norc -q
(ql:quickload 'foo)
(foo::main)

みたいな感じで書いて、実行可能ファイルにしてパスの通った所に置けば良いので、そこそこお手軽です。ただCLISP以外はCLISP程の手軽さは感じられないことが多いかなと思います。

また、スクリプト的に書くのか、slime上でそこそこLisp的に開発するのかの間で逡巡することもままあるかなという印象です。

読み込み時のパス変数を使う

ファイルを読み込んだ時に、*load-pathname*や、*load-truename*でパスが取得可能なので、このパスから色々することも可能です。
残念ながらLispマシン等で使われていたdefsystemがANSI Common Lispで標準化されなかったため、プロジェクトの読み込み方法が処理系ごとに大きく違ってしまっていた、1990年代〜ASDFというdefsystemが普及する2000年代あたりまでは、これらのロード時/コンパイル時パスをあれこれしてどうにか対処することもあったようです。
全体的にパスを計算する手間が面倒になる上、それに起因するバグも多くなる印象です。

論理パスを使う

論理パスでは物理パスとは独立に任意のパスを新規に定義できます。
例えば、ホームディレクトリのlispディレクトリを“lisp:”という論理ホストに設定することが可能です。

これで何が可能になるのかというと、(load "lisp:foo")で、~/lisp/foo.lispをロードすることが可能になるので、“lisp:”以下に置かれたlispファイルをロードするという行為がかなり手軽になります。
また、論理パスに対応したエディタであれば、論理パスでファイルがすぐ開けるのも便利で開発が捗ります。
(なお対応しているエディタはほぼありません)

論理パスの設定

論理パスは、logical-pathname-translationsで直に設定してしまっても良いですが、ホストマシン全体で設定する方法がCommon Lispの標準に用意されているので、その手順に従うと色々楽だったりします。

“lisp:”を設定する場合、SBCLの場合は、“sys:site;lisp.translations.newest”に

;;; -*- lisp -*-
(("**;*.*.*" #.(merge-pathnames 
                (make-pathname :name :wild
                               :type :wild
                               :version :unspecific
                               :directory '(:relative "LISP" :wild-inferiors)
                               :case :common)
                (user-homedir-pathname)))))

のような記述をすれば、

(load-logical-pathname-translations "lisp")

で上記のファイルを読み込むことが可能です。
“sys:site;lisp.translations.newest”が論理パスですが、

(translate-logical-pathname "sys:site;lisp.translations.newest")

で物理パスに変換できるので確認できるでしょう。

以上は、load-logical-pathname-translationsの作法に則った設定ですが、面倒臭ければ、/etc/sbclrcに

(setf (logical-pathname-translations "lisp")
      `(("**;*.*" ,(merge-pathnames 
                    (make-pathname :name :wild :directory '(:relative "LISP") :case :common)
                (user-homedir-pathname)))))

のようなものを書いてしまっても良いでしょう。

provide、requireと論理パスの組み合わせ

論理パスを設定しておけば、あまり利用することもないrequireやprovideの機能を活かすことも可能になります。

上記foo.lispの例であれば、foo.lispの中に、(provide "lisp:foo")と宣言し、読み込まれたら"foo"モジュールが登録されるようにておきます。

読み込みは、

(require "lisp:foo" "lisp:foo")

のように明示的にパスを指定してやります。
明示的にパスを指定するので、loadと大差ありませんが、loadと違い、再度読み込みの防止機能があるので、まあこれはこれで便利なこともあるでしょう。

ちなみにモジュール名を論理パスと同じにすると管理が楽です。

まとめ

単一ファイル構成のプロジェクトの読み込みについて論理パスが活用できる可能性について書きました。
隅に置いやられている論理パスですが、使い様によっては結構活用できそうなので、今後も活用法を探っていきたいところです。

■

HTML generated by 3bmd in LispWorks Personal Edition 7.1.2

1984年に最初の仕様が公開されたCommon Lispですが、仕様は主に電子メールのメーリングリストで議論し、採用する機能を投票で決めたりと時代を先取りしていました。

Spice Lispのマニュアルを土台に叩き台となる仕様をまとめ、議論して、まとめ、というのを繰り返して、Common Lisp the Language(CLtL1)として出版されたのですが、その中間の草稿についてはネット上には資料が公開されていなかったため色々と謎が多かったりもしました。

そんなCommon Lispの草稿ですが、今年の去る五月にComputer History MusiumのSoftware Preservation Groupのページで公開されていたようです。

• Computer History Musium:Software Preservation Group / Common Lisp Family

公開されたのは、

• Colander Edition (1982-07-29)
• Laser Edition (1982-11-16)
• Excelsior Edition (1983-08-05)
• Mary Poppins Edition (1983-11-29)

の四つで、厳密にいうと他にも草稿はあるようですが、Common Lispの草稿として資料に登場するのは大体この四つです。

どんなことが分かるか

興味深いのは、完成版に近いMary Poppins Editionよりは、最初期のColander Editionかと思いますが、例えば、*macroexpand-hook*は、displaceを導入する目的で導入された、と明記されていたりします。

displaceは主にインタプリタのマクロ展開を速くする機構で、一度展開した展開形を保持するという機構です。
この機能ですが、ANSI CLに至るまでに可搬的に実現するのが困難という結論になり、ANSI CLでは何を目的とした機能なのかの説明もぼんやりしたものになっています。

時系列に並べると

• CL草稿: displaceのため
• CLtL1: マクロ展開をキャッシュ化することによってインタプリタ速度の向上に活用できる
• CLtL2: 当初の目的を果すのは難しいのでデバッグで主に使いましょう
• ANSI CL: 大域変数なのでまずい使い方をするとコードの解釈が一意でなくなるという注意書き

となるのですが、どんどん非推奨な機能に追いやられていることが分かります。

他、スペシャル変数に耳当てがない等、お馴染の慣習も徐々に確定していったことが分かります。 (ちなみに耳当てをつけるのは投票で可決され、定数には特に飾りを付けない、というのも同じ投票で可決されています)

関連

• #:g1: macroexpand-hookの使い道

まとめ

ANSI CL規格だけからは導入の動機が良く分からない機能は結構あるのですが、最初期まで遡ることが可能だと経緯がより鮮明に見えてきます。

現在でも、投票の詳細については資料がオンラインにないのですが、投票の詳細について公開されるとかなり面白いことになると思います。

■

HTML generated by 3bmd in LispWorks Personal Edition 7.1.2

ざっくりした話ですが、Lisp₁のSchemeには衛生マクロがあるが、Common LispのようなLisp₂は、衛生マクロがないので駄目、みたいな意見を持っている人(主にLisp初学者)はそこそこいると思います。しかし、実際のところ、日々Lisp₂のCommon Lispを使っていてリスト操作のマクロが不衛生で困っちゃうということもありません。
欠点を運用でカバーしているのだ、という話もありますが、これが大した運用でもないというのが実感です。

この実際の感覚のあれこれを説明しようと思っても、Common LispのようなLisp₂のマクロ体系とLisp₁のマクロ体系を比較する、ぱっとした方法がないので、実際のところ比較が難しいのですが、両者でも共通している括弧()のレベルから考えてみることにしました。

関数定義の度に新しい括弧を定義する体系を考えてみる

まず、リスト操作のマクロは、Lisp₂とLisp₁とではあまりにも使い勝手が違います。
端的にいってLisp₂のプログラマの感覚でいうと、Lisp₁上のLisp₂のようなリスト操作のマクロは使い物にならないので一切書かないのが安全という感覚だと思いますが、それについては後述するとして、Lisp₂、Lisp₁で共通の機構を考えてみます。
まず、関数/マクロの定義ごとに新しい括弧の種類を定義するとしてみます。

(defun fib (n)
  (if (< n 2)
      n
      (+ (fib (1- n))
         (fib (- n 2)))))

のようなものを

(defun 【】 (n)
  (if (< n 2)
      n
      (+ 【(1- n)】
         【(- n 2)】)))

と定義し、

【10】
→ 55

のように動くというイメージです。

括弧はリード時に確定するので、それ以降のフェイズで上書きする術を提供しなければ衛生的です。
※なお、Common Lispにはリーダーマクロがあり、ユーザーが新しい括弧を定義することが可能ですが、ユーザー定義部分に関してはプログラマに委ねられています。

Lisp₂の関数/マクロ定義は括弧を定義しているのに感覚として近い

関数/マクロごとに新しい括弧を用意してみることを考えてみましたが、Lisp₂は、Lisp₂のプログラマの感覚からすると、()+シンボルという唯一であることが保証されたオブジェクトの組み合わせで機能するため、定義の度に新しい括弧を定義するのに近いものとなります。

上記で定義した【の文脈でいうと、(fibという唯一な括弧を新しく定義している、とも考えられます。

つまり、リスト操作でのマクロがどれだけ衛生的かというと、上記表現でいう括弧が再定義されない限りにおいて衛生的ということになるかと思います。

逆に括弧が再定義可能ということであれば、関数呼び出しの記述からして破綻させることが可能なので、衛生マクロであろうと無力です(括弧を保護する仕組みが必要)

なお、(+シンボルの組で括弧であるとした場合、実際にはシンボルはユーザーが通常のプログラミングの範囲で操作するため二点問題が考えられます。

• シンボルの競合問題
• プログラムデータが作るスコープでのシャドウイング問題

生成されたプログラムデータに於て、シンボルの競合については、モジュール管理のフェイズでエラーとすることが可能なためプログラマも管理し易いと思いますが、自動生成されるスコープについては管理が難しいと考えられています。

Lisp₂のCommon Lispで具体的な例を挙げると、

(flet ((list (&rest args)
         (apply #'vector args)))
  (list 0 1 2))

のようなコードが自動生成されることを制御する必要がある、ということになりますが、コード生成をしまくるCommon Lispでも実際には問題となることはあまりありません。

これは上述のように、Lisp₂に於ける関数定義では新しい括弧を定義しているような意味合いが強く、変数名と関数名の競合を意識することがないプログラミングスタイルであることが理由だと考えられます。
換言すれば、関数名と変数名が競合しないのがメリットなので、敢えて競合させるようなコードを生成させた挙句に結果として余計な問題に悩んだりしたくないので避けるということかと思います。

関数名と変数名が同一なのがメリットのSchemeにおいて敢えて名前を競合させてデメリットを助長させるようなことはしないのに似ています(もちろんたまにいますが)

(define (foo list args)
  (list args))

リスト操作のマクロでいうと、Lisp₁の場合は、さらに変数名との競合も考慮する必要があります。
加えてマクロが展開された周辺とも名前の競合を考慮する必要がありますが、Lisp₂のプログラマの感覚からすると制御が難しすぎて実質使い物にならないという感想が多いでしょう。
(だから衛生マクロが登場したともいえますが)

コード生成について

Lisp₂のCommon Lispでは、defmacroが単なるリスト生成であることが殆どですが、マクロでなくともユーザーがプログラムでコードを生成するということが手軽に安直に行なわれています。
この場合、生成されるコードは、機械向けの呪文ではなく、人間が書くようなスタイルのコードが生成されることが多い印象ですが、リスト生成に毛が生えた程度でも人間が読め、制御も可能であるようなコードが生成可能であるというのが大きいと思われます。
defmacroのような手書きのコードから一括生成の大量の自動生成のコードまで連続しているというのがポイントです。
Lisp₂以外で、人間が読めるようなコードを安直に生成している文化はあまり目にしたことがないのですが、どうなのでしょうか。

まとめ

上記では、関数の名前と変数の名前が競合する局面について書きました。
Lisp₂のマクロでの変数名の競合は、一時的な変数名を生成したり(gensym)、スコープを作る構文に展開することで簡単にコントロールできるものとされています。
マクロ展開での変数名(識別子)の競合や生成は、メリットともデメリットともされていて、SchemeでもLisp₂でメリットとされて来たことを取り込もうとする等、人間がコントロールする範囲のものと捉えられている節もあるので今回は省いています。

また、Lisp₁上でも、識別子を展開するのではなく、マクロ定義時に関数オブジェクトを取り込み、それをマクロ展開してしまうことによって、名前の競合を起さないテクニックもあるようです。
これでも良さそうですが、コードの字面とオブジェクトとで乖離してしまうので管理が難しそうです。

結局のところ関数名というのは変数名と違って大域なことが殆どですが、これは大域的な名前を操作してプログラミングするという人間の慣習を反映しているのでしょう。
Lisp₂はこの点とも親和性が高いと思います(たまたま先入観が反映された感は強いですが)

■

HTML generated by 3bmd in LispWorks Personal Edition 7.1.2

ここ最近Interlisp-D復活のプロジェクトが活発でOSS化が進んでいるらしいというのは眺めていましたが、いつの間にやら仮想Interlisp-D環境であるmedleyが最近のOS上で動くようになっているようです。

• Interlisp / Medley

以前もmedleyは古いOSを用意すれば動かせたりしましたが、最近のOS上でも動かせるというのは非常に嬉しい。

導入

下記はlinux x86_64で導入する場合です。 clang等が必要ですが適宜インストールしましょう。

git clone https://github.com/Interlisp/maiko.git
cd bin
export PATH=.:$PATH
makeright x

上記でビルドが完了すると、maikoディレクトリの直下のマシンアーキテクチャ名のディレクトリ中にldexが生成されていますので、medleyのsysoutイメージを指定して起動できます。

./linux.x86_64/ldex full.sysout

sysoutイメージは、interlisp.orgに記載のあるRon’s Interlisp dropboxでも数種類配布されているので、適宜利用してみるのも良いでしょう。

• Interlisp > basics

とりあえず、手元では、古いmedleyで動かしていたイメージが起動しました。

今後の展開

OSS化されたということで、処理系のソース等も読めるようになるのかもしれません(既に読める?)
個人的にはLOOPSを触ってみたいと思っています。

関連

• #:g1: Medleyを使ってみよう(2)
• #:g1: レトロLisp探検: INTERLISP

■

HTML generated by 3bmd in LispWorks Personal Edition 7.1.2

S式といえば、逆ポーランド記法(前置記法)という印象がありますが、肝要なのはS式というデータでコードを記述することなので、特に前置でなければいけないということもない筈です。

そもそも、点対リストの記法は中置じゃないかと思うのですが、どうなのでしょう。

(a . d)

前置であれば、

(. a d)

となりそうですが、これでも特に問題はなさそうに思えます。

ちなみにPrologでは、[a|d]というリスト表記は、'.'(a,d)の糖衣構文らしく'.'は前置記法ですが、Lispに由来したものなのかどうなのか。

% az-prolog
%
| ?-'.'(a,d)=[a|d].
yes

点対リストの発展形

点対リストのドットは中置ではないかと書きましたが、Plasma(1974)には、この点対リストの記法を発展させたような記法(x op y)をメインに使用します。

なお、私個人の解釈では、Hewitt先生は、点対リストのドットをオペレーターとして解釈し、点対リスト記法を発展させているように見えるのですが、Plasmaの文献を眺めていてもドットを発展させたという記述は見付けられていないので、完全に独自解釈かもしれません。予めご了承下さい……。
少なくとも、リストの二番目に特別な記号があれば○○するというような構文の作り方ではない気がするのですが。

メッセージ送信

Plasmaではメッセージ送信は、(A <= M)と記述し、Lispでいう関数呼び出しに相当します。
矢印は逆転して記述することも可能で、(M => A)でも可です。
また、(A <= [x y z])の省略形はLispの関数フォームのように、(A x y z)と書けます。 この矢印がLispの点対リストの.に相当します。
なお、[x y z]は配列です。

四則演算

四則演算の+,-,*,/等もまた特別扱いされます。

(1 + 1) 
→ 2

Common Lispで()を再定義するとしたらこんな感じでしょうか

(progn
  (flet ((rdseq (srm chr)
           (let ((xpr (read-delimited-list #\] srm T)))
             (if (= 3 (length xpr))
                 (let ((op (cadr xpr))
                       (x (car xpr))
                       (y (caddr xpr)))
                   (case op 
                     (≡ (list 'define x y))
                     ((=) 
                      (list x y))
                     (otherwise (coerce xpr 'vector))))
               (coerce xpr 'vector)))))
    (set-macro-character #\[ #'rdseq))
  (set-syntax-from-char #\] #\))
  ;;;
  (flet ((rdparen (srm chr)
             (declare (ignore chr))
             (let ((xpr (read-delimited-list #\) srm T)))
               (if (= 3 (length xpr))
                   (let ((op (cadr xpr))
                         (x (car xpr))
                         (y (caddr xpr)))
                     (case op 
                       (<= (cons x (coerce y 'list)))
                       (=> (cons y (coerce x 'list)))
                       ((+ - * / < > =< >=) 
                        (list op x y))
                       (otherwise xpr)))
                 xpr))))
      (set-macro-character #\( #'rdparen)))

(list 
 (list <= [42])
 (list 42)
 (list 0 1 2 3)
 ([0 1 2 3] => list)
 ([(42 + 69) (42 - 69) (42 * 69) (42 / 69)] => list))
→ ((42) (42) (0 1 2 3) (0 1 2 3) (111 -27 2898 14/23))

ちなみに、(の再定義は危険なので、全角括弧ででも試した方が良いかもしれません……。

定義構文

関数(アクタ)定義は、配列+≡の中置です。
Schemeのように、(define fcn (lambda (arg ...) ...))パタンと、左辺?に引数も記述する(define (fcn arg ...) ...)パタンがあります。
思えば、Lisp 1.5の頃からこの二種類は存在するようなのですが、大元はLisp 1.5なのでしょうか。

Plasmaでは下記のように書けます。 (なお、Plasmaにlambdaはありません)

[tak ≡ (lambda (x y z)
         (if (not (x > y))
             z
             ([([(x - 1) y z] => tak)
               ([(y - 1) z x] => tak)
               ([(z - 1) x y] => tak)] => tak)))]

[(tak x y z) ≡ (if (not (x > y))
                    z
                    ([(tak (x - 1) y z)
                      (tak (y - 1) z x)
                      (tak (z - 1) x y)] => tak))]
([18 12 6] => tak)
→ 7

Common Lispで再現してみるなら、≡を中置のdefineと考え、二種のパタンそれぞれに展開するマクロにでもなりそうです。

(defmacro define (name expr)
  (etypecase name
    (cons `(defun ,(car name) (,@(cdr name))
             ,expr))
    (symbol 
     `(progn
        (declaim (function ,name))
        (setf (fdefinition ',name) ,expr)))))

まとめ

点対リストの記法の発展形をPlasmaを源流と捉えてつらつら書いてみましたが、点対リストの形式(x op y)には、未だ開拓されていない可能性があるようなないような。

(x op y)と書けると一体何が嬉しいのか、という気もしますが、ではLispがこれまで(a . d)と書いてきて一体何が嬉しかったのか、と思わないでもないです。

Hewitt先生の記法のアイデアは中置のS式に限らず結構面白いものが多いので、今後もちょこちょこ紹介していきたいと思います。
(絵文字や上付き/下付きのS式等々……)

参考

• A PLASMA PRIMER / Brian C. Smith, Carl Hewitt (1975)

■

HTML generated by 3bmd in LispWorks Personal Edition 7.1.2

ストリームを読み込んで、一つのS式を得るにはreadを使えば良いのですが、その文字列表現を得るのは結構面倒という話をSNSで見掛けました。

いや、with-output-to-string等を使えばreadの結果を文字列として取り出すのは簡単じゃないかなと思ったのですが、これでは上手く行かない状況があるのかもしれません。

;;; 単純な例
(setq *print-circle* T)
(with-output-to-string (out)
  (with-input-from-string (in "#0=(0 1 2 3 . #0#)")
    (print (read in) out)))
→ "
#1=(0 1 2 3 . #1#) "

例えば、存在しないパッケージを含んだ表現を読み込むとエラーになる場合であったり、

(with-output-to-string (out)
  (with-input-from-string (in "(foo:bar baz)")
    (print (read in) out)))
!! Error: Reader cannot find package FOO.

コメントを読み飛ばしたくない場合であったり、

(with-output-to-string (out)
  (with-input-from-string (in "(foo bar #|baz|#)")
    (print (read in) out)))
→ "
(FOO BAR) "

しかし、これらはreadの挙動ではないので、readした結果の文字列ではない気がしますが……。

とはいえ、Lispのプリティプリンタ等を作成する場合等でCommon Lispのreadをうまいこと流用しつつ都合良くreadの標準の挙動を越えた結果が欲しい場合もあります。

make-echo-stream というマイナー機能

上述のように、コメントを読み飛ばしたくない場合や、存在しないパッケージは無視してシンボルのトークンとして読み込みたい場合、元ストリームのecho-streamを作成した状況で、*read-suppress*をTにしてreadを動かし、echo-streamに軌跡を出力するという技が使えます。

具体的には、

(defun read-to-string (&optional (stream *standard-input*)
                                 (eof-error-p T)
                                 eof-value
                                 recursivep
                                 (junk-allowed T))
  (with-output-to-string (outstring)
    (let* ((stream (make-echo-stream stream outstring))
           (*read-suppress* junk-allowed))
      (read stream eof-error-p eof-value recursivep))))

こんな感じのものを作成します。

(setq *print-circle* nil)
(dolist (xpr '("#0=(0 1 2 3 . #0#)"
               "(foo:bar baz)"
               "(foo bar #|baz|#
;; comment
)"))
  (with-input-from-string (in xpr)
    (print (read-to-string in))))
▻ 
▻ "#0=(0 1 2 3 . #0#)" 
▻ "(foo:bar baz)" 
▻ "(foo bar #|baz|#
▻ ;; comment
▻ 
▻ )" 
→ NIL

解説

まず、make-echo-streamですが、read系の関数が読み取ったものを出力するというストリームです。エラーログを出力する場面等で便利な気はしますが、結構マイナーな機能です。
HyperSpecでも読み取ったものを文字列として返す例が紹介されています。

次に*read-suppress*ですが、元来これは、#-、#+を処理するための機能であり、Lispのトークンとして読み込めるレベルのものを適切に無視することが可能です。

これらを組み合せるとreadエラーは回避しつつLispのトークンとして読み込み、文字列として出力することが可能です。

参照

• CLHS: make-echo-stream
• CLHS: read-suppress

■

HTML generated by 3bmd in LispWorks Personal Edition 7.1.2

bit誌1975-01月号 「連載LISP入門 (13) Backtrack法とLisp」にはbindqというフォームが出てきます。
(1974年から1975年にかけてのbit誌での後藤英一先生のLisp連載)

HLISP独自のようですが、M式で書くと、

bindq[x;y;form]

のような形式でCommon Lispでいうprogvに似た形式です。 qはquoteのqですが、formがクォートされるので、Common Lispで実装すると、

(defmacro bindq (vars vals form)
  `(let (,@(mapcar #'list 
                   (eval vars)
                   (eval vals)))
     ,form))

となります。

(let ((x 0))
  (bindq (list 'x 'y)
         (list 'x 42)
    (progn (list x y))))
→ (0 42)

という動作ですが、クォートされた変数名がレキシカル変数を捕むという表記はCommon Lispの作法からすると気持ち悪いかもしれません……、と書いているうちに、HLISPはレキシカルスコープじゃないし、要するにprogvではないかとどんどん思えてきました。

この記事を書き始めたときには、とりあえずレキシカルスコープでprogv的なもの、ということを考えていたのですが……、とりあえず、このまま続けることにします。

スコープを作るフォームの束縛部のデータ

前述bindqや、progvではフォームの束縛部のデータ型はリストでした。
letでも((var val))はリストですが、クォートされていて実行時に生成されるリストではありません。

上述で実装したbindqは実行時に評価されそうな見た目ですが、マクロ展開時にフォームは固定されます。
マクロ展開時までに確定できれば変数でも大丈夫ですが、評価フェイズによってはエラーになったりするので、Common Lispの構文作法としてはあまり良くないでしょう。

(defvar *vars* '(x y))
(defvar *vals* '(0 42))
(bindq *vars* *vals* (list x y))
→ (0 42)

まあでも一つの可能性としては面白いかもしれません。

Plasmaでの束縛部のデータ

リスト以外の束縛部のデータといえば、最近だとClojureが配列を採用していますが、古くは、Plasma(1974)があります。
Plasmaでは、sequenceという配列が[]で表記され、setという集合が{}で表記されていますが、これらが、束縛部で使われます。

(let 
   {[x = 42] [y = 0]}
  ...)
(labels
    {[fib ≡ 
        (cases 
         (≡> [0] 0)
         (≡> [1] 1)
         (≡> [=n] 
             (fib (n - 1) + (fib (n - 2)))))]}
  ...)

束縛部全体は集合で表記され、変数名と値の対は配列で表記されます。

面白いのが、束縛部を変数として与えることが可能なところで、

[math-definitions = 
    {[factorial ≡ ..]
     [fibonacci ≡ ..]
     [cosine ≡ ..]}]

(labels math-definitions body)

という記述が可能とされています。
上記では、labelsのスコープ内に導入しますが、大域環境に定義するenterという機能もあります。

(enter math-definitions)

Plasmaはレキシカルスコープな筈ですが、この辺り実際レキシカルスコープで実現するのは難しそうな機能です。
実際どういう実装がされていたのかは謎……。

ちなみに、Common Lispで真似るならこんな感じでしょうか。
マクロ展開時までに束縛部のデータが確定していれば機能しますが、そうでない可能性を考えると脆弱な仕組みということが分かります。

(progn
  (flet ((rdset (srm chr)
           (let ((tab (make-hash-table :test #'equal)))
             (dolist (elt (read-delimited-list #\} srm T) tab)
               (if (and (typep elt '(vector T 3))
                        (member (elt elt 1) '(= ≡)))
                   (setf (gethash (elt elt 0) tab)
                         (elt elt 2))
                   (setf (gethash elt tab)
                         T))))))
    (set-macro-character #\{ #'rdset))
  (set-syntax-from-char #\} #\))
  (flet ((rdseq (srm chr)
           (coerce (read-delimited-list #\] srm T) 'vector)))
    (set-macro-character #\[ #'rdseq))
  (set-syntax-from-char #\] #\)))

(defpackage plasma 
  (:use)
  (:export let labels))

(defmacro plasma:let (binds &body body)
  (let ((binds (eval binds)))
    (check-type binds hash-table)
    `(let ,(loop :for var :being :the :hash-keys :of binds :using (:hash-value val)
                 :collect `(,var ,val))
       ,@body)))
(plasma:let 
    {[x = 42] [y = 0]} 
  (list x y))
===> (let ((x 42) (y 0)) (list x y))
(defvar *binds* {[x = 42] [y = 0]})
(plasma:let *binds* (list x y))
→ (42 0)

まとめ

束縛部を実行時データとして与えるというのは動的すぎるとしても、コンパイル時までに与えるというのは活用できる局面があったりするかもしれません。

実際の所、Common Lispではリード時までに与えるというのはたまにありますが、declare等のコンパイラへの指示等が殆どで、束縛部を後で与えたいということは殆どないとは思いますが。

(defvar *bindspec* '((x 42) (y 0)))
(let #.*bindspec* (list x y))
→ (42 0)

参考

• A PLASMA PRIMER / Brian C. Smith, Carl Hewitt (1975)

■

HTML generated by 3bmd in LispWorks Personal Edition 7.1.2

古くからボディ部に複数の式を取れることを暗黙のprognといいますが、別にletでも良いんじゃないかなと思って試してみました。

(defpackage let 
  (:use)
  (:export cond lambda))
(defun implicit-let-form-p (form)
  (member (car form) '(let let*)
          :test #'string-equal
          :key #'princ-to-string))

(defmacro let:cond (&rest clauses)
  `(cond ,@(mapcar (lambda (c)
                     (if (implicit-let-form-p (cdr c))
                         `(,(car c) ,(cdr c))
                         c))
                   clauses)))

(defmacro let:lambda ((&rest args) &body clauses)
  `(lambda (,@args)
     ,@(if (implicit-let-form-p clauses)
           `(,clauses)
           clauses)))

(defun fib (n)
  (let:cond ((< n 2) let ((f n)) f)
            (T let ((f1 (fib (1- n)))
                     (f2 (fib (- n 2))))
               (+ f1 f2))))
(fib 10)
→ 55

(mapcar (let:lambda (x)
          let ((y (* 2 x)))
          y)
        '(0 1 2 3))
→ (0 2 4 6)

ネストが一つ減らせる位しか御利益がないですが、大抵の言語のブロックは、変数のスコープと複数フォームを纏める機能が合体しているので、prognまで分解されずに、letがビルディングブロックん基本なのかなと思ったり思わなかったりです。

ちなみに、どこかでみたことがある気がしましたが、Conniverのcdefunのボディ部での“AUX”という記述が今回の暗黙のletそのままでした。
(完全に忘却していた……)

("AUX" (x y z) ...)

のように単体フォームでも使えるようですが、詳細は調べきれていません。
もしかしたら、Conniverは暗黙のprognから進んで、暗黙のletだったのかも?

更新:※Conniverのマニュアルで確認してみたところ、フォームの第二要素が予約語“AUX”であった場合、第三要素はprog変数宣言となる、ということみたいです。
つまり暗黙のprogということみたいですが、暗黙のletみたいなものといえるでしょう。

• The Conniver Reference Manual

Conniverの“AUX”は、MDLが由来のようですが、受け継いたCommon Lispのように引数部に記述するのではなく、ボディ部に記述するというのが面白いですね。

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

ちなみに暗黙のprognとは

Lispでは値を返すスタイルが古くから基本となっていますが、副作用目的で複数の式をまとめる記述としてprogやprog2というフォームも古くから存在しました。

任意の複数の式をまとめるフォームということで落ち着いたのがprognですが、SDS 930 LISPあたりが最初のようです。

prognは便利だったのか、ついでにcondや、lambdaの既存のフォームのボディ部で、prognのように複数の式を取れるように拡張されました。 これを暗黙のprognと呼びますが、元は1つの式しか記述することができなかったため、暗黙のprognという言葉がうまれ後世まで伝わってしまったのでしょう。

(lambda (x) x)  
↓
(lamba (x) (progn x x x))
↓
(lamba (x) x x x)

今となっては何故1つの式しか元は記述することができなかったのかと思ったりもしますが、複数の式を含むということは、値を返さない式を含む(副作用目的の式を含む)ということになるので、元々のLISPは純粋な関数を指向していたともいえます。
もちろん手続的に記述するprogもあったりはするのですが、元々はsetq等の代入もprogの中でしか使えませんでした。

■

HTML generated by 3bmd in LispWorks Personal Edition 7.1.2

論理パスを設定しておくと便利なこともあるので、良く使うlispファイル置き場のディレクトリ等に“lisp:”なんていう論理パスを設定したりしています。
“~/lisp” であれば下記のように設定可能です。

(setf (logical-pathname-translations "LISP")
      `(("*" ,(merge-pathnames 
               (make-pathname :name :wild :directory '(:relative "LISP") :case :common)
               (user-homedir-pathname)))))

(load "lisp:foo")

で、“~/lisp/foo.lisp”がロードできたりするのが便利です。

quicklispなども論理パスを設定しておけば、

(load "quicklisp:setup")

でロードできたりしますが、まあ便利な時は便利でしょう。

ちなみに初期化ファイルを読み込まない状態で、論理パスをロードする仕組みがCommon Lispには、load-logical-pathname-translationsとして用意されていますが、処理系によって記述方法はまちまちです。

Lispエディタで論理パスは使えるか

そんな日々でしたが、普段から論理パスを使っているとエディタでファイルを開く際にも使いたくなります。
論理パスでファイルを開けたりしないもんかなと、試しにLispWorksのエディタのFind Fileで論理パスで指定してみたところ、普通に開けてしまいました。

素直に開けてしまうのが逆に不思議だったので、Find Fileのソースを眺めてみましたが、文字列がprobe-fileに渡されるので、ここで実ファイルにマッピングされる様子。
当然ながら、Common Lisp製のエディタはCommon Lispのパス処理の関数を使うわけで、意図的かどうかは扨措き、エディタも論理パスを処理できちゃうみたいです。

ちなみに、SymbolicsのZmacsではどうなのかなと思い、論理パスを設定して試してみましたが、Find Fileで普通に論理パスが使えました。
こちらは様々なOSが混在した環境で論理パスを設定していた時代に実際に使われていたと思うので、元からサポートしているのでしょう。

論理パスは、物理的にはばらばらに存在するファイルをツリー状にまとめたりがLisp内で簡単にできます。
色々制限はあるのですが、使い方次第では便利に使えるかもしれません。

まとめ

真のLispエディタでは論理パスが使える。

■

HTML generated by 3bmd in LispWorks Personal Edition 7.1.2

LispWorksは商用のCommon Lisp処理系で、お試し版としては、Personal Editionというものがあるのですが、長らくアップデートされていませんでした。
前回リリースされた LispWorks 6.1.1 Personal Edition が、2013-01-19のリリースだったので実に7年ぶりのリリースとなります。

今回リリースされたPersonal Editionのプラットフォームは、x86系とArm。 これら以外のプラットフォームでもLispWorksは稼動しますが、x86系とArm以外を使っている人は稀だと思うので、問題になることはないでしょう。
なお、Personal Edition以外のLispWorksの各エディションは申請すれば一ヶ月評価できるので、マイナープラットフォームの方々でも申請すれば購入前に評価は可能です。

これまで商用処理系の評価版というとLispWorksもFranzのAllegroも32bit版限定でしたが、今回のLispWorks 7.1.2 Personal Editionでは64bit版も配布されています。
32bit環境の方が特殊になりつつある昨今なので当然といえば当然ですが、嬉しいところですね。

LispWorks 7.1.2 Personal Editionの制限

• 利用メモリの制限
• 連続起動時間5時間
• 初期化ファイルが読み込めない

等々は過去のバージョン同様の制限となっています。
5時間の制限と初期化ファイルを手動で読み込ませる必要があることについては、大して苦労することはないのですが、常用するには利用メモリの制限が結構厳しい。
例えば、ironclad等はビルドに結構負荷が掛る方ですが、こういうのは途中で終了となってしまいます。 コンパイルできる範囲でちまちまfaslを生成、処理系を立ち上げ直してロード、という作戦で乗り切ることも場合によっては不可能ではありませんが結構手間ですね。

LispWorks 7.1.2 Personal Editionの使われ方様々

LispWorksを評価するのが本来の目的かと思いますが、意外に大学の授業等での利用が結構あるようです。

PAIPの題材のような古典AIの授業の処理系として活用されているようですが、GUI付きのIDEとしてワンクリックで起動し利用できるので、確かにCommon Lisp入門や学習用途には結構良いと思います。

まとめ

このブログはLispWorksのエディタで書いて、LispWorksからサーバにアップロードという仕組みで更新していますが、今回のブログはLispWorks 7.1.2 Personal Editionで書いてみました。

ちなみに、標準の初期化ファイルを読み込ませるには、リスナーから、

(load *init-file-name*)

とすると楽です。

LispWorksのリスナーでは最外の括弧を記述しなくても良いので、

load *init-file-name*

でもOK。 M-iや、M-C-iで補完も可能なので、load *ini位までの入力で済みます。

■

HTML generated by 3bmd in LispWorks Personal Edition 7.1.2

CLでSRFI、今回移植したのは、SRFI 173: Hooksです。

• SRFI 173: Hooks
• g000001 / SRFI 173 for CL: Hooks

srfi-173は、古典的なLispでお馴染の機構であるフック機構を実現しようというものです。

移植について

参照実装をコピペしただけです。
元がシンプルなので特にソースコードを変更する必要もありませんでした。
テストコードにも手を加えないことにしようかとも思いましたが、テストケースが数個だったのでfiveamの形式にササッと書き直しました。

動作

advice機構のように関数名(シンボル)に関数をぶらさげるのではなく、フックオブジェクトに関数をどんどん登録していきます。
各フックの起動順は不定。フック起動結果の値も不定。
リストに関数をプッシュしていって後で順に呼び出しするのとあまり変らない使い勝手です。

(defvar *hook* (make-hook 0))
(defun one () (print 1))
(defun two () (print 2))
(defun three () (print 3))
(progn
  (hook-add! *hook* #'one)
  (hook-add! *hook* #'two)
  (hook-add! *hook* #'three))
→ (#<Function three 40D005342C>
    #<Function two 40D00533C4>
    #<Function one 40D005335C>
    #<Function three 40D005342C>
    #<Function two 40D00533C4>
    #<Function one 40D005335C>)
(hook-run *hook*)
▻ 
▻ 3 
▻ 2 
▻ 1 
→ nil

導入

Ultralispに登録してみたので、

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

してあれば、

(ql:quickload :srfi-173)

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

■

HTML generated by 3bmd in LispWorks 7.1.2

CLでSRFI、今回移植したのは、SRFI 145: Assumptionsです。

• SRFI 145: Assumptions
• g000001 / SRFI 145 for CL: Assumptions

srfi-145はざっくりいえば、Common Lispのassertに相当するもので、定義はassume一つだけです。
Common Lispのassertは再起動等のアクションがありますが、assumeにはありません。

移植について

assumeのようなものを記述メリットのようなものが色々解説されていますが、賢いコンパイラなら最適化するかもしれない、系の記述が殆どで、assume自体に組込まれた機構で何かする、というわけではありません。

assumeが記述されることによってコンパイラへの最適化やエラーチェックのヒントが増える、という話のようです。

色々書いてあるので、srfi-145で可能性として示されていることが実際に実現できないかをSBCLをメインに試してみました。
Common Lispでも大体似たようなことはできますが、srfi-145の例のような書き方ではないので、実現するにはコンパイラに色々仕込む必要があるようです。

Schemeのコンパイラにsrfi-145が記述しているような可能性を実現している/する可能性のあるコンパイラってあるんでしょうか(なさそう)

動作

(assume (= 1 1) "1 = 1")
→ nil
(assume (= 1 2) "1 = 1")
>> invalid assumption: (= 1 2)
>> 1 = 1 

導入

Ultralispに登録してみたので、

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

してあれば、

(ql:quickload :srfi-145)

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

■

HTML generated by 3bmd in LispWorks 7.0.0

CLでSRFI、今回移植したのは、SRFI 115: Scheme Regular Expressionsです。

• SRFI 115: Scheme Regular Expressions
• g000001 / SRFI 115 for CL: Scheme Regular Expressions

srfi-115は、S式で記述する正規表現で、その表現形式は古くからあるThe SRE regular-expression notation記法を軸にしたものです。
作者のAlex Shinn氏は、IrRegular ExpressionsというS式正規表現のライブラリを作成していて、大体そのサブセットがsrfi-115としてまとまったようです。

• The SRE regular-expression notation
• IrRegular Expressions
• #:g1: irregexの紹介

Common Lispへの移植は、ドラフト時の2013年に一度試してみたのですが、さすがにドラフトだと結構変更があるようなので、ファイナルまで落ち着くまで様子見してたら7年位経過していました。

移植について

参照実装をコピペしただけに近いですが、参照実装には、regexp->sre等の便利ツールが含まれていません。
また仕様自体も核と拡張部分にわかれていますが、参照実装は、核の部分のみのようです。
ドラフトの時はほぼIrRegular Expressionsと同じようなものでしたが、合意が取れなさそうなところはどんどん削って核にしてしまい、残りは拡張部分となったのでしょうか……。

実用面では、IrRegular Expressionsの方が便利なので、Common Lispへの移植し甲斐があるのはIrRegular Expressionsの方でしょう。

ライブラリのサブセットを仕様として定義した例はCommon Lispにも多数ありますが(loop、format等)、中途半端なことになりがちな気がします。

動作

(regexp-search '(w/nocase "foobar") "abcFOOBARdef")
→ #<Regexp-Match 4020002B23> 
(regexp-replace "n" "banana" "k")
→ "bakana" 
(regexp-replace-all '("aeiou") "hello world" "*")
;; or (regexp-replace-all '(or "a" "e" "i" "o" "u") "hello world" "*")
→ "h*ll* w*rld" 
(regexp-split "a" "banana")
→ ("b" "n" "n" "") 
(regexp-extract '(+ numeric) "192.168.0.1")
→ ("192" "168" "0" "1") 

導入

Ultralispに登録してみたので、

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

してあれば、

(ql:quickload :srfi-115)

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

その他

Common LispにSchemeのコードを移植する際に、どうしようかなと悩むのが、:をシンボル名として使うにはエスケープしなければいけないことだったりするのですが、今回は、:を$に置き換えました。
しかし、:をエスケープして\:と書いてもSchemeでは問題ないですし、コードの共用という面では別の文字に置き換えたりせずに、\でエスケープの方が良いかもしれません。

S式正規表現仲間

Common LispでS式正規表現だと、cl-irregsexpというのがあります。
IrRegular Expressionsも似たような名前ですが、なんか付けたくなるような名前なのでしょう。
Uncommon Lisp(R3RS Scheme)系の命名に似てますね。

■

HTML generated by 3bmd in LispWorks 7.0.0

CLでSRFI、今回移植したのは、SRFI 172: Two Safer Subsets of R7RSです。

• SRFI 172: Two Safer Subsets of R7RS
• g000001 / SRFI 172: Two Safer Subsets of R7RS

srfi-172の概要ですが、サンドボックス環境の構築を目的としたサブセットの提案で、副作用手続きあり版(srfi 172)となし版(srfi 172 functional)の2つがあります。
(srfi 172 functional)はざっくりいうと!手続きが含まれていないものという感じです。

Common Lispへの移植の際に参照実装には存在するstring->symbolが仕様の方には見当たらず、symbol->stringと対にならないので報告してみたところ、シンボルがGCされない処理系を考慮して入れていないので、参照実装のミスとのことでした。

安全指向のサンドボックスなので、GCを狙った攻撃等に配慮しているということなのでしょう。

移植について

これまで移植したsrfiをベースにまとめてみましたが、100番台以降に改善版が提案されているような古いsrfiが多いので、そのうち新しいsrfiに置き換えたいところ。

導入

Ultralispに登録してみたので、

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

してあれば、

(ql:quickload :srfi-172)

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

その他

最近のsrfiはgithubにコードや仕様が置かれていますが、githubのイシューを登録するのか、srfiのメーリングリストにイシューを投げるのか若干謎でした。
結局今回は両方に登録しましたが……。

■

HTML generated by 3bmd in LispWorks 7.0.0

Practical Scheme サイト20周年おめでとうございます!

• Practical Scheme

といっても実は半年過ぎてしまっていたようなのですが……。

• Islandlife 1999-11-09

しばらく前から準備していた Schemeのページ をぼちぼちアナウンスすることにする。  
今はまだ、公開できそうなSTkの拡張モジュールを置いておくだけだが、 将来はいろんな洗脳ドキュメントも用意して、Scheme言語布教の総本山とするのだはっはっは。  
ライブラリさえ揃えば、SchemeもPerlに遜色無い使い勝手になると思うんだよな。 

• 20年前のPractical Schemeの様子(archive.org)

Practical Scheme と日本のLispコミュニティ

現在の日本のLispコミュニティで目立った活動をしているところといえば、Shibuya.lisp の月一のミートアップや、不定期開催の関西Lispかと思いますが、 Practical Schemeが存在しなければ、約十年前あたりのプログラミング言語ブームの時に Shibuya.lisp がそこそこの規模で立ち上がることはなかったのではないかと思います。

当時のShibuya.lisp立ち上がりの背景には、GaucheNight(2007) 及び gauche.night(2008) の参加者グループのコミュニティ立ち上げへの手応えみたいなものがあったと思いますが、その地盤を固めていたのは、Practical SchemeやWiLiKiでした。

この二十年で色々なLisp系サイトが立ち上がっては消えていきましたが、二十年間安定した基盤として維持され続けてきたというのは、やはり凄いです。
今後も末永くPractical SchemeのコンテンツやWiLiKiを利用させて頂けると嬉しいです。

■

HTML generated by 3bmd in LispWorks 7.0.0

ACM Digital Library が2020-06-30まで無料だそうです。

• ACM Digital Library

この機会にLisp系で読んでおきたいお勧めといえば、ACM SIGPLAN Lisp Pointers でしょう。

Lisp Pointers は1987年から1995年までのLisp会報誌といった感じのものです。

• Lispのプログラミング技法紹介
• エッセイ
• 処理系紹介
• 開発環境紹介
• 書評
• ANSI Common Lisp 規格進捗報告

等々、内容が濃くて面白い読み物です。

幸か不幸か1995年あたりから古典的なLispはそれほど進歩がありませんので、今でも活用できるような内容も多いと思います(マシンパワーの違いこそあれ)

当時はエキスパートシステムの組み込み言語や、構文拡張等で需要が高かったのか、コードウォーカーの記事がそこそこあるのが、特徴かもしれません。
(Richard C. Waters、Pavel Curtis、Bill van Melle各氏の記事)
古典マクロのコードウォーカー入門記事としては貴重かもしれません。

• SIGPLAN-LISPPOINTERS: Vol 1, No 1
• SIGPLAN-LISPPOINTERS: Vol 1, No 2
• SIGPLAN-LISPPOINTERS: Vol 1, No 3
• SIGPLAN-LISPPOINTERS: Vol 1, No 4
• SIGPLAN-LISPPOINTERS: Vol 1, No 5
• SIGPLAN-LISPPOINTERS: Vol 2, No 1
• SIGPLAN-LISPPOINTERS: Vol 2, No 2
• SIGPLAN-LISPPOINTERS: Vol III, No 1
• SIGPLAN-LISPPOINTERS: Vol IV, No 1
• SIGPLAN-LISPPOINTERS: Vol IV, No 2
• SIGPLAN-LISPPOINTERS: Vol IV, No 3
• SIGPLAN-LISPPOINTERS: Vol IV, No 4
• SIGPLAN-LISPPOINTERS: Vol V, No 1
• SIGPLAN-LISPPOINTERS: Vol V, No 2
• SIGPLAN-LISPPOINTERS: Vol V, No 3
• SIGPLAN-LISPPOINTERS: Vol V, No 4
• SIGPLAN-LISPPOINTERS: Vol VI, No 1
• SIGPLAN-LISPPOINTERS: Vol VI, No 2
• SIGPLAN-LISPPOINTERS: Vol VI, No 3
• SIGPLAN-LISPPOINTERS: Vol VI, No 4
• SIGPLAN-LISPPOINTERS: Vol VII, No 1-2
• SIGPLAN-LISPPOINTERS: Vol VII, No 3
• SIGPLAN-LISPPOINTERS: Vol VII, No 4
• SIGPLAN-LISPPOINTERS: Vol VIII, No 1
• SIGPLAN-LISPPOINTERS: Vol VIII, No 2

■

HTML generated by 3bmd in LispWorks 7.0.0

先日久々にSRFIをCommon Lispに移植してみてコピペ移植もなかなか楽しいというのを思い出してきたので、また移植してみました。

今回移植したのは、SRFI 169: Underscores in numbersです。

• SRFI 169: Underscores in numbers
• g000001 / SRFI 169 for CL: Underscores in numbers

srfi-169の概要ですが、Python、Ruby、C#、Java 7以降ように数値の桁区切りに_を使えるようにするという拡張です。

移植について

オリジナルはリーダーの変更ですが、どうにかリードテーブルをいじる程度で動かせました。
具体的には、数字と+、-をマクロ文字にしてしまって、srfi-169のリーダーで読み直すという戦略です。
隅をつつけば、どこかの挙動に影響がある可能性もありますが、まあ良いでしょう。

(setq *readtable* srfi-169:srfi-169-syntax)
'(0123
  0_1_2_3
  0_123
  01_23
  012_3
  +0123
  +0_123
  -0123
  -0_123
  1_2_3/4_5_6_7
  12_34/5_678
  0_1_23.4_5_6
  1_2_3.5e6
  1_2e1_2
  #b10_10_10
  #o23_45_67
  #d45_67_89
  #xAB_CD_EF
  #x789_9B_C9_EF
  #x-2_0
  #o+2_345_6)
→ (123
   123
   123
   123
   123
   123
   123
   -123
   -123
   123/4567
   617/2839
   123.456D0
   1.235D8
   12000000000000
   42
   80247
   456789
   11259375
   32373459439
   -32
   10030)

ちなみに数値の区切りにアンダーバーを許す程度の簡易的な実装であれば、

(let ((stdrt (copy-readtable nil)))
  (defun read-underscores-in-numbers (stm chr)
    (check-type chr character)
    (check-type stm (satisfies input-stream-p))
    (unread-char chr stm)
    (let ((*readtable* stdrt))
      (let ((thing (read stm T nil T)))
        (typecase thing
          (symbol
           (read-from-string
            (remove #\_
                    (string thing))))
          (T thing))))))
(map nil
     (lambda (c)
       (set-macro-character c #'read-underscores-in-numbers T))
     "+-0123456789")
(list 0123 0_1_2_3 0_123 01_23 012_3 +0123 +0_123 -0123 -0_123 (+ (- 0) -123))
→ (123 123 123 123 123 123 123 -123 -123 -123) 

程度でも実現できそうです。

導入

Ultralispに登録してみたので、

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

してあれば、

(ql:quickload :srfi-169)

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

まとめ

リードテーブルも結構柔軟なので割と色々できてしまいますが、Common LispもRacketのようにリーダーの差し替えができたら良いのになと思うことはあります。

■

HTML generated by 3bmd in LispWorks 7.0.0

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

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

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

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

導入

Ultralispに登録してみたので、

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

してあれば、

(ql:quickload :srfi-175)

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

動作

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

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

まとめ

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

• g000001 / RnRS Compatibility Package for Common Lisp

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

■

HTML generated by 3bmd in LispWorks 7.0.0

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

• Ultralisp

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

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

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

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

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

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

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

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

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

Ultralisp使用感とまとめ

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

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

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

■

HTML generated by 3bmd in LispWorks 7.1.2

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

Lisp的進捗

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

ブログ

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

LispWorks

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

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

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

2020年やってみたいこと

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

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

過去のまとめ

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

■

HTML generated by 3bmd in LispWorks 7.0.0

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

(comment 0 1 2)
→ nil

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

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

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

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

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

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

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

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

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

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

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

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

まとめ

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

■

HTML generated by 3bmd in LispWorks 7.0.0

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

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

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

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

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

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

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

動作

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

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

実装

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

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

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

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

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

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

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

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

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

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

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

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

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

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

まとめ

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

■

HTML generated by 3bmd in LispWorks 7.0.0

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

動作

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

実装について

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

実装

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

まとめ

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

■

HTML generated by 3bmd in LispWorks 7.0.0

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

• CLOS-MOP/compute-slots

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

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

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

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

faceted-slot-class

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

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

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

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

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

実装

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

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

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

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

(ql:quickload :closer-mop)

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

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

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

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

(defgeneric compute-instance-size (class))

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

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

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

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

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

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

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

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

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

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

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

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

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

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

まとめ

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

■

HTML generated by 3bmd in LispWorks 7.0.0

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

• doc/manual/implementation.ccldoc

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

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

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

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

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

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

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

■

HTML generated by 3bmd in LispWorks 7.0.0

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

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

• LispM.de > docs > Publications > Common Lisp
  • ECLOS Metaclass library
  • Extended CLOS
• Advances in Object-Oriented Metalevel Architectures and Reflection
  • Why the MOP should the mopped
    • Google Booksの該当個所

挙動を確認してみる

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

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

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

実装のヒント

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

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

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

あとは、initfunctionを

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

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

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

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

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

実装してみる

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

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

• expand-defmacro

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

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

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

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

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

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

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

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

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

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

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

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

まとめ

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

■

HTML generated by 3bmd in LispWorks 7.0.0

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

• SBCL All News:1.5.9

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

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

SBCL 1.5.8

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

SBCL 1.5.9

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

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

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

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

発動ルールを探る

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

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

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

のようです。

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

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

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

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

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

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

まとめ

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

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

関連記事

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

■

HTML generated by 3bmd in LispWorks 7.0.0

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

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

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

実装した内容としては、

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

位です。

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

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

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

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

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

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

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

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

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

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

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

(defmethod shared-initialize ((instance initialize-at-read-object) slot-names &rest initargs)
  (let* ((class (class-of instance)))
    (dolist (slotd (class-slots class))
      (unless (initialize-slot-from-initarg class instance slotd initargs)
        (when (or (eq t slot-names)
                  (member (slot-definition-name slotd) slot-names))
          (initialize-slot-from-initfunction class instance slotd))))
    instance))