!Lisp Ver.1.0

いや、最初は色々と

「LispによるLispの実装?んな、言語設計者になりたいわけでもねえのにメンド臭い。っつーかさ。それってハッキリ言うとComputer Scienceの極めてTrivialなネタなんじゃねえの?やってられっか。Computer Science学科に在籍した事もねえのに。バカヤロー。」

的な文句言ってたわけなんですが。気づいたらすっかりハマってました(爆)。いや、意外と面白いんだ、これが(笑)。

今回は2回目のLisp実装への挑戦、って事で日曜日辺りからやりはじめたのかな?今回参考にした書籍は対話によるCommon Lisp入門 POD版という本。最近、#9LISP用にLOLにかかりっきりで、それはそれで楽しいんですが、週末時間が足りなくってストレスが溜まってた。そこで気分転換にとか思ったんですが、色んな意味でドツボにハマってました(爆)。

前回のSmall-Lispの実装を通じて、

• クロージャの実装ってどうやんの?
  

とか言う疑問があって。その点対話によるCommon Lisp入門 POD版では曲りなりにもCommon Lispを実装しよう、と言うネタなんで。ああ、これは前回のSmall-Lispの実装をまた一段上に上げられるかな?とか楽観的に考えてたんですが。目論見が大失敗(爆)。完全に別の実装として考えないと整合性が持てない、という結論に到達致しました。だからまたVer.1.0なんですよね。

まあ、その失敗の理由も色々とあるわけですけれども。そもそも対話によるCommon Lisp入門 POD版と言う書籍名が示すように、これはCommon LispでCommon Lispを実装しましょう、ってネタなわけですよ。それをSchemeでやろうと言うのがそもそも大間違いだった(爆)。んで色んなトコでハマるハマる(笑)。

まあ、後で細かいトコの感想は列挙していこうとは思うんですけど。そもそも対話によるCommon Lisp入門 POD版では、CLOS(Common Lisp Object System)使ってCommon Lispの基本的な機能のみのサブセットを作りましょう、ってんですが。一方、僕は知ってる人は知ってますが大のオブジェクト指向嫌いなんですよ(笑)。やってられっか、とか思って。そこでプラットフォームだけの違いじゃなくってCLOSで書かれたコードをPLTの構造体を使って書き直す、というハメになってしまった。これがハマりまくった原因です(爆)。何やってんだろうねえ、全くもう。

ただ、やっぱりオブジェクト指向は怖いですよ。後でその理由もちょっと考察してみます。では、感想文モドキのメモ。

PLTの構造体は単一継承が出来る

PLTは独自の構造体を提供しています。R6RSにも準拠してないですし、またSRFIにも準拠していない、どちらかと言うとCommon Lispの構造体定義法に近いdefine-structというデータ定義用マクロを提供しています。

このブログでも紹介しましたし、こちらのブログでも紹介されていますが、define-structは大変使い易いです。っつーか、例によって、例えばR6RS構造体のベースになったSRFIで提案されている構造体定義のドキュメントがﾜｹﾜｶﾒで使う気にならん、って事もあるんですけど。一般にSchemeのドキュメントってあんま良くねえよな。読みづらくって。しかもレコード型とか言ってるのが気にくわん(笑)。Pascalじゃねえだろっての(笑)。Common Lispと違いを出せばいいってモンじゃねえ(笑)。

さて、このPLTの構造体。単一継承が可能です。親クラスっつーか親構造体っつーか。何て呼べばいいのか知りませんが、いずれにせよ、継承可能です。ただし。多重継承は出来ません。つまり一本のラインで連鎖しているデータ型が定義出来る。

まあ、元々CLOSで書かれたネタをdefine-structで解決出来るのか、というような興味がそもそもあったわけなんですけれども。元ネタの場合にも「これは無駄な継承なんじゃないか?」ってのがチラホラあって。全体的には納得してないんですよね(笑)。

今回の場合、根本的にはアイデンティティ(同一性)の判定、つまり根幹のeq判定の為にオブジェクトと言うルート構造体を作ってるわけです。IDナンバーを振り分ける為だけの。Common Lispだと、本当は、パッケージに属してるシンボルが指しているアドレスのポインタ比較でeqが成り立ってるわけなんですが、そこをIDナンバーを製造する為だけのオブジェクト型にすり替えています。要するに手抜きですよね(笑)。全ての構造体の実体には全く違うIDナンバーが振り分けられるシステムなんで、IDナンバーが違えば同一にはならない、というカラクリになっています。

このシステムから言うと、こいつ「だけ」を継承すれば良い筈なんですが、生憎対話によるCommon Lisp入門 POD版ではCLOS使いまくりでした(笑)。弊害は番組後半で(謎)。

マクロの使い方が間違っているけど(笑)、それでもmake-instanceは超便利だった

今回はたった一つだけmake-instanceという名前のマクロを作成しました。make-instanceなんて名前は丸っきりオブジェクト指向っぽいんですけどね。だったらはじめからオブジェクト指向で実装すりゃあいいのに(笑)。いやいや。

これの作成理由は二つあります。一つは対話によるCommon Lisp入門 POD版テキスト内のコードとの整合比較を簡単にする為。もう一つは最終的には全部「全く違うIDナンバー」を継承する必要性の為、IDナンバー込みで実体を自動作成したほうがラクだろ、ってのがあったんですよね。

さて、そんなワケで、今回のマクロmake-instanceは普通使い道が無いんじゃねえの?と思われているsyntax-rulesのキーワード引数が大活躍しています。ってかこれは使い方としては間違ってんだろうな(笑)。しかし、パターンマッチング型のsyntax-rulesだとこういう使い方もアリじゃねえのか、とは思うんですけどね(笑)。上手く行ったからまあエエか(笑)。CSの宿題のcond作成の為のelse突っ込む場所なだけ、ってのも勿体ねえからな(笑)。

マクロを大量に使う場合は、ソースコード上に置く位置に気を付けて

define-structもマクロです。make-instanceも作成したマクロです。

Schemeの場合、Common Lispみたいなあからさまなeval-whenに纏わるトラブルは起きませんが。その代わり、あるマクロを使用した手続きがある場合、マクロ定義をファイルの先の方に置いておくのは鉄則です。その辺はインタプリタっぽい「お約束」があるので気を付けましょう。これは実装提供のマクロでも注意が必要です。

Lispのリストは便利過ぎる

シーケンシャルアクセスであるリスト(C用語で言うと連結リスト?)は遅いし重い、って印象があるわけですよ。従って、実践主義者であるPeter Seibelなんかは「Common Lispは遅くない」という事を言いたいが為にわざと、著書実践Common Lispでは、戦略的にリストの説明をあとの方に置いています。「Lispはリストだけじゃないんだ!」と言う為に。

LispのLispたる所以はリスト操作の快適さ、なわけなんですけれども、反面「リストの為に」遅い、重い、という印象になってるわけです。

余談ですが、Common Lisp以前のLispでは、何と本当に関数が内部構造をリストとして表現されていたとの事。ぶっちゃけ、重そうなんですが、反面、関数定義式がすぐ見れると言う利点もあった。Common Lispでのシンボル型へのアクセサの一つ、symbol-functionってのは元々はこいつを引きずり出す為の関数だった模様です。そして当時の実装で有名だったマクロにppと言うものがあり、この内部定義での関数のリスト表現を清書印字してくれました。これも当時のsymbol-functionあっての機能だったんですね。

しかし、これじゃ重すぎるんで、Common Lispでは関数のリスト表現を止め、もっと低レベルへのコードへとコンパイルする道を選んだのです。全ては効率の為に。代わりに、Common Lispではdescribeやらfunction-lambda-expressionやらを仕様として要求するようになったんですが、かと言って、当然文書フォーマットまで仕様で定義されているわけじゃあありません。従って、これで「読める」詳細は実装次第だ、という事になります。昔のLispなら実際定義されているコードが眺められたわけですけれど、実際動いているコードがどういう風に書かれているのか、ソースを見なくても分かる、という利点は永久に失われてしまったのです。ああ。

何が言いたいのかというと。効率と表現力はトレードオフの関係にあるという事です。効率を優先すると表現力が落ち、表現力を優先すると効率が落ちる、という事です。どうやらこれは真理らしい。少なくともLispに於いては。

依然としてLispのリストは便利過ぎる。プログラミング言語をLispからマトモに触り始めた自分は特にそうなんですけど、リストがあれば他に何もいらねーやってくらい他のデータ型を必要としないんですね(笑)。何でもリストでやれるわけですし、極めて柔軟なリストを使うと、例えばランダムアクセスの配列とか使う気がしなくなってくる(笑)。まあ、それじゃいけないのは百も承知なんですが、でも便利。何でも突っ込めるしアクセス方法も簡単ですから。

まあ、そういうテイストの矯正の意味もあって、敢えてハッシュとか構造体とか使ってみよう、って課題があったんですけど。まず効率が増える度に自由度があからさまに減っていくんですよ(笑)。これは痛感しました。多分データ型の極北であるオブジェクト指向なんてのは僕から言わせれば不自由の極みですね(笑)。

一体何が起きてるのか?つまり、データ型には設計が必要なんです。リストは何も要らね(笑)。ところが、データ型の設計の際に個人個人の頭の中に「システムの全体像」がある。そこを簡単に他人が修正するわけにはいかない、って事なんです。もちろん自分で設計したもので自分が改良するのはラクですが、たとえ教科書と言おうと他人の褌で相撲を取るってのは至難の業。いや、もっと言うと他人のデータ設計でプログラムを改良するのは無理だ、と言う結論に到達しました。まあ、僕の力量不足もあるんですけどね。

これは前回のSmall-Lispなんかは、他人の設計でも「自由度の高い」リストで主に組み立てられていたからこそ、ちょこちょこと色んな僕なりのアイディアを試せたわけです。一方、今回は難攻不落のオブジェクト指向が元ネタです。誰かがデータ構造さえ決まればプログラムは自然と決まるとか言ったらしいんですが、逆に言うと、データ構造を変更すればプログラムの全体を手直ししなければならないという意味でしょう。データ構造の手直しはちょっとやそっとでは出来ないって事に他なりません。リスト弄りと次元の違う難しさになります。実際、色々と改良を試みましたがことごとく失敗致しました。

まあ、今回はテキスト準拠だ、って前提があるんでこれでもいいんですけど。ただし、自分で設計する場合、どんな言語を使おうと、最初のプロトタイプは効率が悪くてももっとも柔軟なデータ型で作れってのが鉄則のような気がします。どうせ書き直すんですから(笑)、純粋に自分のアタマの中にあるロジック「だけを」試せるデータ型を選んだ方が良いです。そして動かしてみて徹底的に利点、問題点を洗い出す。最初から効率的なデータ型を選ぶと恐らくドツボです。それは恐らく早すぎる最適化と呼ばれるものでしょう。

もう一回言いますが、効率は自由度とのトレードオフで得られるものだと言う事です。C言語なんかは自分で連結リストを実装しなければならないでしょうが、恐らくその方が遥かにマシな結果になるような気がします。気がするだけですが。

ちなみに、ポール・グレアムは次のような事を書いていました。

リストはとても柔軟なので、探検的プログラミングにおいて有用である。リストが何を正確に表現するかについて事前にコミットする必要はない。たとえば、平面上の点を表現するために二つの数のリストを使える。二つのフィールドxとyをもつ点オブジェクトを定義する方がより正しいと考える人がいるかもしれない。しかし、点を表現するためにリストを使うと、n次元を扱うようにプログラムを拡張するときに、行なう必要があるのは座標がない場合はゼロをデフォルトとする新たなコードを作ることだけであり、残りの平面に関するあらゆるコードは動作し続けるだろう。

あるいは、別の方向に拡張して部分的に評価された点を許すと決めた場合、点の成分として変数を表現するシンボルを使い始めることが可能であり、そしてまた、既存のコードは動作し続ける。

探検的プログラミングでは、早すぎる仕様を避けることは早すぎる最適化を避けることと同じくらい重要である。

ポール・グレアム

ポール・グレアムがArcを実装する際に数さえリストで表現しようとしてみたのは割に有名な話だと思うんですが、これも自由度を優先した実験だったのでしょう。ある意味今は、「効率化」はプログラミング言語の仕事であるより、ハードウェアの進歩の仕事になってきてますからね。

さて、いよいよ本題。色々とオブジェクト指向への文句を書いていきます(笑)。

CLOSはオーバースペック

CLOS(Common Lisp Object System)程賛否両論のオブジェクト指向システムもないでしょう。いや、賛否両論ってのはちょっと違うか。実はANSI Common Lispが一番最初に公式仕様としてオブジェクト指向が定義された言語である事に誰も異論は挟まないようですし、また、誰もがCLOSがANSI Common Lispの基盤を支えてる、ってのは分かっているらしい。

ただ、要するに、CLOSを積極的に使う派と全く使わない派に分かれているってのが面白いトコです。まあ、カッコいい言い方をすればマルチパラダイムを体現しているって事なんでしょうけれども。

ところで。何で対話によるCommon Lisp入門 POD版ではCLOSでCommon Lispのサブセット実装、と言うネタにしたんでしょうか?想像するにページ数が足りなかったんじゃねえの、って思ってるんですが(笑)。

同書ではCommon Lispでのデータ抽象の話->オブジェクト指向の話->Common Lisp実装、と速いペースで流れているわけですが、殆ど本の最後なんですよね(笑)。んで、どうせオブジェクト指向を紹介しているわけですし、ページ数も少ないんで、いっちょCLOSでも使ってサブセット実装してみせるか、と。ページ数が足りないんで。ここって大事ですよ。

つまり、制限がキツいページ数でどうにかマトモに動くシステムを作るにはオブジェクト指向って強力なんですよ(笑)。特にCLOSは桁違いのパワーを持っている。色んな意味で舌を巻きました。恐らく普通に説明して実装する流れだとあのページ数でここまで動かせないんじゃなかろうか、と。CLOSのパワーを感じた瞬間です。だからこそ問題があると思ったわけなんですけど。

なお、元々CLOSはSmalltalkと言う言語に影響を受けて誕生した模様で(この辺、Simulaの影響を受けたC++/Javaと対照的)、またルーツを鑑みれば分かるんですが、そもそもLispマシンでのGUIフロントエンドを作成する為に作られたシステムだった模様です。要するにザックリ言うと、ある種コンピュータ・グラフィックス専用のシステムなんです。従って、それに関しては多大な力を発揮するように作られていますが、同時に、文字処理ベースのシステムに対してはオーバースペックって言っても良いかもしれません。つまり、スタイル的に色々とおかしな問題がこのレベルでは出てくるんじゃないか、って思います。

CLOSではデータ追加は超簡単、反面読み解くのが難しい

対話によるCommon Lisp入門 POD版の流れから言うと。最初にIDナンバー特定の為のルートクラスとしてオブジェクトクラスを作成。その子クラスとしてアトムクラスとリストクラスを作成しています。そしてアトムクラスを継承してシンボルクラスを作成。そしてシンボルクラスとリストクラスを多重継承してLisp唯一無二のデータ型であるnullクラスを作成します。と言うのも、nilはCommon Lispではアトムでもあるしリストでもあるから、です。これにより、両者を継承しているnilクラスは自然とアトムにもなりリストにもなる。凄く軽快にデータ型をここまで追加していきます。オブジェクト指向って何て便利なんでしょう!!!…ん?

いや、これは変なんですよ。確かにLisp初心者にはアトムとリストは対になってる、と教えます。教えますが……。実はこれらは本当は対立していません。アトムと対立してるデータ型はリストじゃなくってコンスなんです。従って、この論法から言うとnullはシンボルを継承しても構いませんが、リストを継承する必要なんてない、のです。単にルート近辺の継承クラスにアトムとリストを設定したからおかしな事になる。

ここで言いたいのは、継承を有効活用する以上、データ型のヒエラルキーはキチンと設計しなければならないと言う当たり前の話です。当たり前の話なんですが……CLOSはあまりに強力過ぎて、多重継承があまりにも簡単に行えてしまう為にデータ構造の設計ミスをいとも簡単に隠蔽出来てしまう、のです。残るのはこんがらがったヒエラルキーとは呼べないデータ階層の残骸です。お互いリンクを貼りまくってわけが分からなくなる。

CLOSはかなり危険なシステムなんですよ。自重する分には構わないんでしょうが、あまりにも簡単にデータ型同士にリンクが貼れてしまう為に後に構造見直すには大変な思いをする事になるでしょう。実際、この階層をPLTの単一継承での構造体のリンクへと直すのに若干困りましたから。規模にも当然依るでしょうが、このレベルでこんがらがる、って事は大きなシステムだったらなおさらこんがらがるだろう、って事です。

オブジェクト指向は破壊的操作がいっぱい

まあ、これもスタイルの問題なんでしょうけどね〜。根本的にオブジェクト指向の場合、フィールド(あるいはスロットの値)を破壊的に書き換えるのが前提の為、Schemeが標榜する関数型プログラミングと真逆のトコに位置しています。いやあ、こんなにSchemeで破壊的操作ばっかしたの初めてかもしれない(笑)。もっと上手いテ使ってイミュータブルに仕上げられる可能性もあるんだろうけどな〜。CLOSが前提で書かれたテキストなんで、この辺、上手いテが思いつきませんでした。っつーか先程書いた通り、データ構造設計が決まれば自ずとプログラムが決まるなら、このヒエラルキーが決定された以上、逃げようがないんですけどね。いや、参った参った。

この実装だと中身は循環構造でいっぱい

んで破壊的操作を目論むと当然中には循環構造なんかが自ずとから出てくるわけですよ(笑)。代表的なのはシンボルnil。nilのsymbol-valueはnilなんですよね(笑)。これで如何にも簡単に循環構造の出来上がり、です。破壊的操作様々っつーか(笑)。ポインタが自分自身を指している(笑)。

あと、パッケージもひでえな。パッケージに登録されたnilは当然シンボルなんで、パッケージ内で循環してる、と言う(笑)。最初、構造体で#:transparent(透過設定)付けてたんですけど、あまりにリンクがヒドイんで、見たくなくなって止めました(笑)。ハズしちゃった(笑)。

これ、本物のCommon Lisp実装ってどうなってんだろうな〜。あんまCommon Lispじゃ表面的に循環構造出さないんで。興味があると言えばあるんですけど(SBCLでは*print-circle*弄っても特に循環してませんでしたけどね)。いや、こええこええ。最近のSchemeだとこう言う感じの構造を作るって推奨されてねえんじゃないですかい?

メソッドがあっちこっちに散らかりまくり

恐らく他のメジャーな言語でオブジェクト指向をやって、CLOSでビックリすんのは。メソッドがクラスに属してないって事なんじゃないですかね?普通、オブジェクト指向の単純な説明では「データ型と関数を一緒にしたもの」って解説されているわけですけれども。Common Lisp Object Systemではクラス内で特にメソッドを定義しない。じゃあ、どこがオブジェクト指向なの?となるわけです。

CLOSではメソッドは総称関数と呼ばれる特殊な関数に属しています。しかもこいつは暗黙で作られる(もちろん明示作成してもいいわけですけど)。従ってクラスでデータ型定義、メソッドはまた別に、ってなるわけです。んじゃ何かこのレベルでメリットがあるのか?と問われれば実際は何もないってのが本当のところで(笑)。

唯一目立ったトコですと

• defmethodとはクラス特有の関数が作れる事
  


• メソッドは表面的にはクラスに総称関数を通じて関連付けられているので場合分けする必要がない

ってトコでしょうか。平たく言うと同名異機能の関数が定義出来るって事になるんですけど……。う〜む。

例えば、対話によるCommon Lisp入門 POD版によるとだ。evalなんてのもメソッドとして定義されてるわけですよ。あるクラス専用のeval、別のクラス専用のeval、と。

そうなると、ソースコード上にあっちにエバるは、こっちにエバる、はものすごく散漫な印象になりますよね(笑)。どっかにまとめて置いた方がいいんじゃねえの?と。でも、どっかにまとめるんだったら最初からcondでも使って単一関数として定義しても同じなんじゃねえか、と言う(笑)。何じゃそりゃ(笑)。

まあ、多分、こういうシステムにしてるのは、それこそやっぱりコンピュータグラフィックス作成みたいな大規模システム向けだから、って事じゃないんですかね?まともに書いてて条件分けが20とか30とかになったらさすがに嫌だろ、って事で(笑)。だったら、そのテの条件分け自体が判定システムである総称関数に任せておいて、クラスの傍にメソッド置いときゃエエやん、と。多分元々の発想はそんなトコだったと思いますけど。

要するに、この程度の分量のソースコード量だとCLOSなんて出してもしゃーないって事でもあるんですよ。どの程度の規模のシステムから上がCLOSの領域になるのか、ってのはハッキリしませんが、いずれにせよ、この程度の分量で、あっちにメソッド、こっちにも同名のメソッドが分散してる、って感じじゃ単に邪魔なだけって気がします。古き良きcondを利用したほうがスッキリすると思います。

なお、PLTの構造体を使って場合分けする場合、継承が絡んでくるので、より特定的な派生データ型から条件を徐々に緩めていくような書き方をしないとなりません。最初の一番目の述語がルート構造体のモノだったりすれば派生構造体は全部#tになっちゃうんでおかしくなる。まあ、その辺総称関数だとある程度指定しつつも、自動で最も特定的なクラスに絡んだメソッドを選び出してくれる、ってんでラクってばラクなんですけど……。そもそもそんな事態に陥るのは継承なんて余計な事をしてるからじゃねえのかってのも事実であって(笑)。やれやれ(笑)。

ま、いずれにせよ、CLOSは大規模システム向けです。個人レベルだと使おうが使わまいがどーでもいい。っつーかこのレベルでは明らかに害悪なんじゃねーの、とか思います。

CLOSに付いては以上。終わり。

継続はやっつけ仕事のハックにも最適

クダラない話なんですが(笑)。対話によるCommon Lisp入門 POD版はあまりにも教科書的なREPLモデルを採用していて。これが一旦上部レイヤーのインタプリタ内部に入ると止められないんだ(笑)。端末クローズする以外手がない、っつーか(笑)。どうすんだろ、これ、みたいな感じで(笑)。他の人の話聞いてみたい(爆)。

重要なのは。このシステムだと、一旦READしたら即レイヤー上のLisp構文に変更しちゃうわけですよ。そのデータ変換ってのがこのテキスト上のCommon Lispのサブセットの肝なんですけど。一旦変換されたらexit命令もそのレイヤー内で実装しなければならない、って事になる。一体どうすんべえ、と。かなり困ってたんですね(笑)。

そこでやっつけ仕事。伝家の宝刀、Schemeのcall/ccの出番です。連続体(print (eval (read)))は切り離せないんで、READの返り値がある条件を満たした時、これらカッコの連続体から大域脱出しちゃう。これならちょっとの変更だけで、構造壊しませんしね。やっつけ仕事の際のcall/ccはマジで重宝しますよ(笑)。もう大好き(笑)。

マクロ実装はやっぱり今後の課題

かなりマクロ実装まで後一歩、ってトコまで来てる感じもするんですけどね〜。実際、内部定義してる時「これって形式的にはマクロだよな?」と思いまた、「マクロさえあればもっと簡単に定義出来るのに…」とほぞを噛む事もしばしば、でした。

Lisp系の本では、良く、マクロによるメタプログラミングの重要性が解かれています。ポール・グレアムは次のように言ってます。

マクロを書くというのは、Lispのプログラミングの中でも特別な手法であり、固有の目的と問題がある。コンパイラに渡る内容に変更を加えられるというのは、コンパイラを書き換えられるのとほとんど一緒である。したがって、マクロを書くときには、言語設計者のように考えながら始めなければならない。

ANSI Common Lisp (スタンダードテキスト)

ぶっちゃけ、

「何この人言ってんの?」

とか思ったわけですけど(笑)。メタプログラミングやるのにあたって、プログラマが言語設計者のように考えなければならない?言語設計した事もねえのにか(笑)。だったら無理だろ、と(笑)。

いや、その通りなんだと思います。プログラマにメタプログラミングは通常要らないんですよ。歌うたった事ないヤツに「歌手のように考えろ」とか、演技した事無いヤツに「俳優のように考えろ」ってのは土台無理な相談でしょ。プログラムした事ないヤツに「プログラマのように考えろ」ってのはメタファとしては成り立ちますが現実的な提案じゃありません。しかしマクロは現実に存在してて現実に関連しているわけですから、別な言い方するとやっぱり「言語設計した事が無いヤツが言語設計者のように考える」ってのは無理なんです。んな事ありえない。

という事はだ。この提案には次の二つの意味が考えられます。

1. 実はマクロ自体は言語設計者に取って一番便利な機能であって、ある意味プログラマの為のものではない。
   


2. マクロを理解するには実際にプログラミング言語を実装してみる必要がある。

この二つですよね。そして、これらはLispに於いてはかなり接近している、って意味なんです。つまり、Lispの力がマクロにあり、他の言語に比べるとLispのLispによる実装が簡単だとしたら……。試してみる価値がありますし、恐らく自分でLisp実装をしてみるのがマクロを理解する早道でしょう。そして実装した途端マクロが絶対欲しくなる。コア機能を定義した後のライブラリ的な意味じゃない「機能拡張」はマクロがあったほうが俄然ラクだから、です。

多分、この辺が、Lispのマクロに関しての他言語ユーザーの誤解の源なのかな、とはちょっと思いますね。その辺の言語でその言語自体を実装する事自体が凄く難しい。Lispは機能拡張可能な言語ですが、それは言語設計との境界線を曖昧にしている。それが故にLispに於ける「メタプログラミング」の重要性がピンと来なくなるんで、マクロ是非論、ってのが出てくるのかも。

もう一回言うと、マクロは言語設計者の為の機能でプログラマの為の機能ではない事は明らかです。ただし、Lispに於いてはプログラマと言語設計者の境界線は曖昧だって事です。という事は曲りなりにもLispを実装してみる価値はある。

多分プログラマ的観点でいてもつまるところマクロって理解出来ないような気がします。何となくですけど。で、Lispに於ける境界線が曖昧だったら跨いでもエエんちゃうの?ってのを最近感じ始めました。向こうの水は甘いぞ(笑)。

まあ、残念ながら、今のトコ、defmacroのプリミティヴとしての実装方法って分からないんですけどね。もうちょっとLisp実装を何回かやってみて、改めてArcのソースでも精読してみたいと思います。何かヒントがあるかも。

とまあ、これらが徒然と今回感じたもの、です。CLOSでのコードには腹立ちながらやってたんですが(笑)、曲りなりにもパッケージシステムの実装を通じて、Lisp-1でLisp-2が実装出来たんだ、ってのは感慨深いです。ちょっとレアケースかも、とか思っています。まあ、まだ色々と抜けもありますが、いずれにせよ、前回のSmall-Lispに比べても高機能になったんで良かったですね。苦労しただけの事はありました。

	#!/usr/bin/env bash
	mzscheme blisp.ss

view raw blisp hosted with ❤ by GitHub

	;; mzscheme blisp.ss
	#lang scheme
	(require "bang-lisp-ver.1.0.ss")
	(!lisp-load "blisp.blisp")
	(!lisp)

