今月19日より、国会図書館のデジタル化された資料のうち絶版等で入手困難なものに限ってインターネット経由で閲覧できるサービスが「個人向けデジタル化資料送信サービス」として開始したとのことで早速アカウント登録してみました。

• 「個人向けデジタル化資料送信サービス」の開始について（令和4年5月19日予定）（付・プレスリリース）｜国立国会図書館―National Diet Library

登録には現住所が確認できる身分証が必要で現在のところ約一週間程度で本登録が完了するようです。

おもしろそうな資料

本登録完了前からめぼしいもののリストを作成してみていましたが、コンピュータ関係は歴史がまだ半世紀程度のため文学や音楽に比べると発掘できる資料も少ない印象を持ちました。

Lisp関係でいうと、1980年代の第二次AIブーム&エキスパートシステム関係の資料や、各社で出していた技術レポート、あたりが現在入手困難かつ閲覧可能なものでしょうか。残念ながらbitのようなコンピュータ誌は廃刊になったものを含めて本サービスの対象外のようです(国会図書館内でしか閲覧できません)

ということで、ざっと眺めてみて目についたものを列挙してみます。

• 電子工業月報. 33(6)(344): Common Lispフォーラム報告 / 電子協
  • 1991年のCommon Lispフォーラムというイベントについての報告です。CLOS MOPについてのレクチャーや報告等がありました。Kiczales先生が急病で参加できず代打でJonL氏が担当したとのこと。JonL氏を囲む会も開催された様子。
• パラダイム融合言語の研究
  • 竹内郁雄先生の博士論文です。マルチパラダイム言語TAO/DAOがテーマ
• 電気通信研究所研究実用化報告. 31(11): 会話形LispシステムTAO/60
  • TAO/ELISの前身であるTAO/60についての資料は少ないので貴重。TAOの謎構文について理解が深まるかも。
• 財政金融ジャーナル. 27(4): 日本シンボリックス株式会社代表取締役社長杉本佳久氏に聞く
  • 当時、金融業界で活躍していたLispマシンについて日本シンボリックス社長が解説しています。エキスパートシステムとしての応用。
• NTT電気通信研究所研究実用化報告. 37(2): 知能処理用ワークステーションELIS
  • ELISについての特集があります。TAOの解説もあり。
• 沖電気研究開発. 57(1)(145): LispマシンELISのソフトウェア開発環境
  • こちらはELISを開発していた沖電気側からの報告。
• NTT R&D. 39(1): DIPS Common LISP言語処理系の開発
  • 国産メインフレームプロジェクトのDIPSでCommon Lispを動かしたという報告
• 事務と経営. 37(466): 〈LMI Lambda〉人工知能用プログラム開発と実行環境をサポート
  • まず、LMI Lambdaの記事が書かれていたことが凄い。エキスパートシステムブームが伺い知れますがLambda/Eは確かTI ExplorerのOEMだったと思うので実質TI Explorerです。
• NEC技報 = NEC technical journal. 45(4)(277): 人工知能言語―LISP,Prolog
  • NECが開発していたCommon LispであるNX-LISPについて結構詳しい解説があります。

まとめ

10年程前のプチLispブームの時の話ですが、「Lispは何も実用的なものを生み出したことがない。実用化されたことがない」などと放言する人をちらほら見掛けたりしました(現在でもたまにいるかも)。
当時のインターネットから検索できる資料では、ウェブが擡頭してくる以前の1980年代の資料は皆無に近く、国内の第二次AIブームやLispが関係してくるアプリケーションについての情報も手軽には入手できませんでしたが、国会図書館デジタルコレクションのお蔭で、上記の記事で取り上げたように金融や事務の業界でもニュースになったりはしていたという実態が手軽に確認できるようになってきました。
現在の第三次AIブームのDL/MLという手法/ツールとプログラミング言語のPythonに対応するものが、第二次ブームでのエキスパートシステムとLispとざっくり考えても外してはいないんじゃないかなあと思ったりです(ブームの規模は違えど)。

それはさておき、やはり、1980/90年代に刊行されていたComputer Todayのようなコンピュータ雑誌が閲覧できると嬉しいですねえ。

■

HTML generated by 3bmd in LispWorks 8.0.0

HyperSpecはANSI規格部分と規格成立までのイシューをまとめた部分とがありますが、イシューまとめ部には様々な処理系が登場します。
HyperSpec序文に登場する歴史的な処理系名と合せて、HyperSpecに登場する処理系をまとめてみました。

A-Lisp

• バージョン: 未詳

ユタ大学で作成されていたStandard LispベースのCommon Lisp処理系のようですが詳細は不明です。ユタ大学の文献でたまに目にするような?

Austin Kyoto Common Lisp (AKCL)

• バージョン: 未詳

オースティン大学でメンテナンスされていたKCLです。 後のGCLの元になりました。

Allegro Common Lisp

別名: Extended Common Lisp (ExCL)

• バージョン: 3.1、3.1.beta.22、4.0、未詳

現在も健在のAllegro Common Lispです。

CMU Common Lisp

• バージョン: 16d、未詳

現在も健在のCMUCLです。

Chesnut Lisp-to-C Translator

• バージョン: 2.0、未詳

Common LispからCへのトランスレータです。主に組み込み用途だったようですが、CLtL2あたりの機能までカバーしていたようです。

• https://github.com/binghe/chestnut

Golden Common Lisp

別名: GCLISP

Gold Hill社が1984年あたりから販売していた、Intel PC上で稼動したCommon Lispです。 フルセットのCommon Lispをサポートしたのは結構後(90年代)の様子。

• http://www.goldhill-inc.com/developer.html

HP Common Lisp

別名: HPCL-I

HPが販売していた、Standard LispをベースにしたCommon Lisp処理系です。ユタ大学と共同開発していたようでエコシステムはPortable Standard Lispと共用だったりするようです。 後にHPは、Lucid社の処理系をOEM販売するようになるので、区別するためにIが付いていると思われます。

Ibuki Common Lisp

• バージョン: Release 01/01、未詳

KCLを商用サポートで販売していたIbuki社の処理系

IIM Common Lisp

• バージョン: 3.4、未詳

Integrated Inference Machinesが作製していたLispマシン上のCommon Lispです。 1986年のAAAIでお披露目されたようですが、殆ど情報がありません。 しかし、CLtL2相当の機能が実装されていた様子なのと、バージョンが3.4の記載があるので、地道に開発が進んでいたか、どこかで運用されていたのでしょうか。

Kyoto Common Lisp

• バージョン: 3-Jun-87、9/16/86 on VAX、未詳

ご存知KCL。オブジェクトシステムは搭載していないのでCLtl1の機能についての話のみです。

Lambda Common Lisp

• バージョン: 未詳

LMI Lambda上のCommon Lispです。実際の所Lambda CLと呼ばれていたのかは微妙ですが、LMIのドキュメントにちょっと記載があります。

Lucid Common Lisp

別名: Sun Common Lisp

• バージョン: 2.0.3、2.1、2.1.3、3.0、3.0.1、4.0、4.0.0 Beta-1、4.1

Symbolicsと共に登場回数が非常に多いLucid CLです。
Lucid社はOEM戦略をとっていましたが、Sunのワークステーションとのセットがもっとも普及していた様子。
4.1というバージョンは倒産間際のバージョンですが、ANSI CL規格の成立とLucid社の倒産がほぼ同時期なのが無常です。

Macintosh Common Lisp

別名: Coral Common Lisp 別名: Macintosh Allegro Common Lisp (MACL)

• バージョン: 1.1、1.2、1.2.2、2.0、2.0b3、2.0p1、2.0p2、未詳

Coral→Franz→Apple と渡り歩いたため名称の変遷があります。 現在のClozure CLのご先祖です。

NIL

序文に登場するのみです。

PSL/PCLS

PCLSは、Portable Common Lisp Subsetの頭字語です。 PSLとあるように、ユタ大学で開発されていました。

Poplog Common Lisp

サセックス大学で開発されていた、Poplogという様々な言語が動く環境上のCommon Lispです。
現在はバーミンガム大学で開発が続けられているようです。

• https://www.cs.bham.ac.uk/research/projects/poplog/freepoplog.html

Symbolics CLOE

• バージョン: 未詳

SymbolicsのLispマシンのアプリをIntel PC環境に出荷するための環境です。 Lispマシンは高価なので、開発はLispマシンで行ない、アプリは廉価な環境で実現するというニーズに応えたもの。 ちなみにCLOEだけでも、それなりに開発はできたようです。

S-1 Lisp

S-1スーパーコンピュータで稼動したCommon Lispの前身のような存在です。 NILのコードがベースになっている様子で、S-1 NILとも呼ばれます。

Spice Lisp

Common Lispのベースになった処理系の一つで、後にCommon Lisp化しました。 CMUCL、SBCLの祖先。

Symboics Common Lisp

別名: Genera

• バージョン: 7、7.2、7.3、7.4、8.0、8.0.1、8.1、8.2、8.3、未詳

Symbolics LispマシンのGenera環境のCommon Lispです。 Symboics Common Lispという処理系名の筈ですが、Gereraと記載されていることが殆どです。 登場回数も非常に多く、Common Lisp規格にも結構な影響を与えていそうです。

TI Common Lisp

別名: Explorer

• バージョン: release 6.0、未詳

テキサスインスツルメンツ社のLispマシン: TI Explorer上のCommon Lispです。
Sybolics Gereraもそうですが、処理系名よりシステム(OS)名で記載されているようです。

Utah Common Lisp

別名: UCL

ユタ大学のCommon Lispです。 Standard Lispベースのようで、HP Common Lispや、A-Lisp、PCLS等と関連が深いようです。

VAX LISP

• バージョン: 2.2、未詳

DECのVAXで稼動したCommon Lispです。
商用処理系としては古参。

WCL

アプリのランタイムとして利用されることを主眼とした処理系です。

• https://github.com/wadehennessey/wcl

Xerox Common Lisp

別名: Envos Medley

LispマシンのInterlisp-D上のCommon Lisp。後にEnvos社に譲渡されました。

まとめ

HyperSpecのイシューでしか目にしない処理系もあったりするのですが、規格の改善には人知れず役に立ったりしているような所が面白いですね。

■

HTML generated by 3bmd in LispWorks 8.0.0

• タグの名寄せ方針を決定しました - Qiita Blog

こちらの記事を目にして、Qiitaの記事のタグcommon-lispや、Common LispをCommonLispに名寄せするというのを知りました。 名寄せ自体は必要なことだと思うのですが、今回のQiitaでの対応は、スペースが含まれている名前は削除したものを最優先とするとのことです。

Qiitaのcommon-lispタグを作成したのは、実はQiitaのLispエントリー作成一番乗りだった私なのですが、

• ANSI CL規格 ANSI INCITS 226-1994(S2018)での記述はCommon Lispになっている(空白なしは皆無)。
• ハイフン繋ぎは、パッケージ名として使われているのである意味正式な表記:"COMMON-LISP"、common-lisp
• Stack Overflowでは、common-lispで統一されていた。

あたりを鑑みてcommon-lispを作成しました。 なんだかんだで、Stack Overflowに合せたというのが一番大きい気はしますが、既にcommon-lispというタグで統一して運用されていた感はありました。
ちなみに、Stack Overflow jaのcommon-lispタグ作成も私です(単なる一番乗り) また、各サイトに於けるタグ表記に使える文字の制限なのですが、空白や_、-が使えたり使えなかったりするため、-を使って回避する、ということが多いようです。 なお、Zennも一番乗りだったのですが、-も_も使えないため、CommonLispとなりました。

CommonLisp でも良いじゃないか

と思いますが、CommonLispって気持ち悪いんですよね。 また、ちゃんとした見識を持つ人が、CommonLispという表記を使うということはほぼない、というのも大きい気がします。

CommonLispと書く人の多くは、

• 最近始めたばかり
• 昔ちょっと触っていた
• 独学でずっとやってきて他のCLerとやりとりをしたことがない

等の傾向がかなり高い印象なので、初学者の記事であったり、かなり偏った見識の記事であったりの指標のような存在に感じています。 ぶらさがり括弧のLispコードの親戚みたいなものでしょうか。

まとめ

Qiitaの件はCommonLispに向けて名寄せするということで、common-lispが廃止になったわけではありませんが、CommonLispを中心とすることで文化的にそっちに流れそうなのが嫌だなあという感じです。
せめて自分が愛好する言語の表記くらいは正しく表記したい。

■

HTML generated by 3bmd in LispWorks 8.0.0

Common Lispでは通常、エラーが発生するとデバッガが起動してきて後続の処理をどうするかを訊ねられますが、個人的にはあまり活用できていないので、デバッガ活用方法を模索して行きたいところです。
今回は、初心にかえってデバッガの使い方を点検してみましょう。

デバッガを終了させる

Common Lispを始めてまず面喰うのが、「デバッガが起動してくること」そのものですが、処理系ごとにデバッガから抜けるコマンドが違っていたりして結構厄介です。
とはいえ、SLIME経由で使えばその辺りは統一したインターフェイスになり、q(uit)か、a(bort)を押下すればデバッガから抜けられます。
処理系が用意しているデバッガの場合は、トップレベルに抜けるコマンドが大抵:ret(urn)や、:topで、:a(bort)で該当のエラーから抜けます。

デバッガとコードを行ったり来たりする

デバッガを終了させることができれば、デバッガは起動してもすぐ閉じる、という運用が可能になります。
実質エラーの通知画面のような存在にすることも可能なのですが、それでは寂しいので、もう一歩踏み込んでみましょう。

下記のような欠陥があるコードを用意し、(a)を評価します。

(defun a ()
  (- (b)))
(defun b ()
  (* (parse-integer (c)) 2))
