暗黙のprognならぬ暗黙のlet
Posted 2020-07-05 21:02:45 GMT
古くからボディ部に複数の式を取れることを暗黙のprognといいますが、別にletでも良いんじゃないかなと思って試してみました。
(defpackage let
(:use)
(:export cond lambda))(defun implicit-let-form-p (form)
(member (car form) '(let let*)
:test #'string-equal
:key #'princ-to-string))
(defmacro let:cond (&rest clauses)
`(cond ,@(mapcar (lambda (c)
(if (implicit-let-form-p (cdr c))
`(,(car c) ,(cdr c))
c))
clauses)))
(defmacro let:lambda ((&rest args) &body clauses)
`(lambda (,@args)
,@(if (implicit-let-form-p clauses)
`(,clauses)
clauses)))
(defun fib (n)
(let:cond ((< n 2) let ((f n)) f)
(T let ((f1 (fib (1- n)))
(f2 (fib (- n 2))))
(+ f1 f2))))
(fib 10)
→ 55
(mapcar (let:lambda (x)
let ((y (* 2 x)))
y)
'(0 1 2 3))
→ (0 2 4 6)
ネストが一つ減らせる位しか御利益がないですが、大抵の言語のブロックは、変数のスコープと複数フォームを纏める機能が合体しているので、prognまで分解されずに、letがビルディングブロックん基本なのかなと思ったり思わなかったりです。
ちなみに、どこかでみたことがある気がしましたが、Conniverのcdefunのボディ部での“AUX”という記述が今回の暗黙のletそのままでした。
(完全に忘却していた……)
("AUX" (x y z) ...)のように単体フォームでも使えるようですが、詳細は調べきれていません。
もしかしたら、Conniverは暗黙のprognから進んで、暗黙のletだったのかも?
更新:※Conniverのマニュアルで確認してみたところ、フォームの第二要素が予約語“AUX”であった場合、第三要素はprog変数宣言となる、ということみたいです。
つまり暗黙のprogということみたいですが、暗黙のletみたいなものといえるでしょう。
Conniverの“AUX”は、MDLが由来のようですが、受け継いたCommon Lispのように引数部に記述するのではなく、ボディ部に記述するというのが面白いですね。
ちなみに暗黙のprognとは
Lispでは値を返すスタイルが古くから基本となっていますが、副作用目的で複数の式をまとめる記述としてprogやprog2というフォームも古くから存在しました。
任意の複数の式をまとめるフォームということで落ち着いたのがprognですが、SDS 930 LISPあたりが最初のようです。
prognは便利だったのか、ついでにcondや、lambdaの既存のフォームのボディ部で、prognのように複数の式を取れるように拡張されました。
これを暗黙のprognと呼びますが、元は1つの式しか記述することができなかったため、暗黙のprognという言葉がうまれ後世まで伝わってしまったのでしょう。
(lambda (x) x)
↓
(lamba (x) (progn x x x))
↓
(lamba (x) x x x)今となっては何故1つの式しか元は記述することができなかったのかと思ったりもしますが、複数の式を含むということは、値を返さない式を含む(副作用目的の式を含む)ということになるので、元々のLISPは純粋な関数を指向していたともいえます。
もちろん手続的に記述するprogもあったりはするのですが、元々はsetq等の代入もprogの中でしか使えませんでした。
■
HTML generated by 3bmd in LispWorks Personal Edition 7.1.2
真のLispエディタでは論理パスが使える
Posted 2020-06-28 19:55:59 GMT
論理パスを設定しておくと便利なこともあるので、良く使うlispファイル置き場のディレクトリ等に“lisp:”なんていう論理パスを設定したりしています。
“~/lisp” であれば下記のように設定可能です。
(setf (logical-pathname-translations "LISP")
`(("*" ,(merge-pathnames
(make-pathname :name :wild :directory '(:relative "LISP") :case :common)
(user-homedir-pathname)))))(load "lisp:foo")で、“~/lisp/foo.lisp”がロードできたりするのが便利です。
quicklispなども論理パスを設定しておけば、
(load "quicklisp:setup")でロードできたりしますが、まあ便利な時は便利でしょう。
ちなみに初期化ファイルを読み込まない状態で、論理パスをロードする仕組みがCommon Lispには、load-logical-pathname-translationsとして用意されていますが、処理系によって記述方法はまちまちです。
Lispエディタで論理パスは使えるか
そんな日々でしたが、普段から論理パスを使っているとエディタでファイルを開く際にも使いたくなります。
論理パスでファイルを開けたりしないもんかなと、試しにLispWorksのエディタのFind Fileで論理パスで指定してみたところ、普通に開けてしまいました。
素直に開けてしまうのが逆に不思議だったので、Find Fileのソースを眺めてみましたが、文字列がprobe-fileに渡されるので、ここで実ファイルにマッピングされる様子。
当然ながら、Common Lisp製のエディタはCommon Lispのパス処理の関数を使うわけで、意図的かどうかは扨措き、エディタも論理パスを処理できちゃうみたいです。
ちなみに、SymbolicsのZmacsではどうなのかなと思い、論理パスを設定して試してみましたが、Find Fileで普通に論理パスが使えました。
こちらは様々なOSが混在した環境で論理パスを設定していた時代に実際に使われていたと思うので、元からサポートしているのでしょう。
論理パスは、物理的にはばらばらに存在するファイルをツリー状にまとめたりがLisp内で簡単にできます。
色々制限はあるのですが、使い方次第では便利に使えるかもしれません。
まとめ
真のLispエディタでは論理パスが使える。
■
HTML generated by 3bmd in LispWorks Personal Edition 7.1.2
LispWorks 7.1.2 Personal Edition リリース
Posted 2020-05-21 03:40:49 GMT
LispWorksは商用のCommon Lisp処理系で、お試し版としては、Personal Editionというものがあるのですが、長らくアップデートされていませんでした。
前回リリースされた LispWorks 6.1.1 Personal Edition が、2013-01-19のリリースだったので実に7年ぶりのリリースとなります。
今回リリースされたPersonal Editionのプラットフォームは、x86系とArm。
これら以外のプラットフォームでもLispWorksは稼動しますが、x86系とArm以外を使っている人は稀だと思うので、問題になることはないでしょう。
なお、Personal Edition以外のLispWorksの各エディションは申請すれば一ヶ月評価できるので、マイナープラットフォームの方々でも申請すれば購入前に評価は可能です。
これまで商用処理系の評価版というとLispWorksもFranzのAllegroも32bit版限定でしたが、今回のLispWorks 7.1.2 Personal Editionでは64bit版も配布されています。
32bit環境の方が特殊になりつつある昨今なので当然といえば当然ですが、嬉しいところですね。
LispWorks 7.1.2 Personal Editionの制限
- 利用メモリの制限
- 連続起動時間5時間
- 初期化ファイルが読み込めない
等々は過去のバージョン同様の制限となっています。
5時間の制限と初期化ファイルを手動で読み込ませる必要があることについては、大して苦労することはないのですが、常用するには利用メモリの制限が結構厳しい。
例えば、ironclad等はビルドに結構負荷が掛る方ですが、こういうのは途中で終了となってしまいます。
コンパイルできる範囲でちまちまfaslを生成、処理系を立ち上げ直してロード、という作戦で乗り切ることも場合によっては不可能ではありませんが結構手間ですね。
LispWorks 7.1.2 Personal Editionの使われ方様々
LispWorksを評価するのが本来の目的かと思いますが、意外に大学の授業等での利用が結構あるようです。
PAIPの題材のような古典AIの授業の処理系として活用されているようですが、GUI付きのIDEとしてワンクリックで起動し利用できるので、確かにCommon Lisp入門や学習用途には結構良いと思います。
まとめ
このブログはLispWorksのエディタで書いて、LispWorksからサーバにアップロードという仕組みで更新していますが、今回のブログはLispWorks 7.1.2 Personal Editionで書いてみました。
ちなみに、標準の初期化ファイルを読み込ませるには、リスナーから、
(load *init-file-name*)とすると楽です。
LispWorksのリスナーでは最外の括弧を記述しなくても良いので、
load *init-file-name*でもOK。 M-iや、M-C-iで補完も可能なので、load *ini位までの入力で済みます。
■
HTML generated by 3bmd in LispWorks Personal Edition 7.1.2
CLでSRFI 173
Posted 2020-04-18 20:41:27 GMT
CLでSRFI、今回移植したのは、SRFI 173: Hooksです。
srfi-173は、古典的なLispでお馴染の機構であるフック機構を実現しようというものです。
移植について
参照実装をコピペしただけです。
元がシンプルなので特にソースコードを変更する必要もありませんでした。
テストコードにも手を加えないことにしようかとも思いましたが、テストケースが数個だったのでfiveamの形式にササッと書き直しました。
動作
advice機構のように関数名(シンボル)に関数をぶらさげるのではなく、フックオブジェクトに関数をどんどん登録していきます。
各フックの起動順は不定。フック起動結果の値も不定。
リストに関数をプッシュしていって後で順に呼び出しするのとあまり変らない使い勝手です。
(defvar *hook* (make-hook 0))(defun one () (print 1))
(defun two () (print 2))
(defun three () (print 3))
(progn
(hook-add! *hook* #'one)
(hook-add! *hook* #'two)
(hook-add! *hook* #'three))
→ (#<Function three 40D005342C>
#<Function two 40D00533C4>
#<Function one 40D005335C>
#<Function three 40D005342C>
#<Function two 40D00533C4>
#<Function one 40D005335C>)
(hook-run *hook*)
▻
▻ 3
▻ 2
▻ 1
→ nil
導入
Ultralispに登録してみたので、
(ql-dist:install-dist "http://dist.ultralisp.org/")してあれば、
(ql:quickload :srfi-173)でインストール可能です。
■
HTML generated by 3bmd in LispWorks 7.1.2
CLでSRFI 145
Posted 2020-04-13 20:47:55 GMT
CLでSRFI、今回移植したのは、SRFI 145: Assumptionsです。
srfi-145はざっくりいえば、Common Lispのassertに相当するもので、定義はassume一つだけです。
Common Lispのassertは再起動等のアクションがありますが、assumeにはありません。
移植について
assumeのようなものを記述メリットのようなものが色々解説されていますが、賢いコンパイラなら最適化するかもしれない、系の記述が殆どで、assume自体に組込まれた機構で何かする、というわけではありません。
assumeが記述されることによってコンパイラへの最適化やエラーチェックのヒントが増える、という話のようです。
色々書いてあるので、srfi-145で可能性として示されていることが実際に実現できないかをSBCLをメインに試してみました。
Common Lispでも大体似たようなことはできますが、srfi-145の例のような書き方ではないので、実現するにはコンパイラに色々仕込む必要があるようです。
Schemeのコンパイラにsrfi-145が記述しているような可能性を実現している/する可能性のあるコンパイラってあるんでしょうか(なさそう)
動作
(assume (= 1 1) "1 = 1")
→ nil(assume (= 1 2) "1 = 1")
>> invalid assumption: (= 1 2)
>> 1 = 1
導入
Ultralispに登録してみたので、
(ql-dist:install-dist "http://dist.ultralisp.org/")してあれば、
(ql:quickload :srfi-145)でインストール可能です。
■
HTML generated by 3bmd in LispWorks 7.0.0
CLでSRFI 115
Posted 2020-04-10 21:00:30 GMT
CLでSRFI、今回移植したのは、SRFI 115: Scheme Regular Expressionsです。
srfi-115は、S式で記述する正規表現で、その表現形式は古くからあるThe SRE regular-expression notation記法を軸にしたものです。
作者のAlex Shinn氏は、IrRegular ExpressionsというS式正規表現のライブラリを作成していて、大体そのサブセットがsrfi-115としてまとまったようです。
Common Lispへの移植は、ドラフト時の2013年に一度試してみたのですが、さすがにドラフトだと結構変更があるようなので、ファイナルまで落ち着くまで様子見してたら7年位経過していました。
移植について
参照実装をコピペしただけに近いですが、参照実装には、regexp->sre等の便利ツールが含まれていません。
また仕様自体も核と拡張部分にわかれていますが、参照実装は、核の部分のみのようです。
ドラフトの時はほぼIrRegular Expressionsと同じようなものでしたが、合意が取れなさそうなところはどんどん削って核にしてしまい、残りは拡張部分となったのでしょうか……。
実用面では、IrRegular Expressionsの方が便利なので、Common Lispへの移植し甲斐があるのはIrRegular Expressionsの方でしょう。
ライブラリのサブセットを仕様として定義した例はCommon Lispにも多数ありますが(loop、format等)、中途半端なことになりがちな気がします。
動作
(regexp-search '(w/nocase "foobar") "abcFOOBARdef")
→ #<Regexp-Match 4020002B23> (regexp-replace "n" "banana" "k")
→ "bakana"
(regexp-replace-all '("aeiou") "hello world" "*")
;; or (regexp-replace-all '(or "a" "e" "i" "o" "u") "hello world" "*")
→ "h*ll* w*rld"
(regexp-split "a" "banana")
→ ("b" "n" "n" "")
(regexp-extract '(+ numeric) "192.168.0.1")
→ ("192" "168" "0" "1")
導入
Ultralispに登録してみたので、
(ql-dist:install-dist "http://dist.ultralisp.org/")してあれば、
(ql:quickload :srfi-115)でインストール可能です。
その他
Common LispにSchemeのコードを移植する際に、どうしようかなと悩むのが、:をシンボル名として使うにはエスケープしなければいけないことだったりするのですが、今回は、:を$に置き換えました。
しかし、:をエスケープして\:と書いてもSchemeでは問題ないですし、コードの共用という面では別の文字に置き換えたりせずに、\でエスケープの方が良いかもしれません。
S式正規表現仲間
Common LispでS式正規表現だと、cl-irregsexpというのがあります。
IrRegular Expressionsも似たような名前ですが、なんか付けたくなるような名前なのでしょう。
Uncommon Lisp(R3RS Scheme)系の命名に似てますね。
■
HTML generated by 3bmd in LispWorks 7.0.0
CLでSRFI 172
Posted 2020-04-05 21:25:09 GMT
CLでSRFI、今回移植したのは、SRFI 172: Two Safer Subsets of R7RSです。
srfi-172の概要ですが、サンドボックス環境の構築を目的としたサブセットの提案で、副作用手続きあり版(srfi 172)となし版(srfi 172 functional)の2つがあります。
(srfi 172 functional)はざっくりいうと!手続きが含まれていないものという感じです。
Common Lispへの移植の際に参照実装には存在するstring->symbolが仕様の方には見当たらず、symbol->stringと対にならないので報告してみたところ、シンボルがGCされない処理系を考慮して入れていないので、参照実装のミスとのことでした。
安全指向のサンドボックスなので、GCを狙った攻撃等に配慮しているということなのでしょう。
移植について
これまで移植したsrfiをベースにまとめてみましたが、100番台以降に改善版が提案されているような古いsrfiが多いので、そのうち新しいsrfiに置き換えたいところ。
導入
Ultralispに登録してみたので、
(ql-dist:install-dist "http://dist.ultralisp.org/")してあれば、
(ql:quickload :srfi-172)でインストール可能です。
その他
最近のsrfiはgithubにコードや仕様が置かれていますが、githubのイシューを登録するのか、srfiのメーリングリストにイシューを投げるのか若干謎でした。
結局今回は両方に登録しましたが……。
■
HTML generated by 3bmd in LispWorks 7.0.0
Practical Scheme 20周年おめでとうございます!
Posted 2020-04-02 15:44:00 GMT
Practical Scheme サイト20周年おめでとうございます!
といっても実は半年過ぎてしまっていたようなのですが……。
しばらく前から準備していた Schemeのページ をぼちぼちアナウンスすることにする。
今はまだ、公開できそうなSTkの拡張モジュールを置いておくだけだが、 将来はいろんな洗脳ドキュメントも用意して、Scheme言語布教の総本山とするのだはっはっは。
ライブラリさえ揃えば、SchemeもPerlに遜色無い使い勝手になると思うんだよな。 Practical Scheme と日本のLispコミュニティ
現在の日本のLispコミュニティで目立った活動をしているところといえば、Shibuya.lisp の月一のミートアップや、不定期開催の関西Lispかと思いますが、 Practical Schemeが存在しなければ、約十年前あたりのプログラミング言語ブームの時に Shibuya.lisp がそこそこの規模で立ち上がることはなかったのではないかと思います。
当時のShibuya.lisp立ち上がりの背景には、GaucheNight(2007) 及び gauche.night(2008) の参加者グループのコミュニティ立ち上げへの手応えみたいなものがあったと思いますが、その地盤を固めていたのは、Practical SchemeやWiLiKiでした。
この二十年で色々なLisp系サイトが立ち上がっては消えていきましたが、二十年間安定した基盤として維持され続けてきたというのは、やはり凄いです。
今後も末永くPractical SchemeのコンテンツやWiLiKiを利用させて頂けると嬉しいです。
■
HTML generated by 3bmd in LispWorks 7.0.0
Lisp Pointersを読め!
Posted 2020-03-31 17:46:13 GMT
ACM Digital Library が2020-06-30まで無料だそうです。
この機会にLisp系で読んでおきたいお勧めといえば、ACM SIGPLAN Lisp Pointers でしょう。
Lisp Pointers は1987年から1995年までのLisp会報誌といった感じのものです。
- Lispのプログラミング技法紹介
- エッセイ
- 処理系紹介
- 開発環境紹介
- 書評
- ANSI Common Lisp 規格進捗報告
等々、内容が濃くて面白い読み物です。
幸か不幸か1995年あたりから古典的なLispはそれほど進歩がありませんので、今でも活用できるような内容も多いと思います(マシンパワーの違いこそあれ)
当時はエキスパートシステムの組み込み言語や、構文拡張等で需要が高かったのか、コードウォーカーの記事がそこそこあるのが、特徴かもしれません。
(Richard C. Waters、Pavel Curtis、Bill van Melle各氏の記事)
古典マクロのコードウォーカー入門記事としては貴重かもしれません。
- SIGPLAN-LISPPOINTERS: Vol 1, No 1
- SIGPLAN-LISPPOINTERS: Vol 1, No 2
- SIGPLAN-LISPPOINTERS: Vol 1, No 3
- SIGPLAN-LISPPOINTERS: Vol 1, No 4
- SIGPLAN-LISPPOINTERS: Vol 1, No 5
- SIGPLAN-LISPPOINTERS: Vol 2, No 1
- SIGPLAN-LISPPOINTERS: Vol 2, No 2
- SIGPLAN-LISPPOINTERS: Vol III, No 1
- SIGPLAN-LISPPOINTERS: Vol IV, No 1
- SIGPLAN-LISPPOINTERS: Vol IV, No 2
- SIGPLAN-LISPPOINTERS: Vol IV, No 3
- SIGPLAN-LISPPOINTERS: Vol IV, No 4
- SIGPLAN-LISPPOINTERS: Vol V, No 1
- SIGPLAN-LISPPOINTERS: Vol V, No 2
- SIGPLAN-LISPPOINTERS: Vol V, No 3
- SIGPLAN-LISPPOINTERS: Vol V, No 4
- SIGPLAN-LISPPOINTERS: Vol VI, No 1
- SIGPLAN-LISPPOINTERS: Vol VI, No 2
- SIGPLAN-LISPPOINTERS: Vol VI, No 3
- SIGPLAN-LISPPOINTERS: Vol VI, No 4
- SIGPLAN-LISPPOINTERS: Vol VII, No 1-2
- SIGPLAN-LISPPOINTERS: Vol VII, No 3
- SIGPLAN-LISPPOINTERS: Vol VII, No 4
- SIGPLAN-LISPPOINTERS: Vol VIII, No 1
- SIGPLAN-LISPPOINTERS: Vol VIII, No 2
■
HTML generated by 3bmd in LispWorks 7.0.0
CLでSRFI 169
Posted 2020-02-19 20:07:29 GMT
先日久々にSRFIをCommon Lispに移植してみてコピペ移植もなかなか楽しいというのを思い出してきたので、また移植してみました。
今回移植したのは、SRFI 169: Underscores in numbersです。
srfi-169の概要ですが、Python、Ruby、C#、Java 7以降ように数値の桁区切りに_を使えるようにするという拡張です。
移植について
オリジナルはリーダーの変更ですが、どうにかリードテーブルをいじる程度で動かせました。
具体的には、数字と+、-をマクロ文字にしてしまって、srfi-169のリーダーで読み直すという戦略です。
隅をつつけば、どこかの挙動に影響がある可能性もありますが、まあ良いでしょう。
(setq *readtable* srfi-169:srfi-169-syntax)'(0123
0_1_2_3
0_123
01_23
012_3
+0123
+0_123
-0123
-0_123
1_2_3/4_5_6_7
12_34/5_678
0_1_23.4_5_6
1_2_3.5e6
1_2e1_2
#b10_10_10
#o23_45_67
#d45_67_89
#xAB_CD_EF
#x789_9B_C9_EF
#x-2_0
#o+2_345_6)
→ (123
123
123
123
123
123
123
-123
-123
123/4567
617/2839
123.456D0
1.235D8
12000000000000
42
80247
456789
11259375
32373459439
-32
10030)
ちなみに数値の区切りにアンダーバーを許す程度の簡易的な実装であれば、
(let ((stdrt (copy-readtable nil)))
(defun read-underscores-in-numbers (stm chr)
(check-type chr character)
(check-type stm (satisfies input-stream-p))
(unread-char chr stm)
(let ((*readtable* stdrt))
(let ((thing (read stm T nil T)))
(typecase thing
(symbol
(read-from-string
(remove #\_
(string thing))))
(T thing))))))(map nil
(lambda (c)
(set-macro-character c #'read-underscores-in-numbers T))
"+-0123456789")
(list 0123 0_1_2_3 0_123 01_23 012_3 +0123 +0_123 -0123 -0_123 (+ (- 0) -123))
→ (123 123 123 123 123 123 123 -123 -123 -123)
程度でも実現できそうです。
導入
Ultralispに登録してみたので、
(ql-dist:install-dist "http://dist.ultralisp.org/")してあれば、
(ql:quickload :srfi-169)でインストール可能です。
まとめ
リードテーブルも結構柔軟なので割と色々できてしまいますが、Common LispもRacketのようにリーダーの差し替えができたら良いのになと思うことはあります。
■
HTML generated by 3bmd in LispWorks 7.0.0
CLでSRFI 175
Posted 2020-02-16 14:16:07 GMT
九年ほど前からSchemeのSRFIをCommon Lispに移植する遊びをしていますが、久々にコピペ移植してみました。
前回SRFI 118を移植したのは、2005-01-02のようなので、実に五年ぶり。
今回移植したのは、SRFI 175: ASCII character libraryで、ASCIIを扱うライブラリのようで、現時点でファイナルになっているものでは一番番号が大きいものです。
導入
Ultralispに登録してみたので、
(ql-dist:install-dist "http://dist.ultralisp.org/")してあれば、
(ql:quickload :srfi-175)でインストール可能です。
動作
ASCIIに関して操作したいことは大体網羅されているので、必要な時には便利に使えるのではないでしょうか。
(ascii-downcase #\G)
→ #\g (ascii-alphabetic? #\1)
→ nil
(remove-if #'ascii-whitespace? "foo bar baz")
→ "foobarbaz"
まとめ
SRFIの移植については、Scheme→Common Lispなコンパチレイヤーがあると楽なのでボチボチ作ってみたりしていますが、このあたりも作り込むとコピペが捗りそうです。
このrnrs-compatでは関数とマクロで変換していますが、トランスレータでの一括変換も試してみたいところ。
■
HTML generated by 3bmd in LispWorks 7.0.0
Ultralisp使ってみた
Posted 2020-02-11 19:14:11 GMT
今年は移植したSRFIでもQuicklispに登録してみようかなと思って、Quicklispに三つ四つ登録してみましたが、「登録するは良いけどユーザーいるの?(大意)」という質問がありました。
SRFIのCommon Lispへの移植は90近くあるのですが、いうまでもなくどれも誰得なものなので、まあそうだよなーなど思ったりしていましたが、こういう誰得なものにはUltralispが合っていると思うと教えてもらったので、Ultralispに登録してみることにしました。
Ultralispは、Quicklispの仕組みを利用していて、“dist”の一つという位置付けです。
(ql-dist:install-dist "http://dist.ultralisp.org/" :prompt nil)で利用できるようになりますが、登録後には“dist”が増えていることが確認できます。
(ql-dist:all-dists)
→ (#<ql-dist:dist quicklisp 2019-12-27> #<ql-dist:dist ultralisp 20200126195012>)Ultralispの売りは、“dist”を五分毎に更新するので、登録から利用までが非常に早いのと、GitHubのリポジトリを管理画面からポチポチ登録すれば、登録は完了という手軽さのようです。
ちなみに別段Quicklisp本家が俺んちルールでやっているということではなく、各distには管理者がいて、Quicklispのデフォルトの“quicklisp” distにも管理者のポリシーがある、ということで適宜棲み分けするのが宜しかろうというところでしょうか。
暗黙のポリシーも含めてリストにするとこんな感じでしょうか。
| “quicklisp” dist | “ultralisp” dist | |
|---|---|---|
| dist更新 | 約一ヶ月毎 | 五分毎 |
| 登録基準 | SBCLでビルドできるか | 特になし |
| 除外基準 | SBCLでビルドできなくなったら | 特になし |
現状、Common Lisp界はSBCL一強になりつつありますが、SBCLでビルドできなければ、“quicklisp” distには載らないんだよなーというのは、まあまあ耳にする話だったので、そういう点も“ultralisp”と“quicklisp”の棲み分けの基準になるかもしれません。
また、Ultralispの登録の手軽さを活かして、とりあえずUltralispに登録して暫く運用し、手応えがあったらQuicklispに申請するというのも良さそうです。
Ultralisp使用感とまとめ
特に“quicklisp” distと変わらないですが、手軽に早く登録できるので、複数環境で自作ライブラリを利用するのはかなり手軽になります。
その代わりといってはなんですが、登録レポジトリのコードを壊しちゃたりした場合でも、素早くそのまま流れていくので注意が必要かなと思います。
(素早く修正すれば良いとはいえ)
こんなUltralispなので登録ライブラリはQuicklispのデフォルトより多いんだろうと思いきや現在1253ということでquicklispの約1800より少ないようです。
“quicklisp” distから“ultralisp” distへの取り込みも進んでいるようなのでそのうち包含するのかもしれません。
ちなみにそもそものきっかけになったSRFIのCommon Lisp移植版ですが、ボチボチUltralispに登録しています。
srfi-2やsrfi-19等便利なものも案外あるので折角なのでUltralisp経由で活用していきたいと思います。
■
HTML generated by 3bmd in LispWorks 7.1.2
2019年振り返り
Posted 2019-12-31 15:13:25 GMT
毎年振り返りのまとめを書いているので、今回も書きます。
Lisp的進捗
今年は何故か自分の中ではMOPブームが到来し、後半は特にMOP的な拡張をして遊んでいました。
ECLOSを始めとして、1990年代にはMOPの拡張が色々と試行錯誤されていたようなので、これを暫く追試して行こうかなと思います。
どうもMOPは学習の取っ掛かりがないという印象があり、どう学んでいったら良いのか良く分からない状況が自分も長く続きましたが、結局のところ沢山書けば色々憶えてくるようです。
とりあえず役に立つ応用を考えたりするのは後回しで量を書いていれば段々見通しが付いてくるように思えました。
思えばマクロもナンセンスなものを沢山書いていましたし、自分はとりあえず量を書かないことには身に付かない質かもしれません。
Common LispのMOPも中途半端だったり発展途中(で四半世紀進歩がない)だったりするので、その辺りの状況もまとめてみたいと考えています。
ブログ
今年書いた記事は38記事でした。
年々記事の量が減っていますが、ネタがない訳ではなく記事にするのが面倒というところです。
世間的にもLispの記事を目にすることは大分少なくなりました。大分ブログというツールも廃れた感がありますが、2020年はもうちょっと書いていきたいと思います。
LispWorks
LispWorksを購入してから早四年半。
それまでSBCL+SLIMEをメインに使っていましたが、購入を機にLispWorksのIDEメインとしました。
しかし、いまだにSLIMEで便利だった機能を越えられていないところがあります。
LispWorksの方が便利なところも多いのですが、2020年は両者の良いとこ取りな環境を構築していきたいところです。
LispWorksでの職場の社内ツール作りもあいかわらず継続していて、利用者もアプリの種類も増えました。
折角なのでLispWorksのCommmon SQLやKnowledgeWorksの機能も使ってみていますが、デザインは古いもののそこそこ便利に使えています。
DBや推論機能はメタクラスが定義されており、これらをmixinして連携させるのが楽しいといえば楽しいです。
ウェブ屋さんが沢山在籍する職場では何かGUIのツールを作成するとなれば、ウェブアプリになると思いますが、そうでなければ、LispWorksみたいなアプリ作成機能もそこそこ有用かなと思います。
特に社内でしか使わないとなれば、ウェブアプリのメンテもそこそこ面倒なので。
2020年やってみたいこと
2019年の計画では、コンディションシステムアドベントカレンダーを開催したいと思っていましたが、ちょっと試しにQiitaを退会してみたら、記事がごっそり消えてしまったので、アドベントカレンダーを開催するのがめんどうになってしまい2019年はスキップしてしまいました。
コンディションシステムやMOPは今後も深追いしていきたい所存です。
また、1980年代のエキスパートシステムブームとLispについて大体見通しが付いてきたので、2020年は、第二次AIブームでのLispの活躍とは何だったのか等々まとめてみたいと考えています。
過去のまとめ
- #:g1: 2018年振り返り
- #:g1: 2017年振り返り
- #:g1: 2016年振り返り
- #:g1: 2015年振り返り
- #:g1: 2014年振り返り
- #:g1: 2013年振り返り
- #:g1: 2012年振り返り
- #:g1: 2011年を振り返る
- #:g1: 2010年を振り返る
- #:g1: 2009年を振り返る
- #:g1: 今年一年をふりかえる
■
HTML generated by 3bmd in LispWorks 7.0.0
痕跡を残さないS式コメント
Posted 2019-12-21 18:10:57 GMT
コメントをS式で書く方式のcommentは、古くはMACLISPに、最近だとClojureにありますが、中身を無視してnil(MACLISPだと'comment)を返すシンプルなフォームです。
(comment 0 1 2)
→ nilcommentの中身もS式として成立していないといけないのですが、動いているコードをコメントアウトする分には大抵問題になることはないでしょう。
Common Lispで書くとするとこんな感じになります。
(defmacro comment (&body body)
(declare (ignore body))
nil)S式コメントには一つ問題があり、nil等の値を残してしまうので、commentを残す場所には配慮する必要があります。
(vector (list 42))
→ #((42)) (vector (comment (list 42)))
→ #(nil)
ここで一捻りして、nilではなく(values)を置いてみるとどうでしょうか。
(defmacro comment (&body body)
(declare (ignore body))
'(values))(values)は0個の返り値を返しますが、Common Lispの場合は値が評価される場所ではnilとなります。
つまり、nilと書いた場合と大差ないのですが、
(vector (comment (list 42)))
→ #(nil) #.を付けると、痕跡を消すことができます。
(vector #.(comment (list 42)))
→ #() リーダーマクロの書法の一つとして、値を出力したくない場合は、(values)を使うというのがあるのですが、これを利用した格好です。
まとめ
#.(comment ...)だとちょっと長いので、普段は、(comment ...)で書き、必要になったら#.を足す、という使い方をすれば、そこそこ便利に使えるかもしれません。
■
HTML generated by 3bmd in LispWorks 7.0.0
MOPでSoA
Posted 2019-12-17 17:58:29 GMT
構造体の配列を作成する方法として、
- 構造体を配列に配置する(AoS: Array of Structures)
- 配列の構造体を作る(SoA: Structure of Arrays)
があるようですが、SoAの方が効率が良いらしいです。
Common Lispでいうと、インスタンスの配列を作成するか、インスタンスのスロットを配列にするかになりますが、MOP細工でインスタンスのスロットは配列にはせずに通常のままでSoAな構成にしてみよう、というのが今回の趣旨です。
- クラスメタオブジェクトにインスタンスのスロットを配列として保持し、
allocate-instanceでスロットの配列に配置。- インデックスはインスタンスのデータ部が空き地なのでここに格納
といった風に構成してみました。
LispWorks依存ですが、standard-objectの構造はメジャーどころは大体一緒なので移植は簡単だと思います。
動作
(defclass 🐱 (soa-object)
((a :initform 0 :type bit :initarg :a)
(b :initform #\. :type character :initarg :b)
(c :initform nil :type boolean :initarg :c))
(:metaclass soa-class)
(:pool-size 0))(instance# (class-prototype (find-class '🐱)))
→ 0
(class-slot-vectors (find-class '🐱))
→ ((a . #*) (b . "") (c . #()))
(set '🐱 (make-instance '🐱 :a 0 :b #\- :c T))
→ #<🐱 40201E2BFB>
(mapcar (lambda (s)
(cons (car s)
(elt (cdr s) (instance# 🐱))))
(class-slot-vectors (find-class '🐱)))
→ ((a . 0) (b . #\-) (c . t))
(dotimes (i 100)
(make-instance '🐱 :a 1 :b #\. :c nil))
→ nil
(class-slot-vectors (find-class '🐱))
→ ((a . #*001111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111)
(b . "^@-....................................................................................................")
(c
. #(nil t nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)))
(with-slots (a b c)
(make-instance '🐱 :a 1 :b #\. :c nil)
(list a b c))
→ (1 #\. nil)
実装
堅牢性に難ありですが、概念実証くらいにはなるかなというところです。
(defpackage "e477e14c-8275-5c00-82d3-82f8adcd1567"
(:use :c2cl))
(in-package "e477e14c-8275-5c00-82d3-82f8adcd1567")
(defclass soa-class (standard-class)
((pool-size :initform 256 :accessor instance-pool-size :initarg :pool-size)
(instance-index :initform 0 :accessor instance-index)
(slot-vectors :initform nil :accessor class-slot-vectors)))
(defmethod validate-superclass ((c soa-class)
(s standard-class))
T)
(defclass soa-object ()
()
(:metaclass Soa-class))
(defun instance# (soa-object)
(clos::%svref Soa-object 1))
(defmethod allocate-instance ((class soa-class) &rest initargs)
(let* ((class (clos::ensure-class-finalized class)))
(prog1
(sys:alloc-fix-instance (clos::class-wrapper class)
(instance-index class))
(incf (instance-index class)))))
(defmethod shared-initialize ((instance soa-object) slot-names &rest initargs)
(flet ((initialize-slot-from-initarg (class instance slotd)
(let ((slot-initargs (slot-definition-initargs slotd))
(name (slot-definition-name slotd)))
(loop :for (initarg value) :on initargs :by #'cddr
:do (when (member initarg slot-initargs)
(setf (slot-value-using-class class instance name)
value)
(return t)))))
(initialize-slot-from-initfunction (class instance slotd)
(let ((initfun (slot-definition-initfunction slotd))
(name (slot-definition-name slotd)))
(unless (not initfun)
(setf (slot-value-using-class class instance name)
(funcall initfun))))))
(let ((class (class-of instance)))
(dolist (slotd (class-slots class))
(unless (initialize-slot-from-initarg class instance slotd)
(when (or (eq t slot-names)
(member (slot-definition-name slotd) slot-names))
(initialize-slot-from-initfunction class instance slotd)))))
instance))
(defun soa-instance-access (class obj key)
(elt (cdr (assoc key (class-slot-vectors class)))
(instance# obj)))
(defun (setf soa-instance-access) (val class obj key)
(when (> (instance# obj)
(1- (instance-pool-size class)))
(setf (instance-pool-size class)
(1+ (instance# obj)))
(dolist (slot (class-slot-vectors class))
(adjust-array (cdr slot)
(instance-pool-size class))))
(setf (elt (cdr (assoc key (class-slot-vectors class)))
(instance# obj))
val))
(defmethod slot-value-using-class ((c Soa-class) inst slot-name)
(soa-instance-access c inst slot-name))
(defmethod (setf slot-value-using-class) (newvalue (c Soa-class) inst slot-name)
(setf (soa-instance-access c inst slot-name) newvalue))
(defmethod ensure-class-using-class :after ((class soa-class) name &rest initargs &key)
(when (consp (instance-pool-size class))
(setf (instance-pool-size class)
(car (instance-pool-size class))))
(setf (class-slot-vectors class)
(mapcar (lambda (s)
(cons (slot-definition-name s)
(make-array (instance-pool-size class)
:element-type (or (slot-definition-type s) T)
:adjustable T
:initial-element (funcall (slot-definition-initfunction s)))))
(class-slots class))))
まとめ
Common LispはC風に効率よく構造体を配列に詰められないのか、等々の質問はたまにみかけるのですが、今回のように高次のデータ構造的に記述して低次のデータ構造にマッピングする方法もなくはないかなとは思います。
直截的な回答としてはFFIでメモリの塊をいじる方法などになりそうですが。
■
HTML generated by 3bmd in LispWorks 7.0.0
Allegro CLのfixed-indexスロット再現リベンジ
Posted 2019-12-11 17:12:32 GMT
先日書いたAllegro CLのfixed-indexスロットアクセスを真似してみるの記事では、任意の値でslot-definition-loctionを確定させる術を分かっていなかったので、中途半端なことになっていました。
compute-slots :aroundを使った確定方法が分かったのでリベンジします。
動作
(<defclass> foo ()
((a :initarg :a fixed-index 2 :accessor foo-a)
(b :initarg :b fixed-index 4 :accessor foo-b)
(c :initarg :c :accessor foo-c))
(:metaclass fixed-index-slot-class))(mapcar (lambda (s)
(list (slot-definition-name s)
(slot-definition-location s)))
(class-slots <foo>))
→ ((c 0) (a 2) (b 4))
(let ((foo (a 'foo)))
(setf (foo-a foo) 'a)
(setf (foo-b foo) 'b)
(setf (foo-c foo) 'c)
(std-instance-slots foo))
→ #(c #<Slot Unbound Marker> a #<Slot Unbound Marker> b)
実装について
- インデックスが指定されていないスロットは、先頭から空いている番地に差し込みます。
slot-value-using-classがいつものごとくLispWorks依存です(AMOP準拠でない) なおかつ遅そうです。
実装
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :closer-mop))
(defpackage "506dccfc-1d3a-5b8c-9203-948447c433b4" (:use :c2cl))
(in-package "506dccfc-1d3a-5b8c-9203-948447c433b4")
;; utils
(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (fdefinition 'a) #'make-instance)
(defun fintern (package control-string &rest args)
(with-standard-io-syntax
(intern (apply #'format nil control-string args)
(or package *package*))))
(defmacro <defclass> (name supers slots &rest class-options)
`(defconstant ,(fintern (symbol-package name) "<~A>" name)
(defclass ,name ,supers ,slots ,@class-options))))
(<defclass> fixed-index-slot-class (standard-class)
())
(defmethod validate-superclass ((c fixed-index-slot-class) (s standard-class))
T)
(<defclass> fixed-index-slot-definition (standard-slot-definition)
((fixed-index :initform nil
:initarg fixed-index
:accessor slot-definition-fixed-index)))
(<defclass> fixed-index-direct-slot-definition
(fixed-index-slot-definition standard-direct-slot-definition)
())
(<defclass> fixed-index-effective-slot-definition
(fixed-index-slot-definition standard-effective-slot-definition)
())
(defmethod direct-slot-definition-class ((c fixed-index-slot-class) &rest initargs)
(declare (ignore initargs))
<fixed-index-direct-slot-definition>)
(defmethod effective-slot-definition-class ((c fixed-index-slot-class) &rest initargs)
(declare (ignore initargs))
<fixed-index-effective-slot-definition>)
(defmethod compute-effective-slot-definition ((class fixed-index-slot-class) name direct-slot-definitions)
(declare (ignore name))
(let ((effective-slotd (call-next-method)))
(dolist (slotd direct-slot-definitions)
(when (typep slotd <fixed-index-slot-definition>)
#-allegro (setf (slot-definition-fixed-index effective-slotd)
(slot-definition-fixed-index slotd))
#+allegro (setf (slot-value effective-slotd 'excl::location)
(slot-definition-fixed-index slotd))
(return)))
effective-slotd))
(defmethod allocate-instance ((class fixed-index-slot-class) &rest initargs)
(let* ((class (clos::ensure-class-finalized class))
(slotds (class-slots class))
(max-index (loop :for s :in slotds :maximize (slot-definition-location s))))
(sys:alloc-fix-instance (clos::class-wrapper class)
(sys:alloc-g-vector$fixnum (1+ max-index)
clos::*slot-unbound*))))
(defmethod compute-slots :around ((class fixed-index-slot-class))
(let* ((slotds (call-next-method))
(indecies (mapcan (lambda (s)
(and (slot-definition-fixed-index s)
(list (slot-definition-fixed-index s))))
slotds))
(free-indecies (loop :for i :from 0 :to (apply #'max indecies)
:unless (find i indecies) :collect i)))
(dolist (s slotds)
(if (slot-definition-fixed-index s)
(setf (slot-definition-location s)
(slot-definition-fixed-index s))
(setf (slot-definition-location s)
(pop free-indecies))))
(sort (copy-list slotds) #'< :key #'slot-definition-location)))
(defun standard-instance-boundp (instance index)
(not (eq clos::*slot-unbound* (standard-instance-access instance index))))
(defmethod slot-value-using-class
((class fixed-index-slot-class) instance slot-name)
(let* ((slotd (find slot-name (class-slots class)
:key #'slot-definition-name))
(loc (slot-definition-location slotd)))
(cond ((not slotd)
(slot-missing class instance slot-name 'slot-makunbound))
((null (standard-instance-boundp instance loc))
(slot-unbound class instance slot-name))
(T
(standard-instance-access instance loc)))))
(defmethod (setf slot-value-using-class)
(val (class fixed-index-slot-class) instance slot-name)
(let* ((slotd (find slot-name (class-slots class)
:key #'slot-definition-name))
(loc (slot-definition-location slotd)))
(if (not slotd)
(slot-missing class instance slot-name 'slot-makunbound)
(setf (standard-instance-access instance loc) val))))
(declaim (inline std-instance-slots))
(defun std-instance-slots (inst)
#+allegro (excl::std-instance-slots inst)
#+sbcl (sb-pcl::std-instance-slots inst)
#+lispworks (clos::standard-instance-static-slots inst))
まとめ
インスタンスのスロットをベクタ上に任意に配置したり、ハッシュテーブルにしてみたり、ということができることは分かりましたが、標準から逸れたことをすると、どうもスロットのアクセス周りを全部書かないといけないっぽいですね。
■
HTML generated by 3bmd in LispWorks 7.0.0
MOPで隠しスロットの実現
Posted 2019-12-09 19:26:03 GMT
ここ最近、standard-instance-accessでインスタンス内部のベクタに直接アクセスするようなことを試していましたが、インデックスを求める方法があやふやでした。
compute-slotsで並んだ順で確定するのは分かっていたのですが、並び順ということは飛び飛びにはできないわけで、どうしたものかと考えていましたが、compute-slotsの説明を良く読んだら、compute-slotsのプライマリメソッドでスロット定義を並べて、compute-slotsの:aroundメソッドでslot-definition-locationの内容を確定するようなことが書いてあります。
In the final step, the location for each effective slot definition is
set. This is done by specified around-methods; portable methods cannot
take over this behavior. For more information on the slot definition
locations, see the section ``Instance Structure Protocol.''ということでSBCLのMOP実装を確認してみましたが、やはり:aroundでlocationを設定していました。なるほど。
compute-slotsの:aroundを乗っ取るには、さらなる:aroundを定義するしかないわけですが、どうも可搬性のためにはいじってはいけない場所のようです。
とはいえ、インデックスの設定方法が分かったので、試しに今回は、X3J13-88-003R-DRAFTのコード例にあるfaceted-slot-classを動かしてみたいと思います。
faceted-slot-class
X3J13-88-003Rのドラフトにはindex-in-instanceというAPIが存在していて、スロット名からインデックスを算出する仕組みになっていたようです。
このindex-in-instanceの利用例として、0、2、4…をスロット、1、3、5…をファセットとして配置するメタクラスを定義しています。
動作は下記のようになります。
(defclass zot ()
((a :initform 42)
(b :initform 43)
(c :initform 44))
(:metaclass faceted-slot-class))(let ((o (make-instance 'zot)))
(values
(with-slots (a b c) o
(list a b c))
(loop :for index :from 0 :repeat (compute-instance-size (class-of o))
:collect (standard-instance-access o index))))
→ (42 43 44)
(42 #<Slot Unbound Marker> 43 #<Slot Unbound Marker> 44 #<Slot Unbound Marker>)
;;; ファセットに値を設定
(let ((o (make-instance 'zot)))
(setf (slot-facet o 'a) 'facet-a)
(setf (slot-facet o 'b) 'facet-b)
(setf (slot-facet o 'c) 'facet-c)
(values
(with-slots (a b c) o
(list a b c))
(loop :for index :from 0 :repeat (compute-instance-size (class-of o))
:collect (standard-instance-access o index))))
→ (42 43 44)
(42 facet-a 43 facet-b 44 facet-c)
実装
ということで実装ですが、元のコードのAPIをできるだけ残したかったのですが、どうもコンセプトコードのようで実際に動かすと色々矛盾がある様子。
その辺りは適当に辻褄を合せました。
しかし、辻褄が合わないところもあり、
compute-slotの中でindex-in-instanceを使って綺麗にカスタマイズしたいが、index-in-instanceが使うスロット情報は遡ればcompute-slotを利用するので循環が発生する
等は、index-in-instanceの内容をcompute-slotの中にベタ書きで展開することで回避しています。
以下、LispWorks依存なコードです。
LispWorks標準のslot-value-using-classは、スロットのインデックスが隙間無く並んでいることを前提としていて、疎な配置にすると動作がおかしくなるので、自前で定義しています。
(ql:quickload :closer-mop)
(defpackage "2f1cccc9-c776-5726-9e68-91d2d9042169" (:use :c2cl))
(in-package "2f1cccc9-c776-5726-9e68-91d2d9042169")
(defgeneric index-in-instance (class description))
(defmethod index-in-instance ((class cl:standard-class) description)
(typecase description
(symbol
(position description (class-slots class)
:key #'slot-definition-name))
(T (error "Don't understand the description ~S." description))))
(defgeneric compute-instance-size (class))
(defmethod compute-instance-size ((class cl:standard-class))
(length (class-slots class)))
(defclass faceted-slot-class (standard-class) ())
(defmethod validate-superclass ((c faceted-slot-class) (s standard-class))
T)
(defmethod compute-instance-size ((class faceted-slot-class))
(* 2 (call-next-method)))
(defmethod allocate-instance ((class faceted-slot-class) &rest initargs)
(let ((class (clos::ensure-class-finalized class)))
(sys:alloc-fix-instance (clos::class-wrapper class)
(sys:alloc-g-vector$fixnum (compute-instance-size class)
clos::*slot-unbound*))))
(defmethod index-in-instance ((class faceted-slot-class) description)
(cond ((symbolp description)
(let ((index (call-next-method)))
(and index (* 2 index))))
((and (consp description)
(eq (car description) 'facet))
(1+ (index-in-instance class (cadr description))))
(T
(error "Don't understand the description ~S." description))))
(defun standard-instance-access* (instance description trap not-bound-function missing-function)
(declare (ignore trap))
(let* ((class (class-of instance))
(index (index-in-instance class description)))
(cond ((null index)
(funcall missing-function instance description))
((not (numberp index))
(slot-value index 'value))
((null (standard-instance-boundp instance index))
(funcall not-bound-function instance description))
(T
(standard-instance-access instance index)))))
(defun (setf standard-instance-access*) (val instance description trap not-bound-function missing-function)
(declare (ignore trap not-bound-function))
(let* ((class (class-of instance))
(index (index-in-instance class description)))
(cond ((null index)
(funcall missing-function instance description))
((not (numberp index))
(slot-value index 'value))
(T
(setf (standard-instance-access instance index) val)))))
(defun standard-instance-boundp (instance index)
(not (eq clos::*slot-unbound* (standard-instance-access instance index))))
(defun slot-facet (instance slot-name)
(standard-instance-access* instance
(list 'facet slot-name)
nil
#'facet-unbound
#'facet-missing))
(defun (setf slot-facet) (new-value instance slot-name)
(setf (standard-instance-access* instance
(list 'facet slot-name)
nil
#'facet-unbound
#'facet-missing)
new-value))
(defun facet-unbound (instance facet)
(error "The facet ~S is unbound in the object ~S" (cadr facet) instance))
(defun facet-missing (instance facet)
(error "The facet ~S is missing from the object ~S" (cadr facet) instance))
(defmethod compute-slots :around ((class faceted-slot-class))
(let ((slotds (call-next-method)))
(dolist (s slotds)
;; Base case
(setf (slot-definition-location s)
(* 2 (position s slotds))))
slotds))
(defmethod slot-value-using-class ((class faceted-slot-class) instance slot-name)
(let ((index (index-in-instance class slot-name)))
(cond ((null index)
(slot-missing class instance slot-name 'slot-makunbound))
((not (numberp index))
(slot-value index 'value))
((null (standard-instance-boundp instance index))
(slot-unbound class instance slot-name))
(T
(standard-instance-access instance index)))))
まとめ
index-in-instanceは、class-slotsとslot-definition-nameとslot-definition-locationの組み合わせとも大差ないともいえますが、index-in-instanceの方がスロット名とインデックスの関係が明確になる上にカスタマイズしやすそうな気もします。
今回の例では、index-in-instanceを呼びまくっていますが、ちょっと遅そうなので、クラスにインデックスを保持させる方が良いかもしれません。
■
HTML generated by 3bmd in LispWorks 7.0.0
文字列中にダブルクォートが頻出してエスケープが面倒な時はシンボルで記述して変換
Posted 2019-12-08 19:31:12 GMT
表題の通りなのですが、Clozure CLのマニュアルのソースを眺めていて、こんな記述をみつけました。
- doc/manual/implementation.ccldoc
(item "r13 is used to hold the TCR on PPC32 systems; it's not used on PPC64."))
(item #:|r14 (symbolic name loc-pc) is used to copy "pc-locative" values between main memory and special-purpose PPC registers (LR and CTR) used intern function-call and return instructions.|)一応解説すると、マニュアルは文字列のリストで記述されていて、文字列の表記には文字列でもシンボルでも使えるようにしてあるので、ダブルクォートのエスケープが面倒な時にはシンボルで記述する(上記の例ではインターンを嫌ってか自由シンボル)ということです。
上記の例ではマクロ展開時の処理ですが、実行時ならば、
(string '|"""foo "bar" baz"""|)
→ "\"\"\"foo \"bar\" baz\"\"\"" となり、リード時処理なら文字列を直に書いているのと同一です。
#.(string '|"""foo "bar" baz"""|)
≡ "\"\"\"foo \"bar\" baz\"\"\"" 個人的には以前から思い付きでやっていたことなのですが、自分以外にもこんなことしている人をみつけた記念に記事にしてみました。
■
HTML generated by 3bmd in LispWorks 7.0.0
ECLOSのself-referent-classを再現してみる
Posted 2019-12-04 20:14:19 GMT
最近はECLOSを再現して遊んでいますが、今回は、self-referent-classというメタクラスを再現してみます。
なお、self-referent-classについては、ECLOSの論文に詳しいので参照してください。
- LispM.de > docs > Publications > Common Lisp
- ECLOS Metaclass library
- Extended CLOS
- Advances in Object-Oriented Metalevel Architectures and Reflection
- Why the MOP should the mopped
挙動を確認してみる
説明はあるとはいえ、マニュアルや仕様書ではないので、実際実装してみようとすると良くわからないところはありますが、インスタンスの初期化時に他のスロットを参照できること=自己参照、ということのようです。 論文の解説によれば、大体下記のような挙動になります。
- 初期化時に自己のインスタンスを
selfという変数で参照可能 (slot-name self)という形式で自身の式より左側のスロットを参照可能- しかしこれが
creatorやparentの機能なのか判然としない
- しかしこれが
(defclass horizontal-line (self-referent-object)
((x1 :accessor x1 :initarg :x1 :type real)
(x2 :accessor x2 :initarg :x2 :type real)
(y :accessor y :initarg :y :type real)
(point1 :initform (make-point (x1 self)
(y self)))
(point2 :initform (make-point (x2 self)
(y self))))
(:metaclass self-referent-class))(set' obj (make-instance 'horizontal-line :x1 1 :x2 2 :y 3))
(slot-value obj 'x1)
→ 1
(slot-value obj 'x2)
→ 2
(slot-value obj 'point1)
→ (1 3)
(slot-value obj 'point2)
→ (2 3)
実装のヒント
論文にはCommon LispのMOPについて問題点が何点も指摘されていますが、スロット定義のinitfunctionが引数を取らないことも指摘しています。
この指摘の中で、この問題を回避するためにスペシャル変数経由で渡していると書いてあるのですが、だとすると、shared-initializeの中のスロット初期化関数にスペシャル変数経由でselfを渡しているのでしょう。
shared-initializeの:aroundを使ってスペシャル変数の囲いはこんな風に書けるでしょう。
(defmethod shared-initialize :around ((instance self-referent-object) slot-names &rest initargs)
(let ((*self-referent-object-self* instance))
(declare (special *self-referent-object-self*))
(call-next-method)))あとは、initfunctionを
(lambda (&aux (self *self-referent-object-self*))
(declare (special *self-referent-object-self*))
...)のようなものに差し替えればOKです。
(slot-name self)のような形式は、スロット名の局所関数を作成し、ensure-class-using-classの周りに展開されるようにすれば良さそうです。
以上で、想像される展開は下記のようになります。
(eval-when (:compile-toplevel :load-toplevel :execute)
(flet ((x1 (self) (slot-value self 'x1))
(x2 (self) (slot-value self 'x2))
(y (self) (slot-value self 'y))
(point1 (self) (slot-value self 'point1))
(point2 (self) (slot-value self 'point2)))
(def:def (lisp:defclass horizontal-line)
(clos::ensure-class-without-lod 'horizontal-line
:metaclass
'self-referent-class
:direct-slots
(list (list :name 'x1
:readers '(x1)
:writers '((setf x1))
:initargs '(:x1)
:type 'real)
(list :name 'x2
:readers '(x2)
:writers '((setf x2))
:initargs '(:x2)
:type 'real)
(list :name 'y
:readers '(y)
:writers '((setf y))
:initargs '(:y)
:type 'real)
(list :name 'point1
:initform
'(make-point (x1 self) (y self))
:initfunction
#'(lambda (&aux (self zreclos.meta::*self-referent-object-self*))
(declare (special zreclos.meta::*self-referent-object-self*))
(make-point (x1 self) (y self))))
(list :name 'point2
:initform
'(make-point (x2 self) (y self))
:initfunction
#'(lambda (&aux (self zreclos.meta::*self-referent-object-self*))
(declare (special zreclos.meta::*self-referent-object-self*))
(make-point (x2 self) (y self)))))
:direct-superclasses '(self-referent-object)
:location
(def:location)))))実装してみる
defclassがメタクラスに応じて任意の展開にディスパッチされると便利なのですが、LispWorksだとexpand-defclassというのがあるので、ここに展開メソッドを追加してやることでdefclassの兄弟マクロを定義せずに済みました。
このexpand-defclassですが、X3J13-88-003Rにあるのと同じ大体同じインターフェイスです。
他にもスロットのオプションの展開等にもLispWorksには便利なメソッドがあるので使ってみました(非公開APIですが)
ちなみに、これらはclass-prototypeをディスパッチに利用するのですが、昔からこういう使い方は或る種の定番だったようです。
などなどですが、ベタベタにLispWorks依存になっています。
(defclass self-referent-class (standard-class)
()
(:metaclass standard-class))
(defmethod validate-superclass ((c self-referent-class)
(s standard-class))
T)
(defun make-creator-function-form (slot-form)
(let ((name (car slot-form)))
`(,name (self) (slot-value self ',name))))
(defmethod clos::expand-defclass
((prototype self-referent-class) metaclass name superclasses slots class-options)
(destructuring-bind (eval-when opts &body body)
(call-next-method)
`(,eval-when ,opts
(flet (,@(mapcar #'make-creator-function-form slots))
,@body))))
(defclass self-referent-object (standard-object)
()
(:metaclass self-referent-class))
(defmethod shared-initialize :around ((instance self-referent-object) slot-names &rest initargs)
(let ((*self-referent-object-self* instance))
(declare (special *self-referent-object-self*))
(call-next-method)))
;; from alexandria
(defun flatten (tree)
"Traverses the tree in order, collecting non-null leaves into a list."
(let (list)
(labels ((traverse (subtree)
(when subtree
(if (consp subtree)
(progn
(traverse (car subtree))
(traverse (cdr subtree)))
(push subtree list)))))
(traverse tree))
(nreverse list)))
(defun non-trivial-initform-initfunction-p (initform)
#+lispworks7.1
(loop :for (name ntifif) :on (flatten initform)
:thereis (and (eq 'hcl:lambda-name name)
(eq 'clos::non-trivial-initform-initfunction ntifif)))
#+lispworks7.0
(let ((x initform))
(and (consp x)
(eq 'function (car x))
(eq 'lambda (caadr x)))))
(defgeneric make-sr-class-initfunction-form (class ifform))
(defmethod make-sr-class-initfunction-form ((class self-referent-class)
ifform)
(if (non-trivial-initform-initfunction-p ifform)
(destructuring-bind (function (lambda arg &body body))
ifform
(declare (ignore arg))
`(,function (,lambda (&aux (self *self-referent-object-self*))
(declare (special *self-referent-object-self*))
,@body)))
ifform))
(defmethod clos::canonicalize-defclass-slot
((prototype self-referent-class) slot)
(let* ((plist (copy-list (cdr (call-next-method))))
(ifform (getf plist :initfunction)))
(if (getf plist :initform)
(progn
(remf plist :initfunction)
`(list ,@plist
:initfunction ,(make-sr-class-initfunction-form prototype
ifform)))
(progn
`(list ,@plist)))))
まとめ
expand-defclassは便利なのでLispWorks限らず他でも使いたいところですが、このあたりは統一されてないんですよねえ。
■
HTML generated by 3bmd in LispWorks 7.0.0
SBCLにcaseのジャンプテーブル最適化が入ったので試してみる
Posted 2019-11-27 20:02:15 GMT
昨日リリースされたSBCL 1.5.9にcaseのジャンプテーブル最適化が入ったようなので早速どんなものか試してみたいと思います。
とりあえず若干わざとらしいものを試してみます。
caseのキーに0から511までの数値をシャッフルしたものを指定して分岐し、さらに二段目のcaseで元に戻すのを5回繰り返すのを1000繰り返してみます。
(defconstant nbranch 512);; alexandria
(defun shuffle (sequence &key (start 0) end)
"Returns a random permutation of SEQUENCE bounded by START and END.
Original sequece may be destructively modified, and share storage with
the original one. Signals an error if SEQUENCE is not a proper
sequence."
(declare (type fixnum start)
(type (or fixnum null) end))
(etypecase sequence
(list
(let* ((end (or end (length sequence)))
(n (- end start)))
(do ((tail (nthcdr start sequence) (cdr tail)))
((zerop n))
(rotatef (car tail) (car (nthcdr (random n) tail)))
(decf n))))
(vector
(let ((end (or end (length sequence))))
(loop for i from start below end
do (rotatef (aref sequence i)
(aref sequence (+ i (random (- end i))))))))
(sequence
(let ((end (or end (length sequence))))
(loop for i from (- end 1) downto start
do (rotatef (elt sequence i)
(elt sequence (+ i (random (- end i)))))))))
sequence)
(defmacro casetabletest (x)
(let ((xy (loop :for x :across (shuffle
(let ((vec (make-sequence 'vector nbranch)))
(dotimes (i nbranch vec)
(setf (elt vec i) i))))
:for i :from 0 :collect (list i x))))
`(case (case ,x
,@xy
(otherwise -1))
,@(mapcar #'reverse xy)
(otherwise -1))))
(defun casetest (&aux (n 0))
(dotimes (i nbranch n)
(incf n (casetabletest
(casetabletest
(casetabletest
(casetabletest
(casetabletest i))))))))
(compile 'casetest)
(time (dotimes (i 1000)
(casetest)))
SBCL 1.5.8
t% /l/sbcl/1.5.8/bin/sbcl --no-sysinit --no-userinit --load /tmp/case.lisp --quit
This is SBCL 1.5.8, an implementation of ANSI Common Lisp.
More information about SBCL is available at <http://www.sbcl.org/>.SBCL is free software, provided as is, with absolutely no warranty.
It is mostly in the public domain; some portions are provided under
BSD-style licenses. See the CREDITS and COPYING files in the
distribution for more information.
Evaluation took:
1.986 seconds of real time
1.990000 seconds of total run time (1.990000 user, 0.000000 system)
100.20% CPU
6,537,459,720 processor cycles
0 bytes consed
SBCL 1.5.9
t% /l/sbcl/1.5.9/bin/sbcl --no-sysinit --no-userinit --load /tmp/case.lisp --quit
This is SBCL 1.5.9, an implementation of ANSI Common Lisp.
More information about SBCL is available at <http://www.sbcl.org/>.SBCL is free software, provided as is, with absolutely no warranty.
It is mostly in the public domain; some portions are provided under
BSD-style licenses. See the CREDITS and COPYING files in the
distribution for more information.
Evaluation took:
0.056 seconds of real time
0.060000 seconds of total run time (0.060000 user, 0.000000 system)
107.14% CPU
184,341,012 processor cycles
0 bytes consed
この極端な例では35倍も速くなっています。
まあこんなことはそうそうないですが!
ちなみに類似の最適化を実施するClozure CLでも同じ位のスピードが出るようです。
t% /l/ccl/1.11.5/lx86cl64 -n -l /tmp/case.lisp -e '(quit)'
(DOTIMES (I 1000) (CASETEST))
took 55,783 microseconds (0.055783 seconds) to run.
During that period, and with 8 available CPU cores,
60,000 microseconds (0.060000 seconds) were spent in user mode
0 microseconds (0.000000 seconds) were spent in system mode発動ルールを探る
上記の例では最適化が発動しましたが、caseのジャンプテーブル化ではそんなに大きなテーブルは作らないことがほとんどなので、SBCLではどういう縛りがあるか確認してみます。
発動ルールは、src/compiler/ir2opt.lispのshould-use-jump-table-pの中に記述されているようで、
- キーの最大値から最小値を引いたもの+1がテーブルサイズ
- テーブルサイズは分岐の数の二倍が上限
のようです。
(defun should-use-jump-table-p (chain &aux (choices (car chain)))
;; Dup keys could exist. REMOVE-DUPLICATES from-end can handle that:
;; "the one occurring earlier in sequence is discarded, unless from-end
;; is true, in which case the one later in sequence is discarded."
(let ((choices (remove-duplicates choices :key #'car :from-end t)))
;; Convert to multiway only if at least 4 key comparisons would be needed.
(unless (>= (length choices) 4)
(return-from should-use-jump-table-p nil))
(let ((values (mapcar #'car choices)))
(cond ((every #'fixnump values)) ; ok
((every #'characterp values)
(setq values (mapcar #'sb-xc:char-code values)))
(t
(return-from should-use-jump-table-p nil)))
(let* ((min (reduce #'min values))
(max (reduce #'max values))
(table-size (1+ (- max min )))
(size-limit (* (length values) 2)))
;; Don't waste too much space, e.g. {5,6,10,20} would require 16 words
;; for 4 entries, which is excessive.
(when (and (<= table-size size-limit)
(can-encode-jump-table-p min max))
;; Return the new choices
(cons choices (cdr chain)))))))上記ルールからすると、一つ置きで配置された整数のキーは最適化されますが、二つ置きだとルールから外れるので最適化されないことが分かります。
一応試してみましょう。
(defun foo2 (x)
(declare (type fixnum x))
#.`(case x
,@(loop :for i :from 0 :by 2 :repeat 10
:collect (list i i))
(otherwise -1))); disassembly for FOO2
; Size: 110 bytes. Origin: #x52DF52DA ; FOO2
; 2DA: 498B4510 MOV RAX, [R13+16] ; thread.binding-stack-pointer
; 2DE: 488945F8 MOV [RBP-8], RAX
; 2E2: 4C8BDB MOV R11, RBX
; 2E5: 4983FB24 CMP R11, 36
; 2E9: 774E JNBE L10
; 2EB: 488D0526FFFFFF LEA RAX, [RIP-218] ; = #x52DF5218
; 2F2: 42FF2498 JMP QWORD PTR [RAX+R11*4]
; 2F6: L0: BA04000000 MOV EDX, 4
; 2FB: L1: 488BE5 MOV RSP, RBP
; 2FE: F8 CLC
; 2FF: 5D POP RBP
; 300: C3 RET
; 301: L2: BA08000000 MOV EDX, #x8 ; is_lisp_thread
; 306: EBF3 JMP L1
; 308: L3: BA0C000000 MOV EDX, 12
; 30D: EBEC JMP L1
; 30F: L4: BA10000000 MOV EDX, 16
; 314: EBE5 JMP L1
; 316: L5: BA14000000 MOV EDX, 20
; 31B: EBDE JMP L1
; 31D: L6: BA18000000 MOV EDX, 24
; 322: EBD7 JMP L1
; 324: L7: BA1C000000 MOV EDX, 28
; 329: EBD0 JMP L1
; 32B: L8: BA20000000 MOV EDX, 32
; 330: EBC9 JMP L1
; 332: L9: BA24000000 MOV EDX, 36
; 337: EBC2 JMP L1
; 339: L10: 48C7C2FEFFFFFF MOV RDX, -2
; 340: EBB9 JMP L1
; 342: L11: 31D2 XOR EDX, EDX
; 344: EBB5 JMP L1
; 346: CC10 INT3 16 ; Invalid argument count trap(defun foo3 (x)
(declare (type fixnum x))
#.`(case x
,@(loop :for i :from 0 :by 3 :repeat 10
:collect (list i i))
(otherwise -1))); disassembly for FOO3
; Size: 154 bytes. Origin: #x52DF53CE ; FOO3
; 3CE: 498B5D10 MOV RBX, [R13+16] ; thread.binding-stack-pointer
; 3D2: 48895DF8 MOV [RBP-8], RBX
; 3D6: 4885C0 TEST RAX, RAX
; 3D9: 0F8483000000 JEQ L9
; 3DF: 4883F806 CMP RAX, 6
; 3E3: 750B JNE L1
; 3E5: BA06000000 MOV EDX, 6
; 3EA: L0: 488BE5 MOV RSP, RBP
; 3ED: F8 CLC
; 3EE: 5D POP RBP
; 3EF: C3 RET
; 3F0: L1: 4883F80C CMP RAX, 12
; 3F4: 7507 JNE L2
; 3F6: BA0C000000 MOV EDX, 12
; 3FB: EBED JMP L0
; 3FD: L2: 4883F812 CMP RAX, 18
; 401: 7507 JNE L3
; 403: BA12000000 MOV EDX, 18
; 408: EBE0 JMP L0
; 40A: L3: 4883F818 CMP RAX, 24
; 40E: 7507 JNE L4
; 410: BA18000000 MOV EDX, 24
; 415: EBD3 JMP L0
; 417: L4: 4883F81E CMP RAX, 30
; 41B: 7507 JNE L5
; 41D: BA1E000000 MOV EDX, 30
; 422: EBC6 JMP L0
; 424: L5: 4883F824 CMP RAX, 36
; 428: 7507 JNE L6
; 42A: BA24000000 MOV EDX, 36
; 42F: EBB9 JMP L0
; 431: L6: 4883F82A CMP RAX, 42
; 435: 7507 JNE L7
; 437: BA2A000000 MOV EDX, 42
; 43C: EBAC JMP L0
; 43E: L7: 4883F830 CMP RAX, 48
; 442: 7507 JNE L8
; 444: BA30000000 MOV EDX, 48
; 449: EB9F JMP L0
; 44B: L8: 4883F836 CMP RAX, 54
; 44F: 48C7C2FEFFFFFF MOV RDX, -2
; 456: 41BB36000000 MOV R11D, 54
; 45C: 490F44D3 CMOVEQ RDX, R11
; 460: EB88 JMP L0
; 462: L9: 31D2 XOR EDX, EDX
; 464: EB84 JMP L0
; 466: CC10 INT3 16 ; Invalid argument count trapまとめ
SBCLのcaseのジャンプテーブル化は、キーをそこそこ密に配置する必要がある様子。
ちなみに、caseの最適化と本記事では書いてきましたが、Clozure CLと同じく、コンパイラが最適化で実施するので、Lispのレベルではifの組み合わせが最適化のルールに合致していれば発動します。
SBCLには最近細かい最適化が入ってきていますが今後も地味に速くなって行きそうです。
関連記事
■
HTML generated by 3bmd in LispWorks 7.0.0
スロットのアクセス時まで初期化を遅らせる
Posted 2019-11-24 20:54:15 GMT
ECLOSのlazy-classというのを再現してみようかなと思っているのですが、このlazy-slotには初期化のタイミングが、通常の初期化時と、スロット読み取り時直前とで二通りで選択可能です。
lazy-classには、他にも初期化の依存関係を記述する機能があるのですが、とりあえずそれは置いて、初期化タイミングだけ切り出して実現方法を考えてみました。
上手く行けば、初期化の依存関係を記述する機能と、初期化タイミングの指定は後でmixinできるでしょう。
あれこれ考えて作成してみましたが、下記のように動作します。
(defconstant <i@robj>
(defclass i@robj (initialize-at-read-object)
((a :initform 'a :initialize-at-read-p T)
(b :initform 'b :accessor b)
(c :initform 'c :accessor c))
(:metaclass initialize-at-read-class)))(class-slots <i@robj>)
→ (#<initialize-at-read-effective-slot-definition a 402023D19B>
#<initialize-at-read-effective-slot-definition b 402023D37B>
#<initialize-at-read-effective-slot-definition c 402023D3EB>)
(class-initialize-at-read-slots <i@robj>)
→ (#<initialize-at-read-effective-slot-definition a 4020235393>)
(let ((o (make-instance <i@robj>)))
(list (slot-boundp o 'a)
(slot-value o 'a)
(slot-value o 'b)
(slot-value o 'c)))
→ (nil a b c)
実装した内容としては、
- 読み取り時初期化のスロットを
class-initialize-at-read-slotsとして取得することにする - 読み取り時初期化のスロットは
shared-initializeでは初期化を飛す - 読み取り時初期化のスロットは、初回の読み取りは未束縛のため、
slot-unboundが起動されるので、ここで初期化する - スロットの初期化を条件によりスキップしないといけないので
shared-initializeを置き換え
位です。
実現したいことは単純なので、どうにかコードを圧縮したいところですが、MOPのコードはどうも長くなってしまいますね。
まあ、そんなに頻繁に書くものでもないので長くても良いのか……。
今回の場合は、slot-unboundを使ってスロットの初期化をすれば良いので、クラスごとに定義することにはなるもののMOPをカスタマイズしなくてもslot-unboundの定義だけすれば、正味五六行の追加で済みそうではあります。
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :closer-mop))
(defpackage "a86f7ecc-112d-5ccb-9280-20798a2e36b4"
(:use :c2cl))
(in-package "a86f7ecc-112d-5ccb-9280-20798a2e36b4")
;; utils
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun package-symbolconc (package-spec &rest frobs)
(values
(intern
(with-standard-io-syntax
(with-output-to-string (out)
(dolist (elt frobs)
(unless (typep elt '(or symbol string fixnum character))
(error "The value ~A is not of type (OR SYMBOL STRING FIXNUM CHARACTER)."
elt))
(princ elt out))))
package-spec)))
(defun symbolconc (&rest frobs)
(declare (dynamic-extent frobs))
(apply #'package-symbolconc *package* frobs)))
(defclass initialize-at-read-class (standard-class)
((initialize-at-read-slots :initform nil
:accessor class-initialize-at-read-slots))
(:metaclass standard-class))
(defclass initialize-at-read-object (standard-object)
()
(:metaclass initialize-at-read-class))
(defmethod validate-superclass ((c initialize-at-read-class) (s standard-class))
T)
(macrolet
((defslotd (name)
(let ((class (symbolconc name '-class))
(slotd (symbolconc name '-slot-definition))
(dslotd (symbolconc name '-direct-slot-definition))
(eslotd (symbolconc name '-effective-slot-definition))
(slotp (symbolconc 'slot-definition- name '-p)))
`(progn
(defclass ,slotd (standard-slot-definition)
((,(symbolconc name '-p)
:initform nil
:accessor ,slotp
:initarg ,(package-symbolconc :keyword name '-p))))
(defclass ,dslotd (,slotd standard-direct-slot-definition)
())
(defclass ,eslotd (,slotd standard-effective-slot-definition)
())
(defmethod direct-slot-definition-class ((class ,class) &rest initargs)
(declare (ignore initargs))
(find-class ',dslotd))
(defmethod effective-slot-definition-class ((class ,class) &rest initargs)
(declare (ignore initargs))
(find-class ',eslotd))
(defmethod compute-effective-slot-definition ((class ,class) name direct-slot-definitions)
(declare (ignore name))
(let ((eslotd (call-next-method)))
(dolist (dslotd direct-slot-definitions)
(when (typep dslotd (find-class ',slotd))
(setf (,slotp eslotd) (,slotp dslotd))
(return)))
eslotd))
(defmethod slot-unbound ((class ,class)
(instance ,(symbolconc name '-object))
name)
(let ((slotd (find name
(,(symbolconc 'class- name '-slots) class)
:key #'slot-definition-name)))
(let ((result (funcall (slot-definition-initfunction slotd))))
(setf (slot-value instance name) result)
result)))
(defmethod compute-slots :around ((class ,class))
(let ((slots (call-next-method)))
(setf (,(symbolconc 'class- name '-slots) class)
(remove-if-not #',slotp slots))
slots))))))
(defslotd initialize-at-read))
(defun initialize-slot-from-initarg (class instance slotd initargs)
(let ((slot-initargs (slot-definition-initargs slotd)))
(loop :for (initarg value) :on initargs :by #'cddr
:do (when (and (member initarg slot-initargs)
(not (slot-definition-initialize-at-read-p slotd)))
(setf (slot-value-using-class class instance slotd)
value)
(return t)))))
(defun initialize-slot-from-initfunction (class instance slotd)
(let ((initfun (slot-definition-initfunction slotd)))
(unless (or (not initfun)
(slot-boundp-using-class class instance slotd))
(unless (slot-definition-initialize-at-read-p slotd)
(setf (slot-value-using-class class instance slotd)
(funcall initfun))))))
(defmethod shared-initialize ((instance initialize-at-read-object) slot-names &rest initargs)
(let* ((class (class-of instance)))
(dolist (slotd (class-slots class))
(unless (initialize-slot-from-initarg class instance slotd initargs)
(when (or (eq t slot-names)
(member (slot-definition-name slotd) slot-names))
(initialize-slot-from-initfunction class instance slotd))))
instance))
■
HTML generated by 3bmd in LispWorks 7.0.0
STklosのメタクラス継承(をCommon Lispで)
Posted 2019-11-17 15:55:00 GMT
前回は、ECLOSが提供するdefclassの:metaclassオプション省略時のメタクラスの自動算出について書きましたが、今回はTiny CLOSの流れを汲むSTklos系のメタクラスメタクラスの自動算出です。
Tiny CLOSが動くScheme処理系は結構あるようですが、より処理系と統合されたり構文が改良されたりしているのがSTklos系のようです。
- STklos
- Guile
- Gauche
- Sagitarius
上記あたりがSTklos系のようですが、Tiny CLOSの系譜をいまいち把握できていないので外しているかもしれません。
上記の継承関係は、
(defclass stklos (tiny-clos clos dylan) ())
(defclass guile (stklos) ())
(defclass gauche (stklos guile) ())
(defclass sagitarius (gauche) ())っぽいですが。
とりあえず、今回のメタクラスの自動算出に関しては、上記処理系で共通なのでSTklos系ということにしましょう。
STklosメタクラスの自動算出アルゴリズム
Gauche: 7.5.1 クラスのインスタンシエーション等に解説されていますが、
define-classに:metaclassが明示されていればそれを使う- 指定がなければ
- ダイレクトスーパークラスのメタクラスのクラス順位リスト中を調べて
- メタクラスが一つに定まればそれを使う
- 複数なら、その複数のメタクラスをスーパークラスとするメタクラスを生成して使う
となります。
メタクラスのクラス順位リスト中をどう調べるのかは、コードは簡単なので詳細はコードを眺めた方が早いでしょう。
下記は、GuileのコードをCommon Lispに移植したものです。
オリジナルではクラス名をgensymで生成していますが、下記ではスーパークラス名のリストを名前としてみています。
(defpackage "d65706d7-0478-5a48-b39b-0dd8c0ff2563"
(:use :c2cl))
(in-package "d65706d7-0478-5a48-b39b-0dd8c0ff2563")
(let ((table-of-metas '()))
(defun ensure-metaclass-with-supers (meta-supers)
(let ((entry (assoc meta-supers table-of-metas :test #'equal)))
(if entry
;; Found a previously created metaclass
(cdr entry)
;; Create a new meta-class which inherit from "meta-supers"
(let* ((name (mapcar #'class-name meta-supers))
(new (make-instance 'standard-class
:name name
:direct-superclasses meta-supers
:direct-slots '())))
(setf (find-class name) new)
(push (cons meta-supers new) table-of-metas)
new)))))
(defun ensure-metaclass (supers)
(if (endp supers)
(find-class 'standard-class)
(let* ((all-metas (mapcar #'class-of supers))
(all-cpls (mapcan (lambda (m)
(copy-list (cdr (class-precedence-list m))))
all-metas))
(needed-metas '()))
;; Find the most specific metaclasses. The new metaclass will be
;; a subclass of these.
(mapc
(lambda (meta)
(when (and (not (member meta all-cpls))
(not (member meta needed-metas)))
(setq needed-metas (append needed-metas (list meta)))))
all-metas)
;; Now return a subclass of the metaclasses we found.
(if (endp (cdr needed-metas))
(car needed-metas) ; If there's only one, just use it.
(ensure-metaclass-with-supers needed-metas)))))
(defpackage stklos
(:use)
(:export defclass))
(defmacro stklos:defclass (name superclasses slots &rest class-options)
(let* ((metaclass (ensure-metaclass (mapcar (lambda (s)
(or (find-class s nil)
(make-instance 'standard-class :name s)))
superclasses)))
(metaclass (case (class-name metaclass)
(forward-referenced-class (find-class 'standard-class))
(otherwise metaclass))))
(clos::expand-defclass (class-prototype metaclass)
(class-name metaclass)
name
superclasses
slots
class-options)))
動作確認
定義できたので動作を確認していきます。
(defclass a-class (standard-class) ())
(defclass b-class (standard-class) ())
(defclass c-class (a-class b-class) ())
(defmethod validate-superclass ((c a-class) (s standard-class)) T)
(defmethod validate-superclass ((c b-class) (s standard-class)) T)(defconstant <a>
(defclass a ()
()
(:metaclass a-class)))
(defconstant <b>
(defclass b ()
()
(:metaclass b-class)))
前回と同じく、a-class、b-class、c-classとメタクラスを定義し、a-classをメタクラスとしたa、b-classをメタクラスとしたbを作成します。
ここで、
(defclass c (a b)
())とした場合に、cのメタクラスがどのように求まるかを確認してみます。
(ensure-metaclass (list <a> <b>))
→ #<standard-class (a-class b-class) 42E014EC0B> ECLOSではc-classが算出されましたが、STklosでは新たにメタクラスが生成されています。
なお、一度生成されたメタクラスはensure-metaclass-with-supersが保持していて、同様のメタクラスの組み合わせが既に存在すれば、それが使われるので重複して生成することはありません。
(defconstant <c>
(stklos:defclass c (a b)
()))(defconstant <d>
(stklos:defclass d (a b)
()))
(class-name (class-of <c>))
→ (a-class b-class)
(class-name (class-of <d>))
→ (a-class b-class)
(eq (class-of <c>) (class-of <d>))
→ t
(find-class (class-name (class-of <d>)))
→ #<standard-class (a-class b-class) 42E014EC0B>
まとめ
今回は、STklos系のメタクラスの自動算出を眺めてみました。
メタクラスのサブクラス方向を探しに行くECLOSとは違って、STklosは継承の最下層になっているメタクラスを集め、複数なら合成して返す、という感じでした。
ちょっと試してみた感じでは、開発時のようにクラスの再定義や削除、同じ定義が別名で定義されたり(実際には名前を付け替えているつもり)が頻発する環境だと、ECLOSが探索するサブクラスのメンテナンスがなおざりになることが多いので、算出された結果も開発者の直感からすると古い情報に基いてしまったりすることがあるようです。
まあ、正しくクラスを削除、再定義すれば良いのでそういうユーティリティを充実させるのも良いかもしれません。
STklos系は、動的にメタクラスを生成するのと、クラス順位リストがサブクラスに比べてきっちり更新されるので、トラブルらしいトラブルには遭遇していません。
さて、どちらの方式が便利なのか……。 しばらく両方の方式を日々比較検討試していきたいと思います。
■
HTML generated by 3bmd in LispWorks 7.0.0
ECLOSのメタクラス継承
Posted 2019-11-16 21:47:29 GMT
うまいタイトルが考えつかなかったので、「ECLOSのメタクラス継承」というタイトルになりましたが、ECLOSが提供するdefclassの:metaclassオプション省略時のメタクラスの自動算出についてです。
なお、ECLOSについては、
- LispM.de > docs > Publications > Common Lisp
- ECLOS Metaclass library
- Extended CLOS
に詳しいので参照してください。
ECLOSのメタクラスの自動算出アルゴリズム
Common Lispでは、カスタマイズしたメタクラスをdefclassで利用する際には明示的に:metaclassを指定しないといけないのですが、結構めんどうです。
上記文献によれば、ECLOSは、
defclassに:metaclassがあればそれを使う- 指定がなければ、
- ダイレクトスーパークラスの集合をSとする。
- それらのメタクラスの集合をM(S)とする。
- Sの要素のサブクラス関係の推移閉包の集合をM*(S)とする。
- M*(S)の要素の共通部分をTとする。
- Tがサブクラス関係の木を成していれば、その根を、さもなくば、
standard-classをメタクラスとする
というアルゴリズムでこの問題を解決します。
いまいち解釈に自信がありませんが、とりあえずそのままコードにしてみました。
推移閉包を求めるコードは、Tiny CLOSのものが手頃だったので、これを利用しています。
(defpackage "31f04d2f-2dc5-523c-a129-1478406e4677"
(:use :c2cl))
(in-package "31f04d2f-2dc5-523c-a129-1478406e4677")
(defun build-transitive-closure (get-follow-ons)
(lambda (x)
(labels ((track (result pending)
(if (endp pending)
result
(let ((next (car pending)))
(if (member next result)
(track result (cdr pending))
(track (cons next result)
(append (funcall get-follow-ons next)
(cdr pending))))))))
(track '() (list x)))))
(defun compute-metaclass (dsupers &key (default-metaclass-name nil))
(block nil
;;Let C be a class, if
;;a) the definition of C includes a (:metaclass M) option then M is the metaclass of C.
(when default-metaclass-name
(return (find-class default-metaclass-name)))
(when (endp dsupers)
(return (find-class 'standard-class)))
;;b) let S be the set of direct superclasses of C
(let* ((| S | dsupers)
(| M(S) | (mapcar #'class-of | S |))
;;and let M*(S) be the set of transitive closures of the subclass relation applied to the elements of M(S)
(| M*(S) | (mapcar (build-transitive-closure #'class-direct-subclasses) | M(S) |))
;;and let T be the intersection of the sets composing M*(S)
(| T | (reduce #'intersection | M*(S) |)))
;;then if T forms a tree according to the subclass relation
(if (and (not (null | T |))
(every #'subtypep | T | (cdr | T |)))
;;then the root of T is the metaclass of C
(car (reverse | T |))
;;otherwise STANDARD-CLASS is the metaclass of C.
(find-class 'standard-class)))))
(defpackage eclos
(:use)
(:export defclass))
(defun ensure-class-soft (name)
(or (find-class name nil)
(make-instance 'standard-class :name name)))
#+lispworks
(defmacro eclos:defclass (name superclasses slots &rest class-options)
(let* ((metaclass-name (cadr (find :metaclass class-options :key #'car)))
(metaclass (compute-metaclass (mapcar #'ensure-class-soft superclasses)
:default-metaclass-name metaclass-name))
(metaclass (case (class-name metaclass)
(forward-referenced-class (find-class 'standard-class))
(otherwise metaclass))))
(clos::expand-defclass (class-prototype metaclass)
(class-name metaclass)
name
superclasses
slots
class-options)))
動作確認
さて、定義できたので動作を確認していきます。
(defclass a-class (standard-class) ())
(defclass b-class (standard-class) ())
(defclass c-class (a-class b-class) ())
(defmethod validate-superclass ((c a-class) (s standard-class)) T)
(defmethod validate-superclass ((c b-class) (s standard-class)) T)(defconstant <a>
(defclass a ()
()
(:metaclass a-class)))
(defconstant <b>
(defclass b ()
()
(:metaclass b-class)))
a-class、b-class、c-classとメタクラスを定義し、a-classをメタクラスとしたa、b-classをメタクラスとしたbを作成します。
ここで、
(defclass c (a b)
())とした場合に、cのメタクラスが適切に求まれば良いのですが、上記で定義したcompute-metaclassで確認してみます。
(compute-metaclass (list <a> <b>))
→ #<lisp:standard-class c-class 4160314BC3> ;; c-classを削除
(progn
(reinitialize-instance (find-class 'c-class) :direct-superclasses nil)
(setf (find-class 'c-class) nil))
;; メタクラスが求まらなかったので、デフォルト値のstandard-classを返す
(compute-metaclass (list <a> <b>))
→ #<lisp:standard-class standard-class 41A0997013>
;; メタクラス再作成
(defclass c-class (b-class a-class) ())
→ #<lisp:standard-class c-class 40202BE5AB>
(compute-metaclass (list <a> <b>))
→ #<lisp:standard-class c-class 40202BE5AB>
とりあえず大丈夫そうなので、eclos:defclassを使ってcを定義してみます。
(eclos:defclass c (a b)
())
→ #<c-class c 402072C593> まとめ
以上の動作をみて分かるように、メタクラスを多重継承する場合は、予め多重継承したメタクラスを用意しておく必要がありますが、用意さえしておけば勝手に見付けてくれるのが便利といえば便利かもしれません。
メタクラス継承の自動算出は、STklos、Guile、Gauche等のSTklos系OOPSでも行なわれています。
ECLOSとは異なったアルゴリズムが使われているので、次回はそちらを眺めたりCommon Lispで実装してみます。
■
HTML generated by 3bmd in LispWorks 7.0.0
slot-valueを排除する試み(2)
Posted 2019-11-10 19:19:05 GMT
前回はとりあえず、インスタンスのアクセスにslot-valueを使わないようなメタクラスを定義してみたりしましたが、slot-value排除を推進してインスタンスの初期化にも細工してみたいと思います。
slot-value経由でのアクセスの廃止=カプセル化という応用で考えてみます。
encapsulated-class
本当はインスタンスの初期化からもslot-valueを排除したかったのですが、気付いたらslot-valueを自作していた感があったので、slot-valueは初期化メソッドの内部でしか利用させないという制限を付けることにしました。
制限の手段としては安直にクラスに class-encapsulated-pを定義して管理します。
slot-value...系はclass-slotsの情報を元に動作することになるので、大元のclass-slotsに制限を掛けてやることにします。
今回は、class-encapsulated-p が Tの時はclass-slotsがエラーを発するようにしてみました。
encapsulated-object
オブジェクトの初期化をカスタマイズするには、standard-objectを派生させる必要があるので、encapsulated-objectを定義し、これの初期化をカスタマイズします。
カプセル化と継承についての問題で、アクセス制限をどう継承するか、というものがあるようですが、今回は継承側の勝手に任せることにしました。
ということでこんな動きになりました。
;; utils
(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (fdefinition 'a) #'make-instance))(defconstant <zot>
(defclass zot (encapsulated-object)
((a :initform 0 :accessor zot.a))
(:encapsulated-p T)
(:metaclass encapsulated-class)))
(class-encapsulated-p <zot>)
→ T
(slot-value (a <zot>) 'a)
!!! Illegal reflective access: #<encapsulated-class zot 4120259C13>.
(zot.a (a <zot>))
→ 0
(defconstant <quux>
(defclass quux (zot)
((x :initform 42)
(y :initform 42)
(z :initform 42))
(:encapsulated-p nil)
(:metaclass encapsulated-class)))
(class-encapsulated-p <quux>)
→ nil
(with-slots (a x y z) (a <quux>)
(list a x y z))
→ (0 42 42 42)
定義
shared-initializeの定義はSBCLのものを参考にしました。
(cl:in-package cl-user)(load "via-accessor-class")
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :closer-mop)
(when (find-package "a6acd6f5-46a2-51bf-83be-8596ac2d2f35")
(delete-package "a6acd6f5-46a2-51bf-83be-8596ac2d2f35")))
(defpackage "a6acd6f5-46a2-51bf-83be-8596ac2d2f35"
(:use :c2cl))
(in-package "a6acd6f5-46a2-51bf-83be-8596ac2d2f35")
(defmacro in-syntax (name)
`(progn
(defvar ,(intern name) (copy-readtable nil))
(setq *readtable* ,(intern name))))
(defmacro local-prefix-setup ()
`(set-macro-character #\~ (lambda (srm chr)
(declare (ignore chr))
(intern (concatenate 'string
(string 'encapsulated-)
(string (read srm)))))))
(in-syntax "a6acd6f5-46a2-51bf-83be-8596ac2d2f35")
(local-prefix-setup)
(define-condition illegal-reflective-access (simple-error)
()
(:report (lambda (condition stream)
(format stream
"Illegal reflective access: ~{~S~}."
(simple-condition-format-arguments condition)))))
(defclass ~class (|3d0ecf39-dd6c-53f5-9672-58d5f5408cc6|:via-accessor-class)
((~p :initform T
:initarg :encapsulated-p
:accessor class-encapsulated-p)))
(defmethod ensure-class-using-class :around ((class ~class) name
&rest initargs
&key (~p T ~p-sup?))
(if (and ~p-sup? (consp ~p))
(apply #'call-next-method class name :encapsulated-p (car ~p) initargs)
(call-next-method)))
(defmethod validate-superclass ((class ~class) (super standard-class))
T)
(defmethod class-slots :around ((class ~class))
(if (class-encapsulated-p class)
(error 'illegal-reflective-access :format-arguments (list class))
(call-next-method)))
(defclass ~object (standard-object)
())
(defmethod shared-initialize ((instance ~object) slot-names &rest initargs)
(flet ((initialize-slot-from-initarg (class instance slotd)
(let ((slot-initargs (slot-definition-initargs slotd)))
(loop :for (initarg value) :on initargs :by #'cddr
:do (when (member initarg slot-initargs)
(setf (slot-value-using-class class instance slotd)
value)
(return t)))))
(initialize-slot-from-initfunction (class instance slotd)
(let ((initfun (slot-definition-initfunction slotd)))
(unless (or (not initfun)
(slot-boundp-using-class class instance slotd))
(setf (slot-value-using-class class instance slotd)
(funcall initfun))))))
(let* ((class (class-of instance))
(encapsulated-p (class-encapsulated-p class)))
(unwind-protect
(progn
(setf (class-encapsulated-p class) nil)
(loop :for slotd :in (class-slots class)
:unless (initialize-slot-from-initarg class instance slotd)
:do (when (or (eq t slot-names)
(member (slot-definition-name slotd) slot-names))
(initialize-slot-from-initfunction class instance slotd))))
(setf (class-encapsulated-p class)
encapsulated-p)))
instance))
(defmethod finalize-inheritance :around ((class ~class))
(let ((encapsulated-p (class-encapsulated-p class)))
(unwind-protect
(progn
(setf (class-encapsulated-p class) nil)
(call-next-method))
(setf (class-encapsulated-p class)
encapsulated-p))))
まとめ
slot-value排除の応用としてカプセル化も考えつつも、初期化でのslot-valueの扱いは日和るという中途半端な考察で、slot-valueを排除するのはなかなか面倒ということが分かっただけでした。
今回は、アクセス制限については、class-slotsでの制御としましたが、スロットをカスタマイズする方法もありそうです。
ちなみに、カプセル化の方法として、
Pythonの命名規約の__foo__みたいなものでしょうか。
;;; importすれば簡単にシンボルは捕捉できる
(defclass foo ()
(#:a #:b #:c))(class-slots (find-class 'foo))
→ (#<standard-effective-slot-definition #:a 40201BF60B>
#<standard-effective-slot-definition #:b 40201BF673>
#<standard-effective-slot-definition #:c 40201BF6DB>)
(mapc (lambda (s)
(shadowing-import (slot-definition-name s)))
(class-slots (find-class 'foo)))
→ (#<standard-effective-slot-definition a 417024825B>
#<standard-effective-slot-definition b 4170248753>
#<standard-effective-slot-definition c 4170248C63>)
(setf (slot-value (make-instance 'foo) 'a) 42)
→ 42
■
HTML generated by 3bmd in LispWorks 7.1.2
slot-valueを排除する試み(1)
Posted 2019-11-06 19:47:19 GMT
オブジェクトへのアクセスは、slot-valueを使わず、アクセサ経由でを心掛けようとは良くいわれますが、今回は、MOPでslot-valueを回避できないかを探る試みです。
MOPには、standard-instance-accessのようなものがあるので、アクセスはstandard-instance-accessを直接使ってしまえば良かろうと思って下記のようなものを書いてみました。
アクセサがstandard-instance-accessでアクセスするインデックスを保持できれば良いだけなのですが、class-slots実行以降でしかインデックスは確定しないので、アクセサが別途インデックスを保持するように拡張し、インデックス確定後にアクセサに値を格納することにしました。
(in-package cl-user)(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :closer-mop)
(when (find-package "3d0ecf39-dd6c-53f5-9672-58d5f5408cc6")
(delete-package "3d0ecf39-dd6c-53f5-9672-58d5f5408cc6")))
(defpackage "3d0ecf39-dd6c-53f5-9672-58d5f5408cc6"
(:use :c2cl))
(in-package "3d0ecf39-dd6c-53f5-9672-58d5f5408cc6")
(eval-when (:compile-toplevel :load-toplevel :execute)
(macrolet ((in-syntax (name)
`(progn
(defvar ,(intern name) (copy-readtable nil))
(setq *readtable* ,(intern name))))
(via-accessor-prefix-setup ()
`(set-macro-character #\~ (lambda (srm chr)
(declare (ignore chr))
(intern (concatenate 'string
(string 'via-accessor-)
(string (read srm))))))))
(in-syntax "3d0ecf39-dd6c-53f5-9672-58d5f5408cc6")
(via-accessor-prefix-setup)))
;; utils
(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (fdefinition 'a) #'make-instance)
(defun fintern (package control-string &rest args)
(with-standard-io-syntax
(intern (apply #'format nil control-string args)
(or package *package*))))
(defmacro <defclass> (name supers slots &rest class-options)
`(defconstant ,(fintern (symbol-package name) "<~A>" name)
(defclass ,name ,supers ,slots ,@class-options)))
#+lispworks
(editor:setup-indent "<defclass>" 2 2 10)
'eval-when)
(defclass ~class (standard-class)
())
(defmethod validate-superclass ((class ~class) (super standard-class))
T)
(defclass ~accessor-method (standard-accessor-method)
((slot-location :initarg :slot-location
:accessor ~accessor-method-location)))
(defclass ~reader-method (~accessor-method standard-reader-method)
())
(defclass ~writer-method (~accessor-method standard-writer-method)
())
(defun ~reader-method-function-maker (method)
#+(or lispworks ccl)
(lambda (arg &rest next-methods)
(declare (ignore next-methods))
(funcall (lambda (instance)
(standard-instance-access instance
(~accessor-method-location method)))
arg))
#+(or sbcl)
(lambda (args next-methods)
(declare (ignore next-methods))
(apply (lambda (instance)
(standard-instance-access instance
(~accessor-method-location method)))
args)))
(defmethod initialize-instance ((method ~reader-method) &rest initargs)
(apply #'call-next-method
method
:function (~reader-method-function-maker method)
initargs))
(defun ~writer-method-function-maker (method)
#+(or lispworks ccl)
(lambda (val arg &rest next-methods)
(declare (ignore next-methods))
(funcall (lambda (val instance)
(setf (standard-instance-access instance
(~accessor-method-location method))
val))
val
arg))
#+(or sbcl)
(lambda (args next-methods)
(declare (ignore next-methods))
(apply (lambda (val instance)
(setf (standard-instance-access instance
(~accessor-method-location method))
val))
args)))
(defmethod initialize-instance ((method ~writer-method) &rest initargs)
(apply #'call-next-method
method
:function (~writer-method-function-maker method)
initargs))
(defmethod reader-method-class ((class ~class) direct-slot &rest args)
(declare (ignore args direct-slot))
(find-class '~reader-method))
(defmethod writer-method-class ((class ~class) direct-slot &rest args)
(declare (ignore args direct-slot))
(find-class '~writer-method))
(defmethod finalize-inheritance :after ((class ~class))
(let ((esds (class-slots class)))
(dolist (dsd (class-direct-slots class))
(dolist (reader (slot-definition-readers dsd))
(let ((meth (find-method (ensure-generic-function reader :lambda-list '(x))
nil
(list class)
nil)))
(when meth
(setf (~accessor-method-location meth)
(slot-definition-location
(find (slot-definition-name dsd)
esds
:key #'slot-definition-name))))))
(dolist (writer (slot-definition-writers dsd))
(let ((meth (find-method (ensure-generic-function writer :lambda-list '(val x))
nil
(list (find-class T) class)
nil)))
(when meth
(setf (~accessor-method-location meth)
(slot-definition-location
(find (slot-definition-name dsd)
esds
:key #'slot-definition-name)))))))))
(defmethod shared-initialize :after ((class ~class) slot-names &rest initargs)
(declare (ignore slot-names initargs))
(finalize-inheritance class))
おまけに速くなるのだろうか……
理屈では間接参照のslot-valueと違って直接参照のstandard-instance-accessの方が速くなる筈ですがどうでしょう。
さすがに処理系もslot-valueでのアクセスの最適化はしていると思いますが……。
(<defclass> foo ()
((a :initform 0 :accessor .a)
(b :initform 1)
(c :initform 2 :accessor .c))
(:metaclass ~class))(<defclass> bar (foo)
((d :initform 3 :accessor .d))
(:metaclass ~class))
読み出し速度
LispWorksだと今回の方式の方が若干速くなることもあったりなかったり。
ちなみにSBCL等だと余計なことをするよりslot-valueの方が速いようです……。
(time
(let ((obj (a <foo>)))
(dotimes (i (expt 10 6))
(slot-value obj 'a))))User time = 1.240
System time = 0.000
Elapsed time = 1.242
Allocation = 1296014992 bytes
0 Page faults
Calls to %EVAL 18000041
(time
(let ((obj (a <foo>)))
(dotimes (i (expt 10 6))
(.a obj))))
User time = 1.100
System time = 0.000
Elapsed time = 1.095
Allocation = 1296011632 bytes
0 Page faults
Calls to %EVAL 17000041
書き込み速度
LispWorksだと読み出し同様、今回の方式の方が若干速くなることもあったりなかったり。 ちなみにSBCL等でも若干速くなるかも。
(time
(let ((obj (a <foo>)))
(dotimes (i (expt 10 6))
(setf (slot-value obj 'a) 42))))User time = 7.260
System time = 0.000
Elapsed time = 7.259
Allocation = 3126471872 bytes
0 Page faults
Calls to %EVAL 20000041
(time
(let ((obj (a <foo>)))
(dotimes (i (expt 10 6))
(setf (.a obj) 42))))
User time = 6.020
System time = 0.060
Elapsed time = 6.074
Allocation = 3118472872 bytes
0 Page faults
Calls to %EVAL 22000041
今回のまとめ
明示的にstandard-instance-accessを使うようにしても、slot-value経由より遅くなることもあるようなので、もう少し詰めて対策しないと御利益はなさそうです。
標準のオブジェクトへのアクセスは処理系が結構最適化しているのですが、ユーザー定義のメタクラス等の派生物は標準から外れるので処理系が用意している最適化の適用外になってしまうことも多いようです。
なお今回は、アクセス方法でslot-valueを外す試みでしたが、インスタンス初期化まわりでもslot-valueは使われています。
どうもslot-valueを排除するのは簡単な話ではなさそう。
〜インスタンス生成篇へつづく〜
■
HTML generated by 3bmd in LispWorks 7.1.2
;|#
Posted 2019-11-02 19:13:57 GMT
;|# はかしこい
どうもiterateのバグを踏んでしまったようなのでソースを眺めていましたが、コード中の ;|# を目にしてこれは賢いなと以前から思っていたことを思い出しました。
#|
;; Optionally set up Slime so that C-c C-c works with #L
#+#.(cl:when (cl:find-package "SWANK") '(:and))
(unless (assoc "ITERATE" swank:*readtable-alist* :test #'string=)
(bind ((*readtable* (copy-readtable *readtable*)))
(enable-sharpL-reader)
(push (cons "ITERATE" *readtable*) swank:*readtable-alist*)))
;|#賢いというのは、#|を;でコメントアウトしさえすれば、後ろの|#のメンテナンス(つまり消す)はしなくても良いというところ。
#|
(list 0 1 2)
;|#(list 0 1 2)を復活したくなった →
;#|
(list 0 1 2)
;|#Quicklisp中にどれくらい含まれているか検索してみましたが、iterateの他は、clazy、teepeedee2、で使われているくらいのようです。
案外少ないかも?
このブログはteepeedee2で運用されていますが、;|#は、teepeedee2のソースで最初に目にした気がします。
■
HTML generated by 3bmd in LispWorks 7.1.2
||パッケージの謎
Posted 2019-10-20 14:41:47 GMT
Common Lispのパッケージは名前を持ち、その名前は文字列となっています。
さて、それでは長さ0の文字列の場合、どのような挙動になるでしょうか。
ざっと調べてみました。
| 処理系 | ""パッケージの扱い |
|---|---|
| LispWorks 7.1.2 | ""パッケージ |
| Allegro CL 10.1 | keywordパッケージ |
| Lucid CL 4.1 | keywordパッケージ |
| CCL 1.11.5 | ""パッケージ |
| CMUCL 21d | ""パッケージ |
| CMUCL 17f | ""パッケージ |
| SBCL 1.5.7 | ""パッケージ |
| AKCL 1.619 | ""パッケージ |
| GCL | ""パッケージ |
| ECL | ""パッケージ |
| MkCL | ""パッケージ |
Allegro CLと、Lucid CLは、(find-package "")でkeywordパッケージを返してきます。
パッケージ名の部分が空であればkeywordパッケージとする、という解釈もそれはそれで整合性がありそうではあります。
リーダーの読み取りの挙動が違っているのかと思いましたが、ちょっと調べてみたら、Allegro CLもLucid CLもニックネームに""が指定されているだけでした。
(package-nicknames :keyword)
→ ("")ANSI CL規格を確認してみると、keywordパッケージのニックネームはnoneとなっていて拡張の余地がありそうな記述もないので、処理系の独自拡張ということになりそうです。
まとめ
なかなか面白い処理系拡張です。
(intern "X" "KEYWORD")
→ :x
:external よりも、
(intern "X" "")
→ :x
:external の方が直感的な気がしなくもありません。
(rename-package :keyword :keyword '(""))によってお手軽に実現できますが、""パッケージが使えなくなるので注意しましょう(そんなパッケージ名使われないか)
■
HTML generated by 3bmd in LispWorks 7.1.2
Allegro CLのfixed-indexスロットアクセスを真似してみる
Posted 2019-10-14 19:51:18 GMT
先日、RedditでAllegro CLのstandard-objectのスロットのアクセスを高速化するオプションについての投稿があり、記事を読んでみたのですが、
第一感としては、何故standard-instance-accessを使わないのだろうか、というところでした。
それとは別にfixed-indexを新機能として紹介していますが、どうも以前にみたことあるなと思ったので、古いAllegro CL 4.3(1996)を確認してみましたが、やはり存在しました。
(パッケージは、clos→exclで移動した模様)
昔からの隠し機能が公になった、というところなのかもしれません。
;;; Allegro CL 4.3
(defclass foo ()
((a :initarg :a clos::fixed-index 2 :accessor foo-a)
(b :initarg :b clos::fixed-index 3 :accessor foo-b)
(c :initarg :c :accessor foo-c)))(defvar *foo-inst* (make-instance 'foo :a 1 :b 2 :c 3))
(defvar *vec* (clos::std-instance-slots *foo-inst*))
USER(13): *vec*
#(3 CLOS::..SLOT-UNBOUND.. 1 2)
...
fixed-index系 と standard-instance-access 系は何が違うのか
fixed-index指定は、オブジェクトのスロットの値を保持しているベクタの位置を直に指定するもので、それに加えて、指定されたfixed-indexの最大値とスロットの総数で大きい方をバックエンドのベクタのサイズにするようです。
指定されていない空き地は#<unbound-marker>のようなもので埋まります。
Allegro CLでもAMOPのstandard-instance-accessと slot-definition-locationはサポートしており、fixed-indexの値とも連動しています。
fixed-indexが簡単に実装できないか、standard-instance-access & slot-definition-location 系の処理系を眺めてみましたが、大抵はスロット数のサイズのベクタを隙間なく並べ、先頭から番号を振るようです。
fixed-indexを真似してみる
スロットの値を保持するベクタの確保の方法が難という感じですが、とりあえずLispWorks等で真似できるか試してみます。
(ql:quickload :closer-mop))(defpackage "4fef36ee-23f6-5dff-beb9-070053d5dbbb" (:use :c2cl))
(in-package "4fef36ee-23f6-5dff-beb9-070053d5dbbb")
;; utils
(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (fdefinition 'a) #'make-instance)
(defun fintern (package control-string &rest args)
(with-standard-io-syntax
(intern (apply #'format nil control-string args)
(or package *package*))))
(defmacro <defclass> (name supers slots &rest class-options)
`(defconstant ,(fintern (symbol-package name) "<~A>" name)
(defclass ,name ,supers ,slots ,@class-options))))
(<defclass> fixed-index-slot-class (standard-class)
())
(defmethod validate-superclass ((c fixed-index-slot-class) (s standard-class))
T)
(<defclass> fixed-index-slot-definition (standard-slot-definition)
((fixed-index :initform nil
:initarg fixed-index
:accessor slot-definition-fixed-index)))
(<defclass> fixed-index-direct-slot-definition
(fixed-index-slot-definition standard-direct-slot-definition)
())
(defmethod direct-slot-definition-class ((c fixed-index-slot-class) &rest initargs)
(declare (ignore initargs))
<fixed-index-direct-slot-definition>)
(defmethod compute-effective-slot-definition ((class fixed-index-slot-class) name direct-slot-definitions)
(declare (ignore name))
(let ((effective-slotd (call-next-method)))
(dolist (slotd direct-slot-definitions)
(when (typep slotd <fixed-index-slot-definition>)
(setf (slot-definition-location effective-slotd)
(slot-definition-fixed-index slotd))
(return)))
effective-slotd))
(defmethod compute-slots ((class fixed-index-slot-class))
(let* ((slots (call-next-method)))
(loop :for idx :from 0 :repeat (length slots)
:do (let* ((s (find idx slots :key #'slot-definition-location)))
(unless s
(let ((s (find-if (lambda (x) (null (slot-definition-location x)))
slots)))
(when s
(setf (slot-definition-location s)
idx))))))
(sort (copy-list slots) #'< :key #'slot-definition-location)))
ちなみに、 effective-slot-definition-class周りを定義していませんが、スロットの順番を指定するだけなので、effective-slotはfixed-indexの値を持たせていません。
(アロケーション〜初期化周りを実装するにあたって必要になりそうではあります。)
再現しようとした結果: 飛び飛びに値を保持するベクタをバックエンドにする方法が分からない
→ 方法が分かったので別記事を書きました: Allegro CLのfixed-indexスロット再現リベンジ
上記では、fixed-indexでスロット群の並び順を指定することはできたのですが、LispWorksではアロケーションされたベクタをAllegro CLのfixed-indexの要件を満すように読み書きする方法が分からず仕舞でした。
SBCLはソースが読めるので、そのうち確認してみたいところ。
とりあえず、Allegro CLのfixed-index記事の御題目としては高速化が目的のようなので、速度を計測してみます。
(<defclass> foo ()
((a :initarg :a fixed-index 1 :accessor foo-a)
(b :initarg :b fixed-index 2 :accessor foo-b)
(c :initarg :c :accessor foo-c))
(:metaclass fixed-index-slot-class));; test
(defparameter *foo-inst* (a <foo> :a 1 :b 2 :c 3))(declaim (inline std-instance-slots))
(defun std-instance-slots (inst)
#+allegro (excl::std-instance-slots inst)
#+sbcl (sb-pcl::std-instance-slots inst)
#+lispworks (clos::standard-instance-static-slots inst))
(declaim (simple-vector std-instance-slots))
(defparameter *vec* (std-instance-slots *foo-inst*))
(locally
(declare (optimize (safety 1) (space 1) (speed 3) (debug 0)
(compilation-speed 0)))
(defun p1 () (dotimes (i 10000000) (signum (foo-a *foo-inst*))))
(defun p2 () (dotimes (i 10000000) (signum (slot-value *foo-inst* 'a))))
(defun p3 () (dotimes (i 10000000) (signum (svref *vec* 1))))
(defun p4 () (dotimes (i 10000000) (signum (svref (std-instance-slots *foo-inst*) 1))))
(defun p5 () (dotimes (i 10000000) (signum (standard-instance-access *foo-inst* 1))))
)
(progn
(time (p1))
(time (p2))
(time (p3))
(time (p4))
(time (p5))
)
LispWorksの場合
LispWorksではバックエンドのベクタをアクセスする方法がstandard-instance-accessなので、Allegro CLの記事のようにバックエンドをベクタを直接取り出してアクセスしたのとほぼ同一な結果になります。
standard-instance-accessがアクセサの60倍強となりAllegro CLの記事の御題目と似たものとなりました。
Timing the evaluation of (p1)User time = 1.870
System time = 0.000
Elapsed time = 1.868
Allocation = 10816 bytes
0 Page faults
; (top-level-form 15)
Timing the evaluation of (p2)
User time = 1.630
System time = 0.000
Elapsed time = 1.619
Allocation = 17584 bytes
0 Page faults
; (top-level-form 15)
Timing the evaluation of (p3)
User time = 0.030
System time = 0.000
Elapsed time = 0.033
Allocation = 13184 bytes
0 Page faults
; (top-level-form 15)
Timing the evaluation of (p4)
User time = 0.040
System time = 0.000
Elapsed time = 0.035
Allocation = 0 bytes
0 Page faults
; (top-level-form 15)
Timing the evaluation of (p5)
User time = 0.040
System time = 0.000
Elapsed time = 0.039
Allocation = 0 bytes
0 Page faults
SBCLの場合
SBCLでは、アクセサもslot-valueも standard-instance-accessでのアクセスと同等まで最適化されるので、どれも速いという結果になりました。
良く考えればこれが理想では?
Evaluation took: (p1)
0.050 seconds of real time
0.050000 seconds of total run time (0.050000 user, 0.000000 system)
100.00% CPU
163,816,326 processor cycles
0 bytes consedEvaluation took: (p2)
0.044 seconds of real time
0.050000 seconds of total run time (0.050000 user, 0.000000 system)
113.64% CPU
145,140,144 processor cycles
0 bytes consed
Evaluation took: (p3)
0.020 seconds of real time
0.020000 seconds of total run time (0.020000 user, 0.000000 system)
100.00% CPU
68,159,274 processor cycles
1,712 bytes consed
Evaluation took: (p4)
0.022 seconds of real time
0.020000 seconds of total run time (0.020000 user, 0.000000 system)
90.91% CPU
71,779,470 processor cycles
0 bytes consed
Evaluation took: (p5)
0.021 seconds of real time
0.020000 seconds of total run time (0.020000 user, 0.000000 system)
95.24% CPU
69,904,809 processor cycles
0 bytes consed
まとめ
Allegro CLのfixed-index機能は面白いとは思うのですが、高速化ということに限っては、SBCLのように何も指定しなくても、 standard-instance-access を使ったのと同等の所まで最適化してくれる方が望ましいでしょう。
fixed-indexでは、特定の位置に特定のデータを配置したものをクラスを跨いで同一のアクセス方法で処理できたりしそうなので、もっと他の使い方があるのでは……、などと思ったり……。
■
HTML generated by 3bmd in LispWorks 7.0.0
eval-whenのおさらい
Posted 2019-10-07 21:08:30 GMT
Common Lispでは、実行時、コンパイル時、リード時、その他色々なタイミングでの評価を活用しますが、その制御に専ら使われるのが、eval-whenです。
といっても、大抵eval-whenを使わないか、(:compile-toplevel :execute :load-toplevel)を全部付けるかです。
実際の所は全部盛りを知っていれば問題ないのですが、入れ子になった場合や、全部盛り以外の組み合わせの挙動を確認してみようかなと思います。
指定の組み合わせを眺めてみる
こんな感じのコードで、適当なファイルに組み合わせを書き出します。
(setf (logical-pathname-translations "tem")
'(("**;*.*.*" "/tmp/**/*.*")))(with-open-file (*standard-output* "tem:ew.lisp"
:direction :output
:if-does-not-exist :create
:if-exists :supersede)
(pprint
(cons
'progn
(loop :for w :in '((progn)
(eval-when (:execute))
(eval-when (:compile-toplevel))
(eval-when (:load-toplevel)))
:collect `(,@w
(eval-when (:compile-toplevel :execute :load-toplevel)
(prin1 ',w)
(terpri))
,@(loop :for i :from 0
:for x :in '(nil
(:compile-toplevel)
(:compile-toplevel :load-toplevel)
(:load-toplevel)
(:compile-toplevel :execute)
(:compile-toplevel :execute :load-toplevel)
(:execute)
(:execute :load-toplevel))
:collect `(eval-when ,x
(prin1 '(,i ,x))
(terpri))))))))
書き出した内容
(progn
(progn
(eval-when (:compile-toplevel :execute :load-toplevel) (prin1 '(progn)) (terpri))
(eval-when nil (prin1 '(0 nil)) (terpri))
(eval-when (:compile-toplevel) (prin1 '(1 (:compile-toplevel))) (terpri))
(eval-when (:compile-toplevel :load-toplevel) (prin1 '(2 (:compile-toplevel :load-toplevel))) (terpri))
(eval-when (:load-toplevel) (prin1 '(3 (:load-toplevel))) (terpri))
(eval-when (:compile-toplevel :execute) (prin1 '(4 (:compile-toplevel :execute))) (terpri))
(eval-when (:compile-toplevel :execute :load-toplevel)
(prin1 '(5 (:compile-toplevel :execute :load-toplevel)))
(terpri))
(eval-when (:execute) (prin1 '(6 (:execute))) (terpri))
(eval-when (:execute :load-toplevel) (prin1 '(7 (:execute :load-toplevel))) (terpri)))
(eval-when (:execute)
(eval-when (:compile-toplevel :execute :load-toplevel) (prin1 '(eval-when (:execute))) (terpri))
(eval-when nil (prin1 '(0 nil)) (terpri))
(eval-when (:compile-toplevel) (prin1 '(1 (:compile-toplevel))) (terpri))
(eval-when (:compile-toplevel :load-toplevel) (prin1 '(2 (:compile-toplevel :load-toplevel))) (terpri))
(eval-when (:load-toplevel) (prin1 '(3 (:load-toplevel))) (terpri))
(eval-when (:compile-toplevel :execute) (prin1 '(4 (:compile-toplevel :execute))) (terpri))
(eval-when (:compile-toplevel :execute :load-toplevel)
(prin1 '(5 (:compile-toplevel :execute :load-toplevel)))
(terpri))
(eval-when (:execute) (prin1 '(6 (:execute))) (terpri))
(eval-when (:execute :load-toplevel) (prin1 '(7 (:execute :load-toplevel))) (terpri)))
(eval-when (:compile-toplevel)
(eval-when (:compile-toplevel :execute :load-toplevel) (prin1 '(eval-when (:compile-toplevel))) (terpri))
(eval-when nil (prin1 '(0 nil)) (terpri))
(eval-when (:compile-toplevel) (prin1 '(1 (:compile-toplevel))) (terpri))
(eval-when (:compile-toplevel :load-toplevel) (prin1 '(2 (:compile-toplevel :load-toplevel))) (terpri))
(eval-when (:load-toplevel) (prin1 '(3 (:load-toplevel))) (terpri))
(eval-when (:compile-toplevel :execute) (prin1 '(4 (:compile-toplevel :execute))) (terpri))
(eval-when (:compile-toplevel :execute :load-toplevel)
(prin1 '(5 (:compile-toplevel :execute :load-toplevel)))
(terpri))
(eval-when (:execute) (prin1 '(6 (:execute))) (terpri))
(eval-when (:execute :load-toplevel) (prin1 '(7 (:execute :load-toplevel))) (terpri)))
(eval-when (:load-toplevel)
(eval-when (:compile-toplevel :execute :load-toplevel) (prin1 '(eval-when (:load-toplevel))) (terpri))
(eval-when nil (prin1 '(0 nil)) (terpri))
(eval-when (:compile-toplevel) (prin1 '(1 (:compile-toplevel))) (terpri))
(eval-when (:compile-toplevel :load-toplevel) (prin1 '(2 (:compile-toplevel :load-toplevel))) (terpri))
(eval-when (:load-toplevel) (prin1 '(3 (:load-toplevel))) (terpri))
(eval-when (:compile-toplevel :execute) (prin1 '(4 (:compile-toplevel :execute))) (terpri))
(eval-when (:compile-toplevel :execute :load-toplevel)
(prin1 '(5 (:compile-toplevel :execute :load-toplevel)))
(terpri))
(eval-when (:execute) (prin1 '(6 (:execute))) (terpri))
(eval-when (:execute :load-toplevel) (prin1 '(7 (:execute :load-toplevel))) (terpri))))書き出したコードを実際にコンパイルしたりロードしたりで実行してみます。
(progn
(format T "~2&================ :execute~%")
(load "tem:ew.lisp" :verbose nil)
(format T "~2&================ :compile-toplevel~%")
(compile-file "tem:ew.lisp" :verbose nil :print nil)
(format T "~2&================ :load-toplevel~%")
(load "tem:ew" :verbose nil :print nil))結果の確認
上記の結果を評価タイミングごとに眺めていきます。
なお、-toplevelと付いていることからも想像できるように、:compile-とload-はトップレベルに置かれないと評価されません。
また、eval-whenの中はトップレベルなので、入れ子にしてもトップレベル扱いです。
:execute
executeは、実行時の評価です。
式をevalしたり、コンパイルしていないソースファイルをloadした場合のフェイズといえるでしょう。
================ :execute
(progn)
(4 (:compile-toplevel :execute))
(5 (:compile-toplevel :execute :load-toplevel))
(6 (:execute))
(7 (:execute :load-toplevel))(eval-when (:execute))
(4 (:compile-toplevel :execute))
(5 (:compile-toplevel :execute :load-toplevel))
(6 (:execute))
(7 (:execute :load-toplevel))
トップレベルの式、もしくは :executeが含まれたeval-whenの中だけ評価されているのが分かります。
:compile-toplevel
:compile-toplevelは、コンパイル時です。eval-whenの直下のフォームと入れ子になった:executeが評価されます。
ややこしいのが、コンパイル時には、eval-whenの:load-toplevel指定の中身も見る(=コンパイルする)ことですが、中身は見ますが、内側に:compile-toplevelを指定しないとコンパイル時には評価されません。
================ :compile-toplevel
(progn)
(1 (:compile-toplevel))
(2 (:compile-toplevel :load-toplevel))
(4 (:compile-toplevel :execute))
(5 (:compile-toplevel :execute :load-toplevel))(eval-when (:compile-toplevel))
(4 (:compile-toplevel :execute))
(5 (:compile-toplevel :execute :load-toplevel))
(6 (:execute))
(7 (:execute :load-toplevel))
(eval-when (:load-toplevel))
(1 (:compile-toplevel))
(2 (:compile-toplevel :load-toplevel))
(4 (:compile-toplevel :execute))
(5 (:compile-toplevel :execute :load-toplevel))
:load-toplevel
:load-toplevelは、コンパイル済みのファイルであるfaslをロードした場合の評価フェイズです。
ロードというと色々ややこしいので、以降、fasloadと呼びます。
fasloadの場合は、:load-toplevelを入れ子にすれば、:load-toplevelの中は評価しますが、:executeの中身はみません。
上述のように:compile-toplevelは入れ子にしても機能しますが、それはコンパイル時に評価されるものなのでfasload時には評価されません。
================ :load-toplevel
(progn)
(2 (:compile-toplevel :load-toplevel))
(3 (:load-toplevel))
(5 (:compile-toplevel :execute :load-toplevel))
(7 (:execute :load-toplevel))(eval-when (:load-toplevel))
(2 (:compile-toplevel :load-toplevel))
(3 (:load-toplevel))
(5 (:compile-toplevel :execute :load-toplevel))
(7 (:execute :load-toplevel))
応用の考察
マクロ展開時限定で何かを評価するには
マクロはコンパイル時に展開されますが、実行時でも展開される可能性はある(インタプリタ動作の場合)ので下記のようになるでしょうか。
fasloadではコンパイル済みの筈なので、マクロ展開が起きることはありません。
(eval-when (:compile-toplevel :execute)
....)マクロ展開時限定で何かしたいことがあれば……ですが。
defpackageのシンボル汚染問題を解消する
defpackage展開用のパッケージを作成して、コンパイル時のみの評価とすれば、fasload時には展開用のパッケージは存在しなくても良いことになります。
;;; tem:zzz.lisp ファイル
(in-package :cl-user)(eval-when (:compile-toplevel)
(defpackage "bfa90b48-5531-5245-9256-8dfb8d9119f3" (:use :cl))
(in-package "bfa90b48-5531-5245-9256-8dfb8d9119f3"))
(defpackage foo
(:use cl)
(:intern a b c))
(compile-file "tem:zzz")
(delete-package "bfa90b48-5531-5245-9256-8dfb8d9119f3")
(load "tem:zzz")(list (find-symbol "A" :cl-user)
(find-symbol "B" :cl-user)
(find-symbol "C" :cl-user)
(find-symbol "A" :foo))
→ (nil nil nil foo::a)
良く考えれば、コンパイル時にdefpackageによって使われたシンボルも、別のイメージにfasloadした時には居なくても良いので、cl-userで書いたのと大した違いはないですね。
そう考えると、defpackageのシンボル汚染問題もコンパイル時のイメージ限定なのかなと。
まとめ
はまり所としては、
:load-toplevelの中の:compile-toplevelがコンパイル時に評価されるというのがややこしいloadという関数名と、:load-toplevelという名前が誤解を招くloadでlispファイルを読み込めば:executeloadでfaslファイルを読み込めば:load-toplevel
位でしょうか。
昔のLispでは、faslを読むのにはfasloadという専用関数が使われ、コンパイルしていないファイルにはloadを使ったりしていたようですが、Common Lispでloadに一本化されたようですね。
以上、eval-whenの考察でした。
■
HTML generated by 3bmd in LispWorks 7.0.0
NILのソース発掘される!
Posted 2019-10-06 16:39:24 GMT
伝説の処理系であるNILですが、先日ソースが発掘され、Software Preservation Groupで公開されたようです。ありがたや!
このブログでもNILについて何度か記事を書いていますが、要約すれば、MITがMACLISPの後継として作ったLISP処理系で、Common Lispの先祖の一つでありつつ後にNILもCommon Lisp化した処理系です(ややこしい)
NILの概要については、
あたりが一番まとまった記事かなと思います。
ソースを眺める
早速ソースを眺めてみましたが、雑感をメモしておこうかなと思います。
LOOPが多用されている。- プリミティブなものも
LOOPで書かれている(CAR、CDR、MAPCAR…) - 本当に多用されているが、
LOOPのメンテナであるGSB氏が書いているからかもしれない。
- プリミティブなものも
FEATUREPがある- Flavorsが組み込み
- Lisp Machine Lisp、MACLISPの実装ともちょっと違うっぽい
- ハッシュテーブルがFlavorsで実装されている
- Lisp Machine Lispも同じく(Flavorsよりハッシュテーブルの方が後で導入されたから?)
- IOもFlavors実装が中心
- Lisp Machine Lispも同じく
#Tがある(真値)- 謎の
*パッケージがある。- 読みは“STAR”らしい。システムの定数が多い。用途未詳。
- 階層パッケージが標準(Lisp Machine Lispと同様)
FLEXURESがある(スペシャル変数のクロージャー)- Extendの定義がある(Flavorsとも違うOOPS)
- Patch Systemがある。
- CGOLが内蔵されている
- MACSYMAユーザーを意識してだろうか
TAGBODYの定義でタグ環境の表現にFlavorsが使われている- パッケージはattribute list(
-*- ... -*-でお馴染み)で指定するらしい - コンパイラの名前は H らしい。
"This is NIL including the H compiler"
- NIL版のEmacsであるSteveが同梱
- LSBが同梱(MACLISP系処理系のポータブルレイヤー&文書化システム)
- デモプログラムにMYCIN、OPS5、YAQ(Prolog)、FRL(フレーム言語)が同梱
(lisp-implementation-type) → "NIL, MIT Common Lisp"らしい
副次的ですが、これまで謎だったLSBシステムのコードが発掘されたというのは結構嬉しいです。
全体的なコードに印象ですが、Lispマシングループとは一味違いつつ、MACLISP寄りでありつつもちょっと違う、という感じでしょうか。
等々、他にも沢山面白そうなところはありますが、今後じっくり眺めていきたいと思います。
関連記事
■
HTML generated by 3bmd in LispWorks 7.0.0
ハッシュテーブルのキーとしてリストを使う
Posted 2019-09-30 19:51:28 GMT
こちらのエントリーを読んでいて、本筋とはちょっと関係ないのですが、リストに対してのsxhashの返り値が特定の長さからは同じ値を返すということについて興味を持ったので手元の処理系で調べてみました。
調べるのに使ったコードは、下記のようなものです
(loop :for i :from 0 :when (= (sxhash (make-list i)) (sxhash '#0=(nil . #0#))) :return i)各処理系でリストの sxhash のハッシュ値が区別できなくなる地点
| 処理系 | 区別できなくなる地点 |
|---|---|
| LispWorks 7.1.2 | 14以降 |
| Allegro CL 10.1 | 14以降 |
| Lucid CL 4.1 | 9以降 |
| CCL 1.11.5 | 7以降 |
| CMUCL 21d | 7以降 |
| CMUCL 17f | 7以降 |
| SBCL 1.5.7 | 5以降 |
| AKCL 1.619 | 4以降 |
| GCL | 4以降 |
| ECL | 3以降 |
| MkCL | 3以降 |
興味本位で、CADR system 78のLisp Machine Lisp(Common Lispの祖先)で試してみたところ、sxhashはどんな長さでも諦めないで計算してくれるようです。
また、循環リストを与えると停止しません。
Lisp Machine Lispと違って、Common Lispで上記のように特定の長さでハッシュ値の計算を打ち切ってしまうのは、sxhashが循環構造のオブジェクトについても停止することが要求されているからでしょう。
それにしても、ECLあたりは3つ目以降は区別できないのでリストをキーとして使うのは難しそうです。
まとめ
リストをハッシュテーブルのキーにしたいことは個人的にはこれまで無かったのですが、リストがキーになっているのを目にしない理由もなんとなく分かった気がします。
■
HTML generated by 3bmd in LispWorks 7.1.2
macOSのLispWorks 7.1でgtkを使う
Posted 2019-09-09 20:09:30 GMT
結論: macOSのLispWorks 7.1でgtkを使うにはfinkのgtk+2を使う
macOSのLispWorks 7.1をX11 gtk+2のGUIで使おうと色々と試行錯誤していましたが、finkのgtk+2であれば使えばどうにか使えることが分かりました。
何故finkなのかというと、
- brewでは、XQuartzのgtkが入るのでNG(LispWorksが対応していない)
- macportsのx11-gtkだとLispWorksのフォント周りがおかしくなるので使えない
ので消去法でfinkなのですが、他のパッケージシステムで上手く動かす方法を探求するのも骨が折れるので、finkを導入することで手を打つのが吉でしょう。
macOS版LispWorksのgtk版自体がおまけで付いてきているような感じなのですが、果してgtk版のユーザーっているのでしょうか。
LispWorks 7.1 macOS gtk + fink のセットアップ
macOS LispWorks 7.1/gtk のインストール
macOS版LispWorksのgtk版は、デフォルトではインストールされません。インストーラにgtk版インストールのオプションがあるので有効にしてインストールしましょう。
fink
finkも最近勢いがないようですが(昔からか)、現時点で最新のmacOS 10.14.6でも使えます。
ただ、brewやportsのような手軽さでインストールすることはできないようです。
下記のリンクを参考にソースインストールを実行しますが、インストールにはJDKが必要です(JREではなく)
JDKを導入した後に、配布されているhelper scriptを実行し、質問にポチポチ答えて行けば、一時間程でインストールできるでしょう。
gtk+2の導入
fink自体のアップデートもできたら、gtk+2のインストールします。
$ /sw/bin/fink install gtk+2一発でOKですが、macOS 10.14だとバイナリ配布はしていないようなので、暫しビルドに時間が掛ります。
gtk版LispWorksの起動
$ LD_LIBRARY_PATH=/usr/lib:/sw/lib /Applications/LispWorks\ 7.1\ \(64-bit\)/lispworks-7-1-0-amd64-darwin-gtkのように起動すればOKです。
デフォルトでは起動時にGUI起動してこないので、(env:start-environment)する必要があります。
自動起動したい場合は、初期化ファイルで、
#+(and macosx gtk)
(env:start-environment)とでもしておけば良いでしょう。
まとめ
macOS版LispWorksをgtkについては、マニュアルにもlibgtk-quartzではなく、libgtk-x11を使えという注意書きがある程度で参考文献が殆どありません。
動いてしまえば、Linux等の通常のgtk版と変わりなく使えるので興味のある方は試してみてはいかがでしょうか。
■
HTML generated by 3bmd in LispWorks 7.1.2
defpackageでの#:symbolについて
Posted 2019-08-15 15:25:34 GMT
Common Lispのdefpackageというかパッケージ関係の関数全般ですが、internやexportするシンボルの名前の表記にstring designatorが使えるので、
(defpackage "FOO"
(:use "CL")
(:export "FOO" "BAR" "BAZ"))とシンボル名を文字列で書かずにシンボルで書くことも可能です。
(defpackage foo
(:use cl)
(:export foo bar baz))この場合、シンボル名が使われるので、
(defpackage #.(string 'foo)
(:use #.(string :cl))
(:export . #.(mapcar #'string '(foo #:bar baz))))のようなことになっていると考えれば良いでしょう。
このstring designatorでのシンボルの表記に各人割とこだわりがみられるので考察してみることにしました。
文字列そのまま
"FOO"、"BAR"等とそのまま書く流儀です。たまに通な人がこの方式で書いてることがあります。
メリットとされること
- 余計なシンボルがインターンされない
デメリットとされること
- リーダーの読み取りケースを変更した環境では上手い具合に馴染まない
しかし、そんな特殊な状況のことを考えてコーディングする必要ってあるんですかね?
シンボル
foo、bar等とそのまま書く流儀です。
一番すっきりしてて良さそうですが、案外少ないです
メリットとされること
- すっきりしている
- リーダーのケースの設定が変化しても良い感じに馴染む(と思われている)
デメリットとされること
defpackageしたパッケージに余計なシンボルがインターンされる
defpackageは、大抵cl-userでされることが多いですが、cl-userは作業用パッケージなので、多少汚染されても良いんじゃないかという気もしますね。
キーワードシンボル
:foo、:bar等と書く流儀です。
よく見かける流儀です。
メリットとされること
- エディタで良い感じに色付けされる
- パッケージ系関数で一貫した記述ができる
(defpackage :foo)、(make-package :foo)vs(defpackage #:foo)、(make-package '#:foo)等々 - リーダーのケースの設定が変化しても良い感じに馴染む(と思われている)
デメリットとされること
- キーワードパッケージに余計なシンボルがインターンされる
キーワードパッケージが汚染されると開発環境のキーワード補完でゴミが補完されることが多くなるので、案外cl-userが汚染されるより嫌かもしれないですね。
自由 シンボル
#:foo、#:bar等と書く流儀です。
これも割と見かける流儀です。
メリットとされること
- 余計なシンボルがインターンされない
- エディタで良い感じに色付けされる
- リーダーのケースの設定が変化しても良い感じに馴染む(と思われている)
デメリットとされること
#:がウザい
第四の方法を考えてみた
見た目がウザいのでdefpackageすれば良いでしょう。
(defpackage "FOO-META" (:use))(in-package "FOO-META")
(cl:defpackage foo
(:use cl)
(:export foo bar baz))
(cl:in-package "CL-USER")
(delete-package "FOO-META")
SBCLならこんな風に書けたりもします。
foo-meta::
(cl:defpackage foo
(:use cl)
(:export foo bar baz))まあ、でもめんどくさいですね。
まとめ
ファイルをロードする時に、暗黙のうちに*package*をcl-user、*readtable*を標準のリードテーブルであると仮定しているコードは、Quicklispの大半を占めますが、それに起因するバグも思いの外多いです(Quicklispのパッケージを1000パッケージ位ロードしてみると体験できます)
作業用パッケージ(とリードテーブル)を作成して、そこでdefpackageするのが吉なのかなあ等々考えていますが、作業用パッケージを作成するなら、余計なシンボルのインターンについても考えなくて良さそうですね。
ちなみにこの記事を書くにあたって、文字列、シンボル、キーワード、
読み取りスピード的にも普通のシンボルで書くのが有利っぽいですが、極端なことをしない限りは有意な差にはならないでしょう。
以上、特にまとまりもない記事でした。
■
HTML generated by 3bmd in LispWorks 7.0.0
Common Lispでアリティの不整合をコンパイルエラーにする
Posted 2019-08-11 20:29:48 GMT
思えば、Common Lispでアリティ(引数の個数)の不整合でエラーを喰らうのは実行時が多い気がしますが、ANSI Common Lisp規格ではコンパイル時に弾くことってできないんでしょうか。
……と思ってHyperSpecにあたってみましたが、コンパイル時にアリティの不整合を検知した場合には、エラーにしてしまうコンパイラがあっても良さそうではありました。
Common Lispは動的言語なので、実行時でも関数等の再定義が可能ですが、上記の3.2.2.3 Semantic Constraintsを眺める限りでは、どちらかといえば、コンパイラ動作の方に重きを置いているように見え、再定義されなくても良い場合を幾つか挙げています。
逆に再定義が保証されることを主として考えるとすると、少なくともnotinline宣言がついてない場合の再定義は、関数が実行時に確実に置き換わることは期待できなさそうです。
また、コンパイラ/インタプリタ動作の整合性とは別に、アリティのチェックについても記載がありますが、エラーは、実行時もしくはコンパイル時に挙げるとあります。
上記は、関数呼び出し時のエラーについての規定なので、基本的に実行時エラーだけで良さそうにも思えますが、マクロ展開等も考慮するとコンパイル時も含めないといけないのでしょうか。
ともあれ、safe callの観点からもコンパイル時に検出することも可能ではありそうです。
ちなみに、組み込み関数はsafe callの観点からすると、アリティの不整合はコンパイル時にエラーにできそうです。
処理系の実際を確認する
呼出しのアリティに不整合があった場合にコンパイルエラーになっても良さそうではあるのですが、実際の処理系の挙動を確認してみました。
このようなファイルをコンパイルして、
(defun foo (x y)
(list x y))(defun bar (x y)
(foo x))
下記のように実行してみます。
(bar 1 2)
>>> invalid number of arguments: 1処理系のメジャーなところは一通り確認してみましたが、コンパイルエラーにする処理系はECLのみのようで、他は警告は出すもののコンパイルは通し、faslをloadして実行したら当然実行時エラーです。
まあ大体Common Lispってこんな感じの動作でしたね、というところ。
むしろECLの動作のほうが意外かもしれません。
| 処理系 | compile-file |
|---|---|
| SBCL | 警告あり |
| CLISP | 警告あり |
| LispWorks | 警告あり |
| Allegro CL | 警告あり |
| Clozure CL | 警告あり |
| ECL | コンパイルエラー |
| MkCL | 警告なし |
| Clasp | 警告なし |
| CMUCL | 警告あり |
アリティの不整合をコンパイルエラーにしたい
さて、規格上はコンパイル時にアリティの不整合を検出してエラーにしても良さそうだけれど、実際のところデフォルトでそういう挙動をする処理系は、殆ど存在していないことが分かりました。
コンパイル時でもなんでもできるCommon Lispなので、工夫はあれこれできそうですが、とりあえずコンパイラマクロを試してみましょう。
とりあえずは、何もしないコンパイラマクロを定義するのみですが、展開時に引数チェックでエラーになることが期待できます。
(defun foo (x y)
(list x y))(define-compiler-macro foo (x y)
`(foo ,x ,y))
(defun bar (x y)
(foo x))
| 処理系 | compile-file |
|---|---|
| SBCL | 警告あり |
| CLISP | コンパイルエラー |
| LispWorks | コンパイルエラー |
| Allegro CL | 警告あり |
| Clozure CL | コンパイルエラー |
| ECL | コンパイルエラー |
| MkCL | 警告なし |
| Clasp | コンパイルエラー |
| CMUCL | 警告あり |
軒並エラーになると予想していましたが、コンパイルが通ってしまうものもある様子。
これは、積極的にエラーにする他ないのかもしれません。
ということで下記のように書いてみました。
(eval-when (:compile-toplevel :load-toplevel :execute)
(define-condition argument-mismatch (program-error)
((form :initarg :form :reader argument-mismatch-form)
(text :initarg :text :reader argument-mismatch-text))
(:report (lambda (c s)
(format s
"~A:~%~S~%"
(argument-mismatch-text c)
(argument-mismatch-form c))))))(defun foo (x y)
(list x y))
(define-compiler-macro foo (&whole w &rest args)
(etypecase (length args)
((eql 2) w)
((integer * 1)
(error 'argument-mismatch :text "Too Few Arguments" :form w))
((integer 3 *)
(error 'argument-mismatch :text "Too Many Arguments" :form w))))
(defun bar (x y)
(foo x))
しかし、SBCL、Allegro CLはコンパイルを通す様子。
| 処理系 | compile-file |
|---|---|
| SBCL | 警告あり |
| CLISP | コンパイルエラー |
| LispWorks | コンパイルエラー |
| Allegro CL | 警告あり |
| Clozure CL | コンパイルエラー |
| ECL | コンパイルエラー |
| MkCL | 警告なし |
| Clasp | コンパイルエラー |
| CMUCL | 警告あり |
SBCLでは、トラップしたいなら、*break-on-signals*を設定しろと警告が出るので、SBCL、Allegro CL、CMUCLはそういうポリシーなのでしょう。
; caught WARNING:
; Error during compiler-macroexpansion of (FOO X). Use *BREAK-ON-SIGNALS* to
; intercept.
;
; Too Few Arguments:
; (FOO X)まとめ
Common Lispでアリティの不整合をコンパイルエラーにする方法を探ってみましたが、
- アリティの不整合のコンディションを作成
*break-on-signals*に適宜設定- コンパイラマクロで引数チェック
の組み合わせで大抵の処理系では実現できそうです。
ちなみに、型の不整合もチェックしたいところですが、SBCLであれば、今回のコンパイラマクロの手法を応用して、deftransformあたりを使えばできなくもなさそう。
■
HTML generated by 3bmd in LispWorks 7.0.0
1960年の処理系 元祖LISP 1.5 を試してみる
Posted 2019-07-14 16:41:02 GMT
先日、LISP 1.5をお題にした、n月刊ラムダノート Vol.1, No.2(2019) / LISP 1.5の風景（川合史朗）が刊行されましたが、この稀にしか来ないLISP 1.5の波に乗らざるを得ない!!ということで、レトロコンピューティング好きの私は、十二年前に書いたLISP 1.5のエミュレータの記事をアップデートすることにしました。
(そういえばそもそも私はレトロコンピューター熱が高じてLispを始めたのでした)
上記記事ではエミュレータ関係のリンク切れ等が多くて、記事の内容を再現できない状態だったので、その辺りを修正しました。
なお、「LISP 1.5の風景」では、Gauche上にMeta*LISPというLISP 1.5の処理系を実装しつつLISPの原初を紐解いていくという内容なので、とてもお勧めです。
1960年の処理系 元祖LISP 1.5 を試してみる
先日は、PDP-1のエミュレータで、PDP-1 Lispを動かしてみましたが、やっぱり元祖である、LISP 1.5も動かしてみたいところ。
でも、さすがに、50年前のIBM7094の環境はかなり厳しいだろうと思いつつ、調べてみたら、なんとこれも簡単に動かせるようにまとめている方がいました。
約60年前の環境が再現できるというのは色々な意味で凄い。まず、データが保存されていて、今日のコンピュータで読めるってのが凄い。
lisp 1.5の環境がまとめられたファイルがあるのでダウンロードし、simhのibm7094で実行できるようにすればOKです。
手短にまとめると、準備するものとしては、
が必要です。
simhのi7094は、Debian GNU/Linuxや、Ubuntuであれば、
$ sudo apt install simhでインストール可能です。
次にLISP 1.5環境の準備ですが、
$ tar xvf lisp15.tar.gz
$ cd lisp15
$ tar xvf utils-1.1.8.tar.gz
$ cd utils && makeとし、lisptape.iniの! txt2bcd -s %1 scratch/lisp.job.mtというのを、! utils/txt2bcd -s %1 scratch/lisp.job.mtに書き換えます。
(txt2bcdをパスの通った所に設置しても良いですが)
上記のファイルを揃えて設定すれば、IBM 7094でLISP 1.5のバッチジョブを流せます。
しかし、若干面倒なので、Emacsのcompileを使って、バッチ処理のシェルスクリプトを起動させてみることにしました。
とはいえ、適当なでっち上げなので、試したい方は各自作成されると良いと思います。
自分の環境では、lisp1.5:loadというcompileをラップした関数と、シェルスクリプトの組み合わせで*compilation*バッファに結果が表示されるようにしてみました。
バッチ用シェルスクリプト(load-lisp1.5)
#!/bin/shINFILE=$1
EMUDIR=/l/lisp-1.5 # lisp 1.5セットのディレクトリを指定
TEM=cur.job
cd $EMUDIR
pwd
[ -f sys.log ] && rm sys.log
printf " TEST FOO\n\n" > $TEM
cat $INFILE >> $TEM
printf "\n\nSTOP))) ))) ))) )))\n FIN END OF LISP RUN\n" >> $TEM
i7094 lisptape.ini $TEM
cat sys.log
Emacsのcompile関数をラップしたバッチ処理を呼び出す関数
(defun lisp1.5:load ()
(interactive)
(let ((compile-command (concat "~/bin/load-lisp1.5 " (buffer-file-name))))
(compile compile-command)))
これで若干対話的にコードが書けるようになったので、適当に試してみます。
reverseとmapcarを作ってみる
define ((
(r1 (lambda (m l)
(cond ((null l) m)
((quote t) (r1 (cons (car l) m) (cdr l))))))(reverse (lambda (u) (r1 () u)))
(mapcar (lambda (lst fn)
(prog (l res)
(setq l lst)
again
(cond ((null l) (return (reverse res))))
(setq res (cons (fn (car l)) res))
(setq l (cdr l))
(go again))))
))
mapcar((1 2 3 4)
(quote (lambda (x) (plus 10 x))))
cond(((quote t) (print (quote hello))))
今日からみると色々変ったところが多いのですが、まず、トップレベルで関数に外側の括弧が付いてなかったりします。
これは、evalquoteと呼ばれるらしいですが、evalで評価するか、applyで評価するかと考えれば良い、と The Evolution of Lisp に書いてました。ちなみにInterlispでは、evalquoteの形式でコーディングできます。
それで、マニュアルを見る限りではreverseは標準で付いてくるっぽいのですが、見付からないので作ってみました。
mapcarの引数の順番が関数とリストとで逆ですが、元々は、リスト→関数の順番だったようです。これまたInterlisp系では、伝統に則ってCommon Lisp(Maclisp系)とは逆です。
結果
MTA: unit is read only
LPT: creating new fileHALT instruction, PC: 10524 (TRA 10523)
Goodbye
TAPE SYSTMP,B3
B3 IS NOW LISP SYSTMP.
TAPE SYSTAP,A4
A4 IS NOW LISP SYSTAP.
TAPE SYSPOT,A3
A3 IS NOW LISP SYSPOT.
TAPE SYSPPT,A7
A7 IS NOW LISP SYSPPT.
TEST WHATEVER
THE TIME ( 0/ 0 000.0) HAS COME, THE WALRUS SAID, TO TALK OF MANY THI
NGS ..... -LEWIS CARROLL-
EVALQUOTE OPERATOR AS OF 1 MARCH 1961. INPUT LISTS NOW BEING READ.
THE TIME ( 0/ 0 000.0) HAS COME, THE WALRUS SAID, TO TALK OF MANY THI
NGS ..... -LEWIS CARROLL-
FUNCTION EVALQUOTE HAS BEEN ENTERED, ARGUMENTS..
DEFINE
(((R1 (LAMBDA (M L) (COND ((NULL L) M) ((QUOTE T) (R1 (CONS (CAR L) M)
(CDR L)))))) (REVERSE (LAMBDA (U) (R1 NIL U))) (
MAPCAR (LAMBDA (LST FN) (PROG (L RES) (SETQ L LST) AGAIN (COND ((NULL L
) (RETURN (REVERSE RES)))) (SETQ RES (CONS (FN (
CAR L)) RES)) (SETQ L (CDR L)) (GO AGAIN))))))
END OF EVALQUOTE, VALUE IS ..
*TRUE*
FUNCTION EVALQUOTE HAS BEEN ENTERED, ARGUMENTS..
MAPCAR
((1 2 3 4) (QUOTE (LAMBDA (X) (PLUS 10 X))))
END OF EVALQUOTE, VALUE IS ..
(11 12 13 14)
FUNCTION EVALQUOTE HAS BEEN ENTERED, ARGUMENTS..
COND
(((QUOTE T) (PRINT (QUOTE HELLO))))
HELLO
END OF EVALQUOTE, VALUE IS ..
HELLO
THE TIME ( 0/ 0 000.0) HAS COME, THE WALRUS SAID, TO TALK OF MANY THI
NGS ..... -LEWIS CARROLL-
END OF EVALQUOTE OPERATOR
FIN END OF LISP RUN
なんでか知りませんが、ルイス・キャロルの文言が引用されてたりします。
若干わかりづらいですが、END OF EVALQUOTE, VALUE IS ..の後が評価結果です。なんとなく良い味を醸し出しています。
やっぱり手近に処理系があって手軽に試せるというのは良い！
PDFのマニュアルもあるので、これを見ながらLISP 1.5を探索してみるのも面白いと思います。
■
HTML generated by 3bmd in LispWorks 7.0.0
ラムダリストでの複雑なパタンマッチ
Posted 2019-06-22 18:59:06 GMT
久々に2ch(5ch)のCommon Lispスレを眺めてみたら面白そうな質問が放置されているのをみつけました。
573デフォルトの名無しさん2019/06/15(土) 16:34:52.25ID:5WxVHbel
defmacroだとdestructuring bind?が使えて
(defmacro test ((a b &optional c) d)
(print (list a b c d))
nil)
(test (1 2) 4) => (1 2 NIL 4)
みたいに書けるけど、&optionalや&keyの後に書こうとしてもSBCLだとdefmacroを評価した時点でエラーになる
&restの後ろには一応書けるっぽい
必須引数と&restの所には書けるけど、&optionalと&keyの所には書けないという認識で良いのか？
もし&optionalの所に書けるなら書き方を教えてくれ 若干質問の主語が不明瞭ですが、多分、&restや、&optionalや&keyの後に変数だけでなく再帰的な複合パタンが書けるのかという質問かなと思います。
端的にいうと規格で再帰的な複合パタンが利用できることが定義されているので、規格準拠の処理系なら書けます。
試しに書いてみると、
(defmacro foo (&optional ((a &rest b &key ((^c (c &optional (d "d" d?))) '("c") c?)) '("a") a?))
`'(,a ,b ,c ,a? ,c? ,d ,d?))(foo)
→ ("a" nil "c" nil nil "d" nil)
(foo (a ^c (c)))
→ (a (^c (c)) c t t "d" nil)
(foo (a :c (c) :allow-other-keys T))
→ (a (:c (c) :allow-other-keys t) "c" t nil "d" nil)
なお、&rest、&optionalや&keyで変数でなく複合パタンを指定した場合、省略時の値がパタンに適合していることに留意する必要があります。
■
HTML generated by 3bmd in LispWorks 7.0.0
○○がLispであるか、そうでないかの簡単な線引き
Posted 2019-06-14 18:48:50 GMT
Rubyは、Lispである、いや違う。Schemeこそ至高のLisp、いやLispじゃない等々、「○○がLispであるか、そうでないか」は自転車置場の議論ネタとしては定番です。
個人的にこの10年位、MACLISP系方言を中心に色々なLispを眺めてきましたが、LispかLispでないかの簡単な判断基準があると思いはじめました。
言語名にLispと入っていればLisp
簡単な判断基準とは、「言語名にLispと入っていればLisp」です。
馬鹿馬鹿しい程単純な理屈ですが、それなりに個人的には納得感があります。
LISP 1.5を本流とすれば、それを継承せんとする言語は、○○Lispと名乗ってきました。
そこから外れるということは、何らかの分派を表明せんがため、ということが多いように思います。
例えば、Schemeは、Planner→Conniver→(Plasma)→Scheme(→Racket)という命名の流れを踏襲したというのもありますが、全面的なレキシカルスコープの採用等、既存のLispから訣別し新しい流れを作るという点で別の名前になった意味はそれなりに大きかったでしょう(当初はそうでなくても)。
近頃だと、Schemeの流れでRacketが分派しましたが、PLT Schemeから、Racket Schemeにならずに、Racketになったのも、そういった意思表明であると思います。
Schemeと同じく、Algolとの融合を図ってレキシカルスコープの採用や、Algol構文を軸に据えたものにLISP 2がありますが、これはLISP 1.5の流れを分派というより上書きしようとしたと考えられるので、これはこれでLISPを冠した命名の流れでしょう。結局こちらのLISPの流れは成功しませんでしたが。
翻ってLISP 1.5→MACLISP(LISP 1.6)→Lisp Machine Lisp→Common Lisp & Emacs Lisp→ISLISPは、Lisp 1.5から続く資産を活用することに腐心して来たわけですし、実際コードもほぼ修正なしで動きます(Emacsはエディタに特化している所があるので若干苦しいですが)。
newLISPなどは若干変わり種ですが、古来のLispがサポートしていたもののCommon Lispで消滅したfexprをサポートするなど、Common Lispとはまた違った古来のLispを継承している所はあります。
また、ClojureがClojure Lispとしなかったのも、Lispをバックグラウンドとした新言語という意味でしょう。
まとめ
何より設計者、コミュニティがLispと名乗りたいと思って言語にLispと付けているからには、なんらかの設計思想の継承を意図しているのでしょうし、別の名前にするからには、なんらかの訣別があると思いますから、一つの線引きの基準になるでしょう。
ちなみに、類似の話として、Lisp系言語でないものについて「○○は本質的にLisp、いや違う」等の議論ネタがありますが、Lispがプログラミング言語の進化/発明においてあまりにも源流に近すぎるため、影響を排除することが難しく、極言すると同時代に誕生したFortranやAlgol以外、今時の主流のパラダイムのどんな言語にでも成立してしまうので、ほぼ意味がない話かなと思っています。
■
HTML generated by 3bmd in LispWorks 7.0.0
SPARCプロセッサのLisp向けタグ命令の謎
Posted 2019-05-27 18:01:15 GMT
Sun(今やOracle)のSPARCプロセッサにはLisp向けにタグ命令が実装されている(いた)という話を耳にされたことはないでしょうか。
具体的には、TADDCC、TSUBCC系の命令で、タグ付きポインタの演算を支援する機能です(ちなみに残念ながら現在では非推奨の機能らしい)。
それはともかく、ウェブを検索したら、当時のLucidだったEric Benson氏がこの機能についての質問に回答していたメールをみつけました。
Yes, the tagged arithmetic instructions were put in the SPARC architecture
for Lucid Common Lisp. If the low-order two bits of a Lisp object
reference are zero, it is a 30-bit immediate fixnum. If some of those
bits are non-zero, it may be a pointer to a floating point number or a
bignum (arbitrary-precision integer). Generic arithmetic is generally
optimized for the fixnum case, since the overwhelming majority of
arithmetic is performed on small integers. On many machines + is compiled
inline as
Test low order two bits of first operand.
If nonzero, use general case. (Operand could be a float or bignum.)
Test low order two bits of second operand.
If nonzero, use general case. (Operand could be a float or bignum.)
Add two operands.
If overflow, use general case. (Result is a bignum).
On the SPARC this is done as one instruction (TADDCC) followed by a
conditional branch rarely taken.
メールによると、SPARCのこの命令は、Lucid CLのために入ったらしいのですが、Lucidは、SunにCommon Lisp処理系をOEM提供しており、Sun Common Lispとして販売されていたりで、LucidとSunはかなり密接な関係でした。
時代的にも当時は第二次AIブーム末期で、エキスパートシステムやCAD等、高価なSymbolics等の専用マシン上で稼動していたLispベースのアプリケーションを比較的廉価なワークステーション上でも動したいというニーズも高かった頃です。
Lucid Common Lispではどう活用しているのか
Lucid CLのために命令が導入されたのはよしとして、実際にどんな感じで活用されていたのか確認してみましょう。
とりあえず、2引数のfixnumの足し算をコンパイルしてdisassembleしてみます。
> (proclaim '(optimize (compilation-speed 0) (speed 3) (safety 3)))
t
> (disassemble (compile nil '(lambda (x y) (declare (fixnum x y)) (the fixnum (+ x y)))))
;;; You are using the compiler in PRODUCTION mode (compilation-speed = 0)
;;; If you want shorter compile time at the expense of reduced optimization,
;;; you should use the development mode of the compiler, which can be obtained
;;; by evaluating (proclaim '(optimize (compilation-speed 3)))
;;; Generation of full safety checking code is enabled (safety = 3)
;;; Optimization of tail calls is enabled (speed = 3)
cmp %u0, 8
tne 16
taddcctv %in0, %in1, %loc0
move %loc0, %in0
jmpl %0, %ra + 8
restore %0, 4, %u0
niltaddcctv(Tagged Add, modify icc and Trap on Overflow)というのがお目当ての命令ですが、探してみてもどうも専らtaddccではなく、tv付きが使われるようです。
safety 0にしてみると、
> (proclaim '(optimize (compilation-speed 0) (speed 3) (safety 0)))
t
> (disassemble (compile nil '(lambda (x y) (declare (fixnum x y)) (the fixnum (+ x y)))))
;;; You are using the compiler in PRODUCTION mode (compilation-speed = 0)
;;; If you want shorter compile time at the expense of reduced optimization,
;;; you should use the development mode of the compiler, which can be obtained
;;; by evaluating (proclaim '(optimize (compilation-speed 3)))
;;; Generation of runtime error checking code is disabled (safety = 0)
;;; Optimization of tail calls is enabled (speed = 3)
taddcctv %in0, %in1, %loc0
move %loc0, %in0
jmpl %0, %ra + 8
restore %0, 4, %u0
nilとなり、アリティのチェックが省略されるようです。
しかし、CMUCLでも活用されていた
さすがLucid CL用に用意されただけあるなと思いましたが、CMUCL 17fのdisassemble結果を眺めたりしていた所、CMUCLでも活用されているのをみつけてしまいました。
CMU Common Lisp 17f, running on sun4
Send bug reports and questions to cmucl-bugs@cs.cmu.edu.
Loaded subsystems:
Python 1.0, target SPARCstation/Sun 4
CLOS based on PCL version: September 16 92 PCL (f)
*
* (proclaim '(optimize (compilation-speed 0) (speed 3) (safety 3)))
EXTENSIONS::%UNDEFINED%
* (disassemble (compile nil '(lambda (x y) (declare (fixnum x y)) (the fixnum (+ x y)))))
Compiling LAMBDA (X Y):
Compiling Top-Level Form: 070BFCA8: .ENTRY "LAMBDA (X Y)"(x y) ; (FUNCTION (FIXNUM FIXNUM) FIXNUM)
C0: ADD -18, %CODE
C4: ADD %CFP, 32, %CSP
C8: CMP %NARGS, 8 ; %NARGS = #:G1
CC: BNE L0
D0: NOP
D4: TADDCCTV %ZERO, %A0 ; %A0 = #:G2
D8: TADDCCTV %ZERO, %A1 ; %A1 = #:G3
DC: TADDCCTV %A1, %A0 ; No-arg-parsing entry point
E0: MOVE %CFP, %CSP
E4: MOVE %OCFP, %CFP
E8: J %LRA+5
EC: MOVE %LRA, %CODE
F0: L0: UNIMP 10 ; Error trap
F4: BYTE #x04
F5: BYTE #x19 ; INVALID-ARGUMENT-COUNT-ERROR
F6: BYTE #xFE, #xEB, #x01 ; NARGS
F9: .ALIGN 4
* (funcall (compile nil '(lambda (x y) (declare (fixnum x y)) (the fixnum (+ x y)))) most-positive-fixnum most-positive-fixnum)
Compiling LAMBDA (X Y):
Compiling Top-Level Form:
1073741822
しかし、Lucid CLと違うのは、safety 0にすると普通のaddになってしまう所。
(+ most-positive-fixnum most-positive-fixnum)が-2になってしまっています。
* (proclaim '(optimize (compilation-speed 0) (speed 3) (safety 0)))
EXTENSIONS::%UNDEFINED%
* (disassemble (compile nil '(lambda (x y) (declare (fixnum x y)) (the fixnum (+ x y)))))
Compiling LAMBDA (X Y):
Compiling Top-Level Form: 071A11F8: .ENTRY "LAMBDA (X Y)"(x y) ; (FUNCTION (FIXNUM FIXNUM) FIXNUM)
210: ADD -18, %CODE
214: ADD %CFP, 32, %CSP
218: ADD %A1, %A0 ; No-arg-parsing entry point
21C: MOVE %CFP, %CSP
220: MOVE %OCFP, %CFP
224: J %LRA+5
228: MOVE %LRA, %CODE
22C: UNIMP 0
* (funcall (compile nil '(lambda (x y) (declare (fixnum x y)) (the fixnum (+ x y)))) most-positive-fixnum most-positive-fixnum)
Compiling LAMBDA (X Y):
Compiling Top-Level Form:
-2
Lucid CLでは、safety 0でもtaddcctvはそのままでbignumに切り替えます。
> (proclaim '(optimize (compilation-speed 0) (speed 3) (safety 0)))
t
> (disassemble (compile nil '(lambda (x y) (declare (fixnum x y)) (the fixnum (+ x y)))))
;;; You are using the compiler in PRODUCTION mode (compilation-speed = 0)
;;; If you want shorter compile time at the expense of reduced optimization,
;;; you should use the development mode of the compiler, which can be obtained
;;; by evaluating (proclaim '(optimize (compilation-speed 3)))
;;; Generation of runtime error checking code is disabled (safety = 0)
;;; Optimization of tail calls is enabled (speed = 3)
taddcctv %in0, %in1, %loc0
move %loc0, %in0
jmpl %0, %ra + 8
restore %0, 4, %u0
nil
> (funcall (compile nil '(lambda (x y) (declare (fixnum x y)) (the fixnum (+ x y)))) most-positive-fixnum most-positive-fixnum)
1073741822この辺りの違いは、Lucid CLの方がtaddccを活用しているといえるのか、それとも処理系のポリシーの違いなのか。
まとめ
まとめらしいまとめはないですが、Common Lispの処理系のためにCPUに命令が追加されたと思うとSPARCが素晴らしいCPUに見えてきました。
(SPARCプロセッサも大分勢いが無くなってきましたが……)
■
HTML generated by 3bmd in LispWorks 7.0.0
Lucid Common Lisp環境構築 【2019年版】
Posted 2019-05-03 22:17:38 GMT
以前にLucid Common Lispが動く環境を構築していたのですが、久し振りに起動してみようと思ったところ全く手順を忘れていたのでメモしておきたいと思います。
構築する環境
- SunOS 4.1.4/SPARC
- Lucid Common Lisp SunOS/SPARC版
用意するもの
- qemu 2.12.1
- Lucid CLのバイナリ
- Lucid Emacs
Lucid CLとLucid EmacsのSunOS/SPARC版は両方ともArchive Team: Various Lucid Packagesに含まれているので探してみましょう。
qemuの準備
qemu 3からvlanオプションが廃止されたようで、netdevオプションを使うことになりましたが、qemu-system-sparcで上手く指定できなかったので、しょうがなく2系統を使うことにしました。
ソースからは下記のようにオプションを指定してビルド可能です。
$ ./configure --target-list=sparc-softmmu
$ makeQEMU/SunOS 4.1.4のセットアップについては下記を参考にしました。
Linux tapの設定
sudo modprobe tun
sudo tunctl -t sunostap0 -u $USER
sudo ifconfig sunostap0 10.0.2.2 netmask 255.255.255.0のようにしてtapを作成しておきます。
sunostap0というのは好きな名前でOKです。
qemuの起動
qemu-system-sparc -bios ss20_v2.25_rom -M SS-20 -nographic -boot d -hda sunos414.img -m 512 -smp 2,cores=2 -cpu "TI SuperSparc 60" -net nic,vlan=0 -net tap,vlan=0,ifname=sunostap0,script=no,downscript=noのようなオプションで起動します。
SunOS 4.1.4の起動
起動の手順がめんどうなので、expectでスクリプトを作成し、それで起動します。
私の手元では、何故かシングルユーザーで起動してからマルチユーザーにしないとおかしなことになりますが、とりあえずスルーすることにします。
#!/bin/shcd /vm/sunos-4.1.4
expect -c "
set timeout -1
spawn /vm/sunos-4.1.4/boot-sun4.sh
expect \"ok \"
send \"setenv sbus-probe-list f\r\"
expect \"ok \"
send \"reset\r\"
expect \"ok \"
send \"boot disk0 -s\r\"
expect \"# \"
send \"ifconfig le0 10.0.2.15\r\"
send \"route add default 10.0.2.2 1\r\"
send \"\exit\r\"
expect \"Program terminated\"
send \"power-off\"
"
rshの設定
sshは存在しない時代ですが、rshは存在します。
telnetより便利なので、rshの設定をしておきます。
これまでの設定の場合、
$ rsh 10.0.2.15で接続可能です。
X環境の設定
Lucid CLは、ターミナルでも使えますが、Lucid CL 4.0あたりだとLucid Emacsと組み合わせて使うことが想定されているようで、このLucid EmacsがX環境でしか起動しないので、Xの環境も構築することにします。
SunOSのウィンドウをリモートで表示したいのですが、昔と違ってセキュリティ周りが色々厳しくなっているので、色々と面倒なので、個別のVNCサーバを起動して、そこで表示させることにします。
#!/bin/shvncserver -geometry 1600x900 :41 -listen tcp
export DISPLAY=$(hostname):41.0
xhost +
openbox
上記では、41番ディスプレイを指定した例ですが、-listen tcpというのがミソで、明示的にこの指定がないとローカルからしか接続できません(リモートホストのアプリがディスプレイを開けない)
ILISPの設定
(require 'ilisp)(setq cmulisp-program "/usr/local/bin/lisp")
(setq lucid-program "~/bin/xlt-ansi")
この設定の場合、M-x run-ilispすると、Lucid CLかCMUCLかを選択して起動できます。
xltの起動
(xlt:xlt)で起動します。
XLTは、クラスブラウザ、プロファイラ、Apropos、オブジェクトのクリップボード(xlt:*0*に代入される)、等々の機能があり、Emacsの開発環境を補助するようなGUIのユーティリティ集というところです。
Allegro CLだと、Allegro Composerという類似のツール集があります。
基本的にSymbolicsの使い勝手をUnix+Emacs上で再現するというのが、1990年代初頭の定番だった様子。
関連記事
■
HTML generated by 3bmd in LispWorks 7.0.0
Common Lispでクラスメソッド
Posted 2019-04-21 09:32:06 GMT
Common Lispにおけるクラスメソッド
SmalltalkやRubyのようにクラスメソッドがある言語のコードをCommon Lispに移植したり、参考にして書いたりしているときに、クラスメソッドに相当する挙動が欲しくなったりするのですが、メタクラスの構成が違うので、そのまま書き写しただけでは、思ったような挙動にはなりません。
Common Lispでそのまま書き下すと大抵以下のようになりますが、
(defclass foo () ())(defclass bar (foo) ())
(defmethod zot ((c (eql (find-class 'foo))))
"zot")
(zot (find-class 'foo))
→ "zot"
(zot (find-class 'bar))
!! No applicable methods
barクラスに対してはfooのクラスメソッドを起動しません。
Smalltalk/Rubyは、クラスごとにメタクラスが存在し、クラスの継承関係とメタクラスの継承関係は同様の構成になりますが、Common Lispでは、クラスメタオブジェクトのクラスをメタクラスと呼んでいるだけなので、同じメタクラスのクラスメタオブジェクト間に継承関係はありません。
Smalltalk/Ruby風のクラスメソッド的なものをどう実現するか
Common LispでもSmalltalk/Rubyのようにクラス生成時に継承関係と同じメタクラスを作ってしまうという方法が一つの解決策です。
以下のリンクは、shiroさんが以前にPython風のクラスメソッドが欲しいという質問に回答した例です
class-prototypeを使う
クラスメソッドは、
- クラスの継承関係を利用する
- インスタンスを生成しなくても起動できる
というのがメリットですが、よくよく考えてみれば、クラスの継承関係を利用できて、インスタンスを生成しなくても起動できさえすれば問題は解決とすると、クラス定義ごとに存在するclass-prototypeを利用してディスパッチすれば良さそうです。
クラスメソッドのnewのようなものは以下のように書けるでしょう。
(defmethod new ((o foo))
(make-instance (class-of (class-prototype (class-of o)))))(defmethod new ((name symbol))
(new (class-prototype (find-class name))))
(defclass foo () ())(new 'foo)
→ #<foo 40200C8273>
(new (class-prototype (find-class 'foo)))
→ #<foo 40200C87EB>
上記例は大分持って回った感じですが、とりあえずclass-prototypeを経由すればOKです。
もうすこしクラスメソッド的な例を考える
もうすこしクラスメソッド的な例としてインスタンスの集合を扱う例を考えてみます。
(defclass instance-recording-class (standard-class)
((instance-record :initform '()
:accessor class-instance-record)))(defmethod validate-superclass ((c instance-recording-class) (sc standard-class))
T)
(defmethod make-instance :around ((class instance-recording-class) &rest initargs)
(let ((inst (call-next-method)))
(push inst (class-instance-record class))
inst))
(defclass A ()
((x :initarg x))
(:metaclass instance-recording-class))(defclass B (A)
()
(:metaclass instance-recording-class))
(dotimes (i 1000)
(make-instance 'B 'x (random 100)))
(length (class-instance-record (find-class 'B)))
→ 1000
(defun prototypep (instance)
(eq instance (class-prototype (class-of instance))))(deftype prototype ()
`(satisfies prototypep))
(defmethod all ((x A))
(check-type x prototype)
(class-instance-record (class-of x)))
(defmethod all ((x symbol))
(all (class-prototype (find-class x))))
(defmethod select ((x A) (selector function))
(check-type x prototype)
(loop :for i :in (class-instance-record (class-of x))
:when (funcall selector i) :collect i))
(defmethod select ((x symbol) (selector function))
(select (class-prototype (find-class x)) selector))
(length (all 'B))
→ 1000
(length (select 'B (lambda (x) (evenp (slot-value x 'x)))))
→ 490
(loop :repeat 10
:for x :in (select 'B (lambda (x) (evenp (slot-value x 'x))))
:collect (slot-value x 'x))
→ (66 92 38 60 74 80 10 20 76 86)
(all (make-instance 'A))
!! The value #<a 4020099793> is not of type prototype.
生成されたインスタンスとプロトタイプが混ざるという潜在的な問題はあるので、上記では、prototype型を定義して弾いてみることにしました。
プロトタイプを利用しているので、集合に対する演算の度にインスタンスが生成されて母数が変化してしまうような問題もないことが分かるかと思います。
まとめ
Smalltalkでは、クラス生成時にクラスの継承関係保持したメタクラスが生成されますが、Common Lisp(MOP)では、クラス生成時に(当然ながら)継承関係を保持したプロトタイプが生成されます。
この関係を上手く利用すれば、Common Lispでのクラスメソッド問題も解決できそうな気がしていますがどうでしょう。
■
HTML generated by 3bmd in LispWorks 7.0.0
MOP vs マクロ (8): メソッド定義でselfを使って楽をしたい
Posted 2019-03-31 19:03:15 GMT
今回のMOP vs マクロは、defmethodのカスタマイズネタで比較してみたいと思います。
メソッド定義でselfを使いたい
Common Lispはマルチメソッドなので、シングルメソッドの言語のようなselfはありませんが、なんとなく気分で、
(defmethod foo ((self bar) x y) ...)のように書いたりすることもあります。
このようにディスパッチは先頭一つでしか行なわない場合に、defmethod内部でselfも使えたら便利なんじゃないか、ということで、そのようなカスタマイズをしてみたいと思います。
マクロ篇
まずはマクロでの実現。とりあえず、安直に下記のように書いてみました。
(ql:quickload :closer-mop)(defpackage "9ef5d5fa-900d-5269-8012-a9c0d39a1860"
(:use :c2cl))
(in-package "9ef5d5fa-900d-5269-8012-a9c0d39a1860")
(defmacro defgeneric-self (name (&rest args) &body body)
(destructuring-bind (class name)
name
`(defgeneric ,name (,class ,@args) ,@body)))
(defmacro defmethod-self (name (&rest args) &body body)
(destructuring-bind (class name)
name
`(defmethod ,name ((self ,class) ,@args)
(with-slots ,(mapcar #'slot-definition-name (class-slots (find-class class))) self
,@body))))
selfとなるインスタンスのクラスをどう指定するかですが、Flavors風に(defmethod (class name) ()...)としてみています。
また、defmethod内部では、selfとインスタンスのスロットがスロット名の変数でアクセスできるようにしたいので、with-slotsでボディを囲んでいます。
なお、マクロで実現といってもスロット名を取得したりする必要があるので、MOPを使う必要はあります。
試してみる
(defconstant <foo>
(defclass foo ()
((a :initform nil)
(b :initform nil)
(c :initform nil))))(finalize-inheritance <foo>)
(defmethod-self (foo frob) (a b c)
(list self a b c))
(frob (make-instance <foo>) 0 1 2)
→ (#<foo 4020290013> nil nil nil)
クラスのスロット名とメソッドの引数名が被った時にはクラスのスロットに遮蔽されてしまいますが、Flavorsもこんな動作なので良しとします。
MOP篇
(ql:quickload :closer-mop)(defpackage "a16a6b7f-083d-52aa-a466-d22b941a23c8"
(:use :c2cl))
(in-package "a16a6b7f-083d-52aa-a466-d22b941a23c8")
(defclass self-generic-function (standard-generic-function)
()
(:metaclass funcallable-standard-class))
(defmethod make-method-lambda
((gf self-generic-function) (method standard-method) λxp env)
(destructuring-bind (lambda (self &rest args) &body body)
λxp
(call-next-method gf
method
(let ((slot-names (mapcar #'slot-definition-name (class-slots (find-class self)))))
`(,lambda (,self ,@args)
(let ((self ,self))
(declare (ignorable self))
(with-slots ,slot-names self
(declare (ignorable ,@slot-names))
,@body))))
env)))
メソッドのボディのコードをカスタマイズするには、make-method-lambdaが返す、lambda式を編集することになるようです。
ボディのコードをいじる用途には、ちょっと面倒なインターフェイスという印象。
試してみる
(defconstant <foo>
(defclass foo ()
((a :initform nil)
(b :initform nil)
(c :initform nil))))(defgeneric frob (foo a b c)
(:generic-function-class self-generic-function))
(defmethod frob (foo a b c)
(list self a b c))
(frob (make-instance <foo>) 0 1 2)
→ (#<foo 402028F48B> nil nil nil)
やっていることはマクロ版と殆ど変わりありません。
第一引数のシンボルをクラス名にする必要があるという所が危ういですが、まあ良しとします。
マクロでお化粧することも可能ですが、そうするとMOPで書く意味があまりないなという気分になってしまいます。
(defmacro defgeneric-self (name (&rest args) &body body)
(destructuring-bind (class name)
name
`(defgeneric ,name (,class ,@args) ,@body
(:generic-function-class self-generic-function))))(defmacro defmethod-self (name (&rest args) &body body)
(destructuring-bind (class name)
name
`(defmethod ,name (,class ,@args) ,@body)))
(defgeneric-self (foo bar) ())(defmethod-self (foo bar) ()
(list self a b c))
まとめ
クラスの情報を得るのにMOPのイントロスペクション機能を使う必要はありますが、得た情報からコード生成をすることに関しては、マクロの方が単純で明解ですね。
■
HTML generated by 3bmd in LispWorks 7.0.0
MOP vs マクロ (7): Gaucheのpropagatedスロット再現
Posted 2019-03-04 22:54:25 GMT
今回のMOP vs マクロは、Gaucheのpropagatedスロット再現で比較してみたいと思います。
propagatedスロットについてはブログでの紹介記事に詳しいですが、合成した部品のスロットにアクセスする際に子コンポーネントのスロットが親のスロットとしてアクセスできる、というものです。
マクロ篇
そもそもGaucheのpropagatedスロットが想定している利用法からするとマクロで実現してみようというのは色々と無理があるのですが、色々捨てて挙動だけ同じにしました。
(defpackage "6401746F-BD45-5DB6-BD1D-B29A1EFA0494"
(:use :c2cl))(cl:in-package "6401746F-BD45-5DB6-BD1D-B29A1EFA0494")
(defmacro with-slots/propagation ((&rest specs) obj &body body)
(etypecase specs
(null
`(with-slots () ,obj
,@body))
((cons atom null)
(let ((_obj (gensym "_obj")))
`(let ((,_obj ,obj))
(with-slots (,(car specs)) ,_obj
(with-slots/propagation (,@(cdr specs)) ,_obj
,@body)))))
(cons
(destructuring-bind (target-slot slots) (car specs)
(let ((_obj (gensym "_obj")))
`(let ((,_obj ,obj))
(with-slots (,@slots) (slot-value ,_obj ',target-slot)
(with-slots/propagation (,@(cdr specs)) ,_obj
,@body))))))))
(defclass rect ()
((width :initform 0 :initarg :width)
(height :initform 0 :initarg :height)))(defclass viewport ()
((dimension :initform (make-instance 'rect))
(width :initarg :width)
(height :initarg :height)))
(let ((obj (make-instance 'viewport)))
(with-slots/propagation ((dimension (width height))) obj
(setq width 42 height 42))
(describe (slot-value obj 'dimension)))
;>> #<rect 40200074CB> is a rect
;>> width 42
;>> height 42
当初の目的からは外れていますが、局所的にオブジェクトを合成したりするのには使えなくもないかも。
(暗黙の規約が多過ぎますが)
MOP篇
マクロでの実現はやりたいことの中身が全部外側に露出してしまっていますが、これをMOPで内側に収めます。
Gaucheでは、compute-get-n-setという便利なメソッドがあるので圧縮して記述できていますが、AMOP作法だと長くなります。
さらに、standard-instance-accessの利用でアクセス速度向上を狙ってみたので、より長くなりました。
(ql:quickload '(closer-mop))(defpackage "5ADAD164-D620-594D-A9C7-8E192966CA64"
(:use :c2cl))
(cl:in-package "5ADAD164-D620-594D-A9C7-8E192966CA64")
(defclass propagated-slot-class (standard-class)
())
(defmethod validate-superclass ((c propagated-slot-class) (sc standard-class))
T)
(defclass propagated-slot-definition (standard-slot-definition)
((propagate-to :initform nil
:initarg :propagate
:initarg :propagate-to
:accessor propagated-slot-definition-propagate-to)
(propagate-to# :initform nil
:accessor propagated-slot-definition-propagate-to#)))
(defmethod slot-definition-allocation ((slotd propagated-slot-definition))
:propagated)
(defmethod (setf slot-definition-allocation) (allocation (slotd propagated-slot-definition))
(unless (eq allocation :propagated)
(error "Cannot change the allocation of a ~S"
slotd))
allocation)
(defconstant <propagated-direct-slot-definition>
(defclass propagated-direct-slot-definition (standard-direct-slot-definition propagated-slot-definition)
()))
(defmethod direct-slot-definition-class ((class propagated-slot-class) &rest initargs)
(if (eq (getf initargs :allocation) :propagated)
<propagated-direct-slot-definition>
(call-next-method)))
(defconstant <propagated-effective-slot-definition>
(defclass propagated-effective-slot-definition (standard-effective-slot-definition propagated-slot-definition)
()))
(defmethod effective-slot-definition-class ((class propagated-slot-class) &rest initargs)
(if (eq :propagated (getf initargs :allocation))
<propagated-effective-slot-definition>
(call-next-method)))
(defmethod compute-effective-slot-definition ((class propagated-slot-class) name direct-slot-definitions)
(declare (ignore name))
(let ((effective-slotd (call-next-method)))
(dolist (slotd direct-slot-definitions)
(when (typep slotd 'propagated-slot-definition)
(setf (propagated-slot-definition-propagate-to effective-slotd)
(propagated-slot-definition-propagate-to slotd))
(return)))
effective-slotd))
(defmethod finalize-inheritance :after ((class propagated-slot-class))
(let ((slotds (class-slots class)))
(dolist (sd slotds)
(when (typep sd 'propagated-slot-definition)
(setf (propagated-slot-definition-propagate-to# sd)
(slot-definition-location (find (propagated-slot-definition-propagate-to sd)
slotds
:key #'slot-definition-name)))))))
#-lispworks
(defmacro slot-foo (fctn class object slotd)
(declare (ignore class))
`(,fctn
(standard-instance-access ,object
(propagated-slot-definition-propagate-to# slotd))
(slot-definition-name ,slotd)))
#-lispworks
(progn
(defmethod slot-value-using-class
((class propagated-slot-class) object (slotd propagated-slot-definition))
(slot-foo slot-value class object slotd))
(defmethod (setf slot-value-using-class)
(value (class propagated-slot-class) object (slotd propagated-slot-definition))
(setf (slot-foo slot-value class object slotd)
value))
(defmethod slot-boundp-using-class
((class propagated-slot-class) object (slotd propagated-slot-definition))
(slot-foo slot-boundp class object slotd))
(defmethod slot-makunbound-using-class
((class propagated-slot-class) object (slotd propagated-slot-definition))
(slot-foo slot-makunbound class object slotd))
(defmethod slot-exists-p-using-class
((class propagated-slot-class) object (slotd propagated-slot-definition))
(slot-foo slot-exists-p class object slotd))
);;; おまけ:LispWorksの場合
#+lispworks
(defmacro slot-foo (fctn class object slot-name)
`(let ((slotd (find ,slot-name (class-slots ,class) :key #'slot-definition-name)))
(if (typep slotd 'propagated-slot-definition)
(,fctn
(standard-instance-access ,object
(propagated-slot-definition-propagate-to# slotd))
,slot-name)
(call-next-method))))
#+lispworks
(progn
(defmethod slot-value-using-class
((class propagated-slot-class) object slot-name)
(slot-foo slot-value class object slot-name))
(defmethod (setf slot-value-using-class)
(value (class propagated-slot-class) object slot-name)
(let ((slotd (find slot-name (class-slots class) :key #'slot-definition-name)))
(if (typep slotd 'propagated-slot-definition)
(setf (slot-value (standard-instance-access object
(propagated-slot-definition-propagate-to# slotd))
slot-name)
value)
(call-next-method))))
(defmethod slot-boundp-using-class
((class propagated-slot-class) object slot-name)
(slot-foo slot-boundp class object slot-name))
(defmethod slot-makunbound-using-class
((class propagated-slot-class) object slot-name)
(slot-foo slot-makunbound class object slot-name))
(defmethod slot-exists-p-using-class
((class propagated-slot-class) object slot-name)
(slot-foo slot-exists-p class object slot-name)))
試してみる
(defclass rect ()
((width :initform 0 :initarg :width)
(height :initform 0 :initarg :height)))(defclass viewport ()
((dimension :initform (make-instance <rect>))
(width :allocation :propagated :propagate dimension
:initarg :width)
(height :allocation :propagated :propagate dimension
:initarg :height))
(:metaclass propagated-slot-class))
(let ((vp (make-instance 'viewport' :width 42 :height 42)))
(describe vp)
(describe (slot-value vp 'dimension)))
;>> #<viewport 4020098D8B> is a viewport
;>> dimension #<rect 4020098DBB>
;>> width 42
;>> height 42
;>> #<rect 4020098DBB> is a rect
;>> width 42
;>> height 42
速度比較
LispWorksだと素のインスタンス生成/スロットアクセスに比較して大体1.5倍程度の遅さで済んでいるようです。
(defclass c000001 ()
((x :initform 0)
(y :initform 0)
(z :initform 0)))(let ((times 1000000)
(ans 0))
(time (dotimes (i times)
(slot-value (make-instance 'viewport) 'width)))
(time (dotimes (i times)
(slot-value (make-instance 'c000001) 'x)))
ans)
Evaluation took:
0.686 seconds of real time
0.680000 seconds of total run time (0.680000 user, 0.000000 system)
99.13% CPU
2,258,481,555 processor cycles
95,986,800 bytes consed
Evaluation took:
0.413 seconds of real time
0.410000 seconds of total run time (0.410000 user, 0.000000 system)
99.27% CPU
1,360,213,671 processor cycles
64,028,672 bytes consed
まとめ
今回は、マクロ向きのお題ではありませんでしたが、動作の内容はMOPの内側か外側かの違いだけではありました。
MOPで組む前に、マクロで適当に書いてみて動作を考える、というもの場合によっては、悪くないかもしれません。
■
HTML generated by 3bmd in LispWorks 7.0.0
DEFUN 50歳おめでとう
Posted 2019-02-28 15:00:00 GMT
Common Lispでお馴染のdefun。
ClojureだとdefnでCommon Lispと同じくデ(ィ)ファンと読むらしいですが、Jon L White氏によってMACLISPに導入されたのが、50年前の今日、1969-03-01でした。
3/1/69 JONL THE CURRENT VERSION OF LISP, "LISP 102", HAS
THE FOLLOWING AS-YET UNDOCUMENTED FEATURES:
1)"DEFUN" IS AN FSUBR USED TO DEFINE
FUNCTIONS. EXAMPLES ARE
(DEFUN ONECONS (X) (CONS 1 X))
WHICH IS EQUIVALENT TO
(DEFPROP ONECONS
(LAMBDA (X) (CONS 1 X)
EXPR)
AND (DEFUN SMASH FEXPR (L) (RPLACD L NIL))
IS EQUIVALENT TO
(DEFPROP SMASH
(LAMBDA (L) (RPLACD L NIL))
FEXPR)
THE NOVEL FEATURE OF "DEFUN" IS THAT ONE NEED
NOT BE SO CONCERNED WITH BALANCING
PARENTHESES AT THE VERY END OF THE FUNCTION
DEFINITION, SINCE THE TYPE FLAG MAY BE
OMITTED IF IT IS "EXPR", AND APPEARS NEAR
THE FRONT OF THE "DEFUN" LIST IF IT IS SOME
OTHER. ALSO, THE "LAMBDA" NEED NOT BE
DIRECTLY INSERTED.
defun誕生以前は、defpropでシンボルのexprや、fexpr、macroプロパティに関数定義をセットしていたようです。
ちなみに、defunとは別の流儀にdeがありますが、こちらは、MIT LISP 1.6(後のPDP-6 LISP/MACLISP)がスタンフォード大学に導入された後にdefunと同様の目的で考案されたものです。
defunは当初、通常の関数(expr)だけでなくマクロ等の各種関数を定義できました。
exprの定義は、defun foo (x)でfexprの定義はdefun foo fexpr (x)とし、同様にマクロは、defun foo macro (x)で定義可能です。
これらは、Common Lispの祖先のLisp Machine Lispで、各種専用構文に分岐します。
上述のStanford LISP 1.6の場合は、exprは、de、fexprは、df、マクロは、dmと二文字の専用構文となっていますが、defunの方は、先祖のdefpropの影響を引き摺ったのかもしれません。
50年も生き延びたdefun構文ですが、100歳まで生き残るでしょうか。
■
HTML generated by 3bmd in LispWorks 7.0.0
Common Lispにおいて(lambda (x) ...)は関数の名前なのかどうか
Posted 2019-02-23 18:23:58 GMT
たまに、Common Lispの仕様では(lambda (x) ...)を関数の名前として定められている、というような話がされることがあります。
しかし、結論としては、ANSI Common Lisp規格では関数の名前ではありません。
今回は、その辺りを調べてまとめてみました。
ANSI Common Lisp規格での関数の名前
(lambda (x) ...)は、ANSI Common Lisp規格では、lambda expressionと呼びますが、その説明を読むとfunction nameが位置する場所にあるlambdaから始まるリスト、のように持って回った説明がされています。
とりあえず、lambda expressionの方は置いておいて、function nameの方を確認すると、シンボルもしくは、(setf シンボル)というリストがfunction nameとなっています。
Common Lisp(1984)での関数の名前
しかし、CLtL1でお馴染のCommon Lisp(1984)での記述を確認してみると、ANSI規格に比べると記述は曖昧で、関数名としてのシンボルと、ラムダ式を同一視しているような記述ではありました。
CLtL1: 5.2 Functions
There are two ways to indicate a function to be used in a function call
form. One is to use a symbol that names the function. This use of
symbols to name functions is completely independent of their use in
naming special and lexical variables. The other way is to use a
lambda-expression, which is a list whose first element is the symbol
lambda. A lambda-expression is not a form; it cannot be
meaningfully evaluated. Lambda-expressions and symbols, when used in
programs as names of functions, can appear only as the first element of a
function-call form, or as the second element of the function
special form. Note that symbols and lambda-expressions are treated as
names of functions in these two contexts. This should be
distinguished from the treatment of symbols and lambda-expressions as
function objects, that is,
objects that satisfy the predicate functionp,
as when giving such an object to apply or funcall to be
invoked.
これはANSI規格へ向けての中間報告であるCLtL2(1990)でも同様です。
この記述をうけてか、竹内郁雄先生の1980年代の著作である「初めての人のためのLisp」11章の脚注にもこんな記述があります。
Common Lispではこのリストを，関数実体を表わす一種の"名前"と呼んでいます。
ちなみに、増補改訂版(2010)では、脚注から本文の先生の台詞に昇格して
Common Lispではこのリストを，関数実体を表わす一種の"名前"であるとしておる
となっています。 まあ、「一種の“名前”」となっているので、どうとでも解釈できそうです。
Common Lisp(1984)からANSI Common Lisp(1994)までに何が変化したのか
ANSI Common Lisp(1994)は、オブジェクト指向システムやコンディションシステムの追加等が目立つところですが、それまで曖昧だった概念や記述が大分整理されました。
function nameとlambda expressionが分離した背景については、Issue FUNCTION-NAME Writeupに記録があります。
まず、function nameについての整理があり、function、fdefinition、defun、fboundp、fmakunbound等々、関数の名前を取るものの整理がされ、(setf ...)が新しく関数名とされました。
これを推進して、lambda expressionを関数名として扱うかの提案が、FUNCTION-NAME:LARGEの12番にあります。
12. Declare that any lamba expression (i.e., a list whose car is LAMBDA and
whose cdr is a well-formed lambda argument list and body) is a function
name. lambda expressionが名前となれば、
(fmakunbound (lambda () ...))のようなケースも考えていくことになると思うのですが、しかし、結局、lambda expressionが無名関数を表す慣習からすると、それをもって名前とするのは矛盾としています。
名は体を表すといいますが、lambda expressionは体が体を表してしまっているというところでしょうか。
Lambda expressions are often thought to denote "anonymous" functions, so
it may seem paradoxical to treat them as names. The paradox is only
apparent, since the expression itself has the properties of a Lisp
function name: It is (typically) a cons tree which can be read, printed,
and stored in source files, and it denotes a well-defined Lisp function.ここからどのような投票が行なわれ、どう決定されたかの資料はみあたらないのですが、12番の提案は採用されなかったのは確かで、function nameにlambda expressionは含まれることは無かった、ということでしょう。
まとめ
年配の方々はもうしょうがないと思いますが、若者はANSI Common Lisp規格を読みましょう。
また、CLtL2はCLtL1からANSI Common Lispまでの中間報告であり規格ではありませんので、CLtL1/2で得た知識は一度ANSI Common Lisp規格でどう変更された/されていないのかの確認をしましょう。
■
HTML generated by 3bmd in LispWorks 7.0.0
MOP vs マクロ (6)
Posted 2019-02-20 18:53:42 GMT
今回は前回に引き続きECLOSネタから、
- instance-recording-class (get to instances from their class, but allow their garbage collection).
でMOP vs マクロ比較をしてみたいと思います。
インスタンス生成を何らかの形で記録するというのはAMOPの3.1章にも出てくる定番ネタです。
この機能の実現は、インスタンス生成で使うmake-instanceに記録を行う関数のフックをかけてやればOKでしょう。
加えて、ECLOSではインスタンスを記録しつつもGCされたら消えるとのことなのですが、これは弱参照リストかなにかにすれば、これもOKでしょう。
ということで書いてみました。
MOPでの実装
LispWorksとSBCLで弱参照のシークエンスを物色してみましたが、弱参照の配列にしてみました。
LispWorksでは、weak-arrayというものがありadjustableなのですが、SBCLにはないので、結局make-weak-pointerで包んでいます。
trivial-garbageを利用すればいくらか可搬性は増すかもしれません。
(cl:in-package :cl-user)(ql:quickload :closer-mop)
(defpackage "d5fc135c-3bcf-4976-9a9e-e6b92c12bd9d"
(:use :c2cl :alexandria))
(in-package "d5fc135c-3bcf-4976-9a9e-e6b92c12bd9d")
(defun make-weak-vector (size &rest initargs)
(declare (dynamic-extent initargs))
#+lispworks (apply #'hcl:make-weak-vector size initargs)
#+sbcl (apply #'make-array size :element-type 'sb-ext:weak-pointer initargs))
(defclass instance-recording-class (standard-class)
((instance-record :initform (make-weak-vector 0 :adjustable T :fill-pointer 0)
:accessor class-instance-record)))
(defmethod validate-superclass ((c instance-recording-class) (sc standard-class))
T)
(defmethod make-instance :around ((class instance-recording-class) &rest initargs)
(let* ((inst (call-next-method))
#+sbcl (inst (sb-ext:make-weak-pointer inst)))
(vector-push-extend inst (class-instance-record class))
inst))
(defun reset-instance-record (class)
(setf (class-instance-record class)
(make-weak-vector 0 :adjustable T :fill-pointer 0)))
試してみる
(defconstant <zot>
(defclass zot ()
((a :initform 42))
(:metaclass instance-recording-class)))(dotimes (i 8)
(make-instance <zot>))
(class-instance-record <zot>)
#+sbcl
→#(#<weak pointer: #<zot {10349DBA73}>> #<weak pointer: #<zot {10349ECDF3}>> #<weak pointer: #<zot {10349ECE63}>> #<weak pointer: #<zot {10349ECEE3}>>
#<weak pointer: #<zot {10349ECF33}>> #<weak pointer: #<zot {10349ECFD3}>> #<weak pointer: #<zot {10349ED023}>> #<weak pointer: #<zot {10349ED073}>>)
#+lispworks
→ #(#<zot 4020034723> #<zot 4020034B43> #<zot 4020034EAB> #<zot 4020035213>
#<zot 402003557B> #<zot 40200358E3> #<zot 4020035C4B> #<zot 4020035FB3>)
#+lispworks (hcl:gc-all)
#+sbcl (sb-ext:gc :full t)
(class-instance-record <zot>)
#+sbcl
→ #(#<broken weak pointer> #<broken weak pointer> #<broken weak pointer> #<broken weak pointer> #<broken weak pointer> #<broken weak pointer>
#<broken weak pointer> #<broken weak pointer>)
#+lispworks
→ #(nil nil nil nil nil nil nil nil)
;; (clear-instance-record <zot>)
SBCLのほうはweak-pointerオブジェクトで包まれるのでちょっと扱いが面倒ですが、まあこんなものでしょう。
allocate-instanceにフックをかけるのでは駄目なのか
AMOPの例でもこういう記録系の拡張は、make-instanceにフックをかけますが、生成ならばallocate-instanceへのフックでも良さそうです。
両者で何が違うのか考えてみましたが、class-prototypeを実行するとプロトタイプの生成でallocate-instanceが呼ばれるので、クラスのプロトタイプインスタンスも含みたい場合はallocate-instanceの方が良いのでしょう。
恐らく、インスタンス記録系は、クラスのプロトタイプインスタンスは大抵除外して考えそうなので、make-instanceの方が自然かと思います。
allocate-instanceを利用した場合
(defmethod allocate-instance :around ((class instance-recording-class) &rest initargs)
(let* ((inst (call-next-method))
#+sbcl (inst (sb-ext:make-weak-pointer inst)))
(vector-push-extend inst (class-instance-record class))
inst))(defconstant <bar>
(defclass bar ()
((a :initform 42))
(:metaclass instance-recording-class)))
(class-instance-record <bar>)
→ #()
(class-prototype <bar>)
→ #<bar 402008BEE3>
(class-instance-record <bar>)
→ #(#<bar 402008BEE3>)
マクロで考えてみた
あまりこういうのはマクロに向いていない気もしますが、比較のために書いてみました。
(defvar *instance-recording-table*
(make-hash-table))(defmacro with-instance-recording ((type) &body form)
(with-unique-names (inst)
`(let* ((,inst (progn ,@form))
#+sbcl (,inst (sb-ext:make-weak-pointer ,inst)))
#-sbcl (check-type ,inst ,type)
#+sbcl (check-type (sb-ext:weak-pointer-value ,inst) ,type)
(vector-push-extend ,inst
(or (gethash ',type *instance-recording-table*)
(setf (gethash ',type *instance-recording-table*)
(make-weak-vector 0 :adjustable T :fill-pointer 0))))
,inst)))
(defun get-instance-record (type)
(values (gethash type *instance-recording-table*)))
(defun reset-instance-record (type)
(setf (gethash type *instance-recording-table*)
(make-weak-vector 0 :adjustable T :fill-pointer 0)))
試してみる
(defclass quux ()
((x :initform 0)))(dotimes (i 8)
(with-instance-recording (quux)
(make-instance 'quux)))
(get-instance-record 'quux)
→ #(#<quux 40200A1413> #<quux 40200A26A3> #<quux 40200A351B> #<quux 40200A4393>
#<quux 40200A520B> #<quux 40200A6083> #<quux 40200A6EFB> #<quux 40200A7D73>)
(hcl:gc-all)
(get-instance-record 'quux)
→ #(nil nil nil nil nil nil nil nil)
マクロなのでクラスオブジェクト以外にも使えます。
(というかそういう風に作っただけ)
(defstruct sss a b c)(dotimes (i 8)
(with-instance-recording (sss)
(make-sss)))
(get-instance-record 'sss)
→ #(#S(sss :a nil :b nil :c nil) #S(sss :a nil :b nil :c nil)
#S(sss :a nil :b nil :c nil) #S(sss :a nil :b nil :c nil)
#S(sss :a nil :b nil :c nil) #S(sss :a nil :b nil :c nil)
#S(sss :a nil :b nil :c nil) #S(sss :a nil :b nil :c nil))
(hcl:gc-all)
(get-instance-record 'sss)
→ #(nil nil nil nil nil nil nil nil)
まとめ
インスタンスの記録についてMOPとマクロで比較してみましたが、元がMOP向きな問題だけにさすがにMOPの方がすっきりします。
しかし、実現している内容はマクロ版も大して変わらないので、あとは使い勝手がどうなるか、でしょうか。
■
HTML generated by 3bmd in LispWorks 7.0.0
MOP vs マクロ (5)
Posted 2019-02-18 21:04:14 GMT
前回のlet*-like slot initialization semanticsはマクロ主体での実装でしたが、今回はMOP主体でチャレンジです。
しかし、defclassが周囲のレキシカル変数を取り込むので何にせよ全体はマクロでまとめる他なさそうですが、そこは諦めます。
あれこれ試行錯誤しましたが、今回の方針は、
let*風の逐次初期化を実行する関数を収めるスロットを付ける (direct-slot-definitionに追加)- メタクラスにインスタンスの初期化をする関数を収めるスロットを付ける
(
class-let*-initfunction) compute-slotsでスロット構成を生成する際に、追加したスロットの初期化関数をまとめる- まとめた関数を
shared-initializeで呼ぶ
shared-initializeで呼ばれる関数ですが、下記のようなものを生成します。
初期化されるインスタンスを引数に取り、内部では、専らstandard-instance-accessを使って読み書きします。
(lambda (obj)
(symbol-macrolet ((a (standard-instance-access obj 0))
(b (standard-instance-access obj 1)))
(when (eq unbound-marker (standard-instance-access obj 0))
(setf (standard-instance-access obj 0)
(funcall #<Function 1 subfunction of (lw:top-level-form 1) 4060007E8C>
nil
nil)))
(when (eq unbound-marker (standard-instance-access obj 1))
(setf (standard-instance-access obj 1)
(funcall #<Function 2 subfunction of (lw:top-level-form 1) 4060007E34>
a
nil)))
(when (eq unbound-marker (standard-instance-access obj 2))
(setf (standard-instance-access obj 2)
(funcall #<Function 3 subfunction of (lw:top-level-form 1) 4060007DAC>
a
b)))))そして、下記がMOPチャレンジ版のコードですが、大したことはしていないのに長くなりました。
(cl:in-package :cl-user)(ql:quickload :closer-mop)
(defpackage :64d0b072-4e6b-44c3-b565-dcf8d4ca63e3
(:use :c2cl)
#+sbcl (:shadowing-import-from :cl :defmethod))
(cl:in-package :64d0b072-4e6b-44c3-b565-dcf8d4ca63e3)
(defconstant unbound-marker
(if (boundp 'unbound-marker)
unbound-marker
(gensym "unbound")))
(defclass let*-slot-class (standard-class)
((let*-slots :initform nil :accessor class-let*-slots :initarg :let*-slots)
(let*-initfunction :accessor class-let*-initfunction :initarg :let*-initfunction)))
(defmethod validate-superclass ((c let*-slot-class) (sc standard-class))
T)
(defclass let*-standard-object (standard-object)
())
(defun process-a-slot (slot)
(loop :with name := (car slot)
:for (k v) :on (cdr slot) :by #'cddr
:when (eq k :initform)
:append `(:initform ,v :initfunction (constantly unbound-marker)) :into initform
:when (eq k :initarg) :collect v :into initargs
:when (eq k :writer) :collect v :into writers
:when (eq k :reader) :collect v :into readers
:when (eq k :accessor) :collect v :into readers :and :collect `(setf ,v) :into writers
:finally (return
`(:name ,name
:initargs ,initargs
,@initform
:writers ,writers
:readers ,readers))))
(defclass let*-direct-slot-definition (standard-direct-slot-definition)
((let*-initfunction :initarg :let*-initfunction :accessor slot-definition-let*-initfunction)))
(defmethod direct-slot-definition-class ((class let*-slot-class) &rest initargs)
(find-class 'let*-direct-slot-definition))
(defmethod compute-slots :around ((class let*-slot-class))
(let* ((let*-slots (class-let*-slots class))
(slots (call-next-method))
(let*-slot#s (loop :for s :in let*-slots
:for pos := (position s slots :key #'slot-definition-name)
:when pos :collect (cons s pos))))
(setf (class-let*-initfunction class)
(compile nil
`(lambda (obj)
(symbol-macrolet (,@(loop :for s :in (butlast let*-slots)
:collect `(,s (standard-instance-access obj ,(cdr (assoc s let*-slot#s))))))
,@(loop :for s :in let*-slots
:for pos := (cdr (assoc s let*-slot#s))
:for argpos :from 0
:collect `(when (eq unbound-marker (standard-instance-access obj ,pos))
(setf (standard-instance-access obj ,pos)
(funcall ,(slot-definition-let*-initfunction
(find s (class-direct-slots class) :key #'slot-definition-name))
,@(replace (make-list (length (cdr let*-slots)))
(subseq (butlast let*-slots) 0 argpos))))))))))
slots))
(defmethod shared-initialize :after
((obj let*-standard-object) slot-names &rest initargs &key &allow-other-keys)
(funcall (class-let*-initfunction (class-of obj)) obj))
(defmacro defclass* (name (&rest superclasses) (&rest slots) &rest class-options)
(loop :with slot-names := (mapcar (lambda (x) (if (consp x) (car x) x))
slots)
:for s :in slots
:for cs := (copy-list (process-a-slot s))
:collect `(,@cs
:let*-initfunction
(lambda (,@(butlast slot-names))
(declare (ignorable ,@(butlast slot-names)))
,(getf cs :initform))) :into canonicalized-slots
:finally (return
`(eval-when (:compile-toplevel :load-toplevel :execute)
(ensure-class ',name
:metaclass 'let*-slot-class
:direct-superclasses (adjoin 'let*-standard-object
',superclasses)
:direct-slots (list ,@(mapcar (lambda (s)
(destructuring-bind (&key name
initargs
initform
initfunction
writers
readers
let*-initfunction
&allow-other-keys)
s
`(list :name ',name
:initargs ',initargs
:initform ',initform
:initfunction ,initfunction
:writers ',writers
:readers ',readers
:let*-initfunction ,let*-initfunction)))
canonicalized-slots))
:let*-slots ',slot-names
,@class-options)))))
動作
(defclass* qqq ()
((a :initform 42 :initarg :a)
(b :initform a :initarg :b)
(c :initform (+ a b) :initarg :c)))(with-slots (a b c) (make-instance 'qqq)
(list a b c))
;=> (42 42 84)
(with-slots (a b c) (make-instance 'qqq :c 0)
(list a b c))
;=> (42 42 0)
(with-slots (a b c) (make-instance 'qqq :b 0)
(list a b c))
;=> (42 0 42)
(with-slots (a b c) (make-instance 'qqq :a 0)
(list a b c))
;=> (0 0 0)
(with-slots (a b c) (make-instance 'qqq :a 0 :b 1)
(list a b c))
;=> (0 1 1)
MOPにして良いことがあるのか
マクロ主体の場合は、スロットアクセスが名前参照ベースなので若干非効率効率ですが、MOPを使えば、standard-instance-access等の効率の良いアクセス方法が使えるので速くできるだろうということで、今回は、standard-instance-accessの利用を軸に組み立ててみました。
素のインスタンス生成〜初期化と比較して、マクロ版は、約1.8倍の時間のところをMOP版では、約1.3倍程度にまで抑えることができました。
まあもっと速くできそうではありますが……。
(defclass let-slot ()
((a :initform 42)
(b :initform 42)
(c :initform 42)))(defclass* let*-slot ()
((a :initform 42 :initarg :a)
(b :initform a :initarg :b)
(c :initform (+ a b) :initarg :c)))
(dc07f5fa-62ee-40a1-ae1a-d1a0f87d19bb::defclass* let*-slot-macro ()
((a :initform 42 :initarg :a)
(b :initform a :initarg :b)
(c :initform (+ a b) :initarg :c)))
計時
(let ((cnt 1000000))
(time
(dotimes (i cnt)
(make-instance 'let-slot)))
(time
(dotimes (i cnt)
(make-instance 'let*-slot)))
(time
(dotimes (i cnt)
(make-instance 'let*-slot-macro))))Timing the evaluation of (dotimes (i cnt) (make-instance 'let-slot))
User time = 1.270
System time = 0.000
Elapsed time = 1.258
Allocation = 1352109704 bytes
0 Page faults
Calls to %EVAL 17000036
Timing the evaluation of (dotimes (i cnt) (make-instance 'let*-slot))
User time = 1.660
System time = 0.000
Elapsed time = 1.654
Allocation = 1352029784 bytes
0 Page faults
Calls to %EVAL 17000036
Timing the evaluation of (dotimes (i cnt) (make-instance 'let*-slot-macro))
User time = 2.260
System time = 0.000
Elapsed time = 2.260
Allocation = 1352020600 bytes
0 Page faults
Calls to %EVAL 17000036
nil
継承した場合にスロットのインデックスの位置関係はどうなるのか
具体的には下記のような場合に、standard-instance-accessが指す先がどのような構成になるのかを把握していないと使えないのですが、
(defclass A ()
((a :initform 0 :initarg :a)
(b :initform 1 :initarg :b)
(c :initform 2 :initarg :c)))(defclass* B (A)
((x :initform 42 :initarg :x)
(y :initform x :initarg :y)
(z :initform (+ x y) :initarg :z)))
(with-slots (a b c x y z) (make-instance 'B :y 1)
(list a b c x y z))
;=> (0 1 2 42 1 43)
AMOPのInstance Structure Protocolの例では、compute-slotsの並び順で、standard-instance-accessのインデックスを決められる的なことが書いてあります。
実際に試してみると、継承した場合、上位クラスのスロット数分だけオフセットしたり(SBCL、LispWorks)名前とスロットの値が一致しなかったり(LispWorks)で、compute-slotsで並べた順がすなわちインデックスとはならない実装があるようです。
しょうがないので、結局名前からインデックスを求めるようにしましたが、私が何か勘違いをしているのか、もしくはこの仕様に準拠している処理系が少ないのか。
まとめ
これまでlet*風にスロットの逐次初期化を2パスで考えてみましたが、shared-initializeを差し替えてしまった方が素直なのかもしれません。
そのうち試してみようかなと思います。
■
HTML generated by 3bmd in LispWorks 7.0.0
MOP vs マクロ (4)
Posted 2019-02-11 15:59:28 GMT
MOP vs マクロなネタを探していますが、古えのメールに面白そうなものがあったので、これをどうにかMOP vs マクロの枠内で再現してみることにします。
ちなみに、このECLOSですが、Metaclass libraryとあるように、MOP的なツールを纏めた商用ライブラリだったようです。
メタクラス関係だけで商品になってたというのが凄い。
告知メールによると主なアイテムは、
- self-referent class
- instance-recording-class (get to instances from their class, but allow their garbage collection).
- operating-class (implement recursive operations like
copy-object,equal-object-pwith suscint in-class specifications) - lazy-class (establish inter-slot/access dependencies to avoid initializing slots until they are needed/make-sense)
- attributed-class (arbitrary-depth attributes in slots, great for frame-like programming)
- constrained-class (multi-way constraints and daemons can be stored in and refer transparently to slots).
- An enhanced Delta-Blue constraint solver with a higher-order architecture
for dynamic update of constraint graphs (no
propagate as if graph still unchangedsemantics). - let*-like slot initialization semantics
ですが、定番そうなものから何やら良く分からないものまであります。
今回は、このリストの中からlet*-like slot initialization semanticsをMOPとマクロで再現してみたいと思います。
例のごとくまずはマクロでの実現から始めます。
let*-like slot initialization semantics をマクロで書いてみる
まず、動作の確認ですが、詳細は不明なものの、多分let*のように上方のスロットの値が次のスロットで使えるということなのではないかと思います。
動作例を考えると、下記のようになるかと思いますが、やりたいことが単純な割には実現は面倒臭そうです。
(let ((z 42))
(defclass* qqq ()
((a :initform z :initarg :a :initarg a)
(b :initform a :initarg :b :initarg b)
(c :initform (+ a b) :initarg :c :initarg c))))(with-slots (a b c) (make-instance 'qqq)
(list a b c))
;=> (42 42 84)
(with-slots (a b c) (make-instance 'qqq :c 0)
(list a b c))
;=> (42 42 0)
(with-slots (a b c) (make-instance 'qqq :b 0)
(list a b c))
;=> (42 0 42)
(with-slots (a b c) (make-instance 'qqq :a 0)
(list a b c))
;=> (0 0 0)
(with-slots (a b c) (make-instance 'qqq :a 0 :b 1)
(list a b c))
;=> (0 1 1)
一応の解説ですが、上記のクラス定義フォームを素のdefclassで置き換えた場合、bとcスロットでaとbが未束縛でエラーになります。
変数zに関してはdefclassは外側の変数を取り込めるのでzはレキシカル変数になります。
(let ((z 42))
(defclass ppp ()
((a :initform z :initarg :a :initarg a)
(b :initform a :initarg :b :initarg b)
(c :initform (+ a b) :initarg :c :initarg c))))(make-instance 'ppp)
;!!! The variable a is unbound.
このlet*的な初期化構文のポイントは、let*的な順次初期化は、クラス定義時に行なわれるのではなく、インスタンス(再)初期化時に行なわれるということです。
マクロでどうするか考えてみる
あれこれ考えてみましたが、とりあえずスロットの初期化を2パスにするのが一番簡単そうなので、それで行くことにしました。
- スロットの
:initfunctionに設定する関数でクロージャーを返すようにしインスタンス初期化まで評価を遅らせる - インスタンス初期化時に、スロットの値が保留になっているかを調べて保留状態ならクロージャーを評価し値を設定
という所です。
マクロ展開を眺めるのが一番早いと思うのですが下記のような展開になります。
(defclass* qqq ()
((a :initform 42 :initarg :a)
(b :initform a :initarg :b)
(c :initform (+ a b) :initarg :c)))
===>
(eval-when (:compile-toplevel :load-toplevel :execute)
(let ((#:a368281
(lambda (obj)
(with-slots (a b c) obj (declare (ignorable a b c)) 42)))
(#:b368282
(lambda (obj) (with-slots (a b c) obj (declare (ignorable a b c)) a)))
(#:c368283
(lambda (obj)
(with-slots (a b c) obj (declare (ignorable a b c)) (+ a b)))))
(ensure-class 'qqq
:direct-superclasses
(adjoin 'let*-standard-object 'nil)
:direct-slots
(list (list :name 'a :initargs '(:a) :initform '42 :initfunction (lambda () #:a368281) :writers 'nil :readers 'nil)
(list :name 'b :initargs '(:b) :initform 'a :initfunction (lambda () #:b368282) :writers 'nil :readers 'nil)
(list :name 'c :initargs '(:c) :initform '(+ a b) :initfunction (lambda () #:c368283) :writers 'nil :readers 'nil)))
(defmethod initialize-let*-slots ((obj qqq))
(let ((sname 'a))
(when (slot-boundp obj sname)
(let ((sval (slot-value obj sname)))
(when (eq #:a368281 sval)
(setf (slot-value obj sname) (funcall sval obj))))))
(let ((sname 'b))
(when (slot-boundp obj sname)
(let ((sval (slot-value obj sname)))
(when (eq #:b368282 sval)
(setf (slot-value obj sname) (funcall sval obj))))))
(let ((sname 'c))
(when (slot-boundp obj sname)
(let ((sval (slot-value obj sname)))
(when (eq #:c368283 sval)
(setf (slot-value obj sname) (funcall sval obj)))))))))マクロ定義(およびクラス定義)
(cl:in-package :cl-user)(ql:quickload :closer-mop)
(cl:defpackage :dc07f5fa-62ee-40a1-ae1a-d1a0f87d19bb
(:use :c2cl))
(cl:in-package :dc07f5fa-62ee-40a1-ae1a-d1a0f87d19bb)
(defclass let*-standard-object (standard-object)
())
(defun process-a-slot (slot)
(loop :with name := (car slot)
:for (k v) :on (cdr slot) :by #'cddr
:when (eq k :initform)
:append `(:initform ,v :initfunction ,(coerce `(lambda () ,v) 'function)) :into initform
:when (eq k :initarg) :collect v :into initargs
:when (eq k :writer) :collect v :into writers
:when (eq k :reader) :collect v :into readers
:when (eq k :accessor) :collect v :into readers :and :collect `(setf ,v) :into writers
:finally (return
`(:name ,name
:initargs ,initargs
,@initform
:writers ,writers
:readers ,readers))))
(defgeneric initialize-let*-slots (obj))
(defmethod shared-initialize :after
((obj let*-standard-object) slot-names &rest initargs &key &allow-other-keys)
(initialize-let*-slots obj))
(defmacro defclass* (name (&rest superclasses) (&rest slots) &rest class-options)
(loop :with slot-names := (mapcar (lambda (x) (if (consp x) (car x) x))
slots)
:for s :in slots
:for cs := (copy-list (process-a-slot s))
:for ifn := (gensym (string (getf cs :name)))
:collect cs :into canonicalized-slots
:collect `(,ifn (lambda (obj)
(with-slots (,@slot-names) obj
(declare (ignorable ,@slot-names))
,(getf cs :initform)))) :into bvs
:collect `(let ((sname ',(getf cs :name)))
(when (slot-boundp obj sname)
(let ((sval (slot-value obj sname)))
(when (eq ,ifn sval)
(setf (slot-value obj sname)
(funcall sval obj)))))) :into slot-init-forms
:do (setf (getf cs :initfunction)
`(lambda () ,ifn))
:finally (return
`(eval-when (:compile-toplevel :load-toplevel :execute)
(let (,@bvs)
(ensure-class ',name
:direct-superclasses (adjoin 'let*-standard-object
',superclasses)
:direct-slots (list
,@(mapcar (lambda (s)
(destructuring-bind (&key name
initargs
initform
initfunction
writers
readers
&allow-other-keys)
s
`(list :name ',name
:initargs ',initargs
:initform ',initform
:initfunction ,initfunction
:writers ',writers
:readers ',readers)))
canonicalized-slots))
,@class-options)
(defmethod initialize-let*-slots ((obj ,name))
,@slot-init-forms))))))
まとめ
案外ほとんどMOP的な要素を使わずにマクロのみで実現できてしまいましたが、スコープ的なものを扱うのでマクロの方が得意なのかもしれません。
ちなみに、スロットの:initfunctionは、ANSI Common Lispの規格にはなく、MOPで規定されているものですが、まあこれくらいは良しとしましょう。
さてこれを今後MOP的にして行きたいと思います。
■
HTML generated by 3bmd in LispWorks 7.0.0
MOP vs マクロ (3)
Posted 2019-02-03 20:45:41 GMT
前回は、全面的なマクロから、ensure-classを使って若干のMOP利用へと進めましたが、今回は、ensure-class-using-classを利用して、もう一歩進めてみたいと思います。
ensure-class-using-class を利用してみる
ensure-classは関数ということもあり、プロトコルを成しているメソッド群をカスタマイズするという感じではありませんが、ensure-classの下請けのensure-class-using-classは、standard-classをカスタマイズしたメタクラスでディスパッチさせることが可能です。
(defpackage d34ab7fb-8666-4f9c-ac95-833380ffefee
(:use :c2mop :cl)
(:shadowing-import-from :c2mop
:defmethod :standard-class :defgeneric
:standard-generic-function :funcallable-standard-class))(in-package d34ab7fb-8666-4f9c-ac95-833380ffefee)
(defun slot-name-conc (prefix name)
(let ((pkg (etypecase prefix
((or null string) *package*)
(symbol (symbol-package prefix)))))
(intern (concatenate 'string (string prefix) (string name)) pkg)))
(defclass conc-name-class (standard-class)
((conc-name :initarg :conc-name :accessor class-conc-name)))
(defmethod validate-superclass ((class conc-name-class) (super standard-class))
T)
上記では、standard-classメタクラスのサブクラスとしてconc-name-classメタクラスを定義してみています。
これで、ensure-class-using-classがディスパッチできるようになります。
(defmethod ensure-class-using-class ((class conc-name-class) name
&rest initargs
&key (conc-name (concatenate 'string (string name) ".") conc-name-sup?)
direct-slots
&allow-other-keys)
(when conc-name-sup?
(setq conc-name (car conc-name)))
(setq direct-slots
(loop :for s :in direct-slots
:collect (destructuring-bind (&key name readers writers &allow-other-keys)
s
(let ((aname (slot-name-conc conc-name name)))
`(:name ,name
:readers (,aname ,@readers)
:writers ((setf ,aname) ,@writers))))))
(let ((class (apply #'call-next-method class name :direct-slots direct-slots
initargs)))
(setf (class-conc-name class) conc-name)
class))ensure-classと同じく、ensure-class-using-classが取るキーワード引数は、defclassのクラスオプションが渡ってきますので、以上で下記のように書けます。
(defclass foo ()
(x
y
(z :accessor z))
(:metaclass conc-name-class)
(:conc-name foo.))(let ((qqq (make-instance 'foo)))
(with-slots (x y z) qqq
(setq x 42 y 43 z 44))
(incf (foo.z qqq))
(list (foo.x qqq)
(foo.y qqq)
(foo.z qqq)))
→ (42 43 45)
マクロ的なアプローチの問題点として
- defclassの派生構文ができてしまう
というのがありましたが、:metaclassを一々指定するのは面倒臭いもののdefclassの標準構文に収まりました。
また、
- マクロ内でdefclassのオプションを解析するのがめんどくさい
というのもensure-classが正規化して渡してくれるので、ensure-classよりはすっきりします。
しかし今度もあまりMOP的でない?
しかし、上記のコードを眺めると判るように前回とさして変化ありません。
アクセサの名前に接頭辞を付けるのだから、MOP的にするなら、スロット定義メタオブジェクトをあれこれするのが筋なのではないか、ということになります。
ということで、スロット定義のプロトコルをカスタマイズしてみます。
(defclass conc-name-direct-slot-definition (standard-direct-slot-definition)
((conc-name :initform nil :initarg :conc-name)))(defmethod direct-slot-definition-class ((class conc-name-class) &rest initargs)
(find-class 'conc-name-direct-slot-definition))
(defmethod initialize-instance :around ((sd conc-name-direct-slot-definition) &rest args &key name conc-name)
(let ((aname (slot-name-conc conc-name name))
(inst (call-next-method)))
(pushnew aname (slot-definition-readers sd) :test #'equal)
(pushnew `(setf ,aname) (slot-definition-writers sd) :test #'equal)
inst))
(defmethod ensure-class-using-class ((class conc-name-class) name
&rest initargs
&key (default-conc-name (concatenate 'string (string name) ".") default-conc-name-sup?)
direct-slots
&allow-other-keys)
(when default-conc-name-sup?
(setq default-conc-name (car default-conc-name)))
(apply #'call-next-method
class
name
:default-conc-name default-conc-name
:direct-slots (mapcar (lambda (s)
(if (getf s :conc-name)
s
(list* :conc-name default-conc-name s)))
direct-slots)
initargs))
解説すると、まずデフォルトのstandard-direct-slot-definitionをカスタマイズするために、conc-name-direct-slot-definitionを定義します。
conc-name-direct-slot-definitionの中では、指定された接頭辞をもとにアクセサ名を生成します。
スロット定義では、:conc-nameで接頭辞を指定しますが、スロット定義メタオブジェクトを生成する時のキーワード引数はdefclassのスロットのキーワード引数が正規化されたものになりますので、単純に:conc-nameを追加しておけばOKです。
次に、このスロット定義を呼び出すために、direct-slot-definition-classが返すクラスをconc-name-direct-slot-definitionに設定します。
direct-slot-definition-classが返すクラスでスロット定義を生成するプロトコルなので、スロット定義のサブクラスを作ってカスタマイズしても、これに設定しないと有効にできません。
また、クラス定義の方で指定する接頭辞とスロットで指定する接頭辞を区別したいので、クラス定義の方は、default-conc-nameと変更します。
(defclass conc-name-class (standard-class)
((conc-name :initarg :default-conc-name :accessor class-conc-name)))これでこんな感じに書けます
(defclass bar ()
((x :conc-name bar=)
(y :conc-name bar_)
(z :accessor z))
(:default-conc-name bar.)
(:metaclass conc-name-class))(let ((qqq (make-instance 'bar)))
(with-slots (x y z) qqq
(setq x 42 y 43 z 44))
(incf (bar.z qqq))
(list (bar=x qqq)
(bar_y qqq)
(bar.z qqq)))
→ (42 43 45)
スロットごとに接頭辞を付けて便利なことがあるかは不明ですが、スロット定義のプロトコルに従ったお蔭でおまけ的に別個に指定できたりします。
まとめ
以上、マクロだけでの実現からMOP的なものまでを順に考えてきましたが、MOPの方は作法を憶えるのが面倒臭いです。
まあしかし、MOPの作法は一応標準化されていますので、俺マクロの使い方を憶えるよりは、ましだったりするかもしれません。
■
HTML generated by 3bmd in LispWorks 7.0.0
MOP vs マクロ (2)
Posted 2019-01-23 17:36:05 GMT
長くなりそうなので数回に分けた記事にしようと思っていましたが、前回の記事を書くなかで自分の中では問題は解決してしまったので、続きを書くのをすっかり忘れていました。
それはさておき、前回は、お題を全部マクロで実現した訳ですが、今回は若干MOPよりです。
といっても、MOPが定めている便利ユーティリティを利用するのみでメタオブジェクトをあれこれという訳ではありません。
「マクロだけでがんばる」から「MOPだけでがんばる」の方向に進めて行き、丁度良い落とし所はどの辺りかを探っていければ良いなと考えています。
ensure-class を利用してみる
前回は、defclassのラッパーという感じでしたが、今回はMOPが定めるdefclassを組み立てるための関数であるensure-classを利用します。
ensure-classは、defclassを組み立てるための関数ともいえますし、ensure-classをお化粧したのがdefclassともいえるでしょう。
(setf (fdefinition 'foo) ...)と(defun foo (...) ...)のような関係と考えるとわかりやすいかと思います。
コードは長いので後ろに置きますが、ensure-classを使えばこんな感じのものに構成できます。
(defclass/conc-name foo ()
(x
y
(z :accessor z))
(:conc-name foo.));;; マクロ展開
===>
(eval-when (:compile-toplevel :load-toplevel :execute)
(ensure-class 'foo
:direct-superclasses 'nil
:direct-slots '((:name x :writers ((setf foo.x)) :readers (foo.x))
(:name y :writers ((setf foo.y)) :readers (foo.y))
(:name z :writers ((setf z) (setf foo.z)) :readers (z foo.z)))
:direct-default-initargs 'nil))
(let ((qqq (make-instance 'foo)))
(with-slots (x y z) qqq
(setq x 42 y 43 z 44))
(incf (foo.z qqq))
(list (foo.x qqq)
(foo.y qqq)
(foo.z qqq)))
→ (42 43 45)
前回の問題点として
- defclassの派生構文ができてしまう
- マクロ内で
defclassのオプションを解析するのがめんどくさい
の二点がありましたが、ensure-classを使っても別段問題は解消されていません。
ensure-classを使った場合、:accessorは、:writerと:readerの組み合わせとして正規化する必要があるので、見通しが若干良くなるのかも、というところです。
オプションの解析部分をより拡張性のあるものにすれば(例えば総称関数にする等)、汎用的な構文として綺麗にまとめられるかもしれません。
既にこの辺りが落とし所な気はしますが、次回はさらにMOP的にすべくensure-class-using-classの活用を考えてみます。
付録: ensure-class を使ってみた場合の定義例
(defpackage 05d2b99b-651a-4352-ba04-47593339a944
(:use :c2mop :cl)
(:shadowing-import-from :c2mop :defmethod :standard-class :defgeneric :standard-generic-function))(in-package 05d2b99b-651a-4352-ba04-47593339a944)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun canonicalize-slots (slots)
(labels ((canonicalize-slot (slot)
(typecase slot
((and symbol (not null)) (list slot))
(T slot))))
(mapcar #'canonicalize-slot slots)))
(defun slot-name-conc (prefix name)
(let ((pkg (etypecase prefix
((or null string) *package*)
(symbol (symbol-package prefix)))))
(intern (concatenate 'string (string prefix) (string name)) pkg)))
(defun process-a-slot (slot)
(loop :with name := (car slot)
:for (k v) :on (cdr slot) :by #'cddr
:when (eq k :initform)
:append `(:initform ,v :initfunction (lambda () ,v)) :into initform
:when (eq k :writer) :collect v :into writers
:when (eq k :reader) :collect v :into readers
:when (eq k :accessor) :collect v :into readers :collect `(setf ,v) :into writers
:finally (return
`(:name ,name
,@initform
:writers ,writers
:readers ,readers))))
)(defmacro defclass/conc-name (name superclasses slots &rest class-options)
(let* ((conc-name (concatenate 'string (string name) "-"))
(class-options (loop :for opt :in class-options
:if (eq :conc-name (car opt))
:do (when (cadr opt)
(setq conc-name (cadr opt)))
:else :collect opt)))
`(eval-when (:compile-toplevel :load-toplevel :execute)
(ensure-class ',name
:direct-superclasses '(,@superclasses)
:direct-slots '(,@(loop :for s :in (canonicalize-slots slots)
:for aname := (slot-name-conc conc-name (car s))
:collect (process-a-slot `(,@s :accessor ,aname))))
:direct-default-initargs '(,@class-options)))))
■
HTML generated by 3bmd in LispWorks 7.0.0
MOP vs マクロ (1)
Posted 2019-01-13 21:46:09 GMT
オブジェクト指向システムを拡張する際に、痒い所に微妙に手が届かない気がするMOPと、なんでもできるけど安易なメタプログラミングも嫌だなあというマクロで使い分けに迷うことはないでしょうか。
例えばですが、defstructにはアクセサを自動で生成する機能があり、この機能については善し悪しがありますが、defclassで同様のアクセサの自動生成を実装するとします。
さて、こういう場合、MOPで実現するのが良いのか、マクロでやっつけてしまえば良いのか微妙に悩んだりしないでしょうか(自分だけ?)
defclassでアクセサの生成をするということは、定義時には名前が確定しているということで、マクロが担当するのが良い気もします。
しかしクラスに関することなので、MOPを使った方が既存の構文の枠組みで拡張できたりもしそうです。
どっちもどっちなのですが、とりあえずはマクロで書いてみました。
defclass/conc-nameは、defcassに展開されるマクロですが、:conc-nameでアクセサの接頭辞を指定できます。
(defclass/conc-name foo ()
(x
y
(z :accessor z))
(:conc-name foo.));;; マクロ展開
===>
(defclass foo ()
((x :accessor foo.x)
(y :accessor foo.y)
(z :accessor z :accessor foo.z)))(let ((qqq (make-instance 'foo)))
(with-slots (x y z) qqq
(setq x 42 y 43 z 44))
(incf (foo.z qqq))
(list (foo.x qqq)
(foo.y qqq)
(foo.z qqq)))
→ (42 43 45) defclass/conc-name定義
(defun canonicalize-slots (slots)
(labels ((canonicalize-slot (slot)
(typecase slot
((and symbol (not null)) (list slot))
(T slot))))
(mapcar #'canonicalize-slot slots)))(defun slot-name-conc (prefix name)
(let ((pkg (etypecase prefix
((or null string) *package*)
(symbol (symbol-package prefix)))))
(intern (concatenate 'string (string prefix) (string name)) pkg)))
(defun ->conc-name (name)
(etypecase name
(null "")
(symbol (string name))
(string name)))
(defmacro defclass/conc-name (name superclasses slots &rest class-options)
(let* ((conc-name-p nil)
(conc-name (concatenate 'string (string name) "-"))
(class-options (loop :for opt :in class-options
:if (eq :conc-name (car opt))
:do (setq conc-name-p T
conc-name (->conc-name (cadr opt)))
:else :collect opt)))
`(defclass ,name (,@superclasses)
(,@(loop :for s :in (canonicalize-slots slots)
:when conc-name-p
:do (setf (cdr (last s))
(list :accessor (slot-name-conc conc-name (car s))))
:collect s))
,@class-options)))
マクロで実装してみた感想
マクロで書いた場合ですが、今回の場合は、
defclassの派生構文ができてしまう- マクロ内で
defclassのオプションを解析するのがめんどくさい
等々が問題かなと感じます。
defclassのオプションを解析するのがめんどくさいのは、defclassの作法に従おうとした結果で、その方が、使い手も類推できて良かろうという判断なのですが、どうせ拡張された構文なので解析しやすそうな構成にすることも可能かなとは思います。
defstructの作法に近付けるなら、
(defclass/conc-name (foo (:conc-name foo.)) ()
(x
y
(z :accessor z)))のようにできるかもしれません。
問題は、defclass/conc-nameはdefstructの作法で書くという情報の取扱がめんどう(使う側の人が色々憶えないといけない)ということです。
利用者の負担を減らすということでは、構文乗っ取り型マクロにしてしまう手もなくはありませんが、どうなんでしょう。
(with-conc-name foo. (defclass foo ()
(x
y
(z :accessor z)))
);; or
(with-accessor-options ((:conc-name foo.)
(:foo opt))
(defclass foo ()
(x
y
(z :accessor z))))
...
この場合は、見掛け上defclassが本体に見えますがwith-conc-nameがdefclassフォームを引数として処理することになります。
トリッキーですが派生構文を処理する場合には、defclass/conc-nameのような新しい名前を導入せずに既存の作法を継承できるので、一番スマートな方法だったりするかもしれません。
次回はMOPの作法で考えてみます。
■
HTML generated by 3bmd in LispWorks 7.0.0
Common Lisp標準が利用するキーワードシンボル一覧はどこにある
Posted 2019-01-02 23:43:53 GMT
たまにCommon Lisp標準が利用するキーワードシンボル一覧が欲しい時がありますが、どこにあるんでしょうか。
とりあえずのところは、HyperSpecのインデックスが利用できると思います。
しかし、どこかにキーワードシンボルだけまとめたものがありそうなのですが……。
少し探しても見当らなかったので、HyperSpecを参考に逆引きCommon Lispに記事を作成してみました。
ちなみに、HyperSpecのものは記事からインデックスを自動生成かなにかをしているようでタイポがあったり、コード例に使われているだけのキーワードシンボルも計上されているようです。
まとめ
エディタの補完機能まわりをカスタマイズしているときに関数が利用するキーワードだけを補完して欲しいのですが、まずは補完対象の一覧が欲しいなと思って、ここに至ります。
ひょっとしたら、ANSI Common Lisp規格票には掲載されていたりするかもと思い確認してみましたが、こちらにも無いようです。うーむ。
■
HTML generated by 3bmd in LispWorks 7.0.0
2018年振り返り
Posted 2018-12-31 18:57:12 GMT
毎年振り返りのまとめを書いているので、今回も書いてみます。
Lisp的進捗
ここ数年マニアックなLispネタでアドベントカレンダーを開催することで、色々調べたりしてLispのマイナー機能に詳しくなるというのをやっていました。
2017年はお休みしたのですが、若干の悔いが残ったので、2018年は、setfとメソッドコンビネーションネタでやってみました。
毎回これ以上はないなという所まで掘り下げられるので良い勉強になります(多分)。
メソッドコンビネーションに関しては、まだ掘り下げて書けることがありそうなので、そのうちちょっと書いてみたいと思います。
ブログ
今年書いた記事は72記事だったようです。
アドベントカレンダーで50記事位書いたのを除けば、大体二週間に一記事書いたり書かなかったりというところです。
近年、ブログを書く人も大分少なくなりましたが、2019年もそこそこ書いていきたいと思います。
LispWorks
LispWorksを購入してから早三年半ですが、持ち前の吝嗇根性からLispWorksを使い倒すべくメインに使い続けています。
ちなみに、以前は、SBCLをメインに使っていました。
SBCLはコンパイラ優秀で、実行速度からいうとほぼ最速の処理系で、ユーザーも一番多く、その上自由ソフトな処理系ということもあり、これ以外の選択はないだろうという感じでもあるのですが、GUIツールキット、Common Lispと統合された開発環境、出荷機能まで一通り揃っている完成度の高い処理系というとLispWorks、Allegro CL、MCL位しかありません。
Allegro CLは個人で使うにはお値段が謎、MCLはPPC Macと共に過去のものになってしまった等で、現実的な統合環境としてはLispWorks位かなと思います。
また、職場の社内ツールをLispWorksで作成してみたところ、色々な条件がたまたま上手くはまり、現在もLispWorksで開発が進んでいます。
- 社内にLispWorksユーザーがたまたま二人いた
- MacでGUIのアプリが必要だったので、LispWorksのCAPIに詳しい人がプロトタイプを作ってみたら手早くできちゃった
というところで、まさに偶然ですが、折角の機会なので活用していきたいところです。
ちなみに開発は同僚にお任せしているので、たまに思い付きの機能追加をしてみたりする以外では私はほとんど開発してません😺
2019年やってみたいこと
ここ二三年でLispマシンのエミュレータも、CADR、LMI Lambda、Symbolics Open Genera、TI Explorer、等一通り出揃いましたが、あまりキャッチアップできてないので2019年は力を入れようかなと思っています。
あと年末には、コンディションシステムアドベントカレンダーを開催したいので、色々準備しておきたいところです。
過去のまとめ
- #:g1: 2017年振り返り
- #:g1: 2016年振り返り
- #:g1: 2015年振り返り
- #:g1: 2014年振り返り
- #:g1: 2013年振り返り
- #:g1: 2012年振り返り
- #:g1: 2011年を振り返る
- #:g1: 2010年を振り返る
- #:g1: 2009年を振り返る
- #:g1: 今年一年をふりかえる
■
HTML generated by 3bmd in LispWorks 7.0.0
setfアドベントカレンダー総括
Posted 2018-12-24 15:00:01 GMT
《 Lisp SETF Advent Calendar 2018 25日目 》
メソッドコンビネーションでアドベントカレンダーを開催することを決めてから、もう一品と考えてsetfアドベントカレンダーを開催してみましたが、後半はネタを捻り出すのがきつかったです。
よくよく考えれば、ただの代入機構なので、話題が広げられる余地はあまりないのですが、ファーストクラスの参照を持つLISP方言についてもうちょっと掘り下げて書けたかもしれません(といっても一回分位だと思いますが)
setfアドベントカレンダーのを書いたお蔭で、setfの定義構文の使い分けについて、きっちり把握できたのは収穫かなと思います。
-完-
■
HTML generated by 3bmd in LispWorks 7.0.0
メソッドコンビネーションアドベントカレンダー総括
Posted 2018-12-24 15:00:00 GMT
《 Lisp メソッドコンビネーション Advent Calendar 2018 25目 》
メソッドコンビネーションでアドベントカレンダーは無謀かなと思いましたが、果してそれなりに無謀でした。
このアドベントカレンダーでの収穫は、eshamsterさんに define-method-combinationの詳細な解説を書いて頂けたことかなと思います。
今後define-method-combinationを書く際には参照することも多くなるのではないでしょうか。
メソッドコンビネーションについて分かったこと
私的にメソッドコンビネーションについて分かったことを纏めると
define-method-combinationは、Common Lispには珍しく細部仕様の詰めが甘いらしい:aroundはメソッド周囲をletで囲むような使い方をするもので、:afterや、:beforeとは一線を画す(ので同じ感覚で多用するものではなさそう)- 割とカジュアルに定義して使うことを考えていたらしい(New flavorsあたりの論文では)
- メソッドの分別の単位はメソッド修飾子。なのでクラスの継承関係とは別個に構成可能。かと思えば、メソッドコンビネーションにメソッドを参加させるためにmixinするようなことも行われていたらしい。
- メソッドの組織化全般に使える
位でしょうか。
メソッドコンビネーションは、まだまだ開拓の余地があると思いますので、今後、さらに活用されることを期待しています。
-完-
■
HTML generated by 3bmd in LispWorks 7.0.0
X3J13 88-003Rのメソッドコンビネーションを探る
Posted 2018-12-23 20:14:57 GMT
《 Lisp メソッドコンビネーション Advent Calendar 2018 24目 》
前回、MOPでのメソッドコンビネーションAPIの実現は、紆余曲折ありつつ、曖昧なところを残しているらしい、と書きました。
今回は、ANSI CLでは取り入れられなかったMOP仕様の草案である X3J13-88-003R の 1988-03-11 版にメソッドコンビネーションのAPIについての記述があったので、それを実際に動かしてみて、どのような設計方針であったのかを探ります。
なお、X3J13-88-003R の 1988-03-11版はTeXをPDFにしたものがこちらにありますので、適宜参照してください。
下準備
シンボル名の競合がありそうなので、専用のパッケージを作成します。
(defpackage X3J13-88-003R
(:use :cl :c2mop)
(:shadowing-import-from :c2mop
:defmethod :standard-class :defgeneric :standard-generic-function)
(:shadow :define-method-combination))(in-package :X3J13-88-003R)
メソッドコンビネーションクラスの定義
method-combinationのサブクラスにstandard-method-combinationとsimple-method-combinationが標準で用意されています。
ただ使い分けについてはいまいちはっきりしません。
とりあえず記述をそのままコードにしています。
(defclass x3j13-88-003r-method-combination (method-combination)
((name
:initarg :name
:reader method-combination-name)
(order
:initarg :order
:reader method-combination-order)
(operator
:initarg :operator
:reader method-combination-operator)
(identity-with-one-argument
:initarg :identity-with-one-argument
:reader method-combination-identity-with-one-argument)
(documentation
:initarg :documentation))
(:default-initargs
:name nil
:order :most-specific-first
:operator nil
:identity-with-one-argument nil
:documentation nil))(defclass standard-method-combination (x3j13-88-003r-method-combination)
())
(defclass simple-method-combination (x3j13-88-003r-method-combination)
())
(defclass short-form-method-combination (simple-method-combination) ())
ここでは、x3j13-88-003r-method-combinationをmethod-combinationのサブクラスにしていますが、恐らくこの定義が、method-combinationの定義になる予定だったのでしょう。
ANSI CLのdefine-method-combinationで指定するようなオプションが、method-combinationの方で定義されていることが分かります。
メソッドコンビネーションオブジェクトのメソッド
メソッドコンビネーション名からメソッドコンビネーションオブジェクトを引いてくるのにmethod-combination-objectを定義します。
AMOPのfind-method-combinationとほぼ同じですが、こちらは総称関数は指定しません。
中身のコードは大体想像で書いています。
(defgeneric method-combination-object (name options))(defmethod method-combination-object ((name (eql nil)) options)
(class-prototype 'standard-method-combination))
(defmethod method-combination-object ((name (eql nil)) options)
(class-prototype 'standard-method-combination))
(defmethod method-combination-object
((name (eql 'standard-method-combination)) options)
(class-prototype 'standard-method-combination))
define-method-combinationの定義
define-method-combinationは、名前を指定するだけでmethod-combination-objectを簡便に定義できるような位置付けになっています。
short-form-method-combinationが決め打ちになっているのですが、意図的なものなのか間違いなのかははっきりしません。
(defmacro define-method-combination (name &key (documentation nil)
(operator name)
(identity-with-one-argument nil))
`(defmethod method-combination-object
((name (eql ',name))
options)
(apply (lambda (&optional (order ':most-specific-first))
(check-type order (member :most-specific-first
:most-specific-last))
(make-instance 'short-form-method-combination
:name ',name
:order order
:documentation ',documentation
:operator ',operator
:identity-with-one-argument
',identity-with-one-argument))
options)))メソッド呼び出しのフォームを作るユーティリティ
make-method-callというユーティリティがあったようですが、このインターフェイスではメソッドの引数を上手く取り扱えないということで廃止になったようです。
ユーティリティが何もない現在は結局ベタ書している状況ですが、このmake-method-callを使っても大抵は問題はなさそうではあります。
なお、このコードも使用例から想像して書いています。
(defun make-method-call (method-list &key operator identity-with-one-argument)
(case operator
(:call-next-method `(call-method ,(car method-list)
,(cdr method-list)))
(ohterwise `(,operator
,@(loop :for m :in method-list :collect `(call-method ,m))))))大体これくらいの定義ですが、これだけでもメソッドコンビネーションが定義できます。
compute-effective-method
define-method-combinationは、メソッドコンビネーションオブジェクトに名前を付けて登録する程度の役割になっていましたが、代りにcompute-effective-methodが式の組み立てのメインになります。
(defmethod compute-effective-method (generic-function
(mc short-form-method-combination)
methods)
(let ((primary-methods (remove (list (slot-value mc 'name))
methods :key #'method-qualifiers
:test-not #'equal))
(around-methods (remove '(:around)
methods :key #'method-qualifiers
:test-not #'equal)))
(when (eq (slot-value mc 'order) ':most-specific-last)
(setq primary-methods (reverse primary-methods)))
(dolist (method (set-difference methods
(union primary-methods around-methods)))
(error "The qualifiers of ~S, ~:S, are not ~S or ~S"
method (method-qualifiers method)
(list (slot-value mc 'name)) '(:around)))
(make-method-call `(,@around-methods
(make-method
,(make-method-call primary-methods
:operator (slot-value mc 'operator)
:identity-with-one-argument
(slot-value mc 'identity-with-one-argument))))
:operator :call-next-method)))メソッドを定義してみる
ではメソッドを定義して動作を確認してみましょう。
総称関数の:method-combination指定が構文チェックでエラーになったりするのでensure-generic-functionを直に使ってみます。
(define-method-combination foo :operator :call-next-method)(ensure-generic-function
'zot
:lambda-list '(x)
:method-combination (method-combination-object 'foo nil))
;; ≡ (defgeneric zot (x))
;;
;; (setf (generic-function-method-combination #'zot)
;; (method-combination-object 'foo nil))
(defmethod zot foo (x) (list :p x))(defmethod zot foo ((x integer)) (list :p 'integer (call-next-method)))
(defmethod zot :around (x)
(list :around (call-next-method)))
(zot 8)
→ (:around (:p integer (:p 8))) - メソッドコンビネーション展開
(compute-effective-method #'zot
(method-combination-object 'foo nil)
(compute-applicable-methods #'zot (list 8)))
→
(call-method
#<standard-method zot (:around) (t) 41E012FF53>
((make-method
(call-method
#<standard-method zot (foo) (integer) 41E012FCDB>
(#<standard-method zot (foo) (t) 41E01306C3>))))) 上手く動いているようです。
まとめ
以上、X3J13 88-003Rでの定義でしたが、それなりにすっきり纏まっている気がします。
define-method-combinationの:argumentsオプションについては触れられていないのですが、compute-discriminating-functionの祖先の定義お眺める限りは、compute-discriminating-functionがcompute-effective-methodの内容を元に関数オブジェクトを生成する際、総称関数の引数と連結するスコープを差し込むつもりだったのかなと想像しています。
(generic-function (gf-args ...)
((lambda (args ...) ;;; define-method-combination の :arguments
,@effective-method)
gf-args ...))謎が多い、define-method-combinationまわりですが、MOPベースだったら、もうちょっとカスタマイズされたメソッドコンビネーションも活用されていたかもしれません(そうでもないか)
■
HTML generated by 3bmd in LispWorks 7.0.0
setf-expansionの返り値が憶えられない
Posted 2018-12-23 16:28:40 GMT
《 Lisp SETF Advent Calendar 2018 24日目 》
これまでも何度かget-setf-expansionや、define-setf-expanderを利用する例を取り上げてきましたが、返り値が5つもあります。
そのお蔭で、多値の何番目がなんの役割だったか毎度調べたりしていますが、これだとちょっと面倒なので、専用構文を作って開発環境のシンタックス補完等の恩恵に与る作戦を考えました。
まずは、get-setf-expansionですが、キーワード引数ならぬ、キーワード多値で値を返すことにしてみました。
(defun get-setf-expansion* (place &optional env)
(multiple-value-bind (vars vals store-vars writer-form reader-form)
(get-setf-expansion place env)
(values :vars vars
:vals vals
:store-vars store-vars
:writer-form writer-form
:reader-form reader-form)))- 素の
get-setf-expansion
(get-setf-expansion '(ldb bytespec i))
→ (#:g255423)
(bytespec)
(#:g255424)
(let ((#:|Store-Var-255422| (dpb #:g255424 #:g255423 i)))
(setq i #:|Store-Var-255422|)
#:g255424)
(ldb #:g255423 i) - 拡張した
get-setf-expansion*
(get-setf-expansion* '(ldb bytespec i))
→ :vars
(#:g255429)
:vals
(bytespec)
:store-vars
(#:g255430)
:writer-form
(let ((#:|Store-Var-255428| (dpb #:g255430 #:g255429 i)))
(setq i #:|Store-Var-255428|)
#:g255430)
:reader-form
(ldb #:g255429 i) 返り値に注釈が付けば、位置とその役割を忘れても大丈夫です。
次に、このキーワード多値を受ける構文を考えてみました。
(defmacro setf-expansion-bind
((&key vars vals store-vars writer-form reader-form)
setf-expansion-form
&body body)
(loop :for (k . v) :in `((:vars . ,vars)
(:vals . ,vals)
(:store-vars . ,store-vars)
(:writer-form . ,writer-form)
(:reader-form . ,reader-form))
:when v :collect `((,k ,v)) :into key-args
:finally (return
`(macrolet ((setf-expansion-values (&key vars vals store-vars writer-form reader-form)
`(values ,vars ,vals ,store-vars ,writer-form ,reader-form)))
(multiple-value-call
(lambda (&key ,@key-args &allow-other-keys)
,@body)
,setf-expansion-form)))))ボディの中では、setf-expansion-valuesオペレーターで注釈付きで多値を記述できるようにしてあります。
(setf-expansion-bind (:vars vars
:vals vals
:store-vars store-vars
:writer-form writer-form
:reader-form reader-form)
(get-setf-expansion* '(ldb bytespec i))
(setf-expansion-values :vars vars
:vals vals
:store-vars store-vars
:writer-form writer-form
:reader-form reader-form))
→ (#:g255477)
(bytespec)
(#:g255478)
(let ((#:|Store-Var-255476| (dpb #:g255478 #:g255477 i)))
(setq i #:|Store-Var-255476|)
#:g255478)
(ldb #:g255477 i) 記述は面倒ですが、たまにしか使わないのとキーワードによる注釈が付くので扱いやすい気がします。
ごちゃごちゃしたキーワード引数はSLIME等でまとめて補完可能なので手打ちする必要はありません。
まとめ
今回は、構文定義 & IDEでの補完 の組み合わせで考えてみましたが、get-setf-expansionのフォームをmultiple-value-bindのフォームで包むような補完ができるIDEの拡張を作ってみても良いかなと思ったりしています。
■
HTML generated by 3bmd in LispWorks 7.0.0
setf系便利構文紹介
Posted 2018-12-23 11:08:45 GMT
《 Lisp SETF Advent Calendar 2018 23日目 》
あと三回setfネタで記事を書かないといけないのですが、何が書けるでしょうか。
とりあえず、今回はsetfのような代入構文をさらに便利にしたような構文を紹介してみたいと思います。
自己代入系
これまで自己代入系の定義構文を紹介したりしましたが、都度定義するのではなく、汎用的なものを定義して使う、というパターンです。
Gauche: update!
(update! place proc)という形式ですが、incfみたいなものは、
(let ((x (list 0)))
(update! (car x) (lambda (v) (+ v 1)))
x)
→ (1)と書けます。
define-modify-macroで一々定義するよりずっと良いですね。
Arc: zap
Gaucheのupdate!とほぼ同じです。引数の順番と名前が違う位です。
(let x (list 0)
(zap (fn (v) (+ v 1))
(car x))
x)
→ (1)TAO/ELIS: !!
以前も紹介しましたが、TAOの!!は自己代入専用の構文です。
!で印を付けた場所に書き戻せます。
(let ((x (list 0)))
(!!(lambda (v) (+ v 1)) !(car x))
x)≡
(let ((x (list 0)))
(!!1+ !(car x))
x)
その他便利なユーティリティ
私見ではPaul Graham氏は面白い代入系ユーティリティを定義しているので、2、3眺めてみます。
Arc: pull
Common Lispのremove-ifとsetf`を組合せた感じです。
(let x '(1 100 2 50 3)
(pull [< _ 10] x) x)
→ ((100 50) foo) pushend
pushは先頭に追加なので末尾に追加したい場合に使えます
(let ((x (list 0 1 2)))
(pushend 100 x)
x)
→ (0 1 2 100) merge-into
述語で場所を探してマージします。
(let ((x (list 0 1 2 0 0 0 8 2 -1)))
(merge-into x 5 #'<)
x)
→ (0 1 2 0 0 0 5 8 2 -1) 元定義は下記のような感じですが、define-modify-macroでlambda式を取れるのは処理系拡張なので、可搬的に書くならdefmacroで定義する必要があるでしょう。
しかしdefine-modify-macro版だとpushendの定義のnconcがすっぽ抜け問題が発生しそうな見た目が気持ち悪いですが、define-modify-macroの展開ではplaceに代入し直されるので大丈夫です。
;;; http://lib.store.yahoo.net/lib/paulgraham/utx.lisp
(define-modify-macro pushend (obj)
(lambda (place obj)
(nconc place (list obj))))(define-modify-macro merge-into (obj fn)
(lambda (place obj fn)
(merge 'list place (list obj) fn)))
- 可搬的
(defmacro pushend (obj place)
(let ((p (gensym)))
`(let ((,p ,place))
(setf ,p (nconc ,p (list ,obj))))))
(defmacro merge-into (place obj fn)
(let ((p (gensym)))
`(let ((,p ,place))
(merge 'list ,p (list ,obj) ,fn))))
まとめ
setf系の便利構文を紹介してみました。
色々定義してみるもの面白いかなと思います。
■
HTML generated by 3bmd in LispWorks 7.0.0
MOPでメソッドコンビネーションの仕組みを実装してみよう
Posted 2018-12-23 10:44:01 GMT
《 Lisp メソッドコンビネーション Advent Calendar 2018 23目 》
先日、Common Lispのメソッドコンビネーションの実現具合とAMOPでの実現に結構な差異があると書きましたが、今回は、define-method-combinationを使わないでMOP中心でメソッドコンビネーションを定義するとどんな感じになるか、を確かめてみたいと思います。
とりあえず、Common LispとAMOP近辺のメソッドコンビネーションを実現方式を調べてみると5つ位バリエーションがみつかりました。
- ANSI Common Lisp
- Closer to MOP
- X3J13-88-003R Metaobject Protocol (Draft)
- AMOPの本文、Closetteの実装
- 各処理系の実装
まず、X3J13-88-003R Metaobject Protocolは草稿どまりですが、AMOPの流儀をベースにしつつも最適化についても考慮していたようなので複雑になっています。
また、define-method-combinationというFlavorsの流れも、MOP上に統合しようとしていたようですがこれも未完です。
次に、ANSI CL規格は、X3J13-88-003Rで練られていた事項を踏まえつつ、MOPの詳細については踏み込まない、という感じになっています。
AMOPの本文、Closetteの実装、は一つの理想形で、ANSI CL規格との兼ね合いのような瑣末なことは考慮されていません(先行しているので当然)
また、各処理系の実装は、概観するとAMOPに準拠しようとしつつ、参照実装の挙動が仕様だ、という感じになっています。
しかし参照実装とはいえ、Portable CommonLoopsの実装が仕様に準拠していない所もあり、その辺りのあやふやさは現在にも受け継がれています。
Closer to MOPは、AMOPの内容を現在メジャーなANSI Common Lisp処理系の上にポータブルな仕様と実装を実現しようとしたものです。
メソッドコンビネーションの枠組み作成
とりあえず、MOP的にメソッドコンビネーションの枠組みを作成してみましょう。
仕様は色々ありますが、compute-effective-methodがメソッドの集合を指定されたメソッドコンビネーションに応じでフォームを組み立てる、というのは共通しています。
なお、以下では、Closer to MOPを利用します。
(ql:quickload :closer-mop)総称関数の定義
標準では、define-method-combination経由でしかメソッドコンビネーションを定義できないので、総称関数ごと別に作成します。
(defclass mcacgf (standard-generic-function)
()
(:metaclass funcallable-standard-class))メソッドコンビネーションクラスの定義
ANSI CLには、method-combinationクラスが定義されているのですが、使い方やスロットの詳細は曖昧なままです。
X3J13-88-003Rでは、サブクラスにstandard-method-combinationとstandard-simple-method-combinationを定義しているようです。
この流儀に沿っているLispWorksのような実装もある様子。
とりあえずは標準のもののサブクラスにします。
(defclass ac-method-combination (method-combination) ())メソッドコンビネーションの配置生成定義
effective-methodというとメソッドオブジェクト(メタオブジェクト)っぽいのですが、どうも式(メタプログラム)を指しているようです。
compute-effective-methodが式を生成するので、ここで直接書き下してしまえばOKです。
下記では、単純にするために:aroundなしのstandardにしています。
(Flavorsでいうdaemon)。
define-method-combination構文の便利機能を使わず手書きしている、という感じですね。
(defmethod c2mop:compute-effective-method ((gf mcacgf)
(mc method-combination)
(methods list))
(loop :for m :in methods
:for mq := (method-qualifiers m)
:when (equal '(:before) mq) :collect `(call-method ,m) :into bs
:when (equal nil mq) :collect m :into ps
:when (equal '(:after) mq) :collect `(call-method ,m) :into as
:finally (return `(multiple-value-prog1
(progn (progn :before-daemons ,@bs)
:primaries
(call-method ,(car ps) (,@(cdr ps))))
(progn :after-daemons ,@as)))))メソッドコンビネーション名の登録
defgenericの:method-combinationオプションで指定できるように登録します。
しかし、find-method-combinationが実装されていない処理系もあるので、フックできないかもしれません(LispWorks等)
(defmethod c2mop:find-method-combination
((gf mcacgf) (type (eql 'mcac)) opts)
(make-instance 'ac-method-combination));;; LispWorksではしょうがないのでテーブルに直に登録
(setf (gethash 'mcac clos::*method-combination-types*)
(make-instance 'ac-method-combination))
動かしてみる
(defgeneric foo (x)
(:generic-function-class mcacgf)
(:method-combination mcac))(defmethod foo (x) x)
(defmethod foo :after (x)
(print (list :after x)))
(defmethod foo :before (x)
(print (list :before x)))
(foo 42)
▻ (:before 42)
▻ (:after 42)
→ 42
- メソッドコンビネーション展開
(c2mop:compute-effective-method #'foo
(make-instance 'ac-method-combination)
(compute-applicable-methods #'foo (list t)))
→ (multiple-value-prog1
(progn
(progn
:before-daemons
(call-method #<standard-method foo (:before) (t) 40E0460B83>))
:primaries
(call-method #<standard-method foo nil (t) 40E042A5EB> nil))
(progn
:after-daemons
(call-method #<standard-method foo (:after) (t) 40E0429F9B>)))困った所
define-method-combinationオプションの:argumentsのサポートが鬼門なのですが、
- まともに実装している処理系がないっぽい
- MOPでどうするか文献がない
等で、MOPで:argumentsをサポートする場合、どういうAPI構成で書くべきなのか良く分かりません。
ANSI CL規格では、effective method中に展開されるとありますが、このあたりも処理系によって挙動がまちまちのようです。
まとめ
とりあえず、define-method-combinationを経由しないでメソッドコンビネーションを定義してみました。
define-method-combinationのマイナーな機能/オプションについてはCommon Lispの仕様が中途半端なせいか、どうやら忠実に実装できているは処理系がなさそうです。
SICL等は綺麗なCommon Lispを目指しているようなので、今後はSICLあたりも参照してみようかなと思います。
■
HTML generated by 3bmd in LispWorks 7.0.0
setfとメソッドコンビネーションについて掘り下げる
Posted 2018-12-22 10:49:25 GMT
《 Lisp メソッドコンビネーション Advent Calendar 2018 22目 》
《 Lisp SETF Advent Calendar 2018 22日目 》
これまで、メソッドコンビネーションで19記事、setfで17記事程書いてきましたが、もう書くことがないです。
setfでメソッドコンビネーション活用について書けば、一挙両得なのでは!、と考えこのネタでひとつ考えてみたいと思います。
setfとメソッドコンビネーション
まず、setfでメソッドコンビネーションの活用が成立する為には、どう考えてもスロットのライタである必要があります。
(defclass foo ()
((x :initarg :x :accessor x :writer (setf x/))))(defvar *foo* (make-instance 'foo :x 42))
(x *foo*)
→ 42
(setf (x/ *foo*) 69)
(x *foo*)
→ 69
クラスのスロット定義で、スロットに対して複数のアクセサ総称関数が定義可能ですが、setfが関係するのは、:accessorか、:writterオプションになります。
defclassで定義するアクセサは、デフォルトではstandardになることが規格で定まっています。
そのため、メソッドコンビネーションを指定したい場合は、defclassでアクセサは作らず、別途定義することになると思われます。
試してみましょう
(defgeneric (setf x-list) (val o)
(:method-combination list))(defmethod (setf x-list) list (val (o foo))
(setf (c2mop:slot-value-using-class (class-of o) o 'x) val)
val)
(defclass bar (foo) ())
(defmethod (setf x-list) list (val (o bar))
(setf (c2mop:slot-value-using-class (class-of o) o 'x) val)
val)
(defvar *bar* (make-instance 'bar :x 42))
(x *bar*)
→ 42
(setf (x-list *bar*) 69)
→ (69 69)
(x *bar*)
→ 69
上記では、listメソッドコンビネーションを実行し代入の返り値をリストにして返しています。
これは、standardメソッドコンビネーション以外で、役に立ちそうな例を考えるのが難しい……。
setfに関しては、実行前後のフック(daemonメソッドコンビネーション)か、乗っ取り(around)があれば十分そうですね(即ちstandardメソッドコンビネーション)
通常は、同一の値を同一スロットに複数回書き込む挙動は求められていないということからもprogn等で有用なことはできなさそうです。
MOPで
(defclass foo ()
((x :initarg :x :accessor x :accessor-method-combination progn)))のように書けるようにすることも検討してみましたが、これも微妙
一応役に立つ例も紹介
メソッドコンビネーションのカスタマイズの方向で書いてしまいましたが、standardとsetfの組み合わせであれば、値の設定前後のフックとして有用な使い方が可能です。
- 事前事後の値チェック(
:before、:after) - 副作用目的での手続の差し込み(
:before、:after) - 乗っ取りで、アクションを加えたり元動作を削除してしまったり(
:around)
(defmethod (setf x/) :after (val (foo foo))
(write-line "こんにちは"))(setf (x/ *foo*) 42)
▻ こんにちは
→ 42
(defmethod (setf x/) :before (val (foo foo))
(check-type val integer))
(setf (x/ *foo*) 'foo)
>>> error
(defmethod (setf x/) :around (val (foo foo))
nil)
(setf (x/ *foo*) 'foo)
→ nil
まとめ
リーダーもを含めたアクセサ全般と、メソッドコンビネーションの組み合わせでは何か有用なことも可能かもしれませんが、setfのライタ限定となると、デフォルトのstandardが必要にして十分だった、ということがわかりました。
■
HTML generated by 3bmd in LispWorks 7.0.0
メソッドコンビネーションとMOPの関係を整理する
Posted 2018-12-21 17:41:46 GMT
《 Lisp メソッドコンビネーション Advent Calendar 2018 21目 》
もうメソッドコンビネーションについて書くことがないので、深刻なネタ不足、準備不足と格闘しておりますが、このあたりでMOPとメソッドコンビネーションについて整理してみましょう。
Common Lispの場合
Common Lispの場合というか、MOPがあって、メソッドコンビネーションもあるというのはCommon Lisp位しか存在しないですが……。
まず、MOPはANSI Common Lisp規格外です。
MOPをサポートする処理系があっても良くて、それの場合はAMOP(The Art of the Metaobject Protocol)が拠り所になるでしょう程度の微妙な距離感になっています。
しかし実際にはANSI Common Lispの処理系の殆どが上述のAMOPの仕様を元にある程度互換性のあるMOPを組んで提供しています。
といってもAMOP自体、ANSI Common Lispの規格程かっちり規定できてはいないので、処理系ごとに差異はあり、その差異を埋めようというライブラリがCloser to MOPになります。
MOPの前置きが長くなりましたが、メソッドコンビネーションを定義するdefine-method-combinationはANSI Common Lisp規格で定義されているものでMOPのサポートを前提とはしていません。
メソッドを配置するコードを定義するのが、define-method-combinationですが、配置定義をしているだけで、定義に従ってあれこれするのは処理系依存です。
また、仮にMOPが存在することを前提に考えても、define-method-combinationにMOP的にオーバーライドできるフックポイントがあるわけでもないのでMOPという感じもあまりないかなと思います(MOPを前提としないデザインなので当たり前かもしれません)
たまに、Common LispのメソッドコンビネーションはMOPでカスタマイズする/可能、と説明している人がいますが、ちょっと違うかなと思います。
もしかすると、AMOPでメソッドコンビネーションを実現するのに、define-method-combinationは使わず、MOPの観点からapply-methodや、compute-effective-method-functionというものを定義して、これで解説してみせているのでCommon Lispもそうなっていると誤解していたりするのかもしれません。
実際の所は、メソッドコンビネーションはMOPがないFlavorsにもありますし、別個の概念と考えた方が良いでしょう。
AMOPはメソッドコンビネーションをMOPで実装してみせた例で、メソッドコンビネーションの追加等のカスタマイズはメソッドのオーバーライドで行う等、MOP的です。
Common Lispのメソッドコンビネーションの処理とMOP
Common Lisp場合のMOPとメソッドコンビネーションの兼ね合いですが、
define-method-combinationでメソッド配置を定義(コード生成の定義)compute-effective-methodがコード生成の定義と、総称関数、メソッド、メソッドコンビネーションの各メタオブジェクトからコード(effective-method)を生成effective-methodはcompute-discriminating-functionが総称関数の関数を作るのに使う
(defmethod foo (x) x)
(defmethod foo :after (x) x)(set 'ms (compute-applicable-methods #'foo '(8)))
→ (#<standard-method foo (:after) (t) 402053A353>
#<standard-method foo nil (t) 402052BAEB>)
(set 'mc (c2mop:find-method-combination #'foo 'standard nil))
→ #<clos::standard-method-combination standard 41A10AAD3B>
(c2mop:compute-effective-method #'foo mc ms)
→
(multiple-value-prog1
(call-method #<standard-method foo nil (t) 411000E97B> nil)
(call-method #<standard-method foo (:after) (t) 411000E773> nil))
となっています。
ちなみに、AMOPでは、
- メソッドコンビネーションごとに、総称関数をサブクラス化する。補助メソッドの特定にはメソッド修飾子を利用。
compute-applicable-methods-using-classesがメソッドを集めてくる- メソッド群を起動する
apply-methods(もしくは効率改善のcompute-effective-method-function)をオーバーライドして、メソッドの起動の組織化をカスタマイズ可能。補助メソッドは特定できるので任意に選別し配置可能。
となっていて、上に述べたように、よりMOP的になっています。
下記のコードはclosetteの例ですが、std-compute-effective-method-functionというコード生成のメソッドになっているもののAMOPのcompute-effective-method-functionと同様の雰囲気です。
(defun std-compute-effective-method-function (gf methods)
(let ((primaries (remove-if-not #'primary-method-p methods))
(around (find-if #'around-method-p methods)))
(when (null primaries)
(error "No primary methods for the~@
generic function ~S." gf))
(if around
(let ((next-emfun
(funcall
(if (eq (class-of gf) the-class-standard-gf)
#'std-compute-effective-method-function
#'compute-effective-method-function)
gf (remove around methods))))
#'(lambda (args)
(funcall (method-function around) args next-emfun)))
(let ((next-emfun (compute-primary-emfun (cdr primaries)))
(befores (remove-if-not #'before-method-p methods))
(reverse-afters
(reverse (remove-if-not #'after-method-p methods))))
#'(lambda (args)
(dolist (before befores)
(funcall (method-function before) args nil))
(multiple-value-prog1
(funcall (method-function (car primaries)) args next-emfun)
(dolist (after reverse-afters)
(funcall (method-function after) args nil))))))))まとめ
Common Lispは、AMOPの記述を基準にするなら、結構Flavors寄りということなのかもしれません。
AMOP的にメソッドコンビネーション定義をするならば、compute-effective-methodをオーバーライドすることになるかなと思います。
ネタ切れなので、AMOP版メソッドコンビネーションを実装してみるかもしれません。
■
HTML generated by 3bmd in LispWorks 7.0.0
setfで自己代入
Posted 2018-12-19 20:05:20 GMT
《 Lisp SETF Advent Calendar 2018 20日目 》
今回は、Pythonや、Rubyにある自己代入構文をsetfで再現してみようかなと思います。
自己代入構文とは
a = a + bをa += bと書ける構文ですが、起源はCなのでしょうか。
aが二回評価されないので効率が良いなんていう話もあるようです。
setfで再現してみる
それではとりあえず、(setf (op a) b)の形式で定義してみましょう。
下記では、標準のオペレーターと名前が被るのでパッケージを別にしています。
(defpackage :self-assignment
(:use :cl)
(:shadow "+" "-" "/" "//" "OR" "AND"))(in-package :self-assignment)
(defmacro define-self-assignment-setf (op fn)
`(define-setf-expander ,op (place)
(multiple-value-bind (dv v sv setter getter)
(get-setf-expansion place)
(values dv
v
sv
`(let ((,@sv (,',fn ,getter ,@sv)))
,setter)
getter))))
(define-self-assignment-setf + cl:+)
(define-self-assignment-setf - cl:-)
(define-self-assignment-setf / cl:/)
(define-self-assignment-setf // cl:floor)
(define-self-assignment-setf % cl:mod)
(define-self-assignment-setf or cl:or)
(define-self-assignment-setf and cl:and)
試してみる
(let ((a 100) (b 42))
(setf (+ a) b) a)
→ 142 (let ((a 100) (b 42))
(setf (- a) b) a)
→ 58
(let ((a 100) (b 42))
(setf (/ a) b) a)
→ 50/21
(let ((a 100) (b 42))
(setf (// a) b) a)
→ 2
(let ((a 100) (b 42))
(setf (% a) b) a)
→ 16
(let ((a 100) (b 42))
(setf (or a) b) a)
→ 100
(let ((a (list (list 100))) (b 42))
(setf (and (caar a)) b) a)
→ ((42))
まとめ
Common Lispにはincf、decfがありますが、自己代入のようなものは、(setf place)で考えた場合、placeっぽくないので、define-modify-macroで定義するのがCommon Lisp流だなあ、と作ってみてから思ったりです。
■
HTML generated by 3bmd in LispWorks 7.0.0
Quicklispのライブラリのメソッドコンビネーションを眺めてみよう
Posted 2018-12-19 18:37:02 GMT
《 Lisp メソッドコンビネーション Advent Calendar 2018 20日目 》
これまでメソッドコンビネーションの定義方法の解説や実際に定義してみたりをしていましたが、メソッドコンビネーションが実際にはどのように使われているかをQuicklispのライブラリ中から探して眺めてみましょう。
method-versions
メソッドコンビネーション: method-version-method-combination
メソッド修飾子でメソッドのバージョンを表現したというもの。
確かにメソッドのまとまりをメソッドコンビネーションの枠組みを使えばバージョンごとに起動したりの管理ができます。
なかなか面白いアイデアですね。
clweb
メソッドコンビネーション: join-strings
文字列を連結するメソッドコンビネーションのようです。
大分限定された使い方ですが、appendやnconcも標準にありますし、そんな感じの気分なのでしょう。
mcclim
メソッドコンビネーション: values-max-min
標準でmin、maxはありますが、多値で両方を返してくるというものです。
chanl
メソッドコンビネーション: select
CSPライブラリのchanlですが、プロセスの制御をメソッドコンビネーションで表現しているようです。
並列処理とメソッドコンビネーションで色々探してみたのですが、chanlで使われていたとは。
修飾子にsend、recv がありますが、結構活用している事例かもしれません。
3b-swf
メソッドコンビネーション: swf-part
swfファイル生成ライブラリですが、daemon各々を:most-specific-lastで起動するもののようです。
serapeum / arnesi
standard/context / wrapping-standard
もとネタは、Tim Bradshaw氏のwrapping-standardメソッドコンビネーションのようです。
standardメソッドコンビネーションの周囲を:wrap-aroundでさらに囲みます(serapeumでは:context)
:wrap-aroundはデフォルトでは、:aroundと逆順の:most-specific-lastです。
filtered-functions
filtered-functionsをメソッドコンビネーション活用の方向から眺めてみましたが、どちらかというと、メソッドコンビネーションより前の段階に工夫がある感じでした。
filtered-functionsについては過去に紹介記事がありますので、そちらをどうぞ。
method-combination-utilities
primary / lax / basic / append/nconc
メソッドコンビネーション定義のためのユーティリティと、有用そうなメソッドコンビネーション定義のライブラリです。
すっかり忘れていましたが、過去に紹介記事も書いていました。
このブログでもmc-expandのようなものを定義していましたが、method-combination-expandみたいなものも定義されています。
メソッドコンビネーションを活用するなら試してみて損はなさそうなユーティリティです。
しかし、LispWorksで動かない様子(PR出そうかな)
まとめ
案外使う人はカジュアルに使っている様子。
メソッドコンビネーションを学んで活用しましょう!
■
HTML generated by 3bmd in LispWorks 7.0.0
メソッドコンビネーションでD風の契約プログラミング: その2
Posted 2018-12-19 12:47:24 GMT
《 Lisp メソッドコンビネーション Advent Calendar 2018 19日目 》
メソッドコンビネーションでD風の契約プログラミング: その1の続きですが、前回は、不変条件をメソッドコンビネーションでどう組むかというところまででした。
Dでは、不変条件は、クラス内でinvariantで定義され、
- すべてのコンストラクタの末尾
- デストラクタの冒頭
- メソッドの冒頭と末尾
に設置されるらしいです。
総称関数でこれをどう表現するかというところですが、
- すべてのコンストラクタの末尾 ⇒ スロットアクセスチェックを
:afterで起動? - デストラクタの冒頭 ⇒
clange-classで起動? - メソッドの冒頭と末尾 ⇒ 総称関数なのでスロットアクセスチェックで良いでしょう
位になるでしょうか。
定義してみる
とりあえず、こんなdateクラスがあったとして、
(defclass date ()
((year :initarg :year :accessor year)
(month :initarg :month :accessor month)
(day :initarg :day :accessor day))
(:default-initargs :year 1900 :month 1 :day 1))(make-instance 'date)
→ #<date 402026FA73>
invariantメソッドが差し込んで使うようなメソッドコンビネーションを定義します。
andと同じような感じですが、基底クラスから順に適用してandの関係になるようにするので、継承順をreverseし、同じクラスに複数のメソッドを付けたいので、修飾子をワイルドカードにしました。
(define-method-combination invariant ()
((pri *))
`(and ,@(loop :for m :in (reverse pri) :collect `(call-method ,m))))これで、dateのスロットについてinvariantメソッドで不変条件を記述します。
(defmethod invariant year ((date date))
(etypecase (year date)
(integer T)))(defmethod invariant month ((date date))
(etypecase (month date)
((integer 1 12) T)))
(defmethod invariant day ((date date))
(etypecase (day date)
((eql 29) (or (/= 2 (month date))
(leap-year-p (year date))))
((eql 30) (/= 2 (month date)))
((eql 31) (typep (month date) '(member 1 3 5 7 8 10 12)))))
このinvariantをスロットに取り付けます。
(defmethod c2mop:slot-value-using-class ((date-class standard-class)
(date date)
slot)
(invariant date)
(multiple-value-prog1
(call-next-method)
(invariant date)))
(defmethod (setf c2mop:slot-value-using-class)
(value (date-class standard-class) (date date) slot)
(invariant date)
(multiple-value-prog1
(call-next-method)
(invariant date)))
これだけでいけるかなと思ったのですが、
(make-instance 'date :year 100 :month 2 :day -2)
→ #<date 4020118C13> あれ……?
インスタンス生成もチェックする
インスタンス生成はslot-value-using-classはスルーする(かもしれない)ようなので、clange-classのことも考えて、shared-initializeにinvariantを設置しました(もうちょっと細かく設定した方が良いかもしれません)
(defmethod shared-initialize :after ((date date) slots &key)
(invariant date))これで生成系はエラーにできます。
(make-instance 'date :year 100 :month 2 :day -2)
>>> error(defclass date2 ()
((year :initform 1900 :initarg :year :accessor year)
(month :initform 1 :initarg :month :accessor month)
(day :initform 1 :initarg :day :accessor day)))
(change-class (make-instance 'date2 :year 100 :month 2 :day -2)
'date)
>>> error
invariantメソッドコンビネーションの展開はこんな感じになります
(defclass datetime (date)
((hour :initarg :hour :accessor hour)
(minute :initarg :minute :accessor minute)
(second :initarg :second :accessor sec))
(:default-initargs :hour 0 :minute 0 :second 0))(defmethod invariant hour ((dt datetime))
(etypecase (hour dt)
((integer 0 24) T)))
(defmethod invariant minute ((dt datetime))
(etypecase (minute dt)
((integer 0 59) T)))
(defmethod invariant second ((dt datetime))
(etypecase (sec dt)
((integer 0 59) T)))
(mc-expand #'invariant
'invariant
nil
(make-instance 'datetime))
→
(and (call-method #<standard-method invariant (year) (date) 41602356B3>)
(call-method #<standard-method invariant (month) (date) 40D035A8B3>)
(call-method #<standard-method invariant (day) (date) 40D035A113>)
(call-method #<standard-method invariant (hour) (datetime) 40D04205BB>)
(call-method #<standard-method invariant (minute) (datetime) 402025F913>)
(call-method #<standard-method invariant (second) (datetime) 402027434B>))
これらinvariantを付加する作業をどうにかまとめたいのですが、MOPを使うかマクロて手続きを纏めるか悩む所です。
invariant手続きをdefclassで指定した方が良さそうなので、MOPになりそうです。
■
HTML generated by 3bmd in LispWorks 7.0.0
たまに便利な(setf apply)/(setf values)
Posted 2018-12-19 10:04:13 GMT
《 Lisp SETF Advent Calendar 2018 19日目 》
今回は、たまに便利な(setf apply)/(setf values)を解説してみたいと思います。
(setf values) | VALUES Forms as Places
(setf values)はそこそこ使われているかと思いますが、Common Lisp(1984)の時代から知識の更新がない年配の方々がmultiple-value-setqしか知らないような場面に遭遇することもままあります。
(古い書籍で勉強してしまったので知らなかった、ということもあります)
multiple-value-setq的な使い方
(let (q r)
(setf (values q r) (floor 1 2))
(list q r))
→ (0 1) psetq、psetf的な使い方
(let ((a 0) (b 1))
(setf (values a b) (values b a))
(list a b))
→ (1 0) (setf values)は他のsetfの場所と複合できるのも便利です
(let ((x (list 0 1)))
(setf (values (car x) (cadr x))
(values (cadr x) (car x)))
x)
→ (1 0) (setf apply) | APPLY Forms as Places
こちらは、Common Lisp(1984)からありますが、配列を多用する人以外は使う機会もないからか、それほど知られていない機能です。
添字のリストだけあって、それを適用したい、ということはあるのですが、(setf apply)とarefを組合せれば可能です。
(let ((subs (list 2 1 0)))
(setf (apply #'aref *a* subs) 42)
*a*)
→
#3A(((0 0 0) (0 0 0) (0 0 0))
((0 0 0) (0 0 0) (0 0 0))
((0 0 0) (42 0 0) (0 0 0))) 規格では、aref、bit、sbitと(setf apply)の組合せは保証されていますが、他は、処理系依存です。
というのも、(setf fn)は必ずしも関数である必要はないためで、マクロで実装されている場合、applyできない、ということになるからです。
ユーザー定義の#'(setf fn)関数であれば、applyが適用できるので(setf apply)も可能です。
まとめ
(setf values)はもっと知られても良いかなと思っています。
ANSI Common Lispと、それ以前のCLtL2、CLtL1は結構違ってますので、仕様の参照/勉強では、ANSI Common Lisp規格を元にした文献を参照しましょう。
■
HTML generated by 3bmd in LispWorks 7.0.0
マクロ展開でもメソッドコンビネーション
Posted 2018-12-18 15:32:33 GMT
《 Lisp メソッドコンビネーション Advent Calendar 2018 18日目 》
メソッドコンビネーションでD風の契約プログラミングの続きを書こうと思いましたが、準備が間に合わないので、思い付きでマクロでもメソッドコンビネーションというネタを書きます。
ANSI Common LispにはAdviceはありませんが、処理系拡張でdefadviceのようなものでadviceを定義することが可能だったりします。
adviceは関数だけでなく、マクロやメソッドにも付けられたりしますが、LispWorksでマクロのadvice定義を利用した例は、こんな感じです。
(defmacro mydefun (name (&rest args) &body body)
`(defun ,name (,@args) ,@body))
(defadvice (mydefun inline :around) (form env)
(destructuring-bind (def name args &body body)
form
(declare (ignore def args body))
`(progn
(declaim (inline ,name))
,(call-next-advice form env))))
(mydefun foo (n) n)
;===> (PROGN (DECLAIM (INLINE FOO)) (DEFUN FOO (N) N))
標準では、マクロの展開関数は関数なので拡張できないのですが、メソッドにして、好きなメソッドコンビネーションを指定してしまえば良い!ということで、マクロ展開メソッドでメソッドコンビネーションです。
雑ですが、こんな感じに書いてみました。
(defmacro defmacro* (name-&-method-qualifiers (&rest args) &body body)
(destructuring-bind (name &rest method-qualifiers)
(if (consp name-&-method-qualifiers)
name-&-method-qualifiers
(list name-&-method-qualifiers))
(let ((form (gensym "form-"))
(env (gensym "env-"))
(xn (or (get name :expander)
(setf (get name :expander)
(make-symbol (string name))))))
`(eval-when (:compile-toplevel :load-toplevel :execute)
(defmethod ,xn ,@method-qualifiers (,form ,env)
(macrolet ((call-next-expander (&rest args)
`(call-next-method ,@args)))
(destructuring-bind (,name ,@args)
,form
(declare (ignore ,name))
,@body)))
(setf (macro-function ',name)
#',xn)))))deという名前でdefunのエイリアス的なものを定義してみる
(defmacro* de (name (&rest args) &body body)
`(defun ,name (,@args) ,@body))(de foo (n) (list n n))
===>
(defun foo (n) (list n n))
de周囲をeval-whenで囲みたくなった
(defmacro* (de :around) (name (&rest args) &body body)
`(eval-when (:compile-toplevel :load-toplevel :execute)
,(call-next-expander)))(de foo (n) (list n n))
===>
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun foo (n) (list n n)))deの定義は全部無効にしたくなった
(defmacro* (de :around) (name (&rest args) &body body)
nil)(de foo (n) (list n n))
===> nil
雑なのでメソッドの良さを全然活かせてないですが、使いようによっては便利なこともあるかも、と少しだけ思いました。
■
HTML generated by 3bmd in LispWorks 7.0.0
拡張setf定義を眺める: 解構篇
Posted 2018-12-17 21:05:17 GMT
《 Lisp SETF Advent Calendar 2018 18日目 》
今回は、処理系拡張のsetfのうち解構系の拡張を眺めてみたいと思います。
destructuringの邦訳語はいまいち一定しない感がありますが、中華圏では、ほぼ、解構で通っているようです。
- 例: 解構賦值 | MDN
解構は短くて意味の通りも良い気がするので、本記事では、解構で通します。
(しかし流行らなそうな言葉の響き……)
解構拡張のsetfとは
setfの場所で解構を使うという拡張です。
Lisp Machine Lispには標準装備だったみたいですが、Common Lispで実装している処理系はないかもしれません。
ということで、以下は、Lisp Machine Lispでの例の紹介です。
(Common Lispでも定義はできます)
(setf list)
これまで、左辺値についてCPLを調べたりもしましたが、CPLは左辺にリスト構文が取れたりしました。
x, y, z := 0, 1, 2これをそのままsetfで書いた感じです。
(let (x y z)
(setf (list x y z) '(0 1 2))
(list x y z))
→ (0 1 2)(setf cons) / (setf list*)
cons、list*も使えます。
(let (x y)
(setf (cons x y) '(0 1 2))
(list x y))
→ (0 (1 2))(let (x y z)
(setf (list* x y z) '(0 1 2))
(list x y))
→ (0 1 (2))
(setf `(,foo ,@bar))
バッククォート式も使えます。
但し、appendの形には対応していないので、,@はリストの最後の部分にしか使えません。
(let (x y)
(setf `(,x ,@y) '(0 1 2))
(list x y))
→ (0 (1 2))(let (x y z)
(setf `(,x ,y ,@z) '(0 1 2))
(list x y))
→ (0 1 (2))
appendの形には対応していないものの、入れ子にすることは可能です。
(let (a b c d e f)
(setf `(,a (,b (,c ,@d) ,e ,@f))
`(a (b (c d d d) e f f f)))
(list a b c d e f))
→ (a (b (c (d d d) e (f f f))))list、list*、consも同様
(let (a b c d e f)
(setf (list (list* (cons c d) e f))
`(a (b (c d d d) e f f f)))
(list a b c d e f))
→ (a (b (c (d d d) e (f f f))))まとめ
setfとバッククォートの組み合わせはなかなか良いんじゃないかと思うのですが、実際の所、あってもそんなに利用頻度は高くなさそうですね。
■
HTML generated by 3bmd in LispWorks 7.0.0
メソッドコンビネーションでD風の契約プログラミング: その1
Posted 2018-12-17 14:20:30 GMT
《 Lisp メソッドコンビネーション Advent Calendar 2018 17日目 》
契約プログラミングをメソッドコンビネーションを表現するネタは既にあるのですが、
もうちょっと簡潔に書けそうな気がしてきたので、試しにD風の契約プログラミングの仕組みを書いてみることにしました。
Dには契約プログラミングが組み込み機能ですが、in節で事前条件のチェック、body節は本体、out節で事後条件をチェックするようになっています。
継承がからんだ場合は、事前条件は、基底クラスから条件をorのでチェック、事後条件は、基底クラスからandでチェック、のようです。
out節で返り値を受け取ってチェックするというのをどう表現するのか厄介ですが、outはチェック関数を返して、プライマリの返り値をチェックすることにしました。
(define-method-combination ddbc ()
((in* (:in))
(out* (:out))
(pri* () :required T))
(let ((results (gensym "results-")))
`(progn
(or ,@(loop :for in :in (reverse in*) :collect `(call-method ,in))
(error "in"))
(let ((,results (multiple-value-list (call-method ,(car pri*) ,(cdr pri*)))))
(declare (dynamic-extent ,results))
(or (and ,@(loop :for out :in (reverse out*) :collect `(apply (call-method ,out) ,results)))
(error "out"))
(values-list ,results)))))これでこんな風に書くと、
(defgeneric integer->integer->integer (x y)
(:method-combination ddbc))(defmethod integer->integer->integer :in ((x number) (y number))
(and (integerp x)
(integerp y)
(not (zerop y))))
(defmethod integer->integer->integer ((x number) (y number))
(/ x y))
(defmethod integer->integer->integer :out ((x integer) (y integer))
#'integerp)
こんなメソッドコンビネーション展開になります
(mc-expand #'integer->integer->integer 'ddbc nil 1 2)
→
(progn
(or (call-method
#<standard-method integer->integer->integer (:in) (number
number) 414009E67B>)
(error "in"))
(let ((#:|results-166692|
(multiple-value-list (call-method
#<standard-method integer->integer->integer nil (number
number) 414009E45B>
nil))))
(declare (dynamic-extent #:|results-166692|))
(or (and (apply (call-method
#<standard-method integer->integer->integer (:out) (integer
integer) 40202D35A3>)
#:|results-166692|))
(error "out"))
(values-list #:|results-166692|)))実行してみます
(defmacro run (form)
"結果確認用ユーティリティ"
`(multiple-value-bind (ans error)
(ignore-errors ,form)
`(,',form :result ,ans :error
,(and error
(format nil
(simple-condition-format-control error)
nil
(simple-condition-format-arguments error))))))(list
(run (integer->integer->integer 1 8))
(run (integer->integer->integer 1 0))
(run (integer->integer->integer 10 2))
(run (integer->integer->integer 10 1/2)))
→
(((integer->integer->integer 1 8) :result nil :error "out")
((integer->integer->integer 1 0) :result nil :error "in")
((integer->integer->integer 10 2) :result 5 :error nil)
((integer->integer->integer 10 1/2) :result nil :error "in"))
まあまあ、動いているようです。
不変条件は、クラスのスロット側にメソッドコンビネーションを付けることになりそうですが、間に合ってないので次回にします。
■
HTML generated by 3bmd in LispWorks 7.0.0
拡張setf定義を眺める: 制御構造篇
Posted 2018-12-17 00:05:13 GMT
《 Lisp SETF Advent Calendar 2018 17日目 》
今回は、処理系拡張のsetfのうち制御構造の拡張を眺めてみたいと思います。
処理系拡張のsetfとは
Common Lispの処理系には、setfの拡張が許されていますが、殆ど拡張は入れてない処理系から突飛なものを入れている処理系まで様々です。
CLISPに結構拡張が入っているので、今回はCLISPを中心に眺めてみます。
(setf if)
setfでifが使えるのですが、そこそこ便利かもしれません。
ifを使ったマクロ展開がされてもsetfの場所として有効なので、言語コアでsetf展開が可能だと、かなり拡張されることになります。
(let ((x 0)
(y 1))
(incf (if (< x y) x y))
(list x y))
→ (1 1)orはifに展開されるので、直接定義されていなくても(setf or)が使える
(let ((x nil)
(y 1))
(incf (or x y))
(list x y))展開はこんな感じです
(let* ((#:cond-29533 (< x y)) (#:new-29534 (+ (if #:cond-29533 x y) 1)))
(if #:cond-29533
(setq x #:new-29534)
(setq y #:new-29534)))(setf progn)
prognも言語のコアなので、これもsetf化の底上げになります。
(let ((x 0)
(y 0)
(z 0))
(incf (progn x y z))
(list x y z))
→ (0 0 1)(setf locally)
locallyも言語のコアなので、マクロ展開の結果への適用を考えているのだと思いますが、theの代わりに使える気もします。
(let ((x 0)
(y 1)
(z 2))
(setf (locally (declare (fixnum x y z ))
(values x y z))
(values 1 1 1))
(list x y z))
→ (1 1 1)(setf funcall)
規格では、(setf apply)が使えるので、ちょっとした変種というところです。
(let ((u (list 0 1 2)))
(incf (funcall #'cadr u))
u)
→ (0 2 2)(setf let)
ここからはLisp Machine Lispに実装されていたものですが、locative(参照)が扱えるので、かなり妙なことが可能です。
(let ((x 0)
f)
(setf (let ((x x))
(setq f (lambda () x))
x)
42)
(list x (funcall f)))
→ (0 42)上記の(setf let)内のxは外側のxをシャドウしていますが、末尾でx変数を返しているので、その参照に42を代入しています。
スコープの外から代入できてる感じなのがエグいですが、ここまで極端な使い方は想定していなそうではあります。
(setf setq)
これはLisp Machine Lispでも有効になっていませんが、コードの断片があるので有効にしてみると、
(let ((x 0)
(y (list 0 1 2)))
(setf (setq x (car y)) 42)
(list x y))
→ (42 (42 1 2))こんなことを考えていたようです。
setqの場合は、値の方の参照に代入します。なかなかエグい。
まとめ
役に立ちそうなものから、面白機能なものまで紹介してみました。
次回は、リスト操作系の拡張を紹介してみたいと思います。
■
HTML generated by 3bmd in LispWorks 7.0.0
メソッドコンビネーションで並列実行
Posted 2018-12-15 21:45:07 GMT
《 Lisp メソッドコンビネーション Advent Calendar 2018 16日目 》
メソッドコンビネーションは、メソッドの集合をあるコンビネーションで実行することなので並列実行も範疇に入ると思われます。
メソッドコンビネーションで並列実行の例は、そこそこあるだろうと思ってネットをしばらく検索してみましたが、どうやらあまり試してみた例はないようです。
NetCLOSの構文の見た目が、メソッドコンビネーションっぽかったのでソースを確認してみましたが、残念ながら、並列実行のパターンに直接メソッドコンビネーションを活用している訳ではない様子(メッセージ送信のシークエンスに活用してはいるようです)
ちなみに、NetCLOSは、ABCL/1にインスパイアされたアクターベースの並列オブジェクト指向なCLOSのネットワーク拡張です。
メソッドコンビネーションと素朴な並列実行
非常に素朴ですが、各メソッドをスレッドに分配して全部実行してジョインというのは簡単に書けます。
コンビネーションとしては、prognメソッドコンビネーションが並列に実行される、という感じでしょうか。
(define-method-combination par ()
((ms (:name . *)))
(let ((ths (loop :for () :in ms
:collect (gensym "thread-"))))
`(let (,@(mapcar (lambda (m th)
`(,th (bt:make-thread
(lambda ()
(call-method ,m))
:name ,(second (method-qualifiers m)))))
ms
ths))
(let ((ans (list ,@ths)))
(declare (dynamic-extent ans))
(values-list (mapcar #'bt:join-thread ans))))))(defgeneric para (x &optional out)
(:method-combination par))(defmethod para :name "foo" (x &optional out)
(format out "~&start A ...~%")
(sleep 3)
(format out "~&... end A~%"))
(defmethod para :name "bar" (x &optional out)
(format out "~&start B ...~%")
(sleep 5)
(format out "~&... end B~%"))
- メソッドコンビネーションの展開
(mc-expand #'para 'par nil 3)
→
(let ((#:|thread-181190|
(bt:make-thread (lambda ()
(call-method #<standard-method para (:name "bar") (t) 40303B7D63>))
:name "bar"))
(#:|thread-181191|
(bt:make-thread (lambda ()
(call-method #<standard-method para (:name "foo") (t) 40303A6263>))
:name "foo")))
(let ((ans (list #:|thread-181190| #:|thread-181191|)))
(declare (dynamic-extent ans))
(values-list (mapcar #'bt:join-thread ans))))- 実行してみる
(para 3 #.*standard-output*)
start A ...
start B ...
... end A
... end B
→ nil
nil上記では、ジョインする手間が省けている程度ですが、やりようによっては役に立つものができるかもしれません……。
■
HTML generated by 3bmd in LispWorks 7.0.0
実践SETF定義:ローカルなsetf
Posted 2018-12-15 19:31:30 GMT
《 Lisp SETF Advent Calendar 2018 16日目 》
今回は、ローカルスコープでのsetf定義について考えてみます(ネタがないから)
ローカルスコープでsetfとは
ANSI Common Lispでは、(setf fn)という関数名が使えるということは以前解説したのですが、これはflet/labelsでも勿論使えます。
つまり、ローカルスコープ限定でsetfフォームが書けるということになります。
#'(setf fn)
(let ((u (list 0 1 2 3 4)))
(flet (((setf kar) (val cons)
(rplaca cons val)))
(setf (kar u) 42)
u))
→ (42 1 2 3 4) Macro Forms as Placesのローカル版
macroletはローカルスコープのマクロを作りますが、Macro Forms as Placesもまたローカルで成立することになります。
(let ((u (list 0 1 2 3 4)))
(macrolet ((kar (list)
`(car ,list)))
(setf (kar u) 42)
u))
→ (42 1 2 3 4) defsetfやdefine-setf-expanderで定義するもののローカル版
setfletや、setf-expander-bindのような、そのボディ内でsetfフォームが書けるような構文を定義しない限り、無理ではないかなと思います。
特にdefine-setf-expanderの方はmacroletにちょっと細工する位では実現が無理に思えるので、コードウォーカーを駆使する他なさそうです。
まとめ
まあ、ローカルのsetfは、ほぼ使うこともないのですが、setfletや、setf-expander-bindのようなものを作ってみるのは、上級マクロ学習の良い題材になりそうな気はします。
興味のある方は試してみては如何でしょうか。
■
HTML generated by 3bmd in LispWorks 7.0.0
実践SETF定義:defstruct、defclassで定義できるおまけsetf
Posted 2018-12-15 13:52:03 GMT
《 Lisp SETF Advent Calendar 2018 15日目 》
setf系構文の紹介ですが、今回は、defstruct、defclassでおまけに定義できるsetfの紹介です。
defstructとsetf
MACLISP系Lispではsetfとdefstructは誕生から共に歩んできた感じですが、defstructの便利機能の一つに、アクセサを自動生成してくれる、というのがあります。
(defstruct zot x y z)(let ((z (make-zot)))
(setf (zot-x z) 42)
z)
→ #S(zot :x 42 :y nil :z nil)
デフォルトで(setf zot-x)という名前で作成してくれますが、この名前が気に入らない場合は、調整することも可能です。
(defstruct (zot (:conc-name ""))
x y z)(let ((z (make-zot)))
(setf (x z) 42)
z)
→ #S(zot :x 42 :y nil :z nil)
しかし、定義しない、という選択はできないので、ごく稀に名前の競合などで面倒なことがあったりはします。
defclassとsetf
後発のdefclassでは、defstructのように決め打ち動作は抑えられるため名前の競合問題は制御可能です。
スロットの指定で、:accessorを指定すれば、リーダーメソッドと(setf 名前)というセッターメソッドが定義されます。
:writerでは、シンボルと(setf fn)形式が指定可能で、スロットに複数指定可能なので複数の名前が一度に定義できます。
(defclass kiji ()
((x :accessor kiji-x)
(y :accessor kiji-y)
(z :accessor kiji-z :writer set-kiji-z :writer (setf hyper-kiji-z))))(let ((o (make-instance 'kiji)))
(setf (kiji-x o) 42)
(kiji-x o))
→ 42
(let ((o (make-instance 'kiji)))
(setf (hyper-kiji-z o) 43)
(kiji-z o))
→ 43
(let ((o (make-instance 'kiji)))
(set-kiji-z 43 o)
(kiji-z o))
→ 43
ちなみに、アクセサの名前ごとに別の総称関数なので個々のメソッドコンビネーションを付与できます(コンビネーションはstandardのみ可能)
(defmethod (setf hyper-kiji-z) :before (val (obj kiji))
(print 'hyper-kiji-z))(let ((o (make-instance 'kiji)))
(setf (kiji-z o) 43)
(kiji-z o))
→ 43
(let ((o (make-instance 'kiji)))
(setf (hyper-kiji-z o) 43)
(kiji-z o))
▻ hyper-kiji-z
→ 43
まとめ
改めて確認してみるとdefclassが随分多機能だなと感心します。
■
HTML generated by 3bmd in LispWorks 7.0.0
New Flavorsのwrapperとwhopperを再現してみよう
Posted 2018-12-15 11:24:57 GMT
《 Lisp メソッドコンビネーション Advent Calendar 2018 15日目 》
前回、メソッドコンビネーション元祖のFlavorsのdefwrapperの定義と:aroundの比較をしてみましたが、今回は、New Flavorsで登場したwhopperも加えてCommon Lispで再現してみようと思います。
FlavorsとNew Flavorsの違いですが、New FlavorsはSymbolicsがFlavorsを改良したもので、sendでのメッセージパッシング構文から、総称関数ベースに変更になった所が目立った違いです。
といっても、send構文もオブジェクトをfuncallしていたので、ちょっとした発想の転換程度の変化にみえます。
なお、New Flavorsは総称関数、多重継承ですが、マルチメソッドではありません。
Flavorsは、MITで開発され、MACLISP系のLisp(Lisp Machine Lisp、MACLISP、Franz Lisp、Zetalisp、Common Lisp)に実装されましたが、方言を跨ぐオブジェクトシステムというもの良く考えると面白いです。
wrapper/whopperの違い
さて、とりあえず、wrapper、whopperの解説ですが、wrapperはこれまでの記事で解説したように、メソッドの周囲を包むマクロ群です。
whopperは、New Flavorsから登場したようですが、Symbolics Common Lisp(1986)のマニュアルを眺めるとCommon Lispの:aroundと挙動は全く同じようです。バーガーキングのワッパーと何か関係があるのでしょうか。
それはさておき、マニュアルでは、マクロのwhopperは再コンパイルが必要だったりして扱いが若干面倒なので極力関数のwhopperを使おうとあります。
wrapperもwhopperも同一の機能ですが、混ぜて使った場合の説明もあり、その場合はwrapperが最外周を取るようです。
wrapperは、マクロなのでほんのちょっと速くできるとありますが、whopperにもインライン展開の構文もあったりするので本当にそうだったのかは謎です。
wrapper/whopperを再現してみる
defwhopper
Common Lispはマルチメソッドなので、シングルメソッドのFlavorsとは若干引数のインターフェイスを変える必要がありますが、大体こんな感じにしました。
(defmacro defwhopper (name (&rest args) &body body)
`(defmethod ,name :whopper (,@args)
(flet ((continue-whopper (&rest args)
(apply #'call-next-method args))
(lexper-continue-whopper (&rest args)
(apply #'apply #'call-next-method args)))
,@body)))defwrapper
wrapperの方は、ボディにマクロ展開を記述するのですが、展開関数をメソッドとは別に管理すると面倒なので、式を展開するメソッドを:wrapperメソッドとして記録することにしてみました。
メソッドコンビネーションの展開時に、:wrapper修飾子のメソッドを集めて、残りのフォームを引数に展開していく方針です。
(defmacro defwrapper (name (margs &body mbody) &body body)
(let ((form (gensym "form-")))
`(defmethod ,name :wrapper (,@margs)
(lambda (,form env)
(declare (ignore env))
(destructuring-bind ,mbody ,form
,@body)))))メソッドコンビネーション定義
wrapperは最外周なのとマクロ展開させるので若干特殊な動きをしますが、standardメソッドコンビネーションの:aroundを:whopperに置き換えたものをwrapperで包んでいく感じで大丈夫でしょう。
;;; Symbolics風のユーティリティ
(defmacro multiple-value-prog2 (form1 form2 &body body)
`(progn
,form1
(multiple-value-prog1 ,form2 ,@body)))(define-method-combination :wrapper ()
((whopper (:whopper))
(before (:before))
(primary () :required t)
(after (:after))
(wrapper (:wrapper)))
(flet ((call-methods (methods)
(mapcar #'(lambda (method)
`(call-method ,method))
methods)))
(let* ((form (if (or before after (rest primary))
`(multiple-value-prog2
(progn ,@(call-methods before))
(call-method ,(first primary)
,(rest primary))
,@(call-methods (reverse after)))
`(call-method ,(first primary))))
(whopper (if whopper
`(call-method ,(first whopper)
(,@(rest whopper)
(make-method ,form)))
form)))
(if wrapper
(reduce (lambda (w ans)
(let ((expander (funcall (method-function w) nil nil)))
(funcall expander (list ans) nil)))
wrapper
:initial-value whopper
:from-end T)
whopper))))
使ってみる
まずは、プライマリを定義してみます
(defgeneric foo (x)
(:method-combination :wrapper))(defmethod foo (x) x)
(foo "42")
→ "42"
次にwrapperを定義。
stringはプライマリがありませんが、wrapperは動きます。
(defwrapper foo ((x) &body body)
`(multiple-value-prog2
(format T "~A~%" '(foo t :wrapper :in))
,@body
(format T "~A~%" '(foo t :wrapper :out))))(defwrapper foo (((x string)) &body body)
`(multiple-value-prog2
(format T "~A~%" '(foo string :wrapper :in))
,@body
(format T "~A~%" '(foo string :wrapper :out))))
(foo "42")
▻ (foo string wrapper in)
▻ (foo t wrapper in)
▻ (foo t wrapper out)
▻ (foo string wrapper out)
→ "42"
次にstringのプライマリを定義して実行してみます
(defmethod foo ((x string))
(values (read-from-string x)))(foo "42")
▻ (foo string wrapper in)
▻ (foo t wrapper in)
▻ (foo t wrapper out)
▻ (foo string wrapper out)
→ 42
次に、whopperを定義してみます。
(defwhopper foo ((x string))
(let ((*read-base* 5.))
(continue-whopper x)))(foo "42")
▻ (foo string wrapper in)
▻ (foo t wrapper in)
▻ (foo t wrapper out)
▻ (foo string wrapper out)
→ 22
メソッドコンビネーションの展開はこんな感じです。
wrapperはcall-methodの連鎖にならずにベタ書きになっているのがわかります。
(mc-expand #'foo
:wrapper
nil
"42")
→
(multiple-value-prog2
(format t "~A~%" '(foo string :wrapper :in))
(multiple-value-prog2
(format t "~A~%" '(foo t :wrapper :in))
(call-method
#<standard-method foo (:whopper) (string) 40E01F98B3>
((make-method
(multiple-value-prog2 (progn)
(call-method
#<standard-method foo nil (string) 40E01C1253>
(#<standard-method foo nil (t) 40E00E75EB>))))))
(format t "~A~%" '(foo t :wrapper :out)))
(format t "~A~%" '(foo string :wrapper :out)))まとめ
New Flavorsのwrapper/whopperを再現してみましたが、マクロだったwrapperが使い易く関数のwhopperとしてまとめられ、そこからCommon Lispの:aroundへ統合されたらしいことがわかります。
define-method-combinationのインターフェイスは、New Flavors時代に固まったようですが、どうもwrapperの仕組みが念頭にあった設計に思えてしまいます。
MOP前提なら、もうちょっと違ったインターフェイスにできる気がするのですが、残念ながらANSI Common Lispでは、MOPが規格外になってしまったので、MOP前提ではないdefine-method-combinationのインターフェイスも生き残ったという所なのかもしれません。
■
HTML generated by 3bmd in LispWorks 7.0.0
FlavorsのdefwrapperとCommon Lispの:aroundの比較
Posted 2018-12-14 14:48:47 GMT
《 Lisp メソッドコンビネーション Advent Calendar 2018 14日目 》
Flavorsには、Common Lispのメソッドコンビネーションの:aroundが無いようなのですが、その代わりにdefwrapperという構文があったようです。
defwrapperの発展的解消の結果、:aroundに纏められたのかなと思えてきたのですが、CADRのエミュレータ上でdefwrapperの実際の使い勝手と挙動を確認してみることにしました。
挙動確認のお題ですが、先日のstandardメソッドコンビネーションの説明で:before、:after、primary、:around全部盛りの定義を紹介したものをFlavorsに書き換えて試してみます。
Flavorsは、(CADR System 78.48 (1982年あたり))のものです。
(progn
(defflavor f1 () ())
(defflavor f2 () (f1))
(defflavor f3 () (f2)))(progn
(defmethod (f1 foo) ()
(format T "~16T~A~%" '(foo f1)))
(defmethod (f2 foo) ()
(format T "~16T~A~%" '(foo f2))
(funcall #'(:method f1 foo) self))
(defmethod (f3 foo) ()
(format T "~16T~A~%" '(foo f3))
(funcall #'(:method f2 foo) self))
;;
(defmethod (f1 :before foo) ()
(format T "~8T~A~%" '(foo f1 :before)))
(defmethod (f2 :before foo) ()
(format T "~8T~A~%" '(foo f2 :before)))
(defmethod (f3 :before foo) ()
(format T "~8T~A~%" '(foo f3 :before)))
;;
(defmethod (f1 :after foo) ()
(format T "~24T~A~%" '(foo f1 :after)))
(defmethod (f2 :after foo) ()
(format T "~24T~A~%" '(foo f2 :after)))
(defmethod (f3 :after foo) ()
(format T "~24T~A~%" '(foo f3 :after))))
(progn
(defwrapper (f3 foo) (() . body)
`(progn
(format T "~A~%" '(foo f3 :wrapper))
. ,body))
(defwrapper (f2 foo) (() . body)
`(progn
(format T "~A~%" '(foo f2 :wrapper))
. ,body))
(defwrapper (f1 foo) (() . body)
`(progn
(format T "~A~%" '(foo f1 :wrapper))
. ,body)))
(<- (make-instance 'f3) 'foo)
▻ (FOO F3 WRAPPER)
▻ (FOO F2 WRAPPER)
▻ (FOO F1 WRAPPER)
▻ (FOO F3 BEFORE)
▻ (FOO F2 BEFORE)
▻ (FOO F1 BEFORE)
▻ (FOO F3)
▻ (FOO F2)
▻ (FOO F1)
▻ (FOO F1 AFTER)
▻ (FOO F2 AFTER)
▻ (FOO F3 AFTER)
→ NIL思えば、Flavorsには、call-next-methodのようなものがない気がするのですが、とりあえず、Common Lispと違ってfunctionの記法が拡張されているので、(funcall #'(:method f2 foo) self) という風にメソッドを直接起動してしのいでいます。
後期のFlavorsや、New Flavorsにはあるのかもしれません。
そもそもFlavorsは標準規格化されてないので、実装によりAPIや挙動がまちまちなので確認が、ちょっとしんどいです。
上記のコードをみて分かるかと思いますが、:aroundの中で、call-next-methodを呼ぶのではなく、defwrapperでは、メソッドのコードをマクロで包み込む、という感じになります。
また、defwrapperはマクロではありますが、Flavorを指定できるので、どのメソッドの外周を包むかを:aroundと同じく指定することが可能です。
まとめ
defwrapperが:aroundに置き換わったと考えると、Common Lispのメソッドコンビネーションの動作の謎が解ける気がして、Flavorsのdefwrapperを紹介してみました。
後期Flavors、New Flavors、さらに、defwrapper以外の謎構文、defwhopperとメソッドコンビネーションについても調べて纏めてみたいと思っています。
■
HTML generated by 3bmd in LispWorks 7.0.0
実践SETF定義:マクロを定義した場合のおまけsetf
Posted 2018-12-13 18:45:56 GMT
《 Lisp SETF Advent Calendar 2018 14日目 》
setf系構文の紹介ですが、今回は、Macro Forms as Placesの紹介です。
Macro Forms as Placesというと何のことだかさっぱりという感じですが、単にマクロを定義したらsetf定義もオマケで付いてきちゃった、という感じのものです。
例を挙げると、
(defmacro kar (x)
`(car ,x))(kar (list 0 1 2))
→ 0
という定義があった場合、setfの定義は何もしていませんが、下記のようなものが動きます。
(let ((list (list 0 1 2)))
(setf (kar list) 42)
list)
→ (42 1 2) ローカルマクロでも可
(macrolet ((qar (x)
`(car ,x)))
(let ((list (list 0 1 2)))
(setf (qar list) '())
(push 42 (qar list))
list))
→ ((42) 1 2) setf場所にマクロで定義したフォームで使えるというのがMacro Forms as Placesです。
Macro Forms as Placesを利用する場合の注意点ですが、マクロ展開後のフォームが、setfで解釈できる状態になっていなければなりません。
具体例を挙げると、prognには、標準ではsetf定義がないので、最外周にprognが現われるような書き方をすればエラーになります。
;; OK
(defmacro kar (x)
`(car ,x));;; NG
(defmacro kar (x)
`(progn (car ,x)))
まとめ
うまくはまれば、便利に使えるMacro Forms as Places。
活用してみては如何でしょうか。
類似の過去記事
■
HTML generated by 3bmd in LispWorks 7.0.0
実践SETF定義:define-modify-macroで頻出パターンをまとめる
Posted 2018-12-13 14:28:27 GMT
《 Lisp SETF Advent Calendar 2018 13日目 》
setf系構文の紹介ですが、今回は、define-modify-macroの紹介です。
define-modify-macroは、簡単に説明するなら、(setq x (fn x))のようなパターンを簡潔に(fnf x)と書けるようにする便利定義構文なのですが、このようなパターンが頻出する訳でもないので、普段はそんなに使うこともない印象があります。
define-modify-macroで何か定義してみる
(setq x (cdr x))というパターンはそこそこ使いますが、define-modify-macroでcdrfでも定義してみましょう。
(define-modify-macro cdrf () cdr)(let ((x (list 0 1 2)))
(cdrf x)
x)
→ (1 2)
まあ、実質同じことをするビルトインマクロにpopがありますが……。
一応返り値が違います。
定義構文の注意点として、代入にされる場所となる変数が先頭に来て、さらにそれが定義構文中には現われない、という点です。
cdrの場合は1引数なので、0引数で記述します。
define-modify-macroを使えば役に立ちそうな立たなそうな構文を大量生産できます。
(define-modify-macro listf (&rest args) list)(let ((x (list 0 1 2)))
(list x 1 2))
→ ((0 1 2) 2 3 4)
(define-modify-macro =f (&rest args) =)
(let ((x 0)
(y 1))
(=f x y )
(list x y))
→ (nil 1)
appendf、nconcf等々は定番アイテムで、色々なユーティリティライブラリに含まれています。
まあ、ライブラリを読み込むのが面倒な場合には、簡単なので定義してしまっても良いでしょう。
modify-macrolet
define-modify-macroは大域定義になるのですが、7年程前にローカル構文版を思い付いて作ったことがありました。
これを使うと、
(modify-macrolet ((nconcf (&rest args) nconc))
(let ((x nil))
(nconcf x (list 0 1 2 3))
x))のように大域の名前を汚染することなくローカルに書くことが可能になります。
ちなみに、個人的には定義してから7年間一度も使ったことはありませんが、ご興味のある方は如何でしょうか。
また、modify-macroletを自作してみるのも一興かなと思います。
■
HTML generated by 3bmd in LispWorks 7.0.0
Flavorsのメソッドコンビネーションを眺めたり再現してみよう: :pass-on
Posted 2018-12-12 19:45:24 GMT
《 Lisp メソッドコンビネーション Advent Calendar 2018 13日目 》
前回に引き続き、メソッドコンビネーション元祖のFlavorsに標準装備されていたメソッドコンビネーションを眺めたり再現してみたりしようと思います。
メソッドの返り値を順繰りに次のメソッドに送っていく:pass-onの再現がしたくて苦戦していましたが、なんとか形にできました。
Flavorsの:pass-onの挙動を確認してみる
とりあえず、LMI Lambdaのエミュレータで挙動が確認できたのですが、こんな感じでした。
(defflavor a () ()
(:method-combination (:pass-on (:base-flavor-last) :m)))(defflavor b () (a))
(defmethod (a :m) (x y)
(values (list :a x) (1+ y)))
(defmethod (b :m) (x y)
(values (list :b x) y))
(send (make-instance 'b) :m 0 1)
→ (:a (:b 0))
2
aを継承するbという2つのflavorに、それぞれmを:pass-onで定義し、bのインスタンスでmを呼び出すと、b.mの返り値をa.mが受け取るようになります。
:base-flavor-lastなのでb→aの順番ですが、:base-flavor-firstにすれば、逆にもできます。
:pass-onが多値で返す意味が分からなかったのですが、良く考えると、メソッドの引数が複数になる場合は、多値かリストにして対応するしかなく、リストだと受取側の引数のインターフェイスを変更しないといけないので、多値で返すしかないですね。なるほど。
Common Lispで再現してみる
MOPのmake-method-lambda、compute-effective-methodあたりでどうにかできないか検討しましたが、call-methodフォームを作成して、また分解して、という感じになってしまうので、call-methodをスルーして、メソッドの関数をmethod-functionで取り出して直接呼ぶことにしました。
(ql:quickload :closer-mop);; LispWorks/Allegro CL
(define-method-combination :pass-on ()
((ms ()))
(:arguments &rest args)
(let ((vs (gensym "vars-")))
`(let* ((,vs ,args)
,@(loop :for m :in ms
:collect `(,vs
(multiple-value-list
(apply ,(c2mop:method-function m)
,vs)))))
(declare (dynamic-extent ,vs))
(values-list ,vs))))
しかし、メソッドの引数情報が欲しいので、define-method-combinationの:argumentsを指定しているのですが、SBCLだと:argumentsがちゃんと実装されていないようなので&restが使えません。
また、method-functionが返す関数の引数は、args、next-methodsの筈なので、(funcall method-function vs nil)とするのが正しそうですが、LispWorksとAllegro CLでは、(apply method-function vs)でないと上手く動かない謎。
そんなこんなで、まともに動くものができているとは言い難いですが、こんな感じに書けます。
(defclass a () ())(defclass b (a) ())
(defgeneric m (o x y)
(:method-combination :pass-on))
(defmethod m ((o a) x y)
(values o (list :a x) (1+ y)))
(defmethod m ((o b) x y)
(values o (list :b x) y))
(m (make-instance 'b) 0 1)
→ #<b 40205BA353>
(:a (:b 0))
2
メソッドコンビネーションの展開はこんな感じで別段変なことはしていませんが、どの処理系も何かしらおかしい感じです。
まあ、LispWorksとAllegro CLで動くので良しとしましょう。
(mc-expand #'m :pass-on nil (make-instance 'b) 0 1)
→
(let* ((#:|vars-131621| args)
(#:|vars-131621|
(multiple-value-list (apply #<Function (method m (b t t)) 4140032074>
#:|vars-131621|)))
(#:|vars-131621|
(multiple-value-list (apply #<Function (method m (a t t)) 41400320FC>
#:|vars-131621|))))
(declare (dynamic-extent #:|vars-131621|))
(values-list #:|vars-131621|)) まとめ
HyperSpecによると、define-method-combinationの:argumentsでは、&restの他に&wholeも使えたりするみたいですが、メジャーな処理系を試してみたところ、まともに:argumentsの機能を実装しているものは無いように思えます。
SBCLは、ソースを眺める限り&restを処理できていないのですが、今後修正されれば、今回の:pass-onも動くんじゃないかなと思います。
■
HTML generated by 3bmd in LispWorks 7.0.0
Flavorsのメソッドコンビネーションを眺めたり再現してみよう: :daemon-with-override
Posted 2018-12-12 13:48:13 GMT
《 Lisp メソッドコンビネーション Advent Calendar 2018 12日目 》
前回に引き続き、メソッドコンビネーション元祖のFlavorsに標準装備されていたメソッドコンビネーションを眺めたり再現してみたりしようと思います。
本当は、:pass-onの再現がしたいのですが、色々間に合ってないので、:daemon-with-overrideの再現でお茶を濁したいと思います。
:daemon-with-overrideは、Common Lispでいうと、:aroundなしのstandardメソッドコンビネーションの前に門番のメソッドがいるような感じですが、こんな感じに定義できます。
(define-method-combination :daemon-with-override ()
((before (:before))
(after (:after))
(primary ())
(override (:override)))
`(or
,@(and override `((call-method ,(car override))))
(multiple-value-prog1
(progn
,@(loop :for m :in before :collect `(call-method ,m))
(call-method ,(car primary) ,(cdr primary)))
,@(loop :for m :in (reverse after) :collect `(call-method ,m)))))細かいオプションは詰めてないですが、これくらいの定義なら空で書けるようになりました。
難解だと思っていたdefine-method-combination構文ですが、10個位定義を書けば、そこそこ覚えられそうですね。
では、使ってみましょう。
(defgeneric foo (x)
(:method-combination :daemon-with-override))(defmethod foo ((x T)) x)
(defmethod foo :before ((x T)) (print :before))
(defmethod foo :after ((x T)) (print :after))
(defmethod foo ((x rational))
`(rational ,(call-next-method)))
(defmethod foo ((x integer))
`(integer ,(call-next-method)))
(defmethod foo :override ((x number))
(evenp x))
(foo 8)
→ t (foo 9)
▻ :before
▻ :after
→ (integer (rational 9))
メソッドコンビネーションを展開してみるとこんな感じになります。
(mc-expand #'foo
:daemon-with-override
nil
1)
→
(or (call-method #<standard-method foo (:override) (number) 40201044DB>)
(multiple-value-prog1
(progn
(call-method #<standard-method foo (:before) (t) 402045306B>)
(call-method
#<standard-method foo nil (integer) 4130468943>
(#<standard-method foo nil (rational) 413046892B>
#<standard-method foo nil (t) 413046961B>)))
(call-method #<standard-method foo (:after) (t) 4020462243>)))まとめ
:daemonメソッドコンビネーションに門番がついているというパターンなので、Common Lispでは、:aroundを使えば実現できるパターンですね。
数あるパターンが、Common Lispでは、:aroundとして集約されたという流れが想像できます。
■
HTML generated by 3bmd in LispWorks 7.0.0
実践SETF定義: setf placeって多値が取れたり取れなかったりする?
Posted 2018-12-12 13:04:44 GMT
《 Lisp SETF Advent Calendar 2018 12日目 》
前回の(setf all)を定義していて気付いたのですが、incfや、push、popはvaluesと組み合わせると処理系によって異なる動作をします。
下記のような例は、SBCLやAllegro CLでは中途半端な動きをしますが、LispWorksではマクロ展開時にエラーになります。
(let ((x 0)
(y 0))
(incf (values x y))
(list x y))
→ (1 nil) or error(let ((x (list 0 1 2))
(y (list 1 2 3)))
(pop (values x y))
(list x y))
→ ((1 2) nil) or error
もしや、setf以外はvaluesを取れないのかと思い、HyperSpecを確認してみましたが、5.1.2.3 VALUES Forms as Placesでもvaluesはsetf以外では機能しない、とは書いてありません。
間接的な定義がされている場合もあるので、それらしきものを探してみましたが、setfベースのマクロについての定義があります。
decf、pop、pushnew、incf、push、remfはdefine-modify-macroで定義されているような挙動をする的な解釈が成立しそうな雰囲気もありますが、
define-modify-macroのAPIからすると、関数の引数として値を処理するので、多値は扱えません。
define-modify-macroで定義すれば、incfのようなものは、
(let ((x 0)
(y 0))
(setf (values x y)
(values (1+ (values x y))))
(list x y))
→ (1 nil) のように展開されると思われるので、中途半端な返り値になっている理由も合点はいきます。
多値を扱いたい
とりあえず、多値を扱えるフォームはどんな感じになるか定義して眺めてみます。
incfの多値版は、こんな感じに定義できるかなと思います。
(defmacro incf* (place &optional (delta 1) &environment env)
(multiple-value-bind (dummies vals newval setter getter)
(get-setf-expansion place env)
(declare (ignore dummies vals setter))
(let ((deltas (loop :for () :on newval :collect (gensym))))
`(multiple-value-bind ,newval
,getter
(setf (values ,@deltas)
,(if (eql 1 delta)
`(values ,@(loop :for () :on deltas :collect 1))
delta))
(setf ,getter
(values ,@(mapcar (lambda (v d)
`(incf ,v ,d))
newval
deltas)))))))(let ((x 0)
(y 1))
(incf* (values x y) (values 1 10))
(list x y))
→ (1 11)
popの多値版はこんな感じ
(defmacro pop* (place &environment env)
(multiple-value-bind (dummies vals newval setter getter)
(get-setf-expansion place env)
(declare (ignore dummies vals setter))
(let ((retvars (loop :for () :on newval :collect (gensym))))
`(multiple-value-bind ,newval
,getter
(let (,@(mapcar (lambda (a d)
`(,a (car ,d)))
retvars
newval))
(setf ,getter
(values ,@(mapcar (lambda (v)
`(cdr ,v))
newval)))
(values ,@retvars))))))(let ((x (list 0 1 2))
(y (list 0 1 2)))
(pop* (values x y))
(list x y))
→ ((1 2) (1 2))
VALUES Forms as Placesを処理できるdefine-modify-macro*のようなものを定義してみても良いかもしれません。
まとめ
どうせコンパイル時に展開すると思うのでVALUES Forms as Placesを処理できても良いと思うのですが、何か事情があるのでしょうか。
これらのフォームは、ループ内で頻出しそうなので極力無駄のない定義になる必要があるような気はしますが、展開時に無駄は省けそうですし、さて真相やいかに……。
■
HTML generated by 3bmd in LispWorks 7.0.0
Flavorsのメソッドコンビネーションを眺めたり再現してみよう: その二
Posted 2018-12-11 14:47:02 GMT
《 Lisp メソッドコンビネーション Advent Calendar 2018 11日目 》
前回に引き続き、メソッドコンビネーション元祖のFlavorsに標準装備されていたメソッドコンビネーションを眺めたり再現してみたりしようと思います。
前回いきなりcaseメソッドコンビネーションの再現に取り組んでみましたが、改めて、どんなメソッドコンビネーションがあるのか一覧にしてみたくなりました(ネタ切れだから)
調べてみたのは、後期Flavors〜New Flavorsあたりのメソッドコンビネーションです。
前知識
Flavorsのメソッドコンビネーションの標準構成は、Common Lisp版から:aroundを外したようなものです。
:aroundの部分は、defwrapperというメソッドを囲むマクロを定義する感じになります。
また、キーワードシンボルになっていますが、Lisp Machine Lispでは、userパッケージのシンボルの略記になります。
つまり、(eq :progn 'progn)です。
共用シンボルはuserパッケージに置かないで、keywordパッケージに纏めよう、と整理したのがCommon Lispです。
さて、では眺めてみましょう。
:daemon
Common Lispのstandardメソッドコンビネーションから:aroundを外したようなもの。
これを:darmonと呼びます。
:before / :after
Common Lispと同じです、:daemonメソッドコンビネーションの部品を単体で呼び出しているとも考えられます。
:and / :or / :progn
Common Lispから:aroundを外したようなもの。
:append / :nconc / :list
Common Lispから:aroundを外したようなもの。
:inverse-list
listが逆順になって返ってきます。
わざわざ用意しているからには使い道があるのでしょう……。
:max / :min / :sum
Common Lispと同じですが、:sumは、Common Lispでは+になっていますね。
:case
前回紹介した不思議メソッドコンビネーションです。
:daemon-with-and
:andの前後を:before、:afterで囲んだものです。
Common Lispではandに:daemonは付きません。
:daemon-with-or
:orの前後を:before、:afterで囲んだものです。
:daemon-with-override / :override
:overrideで定義したメソッドが:daemonメソッドコンビネーションの前に配置されていて、それがorで結合しています。
つまり、:overrideがnilを返した場合だけ、:daemonに進むという変ったものです。
:two-pass
プライマリ全部起動の後に:after全部を起動するものらしいです。
make-instanceで良く使うらしいですが、インスタンス初期値の設定とかでしょうか。
:pass-on
メソッドの返り値を次のメソッドに次々と渡していくメソッドコンビネーションのようです。
先日フィルターを作ろうとしていましたが、pass-onならできそうです。
しかし、返り値は何故か多値で返す様子。。
(a b c)という引数を持つメソッドを連鎖させるには、(values a b c)で値を渡さないといけないようですが、何故なのか。
ネタ切れなので、次回からCommon Lispで、Flavorsのメソッドコンビネーションを、`Symbolics Open Genera上のFlavorsの挙動を確認しつつ再現していきます。
■
HTML generated by 3bmd in LispWorks 7.0.0
実践SETF定義:define-setf-expanderで型破りなsetf構文を作ろう
Posted 2018-12-10 17:46:17 GMT
《 Lisp SETF Advent Calendar 2018 11日目 》
setf関数、defsetfと紹介してきましたが、今回は一番汎用的なdefine-setf-expanderの紹介です。
実際、defsetfや、define-modify-macroも、define-setf-expanderの定義に展開している処理系も多いです。
define-setf-expanderを簡単に説明すると、
(setf (x y z) a b c)のようなフォームのx、y、z、a、b、cという部品を好きなように配置することが可能です。
好きなように、といっても一応x、y、zは変数としての振舞い、a、b、cは値としての振舞いをする必要はありますので、作法に則る必要はあります。
CPLの代入構文のallを作ってみよう
左辺値について調べている際に、CPLが左辺値、右辺値を整理したとWikipediaに書いてあったので、ちょっと眺めてみましたが、Fortran、Algolに比較すれば、左辺値が拡張された感じはします。
左辺値にリスト表現や配列をとって、変数を複数同時に代入できたり、リストを分解して変数に代入できたり、1963年の言語にしては先進的ですが、拡張のバリエーションとして、
all a, b, c := 0という書法がありました。
上記の場合は、変数全部に0が代入されるわけですが、左辺と右辺で微妙に対称性がなく、イレギュラーなsetf定義の例に良さそうなので、ちょっと考えてみましょう。
まず、構文の見た目ですが、こんな感じになるかなと思います。
(setf (all a b c) 0)(list a b c)
→ (0 0 0)
構文全体としては直感的なのですが、allというゲッターを考えるに、これは単独では存在できそうにないですが、どうなんでしょう。
それはさておきこんな感じに書いてみました。
(define-setf-expander all (&rest places &environment env)
(loop :with store := (gensym "all-")
:for p :in places
:for (d v sv setter getter) := (multiple-value-list (get-setf-expansion p env))
:append d :into ds
:append v :into vs
:append sv :into svs
:collect setter :into setters
:collect getter :into getters
:finally (return
(values ds
vs
`(,store)
`(let (,@(mapcar (lambda (v)
`(,v ,store))
svs))
(values ,@setters))
`(values ,@getters)))))下記のフォームをマクロ展開してみると、
(let ((x 0)
(y 0)
(z 0))
(incf (all x y z) 100)
(list x y z))
→ (100 100 100)こんな感じになります。
(let ((x 0) (y 0) (z 0))
(let* ()
(let* ()
(let ((#:|all-128690| (+ (values x y z) 100)))
(let ((#:|Store-Var-128691| #:|all-128690|)
(#:|Store-Var-128692| #:|all-128690|)
(#:|Store-Var-128693| #:|all-128690|))
(values (setq x #:|Store-Var-128691|)
(setq y #:|Store-Var-128692|)
(setq z #:|Store-Var-128693|))))))
(list x y z))大体の場所でallは機能が成立するようです。
(let ((x (list 0 1 2))
(y 0)
(z 1))
(setf (all (values (car x) (cadr x)) y z)
42)
(list x y z))
→ ((42 42 2) 42 42) (let ((v (make-sequence 'vector 7)))
(setf (all (elt v 1)
(elt v 3)
(elt v 5))
'-
(all (elt v 0)
(elt v 2)
(elt v 4)
(elt v 6))
'+)
v)
→ #(+ - + - + - +)
しかし、push、popの挙動は良く分かりません。
push/popした後のリストがallによって同値になるので、これであってるような間違っているような。
(let ((x (list 1 2 3))
(y (list 0 0 0)))
(push 'a (all x y))
(list x y))
→ ((a 1 2 3) (a 1 2 3)) (let ((x (list 1 2 3))
(y (list 0 0 0)))
(pop (all x (cdr y)))
(list x y))
→ ((2 3) (0 2 3))
まとめ
変った代入構文をみつけたら、また定義に挑戦してみようと思います。
■
HTML generated by 3bmd in LispWorks 7.0.0
Flavorsのメソッドコンビネーションを再現してみよう: case篇
Posted 2018-12-09 20:59:45 GMT
《 Lisp メソッドコンビネーション Advent Calendar 2018 10日目 》
組み込みのメソッドコンビネーションの紹介も尽きてきたので、メソッドコンビネーション元祖のFlavorsに標準装備されていたメソッドコンビネーションの再現でもしてみましょう。
Flavorsのcaseメソッドコンビネーション(の真似のつもり)
Flavorsのcaseメソッドコンビネーションと題しつつオリジナルの挙動が確認できていないのですが、どうもFlavorsとNew Flavorsで挙動が違うようです。
再現したつもりなのは、New Flavorsの方ですが、もしかすると、第二修飾子がメソッドの引数に現れた場合のディスパッチにcaseを使うのかもしれません。
作成してみたものは、メソッドの引数を安直にcaseに展開するもので、第二修飾子がcaseのマッチ対象になります。
(define-method-combination case ()
((case-clauses (case . *)))
(:arguments a)
(loop :for c :in case-clauses
:if (equal '(case otherwise) (method-qualifiers c))
:collect c :into otherwise
:else
:collect `(,(cadr (method-qualifiers c)) (call-method ,c nil)) :into clauses
:finally
(return
`(case ,a
,@clauses
,@(and otherwise
`((otherwise
,(reduce (lambda (m ms)
`(call-method ,m ,(and ms `((make-method ,ms)))))
otherwise
:initial-value nil
:from-end T))))))))(defgeneric fib (n)
(:method-combination case))(defmethod fib case 0 (n) n)
(defmethod fib case 1 (n) n)
(defmethod fib case otherwise ((n number))
(+ (fib (1- n)) (fib (- n 2))))
(defmethod fib case otherwise ((n integer))
(call-next-method))
(fib 20)
→ 6765
展開を確認してみるとこんな感じです
(mc-expand #'fib
'case
nil
20)
→
(case a
(1 (call-method #<standard-method fib (case 1) (t) 41E00640EB> nil))
(0 (call-method #<standard-method fib (case 0) (t) 41E00641C3> nil))
(otherwise
(call-method
#<standard-method fib (case otherwise) (integer) 41E0061D63>
((make-method
(call-method
#<standard-method fib (case otherwise) (number) 41E0059333>
nil)))))) eql特定子をメソッドコンビネーションで実装してしまっている感がありますが、汎用化を推し進めると、filtered-functionみたいなことになるのかなと思います。
今後、Flavors、New Flavorsのcaseメソッドコンビネーションの挙動が確認できたら、オリジナルに忠実なものも作成してみようと思います。
■
HTML generated by 3bmd in LispWorks 7.0.0
define-method-combinationの短形式は使えるか
Posted 2018-12-09 10:54:06 GMT
《 Lisp メソッドコンビネーション Advent Calendar 2018 9日目 》
前回メソッドコンビネーションのlistが:aroundと組み合わせることで結構汎用的に使えることが分かってしまいました。
+、min、max、append、nconcのメソッドコンビネーションを眺めると、どれも&restな引数の関数なので、listメソッドコンビネーションでできた結果を:aroundでapplyすれば良いだけです。
define-method-combinationの短形式は指定したシンボルのフォームで囲むメソッドコンビネーションを定義しますが、関数以外のオペレーターも指定することが可能です。
define-method-combinationの短形式の存在意義を確認するため、clパッケージ内のフォームを物色してみました。
define-method-combinationの短形式で定義できそうなものを探す
ということで、引数が&restか&bodyかで始まるフォームをclパッケージから探してみましたが、下記のようになりました。
(ql:quickload :trivial-arguments)(loop :for s :being :the :external-symbols :of :cl
:when (and (fboundp s)
(ignore-errors
(typep (trivial-arguments:arglist s)
'(cons (member &rest &body) *))))
:collect s)
→
(rotatef shiftf cond ignore-errors
append logeqv tagbody and
locally logand lcm psetf
trace vector in-package with-standard-io-syntax
gcd psetq setq logior
nconc or list progn
make-broadcast-stream values untrace loop
make-concatenated-stream declaim logxor +
*)
なるほど、碌な応用が考えつかないものばかりです。
標準で提供されているメソッドコンビネーションは、このリストの中でも割合に有用なものが選ばれていたことも判ります。
とりあえず、幾つか定義を試してみましょう
ignore-errorsメソッドコンビネーション
define-method-combinationの短形式で順次実行のフォームを定義した場合、基本的にprognと同じようになります。
(define-method-combination ignore-errors)(defgeneric foo (x y)
(:method-combination ignore-errors))
(defmethod foo ignore-errors (x y)
(+ x y))
(defmethod foo ignore-errors ((x list) (y list))
(append x y))
(foo 1 2)
→ 3
(foo '(0 1 2) '(a b c))
→ nil
#<conditions:arithmetic-type-error 40201FF25B>
こんな感じに展開されるのですが、エラーが発生してもとにかく続行したいという時には使えるかもしれません。
ignore-errorsメソッドコンビネーションは、prognメソッドコンビネーションを`ignore-errorsで囲めば定義せずに済んでしまいそうです。
and、orメソッドコンビネーションと:aroundでignore-errors適用も良さそうです。
一応の展開形確認
(mc-expand #'foo
'ignore-errors
nil
'(0 1 2)
'(a b c))→
(ignore-errors (call-method
#<standard-method foo (ignore-errors) (list list) 402014EFD3>
nil)
(call-method
#<standard-method foo (ignore-errors) (t t) 40201FE2C3>
nil))
valuesメソッドコンビネーション
listメソッドコンビネーションに:aroundでvalues-listすれば良いのですが、より直截的でしょうか。
(define-method-combination values)(defgeneric foo (x y)
(:method-combination values))
(defmethod foo values (x y)
(list x y))
(defgeneric bar (x)
(:method-combination values))
(defmethod bar values ((x number))
(list x 'number))
(defmethod bar values ((x rational))
(list x 'rational))
(defmethod bar values ((x float))
(list x 'float))
(defmethod bar values ((x integer))
(list x 'integer))
(bar 1.0)
→ (1.0 float)
(1.0 number)
まあ、頭を捻れば応用例も見出せるかもしれません。
loopメソッドコンビネーション
loopで囲んでみましたが、メソッドコンビネーションスコープとループのスコープが微妙に噛み合いません。
長形式で工夫して定義するかMOPでメソッドコンビネーションの枠組み自体を書き換えるかしないと、あまり有用な定義はできなさそうです。
噛み合わない点ですが、loopのblockスコープが指定できない、等々です。
これもprognメソッドコンビネーションで、条件が成立するまでループさせるような:aroundを書いた方が有用かもしれません。
(define-method-combination loop)(defgeneric baz (x)
(:method-combination loop))
(defmethod baz loop (x)
(print x)
(throw 'baz x))
(defmethod baz loop ((x number))
(print (list (incf x) 'number)))
(defmethod baz loop ((x rational))
(print (list (incf x) 'rational)))
(defmethod baz loop ((x integer))
(print (list (incf x) 'integer)))
(defmethod baz :around (x)
(catch 'baz
(call-next-method)))
(baz 8)
▻ (9 integer)
▻ (9 rational)
▻ (9 number)
▻ 8
→ 8
tagbodyメソッドコンビネーション
折角なので常軌を逸していそうなtagbodyについて考えてみましたが、blockや、tagbodyのタグのスコープはダイナミックエクステントなので、普通に書いたらメソッドを跨ぐことができません。
ということで、定義がtagbodyやblockの中に収まっている必要があります。
(define-method-combination tagbody)(defgeneric fact (n)
(:method-combination tagbody))
(block nil
(let ((n 20)
(ans 1))
(tagbody
(defmethod fact tagbody ((n (eql 0)))
(go X))
(defmethod fact tagbody ((n integer))
(setq ans (* n ans))
(go L))
L (decf n)
(fact n)
X (return ans))))
→ 121645100408832000
まとめ
define-method-combinationの短形式を使って有用なものを定義できることは、ほぼなさそうです。
関数系であれば、listメソッドコンビネーション & :aroundの組み合わせで、順次実行フォーム系であれば、progn & :aroundの組み合わせを、非常に簡潔に書ける、ということがメリットですが、長形式だけ用意しておけば良かったのではないかナー、という結論です。
■
HTML generated by 3bmd in LispWorks 7.0.0
setf系アイデアの最終形態: letf
Posted 2018-12-08 19:29:08 GMT
《 Lisp SETF Advent Calendar 2018 9日目 》
今回は、また毛色を変えて、setf系の面白構文を紹介したいと思います。
letf
letfは、Lisp Machine Lispに存在したletとsetfが合体したような構文です。
束縛系構文なので、代入系のsetfとはちょっと違うのですが、こんな感じで使えます。
(defstruct s x y z)(let ((s (make-s :x 0 :y 1 :z 2)))
(letf (((s-x s) 42))
(print s)
(list s
(s-x s)
(s-y s)
(s-z s))))
▻ #S(s :x 42 :y 1 :z 2)
→ (#S(s :x 0 :y 1 :z 2)
42
1
2)
letの変数部分が、setfでいう一般化変数になっていて、上記の場合は、letfのボディの中では構造体sのxスロットは42になっていますが、スコープを抜ければ復帰します。
Lisp Machine Lispでは、ロカティブという参照の仕組みがありますが、ロカティブをすげかえる仕組みがマシンのメモリ参照のレベルで実装されていて、この機能によってCommon Lispでいうスペシャル変数のような感じで色々なものの参照を扱えるのですが、letfはこれを活用しています。
Common LispでもLispWorksのような一部の処理系には、letfがユーティリティとして含まれていますが、代入して元に戻すフォームをunwind-protectで囲んだ実装です。
Emacs Lispのcl.elにも何故かletfがありますが、こちらも代入して復帰となっています。
※註: Common Lispにはletfはありません。
なお、代入して元に戻す方式と、スペシャル変数のようなバインディング方式の違いですが、マルチプロセス時等に挙動が変ってきます。
また、letfで扱えるのは、ロカティブのみです。
setfでは読み出しと書き込みで整合性がなかったり非対称なものを定義できますが、こういうものはletfでは扱えません。
参考
■
HTML generated by 3bmd in LispWorks 7.0.0
定番メソッドコンビネーション紹介: list
Posted 2018-12-08 08:45:11 GMT
《 Lisp メソッドコンビネーション Advent Calendar 2018 8日目 》
今回はCommon Lispの組み込みメソッドコンビネーションのlistを紹介していきます。
listメソッドコンビネーション
listは、メソッドの集合をlistで囲んだように実行するもので、全体の結果がリストとして返ってきます。
(defgeneric foo (x)
(:method-combination list))(defmethod foo list ((x number))
(cons x 'number))
(defmethod foo list ((x rational))
(cons x 'rational))
(defmethod foo list ((x float))
(cons x 'float))
(defmethod foo list ((x integer))
(cons x 'integer))
(foo 1)
→ ((1 integer) (1 rational) (1 number))
こんなのどこで使うんだと思ってしまいますが、あれこれ考える中で、返り値がリストということは、:aroundで色々変形してやれば、結構汎用的な使い方もできることに気付きました。
多値で返す
(defmethod foo :around (x)
(values-list (call-next-method)))(foo 1)
→ (1 integer)
(1 rational)
(1 number)
任意の集約
(defmethod foo :around (x)
(reduce (lambda (x ans)
`(,(+ (car x) (car ans))
,(cons (cadr x) (cadr ans))))
(call-next-method)
:initial-value '(0 nil)
:from-end T))(foo 1)
→ (3 (integer rational number))
標準の組み込みメソッドコンビネーションで結果を集約する関数系のものに、+、min、max、append、nconcがありますが、これ等は、list+:aroundで集約で実現できてしまいそうです。
自ら今後紹介するメソッドコンビネーションのネタを潰してしまった感もありますが、次回も、標準組み込みのメソッドコンビネーションを紹介したりしようかなと思います。
■
HTML generated by 3bmd in LispWorks 7.0.0
実践SETF定義: defsetf長形式篇
Posted 2018-12-07 18:38:26 GMT
《 Lisp SETF Advent Calendar 2018 8日目 》
実践編今回は、defsetfの長形式篇です。
前回、defsetfの短形式を紹介しましたが、短形式では、引数の順番等の条件がうまく嵌ればとても簡潔に書けます。
しかし、そうはいかない場合もあるのと、仮引数で&optional、&key等々と指定したい場合にdefsetfの長形式を使うことになります。
短形式と同じ例ですが、こんなゲッターとセッターの対があった場合、
(defun kar (list)
(car list))(defun set-kar (list val)
(rplaca list val))
(let ((u (list 0 1 2)))
(set-kar u 42)
(list u (kar u)))
→ ((42 1 2) 42)
(defsetf kar (list) (val)
`(set-kar ,list ,val))のように、普通のマクロ定義のような感じで書けます。
(let ((u (list 0 1 2)))
(setf (kar u) 42)
(list u (kar u)))
→ ((42 1 2) 42) 引数宣言の順番も、setfが使われる場合の引数の順番と同じなので迷うこともないでしょう。
短形式では、非常に簡潔に書けました、
(defsetf kar set-kar)しかし、長形式で明示的に書かれていた方が判り易いですね。
defsetfで定義できるものは基本的にセッターとゲッターが存在し、それが対称に動作しているものになります。
defsetfで扱えないようなイレギュラーなものは、最も汎用的なsetf定義オペレーターである、define-setf-expanderとget-setf-expansionを駆使することになります。
アドベントカレンダーの後半ではイレギュラーなsetf定義でも紹介していこうかなと思います。
■
HTML generated by 3bmd in LispWorks 7.0.0
定番メソッドコンビネーション紹介: progn
Posted 2018-12-06 17:46:30 GMT
《 Lisp メソッドコンビネーション Advent Calendar 2018 7日目 》
今回はCommon Lispの組み込みメソッドコンビネーションのprognを紹介していきます。
prognメソッドコンビネーション
prognは、メソッドの集合をprognで囲んだように実行するものです。
メソッドコンビネーションアドベントカレンダー 5日目で、フィルターのパターンをメソッドコンビネーションですっきり書けないか考えていましたが、アイテムの一時置き場を用意して更新していくことが可能であれば、prognで書けそうだと思ったので試してみました。
メニューにはアイテム置き場とフィルター適用済アイテムを持たせて、初期化とソートを:aroundで、他各種フィルターの適用は、prognメソッドコンビネーションで実行してみています。
(defclass menu ()
((items :initform '() :initarg :items :accessor items)
(filtered-items :initform '() :initarg :items :accessor filtered-items)))(defclass fizz-filtered-menu (menu) ())
(defclass buzz-filtered-menu (menu) ())
(defclass *-filtered-menu (fizz-filtered-menu buzz-filtered-menu) ())
(defgeneric filter (menu)
(:method-combination progn))
(defmethod filter :around ((menu *-filtered-menu))
(setf (filtered-items menu) ;filtered-items初期化
(items menu))
(call-next-method) ;フィルタリング
(setf (filtered-items menu) ;昇順にソート
(sort (filtered-items menu) #'<))
menu)
(defmethod filter progn ((menu fizz-filtered-menu))
(setf (filtered-items menu)
(remove-if-not (lambda (x) (zerop (mod x 3)))
(filtered-items menu)))
menu)
(defmethod filter progn ((menu buzz-filtered-menu))
(setf (filtered-items menu)
(remove-if-not (lambda (x) (zerop (mod x 5)))
(filtered-items menu)))
menu)
フィルターを掛けるためだけに、mixin的なクラスを定義するのが、微妙な気がしますが、まあ良しとしましょう。
実行してみましょう。
(let ((menu (make-instance '*-filtered-menu
:items (loop :repeat 100 :collect (random 100)))))
(filtered-items (filter menu)))
→ (0 15 30 45 45 60 60 60 75) 先日定義してみたmc-expandで展開形を確認してみると、:aroundで囲まれたprognということが判ります。
(mc-expand #'filter 'progn nil (make-instance '*-filtered-menu))
→
(call-method
#<standard-method filter (:around) (*-filtered-menu) 41C008E0CB>
((make-method
(progn
(call-method #<standard-method filter (progn) (fizz-filtered-menu) 402003E7FB> nil)
(call-method #<standard-method filter (progn) (buzz-filtered-menu) 4020052C8B> nil))))) :around修飾子の謎 その二
:aroundは、メソッド単体を囲んで実行するというよりは、コンビネーション全体を取り囲うものなのでは? Flavorsのdefwrapperのような使い方をするのではないか? と昨日書きましたが、改めてSonya Keene氏 のObject-Oriented Programming in Common Lisp(邦訳:Common Lispオブジェクト指向)を確認したところ、「5. Controlling the Generic Dispatch」の章でちゃんとそんな風に説明してました。
前に読んでた筈でしたが、すっかり忘れていたようです……。
Object-Oriented Programming in Common Lisp(邦訳:Common Lispオブジェクト指向)は、Common Lispにオブジェクトシステムを導入するのにあたって貢献した人達(主にSymbolics)が執筆に協力している本なので、割合に説明が細かいです。
また、多くの書籍では、Common Lispと他の言語のオブジェクトシステムとの対比でオブジェクトシステムに変な機能があるとか無いとかで説明されることも多いですが、この本は、Common Lispネイティブな視点で書かれている所もお勧めです(ANSI CL成立前の仕様だったりするのが若干残念)
次回も、標準組み込みのメソッドコンビネーションを紹介したりしようかなと思います。
■
HTML generated by 3bmd in LispWorks 7.0.0
定番メソッドコンビネーション紹介: and
Posted 2018-12-05 18:10:00 GMT
《 Lisp メソッドコンビネーション Advent Calendar 2018 6日目 》
今回はCommon Lispの組み込みメソッドコンビネーションのandを紹介していきます。
andメソッドコンビネーション
standardはパターンに分類するなら呼び出しのフックの実現でしたが、andは、メソッドの集合をandで実行するものです。
二次元座標2dと、それを継承した3d、ついでに何故か2dのスーパークラスである1dがある場合を考えてみましょう。
(defclass 1d ()
((x :initarg :x :accessor x)))(defclass 2d (1d)
((y :initarg :y :accessor y)))
(defclass 3d (2d)
((z :initarg :z :accessor z)))
これらの等価を判定する==を考えてみると、andを使えば、
(defgeneric == (x y)
(:method-combination and))(defmethod == and ((a 1d) (b 1d))
(= (x a) (x b)))
(defmethod == and ((a 2d) (b 2d))
(= (y a) (y b)))
(defmethod == and ((a 3d) (b 3d))
(= (z a) (z b)))
こんな風にすっきり書けます。
(== (make-instance '1d :x 10)
(make-instance '1d :x 10))
→ t (== (make-instance '2d :x 10 :y 20)
(make-instance '2d :x 10 :y 25))
→ nil
(== (make-instance '3d :x 100 :y 50 :z 80)
(make-instance '3d :x 100 :y 50 :z 80))
→ t
(== (make-instance '3d :x 100 :y 50 :z 80)
(make-instance '3d :x 100 :y 50 :z 8))
→ nil
前回定義してみたmc-expandで展開形を確認してみると、こんな感じに、実際にandでメソッドが囲まれています。
※なお展開形は実装依存です。LispWorksでは実際は、sys::blocked-andが使われています。
(mc-expand #'==
'and
nil
(make-instance '3d :x 100 :y 50 :z 80)
(make-instance '3d :x 100 :y 50 :z 8))
→
(and (call-method #<standard-method == (and) (3d 3d) 41D052D4A3>
nil)
(call-method #<standard-method == (and) (2d 2d) 41D052D48B>
nil)
(call-method #<standard-method == (and) (1d 1d) 41D04E5EE3>
nil))さらに、andは、:around修飾子も持っているので、実行の全体を何かの処理で包みたい場合に使えます。
(defvar *debug* nil)(defgeneric == (x y)
(:method-combination and))
(defmethod == and ((a 1d) (b 1d))
(when *debug* (print (list (x a) (x b))))
(= (x a) (x b)))
(defmethod == and ((a 2d) (b 2d))
(when *debug* (print (list (y a) (y b))))
(= (y a) (y b)))
(defmethod == and ((a 3d) (b 3d))
(when *debug* (print (list (z a) (z b))))
(= (z a) (z b)))
(defmethod == :around (x y)
(let ((*debug* T))
(call-next-method)))
(== (make-instance '3d :x 100 :y 50 :z 80)
(make-instance '3d :x 1 :y 50 :z 80))
▻ (80 80)
▻ (50 50)
▻ (100 1)
→ nil
:around修飾子の謎
メソッドコンビネーションアドベントカレンダーを書き始める前は、and等でも:aroundが使えるのを知りませんでした。
使えることを知ってからも一体何に使うのか謎でしたが、Flavorsにあった、defwrapperのようなパターンを記述するためなのかもしれません。
そう考えると:aroundが最外周に配置されることもなんとなく分かる気がしますが、
上記の例は、ちょっとわざとらしい例ながらもdefwrapperの使い方に近いです。
次回も、標準組み込みのメソッドコンビネーションを紹介したりしようかなと思います。
■
HTML generated by 3bmd in LispWorks 7.0.0
実践SETF定義: defsetf短形式篇
Posted 2018-12-05 16:45:28 GMT
《 Lisp SETF Advent Calendar 2018 6日目 》
実践編今回は、defsetfの短形式篇です。ネタは刻んでいきます。
defsetfや、define-method-combinationでは、良く使いそうなものを短く書ける短形式と、詳細にパラメータを記述できる長形式がありますが、そんなに頻繁に使うわけでもないので、短形式があることで逆に混乱を招いている気がします……。
そんな短形式ですが、既存のゲッターとセッターが違う名前で存在する場合に、ゲッターの名前に統一するような場合に使えます。
具体例としては、こんな対があった場合、
(defun kar (list)
(car list))(defun set-kar (list val)
(rplaca list val))
(let ((u (list 0 1 2)))
(set-kar u 42)
(list u (kar u)))
→ ((42 1 2) 42)
defsetf一発で(setf kar)に纏められます。
(defsetf kar set-kar)しかし、セッター側の引数の順番に注意。
うまくはまるには、変数→値の順である必要があります。
(let ((u (list 0 1 2)))
(setf (kar u) 42)
(list u (kar u)))
→ ((42 1 2) 42) 処理系の基本関数などの定義では、結構使われているようですが、ユーザーが書くプログラムで、バラバラの名前のゲッター、セッターをsetfのもとに統一する、ということはあまりなさそうです。
長形式だけを用意しておいて、パターンが頻出する場合には、ユーザにマクロを書かせる、という方針でも良かったのでは……。
次回は、defsetfの長形式を解説してみます。
■
HTML generated by 3bmd in LispWorks 7.0.0
カジュアルにメソッドコンビネーション定義してみよう
Posted 2018-12-05 07:11:18 GMT
《 Lisp メソッドコンビネーション Advent Calendar 2018 5日目 》
組み込みのメソッドコンビネーションのパターンを淡々と紹介していこうかなと思いましたが、eshamsterさんの記事が面白かったので、自分も簡単なものを考えて定義してみることにしました。
フィルターでメソッドコンビネーションが使えないか
たまたま今日GUIの一覧メニューのフィルターを作成していて、フィルターってメソッドコンビネーションで上手く書けるのでは?と思ったので試してみます。
とりあえず、リスト対して絞り込みの関数を順にandな感じで適用していく、という感じです。
通常なら、下記のようにでも書くのかなという所です。
(flet ((filter-integerp (list)
(remove-if-not #'integerp list))
(filter-evenp (list)
(remove-if-not #'evenp list))
(filter-flatten (list)
(flatten list)))
(defparameter *fns* (list #'filter-flatten
#'filter-integerp
#'filter-evenp)))(reduce (lambda (res f)
(funcall f res))
*fns*
:initial-value
'((1 2 3 4 (1 2 3 4 nil t 8) t 8) (1 2 3 4 (1 2 3 4 nil t 8) t 8)))
→ (2 4 2 4 8 8 2 4 2 4 8 8)
フィルターをメソッドコンビネーションで書いてみよう
下準備
メソッドコンビネーションを定義するにあたって、コンビネーションがどう展開されるかを確認しつつ書きたいので展開ユーティリティを定義すると良いかなと思います。
(ql:quickload :closer-mop)(defun mc-expand (gf mc mcopts &rest args)
(c2mop:compute-effective-method gf
(c2mop:find-method-combination gf mc mcopts)
(compute-applicable-methods gf args)))
これでこんな感じに展開できます。
(mc-expand #'foo
'chain
'()
'(1 2 3 4 nil t 8))
→
(progn
(call-method
#<standard-method foo (chain evenp-filter) (list) 4020328873>
((make-method
(call-method
#<standard-method foo (chain integerp-filter) (list) 4020231D53>
nil))))) 展開を確認しながら書けるのであれば、謎のdefine-method-combinationも使いこなせる気がしてきます。
書いてみる
さて、とりあえずは、フィルター適用の順序不定で良しとして、こんな感じに書いてみました。
標準のメソッドコンビネーションでは、:before、:after等、修飾子の指定は一つですが、実際はこの部分はリストになっていて、equalで等価判定されます。
定義されるメソッドが違う名前であれば、クラス関係に関係なく増やすことが可能です。
(define-method-combination chain ()
((methods (chain . *)))
`(progn
,(reduce (lambda (m ms)
`(call-method ,m ,(and ms `((make-method ,ms)))))
methods
:initial-value nil
:from-end T)))(defgeneric foo (x)
(:method-combination chain))
(defmethod foo chain integerp-filter ((u list))
(remove-if-not #'integerp (call-next-method)))
(defmethod foo chain evenp-filter ((u list))
(remove-if-not #'evenp (call-next-method)))
(defmethod no-next-method ((gf (eql #'foo)) method &rest args)
(apply #'identity args))
(foo '(1 2 3 4 nil t 8))
→ (2 4 8) call-next-methodで次を呼ばないといけないのがめんどうな気がしますが、処理結果を次に渡す安直で良い方法が分かりません(メソッドを分解して関数を取り出しても良いのですが……)
順不同で登録/呼びだしをするのでno-next-methodでデフォルト値を返すようにしています。
やっぱり順番を指定したい
やっぱり適用順によってはエラーになるようなフィルター構成もあるので、順番は指定しても良いかなと思ったので、優先順位を指定してみることにしました。
(defun ordered-chain-qualifier-p (method-qualifiers)
(typep method-qualifiers
'(cons (eql ordered-chain) (cons integer (cons T null)))))(define-method-combination ordered-chain ()
((methods ordered-chain-qualifier-p))
(let ((methods (remove-duplicates methods
:key (lambda (method)
(third (method-qualifiers method)))
:from-end T)))
`(progn
,(reduce (lambda (m ms)
`(call-method ,m ,(and ms `((make-method ,ms)))))
(stable-sort methods #'>
:key (lambda (method)
(second (method-qualifiers method))))
:initial-value nil
:from-end T))))
(defgeneric bar (x)
(:method-combination ordered-chain)))
(defmethod bar ordered-chain 0 identity ((u list))
u)
(defmethod bar ordered-chain 100 integerp-filter ((u list))
(remove-if-not #'integerp (call-next-method)))
(defmethod bar ordered-chain 200 evenp-filter ((u list))
(remove-if-not #'evenp (call-next-method)))
(defmethod bar ordered-chain 1 flatten-filter ((u list))
(flatten (call-next-method)))
展開はこんな感じです。
(mc-expand #'bar
'ordered-chain
'()
'(1 2 3 4 nil t 8))
→
(progn
(call-method
#<standard-method bar (ordered-chain 200 evenp-filter) (list) 4020447F83>
((make-method
(call-method
#<standard-method bar (ordered-chain
100
integerp-filter) (list) 402031D65B>
((make-method
(call-method
#<standard-method bar (ordered-chain
1
flatten-filter) (list) 4020458C5B>
((make-method
(call-method
#<standard-method bar (ordered-chain 0 identity) (list) 4020467533>
nil)))))))))))メソッドコンビネーション修飾子の二番目に整数で優先度を付けてみました。
パターンマッチでも行けると思いますが、ordered-chain-qualifier-pを定義して選別しています。
メソッドコンビネーション修飾子はequalで判定されると上述しましたが、優先度を変更して再定義するとメソッドがどんどん増えてしまうので、重複も削除しています。
また、デフォルトメソッドを最優先として定義すればno-next-methodの定義も不要になります。
さて実行してみると、
(bar '((1 2 3 4 (1 2 3 4 nil t 8) t 8) (1 2 3 4 (1 2 3 4 nil t 8) t 8)))
→ (2 4 2 4 8 8 2 4 2 4 8 8) とりあえずは、3つのフィルターが順に適用されているようです。
問題点
しかし、優先度を付けてみると、今度は、call-next-methodと優先番号の組み合わせが直感的でない気がします。
具体的には、優先番号が低い順から呼ばれるのに、引数の適用は優先度の高い方からされる、ということで、call-next-methodで呼ばない場合、連鎖は優先度が低い方から途切れてしまいます。
call-methodの入れ子にしないで、平坦に優先順に並べ、適用結果を次々に受け渡すことができれば、整合性は取れる筈ですが……。
メソッドコンビネーションアドベントカレンダー終了まで良い解決策が思い付けば記事のネタにしたいと思います。
■
HTML generated by 3bmd in LispWorks 7.0.0
TAOの!
Posted 2018-12-04 17:31:40 GMT
《 Lisp SETF Advent Calendar 2018 5日目 》
今回は、TAO/ELISの!、!!についてです。
実の所、TAO/ELISの!、!!は、setfとは挙動は似ているものの実現方法が異なったもので、Common Lispのようにマクロに展開されるものではなく、(!という特別な括弧が作る代入フォームです。
詳しくは、1986年のbit誌のマルチパラダイム言語 TAO 連載で解説されていますので興味のある方は参照してみると良いかと思います。
この!記法は、setfが!になった感じですが、上述のように特殊な括弧です。
(!(car x) 42) ≡ (setf (car x) 42) このフォームは読み書きの場所を返すようになっている(マシンの支援あり)ので、
(!(if pred (car x) x) 42)のようなものもsetfのような事前のマクロ定義なしに書くことが可能です。
!!の方は自己代入式といって、これも面白くて便利なのですが、フォームの結果を代入する場所を!で指定して書き込むというものです。
これを使うと(setq x (+ x 42))のような良くある代入が、
(!!+ !x 42)のように書けます。
(!!cdr !x) ≡ (pop x)(!!nconc !(car x) y) ≡ (setf (car x) (nconc (car x) y))
(!!delete 'a !x) ≡ (setq x (delete 'a x))
等々入り組んだ表現になる程シンプルに書けたりします。
ちなみに、このアイデアは、1979のTAO/60にはあったようで、PDP-11上に実装された初期のTAO/60について書かれた、TAO LISP についての5. 複値形式 (Double valued form)の段落で説明があります。
これによると、
複値形式の概念に思い至ったのは, ALGOL68 や Pascal のプログラムを Lisp に移し替えようとしたとき, どうしてもスムーズにいかなかった悔しい経験があったからである.
とのことなので、やはりAlgol系言語の左辺値の書法が念頭にあったようです。
記法は、TAO/ELISの!ではなく、:を使っています。
TAO/ELISでは、Common Lispに接近したため、キーワードシンボルと記法がぶつかってしまうために!になったようです。
(TAO/ELIS復活祭(2010)で竹内先生が軽く説明していました)
インタプリタの軽快な動作に力を入れていたTAO/ELISでしたが、setfのようにコンパイル前提のマクロでの実現ではない方向で工夫を凝らした代入機構の紹介でした。
ちなみにCommon Lispでも、リーダーマクロで(を再定義すれば、そこそこ似た感じに記述することは可能です。
興味のある方は挑戦されてみてはいかがでしょうか。
■
HTML generated by 3bmd in LispWorks 7.0.0
実践SETF定義: #'(setf foo)篇
Posted 2018-12-03 16:50:53 GMT
《 Lisp SETF Advent Calendar 2018 4日目 》
どうもsetf機構についてどんどんマイナーな方向に進んでしまいそうなので、実践的なものも挟んでいきたいと思います。
Common Lispでのsetfの定義方法と定義構文ですが、やたらと数が多いです。
しかも、省略形式と、詳細形式に分かれていたりして、一体何を使ったら良いのかと思うこともままあります。
ざっと一覧にすると、
- 自動アクセサ生成系(
defclass、defstruct) - Macro Forms as Places/Symbol Macros as Places で自動で定義される系
(defun/defmethod (setf ...))defsetfdefine-setf-expanderdefine-modify-macro
加えて、定義時に使う補助関数として、get-setf-expansionがあります。
今回は、上記から、(defun/defmethod (setf ...)) を解説したいと思います。
(defun/defmethod (setf ...))
(defun/defmethod (setf ...)) の形式は、CLtL1には存在しておらず、ANSI CLになってから追加されたものです。
追加の目的ですが、メソッドのアクセサをdefmethodで定義させたいためです。
(defclass foo ()
(a b c))(defmethod (setf foo-a) (val (obj foo))
(setf (slot-value obj 'a) val))
こんな感じのことがしたいという訳ですが、ANSI CLでは、この為に関数名を拡張して、(setf foo)というような名前も使えるようにしました。
なお、この形式の関数名はsymbol-functionでは扱えないのでfdefinitionを利用します。(専らfdefinitionを使っておけば良いのですが)
(funcall #'(setf foo-a) 42 (make-instance 'foo))
→ 42(setf (foo-a (make-instance 'foo)) 42)
→ 42
(fdefinition '(setf foo-a))
→ #<standard-generic-function (setf foo-a) 40E01CBF4C>
単なる関数/メソッドなので、setfとは関係ないこともできてしまいますが、当然ながら、これはスタイル上良くないこと、とされています。
(defun (setf foo) (val var)
(list var val))(setf (foo 'var) 'val)
→ (var val)
なお、処理系が標準関数のsetfの実装をマクロにするか関数にするかは任意なので、関数で書けるからといって、
(funcall #'(setf car)...)のような書き方をしても可搬性は期待できません。
個人的には良くやってしまうミスなのですが、統一して欲しい……。
アドベントカレンダーもまだまだ残りの日数がありますので、今後もsetfの定義のバリエーションについて書いていきます。
■
HTML generated by 3bmd in LispWorks 7.0.0
史上初のSETFを探す旅
Posted 2018-12-02 18:25:23 GMT
《 Lisp SETF Advent Calendar 2018 3日目 》
探す旅とか書いてますが、LispでSETFのようなものが初めて導入されたのは、結論からいうとLISP 2(1965)だと思います。
しかし、Lispの歴史の文献については、The Evolution of Lispが決定版で良く知られているものなのですが、LISP 2についての記述は何故か殆どありません。
EoLに拠り所にするならば、1973年のL Peter Deutsch氏のByte Lisp(setfq)が最初となるでしょう。
さて、LISP 2ですが、LISP 2は、後世のLispの試行錯誤を先取りしている所が多々ありますが、それはAlgolとの接近による所が多いです。
その後のLispがAlgol化していったから、とも言えますが、具体的には、
- Algol構文の採用(Algolとコード共用できるレベルを目指す)
- 型宣言の導入
- 静的スコープの採用
- 拡張された左辺値
あたりがあります。
1975年にSchemeがAlgolの影響でLispに静的スコープを取り入れたのが、Lisp史の一つの大きな転換点とされますが、Schemeに10年先行して、LISPをまんまAlgol化しようとしたLISP 2が完全に忘却されているのは不思議ではあります。
なお、LISP 2の発掘については、Paul McJones先生が熱心に取り組まれているようです。
LISP 2は構想のみで実装はなかった、とされていましたが、先日実装も発見されたようです。後世で発掘されるというのも面白い。
さて、この記事ではsetfがメインテーマなので、上記3項目の中では、拡張された左辺値について詳しくみて行くのですが、setf関連については、
LISP II Internal Language(1965) 3.1 ASSIGNMENT-EXPRESSION, LOCATIVES に纏められています。
これによると、(SET locative expression)という形式になっていて、locativeというのがCommon Lispのsetfでいうplaceという感じになっています。
locativeには、ビットやリスト、配列があり、下記のように書けたようです。
(set (car x) b)(set (cdr x) b)
(set (bit 2 2 a) (bit 2 2 15))
(block ((a real array) (m integer))
(set (a m) 42))
(set (prop (quote x)) (quote (p 42)))
S式は中間言語なので、表層言語でも書いてみると、
car x ← b;cdr x ← b;
bit (2, 2, a) ← bit (2, 2, 15);
begin real array a; integer m;
a[m] ← 42;
end;
prop 'x ← '(p 42);
となります。
これらは、Common Lispで書くと、それぞれ、
(setf (car x) b)(setf (cdr x) b)
(setf (ldb (byte 2 2) a) (ldb (byte 2 2) 15))
(setf (aref a m) 42)
(setf (symbol-plist 'x) '(p 42))
となります。
LISP 2では型宣言するので、配列のsetでは、(配列名 インデックス)という形式でOKのようです。
読み出しと書き込みの記法の二重性について
左辺値について、1960年代初頭のFORTRAN、Algol、CPLあたりの扱いを眺めてみましたが、左辺に配列の記法が来るものは、添字付き変数という概念のようで、配列のアクセサが介在するものではないようです。
LISP 2の記法でもその辺りを踏襲しているように見えますが、locativeという概念で左辺にアクセサの記法が出てくるのは、当時の他の言語と比べてもそれなりに先進的だったのかもしれません。
参考
■
HTML generated by 3bmd in LispWorks 7.0.0
定番メソッドコンビネーション紹介: standard
Posted 2018-12-01 20:40:27 GMT
《 Lisp メソッドコンビネーション Advent Calendar 2018 2日目 》
ほぼ無計画なので、内容が続き物だったりそうではなかったりします。
とりあえず、定番というか、Common Lispに標準で用意されているメソッドコンビネーションの紹介でもしていこうかなと思います。
standardメソッドコンビネーション
Common Lispのdefmethodで定義したものは、標準でこのタイプになります。
主な登場人物は、:before、:after、:around、call-next-methodです。
:before、:after、:aroundは、指定したコンビネーションでのメソッドの追加で利用し、call-next-methodは、優先順位リストに従って次のメソッドを起動します。
他のOOP言語では、superに相当しますが、Common Lispでは、必ずしも継承順位で上位ものを呼び出すわけではないので、call-nextなのでしょう。
とりあえず、実際に:before、:after、:around、call-next-method全部盛りのメソッドを定義して動作を確認してみましょう。
(progn
(defclass c1 () ())
(defclass c2 (c1) ())
(defclass c3 (c2) ()))(progn
(defmethod foo ((o c1))
(format T "~16T~A~%" '(foo c1)))
(defmethod foo ((o c2))
(format T "~16T~A~%" '(foo c2))
(call-next-method))
(defmethod foo ((o c3))
(format T "~16T~A~%" '(foo c3))
(call-next-method))
;;
(defmethod foo :before ((o c1))
(format T "~8T~A~%" '(foo c1 :before)))
(defmethod foo :before ((o c2))
(format T "~8T~A~%" '(foo c2 :before)))
(defmethod foo :before ((o c3))
(format T "~8T~A~%" '(foo c3 :before)))
;;
(defmethod foo :after ((o c1))
(format T "~24T~A~%" '(foo c1 :after)))
(defmethod foo :after ((o c2))
(format T "~24T~A~%" '(foo c2 :after)))
(defmethod foo :after ((o c3))
(format T "~24T~A~%" '(foo c3 :after)))
;;
(defmethod foo :around ((o c1))
(format T "~A~%" '(foo c1 :around))
(call-next-method))
(defmethod foo :around ((o c2))
(format T "~A~%" '(foo c2 :around))
(call-next-method))
(defmethod foo :around ((o c3))
(format T "~A~%" '(foo c3 :around))
(call-next-method)))
とりあえず、実行してみるとこんな感じになります。
(foo (make-instance 'c3))
▻ (foo c3 around)
▻ (foo c2 around)
▻ (foo c1 around)
▻ (foo c3 before)
▻ (foo c2 before)
▻ (foo c1 before)
▻ (foo c3)
▻ (foo c2)
▻ (foo c1)
▻ (foo c1 after)
▻ (foo c2 after)
▻ (foo c3 after)
→ nil大元のメソッドは、プライマリメソッドと呼びますが、call-next-methodで次のメソッドを呼ぶことが可能です。
上記では、(foo c3)、(foo c2)で明示的に呼び出していますが、もちろん無ければ呼ばれません。
:beforeは、プライマリメソッド起動の前に起動されますが、クラス優先順位リストの順に該当するものは全て呼び出されます。
:afterは、:beforeと対称の動作です。
なお、:before、:afterの中では、call-next-methodは使用できません。
:aroundが割合に複雑ですが、:aroundがあれば、それが最初に起動されます。
その:aroundの中で、call-next-methodが起動されれば、クラス優先順位リスト順に、次の:aroundを起動、:aroundがなければプライマリメソッドを起動します。
call-next-methodを呼べば、その返り値が利用できるので、このデフォルト値を加工するような使い方が殆どです。
:before、:afterではcall-next-methodが使えないので、スロットの値を設定する等、副作用目的での利用となります。
GoFのObserverパターンのようなものは、呼び出しイベント時に起動したいフックのようなものが多いので、:before、:afterで賄うことが可能かなと思います。
メソッドの中身を覗いてみる
compute-effective-methodで確認すると、call-methodの連鎖が直接見えて判り易いので確認してみると下記のようになります。
call-methodは第一引数に起動するメソッド、第二引数にそれ以降で起動するメソッドのリストを取りますが、入れ子にしていけば、所謂、継続渡しに似た記述になります。
起動リストが空か、メソッドのボディにcall-next-methodの記述がなければ、以降のメソッドは起動されず、そこで処理はストップします。
(c2mop:compute-effective-method #'foo
(c2mop:find-method-combination #'foo 'standard nil)
(compute-applicable-methods #'foo (list (make-instance 'c3))))→ (call-method
#<standard-method foo (:around) (c3) 4190211F13>
(#<standard-method foo (:around) (c2) 4190211F2B>
#<standard-method foo (:around) (c1) 4190211C93>
(make-method
(progn
(call-method #<standard-method foo (:before) (c3) 419021266B> '())
(call-method #<standard-method foo (:before) (c2) 4190212683> '())
(call-method #<standard-method foo (:before) (c1) 419021258B> '())
(multiple-value-prog1
(call-method
#<standard-method foo nil (c3) 4190212753>
(#<standard-method foo nil (c2) 419021276B>
#<standard-method foo nil (c1) 419021269B>))
(call-method #<standard-method foo (:after) (c1) 4190211F43> '())
(call-method #<standard-method foo (:after) (c2) 4190212573> '())
(call-method #<standard-method foo (:after) (c3) 419021255B> '()))))))
元祖Flavorsのデフォルトコンビネーション
元祖Flavorsでは、当初デフォルトのメソッドコンビネーションとして、:daemonコンビネーションが用意されていましたが、登場したのは大体1981年頃のようです。
これは、:before、プライマリ、:afterの組み合わせで、Common Lispのstandardからcall-next-methodと:aroundを削ったような挙動ですが、1984年あたりになると、:aroundも追加された様子。
call-next-methodのようなものはなく、#'(:method flavor method-name)のような形式で直接呼び出したり、:around専用の継続メソッドを呼び出す構文を使ったようです。
次回は、andコンビネーションあたりを紹介しようと思います。
■
HTML generated by 3bmd in LispWorks 7.0.0
メソッドコンビネーションってなに?
Posted 2018-12-01 09:50:35 GMT
《 Lisp メソッドコンビネーション Advent Calendar 2018 1日目 》
Lisp メソッドコンビネーション Advent Calendar 2018始まりました。
開始初日にして既につらい。
setfネタともう一品と思ってテーマにメソッドコンビネーションを選んでみましたが、setf以上にニッチでした。
メソッドコンビネーションってなに?
さて、メソッドコンビネーションについての説明ですが、読んでそのまま、メソッドのコンビネーションのことです。
どういう面の組み合わせかというと、ざっくりメソッドの起動とその順番についてと考えて良いでしょう。
(defclass k0 () ())
(defclass k1 (k0) ())
(defclass k2 (k1) ())(defmethod m ((obj k2)) 'k2)
(defmethod m ((obj k1)) 'k1)
(defmethod m ((obj k0)) 'k0)
こんな感じの定義があったとすると、
Common Lispでは、compute-applicable-methodsで起動するメソッドを確認することが可能です。
(compute-applicable-methods #'m (list (make-instance 'k2)))(#<standard-method m nil (k2) 40E011D08B>
#<standard-method m nil (k1) 40E004A153>
#<standard-method m nil (k0) 40E006B64B>)
上記の定義では、k0 < k1 < k2 という継承順のクラスに対し、それぞれmを定義しています。
k2についてmを起動してみると、
(m (make-instance 'k2))
→ k2 となりますが、Common Lispの標準では、compute-applicable-methodsで求めたリストのメソッドが呼ばれていきます。
この例では他2つのメソッドは、呼ばれませんが、明示的な操作と相対的な名前で呼ぶことも可能です。
3つのメソッドのコンビネーションについて説明しましたが、Common Lispでは上記はstandardという名前が付いています。
なんとなく想像が付くかと思いますが、Common Lispでは任意のメソッドの束を任意の構成で呼んだり呼ばなかったりが可能です。
Advice機構とメソッドコンビネーション
メソッドコンビネーションというとbefore、after等の修飾子を付けてフックを掛ける使い方の印象が強いと思います。
具体的な例でいうと、上記のコードにbefore、afterを追加定義してmを起動すると、
(defmethod m :before ((obj k2)) (print "before k2"))
(defmethod m :after ((obj k2)) (print "after k2"))(m (make-instance 'k2))
▻ "before k2"
▻ "after k2"
→ k2となります。
さて、compute-applicable-methodsで確認してみると、メソッドが増えているのが分かります。
(compute-applicable-methods #'m (list (make-instance 'k2)))
→ (#<standard-method m (:after) (k2) 40E0868EF3>
#<standard-method m (:before) (k2) 40E086956B>
#<standard-method m nil (k2) 40E011D08B>
#<standard-method m nil (k1) 40E004A153>
#<standard-method m nil (k0) 40E006B64B>)起動のされ方については、Common LispのMOPで定義されているcompute-effective-methodで起動コードを確認することが可能です。
(c2mop:compute-effective-method #'m
(c2mop:find-method-combination #'m 'standard nil)
(compute-applicable-methods #'m (list (make-instance 'k2))))
→ (progn
(call-method #<standard-method m (:before) (k2) 40204EB4DB> nil)
(multiple-value-prog1
(call-method #<standard-method m nil (k2) 40E011D08B>
(#<standard-method m nil (k1) 40E004A153>
#<standard-method m nil (k0) 40E006B64B>))
(call-method #<standard-method m (:after) (k2) 40204E84E3> nil))) 上記はLispWorksの例ですが、起動するコードを直接確認できるので、何か良く分からなくなってきたら実際にどんなものが生成されるか確認してみるのも良いでしょう。
このように生成されたコードを眺めてみると、メソッドコンビネーションのコンビネーションの一つとして、フック/Advice機構が実現されていることが分かります。
本体メソッドの前後に副メソッドを配置するコンビネーションは、GoFデザインパターンでもObserverパターンとして良く知られていますが、古えのLisp畑(Flavors等)では、フレーム理論の影響からか、配置されるメソッドをdaemonと呼び、この標準パターンもdaemonと呼んでいます(ややこしい)
伝統を受け継いでいるCommon Lispでもこのコンビネーションが標準となっていて、standardという名前が付いている、という訳です。
フレームワークの代表的な使われ方と、フレームワークそのものが混同されるのは常ですが、メソッドコンビネーションもフックとしての使われ方だけではないことに留意する必要はあるでしょう。
今後は、メソッドコンビネーションの歴史、Common Lispや、Lisp Machine Lisp等でのメソッドコンビネーションの定義方法の解説etcを書いていく予定です(一体書けるのか)
■
HTML generated by 3bmd in LispWorks 7.0.0
SETFってなに?
Posted 2018-11-30 17:05:36 GMT
《 Lisp SETF Advent Calendar 2018 1日目 》
Lisp SETF Advent Calendar始まりました。
数年に一度Lisp系でニッチなAdvent Calendarを催したりしていますが、最近あまりニッチなことはしていませんでした。
その反動なのかLisp SETF Advent Calendarですが、ニッチすぎたかもしれません。
ちなみに、過去のニッチなAdvent Calendarには下記のようなものがあります。
- Lisp Reader Macro Advent Calendar 2012
- Metaobject Protocol(MOP) Advent Calendar 2013
- レトロLisp Advent Calendar 2016
SETFってなに?
さて、setfについての簡単な説明です。
プログラミング言語の代入構文にも様々ありますが、左辺に変数名だけでなく、配列の場所であったり、リストであったりが記述できるものがあります。
x := x + 1
a[x] := y + 1
a, b, c := list(0, 1, 2)
...右側にはどんな値でも置けるのですが、左側に置いて意味を成すものを考えると、値を代入できる場所の指定/参照、となることが多いようです。
Lispのsetfとは、値の読み書きの場所について一般化し、値の読み出しのフォームと同じ見た目のフォームで書き込みも表現しようというものです。
setfは、
(setf 場所 値)という形式ですが、「場所」には、変数名や値をアクセスする記述を使用できます。
一番身近なリスト操作のcarで説明すると、
リストのcar読み出しフォーム
(setq x (list 0 1 2 3)(car x)
→ 0
リストのcar書き込み
(