view raw blisp.ss hosted with ❤ by GitHub

	;; bang-lisp is a subset of Common Lisp implementation,
	;; based on the textbook, "対話によるCommon Lisp入門",
	;; published from 森北出版株式会社.
	;; # ISBN-10: 4627836090
	;; # ISBN-13: 978-4627836099
	;; Additionally, some library functions are imported from
	;; Appendix B of Paul Graham's "ANSI Common Lisp".
	;; # ISBN-10: 4894714337
	;; # ISBN-13: 978-4894714335
	;; Originally, "対話によるCommon Lisp入門" suggests to use
	;; CLOS, Common Lisp Object System, to implement the subset
	;; of Common Lisp; however, I do not like Object Oriented
	;; Programming style; in fact, I do try that by using PLT
	;; Scheme's define-struct. Therefore, this implementation
	;; heavily depends on PLT Scheme in order to convert some OOP
	;; idea to structures with some fun and ,also, headache.
	;; Thanks to PLT to provide such a great Scheme implementation,
	;; anyway.
	;; People may see the topic like Scheme implemented on Scheme or
	;; CL implemented on CL; however I think it must be rarely to see
	;; CL implemented on Scheme and vice versa. Thus, even though this
	;; is my personal lesson to understand Lisps more, it may be helpful
	;; for the people, studying to implement a Common Lisp subset on
	;; Scheme. It must be fun across Lisp-1 and Lisp-2, with PLT.
	;; By the way, most of ! mark on this source does not related to
	;; any destructive operations(some are yes, of course).
	;; The way of naming procedures here just relies on the text book,
	;; "対話によるCommon Lisp入門".
	(module bang-lisp-ver.1.0 scheme
	(provide (all-defined-out))
	;;; !Lisp 基本設定
	;; id の設定
	(define *new-id* 0)
	(define (new-id) (set! *new-id* (+ 1 *new-id*)) *new-id*)
	;; オブジェクトの生成
	(define-struct !object (id))
	;; 二つのオブジェクトの同値性判定
	(define (!eq? x y) (= (!object-id x) (!object-id y)))
	;;; 構造体によるデータ抽象
	;; 構造体によるアトムの定義
	(define-struct (!atom !object) ()
	)
	;; 構造体によるコンスの定義
	(define-struct (!cons !object)
	(first rest)
	)
	;; 構造体による数値の定義
	(define-struct (!number !atom) (number)
	)
	;; 構造体による文字列の定義
	(define-struct (!string !atom) (string)
	)
	;; 構造体によるシンボルの定義
	(define-struct (!symbol !atom)
	(name value function plist package)
	#:mutable
	)
	;; 構造体による NULL の定義
	(define-struct (!null !symbol) ()
	)
	;;; 構造体によるパッケージの定義
	(define-struct (!package !atom)
	(name hash)
	)
	;;; 構造体による関数の定義
	(define-struct (!function !atom) ()
	)
	;; 構造体による特殊オペレータの定義
	(define-struct (!special !function)
	(code)
	)
	;; 構造体による funcallable の定義
	(define-struct (!funcallable !function) ()
	)
	;; 構造体によるプリミティヴの定義
	(define-struct (!primitive !funcallable)
	(code)
	)
	;; 構造体によるクロージャの定義
	(define-struct (!closure !funcallable)
	(body parameters environment)
	)
	;; make-instance で構造体によるデータ型の作成(ショートカット)
	(define-syntax make-instance
	(syntax-rules
	(!object !atom !cons !number !string
	!symbol !package !special !primitive !closure)
	((_ !object)
	(make-!object (new-id)))
	((_ !atom)
	(make-!atom (new-id)))
	((_ !cons x y)
	(make-!cons (new-id) x y))
	((_ !number number)
	(make-!number (new-id) number))
	((_ !string string)
	(make-!string (new-id) string))
	((_ !symbol name value function plist package)
	(make-!symbol (new-id)
	name value function plist package))
	((_ !package name hash)
	(make-!package (new-id)
	name hash))
	((_ !special code)
	(make-!special (new-id) code))
	((_ !primitive code)
	(make-!primitive (new-id) code))
	((_ !closure body parameters environment)
	(make-!closure (new-id) body parameters environment))))
	;;; データ変換
	;; !Lisp のデータから PLT Scheme 上のデータへの変換
	(define (!CL->plt !obj)
	(cond ((!cons? !obj)
	(cons (!CL->plt (!cons-first !obj))
	(let ((tail (!cons-rest !obj)))
	(if (!null? tail)
	'()
	(!CL->plt tail)))))
	((!symbol? !obj)
	(string->symbol (!CL->plt (!symbol-name !obj))))
	((!string? !obj)
	(!string-string !obj))
	((!number? !obj)
	(!number-number !obj))
	((!object? !obj)
	!obj)
	(else
	#f)))
	;; PLT Scheme のデータから !Lisp 上のデータへの変換
	(define (plt->!CL obj)
	(cond ((pair? obj)
	(!cons! (plt->!CL (car obj)) (plt->!CL (cdr obj))))
	((null? obj)
	!nil)
	((symbol? obj)
	(!intern! (plt->!CL (string-upcase (symbol->string obj)))))
	((string? obj)
	(make-instance !string obj))
	((number? obj)
	(make-instance !number obj))
	(else
	#f)))
	;;; 手続き
	;; !make-symbol! の定義
	(define (!make-symbol! !str !pac)
	(make-instance !symbol !str #f #f #f !pac))
	;; null!? の定義
	(define (null!? !obj)
	(!eq? !obj !nil))
	;; !intern! の定義
	(define (!intern! !str (!pac !*package*))
	(let ((str (!string-string !str))
	(hash (!package-hash !pac)))
	(let ((!sym (hash-ref hash str #f)))
	(or !sym
	(let ((!symbol (!make-symbol! !str !pac)))
	(hash-set! hash str !symbol)
	!symbol)))))
	;; コンスの定義
	(define (!cons! x y)
	(make-instance !cons x y))
	;; 引数を評価しない手続き
	(define (noeval-args! !args)
	(let loop ((!args !args) (acc '()))
	(if (null!? !args)
	(reverse acc)
	(loop (!cons-rest !args)
	(cons (!cons-first !args) acc)))))
	;; 引数を評価する手続き
	(define (eval-args! !args local)
	(let loop ((!args !args) (acc '()))
	(if (null!? !args)
	(reverse acc)
	(loop (!cons-rest !args)
	(cons (!eval! (!cons-first !args) local) acc)))))
	;; funcall の定義
	(define (!funcall! !obj . args)
	(cond
	((!closure? !obj)
	(!eval! (!closure-body !obj)
	(let ((h (!closure-environment !obj)))
	(for-each (lambda (key val)
	(hash-set! h key val))
	(!closure-parameters !obj)
	args)
	h)))
	((!primitive? !obj)
	(apply (!primitive-code !obj) args))
	(else
	#f)))
	;; function の定義
	(define (!function! local !obj)
	(cond
	((!cons? !obj)
	(make-instance !closure
	(!cons-first (!cons-rest (!cons-rest !obj)))
	(noeval-args! (!cons-first (!cons-rest !obj)))
	local))
	((!symbol? !obj)
	(!symbol-function !obj))
	(else
	#f)))
	;; 外部ライブラリのロード用手続き
	(define (!lisp-load filename)
	(letrec ((!load
	(lambda (p)
	(let ((x (read p)))
	(cond ((eof-object? x)
	(close-input-port p))
	(else
	(!eval! (plt->!CL x))
	(!load p)))))))
	(call-with-input-file filename !load)))
	;;; 大域変数
	;; 大域変数としてのパッケージの定義
	(define !*package*
	(make-instance !package
	(plt->!CL "!CL-USER")
	(make-hash)))
	;; 大域変数としての nil の定義
	(define !nil
	(make-!null (new-id)
	(plt->!CL "NIL")
	#f
	#f
	#f
	!*package*))
	(set-!symbol-value! !nil !nil)
	(set-!symbol-plist! !nil !nil)
	;; 大域変数としてのパッケージの定義
	(hash-set! (!package-hash !*package*) "NIL" !nil)
	;; 大域変数としての t の定義
	(define !t (plt->!CL 't))
	(set-!symbol-value! !t !t)
	;; 大域変数としての pi の定義
	(define !pi (plt->!CL 'pi))
	(set-!symbol-value! !pi (plt->!CL pi))
	;; 大域変数としての lambda の定義
	(define !lambda (plt->!CL 'lambda))
	;;; !Lisp 本体
	;; REPL
	(define *version* "!Lisp Ver.1.0\n")
	(define (!lisp)
	(call/cc
	(lambda (k)
	(define (repl)
	(print-prompt) (!print! (!eval! (!read! k))) (newline))
	(define (loop exp)
	(loop (repl)))
	(display *version*)
	(loop (repl)))))
	(define (print-prompt)
	(display (string-append
	(!CL->plt (!package-name !*package*))
	"> ")))
	(define (!read! k)
	(let ((exp (read)))
	(if (and (list? exp)
	(memq (car exp)
	'(bye quit end exit)))
	(k 'GOOD-BYE)
	(plt->!CL exp))))
	(define (!print! !obj)
	(write (!CL->plt !obj))
	!obj)
	;; eval
	(define (!eval! !obj (local (make-hasheq)))
	(cond
	((!cons? !obj)
	(!apply! (!cons-first !obj) (!cons-rest !obj) local))
	((!symbol? !obj)
	(let ((binding (hash-ref local !obj #f)))
	(or binding
	(!symbol-value !obj))))
	(else
	!obj)))
	;; apply
	(define (!apply! !obj !args local)
	(cond
	((!funcallable? !obj)
	(apply !funcall!
	(cons !obj (eval-args! !args local))))
	((!special? !obj)
	(apply (!special-code !obj)
	(cons local
	(noeval-args! !args))))
	((!symbol? !obj)
	(!apply! (!symbol-function !obj) !args local))
	(else
	#f)))
	;;; 特殊オペレータの定義
	;; quote の定義
	(define (!quote! local !a1) !a1)
	;; if の定義
	(define (!if! local !condition !then !else)
	(if (null!? (!eval! !condition local))
	(!eval! !else local)
	(!eval! !then local)))
	;; setq の定義
	(define (!setq! local !sym !form)
	(let ((!value (!eval! !form local))
	(binding (hash-ref local !sym #f)))
	(cond (binding
	(set! binding !value)
	!value)
	(else
	(set-!symbol-value! !sym !value)
	!value))))
	;; defun の定義
	(define (!defun! local !name !parameters !body)
	(set-!symbol-function! !name
	(make-instance !closure
	!body
	(noeval-args! !parameters)
	local))
	!name)
	;;; 基本関数の定義
	;; eq? の定義
	(define (!eq!? !x !y)
	(if (!eq? !x !y) !t !nil))
	;; null? の定義
	(define (!null!? !x) (!eq!? !x !nil))
	;; atom? の定義
	(define (!atom!? !x)
	(cond ((!atom? !x) !t)
	((!null? !x) !t)
	(else !nil)))
	;; list? の定義
	(define (!list!? !x)
	(cond ((!cons? !x) !t)
	((!null? !x) !t)
	(else !nil)))
	;; + の定義
	(define (!+! . list-of-!numbers)
	(plt->!CL (apply + (map !CL->plt list-of-!numbers))))
	;; - の定義
	(define (!-! . list-of-!numbers)
	(and (pair? list-of-!numbers)
	(plt->!CL (apply - (map !CL->plt list-of-!numbers)))))
	;; * の定義
	(define (!*! . list-of-!numbers)
	(plt->!CL (apply * (map !CL->plt list-of-!numbers))))
	;; / の定義
	(define (!/! . list-of-!numbers)
	(and (pair? list-of-!numbers)
	(plt->!CL (apply / (map !CL->plt list-of-!numbers)))))
	;; eval の定義
	(define (!eval*! !form) (!eval! !form (make-hasheq)))
	;; consp の定義
	(define (!cons!? !obj) (if (!cons? !obj) !t !nil))
	;; stringp の定義
	(define (!string!? !obj) (if (!string? !obj) !t !nil))
	;;; 各定義のインストール
	;; quote のインストール
	(set-!symbol-function! (plt->!CL 'quote)
	(make-instance !special !quote!))
	;; if のインストール
	(set-!symbol-function! (plt->!CL 'if)
	(make-instance !special !if!))
	;; setq のインストール
	(set-!symbol-function! (plt->!CL 'setq)
	(make-instance !special !setq!))
	;; eq のインストール
	(set-!symbol-function! (plt->!CL 'eq)
	(make-instance !primitive !eq!?))
	;; null のインストール
	(set-!symbol-function! (plt->!CL 'null)
	(make-instance !primitive !null!?))
	;; atom のインストール
	(set-!symbol-function! (plt->!CL 'atom)
	(make-instance !primitive !atom!?))
	;; listp のインストール
	(set-!symbol-function! (plt->!CL 'listp)
	(make-instance !primitive !list!?))
	;; + のインストール
	(set-!symbol-function! (plt->!CL '+)
	(make-instance !primitive !+!))
	;; - のインストール
	(set-!symbol-function! (plt->!CL '-)
	(make-instance !primitive !-!))
	;; * のインストール
	(set-!symbol-function! (plt->!CL '*)
	(make-instance !primitive !*!))
	;; / のインストール
	(set-!symbol-function! (plt->!CL '/)
	(make-instance !primitive !/!))
	;; first のインストール
	(set-!symbol-function! (plt->!CL 'first)
	(make-instance !primitive !cons-first))
	;; rest のインストール
	(set-!symbol-function! (plt->!CL 'rest)
	(make-instance !primitive !cons-rest))
	;; cons のインストール
	(set-!symbol-function! (plt->!CL 'cons)
	(make-instance !primitive !cons!))
	;; read のインストール
	(set-!symbol-function! (plt->!CL 'read)
	(make-instance !primitive !read!))
	;; print のインストール
	(set-!symbol-function! (plt->!CL 'print)
	(make-instance !primitive !print!))
	;; symbol-name のインストール
	(set-!symbol-function! (plt->!CL 'symbol-name)
	(make-instance !primitive !symbol-name))
	;; symbol-value のインストール
	(set-!symbol-function! (plt->!CL 'symbol-value)
	(make-instance !primitive !symbol-value))
	;; symbol-function のインストール
	(set-!symbol-function! (plt->!CL 'symbol-function)
	(make-instance !primitive !symbol-function))
	;; symbol-plist のインストール
	(set-!symbol-function! (plt->!CL 'symbol-plist)
	(make-instance !primitive !symbol-plist))
	;; symbol-package のインストール
	(set-!symbol-function! (plt->!CL 'symbol-package)
	(make-instance !primitive !symbol-package))
	;; funcall のインストール
	(set-!symbol-function! (plt->!CL 'funcall)
	(make-instance !primitive !funcall!))
	;; function のインストール
	(set-!symbol-function! (plt->!CL 'function)
	(make-instance !special !function!))
	;; defun のインストール
	(set-!symbol-function! (plt->!CL 'defun)
	(make-instance !special !defun!))
	;; eval のインストール
	(set-!symbol-function! (plt->!CL 'eval)
	(make-instance !primitive !eval*!))
	;; consp のインストール
	(set-!symbol-function! (plt->!CL 'consp)
	(make-instance !primitive !cons!?))
	;; stringp のインストール
	(set-!symbol-function! (plt->!CL 'stringp)
	(make-instance !primitive !string!?))
	)

view raw bang-lisp-ver.1.0.ss hosted with ❤ by GitHub

	(defun car (x)
	(first x))
	(defun cadr (x)
	(car (cdr x)))
	(defun cddr (x)
	(cdr (cdr x)))
	(defun cdr (x)
	(rest x))
	(defun copy-list-aux (x)
	(if (atom x)
	x
	(cons (car x)
	(copy-list-aux (cdr x)))))
	(defun copy-list (lst)
	(cons (car lst) (copy-list-aux (cdr lst))))
	(defun copy-tree (tr)
	(if (atom tr)
	tr
	(cons (copy-tree (car tree))
	(copy-tree (cdr tree)))))
	(defun identity (x)
	x)
	(defun mapcar (fn lst)
	(if (null lst)
	nil
	(cons (funcall fun (car lst))
	(mapcar fun (cdr lst)))))
	(defun not (x)
	(eq x nil))
	(defun pair (lst)
	(if (null lst)
	nil
	(cons (cons (car lst) (cadr lst))
	(pair (cddr lst)))))
	(defun second (x)
	(cadr x))
	(defun third (x)
	(car (cdr (cdr x))))
	(defun 1+ (x)
	(+ x 1))
	(defun 1- (x)
	(- x 1))

view raw blisp.blisp hosted with ❤ by GitHub

vallog: macro while

vallog: macro while

do マクロの使い方を覚えられないクラスタです。

なかなかこれが、Schemeでは再帰ばっか練習するんで、doは意識して練習しないとdo嫌いに成りかねません。
まあ、以前も言ったんですけど、スタイル的には実はdoはnamed-letの変種です。Common Lispの内部では再帰とは全く違う破壊的な計算を行ないますが、かと言って、スタイルだけに注目すれば、実はnamed-letとはそんなに違いがないのです。
僕の中では

1. 横に広がるnamed-let


2. 縦に伸びるdo

とか言ってました。意味分かんないっすね(笑)。まあ、変数束縛の位置が、って事なんですけれども。あと、doがフグみたいに見える、ってんでフグ構文とか呼んでたりしました(笑)。

doの一般形は次のようになっています。

	(do (( <<変数1>> <<初期値1>> <<ステップ1>>)
	...
	( <<変数m>> <<初期値m>> <<ステップm>>))
	(<<終了条件>> <<式>>...<<式>>)
	<<式1>>
	...
	<<式n>>)

view raw basic-of-do.lisp hosted with ❤ by GitHub

ね、フグみたいでしょ(笑)?



Schemeのnamed-letの一般形は次の通りです。

	(let name ((<<変数1>> <<初期値1>>) ... (<<変数m>> <<初期値m>>))
	(cond (<<終了条件>>
	<<式>> ... <<式>>)
	(else
	(name <<ステップ1>> ... <<ステップm>>))))

view raw named-let.scm hosted with ❤ by GitHub

つまり、基本的には変数、初期値、ステップの配置が違うだけ、です。doだとまとめて記述する。named-letだとそうじゃない、って事ですね。

どっちがどっちより便利、って事は基本無いわけなんですけれども。

	;; ファイルを読み込んで行数を表示する手続き(Scheme)
	(define (count-lines filename)
	(call-with-input-file filename
	(lambda (p)
	(let loop ((c (read-char p))
	(count 0))
	(cond ((eof-object? c) (close-input-port p) count)
	(else (loop (read-char p) (if (char=? c #\newline)
	(+ count 1)
	count))))))))
	(define (count-lines/do filename)
	(call-with-input-file filename
	(lambda (p)
	(do ((c (read-char p) (read-char p))
	(count 0 (if (char=? c #\newline)
	(+ count 1)
	count)))
	((eof-object? c) (close-input-port p) count)))))

view raw named-let-ve-do.scm hosted with ❤ by GitHub

ただ、個人的には、ここで言う副作用とは、例えば入出力であるとか、そう言うケースですが、副作用が関わる式、特に出力を実行しなければならない場合、doの方がよりシンプルに書ける場合が多いとは思います。named-letだと、スッキリ決まらないケースが多くて、そう言う場合、doの方がシックリくる場合が多いような気がします。

	;; ファイルを読み込んで表示して、行数を表示する手続き(Scheme)
	(define (print-and-count-lines filename)
	(call-with-input-file filename
	(lambda (p)
	(let loop ((c (read-char p))
	(count 0))
	(cond ((eof-object? c) (close-input-port p) count)
	(else (display c) ; 基本 begin に頼って形式的には汚くなる
	(loop (read-char p) (if (char=? c #\newline)
	(+ count 1)
	count))))))))
	(define (print-and-count-lines/do filename)
	(call-with-input-file filename
	(lambda (p)
	(do ((c (read-char p) (read-char p))
	(count 0 (if (char=? c #\newline)
	(+ count 1)
	count)))
	((eof-object? c) (close-input-port p) count)
	(display c))))) ;ボディに出力命令がサッと置ける

view raw named-let-vs-do-2.scm hosted with ❤ by GitHub

上の例はあまり良くないんですが、と言うのも、named-letはcondを使って暗黙のbeginで上手い具合にみっともなさを回避してるんですが、基本、named-letのシンプルさはぶち壊れてるんです(笑)。目立ちませんが(笑)。
反面、後者のdoヴァージョンは本体部に「計算以外の余計な作業」をまとめられます。これはシンプル過ぎる例なんですが、長く余計な作業がある、って事はままあるんです。そう言う時、さすがの再帰構文でもシンプルに書けなくなる。いや、構造はシンプルなんですが、コード自体は汚く見える場合があるんですよね。

いや、すまない。いい例が思いつかなかった(爆)。ただ、普段は再帰で構わないけど、いざとなったらdoの方がシンプルに書ける場合があるんだよ、って事です。はい。

注:いや、ホントに下手な例でゴメン。というのも、doに関して言っても、カウンター内で出来る事は全てやってしまうのがスタイル的には美しいんですが、それで悩むんだったら素直に再帰した方が良い、ってのが事実。要するに再帰での「引数内のカウンター処理だけじゃどうしようもない」部分が出てきた場合、doの出番だ、って言い方の方が正しいかも。

さて、valvallowさんの記事によると、どうやら「NILじゃない返り値が欲しい」との事。まあ、これは当然でしょうね。
ポール・グレアムが何でマクロで書いたwhileでNIL以外の返り値を返すようにしなかったのか?想像するに、二つ程理由が考えられて、マクロの導入章(第7章なのに!)の辺りなんで、あんまややこしい例じゃなくってシンプルな例にしたかった事。あとは破壊的変更が前提のマクロなんで、返り値を返すとマズイ、って事があったんでしょうね。

グレアムのwhileは次のようにしてみれば面白い結果が出てきます。

	CL-USER> (defmacro my-while (test &body body)
	`(do ()
	((not ,test))
	,@body))
	MY-WHILE
	CL-USER> (let ((i 0))
	(my-while (< i 10)
	(print i)
	(incf i)) ; (setf i (+ i 1)) と同じ
	i) ; i を返してみる
	0
	1
	2
	3
	4
	5
	6
	7
	8
	9
	10 ;何と i は 10 になってる!
	CL-USER>

view raw graham's-do-example.lisp hosted with ❤ by GitHub

whileの指定はi < 10の筈なのに、何とiは10になっています。つまり、返り値になるのはこのiになるのは自明でしょう。これはマズいです(笑)。恐らく返り値は9であって欲しい、ってのが皆願う事でしょうから。
だから破壊的変更が前提なら、返り値をNILでもしとけば良い。堅実な判断ですよね。

さて、それでは返り値を、Common Lispらしく最後に実行された値を返すように改造していきましょう。まずは、LOLでお馴染みでしょうが、関数lastとbutlastってのを使ってみます。

	CL-USER> (last '(0 1 2 3 4 5))
	(5)
	CL-USER> (butlast '(0 1 2 3 4 5))
	(0 1 2 3 4)
	CL-USER>

view raw last-and-butlast.lisp hosted with ❤ by GitHub

関数lastはリストの最後の値のリストを返し、関数butlastはリストの最後の要素を除いたリストを返します。今何でこれを使おうと思ったのか、と言う理由は、繰り返しが何回実行されようと、必要なのは計算の最後の作業結果だという事だからです。
例えば、上のvalvallowさんの例だと、欲しいのは式をして実行された(print i)と(incf i)全体じゃなくって、あくまで(incf i)だけ、なんです。言い換えるとbodyの最後の計算結果さえ分かっていれば良い、と言う事です。
すなわち、bodyを二つに分けちゃう。最後と、それ以外、です。

このアイディアで雛形は一応次の通りになります。

	(defmacro my-while% (test &body body)
	;; var の初期値は nil で、(last body) は do のボディの式が評価されてから実行される
	`(do ((var nil ,@(last body)))
	((not, test) var)
	,@(butlast body))) ; body の最後尾以外の評価がボディの仕事

view raw my-while%.lisp hosted with ❤ by GitHub

では実行してみますか。

	CL-USER> (let ((i 0))
	(my-while% (< i 10)
	(print i)
	(incf i)))
	0
	1
	2
	3
	4
	5
	6
	7
	8
	9
	10 ; あれ!?やっぱり10になっている!
	CL-USER>

view raw evaluation-of-my-while%.lisp hosted with ❤ by GitHub

やっぱりダメだ(笑)!bodyを二つに分ける、ってアイディアは秀悦だとは思うんですが、返り値が10になってます。こりゃイカン。
この理由は、終了条件が調べられる前にvarが更新されちゃうから、なんです。つまり、テスト式に行く前にiが10になってしまう。ここを直さないとどーにもならん、わけです。
さて、ここでやっつけ仕事のハック。嫌でもvarが更新されちゃうんだったら、その前の状態を保存しとけばエエんちゃうの?ってのがアイディア。つまり、変数を二つ用意しちゃうんだ!!!一つは今まで通り(last body)の更新用。もうひとつは、前回のそれの保存用だ!これでどうだ。

	(defmacro my-while%% (test &body body)
	;; var0 の初期値は nil で、(last body) は do のボディの式が評価されてから実行される
	`(do ((var0 nil ,@(last body))
	;; var1 の初期値も nil で、更新値は「前回の」var0 の値
	(var1 nil var0))
	((not ,test) var1) ; 返り値は var1 になる
	,@(butlast body)))

view raw my-while%%.lisp hosted with ❤ by GitHub

では実行してみましょう。

	CL-USER> (let ((i 0))
	(my-while%% (< i 10)
	(print i)
	(incf i)))
	0
	1
	2
	3
	4
	5
	6
	7
	8
	9
	9 ; やった!返り値が 9 になった!
	CL-USER>

view raw evaluation-of-my-while%%.lisp hosted with ❤ by GitHub

上手く行きましたね。大成功！！！これで終わり……とはいかないんですよ、残念ながら(笑)。
実はこのマクロは次のような問題があるんです。

	CL-USER> (let ((var0 0))
	(my-while%% (< var0 10)
	(print var0)
	(incf var0)))
	; in: LAMBDA NIL
	; (LET ((VAR0 0))
	; (MY-WHILE%% (< VAR0 10) (PRINT VAR0) (INCF VAR0)))
	;
	; caught STYLE-WARNING:
	; The variable VAR0 is defined but never used.
	;
	; compilation unit finished
	; caught 1 STYLE-WARNING condition
	; Evaluation aborted.
	CL-USER> (let ((var1 0))
	(my-while%% (< var1 10)
	(print var1)
	(incf var1)))
	; in: LAMBDA NIL
	; (LET ((VAR1 0))
	; (MY-WHILE%% (< VAR1 10) (PRINT VAR1) (INCF VAR1)))
	;
	; caught STYLE-WARNING:
	; The variable VAR1 is defined but never used.
	;
	; compilation unit finished
	; caught 1 STYLE-WARNING condition
	; Evaluation aborted.
	CL-USER>

view raw error-of-my-while%%.lisp hosted with ❤ by GitHub

これが変数衝突ですね。つまり、my-while%%マクロの内部でvar0、var1って変数名を使ってるわけなんですけど、これが外部から与えられると途端にぶつかってしまってどうにもこうにも行かなくなる。
つまり、これを避けるのがgensymです。だから、こう書かないとなりません。

	(defmacro my-while (test &body body)
	;; テンプレートの外部で var0、var1 で gensym を束縛する
	(let ((var0 (gensym)) (var1 (gensym)))
	`(do ((,var0 nil ,@(last body))
	(,var1 nil ,var0))
	((not ,test) ,var1)
	,@(butlast body))))

view raw my-while.lisp hosted with ❤ by GitHub

これで安心してどんな変数名をmy-whileマクロ内に持たせても大丈夫です。

	CL-USER> (let ((i 0))
	(my-while (< i 10)
	(print i)
	(incf i)))
	0
	1
	2
	3
	4
	5
	6
	7
	8
	9
	9 ; 返り値は9!!!
	CL-USER> (let ((var0 0))
	(my-while (< var0 10)
	(print var0)
	(incf var0)))
	0
	1
	2
	3
	4
	5
	6
	7
	8
	9
	9 ; 多い日も安心!
	CL-USER> (let ((var1 0))
	(my-while (< var1 10)
	(print var1)
	(incf var1)))
	0
	1
	2
	3
	4
	5
	6
	7
	8
	9
	9 ; 横モレしない!
	CL-USER>

view raw evaluation-of-my-while.lisp hosted with ❤ by GitHub

gensymをいつ使うか?基本的にはいつでもです。意図してアナフォリックマクロを書く時以外はバンバン使って構わないと思います。あって困るもんじゃない。
基本的には、

• defmacroで引数として与えられた変数以外で、テンプレート内に「いきなり」現れる名前全部に対してgensymを使って構わない

と言うのが原則です。複雑なマクロでテンプレート内にバンバン新しい変数が現れる場合はgensymだらけになりますが、それで良い、のです。繰り返しますが、gensymはあって困るもんじゃない。むしろ無けりゃ困るんです。

まあ、もっともみっともなくなる可能性もありますが、その回避の為にOn Lispではwith-gensymsというコードが紹介されています。また、上のmy-whileはLOL流にdefmacro!を用いれば次のように記述されますね。

	(defmacro! my-while! (test &body body)
	`(do ((,g!var0 nil ,@(last body))
	(,g!var1 nil ,g!var0))
	((not ,test) ,g!var1)
	,@(butlast body)))

view raw my-while!.lisp hosted with ❤ by GitHub

ちなみに、再帰版は次のようになるでしょう。

	(defmacro my-while2 (test &body body)
	(let ((self (gensym)) (exp (gensym)) (acc (gensym)))
	`(labels
	((,self (,exp ,acc)
	(if (not, test)
	,acc
	(,self (progn ,@body) ,exp))))
	(,self (progn ,@body) nil))))
	(defmacro! my-while2! (test &body body)
	`(labels
	((,g!self (,g!exp ,g!acc)
	(if (not ,test)
	,g!acc
	(,g!self (progn ,@body) ,g!exp))))
	(,g!self (progn ,@body) nil)))

view raw recursive-my-whiles.lisp hosted with ❤ by GitHub

vallog: On Lisp memoize

vallog: On Lisp memoize

あああ、僕もうっかりしてました。

On Lispのmemoizeなんですけど。久々にGauche起動してValvallowさんに従って試してみたら、次のような結果になりました。

	gosh> (define (memoize fn)
	(let ((cache (make-hash-table 'equal?)))
	(lambda args
	(let ((val (hash-table-get cache args #f)))
	(if val val
	(hash-table-put! cache args (apply fn args)))))))
	memoize
	gosh> (define (fib n)
	(if (< n 2)
	1
	(+ (fib (- n 1))(fib (- n 2)))))
	fib
	gosh> (time (fib 35))
	;(time (fib 35))
	; real 2.451
	; user 2.450
	; sys 0.000
	14930352
	gosh> (time ((memoize fib) 35))
	;(time ((memoize fib) 35))
	; real 2.580
	; user 2.570
	; sys 0.000
	#<undef>
	gosh> (time ((memoize fib) 35))
	;(time ((memoize fib) 35))
	; real 2.438
	; user 2.430
	; sys 0.000
	#<undef>
	gosh>

view raw memoize-test.scm hosted with ❤ by GitHub

あれ、全然速くなっていない……。

考えてみれば当然で、手続きmemoizeは呼び出す度に新しくレキシカル環境を作ります。
と言う事は。cacheに保存される筈のハッシュテーブルは、手続きmemoizeが呼び出される度に新しくクロージャの中で作られて、そしてmemoizeの起動が終了する度にその寿命を全うするわけです。
従って、hash-table-getの返り値は毎度必ず#fになる、って事です。

これじゃあ意味無い。

んで、On Lispを良く見てみると、実は「敢えて」memoizeとそれが受け取る関数引数を合わせて大域環境に束縛しているんです。
これが手続きmemoizeの正しい使い方です。本に依ると、大域変数slowidに束縛されている以上、クロージャ、翻って使用されたハッシュテーブルが廃棄されません。

	gosh> (define slowid (memoize fib))
	slowid
	gosh> (time (slowid 35))
	;(time (slowid 35))
	; real 2.549
	; user 2.510
	; sys 0.000
	#<undef>
	gosh> (time (slowid 35))
	;(time (slowid 35))
	; real 0.000
	; user 0.000
	; sys 0.000
	14930352
	gosh>

view raw right-way-of-using-memoize.scm hosted with ❤ by GitHub

ご覧になれば分かるでしょうが、一回目の大域変数slowidに35を付けた時の呼び出しは遅いです。反面、クロージャ/ハッシュテーブルは依然と大域変数slowidに束縛されたまま、なんで、二回目の呼び出し時は高速なハッシュ検索により、時間が殆どかからず値を見つけ出している事が分かると思います。

これがmemoizeの使い方です。

Small-Lisp 実装を通して

感想文です。

まあ、前言った通り、

「Lispの実装をLispで行う？ネタ？それってオモロイのか？」

とか懐疑的だったんですけど。実際やってみると面白い(笑)。ハマりました(笑)。色んな意味ですけどね。

まあ、別に自分で0から考えて、ってわけじゃなくって、森北から出ているSchemeによる記号処理入門を見ながらやってたわけですけど。それで自分が気に入らないコーディングスタイルとか、あるいはこうだったら良いなあ、ってのを考えながら弄ってたわけですけれども。

でもマジに意外と面白かったです。ちょっとはSICPの第4章辺り読む自信付いたかな？

個人的には「こりゃ大変だ」とか思ったのがラムダ式(Small-Lispではfnと言う名前になってる)と=(Common Lispで言うsetf)の実装ですかね。あ、ifも大変だったな。中でもやっぱ一番大変だったのは=の実装ですかね。CLのsetfみたいな動作させたい、ってんで、CLでmacroexpandかけて調べてみたんですが、これが出てくるのがprimitiveであるrplacaとrplacdで。あんまこの二つ使った事が無いんで、Common Lisp 入門 (岩波コンピュータサイエンス)調べながら…と一番手間がかかりました。
結局、大域環境である*environment*をPLTのハッシュで実装してたんで、そこの内容をhash-set!で無理矢理書き換える、と。そう言う荒業を行って何とか解決。alistだったらこう上手くは行かなかったんだろうな。ハッシュテーブル様々です。

まあ、課題が多い実装なんですが。今思いつくトコをちょっとメモ。

1. ラムダ式のbodyに複数の式が置けない。


2. レキシカル・クロージャはどうやって実装する？


3. 一々quoteとか書きたくないんだけど、ショートカットである'の実装方法は？


4. マクロの実装方法は？

ってなトコですかね。
本の進み方によると、これはダイナミック・スコープにしかなり得ないと思うんで、そこの回避が謎ですね。まあ、この辺はSICP再挑戦して読んでみればわかるのかな？
quoteもみっともないですね。リーダマクロを実装すれば何とかなるのでしょうか。でもそこへ行くのが大変そう(笑)。
最後のマクロ実装。これは痛感しました。実は何を置いてもマクロを最初に実装しておくべきなのでは、と。
例えば、Small-Lispだとdefが特殊オペレータ扱いになってるんですよね。ところが、=とfnがあるんで、マクロさえあればその上に被せたレイヤー上に簡単に実装出来るわけです。マクロが無いからevalを直接弄って特殊オペレータとして実装しなきゃならない。これは無駄ですよね。
fnを実装している最中に「あ、これはマクロ書いてるっぽいな」とかちょっと思ったわけですけど、要するに直接evalを弄らずにショートカットできればいいのに。マクロは偉大です。自分でLispを実装してみるのがマクロ理解への一つの方策なのかもしれません。
が、マクロ実装を解説してあるような本ってあるんか(笑)。

その辺でcond実装するのも止めちゃったんだよね(笑)。マクロとifがあればcondなんてお茶の子さいさいで実装出来るのに。スカンタコ。

でもまあ、マジで面白いですよ。自分でプログラミング言語を曲りなりにも実装する、ってのは自信に繋がりますね。面白い。んで、ポール・グレアムのArcのコードも参考にしてたんですが、手探りでやってても色んな事が徐々に判ってくる。

ところで、CSの宿題で「LispでLispを実装しなきゃいけない」って言われて嫌々やってる人たちにちょっとヒントを。

applyとevalの仕事の区別なんて付けないで良い

いきなり怒られそうな事を書いてるんですけど(笑)。でも、やってみてここはそう思いました。
SICPなんかでは「Lispはevalとapplyの相互作用」とかエラソーな事書かれてたんですけど(笑)。実際、この辺は実装者のさじ加減でしょうね。
つまり、やりたけりゃ、特殊形式であるconsとか、特殊形式であるcarとかやってもいいわけです。「やっちゃいけない」ってワケじゃない。まあ、Lispのオーソドックスな実装上の流れから言ってevalとapplyに分けてる、って考えて良いでしょう。
一般には、次の役割がそれぞれあるわけですよ。

1. 特殊形式はeval内で実装する。


2. 基本関数はapply内で実装する。

これは要するに、REPLで打った時、引数にクオートが要らないのが前者、引数にクオートが必要になるのが後者、です。それだけ、なんです(笑)。マジな話で(笑)。
つまり、REPLで打った時に「引数いらねえ方が俺は好きだな」って場合は、堂々とeval内で実装しちゃいましょう(笑)。貴方のLispである以上、貴方の好みで良い筈です。それが例え「スチャラカな」実装だとしても。
実装形式上の話をすると、evalはexpressionを丸ごと一つとして受け取りますが、codeは分解された状態(function部とその引数部)でexpressionを受け取ります。このささいな違いがREPL上の引数の動作に影響を与える、のです。

メンド臭い実装はベースのLispに丸投げしちゃおう(笑)

これもそうですね。いくら「自分で実装する」とか言っても、基本的な関数で実装がメンド臭そうだったら、レイヤーの下で動いてるLispに丸投げするのも手、です。全部自分で造らなくても良い。もし、それが必要なら、アセンブリで実装する以上の事ってないわけですから。せっかくLispでLispを実装するんなら、余計な部分は下部で動いているLispに丸投げするのも手、です。恥ずかしがる必要はありません。
なお、ポール・グレアムのArcも読みながらやってたんですが、ポール・グレアムも面倒な部分は下部のPLTに丸投げしてました(笑)。Arcのソースコード内で逆引用符が使われているリストの部分は、どうやら下部のPLTに丸投げする為のハックの模様です。

caseを使いこなそう

どうも、あまりにもcondが優秀なのと、ミニマリズムのせいで、ついついSchemeでは存在が薄れがちなcaseですけど。ソースコードを短く、かつ、読みやすくする為にはcaseの多用が必要だ、と感じました。evalもapplyもコードが大きく成りかねないんで、それを避ける為には、

1. 手続きの分割


2. caseの多用

が肝です。
そもそも、Emacsの画面の半分以上を占めるようなコードを書くべきじゃない、と言う気がします。ショートカットになる為だったら色々と試してみるべきでしょう。同様に部分解が簡単に形成出来るんだったらdefine-syntax等のマクロも多用すべきだと思います。
Small-Lispだと、しょーもないマクロを3つ程作りましたが、それにより、コードの短縮化が可能になったんで、まあ良し、と思っています(もうちょっと上手く抽象化出来るかもしれない、って疑念もありますが)。

とまあ、感想文でした。
この続きはSICPに進むか、あるいはArcのソースをCLに移植するか。ちょっと楽しくなってきました。

Small-Lisp Ver.1.3

	#!/usr/bin/env bash
	mzscheme slisp.ss

view raw slisp hosted with ❤ by GitHub

	;; mzscheme slisp.ss
	#lang scheme
	(require "small-lisp-ver.1.3.ss")
	(slisp-load "slisp.slisp")
	(slisp)

view raw slisp.ss hosted with ❤ by GitHub

	;; Small-Lisp, based on the textbook "Schemeによる記号処理入門",
	;; implements now 15 Lisp functions such as null?, 1st, 2nd, 3rd, rst,
	;; cons, atom?, is?, +, -, *, /, >, < and fn as primitives.
	;; Version.1.3 has three special operators, if, = and def, which are all
	;; inspired by Paul Graham's Arc. = is setf of CL. def is defun of CL.
	;; Renamed some operators, because I like schemers' way better.
	;; Now Small-Lisp has a file-loading function, slisp-load, then it can
	;; load and evaluate some function-definition files, that define non-primitive
	;; functions defined in Small-Lisp style. "slisp.slisp" provides some functions
	;; such as car, cdr, cadr, caddr, last, append, length, and factorial, all built
	;; on Small-Lisp's primitives.
	;; Redefined some structures by using PLT's hashtables, instead
	;; of using a-lists; therefore, these codes here are heavily
	;; dependent on PLT Scheme.
	;; In addition, REPL is now more CL-like, and true/false is T/NIL, with upper-case.
	(module small-lisp-ver.1.3 scheme
	(provide (all-defined-out))
	;; (s-assoc 'a #hasheq((a . (1 2 3)) (b . 2))) ==> (1 2 3)
	(define (s-assoc x y)
	(hash-ref y x (lambda ()
	(error-message x)
	'())))
	(define (error-message x)
	(for-each display
	`(" **** Unknown expression : " ,x "\n")))
	;; eval 方面
	(define (atom? x)
	(not (pair? x)))
	(define (s-eval exp env)
	(if (atom? exp)
	(s-number? exp env)
	(let ((key (car exp)) (body (cdr exp)))
	(case key
	((if) (eval-if body env))
	((=) (eval-= body env))
	((def) (eval-def body env))
	((quote) (car body))
	(else (s-apply key
	(eval-args body env) env))))))
	;; (eval-args '(a b) #hasheq((a . 3) (b . 4))) ==> (3 4)
	(define (eval-args exp env)
	(map (lambda (x)
	(s-eval x env)) exp))
	(define-syntax s-assoc-helper
	(syntax-rules ()
	((_ exp env pred? proc)
	(let ((it (pred? exp)))
	(if it
	(s-assoc (not it) env)
	(proc exp))))))
	(define (s-number? exp env)
	(if (number? exp)
	exp
	(s-assoc exp env)))
	;; (define ht (make-hasheq))
	;; (hash-set! ht #t 'T)
	;; (hash-set! ht #f '())
	;; (hash-set! ht 'x '(1 2 3))
	;; (eval-if '((atom x) x (1st x)) ht) ==> 1
	;;
	(define (eval-if con env)
	(s-assoc-helper con env null?
	(lambda (x)
	(let ((head (car x)) (tail (cdr x)))
	(let ((eval-head (s-eval head env)))
	(cond ((null? tail) eval-head)
	((not (eq? '() eval-head)) (s-eval (car tail) env))
	(else (eval-if (cdr tail) env))))))))
	(define (eval-= exp env)
	(let ((head (car exp)) (val (s-eval (cadr exp) env)))
	(if (atom? head)
	(begin (hash-set! env head val) val)
	(let ((key (cadr head)))
	(let ((var (s-assoc key env)))
	(case (car head)
	((car) (hash-set! env key
	(cons val (cdr var)))
	(s-assoc key env))
	((cdr) (hash-set! env key
	(cons (car var)
	(if (pair? val)
	val
	`(,val))))
	(s-assoc key env))
	(else (error-message exp))))))))
	(define (eval-def exp env)
	(let ((name (car exp))
	(args (cadr exp))
	(body (third exp)))
	(hash-set! env name `(fn ,args ,body))
	name))
	;; apply 方面
	(define (s-null? foo env)
	(s-eval (null? foo) env))
	;; (s-atom? 4) ==> t
	(define (s-atom? foo env)
	(s-eval (not (pair? foo)) env))
	;; (s-is? 1 1) ==> t
	(define (s-is? foo bar env)
	(s-eval (eq? foo bar) env))
	(define-syntax operator-generator
	(syntax-rules ()
	((_ name foo bar acc pred? proc)
	(cond ((pred? foo)
	acc)
	((pred? bar)
	foo)
	(else
	(name (proc foo (car bar)) (cdr bar)))))))
	(define (s-+ foo bar)
	(operator-generator s-+ foo bar 0 null? +))
	(define (s-- foo bar)
	(operator-generator s-- foo bar 0 null? -))
	(define (s-* foo bar)
	(operator-generator s-* foo bar 1 null? *))
	(define (s-/ foo bar)
	(operator-generator s-/ foo bar 1 null? /))
	(define-syntax compare-helper
	(syntax-rules ()
	((_ name foo bar env pred? proc)
	(cond ((pred? foo)
	(error-message foo))
	((pred? bar)
	(s-assoc #t env))
	(else
	(let ((head (car bar)))
	(if (not (proc foo head))
	(s-assoc (proc foo head) env)
	(name head (cdr bar) env))))))))
	(define (s-> foo bar env)
	(compare-helper s-> foo bar env null? >))
	(define (s-< foo bar env)
	(compare-helper s-< foo bar env null? <))
	(define (s-apply func args env)
	(cond
	((null? func)
	(error-message args))
	((pair? func)
	(s-fn? func args env))
	(else
	(let ((head (s-assoc-helper args env null? car))
	(tail (s-assoc-helper args env null? cdr)))
	(let ((head-of-tail (s-assoc-helper tail env null? car)))
	;; 基本関数の処理
	(case func
	((null?) (s-null? head env))
	((1st) (s-assoc-helper head env null? car))
	((2nd) (s-assoc-helper head env (lambda (x) (< (length x) 2)) cadr))
	((3rd) (s-assoc-helper head env (lambda (x) (< (length x) 3)) caddr))
	((rst) (s-assoc-helper head env null? cdr))
	((cons) (cons head head-of-tail))
	((atom?) (s-atom? head env))
	((is?) (s-is? head head-of-tail env))
	((+) (s-+ head tail))
	((-) (s-- head tail))
	((*) (s-* head tail))
	((/) (s-/ head tail))
	((>) (s-> head tail env))
	((<) (s-< head tail env))
	;; 基本関数以外の関数に対する評価
	(else (s-apply (s-eval func env) args env))))))))
	;; lambda式の処理
	(define (s-fn? func args env)
	(if (eq? (car func) 'fn)
	(s-eval (third func)
	(pairlis->hash (cadr func) args env))
	(error-message args)))
	;; REPL
	;; プロンプトの表示とS式の読み込み
	(define (prompt)
	(begin (display "SL-USER> ")
	(read)))
	(define *version* "Small-Lisp Ver.1.3\n")
	(define (slisp)
	(define (loop exp)
	(if (and (list? exp) ;終了条件のチェック
	(memv (car exp)
	'(bye quit end exit)))
	'GOOD-BYE
	(let ((c (begin (display (null-environment? exp *environment*))
	(newline))))
	(loop (prompt)))))
	(display *version*)
	(init-environment) ;環境の初期設定
	(loop (prompt))) ;プロンプトの表示/S式の読み込み
	(define *environment* (make-hasheq)) ;大域変数の宣言
	(define (init-environment) ;環境の初期設定
	(hash-set! *environment* #t 't)
	(hash-set! *environment* #f '()))
	;; (define ht (make-hasheq))
	;; (hash-set! ht 'foo 3)
	;; (pairlis->hash '(i j k) '(a b c) ht) ==> #hasheq((foo . 3) (k . c) (j . b) (i . a))
	;; (define ht2 (make-hasheq))
	;; (pairlis->hash '(a b) '(1 2) ht2) ==> #hasheq((b . 2) (a . 1))
	;;
	(define (pairlis->hash x y z)
	(cond ((or (null? x) (null? y)) z)
	(else (hash-set! z (car x) (car y))
	(pairlis->hash (cdr x) (cdr y) z))))
	(define (null-environment? exp env)
	(let ((it (s-eval exp env)))
	(if (null? it)
	'NIL
	(capital-symbol it))))
	(define (capital-symbol exp)
	(cond ((symbol? exp)
	(string->symbol (string-upcase (symbol->string exp))))
	((list? exp)
	(map capital-symbol exp))
	(else
	exp)))
	;; 外部ライブラリのロード用手続き
	(define (slisp-load filename)
	(letrec ((s-load
	(lambda (p)
	(let ((x (read p)))
	(cond ((eof-object? x)
	(close-input-port p))
	(else
	(s-eval x *environment*)
	(s-load p)))))))
	(call-with-input-file filename s-load)))
	)

view raw small-lisp-ver.1.3.ss hosted with ❤ by GitHub

	;; basic Small-Lisp functions
	(def car (lst)
	(1st lst))
	(def cdr (lst)
	(rst lst))
	(def cadr (lst)
	(2nd lst))
	(def caddr (lst)
	(3rd lst))
	(def last (a)
	(if (null? (rst a))
	a
	(last (rst a))))
	(def append (x y)
	(if (null? x)
	y
	(cons (1st x) (append (rst x) y))))
	(def len (x)
	(len-aux x 0))
	(def len-aux (x acc)
	(if (null? x)
	acc
	(len-aux (rst x) (+ 1 acc))))
	(def factorial (x)
	(fact-aux x 1))
	(def fact-aux (x acc)
	(if (< x 1)
	acc
	(fact-aux (- x 1) (* x acc))))

view raw slisp.slisp hosted with ❤ by GitHub

Small-Lisp Ver.1.2

	#!/usr/bin/env bash
	mzscheme slisp.ss

view raw slisp hosted with ❤ by GitHub

	;; mzscheme slisp.ss
	#lang scheme
	(require "small-lisp-ver.1.2.ss")
	(slisp)

view raw slisp.ss hosted with ❤ by GitHub

	;; Small-Lisp, based on the textbook "Schemeによる記号処理入門",
	;; implements only 5 basic Lisp functions such as 1st, rst,
	;; cons, atom?, and is?. Also it has fn, the lambda expression
	;; as a primitive.
	;; Version.1.2 has three special operators, if, = and def, which are
	;; inspired by Paul Graham's Arc. = is setf of CL. def if defun of CL.
	;; Rename some operators, because I like schemers' way better.
	;; Redefined some structures by using PLT's hashtables, instead
	;; of using a-lists; therefore, these codes here are heavily
	;; dependent on PLT Scheme.
	;; In addition, REPL is now more CL-like, and true/false is T/NIL, with upper-case.
	(module small-lisp-ver.1.2 scheme
	(provide (all-defined-out))
	;; (s-assoc 'a #hasheq((a . (1 2 3)) (b . 2))) ==> (1 2 3)
	(define (s-assoc x y)
	(hash-ref y x (lambda ()
	(error-message x)
	'())))
	(define (error-message x)
	(for-each display
	`(" **** Unknown expression : " ,x "\n")))
	(define (atom? x)
	(not (pair? x)))
	(define (s-eval exp env)
	(cond ((atom? exp)
	(s-number? exp env))
	((eq? (car exp) 'if)
	(eval-if (cdr exp) env))
	((eq? (car exp) '=)
	(eval-= (cdr exp) env))
	((eq? (car exp) 'def)
	(eval-def (cdr exp) env))
	((eq? (car exp) 'quote)
	(cadr exp))
	(else (s-apply (car exp)
	(eval-args (cdr exp) env) env))))
	;; (eval-args '(a b) #hasheq((a . 3) (b . 4))) ==> (3 4)
	(define (eval-args exp env)
	(map (lambda (x)
	(s-eval x env)) exp))
	(define-syntax s-assoc-helper
	(syntax-rules ()
	((_ exp env proc)
	(let ((it (null? exp)))
	(if it
	(s-assoc (not it) env)
	(proc exp))))))
	(define (s-number? exp env)
	(if (number? exp)
	exp
	(s-assoc exp env)))
	;; (define ht (make-hasheq))
	;; (hash-set! ht #t 'T)
	;; (hash-set! ht #f '())
	;; (hash-set! ht 'x '(1 2 3))
	;; (eval-if '((atom x) x (1st x)) ht) ==> 1
	;;
	(define (eval-if con env)
	(s-assoc-helper con env
	(lambda (x)
	(let ((head (car x)) (tail (cdr x)))
	(let ((eval-head (s-eval head env)))
	(cond ((null? tail) eval-head)
	((not (eq? '() eval-head)) (s-eval (car tail) env))
	(else (eval-if (cdr tail) env))))))))
	(define (eval-= exp env)
	(let ((head (car exp)) (val (s-eval (cadr exp) env)))
	(if (atom? head)
	(begin (hash-set! env head val) val)
	(let ((key (cadr head)))
	(let ((var (s-assoc key env)))
	(case (car head)
	((car) (hash-set! env key
	(cons val (cdr var)))
	(s-assoc key env))
	((cdr) (hash-set! env key
	(cons (car var)
	(if (pair? val)
	val
	`(,val))))
	(s-assoc key env))
	(else (error-message exp))))))))
	(define (eval-def exp env)
	(let ((name (car exp))
	(args (cadr exp))
	(body (third exp)))
	(hash-set! env name `(fn ,args ,body))
	name))
	;; (s-atom? 4) ==> t
	(define (s-atom? foo env)
	(s-eval (not (pair? foo)) env))
	;; (s-is? 1 1) ==> t
	(define (s-is? foo bar env)
	(s-eval (eq? foo bar) env))
	(define (s-apply func args env)
	(cond
	((null? func)
	(error-message args))
	((pair? func)
	(s-fn? func args env))
	(else
	(let ((head (car args)) (tail (cdr args)))
	(let ((head-of-tail (s-assoc-helper tail env car)))
	;; 基本関数の処理
	(case func
	((1st) (s-assoc-helper head env car))
	((rst) (s-assoc-helper head env cdr))
	((cons) (cons head head-of-tail))
	((atom?) (s-atom? head env))
	((is?) (s-is? head head-of-tail env))
	;; 基本関数以外の関数に対する評価
	(else (s-apply (s-eval func env) args env))))))))
	;; lambda式の処理
	(define (s-fn? func args env)
	(if (eq? (car func) 'fn)
	(s-eval (third func)
	(pairlis->hash (cadr func) args env))
	(error-message args)))
	;; プロンプトの表示とS式の読み込み
	(define (prompt) (begin (display "SL-USER> ") (read)))
	(define *version* "Small-Lisp Ver.1.2\n")
	(define (slisp)
	(define (loop exp)
	(if (and (list? exp) ;終了条件のチェック
	(memv (car exp)
	'(bye quit end exit)))
	'GOOD-BYE
	(let ((c (begin (display (null-environment? exp *environment*))
	(newline))))
	(loop (prompt)))))
	(display *version*)
	(init-environment) ;環境の初期設定
	(loop (prompt))) ;プロンプトの表示/S式の読み込み
	(define *environment* (make-hasheq)) ;大域変数の宣言
	(define (init-environment) ;環境の初期設定
	(hash-set! *environment* #t 't)
	(hash-set! *environment* #f '()))
	;; (define ht (make-hasheq))
	;; (hash-set! ht 'foo 3)
	;; (pairlis->hash '(i j k) '(a b c) ht) ==> #hasheq((foo . 3) (k . c) (j . b) (i . a))
	;; (define ht2 (make-hasheq))
	;; (pairlis->hash '(a b) '(1 2) ht2) ==> #hasheq((b . 2) (a . 1))
	;;
	(define (pairlis->hash x y z)
	(cond ((or (null? x) (null? y)) z)
	(else (hash-set! z (car x) (car y))
	(pairlis->hash (cdr x) (cdr y) z))))
	(define (null-environment? exp env)
	(let ((it (s-eval exp env)))
	(if (null? it)
	'NIL
	(capital-symbol it))))
	(define (capital-symbol exp)
	(cond ((symbol? exp)
	(string->symbol (string-upcase (symbol->string exp))))
	((list? exp)
	(map capital-symbol exp))
	(else
	exp)))
	)

view raw small-lisp-ver.1.2.ss hosted with ❤ by GitHub

実行例:

	/home/cametan $ ./slisp
	Small-Lisp Ver.1.2
	SL-USER> (= x (quote (1 2 3)))
	(1 2 3)
	SL-USER> x
	(1 2 3)
	SL-USER> (rst x)
	(2 3)
	SL-USER> (cons (quote a) x)
	(A 1 2 3)
	SL-USER> x
	(1 2 3)
	SL-USER> (= (car x) (quote a))
	(A 2 3)
	SL-USER> (= (cdr x) (quote (b c)))
	(A B C)
	SL-USER> (def car (lst) (1st lst))
	CAR
	SL-USER> (car x)
	A
	SL-USER> (def 2nd (lst) (car (rst lst)))
	2ND
	SL-USER> (2nd x)
	B
	SL-USER> (2nd (quote ()))
	NIL
	SL-USER> (bye)
	GOOD-BYE
	/home/cametan $

view raw test.lisp hosted with ❤ by GitHub

Google 日本語入力 on Ubuntu 登場！ その名もMozc

もずくが美味しい季節がそろそろやってきますね。

待ち焦がれたGoogle日本語入力オープンソース版、その名もMozc。なかなか良いですよ。
ビルドが必要ですが、解説通りにやっておきゃまあOKです。
っつーか事実上、端末上へのコピペだよな（笑)。

解説は次のページで。

mozc

結構ビルドに時間かかるんですけどね。
Debian/Ubuntuユーザーは、Compilation飛ばして最後のBuild and install debian packageに飛んでください。CompilationはDebian/Ubuntuユーザー以外へのインストラクションなんで。

それと、多分、インストールしただけではiBusに認識されないと思います。認識させるには再起動かける必要があるのではないでしょうか。

Small-Lisp Ver.1.1

	#!/usr/bin/env bash
	mzscheme slisp.ss

view raw slisp hosted with ❤ by GitHub

	;; mzscheme slisp.ss
	#lang scheme
	(require "small-lisp-ver.1.1.ss")
	(slisp)

view raw slisp.ss hosted with ❤ by GitHub

	;; Small-Lisp, based on the textbook "Schemeによる記号処理入門",
	;; implements only 5 basic Lisp functions such as 1st, rst,
	;; cons, atom, and eq.
	;; Version.1.1 also implements a special operator if, which is
	;; inspired by if of Paul Graham's Arc, and fn, that is
	;; the lambda expression.
	;; Redefined some structures by using PLT's hashtables, instead
	;; of using a-lists; therefore, these codes here are heavily
	;; dependent on PLT Scheme.
	;; In addition, REPL is now more CL-like, and true/false is T/NIL, with upper-case.
	(module small-lisp-ver.1.1 scheme
	(provide (all-defined-out))
	;; (s-assoc 'a #hasheq((a . (1 2 3)) (b . 2))) ==> (1 2 3)
	(define (s-assoc x y)
	(hash-ref y x (lambda ()
	(error-message x)
	'())))
	(define (error-message x)
	(for-each display
	`(" **** Unknown expression : " ,x "\n")))
	(define (atom? x)
	(not (pair? x)))
	(define (s-eval exp env)
	(cond ((atom? exp)
	(s-number? exp env))
	((eq? (car exp) 'if)
	(eval-if (cdr exp) env))
	((eq? (car exp) 'quote)
	(cadr exp))
	(else (s-apply (car exp)
	(eval-args (cdr exp) env) env))))
	(define (s-number? exp env)
	(if (number? exp)
	exp
	(s-assoc exp env)))
	;; (eval-args '(a b) #hasheq((a . 3) (b . 4))) ==> (3 4)
	(define (eval-args exp env)
	(map (lambda (x)
	(s-eval x env)) exp))
	;; (s-atom? 4) ==> t
	(define (s-atom? foo env)
	(s-assoc (not (pair? foo)) env))
	;; (s-eq? 1 1) ==> t
	(define (s-eq? foo bar env)
	(s-assoc (eq? foo bar) env))
	(define-syntax s-assoc-helper
	(syntax-rules ()
	((_ exp env proc)
	(let ((it (null? exp)))
	(if it
	(s-assoc (not it) env)
	(proc exp))))))
	(define (s-apply func args env)
	(cond
	((null? func)
	(error-message args))
	((pair? func)
	(s-fn? func args env))
	(else
	(let ((head (car args)) (tail (cdr args)))
	(let ((head-of-tail (s-assoc-helper tail env car)))
	;; 基本関数の処理
	(case func
	((1st) (s-assoc-helper head env car))
	((rst) (s-assoc-helper head env cdr))
	((cons) (cons head head-of-tail))
	((atom) (s-atom? head env))
	((eq) (s-eq? head head-of-tail env))
	;; 基本関数以外の関数に対する評価
	(else (s-apply (s-eval func env) args env))))))))
	;; lambda式の処理
	(define (s-fn? func args env)
	(if (eq? (car func) 'fn)
	(s-eval (third func)
	(pairlis->hash (cadr func) args env))
	(error-message args)))
	;; プロンプトの表示とS式の読み込み
	(define (prompt) (begin (display "SL-USER> ") (read)))
	(define *version* "Small-Lisp Ver.1.1\n")
	(define (slisp)
	(define (loop exp)
	(if (and (list? exp) ;終了条件のチェック
	(memv (car exp)
	'(bye quit end exit)))
	'GOOD-BYE
	(let ((c (begin (display (s-eval exp *environment*))
	(newline))))
	(loop (prompt)))))
	(display *version*)
	(init-environment) ;環境の初期設定
	(loop (prompt))) ;プロンプトの表示/S式の読み込み
	(define *environment* (make-hasheq)) ;大域変数の宣言
	(define (init-environment) ;環境の初期設定
	(hash-set! *environment* #t 'T)
	(hash-set! *environment* #f 'NIL))
	;; (define ht (make-hasheq))
	;; (hash-set! ht 'foo 3)
	;; (pairlis->hash '(i j k) '(a b c) ht) ==> #hasheq((foo . 3) (k . c) (j . b) (i . a))
	;; (define ht2 (make-hasheq))
	;; (pairlis->hash '(a b) '(1 2) ht2) ==> #hasheq((b . 2) (a . 1))
	;;
	(define (pairlis->hash x y z)
	(cond ((or (null? x) (null? y)) z)
	(else (hash-set! z (car x) (car y))
	(pairlis->hash (cdr x) (cdr y) z))))
	;; (define ht (make-hasheq))
	;; (hash-set! ht #t 'T)
	;; (hash-set! ht #f 'NIL)
	;; (hash-set! ht 'x '(1 2 3))
	;; (eval-if '((atom x) x (1st x)) ht) ==> 1
	;;
	(define (eval-if con env)
	(s-assoc-helper con env
	(lambda (x)
	(let ((head (car x)) (tail (cdr x)))
	(let ((eval-head (s-eval head env)))
	(cond ((null? tail) eval-head)
	((not (eq? 'NIL eval-head)) (s-eval (car tail) env))
	(else (eval-if (cdr tail) env))))))))
	)

view raw small-lisp-ver.1.1.ss hosted with ❤ by GitHub

実行例:

	/home/cametan $ ./slisp
	Small-Lisp Ver.1.1
	SL-USER> ((fn (x) (if (atom x) x (rst x))) 100)
	100
	SL-USER> ((fn (x) (if (atom x) x (rst x))) (quote (1 2 3)))
	(2 3)
	SL-USER> (bye)
	GOOD-BYE
	/home/cametan $

view raw test.lisp hosted with ❤ by GitHub

Small-Lisp Ver.1.0

	#!/usr/bin/env bash
	mzscheme slisp.ss

view raw slisp hosted with ❤ by GitHub

	;; mzscheme slisp.ss
	#lang scheme
	(require "small-lisp-ver.1.0.ss")
	(slisp)

view raw slisp.ss hosted with ❤ by GitHub

	;; Small-Lisp, based on the textbook "Schemeによる記号処理入門",
	;; implements only 5 basic Lisp functions such as 1st, rst,
	;; cons, atom, and eq.
	;; Redefined some structures by using PLT's hashtables, instead
	;; of using a-lists; therefore, these codes here are heavily
	;; dependent on PLT Scheme.
	;; In addition, REPL is now more CL-like, and true/false is T/NIL, with upper-case.
	;; 1st and rst acts like CL; that is, (1st (quote ())) => NIL,
	;; and (rst (quote ())) => NIL
	(module small-lisp-ver.1.0 scheme
	(provide (all-defined-out))
	;; (s-assoc 'a #hasheq((a . (1 2 3)) (b . 2))) ==> (1 2 3)
	(define (s-assoc x y)
	(hash-ref y x (lambda ()
	(error-message x)
	'())))
	(define (error-message x)
	(for-each display
	`(" **** Unknown expression : " ,x "\n")))
	(define (atom? x)
	(not (pair? x)))
	(define (s-eval exp env)
	(cond ((atom? exp)
	(s-number? exp env))
	((eq? (car exp) 'quote)
	(cadr exp))
	(else (s-apply (car exp)
	(eval-args (cdr exp) env) env))))
	(define (s-number? exp env)
	(if (number? exp)
	exp
	(s-assoc exp env)))
	;; (eval-args '(a b) #hasheq((a . 3) (b . 4))) ==> (3 4)
	(define (eval-args exp env)
	(map (lambda (x)
	(s-eval x env)) exp))
	;; (s-atom? 4) ==> t
	(define (s-atom? foo env)
	(s-assoc (not (pair? foo)) env))
	;; (s-eq? 1 1) ==> t
	(define (s-eq? foo bar env)
	(s-assoc (eq? foo bar) env))
	(define-syntax s-assoc-helper
	(syntax-rules ()
	((_ proc exp env)
	(let ((it (null? exp)))
	(if it
	(s-assoc (not it) env)
	(proc exp))))))
	(define (s-apply func args env)
	(if (or (pair? func) (null? func))
	(error-message args)
	(let ((head (car args)) (tail (cdr args)))
	(let ((head-of-tail (s-assoc-helper car tail env)))
	;; 基本関数の処理
	(case func
	((1st) (s-assoc-helper car head env))
	((rst) (s-assoc-helper cdr head env))
	((cons) (cons head head-of-tail))
	((atom) (s-atom? head env))
	((eq) (s-eq? head head-of-tail env))
	;; 基本関数以外の関数に対する評価
	(else (s-apply (s-eval func env) args env)))))))
	;; プロンプトの表示とS式の読み込み
	(define (prompt) (begin (display "SL-USER> ") (read)))
	(define *version* "Small-Lisp Ver.1.0\n")
	(define (slisp)
	(define (loop exp)
	(if (and (list? exp) ;終了条件のチェック
	(memq (car exp)
	'(bye quit end exit)))
	'GOOD-BYE
	(let ((c (begin (display (s-eval exp *environment*))
	(newline))))
	(loop (prompt)))))
	(display *version*)
	(init-environment) ;環境の初期設定
	(loop (prompt))) ;プロンプトの表示/S式の読み込み
	(define *environment* (make-hasheq)) ;大域変数の宣言
	(define (init-environment) ;環境の初期設定
	(hash-set! *environment* #t 'T)
	(hash-set! *environment* #f 'NIL))
	)

view raw small-lisp-ver.1.0.ss hosted with ❤ by GitHub

実行例:

	cametan-laptop% ./slisp
	Small-Lisp Ver.1.0
	SL-USER> 1
	1
	SL-USER> (1st (quote (foo baz)))
	foo
	SL-USER> (rst (quote (foo baz)))
	(baz)
	SL-USER> (eq (quote (foo baz)) (quote (1 2)))
	NIL
	SL-USER> (atom (quote foo))
	T
	SL-USER> (atom (quote (1 2 3)))
	NIL
	SL-USER> (bye)
	GOOD-BYE
	cametan-laptop%

view raw test.lisp hosted with ❤ by GitHub

Arc のソース閲覧

@valvallowさんが

Lisp 系の書籍は、このネタ多いなー（笑）

とか記述していて、全くです、よね(笑)。

この辺のLisp on Lispと言うネタは散見してるんですが、実際僕もそんなにマジメにやった事がないです。マズいんでしょうけどね(笑)。
理由はいくつかあるんですけど、

• プログラムを作りたいんであってプログラミング言語を作りたいわけじゃない


• そもそも、それで作って効率的なの?

と言うのが大きな理由でしょうか。例えば、自分でマジメにLisp処理系をLisp上で書いて、それで果たして愛用出来るようなものになるんか、とか。単なるCSの宿題のネタじゃなかろうか、とか。マジメにLisp処理系を作ってる人はやっぱりCとかで書いてるんだろ?と。LispでLispを書くのが面白くて実用的であれば、ブートストラッピング的にこの世はLispで書かれたLisp処理系で溢れてるんじゃなかろうか、とかね。色々謎がある。

現存するLispで「Lispで書かれたLisp」としては、ポール・グレアムのArcがあります。他の言語で書かれたソースだと読めない可能性もある、んですが、一方、Schemeやってる層だったら比較的読みやすいのでは、と。CS的な意味で言っても、非常にオーソドックスな教科書的なコードなんじゃないのかな、って気がちょっとしますね。

いずれ、このソースを楽々読みこなせるようになりたいもの、です。

	; mzscheme -m -f as.scm
	; (tl)
	; (asv)
	; http://localhost:8080
	(require mzscheme) ; promise we won't redefine mzscheme bindings
	(require "ac.scm")
	(require "brackets.scm")
	(use-bracket-readtable)
	(aload "arc.arc")
	(aload "libs.arc")
	(tl)

view raw as.scm hosted with ❤ by GitHub

	; Arc Compiler.
	(module ac mzscheme
	(provide (all-defined))
	; uncomment the following require for mzscheme-4.x
	; much of Arc will work, but not mutable pairs.
	; (require rnrs/mutable-pairs-6)
	(require (lib "port.ss"))
	(require (lib "process.ss"))
	(require (lib "pretty.ss"))
	; compile an Arc expression into a Scheme expression,
	; both represented as s-expressions.
	; env is a list of lexically bound variables, which we
	; need in order to decide whether set should create a global.
	(define (ac s env)
	(cond ((string? s) (ac-string s env))
	((literal? s) s)
	((eqv? s 'nil) (list 'quote 'nil))
	((ssyntax? s) (ac (expand-ssyntax s) env))
	((symbol? s) (ac-var-ref s env))
	((ssyntax? (xcar s)) (ac (cons (expand-ssyntax (car s)) (cdr s)) env))
	((eq? (xcar s) 'quote) (list 'quote (ac-niltree (cadr s))))
	((eq? (xcar s) 'quasiquote) (ac-qq (cadr s) env))
	((eq? (xcar s) 'if) (ac-if (cdr s) env))
	((eq? (xcar s) 'fn) (ac-fn (cadr s) (cddr s) env))
	((eq? (xcar s) 'assign) (ac-set (cdr s) env))
	; the next three clauses could be removed without changing semantics
	; ... except that they work for macros (so prob should do this for
	; every elt of s, not just the car)
	((eq? (xcar (xcar s)) 'compose) (ac (decompose (cdar s) (cdr s)) env))
	((eq? (xcar (xcar s)) 'complement)
	(ac (list 'no (cons (cadar s) (cdr s))) env))
	((eq? (xcar (xcar s)) 'andf) (ac-andf s env))
	((pair? s) (ac-call (car s) (cdr s) env))
	(#t (err "Bad object in expression" s))))
	(define atstrings #f)
	(define (ac-string s env)
	(if atstrings
	(if (atpos s 0)
	(ac (cons 'string (map (lambda (x)
	(if (string? x)
	(unescape-ats x)
	x))
	(codestring s)))
	env)
	(unescape-ats s))
	(string-copy s))) ; avoid immutable strings
	(define (literal? x)
	(or (boolean? x)
	(char? x)
	(string? x)
	(number? x)
	(eq? x '())))
	(define (ssyntax? x)
	(and (symbol? x)
	(not (or (eqv? x '+) (eqv? x '++) (eqv? x '_)))
	(let ((name (symbol->string x)))
	(has-ssyntax-char? name (- (string-length name) 1)))))
	(define (has-ssyntax-char? string i)
	(and (>= i 0)
	(or (let ((c (string-ref string i)))
	(or (eqv? c #\:) (eqv? c #\~)
	(eqv? c #\+)
	;(eqv? c #\_)
	(eqv? c #\.) (eqv? c #\!)))
	(has-ssyntax-char? string (- i 1)))))
	(define (read-from-string str)
	(let ((port (open-input-string str)))
	(let ((val (read port)))
	(close-input-port port)
	val)))
	; Though graphically the right choice, can't use _ for currying
	; because then _!foo becomes a function. Maybe use <>. For now
	; leave this off and see how often it would have been useful.
	; Might want to make ~ have less precedence than +, because
	; ~foo+bar prob should mean (andf (complement foo) bar), not
	; (complement (andf foo bar)).
	(define (expand-ssyntax sym)
	((cond ((or (insym? #\: sym) (insym? #\~ sym)) expand-compose)
	((insym? #\+ sym) expand-and)
	; ((insym? #\_ sym) expand-curry)
	((or (insym? #\. sym) (insym? #\! sym)) expand-sexpr)
	(#t (error "Unknown ssyntax" sym)))
	sym))
	(define (expand-compose sym)
	(let ((elts (map (lambda (tok)
	(if (eqv? (car tok) #\~)
	(if (null? (cdr tok))
	'no
	`(complement ,(chars->value (cdr tok))))
	(chars->value tok)))
	(tokens (lambda (c) (eqv? c #\:))
	(symbol->chars sym)
	'()
	'()
	#f))))
	(if (null? (cdr elts))
	(car elts)
	(cons 'compose elts))))
	(define (expand-and sym)
	(let ((elts (map chars->value
	(tokens (lambda (c) (eqv? c #\+))
	(symbol->chars sym)
	'()
	'()
	#f))))
	(if (null? (cdr elts))
	(car elts)
	(cons 'andf elts))))
	; How to include quoted arguments? Can't treat all as quoted, because
	; never want to quote fn given as first. Do we want to allow quote chars
	; within symbols? Could be ugly.
	; If release, fix the fact that this simply uses v0... as vars. Should
	; make these vars gensyms.
	(define (expand-curry sym)
	(let ((expr (exc (map (lambda (x)
	(if (pair? x) (chars->value x) x))
	(tokens (lambda (c) (eqv? c #\_))
	(symbol->chars sym)
	'()
	'()
	#t))
	0)))
	(list 'fn
	(keep (lambda (s)
	(and (symbol? s)
	(eqv? (string-ref (symbol->string s) 0)
	#\v)))
	expr)
	expr)))
	(define (keep f xs)
	(cond ((null? xs) '())
	((f (car xs)) (cons (car xs) (keep f (cdr xs))))
	(#t (keep f (cdr xs)))))
	(define (exc elts n)
	(cond ((null? elts)
	'())
	((eqv? (car elts) #\_)
	(cons (string->symbol (string-append "v" (number->string n)))
	(exc (cdr elts) (+ n 1))))
	(#t
	(cons (car elts) (exc (cdr elts) n)))))
	(define (expand-sexpr sym)
	(build-sexpr (reverse (tokens (lambda (c) (or (eqv? c #\.) (eqv? c #\!)))
	(symbol->chars sym)
	'()
	'()
	#t))
	sym))
	(define (build-sexpr toks orig)
	(cond ((null? toks)
	'get)
	((null? (cdr toks))
	(chars->value (car toks)))
	(#t
	(list (build-sexpr (cddr toks) orig)
	(if (eqv? (cadr toks) #\!)
	(list 'quote (chars->value (car toks)))
	(if (or (eqv? (car toks) #\.) (eqv? (car toks) #\!))
	(err "Bad ssyntax" orig)
	(chars->value (car toks))))))))
	(define (insym? char sym) (member char (symbol->chars sym)))
	(define (symbol->chars x) (string->list (symbol->string x)))
	(define (chars->value chars) (read-from-string (list->string chars)))
	(define (tokens test source token acc keepsep?)
	(cond ((null? source)
	(reverse (if (pair? token)
	(cons (reverse token) acc)
	acc)))
	((test (car source))
	(tokens test
	(cdr source)
	'()
	(let ((rec (if (null? token)
	acc
	(cons (reverse token) acc))))
	(if keepsep?
	(cons (car source) rec)
	rec))
	keepsep?))
	(#t
	(tokens test
	(cdr source)
	(cons (car source) token)
	acc
	keepsep?))))
	(define (ac-global-name s)
	(string->symbol (string-append "_" (symbol->string s))))
	(define (ac-var-ref s env)
	(if (lex? s env)
	s
	(ac-global-name s)))
	; quasiquote
	(define (ac-qq args env)
	(list 'quasiquote (ac-qq1 1 args env)))
	; process the argument of a quasiquote. keep track of
	; depth of nesting. handle unquote only at top level (level = 1).
	; complete form, e.g. x or (fn x) or (unquote (fn x))
	(define (ac-qq1 level x env)
	(cond ((= level 0)
	(ac x env))
	((and (pair? x) (eqv? (car x) 'unquote))
	(list 'unquote (ac-qq1 (- level 1) (cadr x) env)))
	((and (pair? x) (eqv? (car x) 'unquote-splicing) (= level 1))
	(list 'unquote-splicing
	(list 'ar-nil-terminate (ac-qq1 (- level 1) (cadr x) env))))
	((and (pair? x) (eqv? (car x) 'quasiquote))
	(list 'quasiquote (ac-qq1 (+ level 1) (cadr x) env)))
	((pair? x)
	(map (lambda (x) (ac-qq1 level x env)) x))
	(#t x)))
	; (if) -> nil
	; (if x) -> x
	; (if t a ...) -> a
	; (if nil a b) -> b
	; (if nil a b c) -> (if b c)
	(define (ac-if args env)
	(cond ((null? args) ''nil)
	((null? (cdr args)) (ac (car args) env))
	(#t `(if (not (ar-false? ,(ac (car args) env)))
	,(ac (cadr args) env)
	,(ac-if (cddr args) env)))))
	(define (ac-dbname! name env)
	(if (symbol? name)
	(cons (list name) env)
	env))
	(define (ac-dbname env)
	(cond ((null? env) #f)
	((pair? (car env)) (caar env))
	(#t (ac-dbname (cdr env)))))
	; translate fn directly into a lambda if it has ordinary
	; parameters, otherwise use a rest parameter and parse it.
	(define (ac-fn args body env)
	(if (ac-complex-args? args)
	(ac-complex-fn args body env)
	(ac-nameit
	(ac-dbname env)
	`(lambda ,(let ((a (ac-denil args))) (if (eqv? a 'nil) '() a))
	,@(ac-body* body (append (ac-arglist args) env))))))
	; does an fn arg list use optional parameters or destructuring?
	; a rest parameter is not complex
	(define (ac-complex-args? args)
	(cond ((eqv? args '()) #f)
	((symbol? args) #f)
	((and (pair? args) (symbol? (car args)))
	(ac-complex-args? (cdr args)))
	(#t #t)))
	; translate a fn with optional or destructuring args
	; (fn (x (o y x) (o z 21) (x1 x2) . rest) ...)
	; arguments in top-level list are mandatory (unless optional),
	; but it's OK for parts of a list you're destructuring to
	; be missing.
	(define (ac-complex-fn args body env)
	(let* ((ra (ar-gensym))
	(z (ac-complex-args args env ra #t)))
	`(lambda ,ra
	(let* ,z
	,@(ac-body* body (append (ac-complex-getargs z) env))))))
	; returns a list of two-element lists, first is variable name,
	; second is (compiled) expression. to be used in a let.
	; caller should extract variables and add to env.
	; ra is the rest argument to the fn.
	; is-params indicates that args are function arguments
	; (not destructuring), so they must be passed or be optional.
	(define (ac-complex-args args env ra is-params)
	(cond ((or (eqv? args '()) (eqv? args 'nil)) '())
	((symbol? args) (list (list args ra)))
	((pair? args)
	(let* ((x (if (and (pair? (car args)) (eqv? (caar args) 'o))
	(ac-complex-opt (cadar args)
	(if (pair? (cddar args))
	(caddar args)
	'nil)
	env
	ra)
	(ac-complex-args
	(car args)
	env
	(if is-params
	`(car ,ra)
	`(ar-xcar ,ra))
	#f)))
	(xa (ac-complex-getargs x)))
	(append x (ac-complex-args (cdr args)
	(append xa env)
	`(ar-xcdr ,ra)
	is-params))))
	(#t (err "Can't understand fn arg list" args))))
	; (car ra) is the argument
	; so it's not present if ra is nil or '()
	(define (ac-complex-opt var expr env ra)
	(list (list var `(if (pair? ,ra) (car ,ra) ,(ac expr env)))))
	; extract list of variables from list of two-element lists.
	(define (ac-complex-getargs a)
	(map (lambda (x) (car x)) a))
	; (a b . c) -> (a b c)
	; a -> (a)
	(define (ac-arglist a)
	(cond ((null? a) '())
	((symbol? a) (list a))
	((symbol? (cdr a)) (list (car a) (cdr a)))
	(#t (cons (car a) (ac-arglist (cdr a))))))
	(define (ac-body body env)
	(map (lambda (x) (ac x env)) body))
	; like ac-body, but spits out a nil expression if empty
	(define (ac-body* body env)
	(if (null? body)
	(list (list 'quote 'nil))
	(ac-body body env)))
	; (set v1 expr1 v2 expr2 ...)
	(define (ac-set x env)
	`(begin ,@(ac-setn x env)))
	(define (ac-setn x env)
	(if (null? x)
	'()
	(cons (ac-set1 (ac-macex (car x)) (cadr x) env)
	(ac-setn (cddr x) env))))
	; trick to tell Scheme the name of something, so Scheme
	; debugging and profiling make more sense.
	(define (ac-nameit name v)
	(if (symbol? name)
	(let ((n (string->symbol (string-append " " (symbol->string name)))))
	(list 'let `((,n ,v)) n))
	v))
	; = replaced by set, which is only for vars
	; = now defined in arc (is it?)
	; name is to cause fns to have their arc names for debugging
	(define (ac-set1 a b1 env)
	(if (symbol? a)
	(let ((b (ac b1 (ac-dbname! a env))))
	(list 'let `((zz ,b))
	(cond ((eqv? a 'nil) (err "Can't rebind nil"))
	((eqv? a 't) (err "Can't rebind t"))
	((lex? a env) `(set! ,a zz))
	(#t `(namespace-set-variable-value! ',(ac-global-name a)
	zz)))
	'zz))
	(err "First arg to set must be a symbol" a)))
	; given a list of Arc expressions, return a list of Scheme expressions.
	; for compiling passed arguments.
	(define (ac-args names exprs env)
	(if (null? exprs)
	'()
	(cons (ac (car exprs)
	(ac-dbname! (if (pair? names) (car names) #f) env))
	(ac-args (if (pair? names) (cdr names) '())
	(cdr exprs)
	env))))
	; generate special fast code for ordinary two-operand
	; calls to the following functions. this is to avoid
	; calling e.g. ar-is with its &rest and apply.
	(define ac-binaries
	'((is ar-is2)
	(< ar-<2)
	(> ar->2)
	(+ ar-+2)))
	; (foo bar) where foo is a global variable bound to a procedure.
	(define (ac-global-call fn args env)
	(cond ((and (assoc fn ac-binaries) (= (length args) 2))
	`(,(cadr (assoc fn ac-binaries)) ,@(ac-args '() args env)))
	(#t
	`(,(ac-global-name fn) ,@(ac-args '() args env)))))
	; compile a function call
	; special cases for speed, to avoid compiled output like
	; (ar-apply _pr (list 1 2))
	; which results in 1/2 the CPU time going to GC. Instead:
	; (ar-funcall2 _pr 1 2)
	; and for (foo bar), if foo is a reference to a global variable,
	; and it's bound to a function, generate (foo bar) instead of
	; (ar-funcall1 foo bar)
	(define direct-calls #f)
	(define (ac-call fn args env)
	(let ((macfn (ac-macro? fn)))
	(cond (macfn
	(ac-mac-call macfn args env))
	((and (pair? fn) (eqv? (car fn) 'fn))
	`(,(ac fn env) ,@(ac-args (cadr fn) args env)))
	((and direct-calls (symbol? fn) (not (lex? fn env)) (bound? fn)
	(procedure? (namespace-variable-value (ac-global-name fn))))
	(ac-global-call fn args env))
	((= (length args) 0)
	`(ar-funcall0 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))
	((= (length args) 1)
	`(ar-funcall1 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))
	((= (length args) 2)
	`(ar-funcall2 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))
	((= (length args) 3)
	`(ar-funcall3 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))
	((= (length args) 4)
	`(ar-funcall4 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))
	(#t
	`(ar-apply ,(ac fn env)
	(list ,@(map (lambda (x) (ac x env)) args)))))))
	(define (ac-mac-call m args env)
	(let ((x1 (apply m (map ac-niltree args))))
	(let ((x2 (ac (ac-denil x1) env)))
	x2)))
	; returns #f or the macro function
	(define (ac-macro? fn)
	(if (symbol? fn)
	(let ((v (namespace-variable-value (ac-global-name fn)
	#t
	(lambda () #f))))
	(if (and v
	(ar-tagged? v)
	(eq? (ar-type v) 'mac))
	(ar-rep v)
	#f))
	#f))
	; macroexpand the outer call of a form as much as possible
	(define (ac-macex e . once)
	(if (pair? e)
	(let ((m (ac-macro? (car e))))
	(if m
	(let ((expansion (ac-denil (apply m (map ac-niltree (cdr e))))))
	(if (null? once) (ac-macex expansion) expansion))
	e))
	e))
	; macros return Arc lists, ending with NIL.
	; but the Arc compiler expects Scheme lists, ending with '().
	; what to do with (is x nil . nil) ?
	; the first nil ought to be replaced with 'NIL
	; the second with '()
	; so the rule is: NIL in the car -> 'NIL, NIL in the cdr -> '().
	; NIL by itself -> NIL
	(define (ac-denil x)
	(cond ((pair? x) (cons (ac-denil-car (car x)) (ac-denil-cdr (cdr x))))
	(#t x)))
	(define (ac-denil-car x)
	(if (eq? x 'nil)
	'nil
	(ac-denil x)))
	(define (ac-denil-cdr x)
	(if (eq? x 'nil)
	'()
	(ac-denil x)))
	; is v lexically bound?
	(define (lex? v env)
	(memq v env))
	(define (xcar x)
	(and (pair? x) (car x)))
	; #f and '() -> nil for a whole quoted list/tree.
	; Arc primitives written in Scheme should look like:
	; (xdef foo (lambda (lst)
	; (ac-niltree (scheme-foo (ar-nil-terminate lst)))))
	; That is, Arc lists are NIL-terminated. When calling a Scheme
	; function that treats an argument as a list, call ar-nil-terminate
	; to change NIL to '(). When returning any data created by Scheme
	; to Arc, call ac-niltree to turn all '() into NIL.
	; (hash-table-get doesn't use its argument as a list, so it doesn't
	; need ar-nil-terminate).
	(define (ac-niltree x)
	(cond ((pair? x) (cons (ac-niltree (car x)) (ac-niltree (cdr x))))
	((or (eq? x #f) (eq? x '())) 'nil)
	(#t x)))
	; The next two are optimizations, except work for macros.
	(define (decompose fns args)
	(cond ((null? fns) `((fn vals (car vals)) ,@args))
	((null? (cdr fns)) (cons (car fns) args))
	(#t (list (car fns) (decompose (cdr fns) args)))))
	(define (ac-andf s env)
	(ac (let ((gs (map (lambda (x) (ar-gensym)) (cdr s))))
	`((fn ,gs
	(and ,@(map (lambda (f) `(,f ,@gs))
	(cdar s))))
	,@(cdr s)))
	env))
	(define err error)
	; run-time primitive procedures
	;(define (xdef a b)
	; (namespace-set-variable-value! (ac-global-name a) b)
	; b)
	(define-syntax xdef
	(syntax-rules ()
	((xxdef a b)
	(let ((nm (ac-global-name 'a))
	(a b))
	(namespace-set-variable-value! nm a)
	a))))
	(define fn-signatures (make-hash-table 'equal))
	; This is a replacement for xdef that stores opeator signatures.
	; Haven't started using it yet.
	(define (odef a parms b)
	(namespace-set-variable-value! (ac-global-name a) b)
	(hash-table-put! fn-signatures a (list parms))
	b)
	(xdef sig fn-signatures)
	; versions of car and cdr for parsing arguments for optional
	; parameters, that yield nil for nil. maybe we should use
	; full Arc car and cdr, so we can destructure more things
	(define (ar-xcar x)
	(if (or (eqv? x 'nil) (eqv? x '()))
	'nil
	(car x)))
	(define (ar-xcdr x)
	(if (or (eqv? x 'nil) (eqv? x '()))
	'nil
	(cdr x)))
	; convert #f from a Scheme predicate to NIL.
	(define (ar-nill x)
	(if (or (eq? x '()) (eq? x #f))
	'nil
	x))
	; definition of falseness for Arc if.
	; must include '() since sometimes Arc functions see
	; Scheme lists (e.g. . body of a macro).
	(define (ar-false? x)
	(or (eq? x 'nil) (eq? x '()) (eq? x #f)))
	; call a function or perform an array ref, hash ref, &c
	; Non-fn constants in functional position are valuable real estate, so
	; should figure out the best way to exploit it. What could (1 foo) or
	; ('a foo) mean? Maybe it should mean currying.
	; For now the way to make the default val of a hash table be other than
	; nil is to supply the val when doing the lookup. Later may also let
	; defaults be supplied as an arg to table. To implement this, need: an
	; eq table within scheme mapping tables to defaults, and to adapt the
	; code in arc.arc that reads and writes tables to read and write their
	; default vals with them. To make compatible with existing written tables,
	; just use an atom or 3-elt list to keep the default.
	(define (ar-apply fn args)
	(cond ((procedure? fn)
	(apply fn args))
	((pair? fn)
	(list-ref fn (car args)))
	((string? fn)
	(string-ref fn (car args)))
	((hash-table? fn)
	(ar-nill (hash-table-get fn
	(car args)
	(if (pair? (cdr args)) (cadr args) #f))))
	; experiment: means e.g. [1] is a constant fn
	; ((or (number? fn) (symbol? fn)) fn)
	; another possibility: constant in functional pos means it gets
	; passed to the first arg, i.e. ('kids item) means (item 'kids).
	(#t (err "Function call on inappropriate object" fn args))))
	(xdef apply (lambda (fn . args)
	(ar-apply fn (ar-apply-args args))))
	; special cases of ar-apply for speed and to avoid consing arg lists
	(define (ar-funcall0 fn)
	(if (procedure? fn)
	(fn)
	(ar-apply fn (list))))
	(define (ar-funcall1 fn arg1)
	(if (procedure? fn)
	(fn arg1)
	(ar-apply fn (list arg1))))
	(define (ar-funcall2 fn arg1 arg2)
	(if (procedure? fn)
	(fn arg1 arg2)
	(ar-apply fn (list arg1 arg2))))
	(define (ar-funcall3 fn arg1 arg2 arg3)
	(if (procedure? fn)
	(fn arg1 arg2 arg3)
	(ar-apply fn (list arg1 arg2 arg3))))
	(define (ar-funcall4 fn arg1 arg2 arg3 arg4)
	(if (procedure? fn)
	(fn arg1 arg2 arg3 arg4)
	(ar-apply fn (list arg1 arg2 arg3 arg4))))
	; replace the nil at the end of a list with a '()
	(define (ar-nil-terminate l)
	(if (or (eqv? l '()) (eqv? l 'nil))
	'()
	(cons (car l) (ar-nil-terminate (cdr l)))))
	; turn the arguments to Arc apply into a list.
	; if you call (apply fn 1 2 '(3 4))
	; then args is '(1 2 (3 4 . nil) . ())
	; that is, the main list is a scheme list.
	; and we should return '(1 2 3 4 . ())
	; was once (apply apply list (ac-denil args))
	; but that didn't work for (apply fn nil)
	(define (ar-apply-args args)
	(cond ((null? args) '())
	((null? (cdr args)) (ar-nil-terminate (car args)))
	(#t (cons (car args) (ar-apply-args (cdr args))))))
	(xdef cons cons)
	(xdef car (lambda (x)
	(cond ((pair? x) (car x))
	((eqv? x 'nil) 'nil)
	((eqv? x '()) 'nil)
	(#t (err "Can't take car of" x)))))
	(xdef cdr (lambda (x)
	(cond ((pair? x) (cdr x))
	((eqv? x 'nil) 'nil)
	((eqv? x '()) 'nil)
	(#t (err "Can't take cdr of" x)))))
	(define (tnil x) (if x 't 'nil))
	; (pairwise pred '(a b c d)) =>
	; (and (pred a b) (pred b c) (pred c d))
	; pred returns t/nil, as does pairwise
	; reduce?
	(define (pairwise pred lst)
	(cond ((null? lst) 't)
	((null? (cdr lst)) 't)
	((not (eqv? (pred (car lst) (cadr lst)) 'nil))
	(pairwise pred (cdr lst)))
	(#t 'nil)))
	; not quite right, because behavior of underlying eqv unspecified
	; in many cases according to r5rs
	; do we really want is to ret t for distinct strings?
	; for (is x y)
	(define (ar-is2 a b)
	(tnil (or (eqv? a b)
	(and (string? a) (string? b) (string=? a b))
	(and (ar-false? a) (ar-false? b)))))
	; for all other uses of is
	(xdef is (lambda args (pairwise ar-is2 args)))
	(xdef err err)
	(xdef nil 'nil)
	(xdef t 't)
	(define (all test seq)
	(or (null? seq)
	(and (test (car seq)) (all test (cdr seq)))))
	(define (arc-list? x) (or (pair? x) (eqv? x 'nil) (eqv? x '())))
	; Generic +: strings, lists, numbers.
	; Return val has same type as first argument.
	(xdef + (lambda args
	(cond ((null? args) 0)
	((char-or-string? (car args))
	(apply string-append
	(map (lambda (a) (ar-coerce a 'string))
	args)))
	((arc-list? (car args))
	(ac-niltree (apply append (map ar-nil-terminate args))))
	(#t (apply + args)))))
	(define (char-or-string? x) (or (string? x) (char? x)))
	(define (ar-+2 x y)
	(cond ((char-or-string? x)
	(string-append (ar-coerce x 'string) (ar-coerce y 'string)))
	((and (arc-list? x) (arc-list? y))
	(ac-niltree (append (ar-nil-terminate x) (ar-nil-terminate y))))
	(#t (+ x y))))
	(xdef - -)
	(xdef * *)
	(xdef / /)
	(xdef mod modulo)
	(xdef expt expt)
	(xdef sqrt sqrt)
	; generic comparison
	(define (ar->2 x y)
	(tnil (cond ((and (number? x) (number? y)) (> x y))
	((and (string? x) (string? y)) (string>? x y))
	((and (symbol? x) (symbol? y)) (string>? (symbol->string x)
	(symbol->string y)))
	((and (char? x) (char? y)) (char>? x y))
	(#t (> x y)))))
	(xdef > (lambda args (pairwise ar->2 args)))
	(define (ar-<2 x y)
	(tnil (cond ((and (number? x) (number? y)) (< x y))
	((and (string? x) (string? y)) (string<? x y))
	((and (symbol? x) (symbol? y)) (string<? (symbol->string x)
	(symbol->string y)))
	((and (char? x) (char? y)) (char<? x y))
	(#t (< x y)))))
	(xdef < (lambda args (pairwise ar-<2 args)))
	(xdef len (lambda (x)
	(cond ((string? x) (string-length x))
	((hash-table? x) (hash-table-count x))
	(#t (length (ar-nil-terminate x))))))
	(define (ar-tagged? x)
	(and (vector? x) (eq? (vector-ref x 0) 'tagged)))
	(define (ar-tag type rep)
	(cond ((eqv? (ar-type rep) type) rep)
	(#t (vector 'tagged type rep))))
	(xdef annotate ar-tag)
	; (type nil) -> sym
	(define (ar-type x)
	(cond ((ar-tagged? x) (vector-ref x 1))
	((pair? x) 'cons)
	((symbol? x) 'sym)
	((null? x) 'sym)
	((procedure? x) 'fn)
	((char? x) 'char)
	((string? x) 'string)
	((integer? x) 'int)
	((number? x) 'num) ; unsure about this
	((hash-table? x) 'table)
	((output-port? x) 'output)
	((input-port? x) 'input)
	((tcp-listener? x) 'socket)
	((exn? x) 'exception)
	((thread? x) 'thread)
	(#t (err "Type: unknown type" x))))
	(xdef type ar-type)
	(define (ar-rep x)
	(if (ar-tagged? x)
	(vector-ref x 2)
	x))
	(xdef rep ar-rep)
	; currently rather a joke: returns interned symbols
	(define ar-gensym-count 0)
	(define (ar-gensym)
	(set! ar-gensym-count (+ ar-gensym-count 1))
	(string->symbol (string-append "gs" (number->string ar-gensym-count))))
	(xdef uniq ar-gensym)
	(xdef ccc call-with-current-continuation)
	(xdef infile open-input-file)
	(xdef outfile (lambda (f . args)
	(open-output-file f
	'text
	(if (equal? args '(append))
	'append
	'truncate))))
	(xdef instring open-input-string)
	(xdef outstring open-output-string)
	; use as general fn for looking inside things
	(xdef inside get-output-string)
	(xdef stdout current-output-port) ; should be a vars
	(xdef stdin current-input-port)
	(xdef stderr current-error-port)
	(xdef call-w/stdout
	(lambda (port thunk)
	(parameterize ((current-output-port port)) (thunk))))
	(xdef call-w/stdin
	(lambda (port thunk)
	(parameterize ((current-input-port port)) (thunk))))
	(xdef readc (lambda str
	(let ((c (read-char (if (pair? str)
	(car str)
	(current-input-port)))))
	(if (eof-object? c) 'nil c))))
	(xdef readb (lambda str
	(let ((c (read-byte (if (pair? str)
	(car str)
	(current-input-port)))))
	(if (eof-object? c) 'nil c))))
	(xdef peekc (lambda str
	(let ((c (peek-char (if (pair? str)
	(car str)
	(current-input-port)))))
	(if (eof-object? c) 'nil c))))
	(xdef writec (lambda (c . args)
	(write-char c
	(if (pair? args)
	(car args)
	(current-output-port)))
	c))
	(xdef writeb (lambda (b . args)
	(write-byte b
	(if (pair? args)
	(car args)
	(current-output-port)))
	b))
	(define explicit-flush #f)
	(define (printwith f args)
	(let ((port (if (> (length args) 1)
	(cadr args)
	(current-output-port))))
	(when (pair? args)
	(f (ac-denil (car args)) port))
	(unless explicit-flush (flush-output port)))
	'nil)
	(xdef write (lambda args (printwith write args)))
	(xdef disp (lambda args (printwith display args)))
	; sread = scheme read. eventually replace by writing read
	(xdef sread (lambda (p eof)
	(let ((expr (read p)))
	(if (eof-object? expr) eof expr))))
	; these work in PLT but not scheme48
	(define char->ascii char->integer)
	(define ascii->char integer->char)
	(define (iround x) (inexact->exact (round x)))
	(define (ar-coerce x type . args)
	(cond
	((ar-tagged? x) (err "Can't coerce annotated object"))
	((eqv? type (ar-type x)) x)
	((char? x) (case type
	((int) (char->ascii x))
	((string) (string x))
	((sym) (string->symbol (string x)))
	(else (err "Can't coerce" x type))))
	((integer? x) (case type
	((num) x)
	((char) (ascii->char x))
	((string) (apply number->string x args))
	(else (err "Can't coerce" x type))))
	((number? x) (case type
	((int) (iround x))
	((char) (ascii->char (iround x)))
	((string) (apply number->string x args))
	(else (err "Can't coerce" x type))))
	((string? x) (case type
	((sym) (string->symbol x))
	((cons) (ac-niltree (string->list x)))
	((num) (or (apply string->number x args)
	(err "Can't coerce" x type)))
	((int) (let ((n (apply string->number x args)))
	(if n
	(iround n)
	(err "Can't coerce" x type))))
	(else (err "Can't coerce" x type))))
	((pair? x) (case type
	((string) (apply string-append
	(map (lambda (y) (ar-coerce y 'string))
	(ar-nil-terminate x))))
	(else (err "Can't coerce" x type))))
	((eqv? x 'nil) (case type
	((string) "")
	(else (err "Can't coerce" x type))))
	((null? x) (case type
	((string) "")
	(else (err "Can't coerce" x type))))
	((symbol? x) (case type
	((string) (symbol->string x))
	(else (err "Can't coerce" x type))))
	(#t x)))
	(xdef coerce ar-coerce)
	(xdef open-socket (lambda (num) (tcp-listen num 50 #t)))
	; the 2050 means http requests currently capped at 2 meg
	; http://list.cs.brown.edu/pipermail/plt-scheme/2005-August/009414.html
	(xdef socket-accept (lambda (s)
	(let ((oc (current-custodian))
	(nc (make-custodian)))
	(current-custodian nc)
	(call-with-values
	(lambda () (tcp-accept s))
	(lambda (in out)
	(let ((in1 (make-limited-input-port in 100000 #t)))
	(current-custodian oc)
	(associate-custodian nc in1 out)
	(list in1
	out
	(let-values (((us them) (tcp-addresses out)))
	them))))))))
	(xdef new-thread thread)
	(xdef kill-thread kill-thread)
	(xdef break-thread break-thread)
	(xdef current-thread current-thread)
	(define (wrapnil f) (lambda args (apply f args) 'nil))
	(xdef sleep (wrapnil sleep))
	; Will system "execute" a half-finished string if thread killed
	; in the middle of generating it?
	(xdef system (wrapnil system))
	(xdef pipe-from (lambda (cmd)
	(let ((tf (ar-tmpname)))
	(system (string-append cmd " > " tf))
	(let ((str (open-input-file tf)))
	(system (string-append "rm -f " tf))
	str))))
	(define (ar-tmpname)
	(call-with-input-file "/dev/urandom"
	(lambda (rstr)
	(do ((s "/tmp/")
	(c (read-char rstr) (read-char rstr))
	(i 0 (+ i 1)))
	((>= i 16) s)
	(set! s (string-append s
	(string
	(integer->char
	(+ (char->integer #\a)
	(modulo
	(char->integer (read-char rstr))
	26))))))))))
	; PLT scheme provides only eq? and equal? hash tables,
	; we need the latter for strings.
	(xdef table (lambda args
	(let ((h (make-hash-table 'equal)))
	(if (pair? args) ((car args) h))
	h)))
	;(xdef table (lambda args
	; (fill-table (make-hash-table 'equal)
	; (if (pair? args) (ac-denil (car args)) '()))))
	(define (fill-table h pairs)
	(if (eq? pairs '())
	h
	(let ((pair (car pairs)))
	(begin (hash-table-put! h (car pair) (cadr pair))
	(fill-table h (cdr pairs))))))
	(xdef maptable (lambda (fn table) ; arg is (fn (key value) ...)
	(hash-table-for-each table fn)
	table))
	(define (protect during after)
	(dynamic-wind (lambda () #t) during after))
	(xdef protect protect)
	; need to use a better seed
	(xdef rand random)
	(xdef dir (lambda (name)
	(ac-niltree (map path->string (directory-list name)))))
	; Would def mkdir in terms of make-directory and call that instead
	; of system in ensure-dir, but make-directory is too weak: it doesn't
	; create intermediate directories like mkdir -p.
	(xdef file-exists (lambda (name)
	(if (file-exists? name) name 'nil)))
	(xdef dir-exists (lambda (name)
	(if (directory-exists? name) name 'nil)))
	(xdef rmfile (wrapnil delete-file))
	(xdef mvfile (lambda (old new)
	(rename-file-or-directory old new #t)
	'nil))
	; top level read-eval-print
	; tle kept as a way to get a break loop when a scheme err
	(define (arc-eval expr)
	(eval (ac expr '())))
	(define (tle)
	(display "Arc> ")
	(let ((expr (read)))
	(when (not (eqv? expr ':a))
	(write (arc-eval expr))
	(newline)
	(tle))))
	(define last-condition* #f)
	(define (tl)
	(display "Use (quit) to quit, (tl) to return here after an interrupt.\n")
	(tl2))
	(define (tl2)
	(display "arc> ")
	(on-err (lambda (c)
	(set! last-condition* c)
	(display "Error: ")
	(write (exn-message c))
	(newline)
	(tl2))
	(lambda ()
	(let ((expr (read)))
	(if (eqv? expr ':a)
	'done
	(let ((val (arc-eval expr)))
	(write (ac-denil val))
	(namespace-set-variable-value! '_that val)
	(namespace-set-variable-value! '_thatexpr expr)
	(newline)
	(tl2)))))))
	(define (aload1 p)
	(let ((x (read p)))
	(if (eof-object? x)
	#t
	(begin
	(arc-eval x)
	(aload1 p)))))
	(define (atests1 p)
	(let ((x (read p)))
	(if (eof-object? x)
	#t
	(begin
	(write x)
	(newline)
	(let ((v (arc-eval x)))
	(if (ar-false? v)
	(begin
	(display " FAILED")
	(newline))))
	(atests1 p)))))
	(define (aload filename)
	(call-with-input-file filename aload1))
	(define (test filename)
	(call-with-input-file filename atests1))
	(define (acompile1 ip op)
	(let ((x (read ip)))
	(if (eof-object? x)
	#t
	(let ((scm (ac x '())))
	(eval scm)
	(pretty-print scm op)
	(newline op)
	(newline op)
	(acompile1 ip op)))))
	; compile xx.arc to xx.arc.scm
	; useful to examine the Arc compiler output
	(define (acompile inname)
	(let ((outname (string-append inname ".scm")))
	(if (file-exists? outname)
	(delete-file outname))
	(call-with-input-file inname
	(lambda (ip)
	(call-with-output-file outname
	(lambda (op)
	(acompile1 ip op)))))))
	(xdef macex (lambda (e) (ac-macex (ac-denil e))))
	(xdef macex1 (lambda (e) (ac-macex (ac-denil e) 'once)))
	(xdef eval (lambda (e)
	(eval (ac (ac-denil e) '()))))
	; If an err occurs in an on-err expr, no val is returned and code
	; after it doesn't get executed. Not quite what I had in mind.
	(define (on-err errfn f)
	((call-with-current-continuation
	(lambda (k)
	(lambda ()
	(with-handlers ((exn:fail? (lambda (c)
	(k (lambda () (errfn c))))))
	(f)))))))
	(xdef on-err on-err)
	(define (disp-to-string x)
	(let ((o (open-output-string)))
	(display x o)
	(close-output-port o)
	(get-output-string o)))
	(xdef details (lambda (c)
	(disp-to-string (exn-message c))))
	(xdef scar (lambda (x val)
	(if (string? x)
	(string-set! x 0 val)
	(set-car! x val))
	val))
	(xdef scdr (lambda (x val)
	(if (string? x)
	(err "Can't set cdr of a string" x)
	(set-cdr! x val))
	val))
	; When and if cdr of a string returned an actual (eq) tail, could
	; say (if (string? x) (string-replace! x val 1) ...) in scdr, but
	; for now would be misleading to allow this, because fails for cddr.
	(define (string-replace! str val index)
	(if (eqv? (string-length val) (- (string-length str) index))
	(do ((i index (+ i 1)))
	((= i (string-length str)) str)
	(string-set! str i (string-ref val (- i index))))
	(err "Length mismatch between strings" str val index)))
	; Later may want to have multiple indices.
	(xdef sref
	(lambda (com val ind)
	(cond ((hash-table? com) (if (eqv? val 'nil)
	(hash-table-remove! com ind)
	(hash-table-put! com ind val)))
	((string? com) (string-set! com ind val))
	((pair? com) (nth-set! com ind val))
	(#t (err "Can't set reference " com ind val)))
	val))
	(define (nth-set! lst n val)
	(set-car! (list-tail lst n) val))
	; rewrite to pass a (true) gensym instead of #f in case var bound to #f
	(define (bound? arcname)
	(namespace-variable-value (ac-global-name arcname)
	#t
	(lambda () #f)))
	(xdef bound (lambda (x) (tnil (bound? x))))
	(xdef newstring make-string)
	(xdef trunc (lambda (x) (inexact->exact (truncate x))))
	(xdef exact (lambda (x)
	(tnil (and (integer? x) (exact? x)))))
	(xdef msec current-milliseconds)
	(xdef current-process-milliseconds current-process-milliseconds)
	(xdef current-gc-milliseconds current-gc-milliseconds)
	(xdef seconds current-seconds)
	(print-hash-table #t)
	(xdef client-ip (lambda (port)
	(let-values (((x y) (tcp-addresses port)))
	y)))
	; make sure only one thread at a time executes anything
	; inside an atomic-invoke. atomic-invoke is allowed to
	; nest within a thread; the thread-cell keeps track of
	; whether this thread already holds the lock.
	(define ar-the-sema (make-semaphore 1))
	(define ar-sema-cell (make-thread-cell #f))
	(xdef atomic-invoke (lambda (f)
	(if (thread-cell-ref ar-sema-cell)
	(ar-apply f '())
	(begin
	(thread-cell-set! ar-sema-cell #t)
	(protect
	(lambda ()
	(call-with-semaphore
	ar-the-sema
	(lambda () (ar-apply f '()))))
	(lambda ()
	(thread-cell-set! ar-sema-cell #f)))))))
	(xdef dead (lambda (x) (tnil (thread-dead? x))))
	; Added because Mzscheme buffers output. Not a permanent part of Arc.
	; Only need to use when declare explicit-flush optimization.
	(xdef flushout (lambda () (flush-output) 't))
	(xdef ssyntax (lambda (x) (tnil (ssyntax? x))))
	(xdef ssexpand (lambda (x)
	(if (symbol? x) (expand-ssyntax x) x)))
	(xdef quit exit)
	; there are two ways to close a TCP output port.
	; (close o) waits for output to drain, then closes UNIX descriptor.
	; (force-close o) discards buffered output, then closes UNIX desc.
	; web servers need the latter to get rid of connections to
	; clients that are not reading data.
	; mzscheme close-output-port doesn't work (just raises an error)
	; if there is buffered output for a non-responsive socket.
	; must use custodian-shutdown-all instead.
	(define custodians (make-hash-table 'equal))
	(define (associate-custodian c i o)
	(hash-table-put! custodians i c)
	(hash-table-put! custodians o c))
	; if a port has a custodian, use it to close the port forcefully.
	; also get rid of the reference to the custodian.
	; sadly doing this to the input port also kills the output port.
	(define (try-custodian p)
	(let ((c (hash-table-get custodians p #f)))
	(if c
	(begin
	(custodian-shutdown-all c)
	(hash-table-remove! custodians p)
	#t)
	#f)))
	(define (ar-close . args)
	(map (lambda (p)
	(cond ((input-port? p) (close-input-port p))
	((output-port? p) (close-output-port p))
	((tcp-listener? p) (tcp-close p))
	(#t (err "Can't close " p))))
	args)
	(map (lambda (p) (try-custodian p)) args) ; free any custodian
	'nil)
	(xdef close ar-close)
	(xdef force-close (lambda args
	(map (lambda (p)
	(if (not (try-custodian p))
	(ar-close p)))
	args)
	'nil))
	(xdef memory current-memory-use)
	(xdef declare (lambda (key val)
	(let ((flag (not (ar-false? val))))
	(case key
	((atstrings) (set! atstrings flag))
	((direct-calls) (set! direct-calls flag))
	((explicit-flush) (set! explicit-flush flag)))
	val)))
	(putenv "TZ" ":GMT")
	(define (gmt-date sec) (seconds->date sec))
	(xdef timedate
	(lambda args
	(let ((d (gmt-date (if (pair? args) (car args) (current-seconds)))))
	(ac-niltree (list (date-second d)
	(date-minute d)
	(date-hour d)
	(date-day d)
	(date-month d)
	(date-year d))))))
	(xdef sin sin)
	(xdef cos cos)
	(xdef tan tan)
	(xdef asin asin)
	(xdef acos acos)
	(xdef atan atan)
	(xdef log log)
	(define (codestring s)
	(let ((i (atpos s 0)))
	(if i
	(cons (substring s 0 i)
	(let* ((rest (substring s (+ i 1)))
	(in (open-input-string rest))
	(expr (read in))
	(i2 (let-values (((x y z) (port-next-location in))) z)))
	(close-input-port in)
	(cons expr (codestring (substring rest (- i2 1))))))
	(list s))))
	; First unescaped @ in s, if any. Escape by doubling.
	(define (atpos s i)
	(cond ((eqv? i (string-length s))
	#f)
	((eqv? (string-ref s i) #\@)
	(if (and (< (+ i 1) (string-length s))
	(not (eqv? (string-ref s (+ i 1)) #\@)))
	i
	(atpos s (+ i 2))))
	(#t
	(atpos s (+ i 1)))))
	(define (unescape-ats s)
	(list->string (letrec ((unesc (lambda (cs)
	(cond
	((null? cs)
	'())
	((and (eqv? (car cs) #\@)
	(not (null? (cdr cs)))
	(eqv? (cadr cs) #\@))
	(unesc (cdr cs)))
	(#t
	(cons (car cs) (unesc (cdr cs))))))))
	(unesc (string->list s)))))
	)

view raw ac.scm hosted with ❤ by GitHub

	; From Eli Barzilay, eli@barzilay.org
	;> (require "brackets.scm")
	;> (use-bracket-readtable)
	;> ([+ _ 1] 10)
	;11
	(module brackets mzscheme
	; main reader function for []s
	; recursive read starts with default readtable's [ parser,
	; but nested reads still use the curent readtable:
	(define (read-square-brackets ch port src line col pos)
	`(fn (_)
	,(read/recursive port #\[ #f)))
	; a readtable that is just like the builtin except for []s
	(define bracket-readtable
	(make-readtable #f #\[ 'terminating-macro read-square-brackets))
	; call this to set the global readtable
	(provide use-bracket-readtable)
	(define (use-bracket-readtable)
	(current-readtable bracket-readtable))
	; these two implement the required functionality for #reader
	;(define (*read inp)
	; (parameterize ((current-readtable bracket-readtable))
	; (read inp)))
	(define (*read . args)
	(parameterize ((current-readtable bracket-readtable))
	(read (if (null? args) (current-input-port) (car args)))))
	(define (*read-syntax src port)
	(parameterize ((current-readtable bracket-readtable))
	(read-syntax src port)))
	; and the need to be provided as `read' and `read-syntax'
	(provide (rename *read read) (rename *read-syntax read-syntax))
	)

view raw brackets.scm hosted with ❤ by GitHub

#9LISP How to use ASDF

What the FUCK is the prerequisite of LOL?

LOLの調子は如何でしょうか?僕は引っかかりまくりながらやっています(笑)。色んな意味で(笑)。

あの本は想定読者がちょっと微妙なところがあります(実際、プログラミング関係の本だとマトモな編集者が介在してるのか分かんないケースが多々あって、想定読者が絞りきれていず、結果、著作者の独りよがりな本を良く見かけますが(※1))。例えば最初の数章が割に冗長なんですけど、先に進んでいくと今度はCommon Lispに精通していなければ意味が分からない部分が散見してたりして。

これ、ホント誤解して欲しくないんですけど、敢えて言っておきます。LOLの評価に関して言うとCommon Lispに精通している人の意見なんて聞いてもしょーがないです。彼らは、そもそも、Lispの本の出版数自体が少ない(C言語/Java/JavaScriptに比べたら圧倒的に少ない!)んで、Lispの本が出ただけで「これは名著だ!」って言いたがる傾向がある、んです。当たり前ですよね。マイナーなアニメのファンブックが出版されたようなモンですから(笑)。中身はともかくとして、ファンなら買って絶賛するよな(笑)。行動パターンがマイナーアニメのファン層と結構カブるので眉に唾付けとかないとなんない(笑)。

第二の問題として、LOLを絶賛しかねない層と言うのは、LOLなんて買わなくてもマクロに精通している層だと言う可能性がある、からです。当然既にCommon Lispに精通しているわけですから、LOLを斜め読みして、

「う～ん、これは良くまとまってるし分かりやすい。」

とか言うでしょう。当たり前です。それは既にCommon Lispの全貌を殆ど把握している人ですから。ところが、こう言う人たちは大体見逃してるんですよね。マクロ初学者に対して適切に構成されてるのか?とか言う視点に欠けてる。「自分が分かれば良い本だ！」とはならないのが難しいトコなんです。本当の事を言うと。

もちろん、ある程度Common Lispを使っていた事がある、と言うのが前提なのかもしれません。しかしそうだとすると、最初の数章の冗長さは何なんだ、って話になる。unit-of-timeマクロなんてあまりにバカバカしい例だと思いませんかね?幼稚な例、と言えばあまりにも幼稚な例です。これ使ってマクロの基礎を解説される層ってどう言う層なんですかね?そもそもCLでマクロを使った事が無い層が対象読者として想定されてなければこんな例ってあり得ないでしょう。

つまるところ、LOLの真のprerequisiteって何なんだって話なんですけどね。LOLはOn Lispを良く引き合いに出してますが、読者的な立場から言うと本当のprerequisiteってのは別のところにある。っつーかそう解釈しないと構成自体に疑問が出ざるを得ない、のです。特に #9LISP みたいに「SchemeからCLに突如移動する」とでもなった場合、この辺の構成の不具合ってのが全面に出てきちゃうのです。

まあ、個人的には、LOLの内容としては、記述されているマクロ自体の価値はともかくとして、本自体は同人誌だとしか思ってないんですけどね。不具合はあって当然(同人誌だから・笑!)なんであんま苛める気は無いんですけど、ただ、権威的な書籍だと思われたら困るだろ、って事だけは言っておきたい。あくまで一書籍として考えた場合、って事です。一方、 #9LISP みたいな勉強会を行ってる建前上、不具合があった方が良い、ってのもまた事実なんですよね(笑)。独学/自習で全て理解出来てしまうような優秀な本だったらそもそも勉強会を開く口実が無くなってしまう(笑)。プログラミングやってる人たちの間で勉強会が多いのは、穿った見方をすると、プログラミング関係の書籍には構成がマズい本がどーゆーわけか多い(※2)と言う事実の裏返しかもしれません(笑)。ちゃうかもしんねえけどよ(笑)。

※1: 実はプログラミング関係の書籍だけ、じゃなくって最近の理工系出版物全般的な傾向なんじゃないか、と思います。編集者が仕事していない。

もちろん、

「編集者は文系出身だから専門的な内容を理解出来ない。」

なんて意見もあるんですが、フザけんな、とか思います(笑)。仮にも編集者はプロでしょうし、そもそもプロの編集者が理解出来ない原稿を書いてる時点で何なんだ、とか思いますし(笑)。だったら紙資源の節約の為、出版なんてせずに論文書いてるべきですね。査定側は同業者でしょうし。わざわざ出版なんかして地球の森林資源を大規模に無駄にする必要もない。

最近の理工系の本がダメダメになってきてるのは、殆ど出版物が事実上ケータイ小説のレベルになってきてる、って事です。だったら新潮社辺りから出版すりゃあエエんちゃうんか(笑)。

※2: SICP、とか(笑)?

Anything relies on ASDF

とか色々文句書いたんですけど(笑)、どう言う経緯を経てそのプログラミング言語を扱ってるのか、と言うのは想定が難しい、と言うのも事実なんですよね。読者が千差万別のバックグラウンドを持っているから、です。

#9LISP のメンバーでもそうかもしれないし、そうじゃないかもしれませんが、CLにあんま明るくない人が最初に躓くのは、恐らくLOLの第3章辺りでいきなり導入されてるCL-PPCREの存在じゃないか、って思います。もちろん、これはANSI仕様書範囲外のトピックです。すなわち、

「CL-PPCREって外部ライブラリ?っぽいんだけど…。それはいいとしてどーやってインストールすんの?これ。LOLには何も書いてないじゃん。」

そう。何も書いてない(笑)。いきなり読者置いてきぼりの第一撃が放たれるのです。特にWindows使ってプログラミングしている人(そう言う人の方が多い)は放置プレイですよ。困ったもんだ。

以前、#9LISP LOL 第2章 メモにも書いておいたんですが、こーゆー場合に使うのがASDF-installです。言わばCommon LispのCPANです。まあ、gemでもいいんですけど(笑)。

使い方をおさらいしておきましょうか(※1)。REPLで流れを書いておきます。

	CL-USER> (require :asdf) ; asdf を呼び出す
	NIL
	CL-USER> (require :asdf-install) ; asdf-install を呼び出す
	("ASDF-INSTALL")
	CL-USER> (asdf-install:install :cl-ppcre) ; cl-ppcre を asdf-install:install を使ってインストールする
	Install where?
	1) System-wide install:
	System in /usr/lib/sbcl/site-systems/
	Files in /usr/lib/sbcl/site/
	2) Personal installation:
	System in /home/cametan/.sbcl/systems/
	Files in /home/cametan/.sbcl/site/
	-->

view raw using-asdf-install.lisp hosted with ❤ by GitHub

2番のPersonal installationを利用すれば良いでしょう。その後、鍵の認証を求められますが、無視して大丈夫です。その後、

	CL-USER> (asdf:operate 'asdf:load-op :cl-ppcre) ; cl-ppcre を asdf:load-op を利用してロードする
	; loading system definition from
	; /usr/share/common-lisp/systems/cl-ppcre.asd into #<PACKAGE "ASDF0">
	; registering #<SYSTEM :CL-PPCRE {B16B109}> as CL-PPCRE
	; registering #<SYSTEM :CL-PPCRE-TEST {B30F529}> as CL-PPCRE-TEST
	NIL
	CL-USER> (use-package :cl-ppcre) ; use-package を利用して、 cl-ppcre の機能を用いる
	T
	CL-USER>

view raw how-to-use-cl-ppcre.lisp hosted with ❤ by GitHub

とすれば、無事、REPL上でCL-PPCREの提供する全機能を使う事が出来ます。やったね!!!

それはさておき。疑問がある人はあるでしょう。

「オーケー。asdf-installってのはPerlで言うCPAN、Rubyで言うgemなわけね。そこは了承した。何かライブラリをインストールしなきゃなんない、って場合はこれ使えばいいわけだ。何かヘンに括弧があるし、コロンだらけだし、要素が多いんで記述がメンド臭そう(※2)なんだけど一応分かった。

でもさ。そもそもASDFって何なのよ?あとさ。不思議の呪文use-packageって一体何なの?これ無いとダメなのかね?普通はロードしたら即ready-to-rock'n-rollなんじゃねえの?手順が多すぎるんだよな。単にファイル持ってきて手作業でロードした方が良かったりして。」

全くもってその通りです。が、ASDF(Another System Definition Facilities)と言うわざとらしい名前のブツ(※3)が無いとちょっとメンド臭い事象が起こる、って事を書いてみます。現象面から見ていった方が分かりやすいCL独特のメンド臭さがある、のです。

※1: もちろんこれはLinux系OSを使ってない人の場合で、Linux、例えばDebian系ディストロUbuntuだと、レポジトリでCL-PPCREを提供してたりするんで、

sudo aptitude install cl-ppcre

と端末から入力した方がラクだったりする。

また、以前書いた通り、GNU CLISPにはASDFがデフォルトで同梱されてなかったりするんで、最初に別途インストールが必要。ただし、Lispboxの場合、最初からASDFが同梱されているので、面倒が減る。

※2: 確かに長い。ただし、LispboxやあるいはEmacs + SLIMEを利用してる場合は、ライブラリさえインストールしていれば手順は簡略化可能。REPL上でコンマ(,)を打つと、候補が表示される。その中にload-systemと言う項目があって、それが(asdf:operate 'asdf:load-op ...)にあたり、これを選択して、パッケージ名(この場合はCL-PPCRE)を入力してEnterを押せば良い。

もっとも、正直な話をすると、選択肢表示がSLIMEの機能だったのかどうか自信がない。@rubikitchさんがメインテナンスをしているanything.elの機能だったかもしれない。色々入れすぎていて、既に何だか不明なのだ(笑)。

詳しくは@rubikitchさんに訊くか、あるいはこの辺を参考にして欲しい。既にanythingはEmacsの必須ツールとなっている。これ無しでは、Emacsでプログラミングなんてメンド臭くてやってられない、って程だ。

また、Emacs Wikiの方でSLIME用のanything-slime.elが公開されている。これも合わせて環境にインストールしておこう。

※3: 言うまでもないが、a、s、d、fは全て、QWERTY配列キーボードの上から3段目の左から順に並んでいるキーである。

What the FUCK caught ERROR?

まず最初に言っておくと、ASDF自体が新しい、って事です。かつこれは仕様範囲外なんですよね。そして、それをマトモに取り扱ってる書籍が無いです。

そこで、簡単な例を上げてみます。LOLの原著サイトの方で、本に書かれてあるコード(正確に言うと、若干改良したもの)がProduction Codeとして上げられています。考え方としては当然、

「う～ん、本を読みながらコード打ち込んで行くのもいいけど、取りあえず全コードを入手して、それを実際動かしながら調べていく、ってのもアリかな?」

と言うのはアリでしょう。アリですよね(笑)?あるいは、LOLの秘密兵器、defmacro!だけが必要で、他の御託は聞きたくない、とか(笑)。そう言う人も居るはずです(笑)。いてもおかしくない(笑)。

いずれにせよ、そう言ったシナリオを考えてみて、そこのコードをコピペしてlol-production-code.lispと言ったファイルを作ったとしましょう。そしてそれをコンパイル/ロードするとする(Lispbox/SLIMEだったらC-c C-kですか)。ハテサテ、これで上手く行く筈、と思ったら、何とエラー表示。次のようなエラーが表示されると思います。

	cd ~/
	2 compiler notes:
	lol-production-code.lisp:265:1:
	error:
	(during macroexpansion of (DEFMACRO! DLAMBDA ...))
	The function O!-SYMBOL-P is undefined.
	lol-production-code.lisp:357:17:
	read-error:
	SB-INT:SIMPLE-READER-ERROR at 8903 (line 357, column 17) on #<SB-SYS:FD-STREAM for "file /home/cametan/lol-production-code.lisp" {B138C51}>:
	no dispatch function defined for #\`
	Compilation failed.
	; compiling file "/home/cametan/lol-production-code.lisp" (written 06 MAY 2010 02:18:39 PM):
	; file: /home/cametan/lol-production-code.lisp
	; in: DEFMACRO! DLAMBDA
	; (DEFMACRO! DLAMBDA (&REST DS)
	; `(LAMBDA (&REST ,G!ARGS)
	; (CASE (CAR ,G!ARGS) (SB-IMPL::BACKQ-COMMA-AT (MAPCAR # DS)))))
	;
	; caught ERROR:
	; (during macroexpansion of (DEFMACRO! DLAMBDA ...))
	; The function O!-SYMBOL-P is undefined.
	;
	; compilation unit aborted
	; caught 1 fatal ERROR condition
	; caught 1 ERROR condition
	; compilation aborted because of fatal error:
	; READ failure in COMPILE-FILE:
	; SB-INT:SIMPLE-READER-ERROR at 8903 (line 357, column 17) on #<SB-SYS:FD-STREAM for "file /home/cametan/lol-production-code.lisp" {B138C51}>:
	; no dispatch function defined for #\`
	; compilation aborted after 0:00:00.306

view raw compilation-failed.lisp hosted with ❤ by GitHub

「え?何でやねん?」

とか思う筈です。あせります。そもそも公式サイトから取ってきたコードなわけですから書き間違いでエラーが出る筈がない。ところが実際、コンパイルは失敗してエラーが出てる。おかしくないのか?

んで、ちょっと落ち着いてエラー表示を読んでみます。次のような事が書いてあります

defmacro!によるdlambdaの定義のマクロ展開時に於いて、エラーが発生。関数o!-symbol-pが定義されていない。

ここで「おかしいな?」となるでしょう。慌ててファイルlol-production-code.lispをチェックしてみる。Doug Hoyteの野郎、o!-symbol-pの定義書き忘れたんじゃねえの?……いや、でもファイル内をインクリメンタル検索してみるとo!-symbol-pはファイル内でキチンと定義されているのです。何じゃこりゃ、Common Lispがぶっ壊れている???

Macro-expansion before Compilation

実際、このテの一見意味不明なエラーは、原則インタプリタであるSchemeじゃお目にかかりません。Scheme慣れしていると皆目見当が付かない現象なんです。しかし、これはCLの仕様から言うとCL特有の、かつ当たり前の現象なんですよね。起こってるのは次のような事です。

CLの仕様によると、マクロはソースコードのコンパイル時に展開される事になっています。しかし、より正確に言うと、マクロは実際にソースコードをコンパイルする前に展開されるわけです。ここがポイント。何故なら、マクロはLispプログラミング上のコードのショートカットを目論んでいる機能ですから、マクロ定義に従って、マクロのソースコードをバンバン置換していかないとならない。つまり、それこそがマクロ展開であって、これが終了しない事にはファイル自体がコンパイル出来ないわけなんです。

と言う事は、マクロ展開中には、ファイルに定義されている関数が利用されてた場合、当然その関数はまだ存在してないって事なんです。上に紹介した現象に従うと、マクロdlambdaは同じファイル内に定義されているdefmacro!を用いて定義されてるんですが、そのdefmacro!は同じファイル内に存在しているo!-symbol-pに依存しています。しかしながら、マクロ展開中にはまだo!-symbol-pは存在していません。何故ならo!-symbol-p自体の評価もコンパイルもまだ行われてないから、です。そこで、Lispのコンパイラはこれを異常と検知し、コンパイルを中断してエラーを返しているのです。

いやはや、言われてみると「なるほどな」ってんで納得するでしょうけど、同時に何てメンドくせえんだとも思うでしょう(笑)。実際僕自身がハマってましたから(笑)。

そして、もっと言うと、Lispコンパイラはたまたま最初に見つけたo!-symbol-pが発見出来なかった、ってんで警告を発してコンパイルを中断したワケなんですけど、良く良く考えてみると、LOLと言う本の性質から考えて、あらゆるマクロ/関数はファイル内部で依存しあってるのは自明です。o!-symbol-pだけ最初に評価しとけば済む、って話じゃないわけです。考えただけでアタマがクラクラしてきますね(笑)。他にもまだ潜在的に色々な障害があるってのが予想出来ますから。

一体このマクロ展開とコンパイル自体のタイムラグはどうやって修正すんの?

Eval-When?

テキスト勉強中にしこしこREPLにコード打ち込んて動かしたり、あるいは、テキストエディタにLispコードを書いて部分的にS式を評価して実行する以上、上に書いたようなコンピレーションの問題は具現化しません。しかしそれじゃ面白くない。

ポール・グレアムがOn Lispと言う言葉で表現したかったのは、Lispでプログラムを書く、と言う事は裸のLispの上にレイヤーを構築していって、思い通りの言語体系を築き上げて、目的のアプリケーションを書くのに使う、と言う事です。と言う事は他の言語に比べてもフレームワーク作成の重要性が極めて高い、と言う事でもあり、何て事のない小さなプログラムを書いてもいずれ大きなアプリケーションの一部になる可能性が常にある、と言う事でもあります。

つまり、Lisp程コードの再利用が重要な言語もないわけです。かつ、コードを再利用する、と言う事はファイルに記述して保存しておかないとならない。しかし、単純にファイルに記述して保存した途端、上に挙げたようなコンパイル時のトラブルが待ち構えています。困ったもんだ。

もう一回上の例を鑑みて状況を整理すると、あるマクロ展開時にそのマクロに必要な関数が評価されていれば問題は起こらないと言う事です。つまり、恣意的に一部分の関数が先行評価されていれば良い。その方法は?と言うのがここでの議題なんです。

LOLはマクロ記述の為の指南書なんですが、残念ながらその手の方法に付いては全く記述していません。つまり、それなりにCommon Lispの知識を持ってるのが前提なんですが、ところが、先に書いたようにその割には最初の数章がロクにCLに付いて知識が無い人間を前提にしたような記述をしている。想定読者が意味不明だ、って言った理由が分かるでしょ(笑)?んで、この手のトラブル対処法を知ってる人なら当然マクロに付いても既に豊富な知識がある筈だって事を言ってたわけなんです。

さて、この問題に対処する為には暫定的には次の三つの対応策が考えられます。

1. 常にREPL上で必要な関数をメンド臭くても先に評価しておく。


2. eval-whenを使う。


3. ASDFを用いてシステムとしてパッケージ化してしまう。

テキストの例に上がっているコードをREPLでシコシコ評価して勉強している以上、1番の方策は当然アリです。が、考えただけでもメンド臭いですよね(笑)。じゃあ、何かのマクロを書いて、それに必要な関数は別なファイルに纏めておいて、先にCLにロードして評価してしまう、ってのもアリかもしれません。が、いずれにせよちとメンド臭い。後々の事を考えると当然ですよね。defmacro!を利用する為に別のファイルにわざわざまとめておいたg!-symbol-pやo!-symbol-pを先にロードする……まあ、やっても良いかもしれませんし、悪くは無いんですが、頻繁にそれ、ってのも困ります。特にコードの再利用を考えると手順はメンド臭くない方が良いわけです。

2番目のeval-whenを使う、と言うのがまさに直接的な回答かもしれません。まさしくこれが、恣意的に先行評価を起こさせる特殊オペレータだから、です。ところが、問題は…手元の資料を見る限り、解説されてないんですよね(笑)。使い方が(笑)。今までの流れを考えると、これだけ大事な特殊オペレータなんですが、ほぼシカトされています(笑)。Common Lispの本書く人は「Lispは実用に使える言語だ!」って前書き辺りで強調するケースが多いんですが、見てきた通り、ファイルに纏めると問題発生、しかもその解決策を書いてないんだったら絵に描いた餅だろう、とか思うんですけど(笑)。

唯一、eval-whenに付いてマトモにページを割いてるのは実践Common Lispくらいですね。この著者はさすが著書に「実践」って名づけるだけあって、アプリケーション作成に於いて何が問題になるのか良く知っています。抽象論にしていない。

原書サイトで解説書いてあるんで、読んでみても良いでしょう。一部日本語訳から抜粋してみます。今まで記述してきた問題点を端的に表現しています。

DEFMACROの展開形にはEVAL-WHENが含まれているので、そのファイル内でマクロを定義した直後から使うことができる。しかしマクロを定義しているファイルでマクロを使うには、マクロだけでなく、マクロが使っている関数もすべて定義されている必要がある。ところがDEFUNでは、通常はコンパイル時に関数が有効にならない。そこでマクロが使うヘルパー関数のDEFUNをすべて:compile-toplevel付きのEVAL-WHENで包むことにより、マクロの展開関数が走るときにその定義が使えるようになる。場合によっては:load-toplevelと:executeを付けてもよいだろう。ファイルのコンパイルやロードの後、もしくはコンパイルする代わりにファイルをロードする場合は、関数の定義が必要になるからだ。

実践Common Lisp

ぶっちゃけ、僕も実践Common Lispは読んだ事は読んでたんですが、すっかり失念していました(笑)。プログラミングでは実際にトラブルに見舞われないと、重要な示唆がどれだけ重要か、って実感出来ないんですよね。困ったもんです。

なお、eval-whenはMacLisp由来だそうで、確かに同じくMacLispの直系の子孫であるEmacs Lispのファイルではeval-when-compileと言う記述を良く見かけます。Emacs Lispを書いている人にはひょっとしてお馴染みなのかもしれません。

Altanative 3: ASDF

さて、第3の選択肢で、ここで扱うのがASDFです。eval-when自体がロクな解説が無いんで嫌ってたんですけど、実はASDFに関しては輪をかけて解説が書いてある書籍が無いです。

じゃあ何でASDFなんだ?それ以前にASDFって一体何なの?端的に表現すると、ASDFとはCommon Lisp用のMakefileです。つまり、ファイル同士の依存関係をハッキリさせて順序良くコンパイルしてロードするように指定する仕組み、なんです。と言う事は、(asdf:operate 'asdf:load-op ...)と言うのは、言わば、GNUのツールで言うmakeなんです。

そして概念的にはMakefileだ、と言う事は、当然eval-whenが必要になるような場面でも、明示的にeval-whenを指定しなくても全て解決してくれる、と言う事です。非常に有難い仕組みなんですよ。使う分にはね。少なくともLinux系のOSでアプリケーションのインストールでmakeを使うよりゃメンド臭くない。

@valvallowさんがブログでOn Lisp と Let Over Lambda のコードって一挙に紹介してたんですけど、僕が何故これやらなかったのか、と言うと、前述の通り、ファイルのコンパイル/ロードで面倒な事になる、って知ってたから、です。と言うかこの記事が上がる前に既になってた(笑)。そして、何故Debian配布のOn Lispのコードにこだわってたのか、と言うのも、この手のコンパイル/ロードに関して言うと面倒が無いから、です。debヴァージョンはASDF化してる。使う分にはラクチンで殆ど何も考えなくて良いのがASDFと言うシステムなんです。

反面、自分でMakefileを作る、もとい、ASDFを設定する、ってのはメンド臭いです。何せ資料となる書籍が無い、んで。僕自身も過去何度か挑戦したんですが、失敗してメンド臭くなっちゃった(笑)。ASDFに付いて少しでも記述してるのがまたもや実践Common Lispだけ、と言う有り体なんですが、そこでもこんな事が書いてあります。

ASDファイルの他の例については、Webで入手できる本書のソースコードが参考になるはずだ。実践の各章で使ったコードは、適切な内部システム依存関係と一緒に、システムとしてASDファイルに記述されている。

実質これしか書いてないんです。事実上、ｸﾞｸﾞﾚｶｽと言ってるわけですよ(笑)。とは言っても日本語で読めるASDFの解説なんて知りませんし、結局英語のマニュアル読まなアカンのか(笑)。うげえメンドくせえ。そもそもマニュアルなんて母国語でさえ読みたくねえシロモノなのに(笑)。そうだろ、皆の衆(笑)?

とは言っても、Lisp勉強していくうちに、そのうちCommon Lispで書かれたアプリケーションを配布したい、と言うような野望がある人もいる事でしょう。CLでのexecutablesの作り方、ってのは謎の部分が多いんですが(マジで多い)、それに比べればASDFはまだ敷居が低そうに見えます。なんせ所詮Makefileですし。しかも前項までの問題、要するにeval-whenにまつわる問題も解決してくれる。一石二鳥です。

てなわけで実践Common Lispの配布コードと首っ引きになってASDFの設定方法を分析していました。再度挑戦です。ここいらでASDFにカタ付けといても良いだろ、と言う個人的動機と、日本語で書かれたASDFの説明がほぼない、って辺りで良いイントロダクションになれば良いな、と言う二つの目的があります。まあ、専門家じゃないんで勘違いもあるかもしれませんが、そこはブログ記事なんで、適当に補完出来る人はより正確な記事を書いてみてください。あとは任せた(笑)。

ところで、ASDFに入る前にCLのパッケージと言われるシステムに付いて軽く解説しておきます。本当はやりたくねえんだけど(笑)、これ解説しとかないとワケワカメなんでしょーがない。

What the FUCK are Packages?

パッケージとは、端的に言うとCommon Lisp上での名前空間を分離/分割する仕組みです。そしてこの存在に絡んでCLerとSchemerがまた喧嘩してんですよね(笑)。んなもんどーでもいいだろ、とか第三者的には思うんですが(笑)。当然、CLにはパッケージがあるけどSchemeには無い(※1)。そしてCLerに言わせると、このパッケージと言う仕組みがCLの設計の根幹を握っているらしい。

余談ですが、ポール・グレアムは独自に新しいLisp方言Arcを設計しています。んで、このArcには名前空間を分割する為のパッケージ、って仕組みが入ってない模様です。んで、当然の如く、Arcを試した層から「Arcにはパッケージが無いの?」と言う質問を受けたらしい。ポール・グレアムはそれに付いてこんな感じで回答していました。

パッケージが必要になったらArcに組み入れようとは思っている。ただ、個人的にはパッケージが必要だ、って思った事は一度もないんだ。

まあ、前にも指摘したんですが、ポール・グレアムはCommon Lispに関しても、自分の好きな機能にはページを多く割く傾向があって、反面自分が好きじゃない機能に関してはページをそんなに割きません(笑)。ANSI Common Lisp読んでも、パッケージに関する解説はちょっとばっかし、です。あんま使ってないんでしょうね(笑)。同様に構造体は好きだけどCLOSはあんま好きじゃない、って事も分かります(笑)。この辺、色んな意味で実践Common Lispの著者、Peter Seibelと極めて対照的です。

さて、本題に戻ると。Common Lispはちょっとしたデータベースのような仕組みになっています。例えば次のようにREPLに入力する。

	CL-USER> 'hoge
	HOGE
	CL-USER>

view raw reaction-of-repl.lisp hosted with ❤ by GitHub

hogeと言うシンボルをREPLに入力するとHOGEと表示する。Schemeなんかを鑑みても、Lisp系の言語だと当たり前の反応なんですが、実はこの時点でCommon Lispでは背後でHOGEと言うシンボルをデータベースに登録しています。このデータベースはシンボル専用のデータベースで、平たく言うとこれがパッケージです。そして、ここで使われているパッケージがCL-USER(本当はCOMMON-LISP-USERと言う名称)のパッケージです。プロンプトに表示されているCL-USERと言うのはこのデータベース、もとい、パッケージ名を表しているんです。

つまり、REPLでシンボルを入力する度に新しいシンボルだったらCommon Lispはパッケージと呼ばれるシンボル用データベースにそのシンボルを登録していきます。これをCLではシンボルをパッケージにインターンすると言います。もし登録済みのシンボルだったら、当然その中身を調べるわけですよね。つまり変数なのか関数なのか、はたまた属性リストなのか、と。端的に言うとこれがCLがユーザーに見えない部分で行っている事で、Schemeに比べると遥に複雑な事をやってるわけです。

ついでに言うと、表面的にはSchemeで言うstring->symbolとCLのinternは結果だけ見ると似たようなモノに見えるんですが、実は意味が違うんです。Schemeのstring->symbolは字面が表している通り単に文字列をシンボルと言う型に変換してるんですが、CLのinternの目的と言うのは、もちろん文字列をシンボルに直すんですが、むしろ明示的にパッケージにシンボルを登録する事、なんです。

	CL-USER> (intern "HOGE")
	HOGE
	:INTERNAL
	CL-USER>

view raw experiment-about-intern.lisp hosted with ❤ by GitHub

internは見た通り、多値関数です。返り値が二つある。最初の返り値は"HOGE"をシンボルに直した表現が表示されていますが、二つ目の返り値は:INTERNALとなっている。これはつまり、「CL-USERと言うパッケージには登録済みのシンボルだよ」と教えている。何故かと言うと、先ほどREPLでhogeと入力していますからね。新規にinternすると、この部分はnilと表示される筈です。

そしてここで分かる事が一つあります。現時点REPLではCL-USERと言うパッケージを対象にしていました。当然CL-USERだけが唯一無二のパッケージ、ってわけじゃあない。他にもパッケージが存在する(※2)し、また独自にパッケージを作る事さえ出来ます。このパッケージ作成の為のマクロをdefpackageと言います。

以降、比較的Common Lisp入門の例が分かりやすいんでそれに準じてみます。

	CL-USER> (defpackage :東京 (:use :common-lisp)) ;東京パッケージを定義
	#<PACKAGE "東京">
	CL-USER> (in-package :東京) ;東京パッケージに変更
	#<PACKAGE "東京">
	東京> '支店長 ;シンボル支店長を東京パッケージにインターン
	支店長
	東京>

view raw tokyo-package.lisp hosted with ❤ by GitHub

上の例では、最初にdefpackageで東京パッケージを定義しています。本体部に(:use :common-lisp)と記述しているのは、CLの基本機能を提供しているCOMMON-LISPパッケージを利用しろ、と言う指定です。(CL-USERとはまた別物。ちなみに短縮形はCL。)これが無いと東京パッケージに入った途端にCommon Lispの全機能が使えなくなると言うようなおマヌケな事態に陥るので忘れないようにしましょう(笑)。言わば要請されたデフォです(笑)。

二つ目の(in-package :東京)でCL-USERから東京パッケージに入っています。in-packageと言うのがパッケージ間を行き来する為のマクロです。ここが実行されるとプロンプトが東京に変更されたのが分かるでしょうか?Lispbox/Emacs + SLIMEは親切な事に現時点どのパッケージにいるのか表示してくれます。

そして、三つ目のREPLでの支店長の評価により、シンボル支店長は東京パッケージへとインターンされます。

続いて、次のようにしてみます。

	東京> (defpackage :大阪 (:use :cl)) ;大阪パッケージを定義
	#<PACKAGE "大阪">
	東京> (in-package :大阪) ;大阪パッケージに変更
	#<PACKAGE "大阪">
	大阪> '支店長 ;シンボル支店長を大阪パッケージにインターン
	支店長
	大阪>

view raw osaka-package.lisp hosted with ❤ by GitHub

殆ど同じなんですが、三つ目に注目してください。先ほどはシンボル支店長は東京パッケージにインターンされました。今度はシンボル支店長は大阪パッケージにインターンされています。これが何を意味してるか、と言うと東京の支店長と大阪の支店長は全く違うシンボルだと言う事です。全然別人だ、と言う事ですね(笑)。これを次のようにして確かめてみます。

	大阪> (defparameter 支店長 1) ;大阪の支店長を 1 と定義
	支店長
	大阪> (in-package :東京) ;東京へ移動
	#<PACKAGE "東京">
	東京> (defparameter 支店長 '(a b c)) ;東京の支店長を (a b c) と定義
	支店長
	東京> (in-package :大阪) ;大阪へ移動
	#<PACKAGE "大阪">
	大阪> 支店長 ;大阪の支店長を評価すると 1 になる
	1
	大阪> (in-package :東京) ;東京へ移動
	#<PACKAGE "東京">
	東京> 支店長 ;東京の支店長を評価すると (a b c) になる
	(A B C)
	東京>

view raw each-shitencho.lisp hosted with ❤ by GitHub

東京の支店長と大阪の支店長が全くの別人、もとい、別のシンボルになってる、って事がお分かりでしょうか。

では東京パッケージから大阪の支店長を参照する事が出来るのでしょうか?出来ますが、原則そう言う場合はシンボルをエクスポートしないとなりません。その為には関数exportを用います。

	東京> (in-package :大阪) ;大阪へ移動
	#<PACKAGE "大阪">
	大阪> (export '支店長) ;シンボル支店長をエクスポートする
	T
	大阪> (in-package :東京) ;東京へ移動
	#<PACKAGE "東京">
	東京> 大阪:支店長 ;大阪の支店長を参照する
	1
	東京>

view raw example-of-export.lisp hosted with ❤ by GitHub

実はASDF自体がパッケージで、asdf:operateとかasdf:load-opとか、やたら名称が長くまたコロンが多用されているのもこれらがexportされたシンボルだから、なんです。CL-USERと言うデフォルトのパッケージでASDFと言う別パッケージのシンボルを利用するにはああ言う記述方法を用いる必要があり、パッケージに於いてはコロンは「～パッケージの」と言う意味になってるわけです。

しかし、場合によっては、コロン多用による記述がメンド臭い場合があります。そう言う場合、次のようにして明示的にシンボルをインポートしたパッケージを定義出来ます。

	東京> (defpackage :名古屋 (:use :cl) ;名古屋パッケージを定義
	(:import-from :大阪 :支店長)) ;大阪パッケージからシンボル支店長をインポート
	#<PACKAGE "名古屋">
	東京> (in-package :名古屋) ;名古屋へ移動
	#<PACKAGE "名古屋">
	名古屋> 支店長 ;名古屋の支店長は大阪の支店長と同一人物?
	1
	名古屋> (in-package :大阪) ;大阪へ移動
	#<PACKAGE "大阪">
	大阪> 支店長 ;大阪の支店長は名古屋の支店長と同じ値を返す
	1
	大阪> (in-package :名古屋) ;名古屋へ移動
	#<PACKAGE "名古屋">
	名古屋> (eq '支店長 '大阪:支店長) ;名古屋の支店長と大阪の支店長は同一人物!
	T
	名古屋> (in-package :東京) ;東京へ移動
	#<PACKAGE "東京">
	東京> (eq '支店長 '大阪:支店長) ;東京の支店長は大阪の支店長とは別人!
	NIL
	東京>

view raw example-of-import-from.lisp hosted with ❤ by GitHub

また、あるパッケージの全機能を使いたい場合、次のようにしてパッケージを定義すれば良いです。

	東京> (defpackage :京都 (:use :cl :大阪)) ; cl の他に大阪パッケージを use するように指定
	#<PACKAGE "京都">
	東京> (in-package :京都) ;京都へ移動
	#<PACKAGE "京都">
	京都> 支店長 ;大阪からエクスポートされた全シンボルは京都パッケージに共有される
	1
	京都> (symbol-package '支店長) ;京都の支店長は大阪の支店長であることが分かる
	#<PACKAGE "大阪">
	京都>

view raw kyoto-package.lisp hosted with ❤ by GitHub

これでパッケージの使い方の基本は全部見ました。パッケージとは要するに名前保護の為のシステムであり、また、明示的にあるパッケージからシンボルをインポートしたりエクスポートしたり、と言う事が出来るのです。Schemeと比べると遥に複雑ですし、最初からこれを真っ正面から取り上げている本は、それこそCommon Lisp入門くらいしかない、んですが、これを煩わしいと感じるか否か、ってのも正直人に依るとは思います。しかしASDFを取り上げる以上、このシステムは避けて通れないのは事実、なんです。んで、ぶっちゃけた話、ポール・グレアムがANSI Common Lispを記述した1995年辺りでは、ASDFそのものが恐らく存在してなかったんでしょう。パッケージ自体の歴史は長いにも関わず、ASDFのせいで近年異様にパッケージの重要度が上がってきた、と思います。

最後に一つだけ。CLerとSchemerの諍いの大体の元凶はマクロに付いて、なんです。LOLでもSchemeの衛生的マクロが批判されていましたが、両者ともマクロの事になるとアツくなる。特に名前の衝突に付いての話になると両者とも譲らないのです(笑)。

ここはパッケージの話を書いてる筈なのに何でいきなりマクロ、しかも名前の衝突、なんて話が出てくるんだ?と思う人もいるでしょうが、実はCLerはこのパッケージと言う仕組みそのものがCLのマクロを支えている、と考えている。そして極論を言うと、Schemeはパッケージを持たない辺りがダメなんだ、と考えている。その部分だけちょっと説明しておきます。

最初にREPLでシンボルを入力するとパッケージにインターンされる、と言う話をしました。その途端そのシンボルはパッケージに保護されるわけです。つまり、どのシンボルでも何らかの形でどっかのパッケージにインターンされてるわけです。たった一つの例外を除いては。それがgensymで生成されるシンボルなんです。

つまり、原則的にどのシンボルでもどっかのパッケージにインターンされて、何らかの方法で参照出来る、と言う建前があるが故に、どのパッケージにもインターンされない、つまり参照出来ないシンボルが生成出来ると言うカラクリが成り立つわけですよ。これがなかなか上手い手を考えたもんだな、と(笑)。CLerの主張とは、こう言った上手い手無しにマクロが書けるか?とSchemeを非難してるわけですね(笑)。

LOLで書いてたgensymの説明、と言うのは、今までやってたパッケージの動作とシンボルのインターン、と言うコンセプトを掴めばより分かりやすいのではないか、と思います。抜粋してみます。

Common Lispでは、シンボル(名前)はパッケージに結び付けられる。パッケージはシンボルの集合であり、与えられた文字列、つまりそのシンボルのsymbol-name文字列を使って、パッケージからシンボルを指すポインタが得られる。このポインタ(通常単にシンボルと呼ばれる)の最も重要な性質は、同じsymbol-nameでそのパッケージから探索された他の全ポインタ(シンボル)との比較が、eqで行われることである。gensymはいかなるパッケージにも属さないシンボルであり、そのシンボルとeqになるシンボルを得られるsymbol-nameは存在しない。名前を付ける必要なしに、1つの式の中で、あるシンボルが他のシンボルとeqとなるようLispに指示したい場合、gensymを使う。プログラマが名前付けを一切行わないため、名前の衝突は発生し得ない。

※1: もちろん、処理系によってはパッケージを持ってるSchemeもあります。中でも印象に残ってるのはScheme48と言う処理系です。CLばりのパッケージを持っていて、何とSRFIを使おうとしてもシンボルが保護されていてインポートしないと使えない、と言うのが強烈でした(笑)。

この辺のライブラリの扱いに対しても、処理系作成者の解釈/判断の余地が大きく、結局処理系間でポータブルなコードを書くのが難しくなる、と言うのがSchemeの特徴です。

移植性のあるSchemeのコードを書くのはCommon Lispで書くのより骨が折れる。

実践Common Lisp

※2: ではデフォルトでは一体いくつくらいパッケージがあるのでしょう?CLHSによると、仕様で標準として最低限要求されているパッケージは次の三つです。

• COMMON-LISP: Common Lispの中核機能が定義されたパッケージ


• COMMON-LISP-USER: デフォルトでユーザーと対話するパッケージ


• KEYWORD: キーワード(アタマにコロンが付いてるシンボル)がインターンされるパッケージ

この3つが最低限要求されているパッケージなんですが、逆に言うと、これさえ満たしていれば、実装次第でもっとパッケージを追加しても良い、と言う事です。つまり、CL処理系の背後では様々なパッケージが動いている、と言う事になります。

処理系で使われている全てのパッケージを一覧するにはlist-all-packagesと言う関数を用います。これは今現在使用されている全てのパッケージ名をリストにして返します。

なお、SBCLの場合ですが、デフォルトの状態で次のようにREPLに入力

(loop for i in (list-all-packages) counting i)

してみると、49と言う数値を返してきます。つまり、SBCLのREPLの裏では49個ものパッケージが連帯しながらCL-USERパッケージを通じてユーザーと対話しているのです。

BASIC OF ASDF

と言うわけで、前項のパッケージの基本を踏まえてASDFの作成方法を記述していきます。ここでは、Lispプログラムとしてはマジでクダラないコードを扱う事にします。それこそ、Hello, World!って表示される程度でいい、と。その方がASDFの記述方法に集中出来るってなもんです。つまり、

(defun hello-world ()
  (princ "Hello, World!"))

を対象のコードとします。

ASDFのファイル構成は次の三つが基本、です。

1. packages.lisp


2. プログラム本体のlispファイル


3. asdファイル

これら三つのファイルがシステム定義を構成していて、これらの外枠のディレクトリ(あるいはフォルダ)内に存在すればいいわけです。ここではHello, World!と表示されるだけのプログラムとも言えないプログラムを用いてるんで、単純にhelloディレクトリをHOMEディレクトリ内に作る形とします。

まずはpackages.lispから。これは前項見た通り、プログラムが所属する(正確に言うと、プログラムが用いているシンボルがインターンされる)パッケージを定義します。雛形は次のような形です。

	(in-package :cl-user)
	(defpackage :パッケージ名
	(:use :common-lisp) ; common-lisp 以外でも使いたいパッケージがあれば指定
	;; (:export :プログラムファイル内で使ってるエクスポートしたいシンボル名
	;; :複数列挙化)
	)

view raw template-of-packages.lisp hosted with ❤ by GitHub

第一行目は、取りあえずこのパッケージ定義がどのパッケージ内で読まれるのか指定しています。デフォルトでCL-USERで読まれればまあ問題が生じないんで、CL-USERに移動しておきます。三行目以降でプログラム本体で使われているシンボルがインターンするべきパッケージを定義します。ここでCOMMON-LISPパッケージをuseするのを忘れないようにしましょう。もう一回繰り返しますが、COMMON-LISPパッケージがCLの中核の機能を定義しているパッケージなんで、これがないとCLの全機能が使えません(笑)。あと、exportはお好きなように。この例のHello, World!を表示するだけのようなクダラないプログラムでは、本体定義であるhello-worldと言うシンボルをエクスポートします。

	(in-package :cl-user)
	(defpackage :hello
	(:use :common-lisp)
	(:export :hello-world))

view raw packages.lisp hosted with ❤ by GitHub

このパッケージ定義を受けて2番目の本体のプログラムは次のようになります。

	(in-package #:hello)
	(defun hello-world ()
	(princ "Hello, World!"))

view raw hello-world.lisp hosted with ❤ by GitHub

第一行にシンボルをインターンさせたいパッケージに移動する旨を定義します。この場合は当然、明示的にpackages.lispで定義されたパッケージ(helloパッケージ)へと移動する、って事ですね。そこさえ書いておけばプログラム本体はフツーに書いて構わない。

なお、この例(hello-world.lisp)ではin-package指定の部分に#を含んでいますが何故かは知りません(笑)。単に実践Common Lispの公式サイトで配布しているソースコードを調べた際に含まれていたんで従ったまで、です(笑)。CL-PPCREも調べてみたんですが、そっちには付いてませんでしたね。もう一つ言うと、一応ASDFのマニュアルもザーっと眺めてみたんですが、特に何も書いてませんでした(笑)。だから、あってもなくても構わないんじゃねえのかな(笑)?良く分からんわ(笑)。

さて、この時点で一つ分かる事があります。それはhello-world.lispはpackages.lispに依存していると言う事です。これは当然ですよね。hello-world.lispはあるパッケージへと移動する旨があるのに、最初にそのパッケージが生成されてなければ意味がないから、です。逆に言うと、最初にパッケージが定義されてからプログラム本体が読み込まれないとならない。この手の依存関係を指定するのがasdファイルです。

asdファイルの雛形は次の通り。

	(defpackage :システムパッケージ名 (:use :asdf :cl)) ;システムパッケージを定義
	(in-package :システムパッケージ名) ;システムパッケージへ移動
	(defsystem システム名
	:name "システム名" ;システム名表示
	:author "" ;著作者名表示
	:version "" ;ヴァージョン番号表示
	:maintainer "" ;メンテナ名表示
	:licence "" ;ライセンス表示
	:description "" ;短い解説表示
	:long-description "" ;詳細な解説表示
	:components ;システム内のファイル設定
	((:file "packages") ;packages.lisp の読み込み
	(:file "" :depends-on ("packages")) ;プログラム本体ファイルの読み込み( packages.lisp に依存)
	;; 複数列挙可
	)
	;; :depends-on () ;依存する外部システム
	)

view raw template-of.asd hosted with ❤ by GitHub

一行目でシステムとしてのパッケージ名を定義します。これは先ほどpackages.lispで定義したパッケージとはまた別です。が、簡便性を優先して、packages.lispで作成したパッケージ名に-systemでも付けた形にしておけば良いでしょう。packages.lispでhelloと言うパッケージを定義してたらasdではhello-systemと言うように。

もう一つ重要なのは、このパッケージではclパッケージ(つまりCOMMON-LISPパッケージ)をuseするのは当然として、ついでにasdfパッケージもuseする事を指定します。これは当然、ここではasdfパッケージで定義された全機能を用いなければならないから、です。ついでに言うと、雛形では四行目以降でdefsystemと言う関数が用いられていますが、これはANSI仕様にはない関数で、ASDFパッケージで定義されているもの、です。従って、これを使う以上ASDFで定義されてエクスポートされたシンボルを全てインポートしないとならない。

正しくシステムパッケージを定義しておいて、二行目でそのシステムパッケージに移動しています。ここはまあ、いいですね。

四行目以降からdefsystemを用いて、色んな情報(ファイルの依存情報や外部システムへの依存情報を含む)を記述していきます。システム名は先ほど同ファイル内に定義したシステムパッケージ名とは別です。原理的にはpackages.lispで定義したパッケージ名とも別です。そして、ここがASDFにシステム名として認識されます。お好きなキャッチーな名前を付けましょう(そして、それがasdファイルの名前になるでしょう)。ここではシンプルにhelloシステム、と名づけます。

以降、:name～:long-descriptionはどーでもいいです(笑)。あっても無くても構いません。与えるものが文字列だ、って事さえ気をつければどう書いても構いません。

重要なのは:componentsです。ここでシステムに必要なファイル群とそれらの間の依存関係を指定します。つまり、今の場合はhelloディレクトリに含まれる3つのファイルのうち、packages.lispとhello.lispの二つのファイルの依存関係がどうなってるのか銘記しないといけません。そしてどのみち、システムを構成し、プログラム自体が記述された全.lispファイルはpackages.lispに依存するだろう事は分かりきっています(何故なら、それがプログラム本体で使われる全シンボルのインターン先を定義してるから、です)。

また、:componentsで指定するファイルには特に拡張子は付けません。

それで、結果としてhello.asdは次のようになります。

	(defpackage :hello-system (:use :asdf :cl))
	(in-package :hello-system)
	(defsystem hello
	:name "hello"
	:author ""
	:version ""
	:maintainer ""
	:licence ""
	:description ""
	:long-description ""
	:components
	((:file "packages")
	(:file "hello-world" :depends-on ("packages")))) ;hello-world.lisp は packages.lisp に依存

view raw hello.asd hosted with ❤ by GitHub

これで完成、です。UNIX系OSだったら

ln -s hello/hello.asd ~/ 

とでもして、hello.asdのシンボリックリンクをHOMEディレクトリに作成します。Windowsだったらasdf:*central-registry*で示唆されているフォルダ内にhello.asdへのショートカットを作成すれば良いでしょう。そしてREPLで(asdf:operate 'asdf:load-op :hello)とすれば(※)、

	CL-USER> (asdf:operate 'asdf:load-op :hello)
	; loading system definition from /home/cametan/hello.asd into
	; #<PACKAGE "ASDF0">
	; registering #<SYSTEM HELLO {AB3F071}> as HELLO
	NIL
	CL-USER>

view raw asdf-load-op-of-hello.lisp hosted with ❤ by GitHub

と表示されてシステムhelloは無事コンパイル/ロードされます。use-packageでhello-worldが使えるのか見てみましょう。

	CL-USER> (use-package :hello)
	T
	CL-USER> (hello-world)
	Hello, World!
	"Hello, World!"
	CL-USER> (symbol-package 'hello-world)
	#<PACKAGE "HELLO">
	CL-USER>

view raw test-of-hello-system.lisp hosted with ❤ by GitHub

上手い具合に動いていますね。シンボルhello-worldはエクスポートされてるんで、use-packageすればCL-USER内でhello-worldを参照出来る、と言う事です。

以上がASDFの基本的な定義方法の紹介です。

※: 繰り返しますが、Lipbox/Emacs + SLIMEだったらREPLでカンマ(,)、load-system、Enter、hello、Enter、です。

":depends on" in :components of a System

さて、今まで見てきた通り、これがASDFの定義方法の全て、です。んで、蛇足になり兼ねないんですが、システム内に一つのasdファイル、一つのpackages.lispファイルはともかくとして、本体のプログラムは複数の*.lispファイルに分散される場合がある、と言う事は自明だと思います。当たり前ですよね。

単純に、複数の*.lispファイルがある場合は、asdファイルの:componentsの欄に拡張子を外したファイル名を列挙すれば良い、って事です。必ずpackages.lispに依存している事を明記して。ただ、問題はそれら本体のファイル同士が何らかの形で依存している場合、です。

例えば、またクダラない例ですけど、hello-worldと言うプログラムが次のような二つのファイルに分散されている例を考えてみます。

	(in-package #:hello)
	(defparameter *h* "Hello, World!")

view raw string-of-hello-world.lisp hosted with ❤ by GitHub

	(in-package #:hello)
	(defun hello-world ()
	(princ *h*))

view raw body-of-hello-world.lisp hosted with ❤ by GitHub

body-of-hello-world.lispではプログラムhello-worldが定義されていますが、本体内で大域変数*h*が参照されています。そしてその*h*はこのファイル内では定義されていません。*h*は別のファイルであるstring-of-hello-world.lispで定義されている。つまり、言い方を変えると、body-of-hello-world.lispはstring-of-hello-world.lispに依存していると言う事です。

こう言う場合、asdファイルの:componentsの欄は次のように記述します。

	(defpackage :hello-system (:use :asdf :cl))
	(in-package :hello-system)
	(defsystem hello
	:name "hello"
	:author ""
	:version ""
	:maintainer ""
	:licence ""
	:description ""
	:long-description ""
	:components
	((:file "packages")
	(:file "string-of-hello-world" :depends-on ("packages"))
	;; body-of-hello-world.lisp は packages.lisp と string-of-hello-world.lisp に依存している
	(:file "body-of-hello-world" :depends-on ("packages" "string-of-hello-world"))))

view raw hello.asd hosted with ❤ by GitHub

:componentsの:fileの:depends-onはリストを取り、そこには複数の依存先ファイルを列挙出来ます。複数のファイルに依存する場合は、馬鹿正直に複数の依存先ファイル名を列挙すればO.K.です。

またREPLでhelloシステムが上手く動いているのかどうか見てみましょう。

	CL-USER> (asdf:operate 'asdf:load-op :hello)
	; loading system definition from /home/cametan/hello/hello.asd into
	; #<PACKAGE "ASDF0">
	; registering #<SYSTEM HELLO {B4E73E1}> as HELLO
	NIL
	CL-USER> (use-package :hello)
	T
	CL-USER> (hello-world)
	Hello, World!
	"Hello, World!"
	CL-USER> (symbol-package 'hello-world)
	#<PACKAGE "HELLO">
	CL-USER>

view raw test-of-hello-system.lisp hosted with ❤ by GitHub

上手い具合に動いてます。かつ、この時点ではpackages.lispに特に変更を加えていません。つまり、シンボルhello-worldはエクスポートされていますが、一方、大域変数*h*はエクスポートされていません。従って、CL-USERでhelloパッケージをuse-packageしても*h*は参照不可能です(※)。

	CL-USER> *h*
	The variable *H* is unbound.
	[Condition of type UNBOUND-VARIABLE]
	; Evaluation aborted.
	CL-USER>

view raw error.lisp hosted with ❤ by GitHub

もう一つ依存パターンを考えてみます。body-of-hello-world.lispには特に変更は加えませんが、string-of-hello-world.lispが別の二つのファイル、a.lispとb.lispに依存しているもの、とします。つまり、次の3つのファイルがpackages.lisp、body-of-hello-world.lisp、hello.asdと共にhelloディレクトリ内にある、とする。

	(in-package #:hello)
	(defparameter *a* "hello, ")

view raw a.lisp hosted with ❤ by GitHub

	(in-package #:hello)
	(defparameter *b* "World!")

view raw b.lisp hosted with ❤ by GitHub

	(in-package #:hello)
	(defparameter *h* (concatenate 'string *a* *b*))

view raw string-of-hello-world.lisp hosted with ❤ by GitHub

a.lispは大域変数*a*を定義、b.lispは大域変数*b*を定義していて、これらの間には相互依存関係はありません。一方、string-of-hello-world.lispは大域変数*a*と*b*を結合している。つまり、string-of-hello-world.lispはa.lispとb.lispに依存してるわけです。そしてbody-of-hello-world.lispはstring-of-hello-world.lispに依存してるんですけど、言い換えるとa.lispとb.lispに間接的に依存しているわけです。

こう言う場合のasdはどうなるのか、と言うと、次のようになります。

	(defpackage :hello-system (:use :asdf :cl))
	(in-package :hello-system)
	(defsystem hello
	:name "hello"
	:author ""
	:version ""
	:maintainer ""
	:licence ""
	:description ""
	:long-description ""
	:components
	((:file "packages")
	(:file "a" :depends-on ("packages"))
	(:file "b" :depends-on ("packages"))
	;; string-of-hello-world は packages.lisp、a.lisp、b.lispに依存している
	(:file "string-of-hello-world" :depends-on ("packages" "a" "b"))
	;; body-of-hello-world.lisp は packages.lisp と string-of-hello-world.lisp に依存している
	;; しかし、a.lisp と b.lisp への依存は明示しなくて良い
	(:file "body-of-hello-world" :depends-on ("packages" "string-of-hello-world"))))

view raw hello.asd hosted with ❤ by GitHub

ご覧のように、間接的に依存しているファイル名は明示しなくて構いません。あくまでpackages.lispのように、直接的に依存しているファイル以外は無視して結構です。従って、string-of-hello-world.lispの依存関係が解消された時点で、body-of-hello-world.lispはstring-of-hello-world.lispだけに依存している、と言うわけです。

※: 嘘です。ホントは無理矢理参照可能です。ただし、パッケージ、と言う名前保護のシステムの目的を考えると「エクスポートされていないシンボルを無理矢理参照する」と言うのは望ましくありませんし、実際、非推奨になっています。参照可能なシンボルは常にエクスポートされてる筈だ、と言う事で、ここでは「無理矢理参照する」方法は明記しません。

:depends-on the Other Systems

さて、今度はHOMEディレクトリにprint-name-of-functionと言うディレクトリを作成してみます。そこに次の三つのファイルを置いてみます。

	(in-package :cl-user)
	(defpackage :p-n-f
	(:use :common-lisp)
	(:export :print-name-of-function))

view raw packages.lisp hosted with ❤ by GitHub

	(in-package #:p-n-f)
	(defmacro print-name-of-function (str)
	(let ((name (map 'string #'(lambda (x)
	(if (string= x " ")
	#\-
	x))
	(remove-if-not #'(lambda (x)
	(or (string= x " ")
	(and (string<= "A" x)
	(string<= x "Z"))))
	(string-upcase str)))))
	`(defun ,(intern name) ()
	(princ ,str))))

view raw print-name-of-function.lisp hosted with ❤ by GitHub

	(defpackage :print-name-of-function-system (:use :asdf :cl))
	(in-package :print-name-of-function-system)
	(defsystem p-n-f
	:name "p-n-f"
	:author ""
	:version ""
	:maintainer ""
	:licence ""
	:description ""
	:long-description ""
	:components
	((:file "packages")
	(:file "print-name-of-function" :depends-on ("packages"))))

view raw p-n-f.asd hosted with ❤ by GitHub

前項までで見た通り、packages.lispではp-n-fと言う名前のパッケージを定義します。エクスポートするシンボルはprint-name-of-function.lispで使われるシンボル、print-name-of-functionです。

print-name-of-function.lispでは、関数を生成するマクロprint-name-of-functionを定義しています。このマクロは凄くクダラないんで、あんま解説したくないんですが(笑)、要するに適当な文字列を受けとると、

1. 文字列を全部大文字に変換する。


2. スペースと大文字のアルファベット以外を全て削除する。


3. スペースをハイフンに変換してこれを関数名としてインターンして、元々与えられた文字列を出力する関数を定義する。

だけです。クダラないんで、まあいいでしょう(笑)。これはこれとして(笑)。

p-n-f.asdもまあいいでしょう。基本的な設定方法にしか従ってません。またもや、UNIX系OSだったら、このp-n-f.asdのシンボリックリンクをHOMEディレクトリに張り(Windowsだったらasdf:*central-registry*で指定されたフォルダにショートカットを作り)、p-n-fシステムをREPLに読み込んでみます。

	; loading system definition from /home/cametan/p-n-f.asd into
	; #<PACKAGE "ASDF0">
	; registering #<SYSTEM P-N-F {B3F2391}> as P-N-F
	CL-USER> (use-package :p-n-f)
	T
	CL-USER> (macroexpand-1 '(print-name-of-function "Hello, World!"))
	(DEFUN HELLO-WORLD () (PRINC "Hello, World!"))
	T
	CL-USER> (print-name-of-function "Hello, World!")
	HELLO-WORLD
	CL-USER> (hello-world)
	Hello, World!
	"Hello, World!"
	CL-USER> (symbol-package 'hello-world)
	#<PACKAGE "COMMON-LISP-USER">
	CL-USER> (symbol-function 'hello-world)
	#<FUNCTION HELLO-WORLD>
	CL-USER> (symbol-package 'print-name-of-function)
	#<PACKAGE "P-N-F">
	CL-USER>

view raw test-of-print-name-of-function.lisp hosted with ❤ by GitHub

上手い具合に動いているようですね。ご覧になった通り、p-n-fパッケージにインターンされているシンボルを持つマクロprint-name-of-functionは受け取った文字列(この場合は"Hello, World!")を関数名に相応しいように修正し、それを今いるCL-USERパッケージ(「今いる」パッケージをカレント・パッケージと言います)にインターンして関数hello-worldを自動生成します。

もっとも、"Hello, World!"を印字する関数を作る為だけのマクロとしてはコード量がクソ多いんですけどね(笑)。全くしょーもない(笑)。でもこんな事も出来るわけです。

	CL-USER> (print-name-of-function "Fuck off!!!")
	FUCK-OFF
	CL-USER> (fuck-off)
	Fuck off!!!
	"Fuck off!!!"
	CL-USER>

view raw fuck-off.lisp hosted with ❤ by GitHub

くだんねえ(爆)。あんまりにもクダんないんで涙が出てきた(笑)。

ま、いっか(笑)。何故こんなクダラないマクロを作ったのか、と言うと、このprint-name-of-functionが定義されたp-n-fシステムをどうやってhelloシステムから呼び出すか、と言うネタが以降のネタなのです。要するに、システム同士の依存ってのが次のテーマです。

まず、helloディレクトリ内の改訂版packages.lispは次のようになります。

	(in-package :cl-user)
	(defpackage :hello
	(:use :common-lisp :p-n-f) ;パッケージ p-n-f も使用するように指定する
	(:export :hello-world))

view raw packages.lisp hosted with ❤ by GitHub

ここはまあいいですよね。ずーっと上の方にも書きましたが、ここでCOMMON-LISP以外にも必要になるパッケージがあったらそれも合わせてuseするって事です。今はp-n-fパッケージ(システムではない)が要り用になるのが前提なんで、p-n-fパッケージも指定しておきます。

次はプログラム本体部のコードです。今回はp-n-fパッケージに含まれているprint-name-of-functionマクロを使うのが前提なんで、ファイルhello-world.lispは次のようになっています。

	(in-package #:hello)
	(print-name-of-function "Hello, World!")

view raw hello.world.lisp hosted with ❤ by GitHub

簡単に定義出来ますが、もう一回次の二点を確認しておいてください。

1. packages.lispでhelloパッケージを定義している。そのパッケージは外部パッケージp-n-fからエクスポートしている全シンボルをuseしてるのが前提である。


2. hello.lispは一行目でhelloパッケージ内に移動する事を指定している。helloパッケージはp-n-fがエクスポートしている全シンボルを共有しているので、p-n-fパッケージで定義されているprint-name-of-functionマクロを使用可能である。

この二点が前提の為、ここでprint-name-of-functionを利用して関数hello-worldを定義出来るわけです。

最後にhello.asdです。それはこう言う風になります。

	;; hello-system 「自体で」 :p-n-f パッケージが要り用になるわけではない事に注意
	(defpackage :hello-system (:use :asdf :cl))
	(in-package :hello-system)
	(defsystem hello
	:name "hello"
	:author ""
	:version ""
	:maintainer ""
	:licence ""
	:description ""
	:long-description ""
	:components
	((:file "packages")
	(:file "hello-world" :depends-on ("packages")))
	;; 外部システムへの依存は :components 内ではなく、その外側の :depends-on で指定する
	;; 実際にここで指定してるのはシステムそのものではなく、外部システムの asd である
	:depends-on ("p-n-f"))

view raw hello.asd hosted with ❤ by GitHub

注釈を付けておきましたが、hello-systemと言うパッケージ自体がp-n-fパッケージに依存しているわけじゃありません。システム定義を良く考えてみたら分かりますけど、ここのパッケージはhelloパッケージにさえも依存していない、のです。あくまで、プログラムとしてのシステム全体を操作してるわけじゃなくって、単にファイルの読み込み順序や必要になる外部パッケージを指定してるのが、このシステムパッケージの役目だ、と言う事を覚えておいてください。

そして、必要になる外部パッケージは:components内で指定するのではなく、それとは別に:depends-onで指定します。ここで指定されてるのは外部システムそのものではなく、外部システム内に存在するasdファイルです。つまり、システムを纏めてあるディレクトリ自体を指定してるわけじゃあない、って事です。また、パス指定なんて高度な事をやってるわけでもありません。従って、要り用になる外部システムのasdファイルもasdf:*central-registry*にシンボリックリンクが張られている必要があります。この例だと、hello.asdのシンボリックリンクもp-n-f.asdのシンボリックリンクも(UNIX系OSでは)HOMEディレクトリ内に存在していないといけません。ASDFがhello.asdを呼び出した時、そこに書かれている定義に従って、asdf:*central-registry*内で、p-n-f.asdを探します。見つかったら、今度そこに書かれてある定義に従って、p-n-fパッケージをコンパイル/ロードします。見つからなかったらエラーを返す、と言う算段です(※)。

これで、(asdf:operate 'asdf:load-op :hello)したら、依存したシステムも合わせてコンパイル/ローディングされてCLに読み込まれます。

	; loading system definition from /home/cametan/hello.asd into
	; #<PACKAGE "ASDF0">
	; registering #<SYSTEM HELLO {B3DF161}> as HELLO
	; loading system definition from /home/cametan/hello.asd into
	; #<PACKAGE "ASDF0">
	; loading system definition from /home/cametan/p-n-f.asd into
	; #<PACKAGE "ASDF0">
	; registering #<SYSTEM P-N-F {AD9A771}> as P-N-F
	; compiling file "/home/cametan/hello/packages.lisp" (written 08 MAY 2010 11:33:31 AM):
	; compiling (IN-PACKAGE :CL-USER)
	; compiling (DEFPACKAGE :HELLO ...)
	; /var/cache/common-lisp-controller/1000/sbcl/local/home/cametan/hello/packages.fasl written
	; compilation finished in 0:00:00.114
	; compiling file "/home/cametan/hello/hello-world.lisp" (written 08 MAY 2010 11:35:41 AM):
	; compiling (IN-PACKAGE #:HELLO)
	; compiling (PRINT-NAME-OF-FUNCTION "Hello, World!")
	; /var/cache/common-lisp-controller/1000/sbcl/local/home/cametan/hello/hello-world.fasl written
	; compilation finished in 0:00:00.003
	CL-USER> (use-package :hello)
	T
	CL-USER> (hello-world)
	Hello, World!
	"Hello, World!"
	CL-USER> (symbol-package 'hello-world)
	#<PACKAGE "HELLO">
	CL-USER> (symbol-function 'hello-world)
	#<FUNCTION HELLO-WORLD>
	CL-USER>

view raw test-of-hello.lisp hosted with ❤ by GitHub

先ほど、直接REPLでprint-name-of-functionを使ってみた時と違い、定義された関数のシンボルhello-worldはパッケージhelloにインターンされている事に注目してください。関数internはカレントパッケージへとシンボルをインターンします。マクロprint-name-of-functionで関数hello-worldを生成したのはhelloパッケージ内、でした。従って関数生成時点では、カレントパッケージであるhelloへとシンボルhello-worldがインターンされたわけです。

※: ぶっちゃけ、Common LispでもSchemeでもパスの概念が丸っきりないんじゃないかって思う。歴史的に言うと、多分その通りで、そもそもこの二つはUNIX前提で生まれたわけではない。当然、ディレクトリ・ツリーなんて言うアイディアも元々UNIXのものなんで、そう言う概念には縛られてないのだろう。

特にCommon Lispの場合、そもそもこの規格がLisp OSのサブセットにあたる、と言う話である。かつ、「どのOSのシステムとも迎合化しない汎用のシステム」を目指したらしい。ワケ分かんね(笑)。

従って、良く分からないシステムを相手にする場合、この手のファイルのパス指定は、OS側に素直に任せておいて(例えばバッチスクリプト/シェルスクリプトを書く、シンボリックリンクを張る、とか)、CLやScheme内で解決しようとしない方が得策な感じがする。Rubyだったらこうはならねえんだろうな(笑)。

この辺に関しての話も、実践Common Lispの第14章や第15章辺りに記述が成されている。興味のある人はご一読を。

なお、ポール・グレアムがArcを作ろうと思った理由の一つは、現存主流OSとのこの手の相性の悪さにイライラしたから、らしい。また、ポール・グレアムはLispは好きだけどLisp OS嫌いで、Arc製作の段では「UNIXが勝った!」と気を吐いていた。いずれにせよ、Arcの目的の一つは、Perl/Rubyのように「UNIX系OSに密着した」Lispを作りたかった、と言う事らしい。

Well, that's almost all

まあ、これでASDFの殆ど全て、だと思います。知ってる範囲内では、と言う事ですけど。いずれにせよ、LOLやあるいはOn Lispを読んで勉強していきながら、どんどんASDFとして纏めて行った方がコードの再利用性を考えると得策だろう、と思います。ずーっとREPL開きっぱなしにしてるわけにも行かないしね(笑)。

最初の方にも書きましたが、CLでのexecutableの作り方、ってのは依然謎が多いです。個人的にはまだ良く分かっていません。経験上、executableを実験的に作って成功したのは、PLT Schemeのみ、と言う有様です(それでも謎が多いんですけど)。しかし、ソースファイルを含んだディレクトリをtarball(あるいはzip)に落としてアプリケーションを配布する、って夢に関して言えば、ASDFを用いればかなり近づける、とは思います。これは武器ですね。

最後に。アプリケーションを書く際、ディレクトリの中にサブディレクトリを配置して、それぞれをASDFに纏めるとする。でも全体で一つのアプリケーションとして動かしたい場合どうするか?その場合、トップディレクトリにアプリケーション名を冠したasdファイルを置いておけば暫定的に解決は出来るだろ、って事だけは言っときます。asdファイルは別のasdファイルを呼ぶことが出来るってのがヒントです。:componentとして、って事ですけれども。重要なのは全てのasdファイルがasdf:*central-registry*にシンボリックリンクを張っている、って事だけです。

LOL SEGMENT-READER

第3章。リードマクロよりSEGMENT-READER。
これも書くんなら、末尾再帰の方がエエんちゃうの?と思ったケース。

	;;; SEGMENT-READER
	;; Scheme-style
	(defun segment-reader (stream ch n &optional (acc nil))
	(labels ((iter (chars curr)
	(if (char= ch curr)
	(coerce (reverse chars) 'string)
	(iter (cons curr chars) (read-char stream)))))
	(if (< n 1)
	(reverse acc)
	(segment-reader stream ch (1- n)
	(cons (iter nil (read-char stream)) acc)))))

view raw segment-reader.lisp hosted with ❤ by GitHub

Doug Hoyte氏は「効率」を考えてdoを使ってんのかな?と思わせておいて、いきなり普通に再帰する、と言うワケの分からん事をする。この人のスタイルは、ぶっちゃけ支離滅裂なんだよな(苦笑)。
例えば、まあ、冗談として聞いて欲しいんですが、マジメに効率考えてdoを使え、ってのなら徹底して次のようにして書く事も可能なんです。

	;;; SEGMENT-READER with DO
	(defun segment-reader (stream ch n)
	(do ((n n (1- n))
	(acc nil
	(push
	(do ((curr (read-char stream)
	(read-char stream))
	(chars nil (push curr chars)))
	((char= ch curr) (coerce (nreverse chars) 'string)))
	acc)))
	((< n 1) (nreverse acc))))

view raw segment-reader-with-do.lisp hosted with ❤ by GitHub

冗談ですけどね(笑)。こんなコード読むの大変ですし。書くのも大変。ただ、分かって欲しいのは、そもそもdoの性質からしてletが要らないだろって事です。letが要らなければ本体部も要らない、っつー事です。

	CL-USER> (segment-reader t #\/ 3)
	あいう/えおか/きくけ/
	("あいう" "えおか" "きくけ")
	CL-USER>

view raw evaluation-of-segment-reader.lisp hosted with ❤ by GitHub

LOL SHARP-DOUBLE-QUOTE と SHARP-GREATER-THAN

実験も兼ねて。

valvallowさんを真似て、github使ってみようかな、と。
まあ、単に今のままでは、ブログにコード貼り付けると、<pre>タグ使っててもインデントがズレて嫌なわけですよ。どうにかなんねえのかな、とか思ってて。
んで、valvallowさんがgist使ってうまい具合にやってるんで、それを真似してみよう、って思ったわけです。で、まあ、gitそのものは要らなかったよね(笑)。gistとgitって違うみてえ(笑)。レポジトリ、なんて作らんで良かった、って話なんですが(笑)。単にアカウント取れば良かっただけの話、と言うオチ(笑)。

それはさておき。LOLをvalvallowさんに続いて読んでるわけですが。他の人の意見はともかくとして読みづれえ。
いや、地の文体がどーの、って話じゃないです。単にコードが読みづらいって話なんだよな(苦笑)。精読試みると引っかかっていけねえや。
第3章、リードマクロからもうこれが破壊的操作の嵐でさ(苦笑)。こんなんここまでやる必要あんのか?とかぶっちゃけ思ってしまいました。もちろん、効率性考えれば必要になるケースってのがあるんですが、僕が思うトコ、この著者って美的観点ってのが全くねえんじゃねえの、とか思ってるのです(笑)。不遜ですけどね。
いやね、実際問題。無頓着にコード書いてるようにしか見えないし、心情的にはSchemerの筈のポール・グレアムも「こりゃあねえだろ」と思うんじゃねえのかな、と(笑)。そこまでいかんでも、ここに列挙されてるコードを他の言語のユーザーが見たら

「不必要に括弧が多すぎ！これだからLisperはよお。」

とか思うんじゃねえのか、と(笑)。ケンケンガクガクですよ(笑)。マジな話でさ。

リードマクロって考え方自体は単純ですよね。単に関数書いてやって、それをset-dispatch-macro-characterで文字指定してやってその関数と関連付けちゃえばおしまい、です。普通にマクロ書くよりラクかもしれませんね。set-dispatch-macro-characterって長ったらしい名前もEmacs + SLIMEだったらEsc-Tabで補完しちゃえばラクラク記述可能です。Viva! Emacs!
問題はその関数の書き方だ。個人的には川合史朗さんが何でも再帰で記述してたような「ローカル関数を設計」してやった方が見た目スッキリすんじゃねえの?とか思うんですけどねえ。生粋のCLerだと違うのかな。doは副作用使う時は確かに便利なんですけど、このケースじゃそんなの多用する必然性がそんなねえんじゃねえの、って思いました。

	;;; SHARP-DOUBLE-QUOTE
	;; Scheme-style
	(defun |#"-reader| (stream sub-char numarg)
	(declare (ignore sub-char numarg))
	(labels ((iter (chars prev)
	(let ((curr (read-char stream)))
	(if (and (char= prev #\") (char= curr #\#))
	(reverse chars)
	(iter (cons prev chars) curr)))))
	(coerce (iter nil (read-char stream)) 'string)))
	(set-dispatch-macro-character
	#\# #\" #'|#"-reader|)

view raw sharp-double-quote.lisp hosted with ❤ by GitHub

まず最初。LOLのSHARP-DOUBLE-QUOTEを書き直したものです。多分Schemeやってる人はこっちの方が見やすいのでは、と思います。オリジナルのコードは破壊的操作しまくりですが、そのテの操作は一切止めています(笑)。
そもそも、Doug Hoyteって人はdefunの「暗黙のprogn」アテにし過ぎだろ、って気もしますしね。これは本読むと、結局欲しいのは(coerce (nreverse chars) 'string)なんですけど、これは単にdoの返り値にした方がいいんじゃねえの、って謎がまずあって。要するにオリジナルのコードはcharを破壊的にdoで弄くっていって、それはそれでほっといて、最後に(coerce (nreverse chars) 'string)なわけですよ。何じゃそりゃ、とか思って(笑)。Lispがどうの、って以前にそれじゃあ手続き型言語のfor文の書き方だろ(笑)。
一方、ignoreはCLHS見ても良く分かんなかったんで、そのまま挿入しています。ロジック考えると必ずしも必要である、とは思えないんですけどね。多分。ま、いいや、その辺はCLの流儀、と言う事で。

	CL-USER> #" " と \. を含みます。"#
	" \" と \\. を含みます。"
	CL-USER>

view raw evaluation-of-sharp-double-quote.lisp hosted with ❤ by GitHub

ってな感じで「Schemeっぽく」書いても問題なく動きますね。では次。

	;;; SHARP-GREATER-THAN
	;; Scheme-style
	(defun |#>-reader| (stream sub-char numarg)
	(declare (ignore sub-char numarg))
	(labels ((foo (chars curr)
	(if (char= #\newline curr)
	(reverse chars)
	(foo (cons curr chars) (read-char stream))))
	(bar (curr pattern pointer output)
	(if (null pointer)
	(reverse (nthcdr (length pattern) output))
	(bar (read-char stream) pattern
	(if (char= (car pointer) curr)
	(cdr pointer)
	pattern) (cons curr output)))))
	(let ((pattern (foo nil (read-char stream))))
	(coerce (bar (read-char stream) pattern pattern nil) 'string))))
	(set-dispatch-macro-character
	#\# #\> #'|#>-reader|)

view raw sharp-greater-than.lisp hosted with ❤ by GitHub

これも原版のコード見ても何が何だか……(苦笑)。いやあ、凹みましたよ(笑)。これもDoug Hoyte氏の手癖か何だか知らないんですが、やっぱりdefunの暗黙のprogn頼みのコードで。かつ破壊的操作をしまくりなんで、何が目的でどう操作してるのか、流れが掴み辛い。あんなにインデントが深くなる必要って全然ない、と思うんですけど。これも再帰に書き換えて、引数内処理した方がスッキリ決まるんじゃないか、って思いました。
暗黙のprogn頼みが何なのか、と言うと。要するに、データをループ回して操作して。それを置き去りにしてまた別にデータ持ってきてループ回してるわけです。それを逐次処理するってのがオリジナルのコードの狙いなわけですが。必要か、それ?とか思ってさ(笑)。
しかも脱出条件が良く分からん。何で(null pointer)が二ヶ所に渡って分散してんだか、皆目見当が付かなかった(笑)。「何じゃこりゃ?」ってのが正直なトコで。破壊的操作を無自覚に使ってるからそーなるんだとしか思えなかった(笑)。
そこで、上の関数ではローカル関数fooとbarを二つ作って凌いでいます。根本的に、この二つの関数って「独立」で構わないんですよ。オリジナルのコードでも最初のループって、結局一種のフラグ作りなんですよね。本当にやりたい事は後者のループが握ってるんです。だから、シンプルにfooでフラグを作って、barで本操作をする、って設計にしました。やりようによってはもっとシンプルに書けるやもしれません。

	CL-USER> #>END
	ここには何でも置けますよ: "、\、"#、や ># だって
	置けちゃう。この文字列の読み込みを終わらせるには...END
	"ここには何でも置けますよ: \"、\\、\"#、や ># だって
	置けちゃう。この文字列の読み込みを終わらせるには..."
	CL-USER>

view raw evaluation-of-sharp-greater-than.lisp hosted with ❤ by GitHub