(defun c ()
  (elt '("x" "1") (random 3)))

エラー発生でデバッガ起動、

The index 2 is out of range for sequence ("x" "1").
   [Condition of type CONDITIONS:INDEX-OUT-OF-RANGE]
Restarts:
 0: [RETRY] Retry SLIME interactive evaluation request.
 1: [*ABORT] Return to SLIME's top level.
 2: [ABORT] Quit process.
Backtrace:
  0: (CONDITIONS::CONDITIONS-ERROR :INVISIBLEP T CONDITIONS:INDEX-OUT-OF-RANGE (:INDEX 2 :SEQUENCE ("x" "1") :DATUM 2 ...))
  1: (ERROR CONDITIONS:INDEX-OUT-OF-RANGE :INDEX 2 :SEQUENCE ("x" "1") ...)
  2: (ELT ("x" "1") 2)
  3: (B)
  4: (A)
  5: (SYSTEM::%INVOKE :INVISIBLEP T)
  6: (SYSTEM::%EVAL (A))
  7: (EVAL (A))
  8: ((SUBFUNCTION 1 (SUBFUNCTION 1 SWANK:INTERACTIVE-EVAL)))
 --more--

とりあえずは、インデックスの範囲超過のエラーですが、エラー発生地点からトップレベルの方に向って一番近い自作の関数を確認します。
SLIMEのデバッガの表示では上から下に向って探してエラーから一番近い自作関数というと、(B)です。

(B)の上で、M-.(slime-edit-definition)するとソースコードにジャンプするので修正を検討します。

(defun b ()
  (* (parse-integer (c)) 2))

このコードには範囲超過のコードは含まれていないのでスキップだろうということで、自作関数の(c)を確認するため、M-.でソースに飛びます。

(defun c ()
  (elt '("0" "1") (random 3)))

の

(elt '("0" "1") (random 3))

がおかしいので、

(elt '("0" "1") (random 2))

に変更して、(c)を再コンパイルします(slime-compile-defun)

修正が済んだので、M-,(slime-pop-find-definition-stack)で戻ります。

(b)の定義に戻るので、更にM-,してデバッガ画面の、(b)の呼び出しの箇所(フレーム)に戻ります。 修正は終ったので、ここでrでフレームをリスタートします。

これで終了と思いきや、

No integer present in "x" from 0 to 1, parse-integer expected one.
   [Condition of type CONDITIONS::SIMPLE-PARSE-ERROR]
Restarts:
 0: [RETRY] Retry SLIME interactive evaluation request.
 1: [*ABORT] Return to SLIME's top level.
 2: [ABORT] Quit process.
Backtrace:
  0: (CONDITIONS::CONDITIONS-ERROR :INVISIBLEP T CONDITIONS::SIMPLE-PARSE-ERROR (:FORMAT-STRING "No integer present in ~S from ~D to ~D, parse-integer expected one." :FORMAT-ARGUMENTS ("x" 0 1)))
  1: (ERROR CONDITIONS::SIMPLE-PARSE-ERROR :FORMAT-STRING "No integer present in ~S from ~D to ~D, parse-integer expected one." :FORMAT-ARGUMENTS ("x" 0 1))
  2: (B)
  3: (A)
  4: (SYSTEM::%INVOKE :INVISIBLEP T)
  5: (SYSTEM::%EVAL (A))
  6: (EVAL (A))
  7: ((SUBFUNCTION 1 (SUBFUNCTION 1 SWANK:INTERACTIVE-EVAL)))
 --more--

となりました。 そういえば、パーズ対象は36進数の表現でした(そういうことにしましょう)ので修正します。

先程と同じく、(b)のフレームの上で、M-xし、定義に飛びます。
定義を、

(defun b ()
  (* (parse-integer (c) :radix 36.) 2))

のように修正し、M-,でデバッガに戻ります。 (b)のフレームの上で、rでリスタートすると、返戻値-66で正常に関数が終了しました。

まとめ

大体こんな感じのことを繰り返すことが多いのですが、今回の例でいうと(c)のフレームが見えていてくれれば、もっと簡単です。 この辺りは、SLIME経由でなく、処理系備え付けのデバッガであれば、表示してくれることもあります。

また、デバッグ設定の具合によって変化するので、デバッガを活用してみるということであれば、

(declaim (optimize (debug 3) (safety 3)))

あたりの設定で開発するのが吉かと思います。

また、処理系によっては手前のフレームからステップ実行したりすることもできます。 個人的にはステップ実行が便利に感じたことがあまりないので、エラーメッセージを良く読んで、ソースに飛ぶ位で十分かなという感じです。

今回の記事より深い内容はあまり知らないのですが、今後も便利な方法を模索してみたいと思います。

関連

• SLIMEのSLDBの画面を見やすくする

■

HTML generated by 3bmd in LispWorks 8.0.0

S式は可読性が良い/悪いというのは定期的に話題になりますが、大抵の場合Code is Dataという観点が抜けています。
LispにおいてCode is Dataというのは必須の要件であり、コードとしてのデータの読み書きの容易さ、把握のしやすさを考えずに可読性を議論してもしょうがないと思います。
逆にいうと、Code is Dataという観点が必要とされない言語がS式を採用する意味はあまりないと思いますし、Code is Dataという観点が必要とされない言語の感覚や価値観でS式を語ってもしょうがないと思います。大抵は、式のパーズが楽とかそういう話にしかなりません。

古くはM式→S式のMS変換に始まり、数式処理システム向けの中置記法などもあったり、DylanのようにAlgol文法の採用などもありますが、S式以外は、大体どれもコードとデータを行き来することになります。

• メタ記述をデータに変換する方式: M式
• パターンマッチ等でコードをデータのように扱う方式: Dylan
• コードを中間形式に変換→コードに戻す: Julia

このような行き来をしないで一つの記法で済ませる方式がS式ですが、歴史的にはLisperは、M式→S式方式からS式に一本化することを選択したといって良いと思います。

Lisp編集では、エディタ上でもコード/データを操作する

Lispではデータでコードを記述しているので、エディタもリストデータを編集できれば良いということになります。リストと要素の操作に還元できるので、非常に操作感が統一されています。
コードの編集は、リストの要素を交換したり、追加したり、をすれば良いだけですが、S式以外の言語では、エディタが文法を理解している必要があり、大抵の場合はS式操作に比べればどこかに引っ掛かりがあります。 また、エディタ上でマクロの展開をしつつマクロを記述していったりしますが、マクロ記述/展開もまた単なるリスト操作であり、この辺りの記述とフィードバック情報の扱いやすさはS式ならではではないかと思います。

S式は、Code is Data、可読性、操作性、のバランスが絶妙なのです。

■

HTML generated by 3bmd in LispWorks 7.0.0

特に何があったというわけでもないですが、lexprの構文が作りたくなったので作ってみました。
そもそも、LEXPRとは何かですが、引数をリストで受け取り中で分解して参照するような仕組みです。 MACLISP系統のMACLISP、Lisp machine Lisp、Franz Lispで使えますが、Common Lispが登場する頃にはより柔軟なλリストキーワードの方式が登場していたためか、可変長引数に対応するだけのLEXPRは取り入れられませんでした。

(defpackage lexpr
  (:use)
  (:export defun arg setarg listify))

(defmacro lexpr:defun (name argn &body body)
  (let ((args (gensym "args")))
    `(defun ,name (&rest ,args &aux (,argn (length ,args)))
       (declare (ignorable ,argn))
       (flet ((lexpr:arg (pos)
                (declare (type list ,args))
                (elt ,args (1- pos)))
              (lexpr:setarg (pos val)
                (declare (type list ,args))
                (setf (elt ,args (1- pos)) val))
              (lexpr:listify (n)
                (if (minusp n)
                    (last ,args (- n))
                    (subseq ,args 0 n))))
         (declare (inline lexpr:arg lexpr:setarg lexpr:listify))
         ,@body))))

arg、setargの引数は1オリジンなので注意が必要

(lexpr:defun plus args
  (lexpr:setarg 1 (* 2 (lexpr:arg 1)))
  (lexpr:setarg 2 (* 2 (lexpr:arg 2)))
  (print (lexpr:listify -3))
  (+ (lexpr:arg 1) (lexpr:arg 2)))

(plus 1 1 1 2 2 2 2 'l 'a 's 't)
>> (a s t)
→ 4

(lexpr:defun print-no-of-arguments n
  (princ "Number of arguments supplied: ")
  (princ n)
  (terpri))

(print-no-of-arguments 'x 'y 'z)
>> Number of arguments supplied: 3
→ nil

(lexpr:defun power n
  (expt (lexpr:arg 1)
        (cond ((> n 1) (lexpr:arg 2))
              (T 2))))

(power 3)
→ 9
(power 3 4)
→ 81

まとめ

LEXPRの定義構文を真似てみました。 思えば、Unixのシェルスクリプトの$1、$2あたりと似ていますね。

■

HTML generated by 3bmd in LispWorks 8.0.0

表題のとおりなのですが、cl-benchというCommon LispのベンチをCommon Lisp以外の言語で走らせて、Common Lispと比較するのも面白いかなと思ったので試してみました。

今回試したのは、GoとDとCommon Lispの各処理系の比較ですが、全部移植するのも大変なので10種類程度の移植となっています。

• g000001/cl-bench-in-single-file

言語をまたいでベンチをとってみての感想

まだ全部のベンチを移植して比較してみたわけではないので、第一感というところですが、

• Lispらしい処理はCommon Lispが速いらしい(あたりまえか)
  • bignum
  • 有理数
  • リスト処理
• Common Lispはインライン展開がいまいち効いていない(処理系ごとに癖があるので個別にチューニングが必要)

—あたりの印象をもちました。
インライン展開については、fib、ackermannあたりは関数呼び出しの速度比べですが、DやGoと同じ程度にインライン展開されるようにするには、結構書き方を調整しないと駄目だと思います。ちなみにD(dmd)のコンパイルオプションでは-inlineを付けていますが、つけない場合は結構遅くなります。

また、cl-benchには、型の指定や扱いがちぐはぐなコードがあったりもするなという印象です。
integerの配列と型指定しているのに、listオブジェクトを検索していたりしますが、コンパイラが賢ければnilに置き換えられてもおかしくなさそうです。
(なお、他の言語では要素の型を合せて比較しないと色々と面倒)

まとめ

あたり前ですが、今時の言語のGoなどは今時の処理に使われそうな処理が速いという印象です。 翻ってCommon Lispですが、やはり記号処理に強いのかなと思いました。
記号処理に強いCommon Lispというのを活かすのは、なかなか難しそうですが色々模索してみたいところです。
また、Common Lispと競合しそうなところで、Juliaあたりとも比較してみたいと思っています。

(2022-02-22 04:42) Juliaにも同様のものを移植し計測してみました。
(2022-02-23 16:55) Rustにも同様のものを移植し計測してみました。

ベンチ結果

■

HTML generated by 3bmd in LispWorks 8.0.0

前回は、muLISPの暗黙のcondをリーダーマクロで再現してみましたが、コードウォーキングのお題としても使えそうな気がしたので、今回は暗黙のcondをコードウォーカーを使って再現してみたいと思います。

利用するコードウォーカーについて

今回利用するコードウォーカーはarnesiのwalk-formです。
S式をパーズしてフォームのオブジェクトに変換し、それをアンパーズしてS式に戻す、という方式です。

変換の戦略としては、muLISPの暗黙のcondは、Common Lispの適用フォームとしては不正なので、これを検知して式を変換します。
具体的には、carにconsが来るのはlambda式の時のみなので、それ以外のconsのフォームを暗黙のcondと見做せば良さそうですが、arnesiでは、lambda式は既にlambda-application-formとしてハンドリングされているので、それ以外のfree-application-formの方にメソッドを定義します。

(ql:quickload '(alexandria arnesi))
(defpackage mu
  (:use)
  (:export defun))

(defun get-block-name (env)
  #+sbcl (caar (sb-c::lexenv-blocks env))
  #+lispworks (caar (compiler::compiler-environment-benv env)))

(defmacro return-innermost (val &environment env)
  `(return-from ,(get-block-name env) ,val))

;;;((foo ...) ...) => (when (foo ...) ... (return-innermost ...))
(arnesi:defunwalker-handler arnesi:free-application-form (arnesi:operator arnesi:arguments)
  (typecase arnesi:operator
    (cons (destructuring-bind (pred &rest body)
                              (call-next-method)
            `(when ,pred ,@(butlast body) 
               (return-innermost ,@(last body)))))
    (atom (call-next-method))))

(defmacro mu:defun (name (&rest args) &body body)
  (multiple-value-bind (body decl doc)
                       (alexandria:parse-body body :documentation T)
    `(defun ,name (,@args)
       ,@(if doc `(,doc) `())
       ,@decl 
       ,(arnesi:unwalk-form
         (arnesi:walk-form `(progn ,@body))))))

試してみる

(mu:defun fib (n)
  "fib"
  (declare (optimize (speed 3) (safety 0) (debug 0)))
  (declare (type fixnum n))
  (labels ((fib (n &aux n1 n2)
             ((< n 1) 0)
             ((< n 2) 1)
             (setq n1 (1- n))
             (setq n2 (- n 2))
             (+ (fib n1)
                 (fib n2))))
    (fib n)))
===>
(defun fib (n)
  "fib"
  (declare (optimize (speed 3) (safety 0) (debug 0)))
  (declare (type fixnum n))
  (progn
    (labels ((fib (n &aux n1 n2)
               (when (< n 1) (return-innermost 0))
               (when (< n 2) (return-innermost 1))
               (setq n1 (1- n))
               (setq n2 (- n 2))
               (+ (fib n1) (fib n2))))
      (fib n))))
(fib 40)
→ 102334155

(mu:defun fizzbuzz (n)
  (flet ((fizzp (n) ((zerop (rem n 3)) T) nil)
         (buzzp (n) ((zerop (rem n 5)) T) nil))
    ((buzzp n)
     ((fizzp n) "fizzbuzz")
     "buzz")
    ((fizzp n) "fizz")
    n))
===>
(defun fizzbuzz (n)
  (progn
    (flet ((fizzp (n) (when (zerop (rem n 3)) (return-innermost t)) nil)
           (buzzp (n) (when (zerop (rem n 5)) (return-innermost t)) nil))
      (when (buzzp n) (when (fizzp n) (return-innermost "fizzbuzz")) (return-innermost "buzz"))
      (when (fizzp n) (return-innermost "fizz"))
      n)))
(loop :for i :from 1 :repeat 100 :collect (fizzbuzz i))
→ (1 2 "fizz" 4 "buzz" "fizz" 7 8 "fizz" "buzz" 11 "fizz" 13 14 "fizzbuzz" 16 17 "fizz" 19 "buzz" "fizz" 22 23 "fizz" "buzz" 26 "fizz" 28 29 "fizzbuzz" 31 32 "fizz" 34 "buzz" "fizz" 37 38 "fizz" "buzz" 41 "fizz" 43 44 "fizzbuzz" 46 47 "fizz" 49 "buzz" "fizz" 52 53 "fizz" "buzz" 56 "fizz" 58 59 "fizzbuzz" 61 62 "fizz" 64 "buzz" "fizz" 67 68 "fizz" "buzz" 71 "fizz" 73 74 "fizzbuzz" 76 77 "fizz" 79 "buzz" "fizz" 82 83 "fizz" "buzz" 86 "fizz" 88 89 "fizzbuzz" 91 92 "fizz" 94 "buzz" "fizz" 97 98 "fizz" "buzz")

まとめ

arnesiのwalk-formを利用してmuLISPの暗黙のcondを再現してみました。
SBCLやLispWorksに付属のPCL系のwalk-formでも可能ですが、arnesiのものはカスタマイズしたい部分にメソッドを定義してやるだけなので簡潔かと思います。
ただし、今回のような定義では、arnesiのunwalk-form全体に影響を及ぼしてしまうので、フォームオブジェクトをサブクラス化してカスタマイズに使う等の工夫が必要になるかと思います。

■

HTML generated by 3bmd in LispWorks 7.0.0

muLISPの本をながめていたところ、どうも見慣れないカッコの連続が目につくので、詳細を確認したのですが、muLISPではprognなどのボディ部でcondの省略形が使えるようです。
いわば暗黙のcondという感じなのですが、詳細な情報を求めてマニュアルを確認すると、これはマクロや式変換ではなく評価器レベルで実現している機能のようです。

• muLISP/muSTAR-80 Al Development System Reference Manual

などと文字で書いても判りづらいのでコード例で示しますが、Common Lispで書くと、

(defun fib (n)
  (cond ((< n 1) 0)
        ((< n 2) 1)
        (T (+ (fib n1)
              (fib n2)))))

のようになるものが、muLISPでは

(defun fib (n)
  ((< n 1) 0)
  ((< n 2) 1)
  (+ (fib n1)
     (fib n2)))

のように書けるようです。またprognがcondにそのまま置き換わった形式でもないようで、任意の節を述語部の間に挟むことが可能です。

(defun fib (n)
  ((< n 1) 0)
  (print n)
  ((< n 2) 1)
  (print n)
  (+ (fib n1)
     (fib n2)))

暗黙のcondをCommon Lispで真似してみる

そもそも元が評価器レベルで実現しているので、これをマクロで実現するのは手間が掛かる割には上手くいかなさそうです。
今回は妥協してリーダーマクロで実現してみることにしました。

(defun get-block-name (env)
  #+sbcl (caar (sb-c::lexenv-blocks env))
  #+lispworks (caar (compiler::compiler-environment-benv env)))

(defmacro return-innermost (val &environment env)
  `(return-from ,(get-block-name env) ,val))

(set-syntax-from-char #\] #\))

(set-macro-character #\[ (lambda (srm chr)
                           (declare (ignore chr))
                           `(if ,(read srm T nil T)
                                (return-innermost ,(cons 'progn (read-delimited-list #\] srm T))))))

ブラケットで囲んだ場合にmuLISPのような挙動となりますが、まあ使い勝手の確認はできそうです。

(defun fib (n)
  "fib"
  (declare (optimize (speed 3) (safety 0) (debug 0)))
  (declare (type fixnum n))
  (labels ((fib (n &aux n1 n2)
             [(< n 1) 0]
             [(< n 2) 1]
             (setq n1 (1- n))
             (setq n2 (- n 2))
             (+ (fib n1)
                (fib n2))))
    (fib n)))
(fib 40)
→ 102334155

まとめ

muLISPの暗黙のcondを再現してみました。
muLISPは1980年代にパソコン用LISPとして結構普及していたようですが、MACLISP系の文法を採用している割には意外な拡張をしていたみたいですね。

■

HTML generated by 3bmd in LispWorks 8.0.0

先日のLispWorks 8.0 Linux版の評価でもちょっと書きましたが、LispWorks 8.0ではエディタバッファでの日本語入力が場合によっては使い物にならない挙動のようです。

• LispWorks 8.0発売!

先日試したのはLinux版だったのでGTk版特有の挙動かと考えLispWorksにもそのように報告しましたが、macOS版でも同じような挙動を確認しました。
しかしこれがなんとも説明しがたい挙動なので動画にしてみました。

LispWorks 7.1 Personal editionでのIMEのインライン変換(正常)

LispWorks 8.0 でのIMEのインライン変換(おかしい)

症状としてはバッファの先頭か末尾に入力する分にはそこまで変でもないですが、それ以外の場所に文字を挿入しようとすると変換選択の画面が画面先頭にでたり、さらにその表示のゴミがのこったりするようです。
GTk版では変換候補の画面が一切出てこないためゴミもバッファに挿入されません。
LispWorksのエディタだけでなくGUIのツールキットのeditor-paneも同様の症状です(まあ同じクラスだから当たり前か……。)
自分は確認していないのでなんともいえませんがeditor-paneがおかしいのでWindows版も同様ではないでしょうか。

日本語入力をさせるアプリを作っている方で、LispWorks 8.0の購入を考えている方は、ちょっと様子を見た方が良いかもしれません。
一応バグ報告をしているので修正されることを期待していますが、LispWorksのメーリングリストでも騒いでいる人はいまのところいません。
IMEを使う文化圏のユーザーは少数派でしょうから、このバグの修正もそんなに期待できないかもしれませんねえ……。

Lispエディタの問題だけならまだ良いのですが、作成したアプリでeditor-paneを使った場合、日本語の入力がまともに機能しなくなるのが痛いですね。

■

HTML generated by 3bmd in LispWorks 8.0.0

前回はは、Lisp方言と愛好者のバックボーンを分類して適当なことを考えたりしてみましたが、今回はShibuya.lispが発足した2008年より前のLispコミュニティについてこれまで調べていたことをざっとまとめてみたいと思います。　　

Shibuya.lisp以前

そもそも最近のフリーソフトウェアを中心としたコンピューター言語の集まりのようなものが盛んになり始めたのはオープンソースムーブメントが活発化してきた2000年代初頭からかと思います。　　 Shibuya.lispは元々Shibuya.pmというPerlコミュニティの集いのLisp版として企画されたようです(higepon氏によって)が、2000年代中頃からは勉強会ブームが到来したりと、プログラミング言語とコミュニティの関係が結構熱かった時期だったなと思います。
このあたりのことをどこかで書いたことがあった記憶があったのですが、このブログに一度まとめていたみたいです。

• 俺のブログ

2000年代以前

さて、オープンソースムーブメント以前からLispは存在するわけですが、2000年以前はどんなことになっていたのかというと、オープンソースの草の根コミュニティという形態よりは、どこかの企業がイベントを開催し、そこに愛好者が集うという形式が多かったようです。
具体的な例を挙げると、数理システムが1990年代後半にセミナーを開いたりしていた様子。

また、アカデミックな方面では、後藤英一先生の呼びかけで始まった　情報処理学会 記号処理研究会 というものが1977年から1995年あたりまで年四回位のペースで続いていたようです。

また、1980年代後半には、Common Lispを中心とした商業ベースのイベントなどもあったようですし、日本シンボリックスを筆頭として、有償でのLispセミナーのようなものが月一程度で開催されていたようです。

詳しくは日本のLispイベントを一覧にまとめていますので興味のある方は眺めてみてください。

• 日本国内で開催のLisp系イベント

なお、この一覧では1990年代後半のイベントを集めることができていません。このあたりで一つの時代が消滅しているような雰囲気もありますが、ウェブに記録があまり残っていない時代でもあるため実際のところどうだったのか詳しく知りたいところではあります。

まとめ

日本のLispコミュニティについて1970年代あたりからざっと眺めてみました。
大体のところは、

• 1970年代: コンピュータ言語研究者の集い
• 1980年代: AI/エキスパートシステム実用化に伴いベンダーがセミナーやイベントを主催
• 1990年代: ほぼ暗黒期
• 2000年代: オープンソースムーブメントやPerl、Ruby等LLの盛り上がりに乗じてLispも盛り上がってみる
• 2010年代: 言語ブーム沈静化、第三次AIブームと、それとはほぼ無縁なLisp
• 2020年代: プログラミングスクールブームと、それとはほぼ無縁なLisp

というところでしょうか

■

HTML generated by 3bmd in LispWorks 7.1.3

with-added-methodsは提案されたもののANSI CLには採用されなかったローカルな総称関数の構文で、現在は、ANSI CL規格の中間報告書であるCLtL2には痕跡を残すのみとなっています。

• CLtL2: with-added-methods

ローカルな総称関数の構文としては、with-added-methods以外にも、lambdaに相当するgeneric-function、flet/labelsに相当するgeneric-flet/generic-labels、とありますが、with-added-methodsだけは、既存の関数の構文には相当するものが存在しません。

数年に一度程度の割合で、ローカルな総称関数という恐しい構文がCommon Lispに存在したという文脈でgeneric-flet/labelsが紹介されることがあるのですが、多分、話題にしている人が想定しているのは、with-added-methodsの方ではないかなと推測しています。というのも、with-added-methods以外は既存の総称関数を拡張するものではなく、局所的に一時的な新しい総称関数を定義するだけなので、flet/labelsと大した違いはありません。

下記はどんな風な構文だったかを試してみるための手抜きのgeneric-系の実装です。どの辺りが手抜きかというと、コンパイルしないとまともな速度で動かない点と、load-time-valueを使っているため周囲の変数環境等を取り込めないところです。
ちなみに、現在使われている処理系でgeneric-系のローカルな総称関数構文をサポートしているのはCLISPのみですが、過去にはSymbolics CLや、MCLが実装していたことがあったようです。

(defpackage "e95807a5-c970-5e32-82b6-328d307de616" 
  (:use c2cl)
  (:shadow generic-function))
(in-package "e95807a5-c970-5e32-82b6-328d307de616")
(deftype generic-function (&rest args)
  `(cl:generic-function ,@args))
(defmacro generic-function ((&rest args) &body body &environment env)
  (let ((gf (gensym "anonymous-generic-function-")))
    `(load-time-value
      (defgeneric ,gf (,@args) ,@body))))
(defmacro generic-flet ((&rest local-gfs) &body body)
  `(flet (,@(mapcar (lambda (gf)
                      (destructuring-bind (name args &body body) gf
                        (let ((gf (gensym "anonymous-generic-function-"))
                              (lf-args (gensym "args")))
                          `(,name (&rest ,lf-args) 
                                  (declare (dynamic-extent ,lf-args))
                                  (apply (load-time-value 
                                          (defgeneric ,gf (,@args) ,@body))
                                         ,lf-args)))))
              local-gfs))
     ,@body))
(defmacro generic-labels ((&rest local-gfs) &body body)
  `(labels (,@(mapcar (lambda (gf)
                        (destructuring-bind (name args &body body) gf
                          (let ((gf (gensym "anonymous-generic-function-"))
                                (lf-args (gensym "args")))
                            `(,name (&rest ,lf-args) 
                                    (declare (dynamic-extent ,lf-args))
                                    (apply (load-time-value 
                                            (defgeneric ,gf (,@args) ,@body))
                                           ,lf-args)))))
                local-gfs))
     ,@body))

(mapcar (generic-function (x y)
          (:method ((x cons) (y cons))
           (append x y))
          (:method ((x number) (y number))
           (+ x y))
          (:method (x y)
           (list x y)))
        '(42 (0 1 2 3) z)
        '(42 (0 1 2 3) z))
→ (84 (0 1 2 3 0 1 2 3) (z z)) 
(generic-flet ((plus (x y)
                 (:method ((x cons) (y cons))
                  (append x y))
                 (:method ((x number) (y number))
                  (+ x y))
                 (:method (x y)
                  (list x y))))
  (list (plus 8 8) 
        (plus '(1 2 3 4) '(1 2 3 4))
        (plus 'z 'z)))
→ (16 (1 2 3 4 1 2 3 4) (z z)) 

;; ローカルの関数を参照できないので引数で渡す必要がある(labelsとは……)
(defun fibonacci (n)
  (generic-labels ((%fib (n fib)
                     (:method ((n (eql 0)) fib) 
                      0)
                     (:method ((n (eql 1)) fib) 
                      1)
                     (:method ((n integer) fib)
                      (+ (funcall fib (1- n) fib)
                         (funcall fib (- n 2) fib)))))
    (%fib n #'%fib)))
(fibonacci 40)
→ 102334155 

with-added-methods

さて今回の主題のwith-added-methodsですが、大体の仕様な下記のようなものです

• 既存の総称関数がなければ、generic-labelと似たような挙動
• 既存の総称関数があれば、その総称関数をコピーし、with-added-methodsで定義されたメソッドを加えて実行する
• 既存の総称関数がないが関数定義がある場合は、その関数をデフォルトメソッドとした総称関数を定義してメソッドも追加

今回改めて確認するまで、この構文は、既存の総称関数に破壊的にメソッドを足して構文を抜けたら戻すものだと記憶していたのですが、破壊的に変更するのではなくコピーをするようです。しかしそうすると再帰しているような場合はどうなるのでしょう……。

具体的に考えると、

(defgeneric fib (n)
  (:method ((n (eql 0))) 0)
  (:method ((n (eql 1))) 1)
  (:method ((n integer)) 
   (+ (fib (1- n))
      (fib (- n 2)))))

のような定義があった場合に、with-added-methodsでfib(5)=5のような定義を足してみる場合、

(with-added-methods (fib (n fib)
                      (:method ((n (eql 5)) fib) 
                       5))
  (fib 40))

となるわけですが、新しく足したメソッドは再帰していないので良いとしても、再帰しているfib integerが内部で呼び出すメソッドもローカルのfibにならないと大域のfibの方に逃げていってしまいます。
これはメソッドのソースコードを保持していれば式を全部展開して総称関数を組み立て直すことで実現できそうではあります。しかしこの方法も大域のメソッドの方がレキシカルな自由変数を取り込んでいる場合に復元できないので、環境も記憶しておく必要があります……。

等々色々問題があるのですが、あまり深追いせずに適当に手抜きで作成してみました。

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun method-description-p (form)
    (typep form '(cons (eql :method) *))))
(defun copy-generic-function (name gf &key generic-function-class
                                           lambda-list
                                           declare
                                           method-combination
                                           method-class
                                           argument-precedence-order)
  (let ((newgf (etypecase gf
                 (GENERIC-FUNCTION
                  (setq generic-function-class (class-of gf))
                  (setq lambda-list (generic-function-lambda-list gf))
                  (setq declare (generic-function-declarations gf))
                  (setq method-combination (generic-function-method-combination gf))
                  (setq method-class (generic-function-method-class gf))
                  (setq argument-precedence-order (generic-function-argument-precedence-order gf))
                  (ensure-generic-function name
                                           :generic-function-class generic-function-class
                                           :lambda-list lambda-list
                                           :declare declare
                                           :method-combination method-combination
                                           :method-class method-class
                                           :method-combination method-combination
                                           :argument-precedence-order argument-precedence-order))
                 (FUNCTION
                  (let ((gf-from-fn (ensure-generic-function name
                                                             :lambda-list (lw:function-lambda-list gf))))
                    (add-method gf-from-fn 
                                (make-instance 'standard-method
                                               :function (lambda (&rest args)
                                                           (declare (ignore next))
                                                           (apply gf args))
                                               :lambda-list (lw:function-lambda-list gf)
                                               :specializers (mapcar (constantly (find-class T))
                                                                     (lw:function-lambda-list gf))))
                    gf-from-fn))
                 (NULL
                  (ensure-generic-function name :lambda-list lambda-list)))))
    (when (typep gf 'generic-function)
      (dolist (m (generic-function-methods gf))
        (add-method newgf (make-instance (generic-function-method-class newgf)
                                         :function (method-function m)
                                         :lambda-list (method-lambda-list m)
                                         :specializers (method-specializers m)))))
    newgf))
(defmacro with-added-methods ((function-name lambda-list &rest method-description/option) &body body)
  `(labels ((,function-name (&rest args)
              (apply (load-time-value
                      ,(let ((name (gensym "gf")))
                         `(let ((,name (copy-generic-function ',name 
                                                              ,(if (fboundp function-name)
                                                                   `#',function-name
                                                                    nil)
                                                              :lambda-list ',lambda-list
                                                              ,@(remove-if #'method-description-p
                                                                           method-description/option))))
                            ,@(mapcar (lambda (mf)
                                        `(defmethod ,name ,@(cdr mf)))
                                      (remove-if-not #'method-description-p
                                                     method-description/option))
                            ,name)))
                     args)))
     ,@body))

試してみる

とりあえず、再帰はうまく扱えないので引数経由で自身を渡すことにします。

(defgeneric fib (n fib)
  (:method ((n (eql 0)) fib) 0)
  (:method ((n (eql 1)) fib) 1)
  (:method ((n integer) fib) 
   (+ (funcall fib (1- n) fib)
      (funcall fib (- n 2) fib))))

とりあえず素のfib

(time (fib 40 #'fib))
Timing the evaluation of (fib 40 #'fib)
User time    =        6.907
System time  =        0.109
Elapsed time =        6.933
Allocation   = 170288 bytes
3995 Page faults
102334155

コンパイルしないと異様に遅い

(time
 (with-added-methods (fib (n fib)
                          (:method ((n (eql 5)) fib) 
                           5))
   (fib 20 #'fib)))
Timing the evaluation of (with-added-methods (fib (n fib) (:method ((n (eql 5)) fib) 5)) (fib 20 #'fib))
User time    =        1.365
System time  =        1.672
Elapsed time =        3.077
Allocation   = 132662416 bytes
226350 Page faults
Calls to %EVAL    368057
6765

コンパイルすればどうにか早くなる

(defun foo-fib (n)
  (with-added-methods (fib (n fib)
                        (:method ((n (eql 5)) fib) 5))
    (fib n #'fib)))
(time (foo-fib 40))
Timing the evaluation of (foo-fib 40)
User time    =        4.069
System time  =        0.084
Elapsed time =        4.075
Allocation   = 160912 bytes
4005 Page faults
102334155

通常の関数をローカルでは総称関数のデフォルトメソッドとして扱い、さらにメソッドを足す

(defun foo (x) x)
(foo 0)
→ 0 
(with-added-methods (foo (x) 
                         (:method ((x (eql 'foo)))
                          '(foo !)))
  (foo 'foo))
→ (foo !) 

まとめ

以上、謎の多いwith-added-methodを手抜き実装しつつ紹介してみました。
仕様がまとめられず没になったのも頷ける気がしますが、割合に使いどころはありそうな構文な気もしました。

■

HTML generated by 3bmd in LispWorks 7.1.3

Emacs系エディタでLispを編集している場合、S式を整形するのにControl-Meta-Q(indent-pp-sexpやIndent Form)を使うと思うのですが最近のmacOSではログアウトのショートカットになっているのでこれを阻止しないと安心してS式編集ができません。

新しいmacOS環境を構築する度に毎度調べているのでブログにメモしておきます。

• keyboard - How to disable command-Q for Quit? - Ask Different

具体的な方法はこちらの記事に詳しいですが、日本語メニューの場合、指定する文言が違い、「画面をロック」とする必要があります。

手順

システム環境設定 > キーボード > ショートカット > アプリケーション

と進み+でアプリケーション「全アプリケーション」でメニュータイトル「画面をロック」を追加し、c-m-Q以外のショートカットを登録し「追加」することで、動作が上書きされます。

まとめ

macOSでのEmacs系エディタでのc-m-Q問題の回避方法をメモしてみました。
ウェブを検索してもEmacsの問題としてはヒットしないのですが皆さんc-m-Qじゃなくて別のキーバインドを使ってるんですかね?(c-m-\とか)

■

HTML generated by 3bmd in LispWorks 7.1.3

Shibuya.lisp Tech Talkが久々に開催されるとのことで、Shibuya.lispの初期の歴史について話ことになってしまったのですが、うまく喋れる気が全くしないので話が空中分解して意味不明な話になった場合の予防処置をしておきたいということで、Shibuya.lispを中心として私が考察したLispコミュニティというものをまとめておきたいと思います。

マイナーコミュニティなのに消滅しない理由を考える

マイナーコミュニティ全般にいえますが、参加者が0になれば消滅することになります。
実際には増えたり減ったり消滅したり再生したりを繰り返していますが、これらは何種類かに分類できるかと思います。
これを参加者のバックボーンと呼んで分類してみましょう。

業務バックボーン

• 基本的に仕事のプロジェクトがなくなればサヨナラ

業務で携わることになった人達です。
いまどきだとClojureの人達は割合にこのあたりに該当するかと思います。
古くはCommon Lispに多かったと思いますが、昔のLispを懐しむけれど今はLispを書いていないようなプログラマはこの辺りに属するかと思います。
ありがちなセリフ『本物のマクロが恋しいよ』、『機会があれば書きたい』、『Lispで飯が食えるのか』

研究者バックボーン

• 息は長いが研究テーマから離れればサヨナラ

研究者の方は息が長いのが特徴です。
息の長い研究者コミュニティというバックボーンが別途あり、その運用方法なども確立されているようにみえます。
Lisp/Schemeでいえば、1980年台に活躍されていた先生方はこの辺りに属しているかと思います。
たまに世間でブームになったときに里におりてくるようなところがあります。

愛好者バックボーン

• 根強い

愛好者にも色々ありますが、処理系作成と、Common Lispのようにアプリ寄りの人達がいます。
マイナージャンル故、教えてくれる人が身近におらず独学者が多いので書籍の影響が異様に強いのが特徴かと思います。
その為か、実際にコミュニティでコードを書いている人達より、Paul Grahamのような有名なハッカーや、著者の先生の思想に影響を受けています。
ネタ元自体がそれ程多くない故、どの本の受け売りなのかネタ元が特定できますが、書籍の情報はどんどん古くなるため、古い知識が再生産される源泉にもなっています(Lispはインタプリタだから遅い説など)

なぜLispで一括りにされるのか

なぜLispで一括りにされるのか不思議に思っていましたが、もしかするとLispの登場が古い故にトピックの分類や棲み分け自体も古い形式を引き継いでいるからかもしれません。
例えば、C系統の言語は、分派それぞれでコミュニティを作りますが、Lispは『方言』としてLispとしてまとまる傾向があります。
Lisp、Algol、Fortranが登場したばかりの1960年代では、『方言』という括りで、主に実装者や研究者がその傘下に集っていたようですが、時代が下ると『方言』より細かい個別の言語でコミュニティを形成するようになり、言語を横断するような概念に関しては、『○○パラダイム』や『△△指向言語』として別途横断的なコミュニティを形成するようになったように見受けられます。

Lispではコミュニティにおける処理系作成者の比率が高いということもあり、自身が開発した処理系をLisp『方言』と考え、方言が集まったLispコミュニティを想定する方がしっくりくということもあるのかもしれません。

Common Lispや、Clojureでは処理系よりアプリへの関心が主なのでLisp方言という括りに関心がある人は多くはありません。特にClojureは個別にまとまる傾向が強いと感じます。

Lisp方言とバックボーン

さて、バックボーンを説明したので、方言とバックボーンの関係を考えてみたいと思います。
また、再生と消滅を繰り返しているので、再生の火口になっていると考えられるものも併記してみます。

Common Lisp

• 愛好者+業務バックボーン→フリーランサー

日本でも海外でも一匹狼の集団といわれることが多いCommon Lispの人達です。
Lisp熱が昂じた結果、業務プレイヤーがLispプログラマとしてフリーランサーとなったような人は良く見掛けます。

• 再生するために必要なもの: 情熱、業務で使えるクオリティの処理系

Clojure

• 業務バックボーン+愛好者→業務プレイヤー

Common Lispの人達程世の中の流れに抗っている感じはなく、割と時流に乗っているようにみえます。
Java資産に乗っかっているようなところも程良いバランスを保てているところかもしれません。

• 再生するために必要なもの: 職場

Scheme

• 研究者+愛好者→処理系製作者

実際に職場でSchemeを採用して複数名で開発をしている、というのはCommon Lisp以上に見掛けません(個人的には皆無)。
最近ではプログラミング言語の研究テーマ抽象的なトピックが多いようで特定の言語でどうこうというのは下火のようです。アカデミック寄りのRacketは教育を主軸にしているように見えます。
SRFIを含めたSchemeコミュニティを概観すると、Schemeの仕様を中心とした処理系製作者コミュニティという趣があります。

• 再生するために必要なもの: 仕様、自作処理系、研究発表

まとめ

なぜLispとして一括りにされるのか、Lispとコミュニティ、等について考察してみました。
個人的にはLispとして一括りにするのは、オブジェクト指向言語全般で一括りにするのと大体似たようなものだなと思ったりです。

■

HTML generated by 3bmd in LispWorks 8.0.0

こちらのツイートを目にして、そういえばVAX LISPのFFIって試したことがなかったので、この機会に試してみることにしました。

Cで書かれたルーチンを呼ぶ方法。この手の話、大事だと思うけどあまり書かれていない。過去のbitで説明があったのはAPPLE LISPのCALLくらい？ pic.twitter.com/dycR4tjaAI

— zick (@zick_minoh) January 3, 2022

試したのは、紹介されているbit誌のコードで、試した処理系はLiving Computersに設置されているVAX-7000/640上のVAX LISP 3.1です。

• Living Computers: VAX-7000/640

まず、Cのコードを作成、

#include <stdio.h>

be_good (times, string)
int times;
char string[];
{
int count;
for (count=0; count < times; count++)
    printf ("%s, I must not be so.\n", string);
printf("\n");
return(times);
}

$ cc be_good.c
$ link/shareable=[user.masso]be_good be_good,sys$input:/option  #改行
universal=be_good #^Zで完了

VAX LISPを起動し下記を定義

(define-external-routine (be-good :image-name "be_good" :entry-point "be_good" :result integer)
  (times :lisp-type integer :mechanism :value)
  (person :lisp-type string :vax-type :asciz))

call-outで実行してみる

Lisp> (call-out be-good 10 "Daddy")
Error in SYSTEM::%SP-CALL-OUT:
%LIB-E-ACTIMAGE, error activating image SCSI$DIA0:[SYS0.SYSCOMMON.][SYSLIB]BE_GOOD.EXE;
-RMS-E-FNF, file not found
Control Stack Debugger
Eval  #10: (SYSTEM::%SP-CALL-OUT 10 "Daddy" 2 #:G556)

どうもBE_GOOD.EXEの場所を見付けてくれない様子……。
ファイルの絶対パス指定等を試してみましたが、解明すべき謎が多すぎるので諦めました。

下記のようなマニュアルの他の例は動くようなのでファイルの場所さえ適切に指定できれば動きそうではあります。

(define-external-routine (put-screen :image-name "scrshr"
                                     :entry-point "lib$put_screen"
                                     :result integer)
  (chars :lisp-type string)
  (line :lisp-type integer
        :vax-type :word)
  (col :lisp-type integer
       :vax-type :word)
  (flag :lisp-type integer
        :vax-type :word))

• VAX LISP User's Guide Ver 2.2

cffiで同じ例を試してみる

このままでは若干寂しいのでcffiで同じ例を試して比較してみることにしました。

#include <stdio.h>

int be_good (int times, char string[])
{
  for (int count = 0; count < times; count++)
    printf ("%s, I must not be so.\n", string);
  printf("\n");
  return(times);
}

をlib-be-good.cとして用意し、

gcc -shared be_good.c -o lib-be-good.so

(ql:quickload "cffi")
(defpackage "2657427c-2fcb-5f17-abc2-5439545b51fa" 
  (:use "CL" "CFFI"))
(in-package "2657427c-2fcb-5f17-abc2-5439545b51fa")
(define-foreign-library lib-be-good
  (T (:default "lib-be-good")))
(use-foreign-library lib-be-good)

と定義。
VAX LISPのcall-outに相当しそうな、foreign-funcallで呼び出してみると、

(with-foreign-string (person "Daddy")
  (foreign-funcall "be_good":int 10 :string person 
                   :int))

Daddy, I must not be so.
Daddy, I must not be so.
Daddy, I must not be so.
Daddy, I must not be so.
Daddy, I must not be so.
Daddy, I must not be so.
Daddy, I must not be so.
Daddy, I must not be so.
Daddy, I must not be so.
Daddy, I must not be so.

という風にできました。
with-foreign-stringは無しでも動きますが、一応メモリ周りの処理をしてくれるので利用しています。

まとめ

VMSでは、Common Language Environmentという言語間で共通の呼出規約が定められていたようで、色々な言語を簡単に混ぜて使えたようです。
マニュアルでもFortranのコードを呼び出す例が紹介されていたりしますが、共通の形式になるので呼び出す側からは元の言語はあまり意識しなくて良い様子です。

■

HTML generated by 3bmd in LispWorks 8.0.0

最近はさほど言われることもなくなりましたが、以前は、Common Lisp処理系は実行可能ファイル(exe)が作れないので使えない、という人が割合にいました。
また、実行可能ファイルが生成できたとしても、フリーソフトのCommon Lisp処理系はファイルサイズについての最適化はそれ程頑張っていないので、非常に巨大なため、これでは使えない、といわれていました。
とはいえ、スマホアプリが100MiBを越えることもざらな近頃では大して話題にならなくなってきたみたいではあります。

この実行可能ファイルのサイズを小さく最適化したいという需要に応えるものとして、1980年代からツリーシェイカーというものがありました。
これは、Lispのイメージ中の不要なものを出荷するイメージから篩い落すというものですが、昔から商用の処理系には装備されており、今でもLispWorksや、Allegro CLにはそのような機能があります。
ちなみに、MCLではメモリが128KiBのような時代から存在していて実用的なサイズで出荷できていたようですし、Lucid CLでも同様だったようです。

• LispWorks 8.0 | Delivery User Guide: 14 Efficiency considerations when coding for delivery

そんなツリーシェイカーですが、開発環境でアプリを作って、あまり考えずに出荷時の最適化を掛け過ぎると、実行環境で必要なものまで落ちてしまいます。
そうなると、開発時から無用なライブラリはできるだけ使わないように調整したり、出荷時に確認して削ぎ落すわけですが、これが案外面倒なので、最近自分は、大きいサイズのままでも良いや、という風に割り切っています。
折角の機能なので活用したいところではあるのですが……。

ちなみにイメージサイズを縮小するのとは別のアプローチとして、OSのホスト言語(C等)を生成し、それをビルドして実行可能ファイルを生成するものがあります(ECL/WCL/Eclipse CL)
また、当然ながらSymbolics等のLispマシンでは、実行可能ファイルのようなものはなく、相当するものとしては、コンパイル済みのアプリをロードする程度のことになります。Unixでいうとコンパイル可能なシェルスクリプトですべてが構成されているような感覚かと思いますが、やはり理想郷ですねえ。

■

HTML generated by 3bmd in LispWorks 8.0.0

SchemeにはSRFI(Scheme Request for Implementation)、PythonにはPEPのようなものがありますが、俺Lisp拡張/ユーティリティのようなものに自分でRFIを書き自分で実装する、というもの面白いかなと思いつきました。
今年は、俺RFIを出して自分で実装してみたいと思います。

SRFIにテンプレートがあるので、これを下敷きにすると良さそう。

• SRFI Template

■

HTML generated by 3bmd in LispWorks 8.0.0

KMRCLを眺めるの242回目。今回は、listener.lispを眺めます。

listener.lisp を眺める

listener.lisp でいうlistenerはLisp処理系側でサーバを起動し、複数のコネクションを待ち受けるようなもののようです。
listenerクラスが複数のworkerクラスを保持するような構成になっています。

init/listener stop-all/listener

サーバの起動

(kl:init/listener
 (make-instance 'kl:listener
                :port 4006
                :function (lambda (io)
                            (write-line (read-line io nil) io)
                            (write-line "さようなら" io)
                            (force-output io)))
 :start)

外部から接続

% telnet localhost 4006
Trying 127.0.0.1...
Connected to localhost.
Escape character is '^]'.
8888
8888
さようなら
Connection closed by foreign host.

サーバ終了

(kl:stop-all/listener)

なお、KMRCL内でのlistener.lispの応用としては、repl.lispがあります。

• KMRCLを眺める(234) repl.lisp

■

HTML generated by 3bmd in LispWorks 8.0.0

bit 1985年6月号 Common Lisp入門 超マシン誕生のデータゼネラル社もCommon Lispを作ってた、と pic.twitter.com/JfSEAPoTYy

— ほうめい　マイコンで遊んでばっかりで (@houmei) December 31, 2021

DG Common Lispといえば、超マシンで名が知られているDGのMV/8000シリーズのMV/10000で稼動したCommon Lispですが、Kyoto Common Lispの最初のプラットフォームでもあります。

そんな、DG Common Lispのランタイムのコアな部分は、なんとChez Schemeや、Schemeの衛生マクロで有名な、Kent Dybvig先生が作っていたそうな。

• The Development of Chez Scheme

Common Lispのλリストの煩雑さを反面教師に以後シンプルなデザインを心掛けるようになったとの由。

■

HTML generated by 3bmd in LispWorks 8.0.0

恒例になっているので今年も振り返りのまとめを書きます。

Lisp的進捗

LispWorksでGUIアプリを作成して使うのが段々面白くなってきた一年でした。といっても大したものは作っていないのですが。

ブログ

今年書いた記事は71記事でした。 この数年、RSSとブログという文化自体が死滅しそうになっていて残念なのですが、2022年もブログは続けていきたいと思っています。
ブログと違ってSNSは発信が手軽というのはありますが、分散した情報をかき集めるのが一苦労なのです。情報の集約という点でブログ文化が好きだったのですが、多分ブログが盛り返すとこというもないでしょう。
SNSとブログでは、完全に棲み分けが進んだ感がありますが、昔は、本文が一行しかないようなブログ記事も普通にありましたし、2022年は一行二行でもブログに記事として投稿していこうかなと思います。

主に書き溜めたブログネタを成仏させる目的で開催したLisp一人 Advent Calendar 2021ですが、これを開催したお蔭で、どうでも良いことを書き散らかす、という感覚が戻ってきたように思います。 折角なので、この感じで書き散らかしていこうかなと思います。

LispWorks

LispWorks 8.0が登場しましたが、引き続きLispWorks生活は続けていこうと思います。 しかし、8.0でGTk版LispWorksの日本語入力に難が出たので、これだけが不安。

2022年の方向性

2022年は基本的に落穂拾い的にやっていこうかと考えていて、過去のブログ記事の保守や、WikipediaのLisp系記事の更新あたりを中心に活動してみたいと思っています。
また、処理系のマニュアルを隅から読んでいくようなのも好いかもしれません。
この数年＜最強のIDE(開発フロントエンド)としてのCommon Lisp＞というコンセプトで何か書いたり作ったりしたいと思っていたのですが、そうなるとOSの主要言語を学ぶ必要があります。Cが全然書けないので、Cの基礎を学んでCFFIでラッパーライブラリを沢山書けるようになりたいなと思ったりもしています。
また、Lispコミュニティについての考察みたいなものも大体まとまってきたので、そのうち書いたりしてみようかなと思ったりもしています。

過去のまとめ

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

■

HTML generated by 3bmd in LispWorks 8.0.0

Franz Lispの関数呼び出しの作法についてのツイートですが、今の感覚からすると確かに奇妙です。

Franz Lisp、そんなことできたのか pic.twitter.com/N3PdgYKIZ5

— zick (@zick_minoh) December 28, 2021

bitの記事からの引用ですが、

Franz Lispのように、関数名のところが変数であれば、その変数の値を関数と思い、それがまた変数であれば今度はその変数の値を関数名だと思い、…といったことはしない

とあります。実はこれMACLISPと同じような挙動なのですが、昔にこのブログに記事を書いていたことを思い出したのでMACLISPと同じ挙動なのか確認してみました。

• Lisp₂とFUNCALL

処理系は、simhのvax ultrix 4.0 上の franz lispです。

$ lisp
Franz Lisp, Opus 38.79
-> (setq x '(0 1 2 3))
(0 1 2 3)
-> (defun foo (x) x)
foo
-> ((lambda (car) (car x)) 'foo)
0

carの大域関数定義が優先されるようです。

-> ((lambda (bar) (bar x)) 'foo)
(0 1 2 3)

しかし関数定義がなければ、変数の方を使います。

barの関数を定義すれば、そちらが優先されます。

-> (defun bar (x) (car x))
bar
-> ((lambda (bar) (bar x)) 'foo)
0

しかし、MACLISPと違って、car部に置くことができるのは、シンボルだけのようです。

-> ('car '(0 1 2))
Error: eval: Undefined function  'car
-> (#'car '(0 1 2 3))
Error: eval: Undefined function  (function car)

ちなみに、MACLISPと同様にこの挙動はインタプリタだけで、ファイルをコンパイルした場合は、エラーになります。

;; foo.lisp
(defun foo (x)
  (let ((kar #'car))
    (kar x)))

$ liszt foo.lisp
Compilation begins with Liszt vax version 8.36
source: foo.lisp, result: foo.lisp.o
foo
%Note: foo.lisp: Compilation complete
%Note: foo.lisp:  Time: Real: 0:0, CPU: 0:0.00, GC: 0:0.00 for 0 gcs
%Note: foo.lisp: Assembly begins
%Note: foo.lisp: Assembly completed successfully
$ lisp
Franz Lisp, Opus 38.79
-> (load "foo.lisp.o")
[fasl foo.lisp.o]
t                                                                                                                                 
-> (foo '(0 1 2 3 4))                                                                                                             
Error: Undefined function called from compiled code  kar                    

まとめ

ここまでインタプリタとコンパイラの挙動が違うと統一したくなる気持ちもわかります。

ちなみに、Lisp₁とLisp₂は名前空間の違いとして語られることが殆どですが、上記の実験からも分かるように、実は同じLisp₂でもフォームのcar部の評価方法も様々なものがあります(した)。
Lisp₁の

(car '(0 1 2 3))

をそのままLisp₂にうつすと

('car '(0 1 2 3))

となる筈です。
しかし、Common Lispではcar部は評価しないものとして定められているので、

(car '(0 1 2 3))

としか書くことができないこともあり、多分細かいことは色々スルーされているのでしょう。

MACLISPやFranz Lispのインタプリタではcar部も関数が出てくるまで評価する、ということなのですが、この辺りも私がCommon Lispの関数/マクロ定義は括弧を定義しているのに感覚として近いと考える所以です。

関連

• Lisp₂のマクロはいうほど不衛生でもない

■

HTML generated by 3bmd in LispWorks 8.0.0

KMRCLを眺めるの241回目。今回は、byte-stream.lispを眺めます。

byte-stream.lisp を眺める

byte-stream.lispは(unsigned-byte 8)(uint8)な配列に対してのストリームインターフェイスを提供するライブラリです。
API(外部シンボル)は、

make-binary-array-output-stream、get-output-stream-data、dump-output-stream-data、make-byte-array-input-streamの4つですが、make-binary-array-output-streamはmake-byte-array-output-streamのタイポでしょう(もしくは修正で取り残されたか)

なお、対応している処理系はSBCL、CMLCL、Allegroだけのようです。

make-byte-array-output-stream

get-output-stream-data

dump-output-stream-data

Common Lisp標準のmake-string-output-streamとget-output-stream-stringと同じような使い勝手です。
ただし、cl:get-output-stream-stringは、何度も実行可能ですが、kl:get-output-stream-dataの方はバッファをフラッシュしてしまうので、フラッシュしない場合は、dump-output-stream-dataを使うべし、ということみたいです。

(let ((out (kl::make-byte-array-output-stream)))
  (map nil
       (lambda (x) (write-byte x out))
       '(#xde #xad #xbe #xef))
  (list (kl:get-output-stream-data out)
        (kl:get-output-stream-data out)))
→ (#(222 173 190 239) #())
(let ((out (kl::make-byte-array-output-stream)))
  (map nil
       (lambda (x) (write-byte x out))
       '(#xde #xad #xbe #xef))
  (list (kl:dump-output-stream-data out)
        (kl:dump-output-stream-data out)))
→ (#(222 173 190 239) #(222 173 190 239))

make-byte-array-input-stream

(let ((in (kl::make-byte-array-input-stream (coerce #(222 173 190 239) '(array (unsigned-byte 8) (*))))))
  (loop :for x := (read-byte in nil in)
        :until (eq x in)
        :collect x))
→ (222 173 190 239)

実装について

SBCLとCMUCL版は結構内部関数を使っていますが、基本的にはバッファの構造体を定義して、ストリームはそのバッファ経由で読み書きする、というものです。
Allegro版はAllegroが提唱しているsimple-streamAPIで組んであります。

■

HTML generated by 3bmd in LispWorks 8.0.0

KMRCLを眺めるの240回目。今回は、color.lispを眺めます。

buff-input.lisp を眺める

read-buffered-fields, make-fields-buffer

(defun make-fields-buffer (&optional (max-fields +max-fields-per-line+)
                                   (max-field-len +max-field+))
  (let ((bufs (make-array max-fields :element-type 'vector :fill-pointer 0 :adjustable nil)))
    (dotimes (i +max-fields-per-line+)
      (setf (aref bufs i) (make-array max-field-len :element-type 'character :fill-pointer 0 :adjustable nil)))
    bufs))
(defun read-buffered-fields (fields strm &optional (field-delim +field-delim+)
                             (eof 'eof))
  "Read a line from a stream into a field buffers"
  (declare (type base-char field-delim)
           (type vector fields))
  (setf (fill-pointer fields) 0)
  (do ((ifield 0 (1+ ifield))
       (linedone nil)
       (is-eof nil))
      (linedone (if is-eof eof fields))
    (declare (type fixnum ifield)
             (type boolean linedone is-eof))
    (let ((field (aref fields ifield)))
      (declare (type base-string field))
      (do ((ipos 0)
           (fielddone nil)
           (rc (read-char strm nil +eof-char+)
              (read-char strm nil +eof-char+)))
          (fielddone (unread-char rc strm))
        (declare (type fixnum ipos)
                 (type base-char rc)
                 (type boolean fielddone))
        (cond
         ((char= rc field-delim)
          (setf (fill-pointer field) ipos)
          (setq fielddone t))
         ((char= rc +newline+)
          (setf (fill-pointer field) ipos)
          (setf (fill-pointer fields) ifield)
          (setq fielddone t)
          (setq linedone t))
         ((char= rc +eof-char+)
          (setf (fill-pointer field) ipos)
          (setf (fill-pointer fields) ifield)
          (setq fielddone t)
          (setq linedone t)
          (setq is-eof t))
         (t
          (setf (char field ipos) rc)
          (incf ipos)))))))

make-fields-bufferは行単位のバッファを作成するユーティリティで、指定した数のフィールドを持ちます。デフォルトのデリミタは#\|ですが、csvやtsvのようにフィールドの間に置くのではなく、フィールドの後に置くタイプのようです。

read-buffered-fieldsは、ストリームから読んだ内容をバッファに保存します。

ちなみに、UTF-8の文字列を扱う場合は、(declare (type base-string field))では制限が強過ぎるのでstringあたりにする必要があります。
フィルポインタ付きの配列で何かバッファリングして読み込むようなコードの例としては、一番シンプルで参考になるかなと思いました。

(with-input-from-string (in "*print-miser-width*    0   
*print-pprint-dispatch* 0   
*print-readably*    0   
*print-right-margin*    0   
*read-eval* 0   
abort   0   
add-method  0   
allocate-instance   0   
arithmetic-error    0   
arithmetic-error-operands   0   
arithmetic-error-operation  0   
array   1   
array-displacement  0   
base-char   0   
base-string 0   
bignum  1   
bit-vector  1   
boolean 0   ")
  (loop :repeat 10 :collect (kl:read-buffered-fields (kl:make-fields-buffer) in #\Tab)))
→ (#("*print-miser-width*" "0")
   #("*print-pprint-dispatch*" "0")
   #("*print-readably*" "0")
   #("*print-right-margin*" "0")
   #("*read-eval*" "0")
   #("abort" "0")
   #("add-method" "0")
   #("allocate-instance" "0")
   #("arithmetic-error" "0")
   #("arithmetic-error-operands" "0"))

なお、buff-input.lispにはこれらの亜種のような定義が数点ありますが、どうもつくりかけっぽくエクスポートもされていません。

■

HTML generated by 3bmd in LispWorks 8.0.0

KMRCLを眺めるの239回目。今回は、color.lispを眺めます。

color.lisp を眺める

どんなユーティリティかと思って中身を覗いてみましたが、Common Lispにはあまり関係なくCGにおける色操作関係のユーティリティのようです。

お馴染のRGBと、グラフィックスアプリでよくみかける色相環と△のHSVの変換ユーティリティが主です。

• RGB
• HSV色空間

rgb→hsv

(defun rgb->hsv (r g b)
  (declare (optimize (speed 3) (safety 0)))
  (let* ((min (min r g b))
         (max (max r g b))
         (delta (- max min))
         (v max)
         (s 0)
         (h nil))
    (when (plusp max)
      (setq s (/ delta max)))
    (when (plusp delta)
      (setq h (* 60  (cond
                       ((= max r) (/ (- g b) delta))
                       ((= max g) (+ 2 (/ (- b r) delta)))
                       (t (+ 4 (/ (- r g) delta))))))
      (when (minusp h)
        (incf h 360)))
    (values h s v)))

rgbをhsvに変換します。rgbの最大値を基準とした割合で計算する様子

(rgb->hsv 1 0 0)
→ 0
  1
  255

rgb255→hsv255

(defun rgb255->hsv255 (r g b)
  "Integer convert from rgb from 0-255 -> h from 0-360 and sv from 0-255"
  (declare (fixnum r g b)
           (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))
  (let* ((min (min r g b))
         (max (max r g b))
         (delta (- max min))
         (v max)
         (s 0)
         (h nil))
    (declare (fixnum min max delta v s)
             (type (or null fixnum) h))
    (when (plusp max)
      (setq s (round (the fixnum (* 255 delta)) max)))
    (when (plusp delta)
      (setq h (cond
               ((= max r)
                (round (the fixnum (* 60 (the fixnum (- g b)))) delta))
               ((= max g)
                (the fixnum
                     (+ 120 (round (the fixnum (* 60 (the fixnum (- b r)))) delta))))
               (t
                (the fixnum
                     (+ 240 (round (the fixnum (* 60 (the fixnum (- r g)))) delta))))))
      (when (minusp h)
        (incf h 360)))
    (values h s v)))

rgbをhsvに変換します。こちらは、256階調で値を返します。

(rgb255->hsv255 #xff #x00 #x00)
→ 0 
  255 
  255 

hsv→rgb

(defun hsv->rgb (h s v)
  (declare (optimize (speed 3) (safety 0)))
  (when (zerop s)
    (return-from hsv->rgb (values v v v)))
  (while (minusp h)
         (incf h 360))
  (while (>= h 360)
         (decf h 360))
  (let ((h-pos (/ h 60)))
    (multiple-value-bind (h-int h-frac) (truncate h-pos)
      (declare (fixnum h-int))
      (let ((p (* v (- 1 s)))
            (q (* v (- 1 (* s h-frac))))
            (t_ (* v (- 1 (* s (- 1 h-frac)))))
            r g b)
        (cond
         ((zerop h-int)
          (setf r v
                g t_
                b p))
         ((= 1 h-int)
          (setf r q
                g v
                b p))
         ((= 2 h-int)
          (setf r p
                g v
                b t_))
         ((= 3 h-int)
          (setf r p
                g q
                b v))
         ((= 4 h-int)
          (setf r t_
                g p
                b v))
         ((= 5 h-int)
          (setf r v
                g p
                b q)))
        (values r g b)))))

hsv→rgbの逆

hsv255→rgb255

(defun hsv255->rgb255 (h s v)
  (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))
  (when (zerop s)
    (return-from hsv255->rgb255 (values v v v)))
  (locally (declare (type fixnum h s v))
    (while (minusp h)
      (incf h 360))
    (while (>= h 360)
      (decf h 360))
    (let ((h-pos (/ h 60)))
      (multiple-value-bind (h-int h-frac) (truncate h-pos)
        (declare (fixnum h-int))
        (let* ((fs (/ s 255))
               (fv (/ v 255))
               (p (round (* 255 fv (- 1 fs))))
               (q (round (* 255 fv (- 1 (* fs h-frac)))))
               (t_ (round (* 255 fv (- 1 (* fs (- 1 h-frac))))))
               r g b)
          (cond
           ((zerop h-int)
            (setf r v
                  g t_
                  b p))
           ((= 1 h-int)
            (setf r q
                  g v
                  b p))
           ((= 2 h-int)
            (setf r p
                  g v
                  b t_))
           ((= 3 h-int)
            (setf r p
                  g q
                  b v))
           ((= 4 h-int)
            (setf r t_
                  g p
                  b v))
           ((= 5 h-int)
            (setf r v
                  g p
                  b q)))
          (values r g b))))))

hsv255→rgb255の逆

hsv-equal

(defun hsv-equal (h1 s1 v1 h2 s2 v2 &key (limit .001))
  (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))
  (flet ((~= (a b)
           (cond
            ((and (null a) (null b))
             t)
            ((or (null a) (null b))
             nil)
            (t
             (< (abs (- a b)) limit)))))
    (cond
     ((and (~= 0 v1) (~= 0 v2))
      t)
     ((or (null h1) (null h2))
      (when (and (~= 0 s1) (~= 0 s2) (~= v1 v2))
        t))
     (t
      (when (~= h1 h2) (~= s1 s2) (~= v1 v2)
        t)))))

hsvの等価判定。whenの返り値を使うのが気持ち悪いという人もいるかもしれません。
(~= h1 h2) (~= s1 s2) (~= v1 v2)は、(and (~= h1 h2) (~= s1 s2) (~= v1 v2))の間違いでしょうか。

(hsv-equal 255 0 0
           255 0 0)
→ T 

hsv255-equal

(defun hsv255-equal (h1 s1 v1 h2 s2 v2 &key (limit 1))
  (declare (type fixnum s1 v1 s2 v2 limit)
           (type (or null fixnum) h1 h2)
           (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))
  (flet ((~= (a b)
           (declare (type (or null fixnum) a b))
           (cond
            ((and (null a) (null b))
             t)
            ((or (null a) (null b))
             nil)
            (t
             (<= (abs (the fixnum (- a b))) limit)))))
    (cond
     ((and (~= 0 v1) (~= 0 v2))
      t)
     ((or (null h1) (null h2))
      (when (and (~= 0 s1) (~= 0 s2) (~= v1 v2))
        t))
     (t
      (when (~= h1 h2) (~= s1 s2) (~= v1 v2)
        t)))))

hsv-equalにほぼおなじ。ユースケース的に分かり易くしたものでしょう。

hsv-similar

(defun hsv-similar (h1 s1 v1 h2 s2 v2 &key
                       (hue-range 15) (value-range .2) (saturation-range 0.2)
                       (gray-limit 0.3) (black-limit 0.3))
  "Returns T if two HSV values are similar."
  (cond
   ;; all black colors are similar
   ((and (<= v1 black-limit) (<= v2 black-limit))
    t)
   ;; all desaturated (gray) colors are similar for a value, despite hue
   ((and (<= s1 gray-limit) (<= s2 gray-limit))
    (when (<= (abs (- v1 v2)) value-range)
      t))
   (t
    (when (and (<= (abs (hue-difference h1 h2)) hue-range)
               (<= (abs (- v1 v2)) value-range)
               (<= (abs (- s1 s2)) saturation-range))
      t))))

hsvの類似度判定

(hsv-similar 255 0 0
             255 0 1
             :hue-range 15)
→ nil 

hsv255-similar

(defun hsv255-similar (h1 s1 v1 h2 s2 v2
                          &key (hue-range 15) (value-range 50) (saturation-range 50)
                          (gray-limit 75) (black-limit 75))
  "Returns T if two HSV values are similar."
  (declare (fixnum s1 v1 s2 v2 hue-range value-range saturation-range
                   gray-limit black-limit)
           (type (or null fixnum) h1 h2)
           (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))
  (cond
   ;; all black colors are similar
   ((and (<= v1 black-limit) (<= v2 black-limit))
    t)
   ;; all desaturated (gray) colors are similar for a value, despite hue
   ((and (<= s1 gray-limit) (<= s2 gray-limit))
    (when (<= (abs (- v1 v2)) value-range)
      t))
   (t
    (when (and (<= (abs (hue-difference-fixnum h1 h2)) hue-range)
               (<= (abs (- v1 v2)) value-range)
               (<= (abs (- s1 s2)) saturation-range))
      t))))

hsv-similarの亜種。

hue-difference

(defun hue-difference (h1 h2)
  "Return difference between two hues around 360 degree circle"
  (cond
   ((and (null h1) (null h2))
    t)
   ((or (null h1) (null h2))
    360)
   (t
    (let ((diff (- h2 h1)))
      (cond
       ((< diff -180)
        (+ 360 diff)
        )
       ((> diff 180)
        (- (- 360 diff)))
       (t
        diff))))))

hueの引き算。360度での計算になります。

(hue-difference-fixnum -361 -1)
→ 0 

hue-difference-fixnum

(defun hue-difference-fixnum (h1 h2)
  "Return difference between two hues around 360 degree circle"
  (cond
   ((and (null h1) (null h2))
    t)
   ((or (null h1) (null h2))
    360)
   (t
    (locally (declare (type fixnum h1 h2))
      (let ((diff (- h2 h1)))
        (cond
         ((< diff -180)
          (+ 360 diff)
          )
         ((> diff 180)
          (- (- 360 diff)))
         (t
          diff)))))))

hue-differenceの亜種。

このコードの中身とは関係ないところですが、 type declarations can be free declarations or bound declarations.

• CLHS: Declaration TYPE

なので、

    (locally (declare (type fixnum h1 h2))
      (let ((diff (- h2 h1)))
        (cond
         ((< diff -180)
          (+ 360 diff)
          )
         ((> diff 180)
          (- (- 360 diff)))
         (t
          diff))))

は、

    (let ((diff (- h2 h1)))
      (declare (type fixnum h1 h2))
        (cond
         ((< diff -180)
          (+ 360 diff)
          )
         ((> diff 180)
          (- (- 360 diff)))
         (t
          diff)))

と書けます。まあ気持ち悪い人には気持ち悪いかもしれません。

■

HTML generated by 3bmd in LispWorks 8.0.0

先日久々にKMRCLを眺めましたが、確認してみるとあと8ファイル眺めればKMRCLは読破できるようなので読み進めてみることにします。

hash.lisp を眺める

print-hash

hash.lispの中身はprint-hashのみです。

(defun print-hash (h &key (stream *standard-output*)
                   key-transform-fn value-transform-fn
                   (prefix "") (divider " -> ") (terminator "~%"))
  (maphash #'(lambda (k v)
               (format stream "~A~S~A~S"
                       prefix
                       (if key-transform-fn
                           (funcall key-transform-fn k)
                           k)
                       divider
                       (if value-transform-fn
                           (funcall value-transform-fn v)
                           v))
               (when terminator (format stream terminator)))
           h)
  h)

名前のとおりhash-tableの中身を印字するものです。
SBCL等は、describeで鍵/値の確認はできませんが、LispWorks等では中身を表示してくれるので、そういう処理系では不要かもしれません。

;;; SBCL
* (describe (alexandria:plist-hash-table '(a 0 b 1 c 2)))
#<HASH-TABLE :TEST EQL :COUNT 3 {1003D22A03}>
  [hash-table]
Occupancy: 0.4
Rehash-threshold: 1.0
Rehash-size: 1.5
Size: 7
Synchronized: no

;;; LispWorks
(describe (alexandria:plist-hash-table '(a 0 b 1 c 2)))
#<eql Hash Table{3} 40111C0803> is a hash-table
b      1
c      2
a      0

LispWorksの場合は、lw:*inspect-through-gui*をTに設定してのinspectの使い勝手が良いのでそちらでも良いでしょう。

■

HTML generated by 3bmd in LispWorks 8.0.0

Lisp一人 Advent Calendar 2021 25日目の記事です。

本アドベントカレンダー最終日ですが、特にどうということもなくLispネタを書いてゆきます。
開始前は、溜っていたネタを書いていくだけ、と考えていましたが、良く考えてみれば、記事にできないから溜ってしまったネタが多く、思いの外記事を作成するのに苦労してしまいました。
これだったらマイナーなテーマのアドベントカレンダーの方が楽だったかもしれません。

さて、今回は、λリストの&list-ofを紹介します。
&list-ofは、Common Lispには取り入れられなかったλリストなのですが、defmacroでletのような束縛構文を作成する際に頻出するパタンである、変数および値一覧の取得に便利に使えるものです。

(destructuring-bind (&rest &list-of (vars vals))
                    '((a 0)
                      (b 1)
                      (c 2))
  (list vars vals))
→ ((a b c) (0 1 2)) 

試してみたい方はいないと思いますが、昔に何故かxyzzy用に移植したものがCommon Lispでそのまま動くので一応Gistのリンクを貼っておきます。

• g000001/destructuring.lisp

これでdefmacroを作成するとこんな風になります

(defpackage "25d76a1c-7e26-5d83-8b7f-2afe5af560c1" 
  (:use cl destructuring)
  (:shadowing-import-from destructuring destructuring-bind &list-of)
  (:shadow defmacro))
(in-package "25d76a1c-7e26-5d83-8b7f-2afe5af560c1")
(cl:defmacro defmacro (name (&rest args) &body body)
  (let ((op (gensym "op"))
        (form (gensym "form"))
        (env (gensym "env")))
    `(eval-when (:compile-toplevel :load-toplevel :execute)
     (setf (macro-function ',name)
           (lambda (,form ,env)
             (destructuring-bind (,op ,@args) ,form
               (locally
                 (declare (ignore ,op ,env))
                 ,@body)))))))

これで、let的な構文を作成するのに&list-ofを使うと、このようにシンプルに書けます。

(defmacro mylet (&list-of (vars vals) &body body)
  `(multiple-value-bind (,@vars) (values ,@vals)
     ,@body))

(mylet ((a 0)
        (b 1)
        (c 2))
       (list a b c))
===>
(multiple-value-bind (a b c)
                     (values 0 1 2) 
  (list a b c))
→ (0 1 2)

まとめ

今回は&list-ofについての誰得情報を書いてみました。
古えに使われていたλリストについては、Lispマシンマニュアルに詳しい解説があるので、興味のある方は眺めてみてはいかがでしょうか。

• Chinual 6th ed.: Lambda-List Keywords

■

HTML generated by 3bmd in LispWorks 8.0.0

Lisp一人 Advent Calendar 2021 24日目の記事です。

MOPについて面白そうな文献がないかウェブを漁っていたら、面白そうな論文を見付けました。

• AvoidingConfusion in Metacircularity: The Meta-Helix

Meta-Helixというのは、クラス⇔インスタンスの関係に加えて、implemented-ofというインスタンス⇔実装の中身、という関係を入れたことで関係が螺旋状になっているのに由来するようですが、一応論文の流れを解説すると、CLOS MOPとTiny CLOS MOPを検討し、これらが持つ問題をMeta-Helical MOPで解決しようというところです。
AvoidingConfusion in Metacircularityというタイトルですが、CLOS MOPの方ではslot-value⇔slot-value-using-classの定義を無限ループさせてしまうことはたまにあるので、確かにそうかなという気はします。
ただし、この論文ではCLOS MOPのそういう超循環的な構成はプログラムとしては理解しやすいという長所はあり、Tiny CLOSのように、スロットと実装のフィールドを分けるのは複雑さを増している、としています。

さて、では超螺旋なMOPだとどういった構成になるのかというと、上述のようにシンプルにオブジェクトにimplemented-ofという関係を付け加えただけです。

昨年、このブログでallocate-instance アドベントカレンダーというのを開催してみましたが、バッキングストレージを別のオブジェクトにするというのは何パタンか試していて、オブジェクトの一連のスロットが別のオブジェクトというパタンかと思います。

なお、Meta-Helixは、コンパイル時/実行時の両方での実現を視野に入れたMOPですが、この論文では説明の都合上実行時のMeta-Helical MOPについての解説が主です。

……ということで実行時超螺旋MOPを実現するメタクラスを下記のように書いてみました。
なお、コードを単純にするため、オブジェクトのスロットをいじるのに自作のライブラリを使っています。

;; https://github.com/g000001/slotted-objects
(ql:quickload '(closer-mop slotted-objects))

(defpackage "ee552d98-e6ee-53f5-98a6-09edb2b2b5ea" 
  (:use c2cl slotted-objects))

(in-package "ee552d98-e6ee-53f5-98a6-09edb2b2b5ea")

(defclass meta-helix-class (slotted-class)
  ((implemented-by :initform (find-class 'standard-class) 
                   :accessor class-implemented-by
                   :initarg :implemented-by)))

(defmethod validate-superclass ((c meta-helix-class) (s standard-class))
  T)

(defclass meta-helix-object (slotted-object)
  ()
  (:metaclass meta-helix-class))

(defgeneric implemented-by (object))
(defmethod implemented-by ((object meta-helix-object))
  (instance-slots object))

(defmethod allocate-instance ((class meta-helix-class) &rest initargs)
  (allocate-slotted-instance (class-wrapper class)
                             (make-instance (class-implemented-by class))))

(defmethod slot-value-using-class ((class meta-helix-class) instance (slotd slot-definition))
  (slot-value-using-class (class-implemented-by class) 
                          (implemented-by instance)
                          slotd))

(defmethod (setf slot-value-using-class) (value (class meta-helix-class) instance (slotd slot-definition))
  (setf (slot-value-using-class (class-implemented-by class) 
                                (implemented-by instance)
                                slotd)
        value))

#+lispworks
(defmethod clos:process-a-class-option ((class meta-helix-class)
                                        (name (eql :implemented-by))
                                        value)
  (unless (and value (null (cdr value)))
    (error "meta-helix-class :implemented-by must have a single value."))
  `(,name ',(car value)))

#-lispworks
(defmethod ensure-class-using-class :around ((class meta-helix-class) name 
                                             &rest initargs
                                             &key (implemented-by nil implemented-by-p))
  (if (and implemented-by-p
           (consp implemented-by))
      (apply #'call-next-method class name :implemented-by (car implemented-by) initargs)
      (call-next-method)))

論文の例を試してみる

まず、xとyのスロットを有するpointオブジェクトを考えます。

(defclass point ()
  (x y))

このオブジェクトにスロットアクセスの履歴を付けたい、という場合、履歴スロット含んだpoint*をpointの実装オブジェクトとして定義します。
このオブジェクトは何等メタな細工はされていないstandard-objectのサブクラスオブジェクトです。

(defclass point* ()
  ((history :initform '())
   (x :initform 0)
   (y :initform 0)))

このpoint*を利用するようにpoint側を定義します。

(defclass history-class (meta-helix-class)
  ())

(defclass history-object ()
  ()
  (:metaclass history-class))

(defclass point (meta-helix-object)
  (x y)
  (:metaclass history-class)
  (:implemented-by point*))

論文のコード例に似せて、history-class/history-objectを定義しましたが、関係が捻れているので逆にわかり辛いかもしれません。
論文には:implemented-byの関係を記述する方法が記載されていないようですが、クラスのオプションで適当に指定することにしました。

そしてスロットのアクセス時にhistoryスロットに履歴を記録するようにします。

(defmethod slot-value-using-class ((class history-class) object (slotd slot-definition))
  (let* ((implemented-by (implemented-by object))
         (slot-name (slot-definition-name slotd)))
    (push `(slot-value ,slot-name)
          (slot-value implemented-by 'history))
    (slot-value implemented-by slot-name)))

(defmethod (setf slot-value-using-class) (value (class history-class) object (slotd slot-definition))
  (let* ((implemented-by (implemented-by object))
         (slot-name (slot-definition-name slotd)))
    (push `((setf slot-value) ,slot-name)
          (slot-value implemented-by 'history))
    (setf (slot-value implemented-by slot-name) value)))

一見して判るようにimplemented-byでリダイレクトしているだけです。

これでこのように使えます。

(let ((point (make-instance 'point)))
  (setf (slot-value point 'x) 42)
  (slot-value point 'y)
  (slot-value point 'x)
  (slot-value (implemented-by point) 'history))
→ ((slot-value x) (slot-value y) ((setf slot-value) x)) 

コンパイル時超螺旋MOP

コンパイル時MOPというのは、基本的にコンパイル時にのみ存在するメタオブジェクトを操作してあれこれするものですが、implemented-byの関係は、Common Lispであれば、マクロやコンパイラマクロ等で、コンパイル時に展開してしまえそうです。
例えば、上記の例は、

(let ((point (make-instance 'point*)))
  (progn
    (push `((setf slot-value) x)
          (slot-value point 'history))
    (setf (slot-value point 'x) 42))
  (progn
    (push `(slot-value y)
          (slot-value point 'history))
    (slot-value point 'y))
  (progn
    (push `(slot-value x)
          (slot-value point 'history))
    (slot-value point 'x))
  (slot-value point 'history))
→ ((slot-value x) (slot-value y) ((setf slot-value) x)) 

という風に展開すれば良いことになります。

まとめ

Meta-Helixという名称は特に広まっていないようですが、実行時MOPとコンパイル時MOPを繋ぐような概念かなと思いました。
これまでこのブログでも＜MOP vs マクロ＞のようなことを書いてきましたが、implemented-ofの関係で整理できないか試してみたいところです。

関連

• MOP vs マクロ (1)
• MOP vs マクロ (2)
• MOP vs マクロ (3)
• MOP vs マクロ (4)
• MOP vs マクロ (5)
• MOP vs マクロ (6)
• MOP vs マクロ (7): Gaucheのpropagatedスロット再現
• MOP vs マクロ (8): メソッド定義でselfを使って楽をしたい

■

HTML generated by 3bmd in LispWorks 8.0.0

Lisp一人 Advent Calendar 2021 23日目の記事です。

SBCLではコンパイラマクロの発展形のようなdeftransformでコンパイル時の型情報を扱って式の展開を制御できたりします。
下記は、x+yという2引数の関数の型情報をみてコンパイル時に式を展開する例です。

#+sbcl
(sb-c:defknown x+y (t t) t () :overwrite-fndb-silently t)
(sb-c:deftransform x+y ((x y) (cl:number cl:number))
  '(cl:+ x y))
(sb-c:deftransform x+y ((x y) (cl:list cl:list))
  '(cl:append x y))
(sb-c:deftransform x+y ((x y) (cl:string cl:string))
  '(cl:concatenate 'cl:string x y))

SBCLでしか使えないのが残念ですが、しかし、良く考えてみると、型の情報は取得できなくても、変数の型宣言の情報は、variable-informationで取得できるので、コンパイル時にコンパイラマクロで展開を制御できるのではないかと思ったので、試しに書いてみます。

• CLtL2: variable-information

(import #+sbcl 'sb-cltl2:variable-information
        #+lispworks 'hcl:variable-information
        #+allegro 'sys:variable-information)
;;; デフォルトの挙動
(defun foo (x) (list :default x))
(foo 42)
→ (:default 42)
;;; コンパイル時に展開を制御するユーティリティ
(defmacro variable-information-typecase (var env &body clauses)
  `(case (cdr (assoc 'type (nth-value 2 (variable-information ,var ,env))))
     ,@clauses))
;;; foo にコンパイラマクロを設定
(define-compiler-macro foo (&whole w x &environment env)
  (variable-information-typecase x env
    (fixnum `(list 'fixnum ,x))
    (string `(list 'string ,x))
    (symbol `(list 'symbol ,x))
    (T w)))

コンパイラマクロを設定したので、コンパイルして確認してみます。

(defun fixnum-bar (x)
  (declare (type fixnum x))
  (foo x))
(defun string-bar (x)
  (declare (type string x))
  (foo x))
(defun symbol-bar (x)
  (declare (type symbol x))
  (foo x))

(fixnum-bar 42)
→ (fixnum 42)
(string-bar "foo")
→ (string "foo")
(symbol-bar 'foo)
→ (symbol foo)

できました!

型宣言がないと分岐できないものの、宣言を活用すれば、コンパイル時に展開を分岐することは可能みたいです。
ちなみに、Allegroは型の名前がちょっと違うので、上の定義では上手く行きません。
variable-information 自体がCLtL2の拡張なので可搬的ではありませんが、サポートしている処理系はそこそこ多いので活用できるのではないでしょうか。

■

HTML generated by 3bmd in LispWorks 8.0.0

Lisp一人 Advent Calendar 2021 22日目の記事です。

記事にまとめられるネタが切れてしまったので、十年ぶりにKMRCLを眺めてみたいと思います。

いまから十年程前には、KMRCLを眺める、というお題で毎日のようにKMRCLのコード片を眺めてブログ記事にしていましたが、実に236回もやっていたようです。
しかし、その割には未だに完読していません。

• TAG: KMRCL

math.lisp を眺める

どこまで読み進めたかのメモを残していた筈なのですが、みつからないため、本ブログを検索して該当なしなので、未だ眺めていないと思われるmath.lispを眺めます。

deriv sin^

(in-package #:kmrcl)
(defun deriv (f dx)
  #'(lambda (x)
      (/ (- (funcall f (+ x dx)) (funcall f x))
         dx)))
(defun sin^ (x)
  (funcall (deriv #'sin 1d-8) x))

よくある微分ユーティリティです。

(funcall (deriv (lambda (x) (expt x 2)) 1d-8) 8)
→ 15.999998481674993D0
(sin^ pi)
→ -0.999999993922529D0

ensure-integer

(defmacro ensure-integer (obj)
  "Ensure object is an integer. If it is a string, then parse it"
  `(if (stringp ,obj)
      (parse-integer ,obj)
     ,obj))

parse-integerを若干安全にした感じでしょうか。nilでのエラーを回避するため?

(ensure-integer "42")
→ 42
  2

histogram

(defun histogram (v n-bins &key min max)
  (declare (fixnum n-bins))
  (when (listp v)
    (setq v (coerce v 'vector)))
  (when (zerop (length v))
    (return-from histogram (values nil nil nil)) )
  (let ((n (length v))
        (bins (make-array n-bins :element-type 'integer :initial-element 0))
        found-min found-max)
    (declare (fixnum n))
    (unless (and min max)
      (setq found-min (aref v 0)
            found-max (aref v 0))
      (loop for i fixnum from 1 to (1- n)
          do
            (let ((x (aref v i)))
              (cond
               ((> x found-max)
                (setq found-max x))
               ((< x found-min)
                (setq found-min x)))))
      (unless min
        (setq min found-min))
      (unless max
        (setq max found-max)))
    (let ((width (/ (- max min) n-bins)))
      (setq width (+ width (* double-float-epsilon width)))
      (dotimes (i n)
        (let ((bin (nth-value 0 (truncate (- (aref v i) min) width))))
          (declare (fixnum bin))
          (when (and (not (minusp bin))
                     (< bin n-bins))
            (incf (aref bins bin))))))
    (values bins min max)))

Wikipediaのヒストグラムの例を計算してみるとこんな感じです。

(histogram '(78 126 156 231 215 304 484 544 566 545 478 258 225 373 620 
             625 606 483 377 370 587 667 643 756 505 436 399 611 679 575 565)
           8
           :min 0
           :max 799)
→ #(1 2 4 5 4 7 7 1)
  0
  799

fixnum-width

(defun fixnum-width ()
  (nth-value 0 (truncate (+ (/ (log (1+ most-positive-fixnum)) (log 2)) .5))))

(integer-length most-positive-fixnum) → 60

と同じ気がするんですが、何か違ってくるのかもしれない。

(fixnum-width)
→ 60

scaled-epsilon

(defun scaled-epsilon (float &optional (operation '+))
  "Return the smallest number that would return a value different from
  FLOAT if OPERATION were applied to FLOAT and this number.  OPERATION
  should be either + or -, and defauls to +."
  (multiple-value-bind (significand exponent)
      (decode-float float)
    (multiple-value-bind (1.0-significand 1.0-exponent)
        (decode-float (float 1.0 float))
      (if (and (eq operation '-)
               (= significand 1.0-significand))
          (scale-float (typecase float
                         (short-float short-float-negative-epsilon)
                         (single-float single-float-negative-epsilon)
                         (double-float double-float-negative-epsilon)
                         (long-float long-float-negative-epsilon))
                       (- exponent 1.0-exponent))
        (scale-float (typecase float
                       (short-float short-float-epsilon)
                       (single-float single-float-epsilon)
                       (double-float double-float-epsilon)
                       (long-float long-float-epsilon))
                     (- exponent 1.0-exponent))))))

このユーティリティの使い方が良く分からないのですが誤差を確認するためのものでしょうか。

sinc

(defun sinc (x)
  (if (zerop x)
      1d0
    (let ((x (coerce x 'double-float)))
      (/ (sin x) x))))

double-floatを返す非正規化sinc関数です。

numbers-within-percentage

(defun numbers-within-percentage (a b percent)
  "Determines if two numbers are equal within a percentage difference."
  (let ((abs-diff (* 0.01 percent 0.5 (+ (abs a) (abs b)))))
    (< (abs (- a b)) abs-diff)))

或る二つの数が指定されたパーセントの誤差範囲に収まっているかを確認するものです。

(numbers-within-percentage 100 96 5)
→ t
(numbers-within-percentage 100 94 5)
→ nil

まとめ

実に十年ぶりにKMRCLを眺めましたが、237回も記事にしているなら流石に完読を目指したいところです。

■

HTML generated by 3bmd in LispWorks 8.0.0

Lisp一人 Advent Calendar 2021 21日目の記事です。

RISC-Vが盛り上がっている昨今ですが、RISC-IVはLisp向けアーキテクチャだったことはご存知でしょうか。
などと、はじめましたが、RISC-VとRISC-IV間でアーキテクチャ的な継承をしていたりはないようです。残念。
そもそも、RISC-IVは、1988年あたりのプロジェクトで、RISC-Vは2010年あたりに開始だそうなので、年月的にも大分隔があります。

RISC-IV(SPUR)プロセッサとは

RISC-IVは、SPURと呼ばれていましたが、Symbolic Processing Using RISCsの略だそうで、そのまま解釈すると並列記号処理向けRISCというところです。
プロジェクトも実際にSMP構成のプロセッサを複数台接続し、分散OSで並列処理のLispを動かす試みというところだったようです。
Lispは、CMUCLやSBCLの先祖であるSpice Lispを並列処理拡張したもので、SPUR Lispという名前でした。

1988年当時は、並列Lispが結構熱い時代でしたが、Connection Machine Lispのような超並列マシンでデータ並列ではなく、それらからすると比較的少数のSMP構成のプロセッサを繋ぐものだったようです。
Common Lisp規格には並列/並行の規定がないため、SPUR Lispでは、メールボックスを基礎とし、その上にfutureやdelayを構成するような拡張をしていたとのことですが、近年のネイティブスレッド対応のCommon Lisp処理系は大体似たような拡張をしているかなと思います(futureやdelayの活用はあまり見掛けない気はしますが)し、SPURマシンの標準的プロセッサ数は多くても12台程度だったようなので最近のPCのコア数と大差ない感じです。

一応、SPURプロセッサのLisp向け機能としては、タグアーキテクチャ、世代別GCのハードウェア支援、関数呼び出しの高速化(レジスタウィンドウ)があるようです。

EECS at UC BerkeleyでSPURで検索すると文献が結構ありますので興味のある方は眺めてみてはいかがでしょうか。

• Berkeley|EECS: Search: spur

参照

• RISC-Vの誕生　既存の命令セットアーキテクチャでは満足できなかった、その理由
• SPUR Lisp: Design and Implementation
• Features for Multiprocessing in SPUR Lisp

■

HTML generated by 3bmd in LispWorks 8.0.0

Lisp一人 Advent Calendar 2021 20日目の記事です。

世の中の人のLispの括弧が駄目というのは、コードがデータに見えてしまって駄目ということなのではないか説

表題のとおりなのですが、このブログの読者はS式で記述されたコードに順応し過ぎている方が殆どだと思いますので、Lisperにも直感的に伝わるように表現するならば、どうにもS式が駄目だ、という人は、こういうコードが、

;;; S式
(defun fib (n)
   (if (< n 2)
       n
       (+ (fib (1- n))
          (fib (- n 2)))))

こう見えている可能性があるんじゃないでしょうか

;;; リスト
#.(list 'defun
        'fib
        (list 'n)
        (list 'if
              (list '< 'n '2)
              'n
              (list '+ 
                    (list 'fib (list '1- 'n))
                    (list 'fib (list '- 'n 2)))))

これなら流石のLisperでも、コードというよりデータに見えるでしょう。

以前、色々な言語でS式を書いてみるというのを試してみましたが、データの表記は大抵、括弧で括られています。

• 色々な言語でCommon Lispのコードを書いてみよう

人よっては括弧で括られたものは、何をどうしてもデータに見えてしまうのではないでしょうか。
Lisperには嫌われるぶら下り括弧もコードがデータに見えないようにする為の抵抗に思えたりもしなくもありません(まあ括弧の対応のためというのもありますが)

ちなみに、S式も、カンマ区切りにすると、コードよりはデータに見えてきます。

;;; S式
(defun, fib, (n),
   (if, (<, n, 2),
       n,
       (+, (fib, (1-, n)),
           (fib, (-, n, 2)))))

S式はこのコードとデータの表記の間の絶妙なバランスで成立している気がしてきました。

鶏と卵の問題ですが、コードとデータを行き来するような言語が流行れば、必然的にS式のような表記体系に落ち着くのではないでしょうか。

■

HTML generated by 3bmd in LispWorks 8.0.0

Lisp一人 Advent Calendar 2021 19日目の記事です。

ブログ記事で未実装の関数定義のHaskellでの取扱い方法を読み、Common Lispでも実現できそうだと思いメモしていましたが、いつの間にか九年程経過していました。
元ブログも消滅してしまったようです……。

• undefinedの代わりに$notImplementedを使おう

さて、not-implementedのようなプレイスホルダー自体はCommon Lispでも良く見掛ける手法で、中身はerrorをあげるものになっていることが殆どかと思います。
今回は、コンパイル時には警告、実行時にはエラー、というマクロを定義してみたいと思います。
おまけでコンパイル時に警告を出すtodo、fixmeも作成してみます。

(define-condition not-implemented-error (simple-error)
  ())
(define-condition not-implemented-warning (simple-warning)
  ())
(define-condition todo (simple-warning)
  ())
(define-condition fixme (simple-warning)
  ())
(defun get-block-name (env)
  #+sbcl (caar (sb-c::lexenv-blocks env))
  #+lispworks (caar (compiler::compiler-environment-benv env)))
(defmacro not-implemented (&environment env)
  (let ((fmtargs (list :format-control "~S : not implemented for ~A ~A"
                       :format-arguments (list 
                                          (get-block-name env)
                                          (lisp-implementation-type)
                                          (lisp-implementation-version)))))
    (apply #'warn 'not-implemented-warning fmtargs)
    `(error 'not-implemented-error
           ,@(mapcar (lambda (a) `',a) fmtargs))))
(defmacro todo (msg &environment env)
  (warn 'todo
        :format-control "~S : TODO : ~A"
        :format-arguments (list (get-block-name env) msg))
  nil)
(defmacro fixme (msg &body body &environment env) 
  (warn 'fixme
        :format-control "~S : FIXME : ~A"
        :format-arguments (list (get-block-name env) msg))
  `(progn ,@body))

使ってみる

(defun foo (x)
  (not-implemented)
  (todo "ご飯食べてから実装する")
  (fixme "治して……"
    (* 42 x)))
3 compiler notes:
g001992.lisp:109:3:
  warning: foo : not implemented for SBCL 1.4.12
g001992.lisp:110:3:
  warning: foo : TODO : ご飯食べてから実装する
g001992.lisp:111:3:
  warning: foo : FIXME : 治して……
Compilation failed.

(foo 8)
!>> foo : not implemented for LispWorks 8.0.0

まとめ

ブロック名を取得するのにANSI CL規格外機能を利用していますが、その他は宏マクロ展開時にwarnを出しているだけです。
処理系によってはwarnにブロック名をつけるので不要だったりはするのですが。

■

HTML generated by 3bmd in LispWorks 8.0.0

Lisp一人 Advent Calendar 2021 19日目の記事です。

Common Lispでは処理系依存の処理を記述するのに#-/#+を使いますが、込み入った条件の場合は結構面倒で、それに伴なったデフォルトケースの記述も面倒です。
既に色々解決方法は考えられていると思いますが、自分もちょっと考えてみました。

(defmacro feature-case (&body clauses)
  `(eval-when (:compile-toplevel :load-toplevel :execute)
     (macrolet ((run ()
                  (read-from-string 
                   ,(with-output-to-string (out)
                      (format out "~&(cond ~%")
                      (dolist (c clauses)
                        (typecase (cadr c)
                          (STRING 
                           (format out
                                   "~&#+~A (T (progn ~A))~%"
                                   (car c)
                                   (cadr c)))
                          (T (if (eql 'otherwise (car c))
                                 (format out
                                         "~&(T ~S)~%"
                                         `(progn ,@(cdr c)))
                                 (format out
                                         "~&#+~A (T ~S)~%"
                                         (car c)
                                         `(progn ,@(cdr c)))))))
                      (format out "~&)~%")))))
       (run))))

利用例

入れ子にもできます。

(feature-case
  (lispworks
   (feature-case 
     (lispworks7+
      (feature-case 
        (lispworks8 'foo)))))
  (otherwise nil))
→ foo

なお、読取時に存在するパッケージが処理系によってまちまちなため、マクロ展開時に存在しないパッケージを読み込んでエラーにならないようにする必要があります。
ここはポータブルには回避しようがないので、文字列で記述してもらうことにしました。

(feature-case
  ((and lispworks6 (or win32 linux))
   "(defmethod environment-p ((environment lexenv::environment))
     t)")
  ((and lispworks7+ (or win32 linux))
   "(defmethod environment-p ((environment compiler::environment))
     t)")
  (otherwise nil))