M式の魅力の無さについて
Posted 2021-05-14 01:29:23 GMT
LispといえばS式ですが、S式について語られる際には大抵はM式も一緒に話題にのぼります。
M式は実際の所、正式な仕様は存在しないので処理系製作者が独自に拡張したものをM式としていたことが多いようですが、今回は、そんなM式の魅力の無さについて考えてみましょう。
魅力の無さ その1: 別に中置記法ではない
前置記法のS式を比較対象とするからか、M式は中置記法といわれますが、中置の文法ではっきり決まっていそうなのは関数定義のdefineの=/≡位と、conldで使われる→位で、あとは前置ですし、ユーザー定義の関数は前置です。
後のプログラミング言語のようにユーザーが中置の文法を定義し結合度を定義する、という機構もありません。
M式の構文自体は、当時のFORTRAN I的に書けたら良いのではないか、という程度の構想だったようですが、FORTRAN Iの構文自体がそれ程洗練されたものでもありません。
結局のところ関数名が括弧の外に出ているだけ、という感じです。
fib[n] = [greaterp[2; n] → n;
T → plus[fib[difference[n; 1]];
fib[difference[n; 2]]]]なお、本格的なプログラミング構文としては、LISP 2でのALGOL構文の採用がありますが、LISP 2は構文としてはALGOLそのものなので中置構文のリッチさに関してはLISP 2が勝るでしょう。
LISP 2
integer function fib(n); integer n;
if n < 2
then n
else fib(n - 1) + fib(n - 2);
end;1960年代当時の次世代LISPであるLISP 2でのALGOL構文の採用が、M式をさらに中途半端な存在にした可能性もなくはないかなと思います。
なお、1960年代に実装されたM式系の構文としては、SDS 930 LISP(1965)のM-languageや中西先生のKLISPがあります。
中西先生の文献にはM言語というのが良く出てきますが、SDS 930 LISP由来なのかもしれません。
SDS 930 LISP
fib [n] : [2 > n # n;
T # (fib (n - 1)) + (fib (n - 2))]ちなみに蛇足ですが、S式はリストで式を表現しているだけなので、リストで中置記法を表現することは可能です。
((fib n) = ((2 > n) → n
T → ((fib(n - 1)) + (fib(n - 2)))))魅力の無さ その2: 括弧の数は少ししか減っていない
括弧は外側を囲むことによってグループ化しますが、括弧を減らす記法として、結合する記号を定義して前後を結合する中置記法や、インデントの深さによってグループ化するオフサイドルールや、引数の数を元に括弧を省略する本来のポーランド記法がありますが、上述のようにM式には極僅かしか中置構文が定義されていないので括弧の数は大してかわりません。
数学記号を中置演算子として用意すれば、括弧を減らすことは可能ですが、上述のようにユーザー定義部分は大して変化なしです。
fib[n] = [[2 > n] → n;
T → fib[n - 1] + fib[n - 2]]]魅力の無さ その3: 構文の括弧に[]を使っている
LISPの極初期では、構文は()とデリミタの,組み合わせで記述されていたようですが、LISP 1.5の頃には[]と;の組み合わせになってしまいました。
fib(n) = (greaterp(2, n) → n,
T → plus(fib(difference(n, 1)),
fib(difference(n, 2))))→
fib[n] = [greaterp[2; n] → n;
T → plus[fib[difference[n; 1]];
fib[difference[n; 2]]]]
()と,は、M式内のS式(リスト)の記法に使われることになったようですが、プログラムの記述の方をゴツくしてしまった理由は謎です。
魅力の無さ その4: 構文の記法とデータの記法が未分化
λの仮引数の後に;が必要だったりで構文というよりデータという感じがしてしまいます。
結局M式のこういう中途半端なところがS式へ吸収される原因だったのではないでしょうか。
fib = λ[[n];
[greaterp[2; n] → n
T → plus[fib[difference[n; 1]];
fib[difference[n; 2]]]]]魅力の無さ その5: データの記法とプログラム構文の記法を覚えないといけない
データからプログラムを作るLispならではの問題ですが、記法が2つあるとどういうルールでどう変換するのか、を覚える必要があります。
この辺りの課題は、M式、ALGOL構文のLISP 2、Dylan、最近だとJuliaにもありますが、プログラム構文としてリッチであれば、データへ変換する際のルールも多くなり直感的でなくなるでしょうし、貧弱であれば、S式で良いじゃんということになってしまいます。
まとめ
結局S式でいいですね。
関連
■
HTML generated by 3bmd in LispWorks 7.0.0
番号付き括弧
Posted 2021-05-12 01:47:37 GMT
PDP-11上のLISP処理系であるLISP-11のマニュアルを眺めていたところ、括弧の下の行に番号を付与している記述がありました。
1960年代初頭のパンチカード時代に良く利用されていたようですが、編集時の括弧のずれでエラーになった場合に不整合を素早く検知できたりするかもしれないので、そういうエディタコマンドを作成してみます。
(ql:quickload "split-sequence")
(defun numbered-parens (str)
(with-output-to-string (out)
(let ((pc 0))
(format out
"~&~{~A~^~%~}"
(mapcan (flet ((subchar (pc)
(character (princ-to-string (mod pc 10)))))
(lambda (line)
(list line
(map-into (make-string (length line))
(lambda (c)
(case c
(#\( (prog1 (subchar pc) (incf pc)))
(#\) (prog2 (decf pc) (subchar pc)))
(otherwise #\Space)))
line))))
(split-sequence:split-sequence #\Newline str))))))
#+LispWorks
(progn
(editor:defcommand "Numbered Parens" (p)
""
""
(declare (ignore p))
(editor::with-random-typeout-to-window ()
(editor::with-defun-start-end-points (beg end)
(editor:current-point)
(write-string (numbered-parens (editor::points-to-string beg end))))))
(editor:bind-key "Numbered Parens" "Control-N")
)括弧のエスケープの処理をきちんと処理するのは手間なので実装していませんが、こんな感じに表示します。
(defun numbered-parens (str)
0 1 1
(with-output-to-string (out)
1 2 2
(let ((pc 0))
2 34 43
(format out
3
"~&~{~A~^~%~}" (mapcan (flet ((subchar (pc)
4 5 67 8 8
(character (princ-to-string (mod pc 10)))))
8 9 0 09876
(lambda (line)
6 7 7
(list line
7
(map-into (make-string (length line))
8 9 0 09
(lambda (c)
9 0 0
(case c
0
(#\( (prog1 (subchar pc) (incf pc)))
1 2 3 4 4 4 432
(#\) (prog2 (decf pc) (subchar pc)))
2 2 2 3 3 3 321
(otherwise #\Space)))
1 109
line))))
8765
(split-sequence:split-sequence #\Newline str))
))))
5 543210まとめ
近頃だと括弧を虹色に分別して表示する機能があり、LispWorksにも標準で実装されていたりしますが、60年前のrainbow modeというところですね。
個人的には色分けされても括弧対応が判然としないのですが、数字付きだとさすがにはっきりします。
さて、果してデバッグで役に立つかどうか、しばらく使ってみます。
■
HTML generated by 3bmd in LispWorks 7.0.0
Common Lispでsingle-floatを返す関数をdouble-float返すようにする設定はあるか
Posted 2021-05-09 23:17:53 GMT
Common Lispでsingle-floatを返す関数をdouble-float返すようにする設定はあるか
Common Lispの標準状態の浮動小数点の精度は、単精度(single-float)です。
最近のプログラミング言語の標準の精度は倍精度(double-float)だったりするので、言語間を跨ぐと若干面倒だったりするのですが、標準で倍精度にする設定はないのでしょうか。
# Python
import cmath
cmath.sqrt(-1/3)
→ 0.5773502691896257j;; Common Lisp
(sqrt -1/3)
→ #C(0.0 0.57735026)結論:そういう設定はない
結論からいうと、そういう設定はありません。
*read-default-float-format*をdouble-floatにすると良いという話は良く耳にしますが、浮動小数点数の読み取りのデフォルトを設定するのみなので、整数等の読み取りには影響なしです。
(setq *read-default-float-format* 'double-float)
→ double-float
(sqrt -1/3)
→ #C(0.0F0 0.57735026F0)
(expt 1 1/2)
→ 1.0F0
上記のような場合、入力側で整数等を浮動小数点数に変換してやることになります。
(sqrt (float -1/3 0d0))
→ #C(0.0D0 0.5773502691896257D0)(expt 1 (float 1/2 0d0))
→ 1.0D0
まとめ
結局のところユーティリティパッケージを作成するしかないようですが、そういうパッケージを見掛けない気がするので需要はないのかもしれません。
作成するとしたら、Common Lispの標準関数で該当するものをdouble-float:sqrtのようにまとめることになりそうです。
■
HTML generated by 3bmd in LispWorks 7.0.0
HAKMEM: ITEM 59 (Schroeppel)
Posted 2021-05-07 23:52:11 GMT
このブログのためのネタ帳をひっくり返して眺めてみると5年位放置しているネタで、HAKMEM: ITEM 59 (Schroeppel)というメモがありました。
HAKMEMはMIT AIラボの人達のメモ集ですが、割合に雑多なメモです。
HAKMEM ITEM 59は、数字の関係だけが記述されていて、メモを残した理由も記述されていません。
2
91038 90995 89338 00226 07743 74008 17871 09376 =82880 83126 51085 58711 66119 71699 91017 17324
91038 90995 89338 00226 07743 74008 17871 09376
とりあえず、
- 2乗した場合に桁数が倍
- 下半分に自分自身が含まれる
ような数を探してみろということなのかなと思い、例題の40桁の倍の80桁のものを探してみることにします。
(defun fig (x)
(length (princ-to-string x)))
(defun test-it (x)
(multiple-value-bind (q r)
(floor (expt x 2)
(expt 10 (fig x)))
(= x r)))
(defun pp (x &optional (out *standard-output*))
(let ((xx (format nil "~,,' ,5:D" x)))
(format out
"~%~VD~%~A =~2%~{~V,,' ,5:D~%~}"
(1+ (length xx)) 2
xx
(multiple-value-bind (q r)
(floor (expt x 2)
(expt 10 (fig x)))
(list (length xx)
q
(length xx)
r)))))
(defun compose-num (x base)
(parse-integer (format nil "~D~D" x base)))
(defun decompose-num (x)
(maplist (lambda (ns)
(parse-integer (coerce ns 'string)))
(coerce (princ-to-string x) 'list)))
(defun hakmem59 (n &optional (limit 80))
;;雑な生成
(loop (when (>= (fig n) limit)
(return))
(dotimes (x 1001) ;雑な連続する0への対策
(let ((xn (compose-num x n)))
(when (test-it xn)
(setq n xn)))))
;;limit桁に切り詰め
(setq n (rem n (expt 10 limit)))
;;表示
(dolist (x (reverse (decompose-num n)))
(when (= (fig (expt x 2))
(* 2 (fig x)))
(pp x))))
2乗した場合に、下一桁に自身の数字が出現する数は、0、1、5、6ですが、下半分の桁に自分自身が現われるとなると、5、6しかありません。
ということで、5か6から出発して一桁ずつ数を当て嵌めて探していけば、簡単にみつかります。
(hakmem59 6 80)
...
...
2
61490 10993 78334 90419 13618 89994 42576 57676 91038 90995 89338 00226 07743 74008 17871 09376 =37810 33620 16684 89789 77935 64658 06599 50861 58235 23230 14798 96610 06702 69587 17457 60530
61490 10993 78334 90419 13618 89994 42576 57676 91038 90995 89338 00226 07743 74008 17871 09376
(hakmem59 5 80)
...
...
2
38509 89006 21665 09580 86381 10005 57423 42323 08961 09004 10661 99773 92256 25991 82128 90625 =
14830 11632 60015 08951 50697 84669 21446 35507 76157 41238 36122 96157 91215 21570 81715 41779
38509 89006 21665 09580 86381 10005 57423 42323 08961 09004 10661 99773 92256 25991 82128 90625
まとめ
以上、雑な探索をしてみましたが、多分探索しなくても一発でみつかる式があったりするんでしょうね。
■
HTML generated by 3bmd in LispWorks 7.0.0
構文チェッカーとしてのコンパイラマクロ
Posted 2021-05-06 02:32:02 GMT
コンパイラマクロがコンパイル時に展開されることを利用して、非推奨APIの警告を出すというアイデアがあったりしますが、スタイルチェッカー的なものを動かすタイミングとしては丁度良く、また、コンパイラマクロは意味論を変えないことが前提なので親和性も高いと思います。
ということで、コンパイラマクロが構文チェッカーとして使えないか考えてみたいと思います。
定義
まず、letの別名のmyというものを定義します。
(defmacro my ((&rest binds) &body body)
`(let (,@binds) ,@body))これに対し、
- 変数名の重複はエラー
- 変数束縛部では
(変数 値)という形式を強制
というのをコンパイラマクロで追加してみます。
(define-compiler-macro my (&whole whole (&rest binds) &body body)
(declare (ignore body))
(dolist (b binds)
(check-type b (cons symbol (cons T null))))
(assert (subsetp binds (remove-duplicates binds :key #'car :from-end T))
nil
"Variable name duplicated in bind spec: ~S"
binds)
whole)試してみる
束縛部の形式チェック
(defun foo ()
(my ((x 3) y)
(list x y)))
;⏏ Error: The value y of b inside (define-compiler-macro my) is not of type (cons symbol (cons t null)).束縛部の変数重複チェック
(defun foo ()
(my ((x 3) (x 4))
(list x)))
;⏏ Error: Variable name duplicated in bind spec: ((x 3) (x 9)).まとめ
チェッカーの使い勝手的には元のコードはいじらずに後からチェッカーを追加したりしたいところですが、define-compiler-macro定義は一つだけなので、元のコードをいじらないわけにはいきません。
compiler-macro-function関数をラップするようなインターフェイスを作成して、adviceの真似事をしてみれば可能な気もします。
何にしろコンパイラマクロを定義する場所は一つしかないので、複数のフックが共存できるような仕組みが必要ですね。
関連
■
HTML generated by 3bmd in LispWorks 7.0.0
Common Lispのテスト述語を宣言で指定する試み
Posted 2021-05-03 03:24:49 GMT
Common Lispのシークエンス関数のテスト述語はデフォルトでeqlですが、文字列の比較が多い最近では、equalがデフォルトの方が使い勝手が良い気がします。
最近のSBCLだとequalを指定しても最適化でeqlやeqにしたりするようですが、それと似た雰囲気でデフォルトをequalにし、declareでテスト述語の指定をすることにしたらどうかと思い試してみました。
下準備
declarationとdefine-declarationでユーザー宣言のtestを宣言します。
testは、(declare (test #'eql))のように使います。
(defpackage "b85d852d-3639-5467-af00-962feb136730"
(:use common-lisp)
(:import-from
#+lispworks harlequin-common-lisp
#+sbcl sb-cltl2
declaration-information
define-declaration)
(:shadow find))(in-package "b85d852d-3639-5467-af00-962feb136730")
(declaim (declaration test))
(define-declaration test (dcl env)
(declare (ignore env))
(values :declare dcl))
コンパイラマクロでの最適化
デフォルトはゆるくequalで、宣言でより判定が狭いeqlやeqを指定した場合に、それが使われるようにします。
(defun find (item sequence &key (test #'equal))
(cl:find item sequence :test test))
(define-compiler-macro find (&whole w item sequence &key (test #'equal)
&environment env)
`(cl:find ,item ,sequence :test
,(or (car (declaration-information 'test env))
test)))
確認
(defun find-foo (x)
(find x '("foo" "bar" "baz")))(find-foo "foo")
→ "foo"
(defun find-foo-dcl-eql (x)
(declare (test #'eql))
(find x '("foo" "bar" "baz")))
(find-foo-dcl-eql "foo")
→ nil
(flet ((sequal (x y)
(string-equal x y)))
(defun find-foo-dcl-string-equal (x)
(declare (test #'sequal))
(find x '("foo" "bar" "baz"))))
(find-foo-dcl-string-equal 'foo)
→ "foo"
まとめ
最適化の筋書だと、意味論は変えずに効率だけ良くなるような記述体系になる必要がありますが、今回の例だと、任意の述語を指定できるので、意味論が変ってしまうような指定もできてしまいます。
また、define-declarationでdeclaimのようなコンパイル単位ローカルなトップレベルの宣言ができれば、ファイルごとに述語のデフォルトを指定できたりして便利なのですが、どうもSBCLもLispWorksもトップレベルの宣言が定義できない様子。
define-declarationは標準機能ではないため、そういう仕様なのか単に実装の都合なのかは微妙ですが、ちょっと不思議。
■
HTML generated by 3bmd in LispWorks 7.0.0
Emacs Lispのネイティブコンパイラ vs Common Lisp
Posted 2021-04-28 22:14:11 GMT
今日はSNSでEmacs Lispのネイティブコンパイラがメインラインに来たという話題で賑っていたので、早速GNU Emacsを--with-native-compでビルドして、Common Lispのネイテイブコンパイラと比較してどんなものなのか眺めてみました。
眺めるといっても、お馴染のfibのマイクロベンチを走らせるだけですが。
Emacs Lisp で実行形態三種の比較
まず、Emacs Lispで、通常の定義、バイトコンパイル、ネイティブコンパイルで比較してみます。
いまひとつ作法が分かっていないのですが、定義形式を合せるために、(setf symbol-function)しています。
一応defunでの定義をファイルに書き出してからファイルをコンパイルする手順でも確認してみましたが、結果はほぼ同じようです。
最適化設定が良く分からないのですが、
(setq comp-speed 3)するとCommon Lispでいう、(declaim (optimize speed 3))的なことになるようなので、以下はこの設定の元で実験しています。
(setf (symbol-function 'fib)
(lambda (n)
(if (< n 2)
n
(+ (fib (1- n))
(fib (- n 2))))))(benchmark-call (lambda () (fib 30)) 1)
→ (0.540617072 0 0.0)
(benchmark-call (lambda () (fib 40)) 1)
→ (79.139097209 0 0.0)
(setf (symbol-function 'fib-bc)
(byte-compile
(lambda (n)
(if (< n 2)
n
(+ (fib-bc (1- n))
(fib-bc (- n 2)))))))(benchmark-call (lambda () (fib-bc 30)) 1)
→ (0.346994376 0 0.0)
(benchmark-call (lambda () (fib-bc 40)) 1)
→ (40.036792254 0 0.0)
(setf (symbol-function 'fib-nc)
(native-compile
(lambda (n)
(if (< n 2)
n
(+ (fib-nc (1- n))
(fib-nc (- n 2)))))))(benchmark-call (lambda () (fib-nc 30)) 1)
→ (0.253148658 0 0.0)
(benchmark-call (lambda () (fib-nc 40)) 1)
→ (29.594145706 0 0.0)
大体のところですが、
| elisp: (fib 40) | Intel(R) Xeon(R) CPU E3-1230 v3 @ 3.30GHz |
|---|---|
| interp | 79sec |
| byte-comp | 40sec |
| native-comp | 29sec |
という結果でした。
Common Lispとの比較
大体のタイムは分かったので、似たようなスピードのCommon Lisp処理系ということだとCLISPあたりか、ということで、CLISPで関数をコンパイルした場合と、Emacs Lispのネイティブコンパイルのfibの結果を比較してみたところ、両者の結果は、ほぼ同じになりました。
なお、CLISPはネイティブコンパイラではなくバイトコンパイラの処理系です。
(setf (symbol-function 'fib)
(lambda (n)
(if (< n 2)
n
(+ (fib (1- n))
(fib (- n 2))))))(time (fib 30))
Real time: 0.248056 sec.
Run time: 0.25 sec.
Space: 0 Bytes
→ 832040
(time (fib 40))
Real time: 30.663303 sec.
Run time: 30.59 sec.
Space: 0 Bytes
→ 102334155
| CLISP: (fib 40) | Intel(R) Xeon(R) CPU E3-1230 v3 @ 3.30GHz |
|---|---|
| interp | 116sec |
| byte-comp | 30sec |
Common Lispのネイティブコンパイラとの比較
Common Lispのメジャーな処理系は大体ネイティブコンパイラですが、LispWorksで最適化設定なしの場合は、こんな感じです。
(setf (symbol-function 'fib)
(lambda (n)
(if (< n 2)
n
(+ (fib (1- n))
(fib (- n 2))))))(compile 'fib)
Timing the evaluation of (fib 40)
User time = 1.350
System time = 0.010
Elapsed time = 1.293
Allocation = 269016 bytes
0 Page faults
→ 102334155
| LispWorks: (fib 40) | Intel(R) Xeon(R) CPU E3-1230 v3 @ 3.30GHz |
|---|---|
| interp | 186sec |
| native-comp | 1.35sec |
Emacs Lispのネイティブコンパイルfibと比べると大体22倍程度の速さです。
ちなみにLispWorksのインタプリタ実行はかなり遅いことがわかりますが、Common Lisp仕様がコンパイル指向なので、インタプリタはおまけだったり、サポートしていなかったりの処理系が殆どです。
なお、SBCLやLispWorksで型宣言や再帰的なインライン展開を実施して最速を狙うと、ネイティブコンパイルのEmacs Lispの約95倍程度の速度が出ます。
関数呼出しの速度を計測するためのfibのようなマイクロベンチでインライン展開するのは卑怯な気もするのですが、gcc等も展開してくるので、gccに合せるならアリかなと思います。
(defun fib (n)
(declare (optimize (speed 3) (safety 0) (debug 0) (compilation-speed 0))
(fixnum n))
(labels ((fib (n)
(declare (fixnum n))
(the fixnum
(if (< n 2)
n
(+ (fib (1- n))
(fib (- n 2)))))))
(declare (inline fib))
(fib n)))CL-USER> (time (fib 40))
Evaluation took:
0.322 seconds of real time
0.320000 seconds of total run time (0.320000 user, 0.000000 system)
99.38% CPU
1,061,775,900 processor cycles
0 bytes consed
まとめ
いまのところEmacs Lispの最適化の作法があまり確立していないようなのですが、Common Lisp風に人が指示する手段もそこそこ用意されているようです。
ただ、まだ発展途上のようでCommon Lispの感覚でコンパイラに最適化のヒント与えようとしても上手く行かない様子。
例えば、comp-hint-fixnumは、(the fixnum ...)な雰囲気のもののようですが、(optimize (speed 3))で使うと現状では却って遅くなったりします。
また、Common Lispではdisassembleで結果を確認しつつ追い込んでいくのが普通ですが、Common Lispのネイティブコンパイラのディスアセンブルの結果と違ってCのコンパイラの世界と行き来している感があります。
Emacs Lispが今後Common Lispのように人力チューニングを中心に展開していくのか、JITを中心にしていくのかは分かりませんが、Common Lisp風なシステムを目指すのであれば、もう少し道具が充実する必要がありそうです。
今回のfibのdisassembleの結果は下記のようになります。
なお、現状、AT&T表記決め打ちのようなのですが、disassemble-internalの中でobjdumpを呼んでいるだけのようなので、ここをいじれば好きな表記に変更できるようです。
disassemble-internal:
...
(call-process "objdump" nil (current-buffer) t "-S" "-M" "intel"
(native-comp-unit-file (subr-native-comp-unit obj)))
...0000000000001290 <F6669622d6e63_fib_nc_0>:
1290: 41 54 push r12
1292: 55 push rbp
1293: 53 push rbx
1294: 48 83 ec 50 sub rsp,0x50
1298: 4c 8b 25 49 2d 00 00 mov r12,QWORD PTR [rip+0x2d49] # 3fe8 <freloc_link_table@@Base-0x5f8>
129f: 48 8b 2d 3a 2d 00 00 mov rbp,QWORD PTR [rip+0x2d3a] # 3fe0 <d_reloc@@Base-0x580>
12a6: 49 8b 1c 24 mov rbx,QWORD PTR [r12]
12aa: 48 8b 7d 00 mov rdi,QWORD PTR [rbp+0x0]
12ae: ff 93 a8 26 00 00 call QWORD PTR [rbx+0x26a8]
12b4: bf 02 00 00 00 mov edi,0x2
12b9: 48 89 e6 mov rsi,rsp
12bc: 48 c7 44 24 08 0a 00 mov QWORD PTR [rsp+0x8],0xa
12c3: 00 00
12c5: 48 89 04 24 mov QWORD PTR [rsp],rax
12c9: ff 93 28 26 00 00 call QWORD PTR [rbx+0x2628]
12cf: 48 8b 7d 00 mov rdi,QWORD PTR [rbp+0x0]
12d3: 48 85 c0 test rax,rax
12d6: 74 18 je 12f0 <F6669622d6e63_fib_nc_0+0x60>
12d8: ff 93 a8 26 00 00 call QWORD PTR [rbx+0x26a8]
12de: 48 83 c4 50 add rsp,0x50
12e2: 5b pop rbx
12e3: 5d pop rbp
12e4: 41 5c pop r12
12e6: c3 ret
12e7: 66 0f 1f 84 00 00 00 nop WORD PTR [rax+rax*1+0x0]
12ee: 00 00
12f0: ff 93 a8 26 00 00 call QWORD PTR [rbx+0x26a8]
12f6: 48 89 c7 mov rdi,rax
12f9: 8d 40 fe lea eax,[rax-0x2]
12fc: a8 03 test al,0x3
12fe: 75 20 jne 1320 <F6669622d6e63_fib_nc_0+0x90>
1300: 48 ba 00 00 00 00 00 movabs rdx,0xe000000000000000
1307: 00 00 e0
130a: 48 89 f8 mov rax,rdi
130d: 48 c1 f8 02 sar rax,0x2
1311: 48 39 d0 cmp rax,rdx
1314: 74 0a je 1320 <F6669622d6e63_fib_nc_0+0x90>
1316: 48 8d 04 85 fe ff ff lea rax,[rax*4-0x2]
131d: ff
131e: eb 0a jmp 132a <F6669622d6e63_fib_nc_0+0x9a>
1320: 49 8b 04 24 mov rax,QWORD PTR [r12]
1324: ff 90 90 25 00 00 call QWORD PTR [rax+0x2590]
132a: 48 8b 55 18 mov rdx,QWORD PTR [rbp+0x18]
132e: 48 8d 74 24 10 lea rsi,[rsp+0x10]
1333: 48 89 44 24 18 mov QWORD PTR [rsp+0x18],rax
1338: bf 02 00 00 00 mov edi,0x2
133d: 48 89 54 24 10 mov QWORD PTR [rsp+0x10],rdx
1342: ff 93 e0 1a 00 00 call QWORD PTR [rbx+0x1ae0]
1348: 48 8b 7d 00 mov rdi,QWORD PTR [rbp+0x0]
134c: 49 89 c4 mov r12,rax
134f: ff 93 a8 26 00 00 call QWORD PTR [rbx+0x26a8]
1355: 48 8d 74 24 20 lea rsi,[rsp+0x20]
135a: bf 02 00 00 00 mov edi,0x2
135f: 48 c7 44 24 28 0a 00 mov QWORD PTR [rsp+0x28],0xa
1366: 00 00
1368: 48 89 44 24 20 mov QWORD PTR [rsp+0x20],rax
136d: ff 93 f8 25 00 00 call QWORD PTR [rbx+0x25f8]
1373: 48 8b 55 18 mov rdx,QWORD PTR [rbp+0x18]
1377: 48 8d 74 24 30 lea rsi,[rsp+0x30]
137c: bf 02 00 00 00 mov edi,0x2
1381: 48 89 44 24 38 mov QWORD PTR [rsp+0x38],rax
1386: 48 89 54 24 30 mov QWORD PTR [rsp+0x30],rdx
138b: ff 93 e0 1a 00 00 call QWORD PTR [rbx+0x1ae0]
1391: 66 49 0f 6e c4 movq xmm0,r12
1396: 48 8d 74 24 40 lea rsi,[rsp+0x40]
139b: bf 02 00 00 00 mov edi,0x2
13a0: 66 48 0f 6e c8 movq xmm1,rax
13a5: 66 0f 6c c1 punpcklqdq xmm0,xmm1
13a9: 0f 29 44 24 40 movaps XMMWORD PTR [rsp+0x40],xmm0
13ae: ff 93 00 26 00 00 call QWORD PTR [rbx+0x2600]
13b4: 48 83 c4 50 add rsp,0x50
13b8: 5b pop rbx
13b9: 5d pop rbp
13ba: 41 5c pop r12
13bc: c3 ret
13bd: 0f 1f 00 nop DWORD PTR [rax]
■
HTML generated by 3bmd in LispWorks 7.0.0
ケーススタイルの変換にリーダーマクロを使う
Posted 2021-04-17 11:20:40 GMT
仕事でjsonデータを扱うのですが、データ形式自体が開発中のため、開発者によってキー名のケーススタイルがぶれるという事態が発生しました。
それはとりあえず統一すれば良いのですが、データのぶれにより既存のアプリがデータを上手く扱えなくなってしまったので、当座でアプリを機能させるためには、キー名を正規化する必要があります。
しかし、既存のコードのキー名の正規化がまためんどくさいので、リテラル表記の部分はリーダーマクロを使って正規化してみることにしました。
(ql:quickload 'kebab)
(set-dispatch-macro-character #\# #\^
(lambda (srm chr arg)
(declare (ignore chr arg))
(kebab:to-camel-case (read srm T nil T))))
(st-json:getjso #^"foo_bar_baz" (st-json:jso "fooBarBaz" 42))
→ 42
t
まあ、急場しのぎですが、こういう時はリーダーマクロが便利ですね。
■
HTML generated by 3bmd in LispWorks 7.0.0
PareditをLispWorksのHemlockに移植してみた
Posted 2021-04-12 17:49:42 GMT
どういう切っ掛けで移植を始めたのか思い出せないのですが、Emacs系エディタでお馴染みのLisp編集支援モードのpareditをLispWorksのエディタ(Hemlock)に移植してみました。
最近のparedit(version 25)は3000行近くあるのですが、移植したものは300行程度のversion 1です。
誰かが既に移植していた気もするのですが、どうも見付からない……。
最初はちまちまとHemlockのdefcommand形式に書き直していたのですが、途中でめんどくさくなってedefunというEmacsのinteractiveを含んだdefun形式のマクロを作成してコピペしていきました。
versio 25とversion 1では機能に差がありますが、私個人が欲しかったforward-slurp-sexp系の機能は大体version 1で既に完備されていたようです。
Editor Lispがあったら嬉しいが……
Emacs系エディタではLispで拡張できるのは嬉しいのですが、似ているけれど割合に違うAPI群をそれぞれ持っているので、エディタ間でLispコードを共有するのは難しい状況です。
大別すると
- GNU Emacs系
- Hemlock系
- Zmacs系
とありますが、圧倒的多数派のEmacs Lispベースで構わないのでEditor Lispとして標準化されたりすると嬉しいですね。
まあ、Hemlockも、Zmacsもほぼ絶滅しているので、これらのプラットフォームがEmacs Lispの資産を活用したいということもないか……。
■
HTML generated by 3bmd in LispWorks 7.0.0
疑似パッケージマーカーに使う記号色々
Posted 2021-04-07 15:18:41 GMT
Common Lispのパッケージ名とシンボル名を区切る:をパッケージマーカーと呼びますが、パッケージシステムの存在しないLisp方言でも擬似的なパッケージ名として接頭辞を付けたりすることがあります。
そんな擬似的なパッケージマーカーを集めてみたり良さそうなパッケージマーカーを考えてみたりしましょう。
package:symbol
:が採用されたのは恐らくLisp Machine Lispが最初ですが、Common Lispに受け継がれました。
Lisp Machine LispとCommon Lispの違う点は、外部に公開するシンボルをpackage:symbolと、一つの:で表現し、二つの場合は、内部シンボルpackage::symbolという風に表現するところと、Common Lispは階層パッケージでない点です。
:の個数の使い分けが案外面倒で、外部に公開するAPIとしてのシンボル名のデザインは結構難しいと感じます。
ちなみに、Common Lisp以外でも、Schemeなどでも区切りとして使われたりしています。
package/symbol
Clojure等が/を使っていますが、他のLispでも疑似パッケージ的に使われることがそこそこある記号かなと思います。
package.symbol
Lisp系ではそんなに使われている感はありませんが、Pythonっぽくもありますし、そこそこ使えそうな気がします。
package-symbol
パッケージが登場する前のLispがこんな感じですが、Emacs Lispの作法ではこのスタイルが推奨されています。
シンボル部に-が良く使われるので、パッケージの区切りかどうかがはっきりしないのが欠点といえば欠点でしょうか。
Common Lispでも、package:subpackage-symbolのような名前は結構使われているかなと思います。
package>symbol
Lispマシン用のCの処理系であるZeta-Cで使われている記法ですが、何故>を使っているのかは良く分かりません。
古えのOSでは>がディレクトリパスの区切りだったりもしたので、/と同じような雰囲気なのかもしれません。
package*symbol
古いLispコードで見掛けたことはありますが、ほぼ見掛けません。
割合に使えそうな気もしますが果して……。
symbol$package
LISP 2で使われていた記法で、LISP 2では正確にはpackageではなくsectionですが、前後が逆なのが特徴です。
大抵は関数名で覚えている気がしますが、パッケージ名が後置だとIDE等での補完が簡単な気もします。
色々考えてみた
package_symbol
Lispでは-の使い勝手の良さから極端に利用頻度が低い_ですが、あまり競合しないので接頭辞の区切りには良いかもしれません
package||symbol
package\Symbol
実質package||symbol、package\Symbolとpackagesymbolは一緒ですが、コードの字面上では区切りが付きます。
<package>subpackage>symbol
<package.subpackage>symbol
[package]symbol
古えのOSのパス区切りを模したものですが、Common Lispではシンボル名に使える文字が多いので結構そのまま書けます。
まとめ
以上、まとまりなく疑似パッケージの区切りを紹介してみたり考えてみたりしました。
個人的に疑似パッケージマーカーが必要になるのは、Schemeのコードで、char-set:alphabetのようなものをCommon Lispにどうにか翻訳するケースが多いですが、これまでは、
- Common Lispのパッケージとして、
char-set:alphabetと翻訳(パッケージ作成がめんどう) char-set.alphabetと翻訳char-set$alphabetと翻訳
等々としてきました。
最近は面倒になってきて、char-set\:alphabetと書くようにもなりましたが、なにか疑似パッケージ記号の決定版みたいなものがあれば、一つの表記に落ち着くのになあと思ったりです。
■
HTML generated by 3bmd in LispWorks 7.0.0
condのelse節色々
Posted 2021-04-03 23:05:30 GMT
Schemeのcondのelse節はelseを書きますが、古典的なLispでは、condのelse節ではTを書きます。
;; Scheme
(cond (...)
(else ...));; Common Lisp
(cond (...)
(T ...))
このTは半ば慣用句で真値となるものであれば何でも良いのですが、最近古い文献を眺めていて妙なものをみつけたのでまとめてみます。
1 と書く
(cond (...)
(1 ...))LISP 1の頃には、nilが0で、Tが1だったりして、M式にもTの代りに直接1が書いてあったりします。
LISP 1のM式をS式に変換した例などで稀ですが見掛けることがあります。
'T と書く
(cond (...)
('T ...))Tにquoteが付いているのですが、何故付いているのかは謎。
LISP 1.5のM式では大文字はクォートされたシンボルを表わすのでM式のTを正確にS式に翻訳すると(quote T)となりますので、この辺りが由来かもしれません。
MACLISPのコードで良く見掛けます。
'else と書く
(cond (...)
('else ...))真値であれば何でも良いので'elseというシンボルをそのまま使ったもの。
たまに古いコードで見掛けます。
稀ですが、
(cond (...)
(:else ...))というキーワードシンボルの場合もあり。
(cond (...)
("else" ...))でも良さそうですが、個人的には目にしたことはありません。
(and)
(cond (...)
((and) ...))List Techniques / Harold V. McIntosh(1963)で良く使われている書法ですが、確かに(and)はTに評価されます。
どちらかというとandよりはorな気分な気がしますが、else節を目立たせる場合には使えたりするかもしれません。
(t)
(cond (...)
((t) ...))MBLISPというLisp 1.5系の古いLispのコード例等に出てくる書き方です。
(t)はTを返すような疑似関数になっています。(true)みたいなものですね。
書かない
(cond (...)
((progn ...)))else節の述語部に直接実行する式を書いてしまうというパターンです。
大抵のLisp処理系では述語部から多値を返すことができないので、注意が必要ですが、1970年代あたりでは結構目にするスタイルです。
arcのifのelse節でも良く見掛けますが多値を考慮しなくて良いのと、括弧がネストしていないのが理由かもしれません。ちなみにclosureだと節が偶数でないとエラーになるのでできないようです。
まとめ
他にも微妙なバリエーションがありますが、1990年代以降はt以外のものを書く人は殆どいないようです。
■
HTML generated by 3bmd in LispWorks 7.0.0
validate-superclassの謎
Posted 2021-03-22 01:47:43 GMT
MOPでメタクラスを定義した場合などに定義が必要になるvalidate-superclassですが、処理系によって定義が必要であったりなかったりするので、実際のところどういう動作が正しいのか改めて確認してみました。
メタクラス定義でvalidate-superclassを定義する意味
メタクラスが違う二つのクラスの間で継承関係が成立するかどうかは分からないのでデフォルトでは継承関係は成立しないとしていて、成立させたい場合は明示する仕組みというのが簡単な説明です。
この「デフォルトでは継承関係は成立しない」というのをvalidate-superclassで表現していて、成立させる場合にはTを返すメソッドを定義します。
(defclass my-class (standard-class)
())(validate-superclass (class-prototype (find-class 'my-class))
(class-prototype (find-class 'standard-class)))
→ nil
この状態で、my-classをメタクラスとするクラスmy-objectを定義する場合、my-objectはオブジェクトの表現としてstandard-objectを継承して利用するのがデフォルト動作(省略時)なので、
(defclass my-object (standard-object)
()
(:metaclass my-class))のようなものを書いた場合、
(validate-superclass (class-prototype (find-class 'my-class))
(find-class 'standard-object))のようなチェックが一連のスーパークラスで実施され、全てがTでなければ、エラーとなります。
処理系ごとのvalidate-superclassの動作の違いですが、下記のようになります。
明示的に指定しなければ互換性はないとする処理系
(validate-superclass (class-prototype (find-class 'my-class))
(find-class 'standard-object))
→ nilAMOPに記載の通りの判定ですが、
- CMUCL
- SBCL
あたりがそういう挙動で、validate-superclassをちゃんと書いてやる必要があります。
サブメタクラスがstandard-classのサブクラスで、スーパーメタクラスがstandard-classの場合は互換性あり
(validate-superclass (class-prototype (find-class 'my-class))
(find-class 'standard-object))
→ T- LispWorks
- CLISP
あたりがこの挙動です。
この挙動であれば、validate-superclassを書かなくて良さそうにも思えますが、メタクラスがstandard-classの別のサブクラス同士だと継承関係がない場合があるので、その場合はvalidate-superclassを書いてやる必要があります。
具体的には、下記のコードのような状況でvalidate-superclassの定義が必要になります。
(defclass my-class/ (standard-class)
())(defclass my-object/ (standard-object)
()
(:metaclass my-class/))
(validate-superclass (class-prototype (find-class 'my-class/))
(find-class 'my-object))
→ nil
(defmethod validate-superclass ((c my-class/) (s my-class))
T)
(validate-superclass (class-prototype (find-class 'my-class/))
(find-class 'my-object))
→ T
;; 上記の定義がなければエラー
(defclass my-object// (my-object)
()
(:metaclass my-class/))
サブメタクラス、スーパーメタクラスが共にstandard-classのサブクラスなら互換性あり
- Allegro CL
- Eclipse CL
あたりがこの挙動です。
メタクラスがstandard-classのサブクラス同士であれば、validate-superclassの定義を書く必要はありません。
これはこれで便利な挙動で、validate-superclassの定義を書くことは殆ど無くなるのは良いのですが、この挙動が災いしてAllegro CLのコードの移植性の無さの一因になっている気がします。
上記のように処理系によってデフォルトの挙動が違いますが、互換性があることを明示するvalidate-superclassのコードがあっても挙動を変えることはないので、AMOP準拠で全部明示しておくのが吉かなと思います。
クラスに互換性がないとはどういうことか
ANSI CL規格では、互いに素である型が定義されていますが、
defclass、define-condition、defstructで継承関係を定義した型以外は互いに素であるとしています。
integerとconsの間では継承関係を考えようとは思わないのですが、メタクラスをカスタマイズする場合は、メタクラスが異なるのみで他の挙動は継承したいことがほとんどかと思います。
validate-superclass の歴史
validate-superclassは用途が限定されている割には機能としては汎用的なのですが、もともとはcheck-super-metaclass-compatibilityという名前だったようです。
途中で、valid-superclass-p等の名前になったりもしたようですが、1990年頃、validate-superclassで落ち着き現在に至る様子。
check-super-metaclass-compatibilityはvalidate-superclassよりも判定が厳しく、デフォルトの挙動は双方のメタクラスがeqの場合のみTとしていたようです。
現在のvalidate-superclassもcheck-super-metaclass-compatibilityの目的に使うことが殆どですが、CMUCLやSBCLでは互換性の判定用に組み込みクラスについても非互換性のリストをもっているので、
(validate-superclass (find-class 'null)
(find-class 'cons))
→ nilのように判定します。
他の処理系は、大体のところはstandard-classの範疇の判定しか想定していないようなのでTを返しますが、こんな動作でも問題ない程度には汎用的には使われていないということなのかもしれません……。
まとめ
validate-superclassについて掘り下げてみましたが、validate-superclassは用途が限定的ですし、考えるほどcheck-super-metaclass-compatibilityという名前のままでも良かったのではないかと思えてきます。
■
HTML generated by 3bmd in LispWorks 7.0.0
1+
Posted 2021-03-18 15:03:34 GMT
Slackなどの絵文字の入力方法に:+1:と入力して、👍を出すというのがありますが、どうしても手が勝手に:1+:と入力してしまうので、諦めて:1+:を絵文字として登録しました。
これで誤入力のイライラから開放されました。Common Lisp病の方にお勧めしたい解決策です。
■
HTML generated by 3bmd in LispWorks 7.0.0
Common Lispで列挙型はどう書いたら良いの
Posted 2021-01-24 15:41:27 GMT
Common Lispでもたまに列挙型が欲しいことがありますが、そもそも列挙型はある要素の集合のことを指すようで、連続的な整数の一連の別名というわけではない様子。
そういった場合は、型記述子memberで記述できるのですが、
(typep 'a '(member a b c))
→ t 大抵の場合は、数値の連続に別名が付いたものが欲しかったりするので、memberでは数値との対応が実現できません。
連続した数値に別名を付与しつつ、これらと組み合わせて使うことが多いcase系の構文でも使い勝手良いものをと考えると、シンボルマクロで数値に別名を付与しつつ型の宣言もつけたらどうかと思い試してみました。
具体的には下記のようになります。
(deftype foo () '(eql 0))
(define-symbol-macro foo 0)(typep foo 'foo)
→ t
少し規模が大き目なものの場合、
(macrolet ((defenum (&rest args)
`(progn
,@(loop :for idx :from 1
:for name :in args
:collect `(progn
(define-symbol-macro ,name ,idx)
(deftype ,name () '(eql ,idx)))))))
(defenum H He Li Be B C N O F Ne Na Mg Al Si P S Cl
Ar K Ca Sc Ti V Cr Mn Fe Co Ni Cu Zn Ga Ge As Se Br
Kr Rb Sr Y Zr Nb Mo Tc Ru Rh Pd Ag Cd In Sn Sb Te I
Xe Cs Ba La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb
Lu Hf Ta W Re Os Ir Pt Au Hg Tl Pb Bi Po At Rn Fr Ra
Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr Rf Db Sg
Bh Hs Mt Ds Rg Cn Nh Fl Mc Lv Ts Og))
(typecase F
((or F Cl Br I At Ts) 'yes)
(T 'no))
→ yes
(deftype Halogens ()
(list 'member F Cl Br I At Ts))
(typecase F
(Halogens 'yes)
(T 'no))
→ yes
ちなみに、定数宣言して、caseと#.の組み合わせを使うというのを目にしたことはありますが、#.を書くのが面倒だったり、評価タイミングを考えたりする必要があったりで、あまり使い勝手は良くないという印象です。
(case .F
((#.F #.Cl #.Br #.I #.At #.Ts) 'yes)
(otherwise 'no))
→ yes まとめ
cl-enumerationのようなライブラリもありますが、一般的な言語の所謂enumとは微妙に目指すところが違うようです。
Common Lispだけで完結している場合には、あまり必要にならないのですが、既存のデータ定義を取り込んだり、別言語のコードを流用したりする場合に、enum欲しいなあとなることが多いですね。
■
HTML generated by 3bmd in LispWorks 7.0.0
マルチパラダイムなCommon Lispには逃げ場が沢山ある
Posted 2021-01-21 01:55:42 GMT
こちらの記事を読んで、自分が考えているオブジェクト指向とは随分違う何かがC++やJavaのオブジェクト指向プログラミングなんだなあと思いましたが、それと同時に、パラダイムがどうこうというより特定のパラダイムやシステムに囚われてしまう状況では、そこから抜け出すには、既存のものを捨てて他のパラダイムに移行せざるを得ないと考えてしまうのかもなあと感じました。
Common Lispはマルチパラダイムですが、
- 手続き/命令型(gotoもあり)
- 関数型/適用型/式指向
- とても動的なオブジェクト指向システム
- メタプログラミング(eval、マクロetc)
あたりが組込み機能です。
データがコードなため、メタプログラミングが容易で、組み込み言語のDSLで、Prologや、プロダクションシステム等を組込んで使ったりすることも可能です。 まあ、DSLが元言語とどこまで違和感なく連携するかはまた別の話ではありますが。
goto廃止論争が華やかだった時代も、マクロで構文を拡張できるLispは、gotoを廃止するということもなく、goを直接手書きしないような構文をマクロで言語標準機能として構築して迂回。
オブジェクト指向システムはSmalltalkの影響下で二三の実装がありましたが、最終的には総称関数という関数呼び出しにメッセージ送信を融合したような形式に収める、などなど、色々なパラダイムを吸収してきてはいますが、オブジェクト指向システムをほぼ使わずに書くことも可能ですし、関数がファーストクラスなので関数型的に書くことも容易です。
もともと対話環境が強力ですが、対話形式でも使えますし、バッチ形式でも使えます。
様々なパラダイムを強力なメタプログラミング機構がゆるくまとめているところもあるかもしれません。
こういうCommon Lispみたいな逃げ場が沢山ある言語が流行ると嬉しいですね。
■
HTML generated by 3bmd in LispWorks 7.0.0
Common Lispで大量のスロットがあるclassの初期化手順を自動生成する
Posted 2021-01-11 20:32:42 GMT
こちらの記事を目にして、IDEでコードを自動生成するのって格好良いと思ったので、Common Lispだとどうなるか考えてみました。
とりあえず構造体の場合は何もしなくてもコンストラクタのinitargがスロット名に応じて決定されてしまうので、何もしなくてもOKです。
勝手に決まってしまうことについては賛否がありますが、便利な局面は多いかと思います。
(defstruct codable-struct)(defstruct (sample-struct (:include codable))
int
title
body
thumbnail-url
tags
categories
created-at
updated-at
comment
favoritedp
bookmarkedp
url)
(make-sample-struct :int 0
:title "title"
:body "body"
:thumbnail-url "https://example.com/image.jpg"
:tags '("tag")
:categories "cat"
:created-at 0
:updated-at 0
:comment "comment"
:favoritedp nil
:bookmarkedp nil
:url "https://example.com")
→ #S(sample-struct :int 0
:title "title"
:body "body"
:thumbnail-url "https://example.com/image.jpg"
:tags ("tag")
:categories "cat"
:created-at 0
:updated-at 0
:comment "comment"
:favoritedp nil
:bookmarkedp nil
:url "https://example.com")
クラスの場合は、構造体と違って全部指定してやらないといけません。
定義していない初期化のためのキーワード(:initarg)を指定しない場合はもちろんエラーです。
(defclass codable ()
())(defclass sample-class (codable)
(int
title
body
thumbnail-url
tags
categories
created-at
updated-at
comment
favoritedp
bookmarkedp
url))
(make-instance 'sample-class)
→ #<sample-class 402018AA93>
(make-instance 'sample-class
:int 0
:title "title"
:body "body"
:thumbnail-url "https://example.com/image.jpg"
:tags '("tag")
:categories "cat"
:created-at 0
:updated-at 0
:comment "comment"
:favoritedp nil
:bookmarkedp nil
:url "https://example.com")
→ #<error>
初期化手続きを生成してみる
Common Lispだとコンストラクタのコードを生成するようなことはマクロで実現してしまうのですが、IDEが補完してくれるのが格好良いという話なので、IDE側でコードを生成して挿入したいところです。
ということで、initialize-instanceのコードを生成して、エディタのコマンドで挿入してみることにしました。
(let* ((keys (mapcar (lambda (s)
(let ((s (slot-definition-name s)))
`(,s nil ,(intern (format nil "~A?" (string s))))))
(class-slots (find-class 'sample-class)))))
`(defmethod initialize-instance ((obj sample-class) &key ,@keys)
(let ((obj (call-next-method)))
,@(mapcar (lambda (k)
(destructuring-bind (name init namep)
k
(declare (ignore init))
`(and ,namep (setf (slot-value obj ',name) ,name))))
keys)
obj)))した結果をエディタ(LispWorksのHemlock)からバッファに挿入します。
パッケージとシンボルの扱いのあれこれがあるので大分ごちゃごちゃになりました。
(defcommand "Generate Memberwise Initializer" (p)
"Generate Memberwise Initializer"
"Generate Memberwise Initializer"
(declare (ignore p))
(let ((def (current-top-level-definition-maybe)))
(if (and (listp def)
(eq (first def) 'defclass))
(progn
(end-of-defun-command 1)
(insert-string
(current-point)
(with-output-to-string (out)
(pprint
(let ((.class-name. (second def)))
(declare (special editor::.class-name.))
(eval
(read-from-string
"(let* ((keys (mapcar (lambda (s)
(let ((s (slot-definition-name s)))
`(,s nil ,(intern (format nil \"~A?\" (string s))))))
(class-slots (find-class editor::.class-name.)))))
`(defmethod initialize-instance ((obj sample-class) &key ,@keys)
(let ((obj (call-next-method)))
,@(mapcar (lambda (k)
(destructuring-bind (name init namep)
k
(declare (ignore init))
`(and ,namep (setf (slot-value obj ',name) ,name))))
keys)
obj)))")))
out))))
(message "~S is not a defclass" def))))これで、defclassの上で、“Generate Memberwise Initializer” します。
(defmethod initialize-instance
((obj sample-class)
&key
(int nil int?)
(title nil title?)
(body nil body?)
(thumbnail-url nil thumbnail-url?)
(tags nil tags?)
(categories nil categories?)
(created-at nil created-at?)
(updated-at nil updated-at?)
(comment nil comment?)
(favoritedp nil favoritedp?)
(bookmarkedp nil bookmarkedp?)
(url nil url?))
(let ((obj (call-next-method)))
(and int? (setf (slot-value obj 'int) int))
(and title? (setf (slot-value obj 'title) title))
(and body? (setf (slot-value obj 'body) body))
(and thumbnail-url? (setf (slot-value obj 'thumbnail-url) thumbnail-url))
(and tags? (setf (slot-value obj 'tags) tags))
(and categories? (setf (slot-value obj 'categories) categories))
(and created-at? (setf (slot-value obj 'created-at) created-at))
(and updated-at? (setf (slot-value obj 'updated-at) updated-at))
(and comment? (setf (slot-value obj 'comment) comment))
(and favoritedp? (setf (slot-value obj 'favoritedp) favoritedp))
(and bookmarkedp? (setf (slot-value obj 'bookmarkedp) bookmarkedp))
(and url? (setf (slot-value obj 'url) url))
obj))defclassで定義した挙動とは厳密には違いますが、こんな感じに初期化できるようになりました。
(make-instance 'sample-class
:int 0
:title "title"
:body "body"
:thumbnail-url "https://example.com/image.jpg"
:tags '("tag")
:categories "cat"
:created-at 0
:updated-at 0
:comment "comment"
:favoritedp nil
:bookmarkedp nil
:url "https://example.com")
→ #<sample-class 4020240C13>
#||
int 0
title "title"
body "body"
thumbnail-url "https://example.com/image.jpg"
tags ("tag")
categories "cat"
created-at 0
updated-at 0
comment "comment"
favoritedp nil
bookmarkedp nil
url "https://example.com"
||#スロット定義を生成してみる
初期化手続きの生成はどうもいまひとつな気がするので、スロット定義を自動生成する方法を試してみます。
とりあえず、
- クラスを定義
- クラスのスロット定義からスロット名を抜き出し
:initargを生成 - コードを置き換え
としてみます。
クラスのスロット定義からスロット名を抜き出し:initargを生成するのはこのようになります。
(defun add-initargs (class-name)
(dolist (s (class-direct-slots (find-class class-name)))
(setf (slot-definition-initargs s)
(list (intern (string (string (slot-definition-name s)))
:keyword))))
(reinitialize-instance (find-class class-name)))次にdefclassフォームの生成
(defun gen-defclass (class-name)
(let ((class (find-class class-name)))
`(defclass ,(class-name class)
(,@(mapcar #'class-name (class-direct-superclasses class)))
,(mapcar (lambda (s)
(append (list (slot-definition-name s))
(mapcan (lambda (i)
(list :initarg i))
(slot-definition-initargs s))))
(class-direct-slots class))
(:documentation ,(documentation class 'type))
(:metaclass ,(class-name (class-of class)))
(:default-initargs ,@(class-default-initargs class)))))エディタのコマンドにまとめる
(defcommand "Generate Memberwise Initializer" (p)
"Generate Memberwise Initializer"
"Generate Memberwise Initializer"
(declare (ignore p))
(let ((def (current-top-level-definition-maybe)))
(if (and (listp def)
(string-equal (first def) 'defclass))
(let ((*package* (get-buffer-current-package (current-buffer))))
(add-initargs (print (second def)))
(let ((dc (gen-defclass (second def))))
(end-of-defun-command 1)
(insert-form-at-point (current-point)
dc))
(values))
(message "~S is not a defclass" def))))これで、コマンド実行でスロット名がキーワードパッケージになった:initargが追加されたdefclassがバッファに挿入されます。
ちなみに、:initarg以外も処理する必要がありますが今回は面倒なので省略します……。
(defclass sample-class (codable)
((int :initarg :int)
(title :initarg :title)
(body :initarg :body)
(thumbnail-url :initarg :thumbnail-url)
(tags :initarg :tags)
(categories :initarg :categories)
(created-at :initarg :created-at)
(updated-at :initarg :updated-at)
(comment :initarg :comment)
(favoritedp :initarg :favoritedp)
(bookmarkedp :initarg :bookmarkedp)
(url :initarg :url))
(:documentation nil)
(:metaclass standard-class)
(:default-initargs))まとめ
色々考えてみましたが、defclassの派生マクロを作る方が楽だなと思いました。
マクロを基準に考えると、IDE側の方は展開したコードから元のコードへ戻す知識が失われるという欠点があり、マクロは派生した構文の使い方をおぼえるのが手間という欠点があります。
プログラム生成の知識をIDEが持つのかマクロが持つのかの違いでしかないと考えれば、プロジェクトごとに派生した定義構文があっても別に良いのかなと思ったりしました。
■
HTML generated by 3bmd in LispWorks 7.0.0
LispWorks IDEの紹介
Posted 2021-01-09 03:32:39 GMT
LispWorks IDEの紹介
LispWorksの特長
LispWorksを他のCommon Lispの処理系と比較した場合の特徴としては、Lisp処理系とIDEが密に連携している点です。
1989年のHarlequinのLispWorksの紹介によると、言語処理系の設計に先行してIDEの設計をしたとありますが、この辺りがLispWorksがIDE然としてしている所以ではないでしょうか。
LispWorks
=========...
The Approach
By designing the programming environment before the underlying language system,
Harlequin has engineered an unrivalled degree of internal cohesion into the
product. Programming tools are firmly embedded in the environment and both are
supported by sophisticated facilities for compilation and interpretation,
together with unobtrusive ephemeral garbage collection. The whole package is
written in Lisp to enhance consistency, maintainability and extensibility.
Lispマシンの環境も単なるLisp処理系ではなくIDEを指向していましたが、その後に擡頭してくる安価なUnixワークステーション上でのCommon Lisp環境もLispマシンを手本とし、IDEとしての完成度を追求していました。
似たような文化の言語にはSmalltalkがありますが、Common Lispの方は、Smalltalkと違って時代が下るにつれ処理系の言語処理系のコア以外の部分がどんどん落ちてしまい、Emacs+Common Lisp処理系(SLIME)というLispマシン以前に近いところまで遡ってしまいました。
その点では、LispWorksはIDEとしてのCommon Lisp環境として生き残った数少ない例かなと思います。
類似のものには、MCLがありましたが、2009年にIDEとしては終焉を迎えています。
LispWorksのIDEで便利な機能をピックアップして紹介
LispWorksのIDEの詳細な解説はマニュアルにゆずるとして、便利な機能をピックアップして紹介してみます。
インスペクタの履歴機能
Tools > Inspectorからインスペクタを開けます。
下記のように*inspect-through-gui* Tの状態でinspectを使うとinspectの実行履歴が、Previous、Nextボタンで参照できます。
(setq *inspect-through-gui* T)(defun foo-loop (n)
(dotimes (i n)
(inspect (* i 8))))
(foo-loop 8)
オブジェクトの状態変化の追跡等に非常に便利です。
関数呼び出しの一覧
Definitions > Function Calls で呼び出しをツリー構造で眺めることが可能です。
所謂、who-calls、calls-whoの機能なのですが、GUIの操作でソースの参照も簡便に実現されているため、ソース参照M-x .およびM-x ,の発展版としても利用可能です。
ステップ実行
GUI画面でステップ実行が可能です。
現在メジャーな開発環境であるSBCL+SLIME等ではステップ実行は苦手としているためか、ステップ実行自体がCommon Lispでは無理という印象がありますが、LispWorksでは普通にGUIから対話的に操作可能です。
ブレイクポイントの設定
Common Lispの関数でいうと(break)ですが、LispWorksでは、IDEとして統合されていて、メニューや、エディタのM-x Toggle Breakpointで該当箇所に印をつけることで、(break)をコードに差し込まなくともブレイクすることが可能です。他の言語のIDEとしてもメジャーな機能かと思います。
ブレイクした後は、IDEのデバッガでリスタートや脱出、値の調査が可能です。
また、インスタンスオブジェクトのスロットのアクセスにもブレイクポイントを仕掛けることが可能です。こちらはインスペクタからブレイクポイントとその種類を設定可能ですがデバッグには便利でしょう。
アウトプットブラウザ
主に印字出力の確認ですが、LispWorksをSLIME的に使うのであれば、エディタ+アウトプットブラウザのウィンドウの二枚開きか、エディタ+リスナーの二枚開きという感じになります。
アウトプットブラウザにはプリントの結果やマクロ展開やtimeの結果が上から下へ流れて表示されます。
コンパイラ警告ブラウザ
コンパイラの警告を一覧でみることができるブラウザです。
エラーメッセージをクリックしてエラー箇所の関数にジャンプし修正、等が可能です。
トレースブラウザ
Common Lispでいう(trace)をGUIから操作できるようにしたものです。
テキスト表示とそれほど違いはありませんが、視認性と操作性は向上しているかと思います。
オブジェクトのクリップボード
テキストのコピペのクリップボード機能のようにオブジェクトをクリップボードに保存し、任意の場所に貼り付けることが可能です。
リスナー上でmake-instanceしたオブジェクトを保存しておき、インスペクタで変化を確認したり、値を設定したりするのに便利です。
ツール間のリンク機能
結果の確認ツールとして、リスナー(REPL)や、インスペクタが活躍しますが、ツール間でリンクすることにより、あるツールの結果をインスペクタやリスナーと同期させることが可能です。
マニュアルに紹介されている例では、クラスブラウザでクラスを眺めつつ、Tools Cloneでクラスブラウザを複製し、主になるクラスブラウザとEdit > Link fromでリンクし、サブの方は同期したスロット定義を眺める、という使い方が紹介されています。
リスナーとの連携は、リスナー上の*変数を仲介した連携が主で、インスペクタとリンクすることにより、リスナーの*変数が更新される度にインスペクタのオブジェクトも更新される、ということが可能です。
ちなみに、エディタともリンク可能ですが、バッファオブジェクトが共有されるため、いまいち使いどころが難しくなっています。もしかしたら、バッファオブジェクト経由でのエディタの一括編集の実行等で活躍できたりするのかもしれません。
統合された定義の取消し機能
def系の構文の上でM-x Undefineコマンドを実行することにより、定義を取り消すことが可能です。
特に便利なのは、defmethodの場合ですが,定義のメソッドだけ削除してくれるところが便利でしょう。
このためLispWorks上では、総称関数をfmakunboundして一式を再定義するようなことは皆無です。
また、定義系の構文がIDEと統合されていて拡張可能なため、任意の定義構文用のUndefine操作をユーザーが設定可能です。
エディタ
エディタはこのブログでも何度か紹介していますが、元は、Spice LispのHemlockというEmacsのCommon Lisp実装です。
この記事もLispWorksのHemlockで書いていますが、Emacsとしてもそこそこ普通に使えます。
ユーザー定義のコマンド等は、当然ながらCommon Lispで拡張を書きますが、LispWorksの機能をフルに活用できるのがメリットでしょうか。
まとめ
ざっと、普段使っていて便利なLispWorks IDEの機能を紹介してみました。
細かい便利機能は沢山あるので、機会があればまた紹介してみたいと思います。
■
HTML generated by 3bmd in LispWorks 7.0.0
データの検索に組み込みPrologを使ってみる(1)
Posted 2021-01-03 21:49:53 GMT
LispWorksのKnowledgeWorksでは、オブジェクトシステムと組み込みPrologが統合されています。
Prologの複合項(構造体)に相当するものをオブジェクトや構造体で表現しますが、この知識ベースクラスのオブジェクトや構造体はワーキングメモリという場所に蓄積されます。
ワーキングメモリに蓄積されたオブジェクトは、(class名 ?obj スロット名 ?slot ...)という形式でパターンマッチで問い合わせ可能になります。
読み込んだJSONや、plistで表現したデータ、ORMでSQLで問い合わせした結果のオブジェクト等、様々な形式のデータをワーキングメモリに格納し、Prologで問い合わせするのが割合に便利なのですが、今回は、LispWorksではなくPAIPrologのようなものでも似たようなことができないか試してみたいと思います。
ウェブページのスクレイピングを組み込みPrologで
今回は、ウェブページのスクレイピングをPrologの問い合わせでやってみます。
利用する組み込みPrologは、PAIPrologですが、単一化がeqlだったり、オブジェクトを項として登録するのに結局改造しないといけなかったので、実験用にPAIPrologからフォークして別パッケージを作成してみました。
(ql:quickload '(clss plump dexador zrpaiprolog))(defpackage "d7aba921-29b4-5320-acaa-13531caa1f16"
(:use c2cl zrlog)
(:shadowing-import-from zrlog ignore debug symbol))
(cl:in-package "d7aba921-29b4-5320-acaa-13531caa1f16")
Prologの項を登録する
今回、DOMオブジェクトにはplumpを利用します。
plump:elementが基本となるオブジェクトなので、plump:elementという名前とオブジェクトを項として登録するadd-object-clauseというものを定義し、オブジェクト生成時のフックに登録します。
(defmethod initialize-instance :after ((obj plump:element) &rest initargs)
(add-object-clause 'plump:element obj))add-object-clauseは、PAIPrologのadd-clauseを少し改造しただけのものです。
項が増えるとシンボルにぶら下がる情報が多くなり過ぎる気がしますが、とりあえず実験なのでこれでよしとします。
(defun add-object-clause (name obj &key asserta)
(let ((pred name))
(assert (and (symbolp pred) (not (variable-p pred))))
(pushnew pred *db-predicates*)
(pushnew pred *uncompiled*)
(setf (get pred 'clauses)
(if asserta
(nconc (list (list (list name obj))) (get-clauses pred))
(nconc (get-clauses pred) (list (list (list name obj))))))
pred))これで、ウェブページを取得し、plump:parseした時点でPrologの項が登録されます。
(plump:parse (dex:get "https://www.shop-shimamura.com/disp/itemlist/001002001/"))
→ #<plump-dom:root 4250272873>CSS Selectorでの問い合わせ的にするために、問い合わせのユーティリティとして、ノードの"class"属性を根の方向に探索するclass-namedというのを定義してみます。
なお、子→親の方向で検索するのは、要素を項としている都合上です。
(defun class-named (class node)
(typecase node
(plump:root NIL)
(T (cond ((plump:attribute node "class")
(and (equal class (plump:attribute node "class"))
node))
(T (and (class-named class (plump:parent node))
node))))))これでこんな風に書けます。
(prolog
(plump::element ?elt)
(is ?tag (plump:tag-name ?elt))
(= ?tag "img")
(is ?ans (class-named "card__thumb" ?elt))
(is T (not (null ?ans)))
(lisp (format T
"~A: ~A~%"
(plump:attribute ?ans "alt")
(plump:attribute ?ans "src"))))
▻ メンズ ワッフルトレーナー（SEASON REASON）: https://img.shop-shimamura.com/items/images/01/0120800000660/01_0120800000660_111_l.jpg
▻ メンズ ワッフルトレーナー（SEASON REASON）: https://img.shop-shimamura.com/items/images/01/0120800000660/01_0120800000660_113_l.jpg
▻ メンズ ワッフルトレーナー（SEASON REASON）: https://img.shop-shimamura.com/items/images/01/0120800000660/01_0120800000660_215_l.jpg
▻ メンズ トレーナー（SEASON REASON）: https://img.shop-shimamura.com/items/images/01/0120800000659/01_0120800000659_111_l.jpg
▻ メンズ トレーナー（SEASON REASON）: https://img.shop-shimamura.com/items/images/01/0120800000659/01_0120800000659_113_l.jpg
▻ メンズ トレーナー（SEASON REASON）: https://img.shop-shimamura.com/items/images/01/0120800000659/01_0120800000659_214_l.jpg
▻ メンズ トレーナー（SEASON REASON）: https://img.shop-shimamura.com/items/images/01/0120800000659/01_0120800000659_305_l.jpg
▻ メンズ プルパーカ（SEASON REASON）: https://img.shop-shimamura.com/items/images/01/0120800000657/01_0120800000657_312_l.jpg
▻ メンズ プルパーカ（SEASON REASON）: https://img.shop-shimamura.com/items/images/01/0120800000657/01_0120800000657_305_l.jpg
▻ メンズ プルパーカ（SEASON REASON）: https://img.shop-shimamura.com/items/images/01/0120800000657/01_0120800000657_307_l.jpg
▻ メンズ裏毛プルパーカ（呪術廻戦）: https://img.shop-shimamura.com/items/images/01/0128200004027/01_0128200004027_213_l.jpg
▻ メンズ裏毛プルパーカ（呪術廻戦）: https://img.shop-shimamura.com/items/images/01/0128200004026/01_0128200004026_212_l.jpg
▻ キャラクタートレーナー(呪術廻戦): https://img.shop-shimamura.com/items/images/01/0123200005469/01_0123200005469_212_l.jpg
▻ キャラクタートレーナー(呪術廻戦): https://img.shop-shimamura.com/items/images/01/0123200005468/01_0123200005468_213_l.jpg
▻ キャラクタートレーナー(にゃんこ大戦争): https://img.shop-shimamura.com/items/images/01/0123200005379/01_0123200005379_213_l.jpg
▻ キャラクタートレーナー(にゃんこ大戦争): https://img.shop-shimamura.com/items/images/01/0123200005378/01_0123200005378_212_l.jpg
▻ キャラクターパーカ(にゃんこ大戦争): https://img.shop-shimamura.com/items/images/01/0123200005377/01_0123200005377_211_l.jpg
▻ メンズ裏毛トレーナー（ブラッククローバー）: https://img.shop-shimamura.com/items/images/01/0128200004042/01_0128200004042_112_l.jpg
▻ メンズ裏毛プルパーカ（ブラッククローバー）: https://img.shop-shimamura.com/items/images/01/0128200004041/01_0128200004041_211_l.jpg
▻ メンズ裏毛プルパーカ（ブラッククローバー）: https://img.shop-shimamura.com/items/images/01/0128200004040/01_0128200004040_213_l.jpg
▻ しまむらロゴパーカ: https://img.shop-shimamura.com/items/images/01/0123200005278/01_0123200005278_201_l.jpg
▻ しまむらロゴトレーナー: https://img.shop-shimamura.com/items/images/01/0123200005277/01_0123200005277_212_l.jpg
→ nilclssでCSS Selectorで書くと
(clss:select ".card__thumb img")一行ですが、CSS Selectorの細かい規則を覚えるのも大変ですし、組み込みPrologで一本化できると嬉しいと思いたい。
木構造オブジェクトの問い合わせ言語は様々あるのですが、これをどうにか組み込みPrologで一本化できないか今後も探っていきたいと思います。
とりあえずは、PrologでJSON等の木構造の問い合わせをどうやっているか調査した方が良いかもしれない……。
■
HTML generated by 3bmd in LispWorks 7.0.0
2020年振り返り
Posted 2020-12-31 14:50:55 GMT
恒例になっているので今年も振り返りのまとめを書きます。
Lisp的進捗
昨年は自分的にMOPブームでしたが、今年はMOPでプログラミングできる知識が大体揃って来た感じで、実際のプログラムでも普通に活用できたりするようになりました。
といっても大した応用ではないのですが、普通の道具になった、位のところです。
CLOS MOPだと大別すると、
- メタクラスの定義
- メタクラスの継承関係の処理(デフォルトの挙動、メタクラスのmixin時の挙動の定義等々)
- スロット定義
- オブジェクトの(再)初期化
- スロットへのアクセス方法
位が大きなトピックで他は上記の組み合わせか、細々としたところなので、クックブック的な感じでまとめておくと便利かなと思ったりしています。
ブログ
今年書いた記事は62記事でした。
まあまあ書いた方だとは思いますが、ネタ自体はストックが100記事分位はあるので、一旦全部出し切りたいところです。
LispWorks
LispWorksを購入してから五年半経過しましたが、すっかりSLIME+SBCLの環境よりLispWorksで書く方が楽になってしまいました。
単なる慣れというところもありますが、IDEとしてはSLIME+SBCLより統合されていて便利なところが多いです。まあもちろんエディタ単体ではHemlock(LispWorksのエディタ)よりGNU Emacsの方が高機能ですが。
仕事では、LispWorksで社内アプリ(Macのデスクトップアプリ)を量産していて、直近の業務で必要なツールを作成していていつの間にか20種類位になりました。
エンジニアでない人にGitHubを使ってもらうのに、GUIで簡単なラッパーを作成したり、社内業務のオートメーションでLispWorksが使えそうなところを見付けたら即投入しています。
Unixのシェルスクリプト、Google Apps Script、等々オートメーションのツールはありますが、手早く書捨てのGUIのアプリを作成できるという点では割とLispWorksは良いと思っています。
2021年の方向性
Lisp界隈もだいぶ盛り下がってきた感じで、当ブログももう誰も読んでない感じになってきました。
盛り上げる方法は多分ないのですが、文章のアウトプットは好きな方なので、ニッチなネタを垂れ流していきたいと思います。
また、13年位Lispコミュニティを眺めていますが、いまだLispに関する知識が1980年代な人を多く目にするのが不思議です。
恐らく古い書籍の情報をソースにしたものが再生成されているのではないかと思うのですが、このような傾向をアップデートすべく、2021年はWikipedia等の化石化した情報も更新したりすることにも取り組んでみようかなと思います(がWikipediaの更新は手間がかかる)
過去のまとめ
- #:g1: 2019年振り返り
- #:g1: 2018年振り返り
- #:g1: 2017年振り返り
- #:g1: 2016年振り返り
- #:g1: 2015年振り返り
- #:g1: 2014年振り返り
- #:g1: 2013年振り返り
- #:g1: 2012年振り返り
- #:g1: 2011年を振り返る
- #:g1: 2010年を振り返る
- #:g1: 2009年を振り返る
- #:g1: 今年一年をふりかえる
■
HTML generated by 3bmd in LispWorks 7.0.0
初期のECLはPrologと融合していたらしい
Posted 2020-12-28 22:07:24 GMT
いつものようにCommon Lisp情報を求めてインターネットを徘徊していたのですが、ECLのマニュアルににCRSというのがあるのが気になって調べてみました。
ECL is based on a Common Runtime Support (CRS) which provides basic facilities for memory management, dynamic loading and dumping of binary images, support for multiple threads of execution.
CRS(Common Runtime Support)
ECLのマニュアルの説明では、CRSは、メモリ管理やスレッド等の実行時に必要なものがモジュール化されたものという感じですが、CRSはECLとも独立した存在のようで、CRSについて別途論文も書かれていました。
こちらの論文を読むと、CRSとはCを中間言語として、実行時に必要な言語機能をモジュール化したり、データ形式を統一したものだったようで、CRSを基盤にCや、Lisp、Prologの環境が構築可能で、それぞれの言語が双方向に呼び出し可能な仕組みだったようです。
;;; Prolog機能を使ったCommon Lispのコード例
(defun reverse (x y)
(trail-mark)
(or (and (get-nil x) ;reverse([],[]).
(get-nil y)
(success))
(trail-restore)
(let (x1 x2 (y2 (make-variable)))
(and
(get-cons x)
(unify-variable x1)
(unify-variable x2)
(goals
(reverse x2 y2) ; :- reverse(X2,Y2),
(concat y2 (list x1) y)))))
(trail-unmark))この論文の後ろの方に出てくるCommon Lispの処理系はECLではなく、Delphi Common Lisp(DCL)というECLの作者であるAttardi先生が1985年に起業したイタリアのベンチャーが販売していた商用処理系なのですが、古いECLのソースを確認すると、ECLは元々はこのDCLのCLOS部やCRS部分がECoLispとしてGPLライセンスで公開されたもののようです。
ECoLisp(Embeddable Common Lispの略)の略でECLとしていたものが、いつのまにかEmbeddable Common Lispの略でECLになったらしいのですが、別にECoLispのままでも良かったような……。
This is ECoLisp (ECL), an Embeddable Common Lisp implementationCopyright (c) 1990, 1991, 1993 Giuseppe Attardi
Authors:
KCL: Taiichi Yuasa and Masami Hagiya
Dynamic loader: William F. Schelter
Conservative GC: William F. Schelter
Top-level, trace, stepper: Giuseppe Attardi
Compiler: Giuseppe Attardi
CLOS: Giuseppe Attardi with excepts from PCL by Gregor Kiczales
Multithread: Giuseppe Attardi, Stefano Diomedi, Tito Flagella
Unification: Giuseppe Attardi, Mauro Gaspari
なお、現状資料が見当たらないので推測に過ぎませんが、KCLにマルチスレッドやCLOS、X11のGUIを付けて商用化されたものがDCLで、ECLは、それをCRSとAKCLをベースに構築しなおしたものなのかなと考えています。
CRSとPrologは何処へ
ECoLisp 0.12をSunOSのエミュレータでビルドして確認してみましたが、この頃までは、CRS部はまだ独立していますが、既にユニフィケーション部はほぼ残骸だけとなり、上記のLispからProlog機能を使うようなコードは書けなくなっています。
CLOS部もPortable CommonLoops(PCL)とは独立の実装で、class-prototypeの代わりに、先にmetaclassクラスを作っておくという独自方式でしたが、徐々にAMOP準拠に書き換えられた様子。
とはいえ、まだ結構な量が健在です。
まとめ
折角面白い機能であったCRSとProlog連携でしたが、どうも1990年代中盤には、ECLのコードからも削除されつつあり利用できなくなっていたようです。残念!
Poplogも共通の言語基盤を通して、Common LispとProlog、ML、Pop-11が連携しますが、あまりこういうのは流行らないのでしょうか。割合に面白いと思うのですが……。
なお、今回始めて知りましたが、Attardi先生は、元々はHewitt先生の元でアクター理論を研究していた方だったようです。
Delphi Common Lispも1980年代中後半にCLOSとX11上のGUI、マルチスレッド機能が使えたワークステーション上の処理系ということで大分時代を先取りしていたようですね。
■
HTML generated by 3bmd in LispWorks 7.0.0
井田昌之先生の公式ページに貴重なCommon Lispの資料が満載
Posted 2020-12-24 20:30:34 GMT
Lispの調べ物をしてインターネットを彷徨っていたところ、井田昌之先生が公開されている歴史的資料のページに辿り着きました。
なんとCommon Lisp系を中心として歴史的な資料が満載ではないですか。
下記にLisp系の資料を抜粋したリンクを適当なコメントと共に並べてみます。
1973
1970年代は、Lisp 1.5 との出会いから、Intel 8080上で動くLispマシンである、ALPS/Iの開発を中心に研究されていたようです。
所謂マイコンといわれていたCPU上でLispを動かす研究としてはかなり初期の取り組みではないでしょうか。
1976
1977
1978
1979
- 197903LispマシンALPS1
- 197903SYM07-1
- 197903コンパクトな処理系が可能な連想情報モデル
- 197903連想情報モデル経営工学会誌
- 197911AdaptableLispMachineIEEECS
- 197911IEEECSConfAnAdaptableLispMachine
1981
1980年代前半は、ALPS/Iの開発と並行して当時擡頭してきたAIマシン(Lispマシン)も研究されていたようです。
1984
1985
1984年にCommon Lispが登場しますが、それまでのマイコンLispの研究をバックグラウンドに、Common Lispのサブセットを検討されたり、Common Lispのオブジェクトシステムについて研究をされていたようです。
- 198506CommonLispいくつかの話題
- 198507HowtoObtainPCL
- 198508PICON日本語概要LMI
- 198509Lispコンテスト記号処理研究会
- 198509PersonalLispSystemComputersandIEFlorida
- 198511SYM34-4
- 198512InterpretationofCommonLoops
- 198512OOFacilitiesPrinciplesJSSSAnnualConf
1986
- 198601CommonLispパネル
- 198603CLOS原案WOOC86
- 198603PICONLMIOverview
- 198603SYM36-7
- 198604ISOTC97SC22N197NWIproposal
- 198605CommonLisp仕様の現在の論点とその方向
- 198608CommonLispCoreSummary
- 198608日仏ラウンドテーブル協力依頼
- 198609DiscriminatingEvalAnnualConfJSSST
- 198611SYM39-6
- 198611対談高度情報化社会
- 198612AAAI86会議報告
- 198612ICLispRelease
- 198612ISOTC97SC22N276AGRecommendations
- 198612日経オブジェクト指向ハード開発
1987
1986年あたりから電子メールを基盤とした議論について等も研究されている様子、また、ISO版Lispについての議論が盛り上がりつつあったことが判ります。
- 198701JISLisp現状認識と私見
- 198701LispandFP会議報告2
- 198702JeidaLisp技術動向調査計画
- 198703ANSIX3J13CommonLispアラカルト
- 198707CommonLoopsソフトウェア科学会
- 198708電子メール討論
- 198711JohnTeeter対談Bit
- 1987SymbolicsS-SystemLeaflet
- 1987SymbolicsS-SystemLeaflet2
- 1987SymbolicsS-Systemリーフレット
1988
ANSI CLに取り込まれる予定のCLOSがかなりまとまった頃で、CLOS的にはかなり熱い時期だったようです。
- 198801CommonLisp文字オブジェクト
- 198801SYM44-2
- 198803AMEXオーソライザーズアシスタント概要
- 198803ARTOverview
- 198808Jeida視察団報告
- 198808MacIvoryReaflet
- 198808MacIvoryRelease
- 198810CLOSワークショップ予稿集
- 198810SymbolicsIVORYArchitecture
- 198810チャートテスト教材原図Lisp
- 198810チャート型性格診断Lispプログラム
1989
1990
ネットワーク透過なウィンドウツールキットであるYYonXの研究、ヨーロッパで擡頭してきた米国Common Lispへの対抗馬であるEuLisp等が熱い時期だったようです。
ワークステーション文化も花盛りという感もあり、キャンパスネットワーク等の研究もされていたようです。
- 199003Europal90-An-Overview-of-YY-and-YYonX
- 199003Europal招待講演
- 199003IPSJ全国大会YYoX
- 199003YYandYYoXEuropal
- 199004InterAI手探りの国際化
- 199008EULispDefinition
- 1990YY電子図書館孫悟空事例
1991
- 199101SYM58-2
- 199101YYカラーグラフィック機構
- 199102TR90004AnOverviewofYYandYYonX
- 199102YYandYYonX
- 199103ICEERL91PaloAlto
- 199103SYM59-2
- 199105青山学報情報センタ
1992
1993
1994
1995
この辺りからLisp関連の研究は一段落され、当時擡頭してきたJavaの方に研究の軸足を移された様子。
また自由ソフトウェア運動の紹介等もされていたようです。
Emacsでは、レキシカルスコープは遅いのでダイナミックスコープを採用した、というのが通説ですが、この下記のインタビューではレキシカルスコープは速度と名前の競合回避には良いが、実装が簡単なのでダイナミックスコープを採用したとありますね。
レキシカルスコープは遅い説はどこが出所だったかな(History of T)だったような。
1996
- 199604Scheme過去現在未来1
- 199605Scheme過去現在未来2
- 199606Emacs解剖学1
- 199607Emacs解剖学2
- 199608Emacs解剖学3
- 199609Emacs解剖学4
- 199610Emacs解剖学5
- 199611Emacs解剖学6
- 199612Emacs解剖学7
1997
2001
2002
まとめ
まだまだ資料を全部は読み込めていないのですが、1980年代後半のCLOS系の資料や、Lispの国際規格化での各国の思惑等が伺える資料はかなり貴重だと思います。
■
HTML generated by 3bmd in LispWorks 7.0.0
allocate-instanceアドベントカレンダー総括
Posted 2020-12-24 15:00:00 GMT
allocate-instance Advent Calendar 2020 25日目の記事です。
アドベントカレンダーも参加者が少ないと最後に総括エントリーという必殺技を使ってエントリーを埋めることができます。
オブジェクトのアロケーションなら原理は簡単なので、ニッチすぎるアドベントカレンダーでも参加者もそこそこいたりするかなと思いましたが、結局一人で完走ということになりました。
なんとなくですが、最後まで何故allocate-instanceに着目したのかが判らない、という感じだったかもしれません。
私としては、アドベントカレンダー開幕で書いたとおり、スロットストレージにベクタ以外が使うというアイデアがあまり活用されていないところに着目したわけですが、活用されないだけあったアイデアであることを証明してしまったのかもしれません。
また、Common Lispではアロケートより後のプロトコルでできることが強力で、オブジェクトのIDとクラス情報だけあれば後はどうとでもできるのがallocate-instanceをいじる意義を低下させている気がします。
実際の活用例でいうと、オブジェクトの永続化あたりでallocate-instanceの話も少し出てきたりもしますが、allocate-instanceは基本的にオブジェクトIDの割り付け程度かなと思います。
やりのこしたこと
振り返ってみると、allocate-instanceのinitargsを活用する例を追求しなかったのが若干悔まれます。
といっても、allocate-instanceにストレージの種類を伝える程度な気はしますが。
あとはハッシュテーブルのストレージがベクタであることを利用して、先頭をオブジェクトのストレージにして、残りをハッシュテーブルにするというのを考えましたが、別に一本にする必要もないかなというところです。
他にも、どうしようもないアイデアはありますが、そのうち試してブログに書いてみたいと思います。
さて、次にアドベントカレンダーを企画した際にはさらにニッチなところを攻めたいと思います。
次回までごきげんよう!
■
HTML generated by 3bmd in LispWorks 7.0.0
allocate-instanceが関係してくるプロトコルを眺める: Tiny CLOS篇
Posted 2020-12-23 18:10:10 GMT
allocate-instance Advent Calendar 2020 24日目の記事です。
引き続き、allocate-instanceが関係してくるInstance Structure Protocol(ISP)周りを中心に色々なCLOS MOP系の処理系で確認していきたいと思います。
今回は、Tiny CLOSのallocate-instance周りを眺めます。
Tiny CLOSは、CLOS風のオブジェクトシステムを採用しているSchemeではTiny CLOSかその派生が採用されていることが多いようです。
作者が、CLOSおよびに参照実装であったPortable CommonLoopsに深く関わり、AMOPの著者でもあるKiczales先生というのもポイントが高いかもしれません。
大体の構成は、先日紹介したKiczales先生が1990年代前半に考えていた新しいInstance Structure Protocolの構成と同一のようです。
Object Creation and Initialization
allocate-instancemakeinitialize
Tiny CLOSでのインスタンスの構成ですが、instance-tag、classという先頭二つの部分と後半のスロット要素からなるベクタ表現されています。ベクタにしたかったというより、1992年のSchemeに構造体がないので、こういう構成にしたのかもしれません。
CLOSの実装でいうwrapper部は、そのままクラスメタオブジェクトの表現です。
ベクタ一本の表現なので、スロット部のベクタだけ取り出すようなことはなく、基本的に先頭2つのオフセットでアクセスする感じになります。
なお、Tiny CLOSはScheme(Common Lisp版もある)の実装なので、allocate-instanceの中身をいじれますが、OOPSが融合している処理系ではC等の実装言語レベルに直結していることが多いようで、安直に下請け関数がアロケートするスロットストレージをベクタからハッシュにすげかえてみる、等のことはやりにくいようです。
なお、Common LispでもECL等がそういう実装になっています。
Instance Structure Protocol
slot-refslot-set!lookup-slot-infocompute-getter-and-setter
スロットストレージの並び順は、CLと同様compute-slotsで確定するようです。
スロットの名前と位置の変換は、compute-getter-and-setterでゲッターとセッターのクロージャー生成する際にクロージャーの中に位置が埋め込まれる方式です。
slot-ref内で、lookup-slot-infoによりこのgetters-n-setters情報からゲッター/セッターを取り出してオブジェクトに適用、という流れになっています。
まとめ
Tiny CLOSは、スロット名とスロット位置変換の仕組みとして、位置情報を含んだゲッター/セッターをクラスメタオブジェクト内にまとめて管理、という方式のようです。
CLOS系OOPSそれぞれ微妙に違いますが、位置情報をクロージャーに閉じ込める方式の方が若干速いかなとは思います。
アクセサを定義すれば、標準のケースでは最適化された場合、スロットストレージへの直接アクセスになると思うので、Common Lispでは速度にこだわるなら、slot-valueは使うなというところなのでしょうか。この辺りどこかでそんな文献読んだことがある気がするのですが思い出せない……。
■
HTML generated by 3bmd in LispWorks 7.0.0
allocate-instanceが関係してくるプロトコルを眺める: TELOS篇
Posted 2020-12-23 02:46:42 GMT
allocate-instance Advent Calendar 2020 23日目の記事です。
引き続き、allocate-instanceが関係してくるInstance Structure Protocol(ISP)周りを中心に色々なCLOS MOP系の処理系で確認していきたいと思います。
今回は、TELOSのallocate-instance周りを眺めます。
TELOSは、EuLispのオブジェクトシステムで、EuLispもCommon Lispより簡潔な作りを指向しています。
EuLispとCommon Lispとの目立った違いは、EuLispがLisp1であることで、クラスの表記も他のシンボルと競合しないように、<foo>のように表記する慣習があります。
ちなみに、ISLISPは、EuLispの影響下にあるので、Lisp2なのに<foo>と表記します。
Object Creation and Initialization
allocatemakeinitialize
まず、インスタンスの構成ですが、class、slotsという二つの部分からなるprimitive-class構造体で表現されています。CLOSの実装でいうとwrapper部は、そのままクラスメタオブジェクトで表現されています。
インスタンスのストレージは標準でベクタ。
スロットストレージへは、primitive-class-slots、wrapperの取り出しは、primitive-class-ofで行えますが、クラスそのものなので別に必要ないかも?
CLOS MOPと異なる点としては、クラスがスロット数を保持するclass-instance-lengthを有します。
Instance Structure Protocol
slot-value(setf slot-value)primitive-slot-value(setf primitive-slot-value)slot-value-using-slotfind-slotslot-readerslot-writercompute-slotsprimitive-refsetter-primitive-refprimitive-find-slot-position
スロットストレージの並び順は、CLと同様compute-slotsで確定するようです。
CLOSのslot-definitionに相当する<slot>クラスがあり、class-slotsに格納されていますが、スロットの位置を計算するには、primitive-find-slot-positionを使います。
特に最適化はされておらず、class-slotsの中を順に探しているだけです。
(primitive-find-slot-position <simple-class> 'c (class-slots <foo>) 0)
→ 2CLのstandard-instance-accessに相当するものは、primitive-refになります。
slot-valueの中で、標準のメタクラスかどうかを判定するようになっており、標準であれば、slot-value-using-slotが、スロットのslot-reader/writerを呼び出しを値を取り出します。
slot-readerは最終的にはprimitive-refを呼びます。
slot-valueは
(slot-value-using-slot (find-slot (class-of obj) name)
obj)と展開されるので、何もしなければ、find-slotが探索してスロット名→スロット位置の変換をするので遅いですが総称関数なので(find-slot obj 'a)等を特定化して定義してやれば高速化はできそうです。
まとめ
CLOS系OOPSでスロット名からスロットの位置を割り出す方法にそれぞれ色々と工夫があるようです。
アクセサに比べてslot-valueの方がプリミティブな雰囲気があり、速度もアクセサより速そうな印象がありますが、MOPの仕組みからして、スロットの位置割り出しが計算済みの分アクセサの方が速いですね。
■
HTML generated by 3bmd in LispWorks 7.0.0
allocate-instanceが関係してくるプロトコルを眺める: MCS篇
Posted 2020-12-21 20:53:44 GMT
allocate-instance Advent Calendar 2020 22日目の記事です。
前回に引き続き、allocate-instanceが関係してくるInstance Structure Protocol(ISP)周りを中心に色々なCLOS MOP系の処理系で確認していきたいと思います。
今回は、MCSのallocate-instance周りを眺めます。
まず、MCSですが、The Meta Class Systemの略で、ObjVlispの流れをくみつつCLOSとの互換性も高いシステムです。
- 過去記事: #:g1: mcsの紹介
MOPも大体同じような構成になっていますが、MCSの方がシンプルでありつつ抽象クラスやmixinクラス等も用意されていて色々整理されているようにも見えます。
Object Creation and Initialization
allocate-instancemake-instanceinitialize-instancechange-classchange-class-using-class
さてまず、インスタンスの構成ですが、isit、slotsという二つの部分からなる構造体で表現されています。isitというのはCLOSの実装でいうとwrapperですが、クラスメタオブジェクトを一つ含んだリストで表現されていて、wrapperとclassのオブジェクトがほぼ一本化されています。
インスタンスのストレージは標準ではベクタです。
スロットストレージへは、mcs%-slots、wrapperの取り出しは、mcs%-isitで行えます。
CLOS MOPと異なる点として、スロット名から、スロットストレージの位置を割り出す関数がクラスの中に格納されている点で、標準では、general-slot-position関数が、class-slot-accessorに格納されています。
Instance Structure Protocol
slot-exists-pslot-boundpslot-makunboundslot-valuemcs%slot-value(setf slot-value)mcs%set-slot-valuemcs%set-slot-value-lowcompute-slotsmcs%local-slot-indexedmcs%local-slot-indexed-low
スロットストレージの並び順は、CLと同様compute-slotsで確定するようです。
スロットの位置を計算する関数がクラスに含まれているので、slot-definition-locationは存在せず、%slot-location-ofが位置計算用関数を呼び出して計算します。
CLのstandard-instance-accessに相当するものは、mcs%local-slot-indexed-lowになりますが、slot unboundのサポートありのmcs%local-slot-indexedも用意されています。
CLと違ってslot-valueはマクロになっており、slot-value-using-系メソッドはなく、mcs%slot-valueに展開か、メソッド内部での最適化として、mcs%local-slot-indexed-lowを用いたアクセスになるよう展開するようです(なお実装ではそこまで最適化されていない)
mcs%slot-valueは、上述のスロット位置を名前から割り出す関数を呼び出して、インスタンスのストレージを添字でアクセスします。
なお、-lowが掴ないものは、slot unboundをサポートせずslot missingのみサポートします。
まとめ
MCSではslot-value-using-classが省略されていますが、その代わりにクラスがスロット名→ストレージの位置の変換関数を保持するというのが面白いと思いました。
この辺りの方式の違いをそのうち比較してみたいところです。
■
HTML generated by 3bmd in LispWorks 7.0.0
allocate-instanceが関係してくるプロトコルを眺める: Common Lisp篇
Posted 2020-12-20 17:40:41 GMT
allocate-instance Advent Calendar 2020 21日目の記事です。
ネタ切れも甚しいのでallocate-instanceが関係してくるInstance Structure Protocol(ISP)周りを中心に色々なCLOS MOP系の処理系で確認していきたいと思います。
まずは、本家Common Lispです。
Instance Structure Protocol
slot-exists-pslot-boundpslot-boundp-using-class
slot-makunboundslot-makunbound-using-class
slot-valueslot-value-using-class
(setf slot-value)(setf slot-value-using-class)
compute-slots :aroundslot-definition-locationstandard-instance-accessfuncallable-standard-classfuncallable-standard-instance-access
ISPで列挙されているのは、スロットアクセス系の関数/メソッドになり、allocate-instance等は埒外です。
ます、関係してくる順序としては、スロットストレージの並び順がcompute-slots :aroundで確定し、インスタンスのストレージとスロットの位置が確定します。それに伴なって、slot-definition-locationの値も決まり、standard-instance-accessでのアクセスの添字も決まる、という感じです。
slot-valueの下請けが、slot-value-using-classで、更に下請けが、standard-instance-accessとされていますが、処理系によっては、slot-valueからインスタンスのストレージに直通の場合もあるようです(LispWorksでスロットアクセスの最適化が有効になっている場合など)
standard-instance-accessは、インスタンスのストレージに添字でアクセスする低レベルの関数ですが、standard-と付いていることから判るように、standard-objectを想定しています。
standard-objectとはインスタンスのストレージ構成が違う場合には使えないと考えた方が良いでしょう。
Class finalization protocol
class-finalized-pfinalize-inheritance
継承関係の確定のプロトコルですが、インスタンスがアロケートされる前に確定している必要があるとされており、allocate-instanceが呼ばれる前にclass-finalized-pで調べて確定していなければ、finalize-inheritanceが呼ばれるとされています。
この判定のタイミングですが、Robert Strandh先生によれば、allocate-instanceの引数のinitargsは確定後の計算結果になるので呼ばれる前に確定している筈としていてPCLでも、make-instanceがfinalize-inheritanceを呼んでいると註記していますが、PCL系であるSBCL等では、allocate-instanceの中で呼ばれています(ensure-class-finalized経由)。
大抵の処理系では、finalize-inheritanceを呼んでいるので、実際のところ必須なのかそうでないのか。ちなみに自分はStrandh先生を信じて今回のアドベントカレンダでは呼ばないスタイルで通しました。
Object Creation and Initialization
make-instanceshared-initializechange-classupdate-instance-for-different-classupdate-instance-for-redefined-class
あたりですが、インスタンスストレージの構成が標準と異なる場合は、初期化/再初期化の手続を別途記述する必要が出てきます。
また、標準的な構成とカスタマイズしたものとでchange-classする場合は、インスタンスストレージの確保も別途記述する必要も出てきます。
大抵は、上記メソッドと標準メソッドコンビネーションでどうにかできますが、もしかしたら、標準から外れる場合は、Dependent maintenance protocolでストレージ形式の修正をしたりした方が良いのかもしれません。
まとめ
関係プロトコルをざっと眺めてみましたが、allocate-instanceをカスタマイズする例がほとんどないですね。
思えば、allocate-instanceのカスタマイズは、大抵は初期の文献に見付かるのですが何故なのか(共通仕様をまとめるのが難しいとか?)
■
HTML generated by 3bmd in LispWorks 7.0.0
virtual slotをallocate-instanceレベルで考えてみる
Posted 2020-12-19 21:12:58 GMT
allocate-instance Advent Calendar 2020 20日目の記事です。
MOPの応用として、仮想的なアロケーションの場所を指定する例があります。
- STklos: 8.2.1.4 Virtual Slots
- LispWorks User Guide and Reference Manual > 18.4 Implementation of virtual slots
大抵は、スロットの:allocation指定で、:virtual等を指定するという感じですが、allocate-instance内でどうにかできないか考えてみます。
allocate-instance内でどうにかするという縛りなので、スロットストレージに関数を詰めて呼び出すという作戦で実行時にデータを取得できるようにしてみます。
(defpackage "f53e7180-1934-50c0-9c43-7c6a79b7a5e2"
(:use c2cl slotted-objects))
(cl:in-package "f53e7180-1934-50c0-9c43-7c6a79b7a5e2")
(defclass virtual-class (slotted-class)
())
(defclass virtual-object (slotted-object)
()
(:metaclass virtual-class))
(defmethod allocate-slot-storage ((class virtual-class) size initial-value)
(let ((storage (make-sequence 'vector size))
(fctns (make-sequence 'vector size)))
(dotimes (index size fctns)
(setf (elt fctns index)
(let ((index index))
(lambda (op value)
(case op
(:get (elt storage index))
(:set (setf (elt storage index) value)))))))))
(defmethod slot-value-using-class ((class virtual-class) instance (slotd slot-definition))
(funcall (elt (instance-slots instance) (slot-definition-location slotd))
:get 'ignore))
(defmethod (setf slot-value-using-class) (value (class virtual-class) instance (slotd slot-definition))
(funcall (elt (instance-slots instance) (slot-definition-location slotd))
:set value))
微妙に使い勝手が悪いですが、とりあえず下記のように書けます。 スロット読み出しが発生すると、スロットストレージに詰められたクロージャーが呼ばれ、値を計算します。
(defclass 56nyan (virtual-object)
((name)
(code :initarg :item-code)
(price))
(:metaclass virtual-class))
(defun get-56nyan-page (code)
(babel:octets-to-string
(drakma:http-request (format nil "https://www.56nyan.com/fs/goronyan/~A" code)
:force-binary T)
:encoding :cp932))
(defmethod allocate-slot-storage ((class (eql (find-class '56nyan))) size initial-value)
(let* ((fcns (call-next-method))
(slotds (class-slots class)))
(labels ((name->loc (name)
(slot-definition-location (find name slotds :key #'slot-definition-name)))
(slot-fctn (name)
(elt fcns (name->loc name)))
((setf slot-fctn) (fctn name)
(setf (elt fcns (name->loc name)) fctn))
(code ()
(funcall (elt fcns (name->loc 'code)) :get nil)))
(setf (slot-fctn 'name)
(lambda (op value)
(declare (ignore value))
(case op
(:get (plump:attribute (elt (clss:select "meta[property=og:title]" (plump:parse (get-56nyan-page (code)))) 0)
"content"))
(:set nil))))
(setf (slot-fctn 'price)
(lambda (op value)
(declare (ignore value))
(case op
(:get (plump:text (elt (clss:select ".itemPrice" (plump:parse (get-56nyan-page (code)))) 0)))
(:set nil)))))
fcns))
実行してみる
allocate-instanceレベルで実現する意義を考えてみましたが、change-classしても値がスムースに移行可能なのではないでしょうか。
(defclass 56nyan-static ()
((name)
(code :initarg :item-code)
(price)))
(let ((obj (make-instance '56nyan :code "7e003-001")))
(change-class obj '56nyan-static)
(describe obj))
⇒
#<56nyan-static 42000B7D3B> is a 56nyan-static
name "アカナ グラスランド キャット 340g (42341) 【正規品】"
code "7e003-001"
price "1,093円"
まとめ
そもそも、Common Lispの場合、スロットのリーダ/ライタでメソッドコンビネーションが使えるので、Virtual Slotsのようなものはあまり必要ないような気もします。
ちなみに、今回のchange-classの用法ですが、Common Lisp Proメーリングリストのchange-classの議論で、とりあえずデータをロードして、change-classで正規化するのが便利、という用例紹介をちょっと真似してみました(今回は正規化してませんが)
自分も以前、change-classの使い方として試してみたことがあった気がしますが、こういう応用も無くはないのかなと思います。
■
HTML generated by 3bmd in LispWorks 7.0.0
allocate-instanceでスロットのデフォルト値をnilにする
Posted 2020-12-19 10:56:17 GMT
allocate-instance Advent Calendar 2020 19日目の記事です。
以前、LW Dylan TranslatorというLispWorks上のDylanのシミュレーターのソースコードを眺めた時に、内部関数を使ってスロットをnilでfillしていたのが印象に残っていたのですが、未束縛スロットの扱いが面倒なので、とりあえず:initform nilしておくというコードもたまに見掛けたりもするので、そこそこ常套句なのかもしれません。
ということで、今回は、allocate-instanceでスロットのデフォルト値をnilにしてみましょう。
(defpackage "cafc9fa3-5687-537e-839a-424c9b589974"
(:use c2cl slotted-objects))(cl:in-package "cafc9fa3-5687-537e-839a-424c9b589974")
(defclass default-to-nil-class (slotted-class)
())
(defmethod allocate-instance :around ((class default-to-nil-class) &key &allow-other-keys)
(let ((instance (call-next-method)))
(fill (instance-slots instance) nil)
instance))
これで下記のような動作になります。
(defclass foo (slotted-object)
((a :initform 'a)
b
c)
(:metaclass default-to-nil-class))(describe (make-instance 'foo))
⇒
#<foo 40203E71A3> is a foo
a a
b nil
c nil
当然ですが、明示的に設定したnilなのか、暗黙のnilなのか区別が付かなくなるので、その辺りは注意です。
そう考えると、取扱が面倒ではありますが未束縛値で埋めておくというのは妥当ではありますね。
■
HTML generated by 3bmd in LispWorks 7.0.0
スロットストレージの拡張と標準オブジェクトとのコンパチビリティの確保について
Posted 2020-12-17 19:59:09 GMT
allocate-instance Advent Calendar 2020 18日目の記事です。
これまで、スロットのストレージを二次元配列にしてみたり、構造体にしてみたりと妙なことを試してきましたが、標準的なスロットストレージを持つオブジェクト(standard-object等)とのchange-classでの相互運用を考慮した場合、スロットストレージも伸展や縮退をサポートする必要があります。
この辺りを司るのは、change-classの下請けのupdate-instance-for-different-classになりますが、滅多に使わない機能というか、私個人もメソッド定義する必要に遭遇したことがありません。
それはさておき、とりあえずの例として、スロットストレージが拡張された、a-class、b-classと、標準構成の三つのクラスを定義したとします。
(defpackage "fd84d50c-3573-5d37-aed2-73e7d98bb52d"
(:use c2cl slotted-objects))
(cl:in-package "fd84d50c-3573-5d37-aed2-73e7d98bb52d")
(defclass a-class (slotted-class)
())
(defclass a-object (slotted-object)
()
(:metaclass a-class))
(defclass b-class (slotted-class)
())
(defclass b-object (slotted-object)
()
(:metaclass a-class))
(defmethod allocate-instance ((class a-class) &key &allow-other-keys)
(allocate-slotted-instance (class-wrapper class)
(make-array `(2 ,(length (class-slots class)))
:initial-element (make-unbound-marker))))
(defmethod allocate-instance ((class b-class) &key &allow-other-keys)
(allocate-slotted-instance (class-wrapper class)
(make-array `(4 ,(length (class-slots class)))
:initial-element (make-unbound-marker))))
(defmethod slot-value-using-class ((class a-class) instance (slotd slot-definition))
(aref (instance-slots instance) 0 (slot-definition-location slotd)))
(defmethod (setf slot-value-using-class) (value (class a-class) instance (slotd slot-definition))
(setf (aref (instance-slots instance) 0 (slot-definition-location slotd))
value))
(defmethod slot-value-using-class ((class b-class) instance (slotd slot-definition))
(aref (instance-slots instance) 1 (slot-definition-location slotd)))
(defmethod (setf slot-value-using-class) (value (class b-class) instance (slotd slot-definition))
(setf (aref (instance-slots instance) 1 (slot-definition-location slotd))
value))
とりあえず、インスタンスのクラスを変更することがなければ、別段このままでも問題ありません。
(defclass foo (a-object)
((a :initform 0)
(b :initform 1)
(c :initform 2))
(:metaclass a-class))
(defclass bar (b-object)
((a :initform 4)
(b :initform 5)
(c :initform 6))
(:metaclass b-class))
(defclass baz (standard-object)
((a :initform 7)
(b :initform 8)
(c :initform 9)))
(progn
(describe (make-instance 'foo))
(describe (make-instance 'bar))
(describe (make-instance 'baz)))
#<foo 402005E1FB> is a foo
a 0
b 1
c 2
#<bar 402005E59B> is a bar
a 4
b 5
c 6
#<baz 402005E8D3> is a baz
a 7
b 8
c 9
しかし、change-classするとなると、インスタンスのストレージが違うので、違いを吸収するメソッドをupdate-instance-for-different-classに定義してやる必要があります。
拡張→標準の移行
standard-objectにchange-classする分には拡張したスロットストレージが削られることになるので、特に難しいことはありません。
(defmethod update-instance-for-different-class
((pre slotted-object) (cur standard-object) &key &allow-other-keys)
(dolist (slotd (class-slots (class-of cur)))
(let ((slot-name (slot-definition-name slotd)))
(when (slot-exists-p pre slot-name)
(setf (slot-value cur slot-name)
(slot-value pre slot-name))))))標準→拡張の移行
standard-objectから拡張したものにchange-classする分には拡張したスロットストレージを使うことになるので、ストレージのアロケートをして、新しいストレージ側に値をコピーする必要があります。
ストレージのアロケーションをメタクラスで切り替えたいとすると、allocate-instanceの下請けとして共通のメソッドを定義するのが良さそうです。
今回は、allocate-slot-storageというメソッドを定義して使うことにしてみました。
(defgeneric allocate-slot-storage (class size initial-value))
(defmethod allocate-slot-storage ((class a-class) size initial-value)
(make-array `(2 ,size) :initial-element initial-value))
(defmethod allocate-slot-storage ((class b-class) size initial-value)
(make-array `(4 ,size) :initial-element initial-value))
;; ... allocate-instanceの書き換えは略 ...
(defmethod update-instance-for-different-class
((pre standard-object) (cur slotted-object) &key &allow-other-keys)
(let ((cur-class (class-of cur)))
(setf (instance-slots cur)
(allocate-slot-storage cur-class
(length (class-slots cur-class))
(make-unbound-marker)))
(dolist (slotd (class-slots cur-class))
(let ((slot-name (slot-definition-name slotd)))
(when (slot-exists-p pre slot-name)
(setf (slot-value cur slot-name)
(slot-value pre slot-name)))))))
拡張→拡張の移行
標準→拡張と内容は同じなのですが、このパターンも用意しておく必要があります。
(defmethod update-instance-for-different-class
((pre slotted-object) (cur slotted-object) &key &allow-other-keys)
(let ((cur-class (class-of cur)))
(setf (instance-slots cur)
(allocate-slot-storage cur-class
(length (class-slots cur-class))
(make-unbound-marker)))
(dolist (slotd (class-slots cur-class))
(let ((slot-name (slot-definition-name slotd)))
(when (slot-exists-p pre slot-name)
(setf (slot-value cur slot-name)
(slot-value pre slot-name)))))))なお、基本的に拡張への移行は、新しくインスタンスのストレージを確保する部分だけなので、update-instance-for-different-classの:beforeメソッドで、ストレージの置き換えを定義するだけで良いのかもしれません。
このあたりの参考資料が見付けられないので良く分からず……。
以上で相互変換が可能になります。
(progn
(progn
;; slotted-object → standard-object
(describe (change-class (make-instance 'foo) 'baz))
(describe (change-class (make-instance 'bar) 'baz))
(describe (change-class (make-instance 'baz) 'baz)))
(progn
;; standard-object → slotted-object
(describe (change-class (make-instance 'bar) 'foo))
(describe (change-class (make-instance 'baz) 'foo)))
(progn
;; slotted-object → slotted-object
(describe (change-class (make-instance 'foo) 'bar))
(describe (change-class (make-instance 'bar) 'bar))))#<baz 402005EC43> is a baz
a 0
b 1
c 2
#<baz 402005F163> is a baz
a 4
b 5
c 6
#<baz 402005F64B> is a baz
a 7
b 8
c 9
#<foo 402005FB33> is a foo
a 4
b 5
c 6
#<foo 4020060073> is a foo
a 7
b 8
c 9
#<bar 4020060583> is a bar
a 0
b 1
c 2
#<bar 4020230B2B> is a bar
a 4
b 5
c 6
まとめ
allocate-なんとかのメソッドを上手い感じに命名してまとめたいところなのですが難しい……。
一応今回は、Closetteを参考に命名してみました。
■
HTML generated by 3bmd in LispWorks 7.0.0
アンドゥ可能なスロット
Posted 2020-12-16 23:30:16 GMT
allocate-instance Advent Calendar 2020 17日目の記事です。
完全なるネタ切れですが、今回はアンドゥ可能なスロットを実現してみたいと思います。
以前に紹介した履歴付きスロットと似たような感じですが、こちらは限定された回数スロットの状態をアンドゥできることをメインに考えます!
動作と仕様
仕様としては、どこかのスロットが変更された場合、スロット全部を保存することにします。
内部では、16セットのスロットを二次元配列で表現したものと現在の位置を、オブジェクトのストレージとします。
また、ユーティリティとしてundo-slotsとreset-slotsも用意してみます。
(defclass foo (undoable-slots-object)
((a :initform 0)
(b :initform 1)
(c :initform 2))
(:metaclass undoable-slots-class))
(defparameter *foo* (make-instance 'foo))
(describe *foo*)
#<foo 4020002193> is a foo
a 0
b 1
c 2
;; 乱数を任意のスロットに代入 x 15回
(dotimes (i 15)
(setf (slot-value *foo* (elt #(a b c) (mod i 3)))
(random 1000)))
;; 15回状態を戻す
(dotimes (i 15)
(describe (undo-slots *foo*)))
#<foo 4020002193> is a foo
a 930
b 743
c 626
#<foo 4020002193> is a foo
a 930
b 365
c 626
#<foo 4020002193> is a foo
a 571
b 365
c 626
#<foo 4020002193> is a foo
a 571
b 365
c 695
#<foo 4020002193> is a foo
a 571
b 92
c 695
#<foo 4020002193> is a foo
a 895
b 92
c 695
#<foo 4020002193> is a foo
a 895
b 92
c 905
#<foo 4020002193> is a foo
a 895
b 139
c 905
#<foo 4020002193> is a foo
a 841
b 139
c 905
#<foo 4020002193> is a foo
a 841
b 139
c 859
#<foo 4020002193> is a foo
a 841
b 342
c 859
#<foo 4020002193> is a foo
a 10
b 342
c 859
#<foo 4020002193> is a foo
a 10
b 342
c 2
#<foo 4020002193> is a foo
a 10
b 1
c 2
#<foo 4020002193> is a foo
a 0
b 1
c 2
nil
実装
(defpackage "955b5b51-173a-50c3-82f6-7add63d9b29a"
(:use c2cl slotted-objects))
(cl:in-package "955b5b51-173a-50c3-82f6-7add63d9b29a")
(defconstant undo-limit 16.)
(defclass undoable-slots-storage ()
((slots :initarg :slots :accessor undoable-slots-storage-slots)
(history# :initform 0 :accessor undoable-slots-storage-history#)))
(defclass undoable-slots-class (slotted-class)
()
(:metaclass standard-class))
(defclass undoable-slots-object (slotted-object)
()
(:metaclass undoable-slots-class))
(defmethod allocate-instance ((class undoable-slots-class) &key &allow-other-keys)
(allocate-slotted-instance (class-wrapper class)
(make-instance 'undoable-slots-storage
:slots (make-array `(,undo-limit ,(length (class-slots class)))
:initial-element (make-unbound-marker)))))
(defclass undoable-slots-object (slotted-object)
()
(:metaclass undoable-slots-class))
(defmethod slot-value-using-class ((class undoable-slots-class) instance (slotd slot-definition))
(let ((storage (instance-slots instance)))
(aref (undoable-slots-storage-slots storage)
(undoable-slots-storage-history# storage)
(slot-definition-location slotd))))
(defmethod (setf slot-value-using-class) (value (class undoable-slots-class) instance (slotd slot-definition))
(let* ((storage (instance-slots instance))
(curpos (mod (undoable-slots-storage-history# storage) undo-limit))
(loc (slot-definition-location slotd)))
(flet ((backup ()
(dotimes (idx (length (class-slots class)))
(let ((new (mod (1+ curpos) undo-limit))
(old curpos))
(setf (aref (undoable-slots-storage-slots storage) new idx)
(aref (undoable-slots-storage-slots storage) old idx)))))
(incpos ()
(setf (undoable-slots-storage-history# storage)
(mod (1+ curpos) undo-limit))))
(backup)
(incpos)
(setf (aref (undoable-slots-storage-slots storage)
(undoable-slots-storage-history# storage)
loc)
value))))
(defmethod initialize-slot-from-initarg ((class undoable-slots-class) instance slotd initargs)
(let ((slot-initargs (slot-definition-initargs slotd)))
(loop :for (initarg value) :on initargs :by #'cddr
:do (when (member initarg slot-initargs)
(let ((storage (instance-slots instance)))
(setf (aref (undoable-slots-storage-slots storage)
(undoable-slots-storage-history# storage)
(slot-definition-location slotd))
value))
(return T)))))
(defmethod initialize-slot-from-initfunction ((class undoable-slots-class) instance slotd)
(let ((initfun (slot-definition-initfunction slotd)))
(unless (not initfun)
(let ((storage (instance-slots instance)))
(setf (aref (undoable-slots-storage-slots storage)
(undoable-slots-storage-history# storage)
(slot-definition-location slotd))
(funcall initfun))))))
(defun undo-slots (obj)
(let ((storage (instance-slots obj)))
(setf (undoable-slots-storage-history# storage)
(mod (1- (undoable-slots-storage-history# storage)) undo-limit)))
obj)
(defun reset-slots (obj)
(let ((storage (instance-slots obj)))
(setf (undoable-slots-storage-history# storage)
0))
obj)
■
HTML generated by 3bmd in LispWorks 7.0.0
リードオンリーなスロット
Posted 2020-12-15 19:11:45 GMT
allocate-instance Advent Calendar 2020 16日目の記事です。
何かallocate-instanceネタがないか、隠しスロットの応用がないか、と探しまわっていますが、そういえば、defstructにはスロットの:read-onlyオプションがあるのに、defclassにはないなと思ったので、隠しスロットで実装してみました。
動作
(defclass foo (acl-slots-object)
((a :initform 0 :read-only T :accessor foo-a)
(b :initform 1 :read-only nil)
(c :initform 2 :read-only T))
(:metaclass acl-slots-class))
(mapcar #'slot-definition-read-only-p (class-slots (find-class 'foo)))
→ (t nil t)
(let ((obj (make-instance 'foo)))
(with-slots (a b c) obj
(list a b c)))
→ (0 1 2)
(let ((obj (make-instance 'foo)))
(with-slots (a b c) obj
(setq b 100)
(list a b c)))
→ (0 100 2)
(let ((obj (make-instance 'foo)))
(with-slots (a b c) obj
(setq a 100)
(list a b c)))
!!! Cannot assign to read only slot a of #<foo 40201234EB>
(let ((obj (make-instance 'foo)))
(setf (foo-a obj) 8))
!!! Cannot assign to read only slot a of #<foo 402020F6C3>
ここまで書いて試してみて、クラスの属性としてスロットにリードオンリー属性を付けるだけならインスタンスに隠しスロットを付ける意味がないという致命的なことに気付いてしまったので、インスタンス生成時にも個別に指定できるようにしてみました。
(make-instance 'bar :read-onlys '(:b))のように:read-onlys引数で該当するスロットの:initargを指定します。
(defclass bar (acl-slots-object)
((a :read-only T :initform 0 :initarg :a :reader bar-a)
(b :read-only nil :initform 1 :initarg :b :accessor bar-b)
(c :read-only T :initform 2 :initarg :c))
(:metaclass acl-slots-class))
(let ((obj (make-instance 'bar)))
(setf (bar-b obj) 42))
→ 42
(let ((obj (make-instance 'bar :read-onlys '(:b))))
(setf (bar-b obj) 42))
!!! Cannot assign to read only slot b of #<bar 402009983B>
まとめ
あと九個もネタが捻り出せない。
実装
(defpackage "3d5973f5-7755-5daf-a825-d623a03a4d53" (:use c2cl slotted-objects))
(cl:in-package "3d5973f5-7755-5daf-a825-d623a03a4d53")
(defconstant slot-dim 0)
(defconstant acl-dim 1)
(defclass acl-slots-class (slotted-class)
()
(:metaclass standard-class))
(defmethod allocate-instance ((class acl-slots-class) &rest initargs)
(allocate-slotted-instance (class-wrapper class)
(make-array `(2 ,(length (class-slots class)))
:initial-element (make-unbound-marker))))
(defclass acl-slots-object (slotted-object)
()
(:metaclass acl-slots-class))
(defmethod slot-value-using-class ((class acl-slots-class) instance (slotd slot-definition))
(aref (instance-slots instance)
slot-dim
(slot-definition-location slotd)))
(defmethod (setf slot-value-using-class) (value (class acl-slots-class) instance (slotd slot-definition))
(let* ((slots (instance-slots instance))
(loc (slot-definition-location slotd)))
(when (aref slots acl-dim loc)
(error "Cannot assign to read only slot ~S of ~S" (slot-definition-name slotd) instance))
(setf (aref slots slot-dim loc) value)))
(defun slot-read-only-p (instance slot-name)
(aref (instance-slots instance)
acl-dim
(slot-definition-location
(find slot-name (class-slots (class-of instance))
:key #'slot-definition-name))))
(defclass acl-slots-slot-definition (standard-slot-definition)
((attributes :initform nil
:initarg :read-only
:accessor slot-definition-read-only-p)))
(defclass direct-acl-slots-slot-definition (standard-direct-slot-definition acl-slots-slot-definition)
())
(defmethod direct-slot-definition-class ((class acl-slots-class) &rest initargs)
(find-class 'direct-acl-slots-slot-definition))
(defclass effective-acl-slots-slot-definition (standard-effective-slot-definition acl-slots-slot-definition)
())
(defmethod effective-slot-definition-class ((class acl-slots-class) &rest initargs)
(find-class 'effective-acl-slots-slot-definition))
(defmethod compute-effective-slot-definition ((class acl-slots-class)
name
direct-slot-definitions)
(let ((effective-slotd (call-next-method)))
(dolist (slotd direct-slot-definitions)
(when (typep slotd 'acl-slots-slot-definition)
(setf (slot-definition-read-only-p effective-slotd)
(slot-definition-read-only-p slotd))
(return)))
effective-slotd))
(defmethod initialize-slot-from-initarg ((class acl-slots-class) instance slotd initargs)
(let ((slot-initargs (slot-definition-initargs slotd)))
(loop :for (initarg value) :on initargs :by #'cddr
:do (when (member initarg slot-initargs)
(setf (aref (instance-slots instance) slot-dim (slot-definition-location slotd))
value)
(return T)))))
(defmethod initialize-slot-from-initfunction ((class acl-slots-class) instance slotd)
(let ((initfun (slot-definition-initfunction slotd)))
(unless (not initfun)
(setf (aref (instance-slots instance) slot-dim (slot-definition-location slotd))
(funcall initfun)))))
(defmethod shared-initialize :after ((instance acl-slots-object) slot-names &key read-onlys &allow-other-keys)
(let* ((class (class-of instance))
(slots (class-slots class)))
(dolist (s slots)
(setf (aref (instance-slots instance) acl-dim (slot-definition-location s))
(slot-definition-read-only-p s))
(when (intersection read-onlys (slot-definition-initargs s))
(setf (aref (instance-slots instance) acl-dim (slot-definition-location s))
T)))))
■
HTML generated by 3bmd in LispWorks 7.0.0
allocate-instanceでメソッド実装の強制
Posted 2020-12-14 15:00:00 GMT
allocate-instance Advent Calendar 2020 15日目の記事です。
Java等では、インスタンス化不可な抽象クラスを定義したり、抽象クラスでメソッドの実装を強制したりできますが、Common Lispだとmixinクラスのインスタンス化はマナーとしてしない程度です。さらに、メソッドの実装を強制については、そもそも総称関数なのでクラスが統治の単位でもありません。
また、オブジェクト指向システムがとても動的なので、チェックがコンパイル時ではなく、実行時によってしまうというのもいま一つなところです。
とはいえ、MOPのインスタンス生成プロトコルにフックを掛けてインスタンス化を抑止することは可能で、そのフックのポイントがallocate-instanceからclass-prototypeあたりになります。
allocate-instanceでメソッド実装の強制
まあ、allocate-instanceにメソッド実装の強制という責務はないのですが、インスタンスが生成されるポイントなのでフックを掛けるのがこのあたりになってしまいます。
とりあえず:abstract-methodsオプションにメソッドを指定してクラスに該当するメソッドが実装されているかをチェックするのをallocate-instance :beforeに仕掛けます。
(defpackage "0cbdbd51-5be8-57c3-9b14-9473f74c8a61" (:use c2cl))
(cl:in-package "0cbdbd51-5be8-57c3-9b14-9473f74c8a61")
(defclass enforcing-abstract-methods-class (standard-class)
((abstract-methods :initform '() :accessor class-abstract-methods)
(direct-abstract-methods :initform '()
:reader class-direct-abstract-methods
:initarg :abstract-methods)))
(defmethod finalize-inheritance :after ((class enforcing-abstract-methods-class))
(setf (class-abstract-methods class)
(remove-duplicates
(loop :for c :in (class-precedence-list class)
:when (typep c 'enforcing-abstract-methods-class)
:append (mapcar #'eval (class-direct-abstract-methods c)))
:from-end T)))
(defmethod allocate-instance :before ((class enforcing-abstract-methods-class)
&key &allow-other-keys)
(dolist (gf (class-abstract-methods class))
(or (some (lambda (x)
(find class (method-specializers x)))
(generic-function-methods gf))
(error "Can't instantiate abstract class ~S with abstract methods ~S."
class
gf))))
ついでに、インスタンス化不可なabstract-classも定義します。
こちらは、以前ブログで紹介したものになります。
一応仕組みを解説すると、abstract-classを:metaclassに指定した場合、class-prototype :aroundとallocate-instanceの組み合わせがエラーになりますが、抽象クラスのサブクラスがstandard-class等を:metaclassに指定すれば、通常ルートでインスタンス生成が実行されるのでエラーにならない、という流れです。
(defclass abstract-class (standard-class)
())
(defmethod validate-superclass ((class abstract-class) (superclass standard-class))
T)
(defmethod validate-superclass ((class standard-class) (superclass abstract-class))
T)
(defvar *outside-abstract-class* nil)
(defmethod allocate-instance ((class abstract-class) &key &allow-other-keys)
(unless *outside-abstract-class*
(error "There was an attempt to make an instance of abstract class ~S" (class-name class))))
(defmethod class-prototype :around ((class abstract-class))
(let ((*outside-abstract-class* T))
(call-next-method)))
試してみる
;; 抽象クラス
(defclass foo ()
(a b c)
(:metaclass abstract-class))
;; インスタンス化できない
(make-instance 'foo)
!!! There was an attempt to make an instance of abstract class foo
;; 実装するメソッド
(defgeneric ztesch (x))
(defgeneric bazola (x y))
;; メソッド実装強制クラス
(defclass bar (foo)
()
(:metaclass enforcing-abstract-methods-class)
(:abstract-methods #'ztesch #'bazola))
;; インスタンス化できない
(make-instance 'bar)
!!! Can't instantiate abstract class #<enforcing-abstract-methods-class bar 41C00A64F3> with abstract methods #<common-lisp:standard-generic-function ztesch 41E001C3FC>.
;; 抽象クラス+メソッド実装強制メタクラス
(defclass abstract-class-enforcing-abstract-methods-class (abstract-class enforcing-abstract-methods-class)
())
;; 抽象クラス+メソッド実装強制クラス(が抽象クラスを継承)
(defclass baz (foo)
()
(:metaclass abstract-class-enforcing-abstract-methods-class)
(:abstract-methods #'ztesch #'bazola))
;; インスタンス化できない(なお実装を強制されたメソッドが空の場合、抽象クラス側のエラーとなる)
(make-instance 'baz)
!!! Can't instantiate abstract class #<abstract-class-enforcing-abstract-methods-class baz 42205DAC5B> with abstract methods #<common-lisp:standard-generic-function ztesch 424001B494>.
;; 抽象クラス+メソッド実装強制クラス(が抽象クラスを継承)のサブクラス
(defclass quux (baz)
()
(:metaclass enforcing-abstract-methods-class))
(finalize-inheritance (find-class 'quux))
;; 実装が強制されたメソッドの確認
(class-abstract-methods (find-class 'quux))
→ (#<common-lisp:standard-generic-function ztesch 41E001C3FC> #<common-lisp:standard-generic-function bazola 41E001C434>)
;; メソッドが実装されていないのでエラー
(make-instance 'quux)
!!! Can't instantiate abstract class #<enforcing-abstract-methods-class quux 40201AD06B> with abstract methods #<common-lisp:standard-generic-function ztesch 41E001C3FC>.
;; メソッドの実装
(defmethod ztesch ((q quux))
(with-slots (a b c) q
(setq a 0 b 1 c 2))
q)
(defmethod bazola ((x integer) (y quux))
(with-slots (a b c) y
(* x (+ a b c))))
;; インスタンス化できた
(bazola 10 (ztesch (make-instance 'quux)))
→ 30
まとめ
今回は抽象クラスとメソッド実装の強制を別々に定義してメタクラスのmixinとしました。
メソッド実装が強制されるという感覚にいま一つ馴染がないのですが、Common Lispにどうなるのが正しいのかは色々コードを書いてみないと分からなさそうです……。
■
HTML generated by 3bmd in LispWorks 7.0.0
allocate-instanceがCLtL2で定義されていない謎
Posted 2020-12-13 17:11:41 GMT
allocate-instance Advent Calendar 2020 14日目の記事です。
折り返しを過ぎましたが、完全にネタ切れなのでallocate-instanceでウェブを検索したりしていますが、allocate-instance関係で以前から不思議に思っていたことを思い出したので調べてみました。
allocate-instanceがCLtL2に定義されていない
そもそも、CLtL2(Common Lisp the Language 2nd Ed.)は、ANSI Common Lisp規格成立までの中間報告書なので、ANSI CL規格からみて不備があってもしょうがないのですが、CLtL2中にはallocate-instanceの名前だけは出現するものの、項目を立てて定義が解説されてはいません。
この辺りが謎だったのですが、どうも単純に考慮漏れだったようで、CLtL2の出版時まで、処理系内部の関数なのか外部APIなのかで揺れていたようです。
オブジェクトをアロケートする手続きはどんな処理系でも備えているのは確かなのですが、外部API仕様として確立する必要が出たのは、make-load-formでユーザー定義の手続きの中にallocate-instanceを含まざるを得ないことが判明したからだったようです。
また、ANSI規格のallocate-instanceにstructure-classの定義があるのが謎だったのですが、これもmake-load-formの為だと考えれば納得です。
まとめ
いつもながらANSI CLは細かいところまで良く考えられていると感心します。 また、CLtL2はANSI CL規格の補助資料として参照するに留めるのが吉だと改めて思いました(が人気の根強いことよ)
参考
■
HTML generated by 3bmd in LispWorks 7.0.0
隠しスロットで再帰的な属性付きスロット
Posted 2020-12-12 18:31:25 GMT
allocate-instance Advent Calendar 2020 13日目の記事です。
今回もECLOSの拡張のアイデアが元ネタですが、ECLOSにはattributed-classという再帰的な属性を持つクラスが紹介されているので、属性を隠しスロットに格納するという方法で定義してみました。
- 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
動作
実際のECLOSのattributed-classがどういう仕様と実装になっているかは資料が少なく良く分からないのですが、どうもスロットも属性も同じ構造を持つようです。
そうなると、属性の方に再帰的に定義クラスのオブジェクトを詰めれば良さそう、ということで、defclassのスロット定義に再帰的にdefclassの定義を詰めてみることにしました。
割と安直ですが、ECLOSの挙動も大体一緒なので実際にこういう構成かもしれません。
(defclass foo (attributed-object)
((x :initform 'x
:attributes
((a :initform 'a
:attributes
((u :initform "u")))
(b :initform (list 0 1))
c))
(y :initform 'y))
(:metaclass attributed-class)
(:default-attributes
((da :initform 'unknown))))
(let ((obj (make-instance 'foo)))
`((,(slot-value obj 'x)
(list ,(slot-value (slot-attribute obj 'x) 'a)
,(slot-value (slot-attribute (slot-attribute obj 'x) 'a) 'u))
,(slot-value (slot-attribute obj 'x) 'b))
,(list (slot-value obj 'y)
(slot-value (slot-attribute obj 'y) 'da))))
→ ((x (list a "u") (0 1)) (y unknown))
(attribute-value (make-instance 'foo) 'x 'a 'u)
→ "u"
実装
(defpackage "0003c1b3-31ed-5d6d-b58a-6d45c62acc5c"
(:use c2cl slotted-objects))
(cl:in-package "0003c1b3-31ed-5d6d-b58a-6d45c62acc5c")
(defclass attributed-class (slotted-class)
((default-attributes :initform 'nil
:initarg :default-attributes
:accessor class-default-attributes))
(:metaclass standard-class))
(defmethod allocate-instance ((class attributed-class) &rest initargs)
(allocate-slotted-instance (class-wrapper class)
(make-array `(2 ,(length (class-slots class)))
:initial-element (make-unbound-marker))))
(defclass attributed-object (slotted-object)
()
(:metaclass attributed-class))
(defun find-named-slot-using-class (class slot-name &optional (no-error-p nil))
#+lispworks
(flet ((wrapper-slot-names (wrapper)
(elt wrapper 4)))
(let ((wrapper (class-wrapper class))
(pos nil))
(cond ((setq pos (position slot-name (elt wrapper 1)))
(elt (wrapper-slot-names wrapper) pos))
(no-error-p nil)
(T (error "~A is not the name of a slotd." slot-name)))))
#-(or lispworks)
(cond ((loop :for slotd :in (class-slots class)
:thereis (and (eq slot-name (slot-definition-name slotd))
slotd)))
(no-error-p nil)
(t (error "~A is not the name of a slotd." slot-name))))
(defconstant slot-dim 0)
(defconstant attribute-dim 1)
(defmethod slot-value-using-class ((class attributed-class) instance (slotd slot-definition))
(aref (instance-slots instance)
slot-dim
(slot-definition-location slotd)))
(defmethod (setf slot-value-using-class) (value (class attributed-class) instance (slotd slot-definition))
(setf (aref (instance-slots instance)
slot-dim
(slot-definition-location slotd))
value))
(defgeneric slot-attribute-using-class (class instance slotd))
(defmethod slot-attribute-using-class ((class attributed-class) instance (slotd slot-definition))
(aref (instance-slots instance)
attribute-dim
(slot-definition-location slotd)))
(defgeneric (setf slot-attribute-using-class) (val class instance slotd))
(defmethod (setf slot-attribute-using-class) (value (class attributed-class) instance (slotd slot-definition))
(setf (aref (instance-slots instance)
attribute-dim
(slot-definition-location slotd))
value))
(defun slot-attribute (instance slot-name)
(let ((class (class-of instance)))
(slot-attribute-using-class class
instance
(find-named-slot-using-class class slot-name))))
(defun (setf slot-attribute) (value instance slot-name)
(let ((class (class-of instance)))
(setf (slot-attribute-using-class class
instance
(find-named-slot-using-class class slot-name))
value)))
(defclass attributed-slot-definition (standard-slot-definition)
((attributes :initform nil
:initarg :attributes
:accessor attributed-slot-definition-attributes)))
(defclass direct-slot/attribute-definition (standard-direct-slot-definition attributed-slot-definition)
())
(defmethod direct-slot-definition-class ((class attributed-class) &rest initargs)
(find-class 'direct-slot/attribute-definition))
#+lispworks
(defmethod clos:process-a-slot-option ((class attributed-class) option value
already-processed-options slot)
(if (eq option :attributes)
(list* :attributes
`(let ((c (defclass ,(gensym (format nil
"ATTRIBUTED-CLASS.A-"
(string (car slot))))
(attributed-object)
,value
(:metaclass attributed-class))))
(finalize-inheritance c)
c)
already-processed-options)
(call-next-method)))
#+lispworks
(defmethod clos:process-a-class-option ((class attributed-class)
(name (eql :default-attributes))
value)
(unless (and value (null (cdr value)))
(error "attributed-class :default-attributes must have a single value."))
(list name
`(let ((c (defclass ,(gensym "DEFAULT-ATTRIBUTES-") (attributed-object)
,(car value)
(:metaclass attributed-class))))
(finalize-inheritance c)
c)))
(defclass effective-slot/attribute-definition (standard-effective-slot-definition attributed-slot-definition)
())
(defmethod effective-slot-definition-class
((class attributed-class) &rest initargs)
(find-class 'effective-slot/attribute-definition))
(defmethod compute-effective-slot-definition ((class attributed-class)
name
direct-slot-definitions)
(let ((effective-slotd (call-next-method)))
(dolist (slotd direct-slot-definitions)
(when (typep slotd 'attributed-slot-definition)
(setf (attributed-slot-definition-attributes effective-slotd)
(attributed-slot-definition-attributes slotd))
(return)))
effective-slotd))
(defmethod shared-initialize :after ((instance attributed-object) slot-names &rest initargs)
(let* ((class (class-of instance))
(slots (class-slots class))
(default-attributes (class-default-attributes class)))
(dolist (s slots)
(let ((attr (attributed-slot-definition-attributes s)))
(if attr
(setf (slot-attribute-using-class class instance s)
(make-instance (attributed-slot-definition-attributes s)))
(and default-attributes
(setf (slot-attribute-using-class class instance s)
(make-instance default-attributes))))))))
(defun attribute-value (instance &rest names)
(let ((ans instance))
(mapl (lambda (n)
(if (cdr n)
(setq ans (slot-attribute ans (car n)))
(setq ans (slot-value ans (car n)))))
names)
ans))
まとめ
スロットの方で再帰的に展開させるとXMLみたいな感じでしょうか。
DOMの表現はノードと属性とで別クラスになっていることが多いですが、attributed-classのようなクラスであれば一本化できそうです。
■
HTML generated by 3bmd in LispWorks 7.0.0
ファイルなスロット
Posted 2020-12-12 12:27:46 GMT
allocate-instance Advent Calendar 2020 12日目の記事です。
アドベントカレンダー折り返し地点で既にネタがブチ切れなのですが、どうにかネタを捻り出していきたいと思います。
今回は、スロットのストレージをOSのファイルとして読み書きしてみることにしました。
“objstore”ディレクトリの直下がクラス名、次にインスタンスのディレクトリがあり、その直下にスロットのファイルが配置されます。
アロケートのタイミングでファイルの読み書きをしなくても、スロットの読み書きでフックをかければ似たようなことはできるのですが、ファイルの確保はallocate-instanceが担当する方が素直かなと思いました。
一応論理パスを利用してファイル名との直接のマッピングは避けています。
非常に簡易的な永続化の方法ですが、案外使えるかも?
実装
(defpackage "8a202ea6-99d1-523d-969b-dbf5fb19ffa5"
(:use c2cl slotted-objects))
(cl:in-package "8a202ea6-99d1-523d-969b-dbf5fb19ffa5")
(setf (logical-pathname-translations "objstore")
`(("**;*.*.*" "/tmp/**/*.*")))
(defclass file-slots-class (slotted-class) ())
(defclass file-slots-objects (slotted-object)
()
(:metaclass file-slots-class))
(defun openo (path)
(open path
:direction :output
:if-does-not-exist :create
:if-exists :supersede))
(defmethod allocate-instance ((class file-slots-class) &rest initargs)
(allocate-slotted-instance (class-wrapper class)
(let* ((instance-name (gensym (string (class-name class))))
(files (mapcar (lambda (s)
(ensure-directories-exist
(make-pathname :host "objstore"
:directory
`(:absolute ,(string (class-name class)) ,(string instance-name))
:name (string (slot-definition-name s)))))
(class-slots class))))
(dolist (f files files)
(with-open-stream (out (openo f))
(print nil out))))))
(defmethod slot-value-using-class ((class file-slots-class) instance (slotd slot-definition))
(with-open-file (in (elt (instance-slots instance) (slot-definition-location slotd)))
(read in)))
(defmethod (setf slot-value-using-class) (value (class file-slots-class) instance (slotd slot-definition))
(with-open-stream (out (openo (elt (instance-slots instance) (slot-definition-location slotd))))
(print value out)
(terpri out)
value))
動作
(defclass foo (file-slots-objects)
((a :initform 0)
(b :initform 1)
(c :initform 2))
(:metaclass file-slots-class))
(defclass bar (foo)
((d :initform 3))
(:metaclass file-slots-class))
(let ((obj (make-instance 'bar)))
(setf (slot-value obj 'd)
"こんにちは"))
$ ls /tmp/bar
bar17928740$ cat /tmp/bar/*/*
0
1
2
"こんにちは"
■
HTML generated by 3bmd in LispWorks 7.0.0
隠しスロットで遅延初期化なスロット
Posted 2020-12-10 17:54:31 GMT
allocate-instance Advent Calendar 2020 11日目の記事です。
このブログで度々取り上げているECLOSというMOPの拡張にlazy-classという初期化をアクセス時まで遅延させる機能があるのですが、今回はこの遅延初期化を二次元配列で実装してみようと思います。
- 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
遅延初期化の仕様
(defclass foo (lazy-init-object)
((a :initform 0 :initialization :read)
(b :initform 1 :initialization :access)
(c :initform 2))
(:metaclass lazy-init-class))こんな感じに:initializationでスロット読み取り時(:read)や、スロット更新時(:access)が指定された場合、その時まで初期化は遅延されます。
本家ECLOSでは、さらにスロット間の初期化順序の関係性を記述することが可能ですが、論文の記述だけだと若干挙動が不明なのと、かなり複雑になるので、今回は初期化タイミングの機能に絞ります。
実装
今回実装した遅延の仕組みは非常に単純で、二次元配列で隠しスロットを付加し、そこに初期化関数のクロージャーを詰め、指定のタイミングで呼び出すだけです。
詰め込みにはshared-initializeを使いますが、安易にshared-initializeの中でslot-value-using-classを呼ぶと無限ループするので注意しましょう。自分はこのパターンを良くやってしまいます(自分だけか)
大したことはしていないのですが、スロットにオプションを追加すると長くなります……。
(defpackage "2fa9989a-2db4-50b0-953d-4285ca2aaa88"
(:use c2cl slotted-objects))
(cl:in-package "2fa9989a-2db4-50b0-953d-4285ca2aaa88")
(defclass lazy-init-class (slotted-class)
())
#+lispworks
(defmethod clos:process-a-slot-option
((class lazy-init-class) option value already-processed-options slot)
(if (eq option :initialization)
(list* :initialization value already-processed-options)
(call-next-method)))
(defclass lazy-init-object (slotted-object)
()
(:metaclass slotted-class))
(defconstant slot-dim 0)
(defconstant init-dim 1)
(defmethod allocate-instance ((class lazy-init-class) &rest initargs)
(declare (ignore initargs))
(allocate-slotted-instance (class-wrapper class)
(make-array `(2 ,(length (class-slots class)))
:initial-element (make-unbound-marker))))
(defclass lazy-init-slot-definition (slot-definition)
((initialization :initform nil
:accessor slot-definition-initialization
:initarg :initialization)))
(defclass lazy-init-direct-slot-definition (standard-direct-slot-definition lazy-init-slot-definition)
())
(defmethod direct-slot-definition-class ((class lazy-init-class) &rest initargs)
(find-class 'lazy-init-direct-slot-definition))
(defclass lazy-init-effective-slot-definition (standard-effective-slot-definition lazy-init-slot-definition)
())
(defmethod effective-slot-definition-class ((class lazy-init-class) &rest initargs)
(find-class 'lazy-init-effective-slot-definition))
(defmethod compute-effective-slot-definition ((class lazy-init-class) name direct-slot-definitions)
(declare (ignore name))
(let ((eslotd (call-next-method)))
(dolist (dslotd direct-slot-definitions)
(when (typep dslotd (find-class 'lazy-init-slot-definition))
(setf (slot-definition-initialization eslotd)
(slot-definition-initialization dslotd))))
eslotd))
(defmethod initialize-slot-from-initarg ((class lazy-init-class) instance slotd initargs)
(let ((slot-initargs (slot-definition-initargs slotd)))
(loop :for (initarg value) :on initargs :by #'cddr
:do (when (member initarg slot-initargs)
(setf (aref (instance-slots instance) slot-dim (slot-definition-location slotd))
value)
(return T)))))
(defmethod initialize-slot-from-initfunction ((class lazy-init-class) instance slotd)
(let ((initfun (slot-definition-initfunction slotd)))
(unless (not initfun)
(setf (aref (instance-slots instance) slot-dim (slot-definition-location slotd))
(funcall initfun)))))
(defmethod shared-initialize ((instance lazy-init-object) slot-names &rest initargs)
(let* ((class (class-of instance))
(slotds (class-slots class)))
(dolist (slotd slotds)
(setf (aref (instance-slots instance) init-dim (slot-definition-location slotd))
(lambda ()
(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))))))
;; eager init
(dolist (slotd slotds)
(when (null (slot-definition-initialization slotd))
(let ((slots (instance-slots instance))
(loc (slot-definition-location slotd)))
(funcall (aref slots init-dim loc))
(setf (aref slots init-dim loc) nil)))))
instance)
(defmethod slot-value-using-class ((class lazy-init-class) instance (slotd slot-definition))
(let ((loc (slot-definition-location slotd))
(slots (instance-slots instance)))
(case (slot-definition-initialization slotd)
((:read)
(when (aref slots init-dim loc)
(funcall (aref slots init-dim loc))
(setf (aref slots init-dim loc) nil)))
(otherwise nil))
(aref slots slot-dim loc)))
(defmethod (setf slot-value-using-class) (value (class lazy-init-class) instance (slotd slot-definition))
(let ((loc (slot-definition-location slotd))
(slots (instance-slots instance)))
(case (slot-definition-initialization slotd)
((:read :access)
(when (aref slots init-dim loc)
(funcall (aref slots init-dim loc))
(setf (aref slots init-dim loc) nil)))
(otherwise nil))
(setf (aref slots slot-dim loc) value)))
動作
(defclass foo (lazy-init-object)
((a :initform 0 :initialization :read)
(b :initform 1 :initialization :access)
(c :initform 2))
(:metaclass lazy-init-class))
(let ((obj (make-instance 'foo)))
(instance-slots obj)) ;スロットデータの中身を覗いてみる
→
#2A((#<Slot Unbound Marker> #<Slot Unbound Marker> 2)
(#<Closure 1 subfunction of (method shared-initialize (lazy-init-object t)) 4060013B14>
#<Closure 1 subfunction of (method shared-initialize (lazy-init-object t)) 4060013B3C>
#<Closure 1 subfunction of (method shared-initialize (lazy-init-object t)) 4060013B64>))
(let ((obj (make-instance 'foo)))
(with-slots (a b c) obj a b c)
(instance-slots obj))
→
#2A((0 #<Slot Unbound Marker> 2)
(nil #<Closure 1 subfunction of (method shared-initialize (lazy-init-object t)) 406001227C> nil)) ; :read で初期化された
(let ((obj (make-instance 'foo)))
(with-slots (a b c) obj
a
(setq b 42)
c)
(instance-slots obj))
→
#2A((0 42 2) (nil nil nil)) ; :readと:access で初期化された
まとめ
スロット初期化の遅延ですが、個人的には遅延させたい局面に遭遇したことがないので、いまいちぴんと来ません。大きなリソースを割り付けたい場合などにはできるだけ遅延させると効率が良いのかも。
メタクラスの定義やスロット定義では似たようなものを毎度書くので、defmetaclassのようなものを定義して使っている人もいます。
Eric L. Peterson氏のdefmetaclassは、なかなか良い圧縮具合と使い勝手っぽいので真似してみたいところですが、全部のパターンがマクロで上手く纏められるかというと、そうでもないのがなんとも悩ましい。
参考
■
HTML generated by 3bmd in LispWorks 7.0.0
コンパクトなスロットの紹介
Posted 2020-12-09 17:04:47 GMT
allocate-instance Advent Calendar 2020 10日目の記事です。
毎度ネタ切れになると、先人の活用事例を参考にしたりライブラリ紹介をしたりしていますが、allocate-instanceに限っては、ほとんど事例がない様子。
メソッドコンビネーションでさえそこそこ事例はあったのに……。
とはいえ、とりあえず一つは見付けたので、そちらの紹介をしてみます。
しかし、どうも実験的なものらしく、プロジェクトのゴミ箱フォルダに入っています。
compact-class
今回紹介するのは、いつも妙なものを作っているhu.dwimの皆さんのhu.dwim.utilの中のcompact-classです。
スロット内容をコンパクトな表現に変換するようですが、とりあえず動作を説明すると、
(defclass foo ()
((a :initform nil :allocation :compact :type boolean)
(b :initform nil :allocation :compact :type boolean)
(c :initform nil :allocation :compact :type boolean)
(d :initform nil :allocation :compact :type boolean))
(:metaclass compact-class))(let ((obj (make-instance 'foo)))
(setf (slot-value obj 'a) T)
(setf (slot-value obj 'b) T)
(with-slots (a b c d) obj
(list a b c d
(instance-slots obj))))
→ (t t nil nil #(3))
—のように:allocation :compactを指定するとboolean型のスロット群の(t t nil nil)のコンパクトな表現として、#(3)が格納されます。
(t t nil nil) 反転→ (nil nil t t) → #b0011 → 3
という具合になります。
対応している型と圧縮/解凍の手順ですが、スロットのリーダー/ライターの関数を生成する部分に書いてあります。
ちなみに、SBCLに特化した記述になっていますが、現在のSBCLでは動かないようです。
(def function make-compact-slot-reader (slot)
(bind ((compact-word-offset (compact-word-offset-of slot))
(compact-bits-offset (compact-bits-offset-of slot))
(compact-bit-size (compact-bit-size-of slot))
(type (slot-definition-type slot)))
(declare (type (integer 0 #.(integer-length most-positive-fixnum)) compact-bit-size compact-bits-offset)
(type fixnum compact-word-offset))
(flet ((%slot-value (instance)
(declare #.(optimize-declaration))
(the fixnum (ldb (byte compact-bit-size compact-bits-offset)
(the fixnum (standard-instance-access instance compact-word-offset))))))
(declare (inline %slot-value))
(cond ((subtypep type 'boolean)
(lambda (instance)
(declare #.(optimize-declaration))
(= (%slot-value instance) 1)))
((subtypep type 'integer)
(lambda (instance)
(declare #.(optimize-declaration))
(%slot-value instance)))
((subtypep type 'base-char)
(lambda (instance)
(declare #.(optimize-declaration))
(code-char (%slot-value instance))))
((subtypep type 'single-float)
(lambda (instance)
(declare #.(optimize-declaration))
#+sbcl (sb-vm::make-single-float (%slot-value instance))))
((and (subtypep type 'simple-base-string)
(consp type))
(lambda (instance)
(declare #.(optimize-declaration))
(iter (with value = (%slot-value instance))
(with string = (make-string (second type)))
(for index :from 0 :below (the fixnum (second type)))
(for position :initially 0 :then (+ 7 position))
(declare (type fixnum index position))
(setf (aref string index) (code-char (ldb (byte 7 position) value)))
(finally (return string)))))
(t
(aif (type-instance-count-upper-bound type)
(bind ((instance-list (type-instance-list type)))
(lambda (instance)
(elt instance-list (%slot-value instance))))
(error "Unknown compact type ~A" type)))))))まとめ
今回は、hu.dwim.utilのcompact-classを紹介してみました。
結構アグレッシブで面白いと思います。
■
HTML generated by 3bmd in LispWorks 7.0.0
多次元配列で隠しスロット
Posted 2020-12-09 01:04:00 GMT
allocate-instance Advent Calendar 2020 9日目の記事です。
以前、初期MOPの文献で、隠しスロットの実例としてスロットにfacetをつけるというのを紹介しましたが、こちらの例では隠しスロットは、本スロットと交代の並びで追加されるので、本スロットの位置×2で位置を求めたりしていました。
しかし、ストレージを一次元配列ではなく、多次元配列にしてしまえば、値のインデックスはそのままで指定の次元アクセスすれば対応した場所にアクセスできて便利なのではないかと思ったので、試してみました。
(defpackage "493c1b0d-ff75-5a3a-9872-43d488f33914"
(:use c2cl slotted-objects))
(in-package "493c1b0d-ff75-5a3a-9872-43d488f33914")
(defclass faceted-slot-class (slotted-class)
())
(defclass faceted-slot-object (slotted-object)
()
(:metaclass faceted-slot-class))
(defconstant slot-dim 0)
(defconstant facet-dim 1)
(defmethod allocate-instance ((class faceted-slot-class) &rest initargs)
(declare (ignore initargs))
(allocate-slotted-instance (class-wrapper class)
(make-array `(2 ,(length (class-slots class)))
:initial-element (make-unbound-marker))))
(defmethod slot-value-using-class ((class faceted-slot-class) instance (slotd slot-definition))
(aref (instance-slots instance) slot-dim (slot-definition-location slotd)))
(defmethod (setf slot-value-using-class) (value (class faceted-slot-class) instance (slotd slot-definition))
(setf (aref (instance-slots instance) slot-dim (slot-definition-location slotd))
value))
(defun facet-missing (instance facet-name)
(error "The facet ~S is missing from the object ~S" facet-name instance))
(defun slot-facet (instance slot-name)
(aref (instance-slots instance)
facet-dim
(slot-definition-location
(or (find slot-name (class-slots (class-of instance)) :key #'slot-definition-name)
(facet-missing instance slot-name)))))
(defun (setf slot-facet) (value instance slot-name)
(setf (aref (instance-slots instance)
facet-dim
(slot-definition-location
(or (find slot-name (class-slots (class-of instance)) :key #'slot-definition-name)
(facet-missing instance slot-name))))
value))
動作
(defclass zot (faceted-slot-object)
((a :initform 42)
(b :initform 43)
(c :initform 44))
(:metaclass faceted-slot-class))(describe (make-instance 'zot))
⇒
#<zot 41601B9CD3> is a zot
a 42
b 43
c 44
;;; facetに値を設定
(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)
(mapcar (lambda (s)
(list (slot-value o s)
(slot-facet o s)))
'(a b c)))
→ ((42 facet-a) (43 facet-b) (44 facet-c))
まとめ
やはりスロットに一対一で対応するような隠しスロットには一本のベクタで配置を工夫するよりは、多次元配列の方が安直に実装できます。
スロットにフラグを持たせる場所としては便利そうですが、さて実用的にはどうなのか……。
■
HTML generated by 3bmd in LispWorks 7.0.0
CODASYLなインスタンス
Posted 2020-12-07 18:39:35 GMT
allocate-instance Advent Calendar 2020 8日目の記事です。
allocate-instanceでカスタマイズしたいような場面について考えていますが、
- インスタンスに隠しスロットのような付加情報を持たせたいが、付加情報は外のAPIからは見えて欲しくない
- アロケートする場所を工夫したい(空間効率etc)
- (外部API的には)余計なスロットを追加しないでインスタンス群を組織化したい
あたりがある気がしていますが、今回は、インスタンス群の組織化で考えてみたいと思います。
CODASYL Set
論理・代数・データベースという本を読んでいて、昔のデータベースの構成方法にCODASYL Setというのがあることを知ったのですが、これはナビゲーショナルデータベースや、ネットワーク型データモデルの先駆けらしいです。
親子関係にあるオブジェクトでリンクトリストを作る感じですが、インスタンス群を組織化するのに隠しスロットが使えそうなので試してみましょう。
オブジェクトはownerとmemberに分かれ、ownerが作る循環リストにメンバーが接続していくという感じです。
CODASYL Setのシンプルな構成は、循環する一方向リストですが、追加や検索の便宜を図ってownerへのポインタと前後のポインタを持つことが多いそうなので、そういう構成で書いてみます。
(defpackage "c247a8da-b119-500b-b556-47ff40b1347a"
(:use c2cl slotted-objects))
(in-package "c247a8da-b119-500b-b556-47ff40b1347a")
(defclass codasyl-class (slotted-class)
((owner :accessor codasyl-class-owner :initform nil :initarg :owner)))
#+lispworks
(defmethod clos:process-a-class-option ((class codasyl-class) (name (eql :owner)) value)
(unless (and value (null (cdr value)))
(error "codasyl-class: :owner must have a single value."))
`(,name ,(car value)))
(defclass codasyl-object (slotted-object)
()
(:metaclass codasyl-class))
(defclass codasyl-element ()
((slots :accessor codasyl-element-slots :initarg :slots)
(owner :accessor codasyl-element-owner :initarg :owner :initform nil)
(next :accessor codasyl-element-next :initform nil)
(prev :accessor codasyl-element-prev :initform nil)))
(defmethod allocate-instance ((class codasyl-class) &rest initargs)
(let* ((slots (make-instance 'codasyl-element
:slots (make-sequence 'vector
(length (class-slots class))
:initial-element (make-unbound-marker))))
(instance (allocate-slotted-instance (class-wrapper class) slots)))
(setf (codasyl-element-owner slots) instance)
(setf (codasyl-element-prev slots) instance)
(setf (codasyl-element-next slots) instance)
instance))
(defmethod slot-value-using-class ((class codasyl-class) instance (slotd slot-definition))
(elt (codasyl-element-slots (instance-slots instance))
(slot-definition-location slotd)))
(defmethod (setf slot-value-using-class) (value (class codasyl-class) instance (slotd slot-definition))
(setf (elt (codasyl-element-slots (instance-slots instance))
(slot-definition-location slotd))
value))
(defun find-last-codasyl-element (owner)
(loop :for elt := (codasyl-element-next (instance-slots owner)) :then (codasyl-element-next (instance-slots elt))
:when (eq (codasyl-element-next (instance-slots elt)) owner)
:return elt))
(defmethod initialize-instance :after ((instance codasyl-object) &rest initargs)
(let ((slot-data (instance-slots instance)))
(let ((default-owner (codasyl-element-owner slot-data))
(new-owner (codasyl-class-owner (class-of instance))))
;; if instance is member type
(and (codasyl-class-owner (class-of instance))
(unless (eq default-owner new-owner)
;; set the new owner
(setf (codasyl-element-owner slot-data) new-owner)
(let ((last (find-last-codasyl-element (codasyl-element-owner slot-data))))
;; concatenate the new member
(setf (codasyl-element-prev slot-data) last)
(setf (codasyl-element-next (instance-slots last)) instance)
(setf (codasyl-element-next slot-data) new-owner)))))))
(defun walk-codasyl-members (owner fn)
(loop :for e := (codasyl-element-next (instance-slots owner)) :then (codasyl-element-next (instance-slots e))
:until (eq e owner)
:do (funcall fn e)))
(defun map-codasyl-members (owner fn)
(loop :for e := (codasyl-element-next (instance-slots owner)) :then (codasyl-element-next (instance-slots e))
:until (eq e owner)
:collect (funcall fn e)))
循環構造を作るので無駄に長くなりました……。
試してみる
(defclass owner-foo (codasyl-object)
((a :initform 0)
(b :initform 1)
(c :initform 2))
(:metaclass codasyl-class))
(defclass member-foo (codasyl-object)
((a :initform 0)
(b :initform 1)
(c :initform 2))
(:metaclass codasyl-class)
(:owner (class-prototype (find-class 'owner-foo))))
;; 10個生成する
(dotimes (i 10)
(make-instance 'member-foo))
;;
(map-codasyl-members (codasyl-class-owner (find-class 'member-foo))
(lambda (m)
(with-slots (a b c) m
(list a b c))))
→ ((0 1 2) (0 1 2) (0 1 2) (0 1 2) (0 1 2) (0 1 2) (0 1 2) (0 1 2) (0 1 2) (0 1 2))
まとめ
1970年代のリソース環境では、循環リストにする価値はあったんだと思いますが、普通のリストにすれば結構単純化できそうです。
要素を別途リストで管理すれば良いのですが、今回のポイントは要素内に隠しスロットで前後および親へのポインタを持つということでしょうか。
Linuxのリスト実装の構造体のトリックがありますが、今回のようなクラスを定義してmixinして使うとリストが作れる的なクラスも実現できたりしそうです。
参考
■
HTML generated by 3bmd in LispWorks 7.0.0
スロット付きオブジェクトのデータ構造について考える
Posted 2020-12-06 21:21:25 GMT
allocate-instance Advent Calendar 2020 7日目の記事です。
これまで、allocate-instanceで確保するストレージをスロット付きオブジェクトというところまで拡大して、データ構造を差し替えたりしてみましたが、現時点で考え付くものをまとめてみたいと思います(ネタ切れともいう)
今回も共通の処理は、slotted-objectsにまとめたものを利用します。
(defpackage "e718761d-aab2-548a-aa32-d3ba5e48b3ce"
(:use c2cl slotted-objects))(in-package "e718761d-aab2-548a-aa32-d3ba5e48b3ce")
シンボルをストレージにする
先日も似たようなことをやっていましたが、symbol-plistをストレージにしたらどうかという試みです。
(defclass symbol-class (slotted-class)
())
(defclass symbol-object (slotted-object)
()
(:metaclass symbol-class))
(defmethod allocate-instance ((class symbol-class) &rest initargs)
(let ((sym (gentemp (string (class-name class)))))
(setf (symbol-plist sym)
(mapcan (lambda (s)
(list s (make-unbound-marker)))
(class-slots class)))
(allocate-slotted-instance (class-wrapper class)
sym)))
(defmethod slot-value-using-class ((class symbol-class) instance (slotd slot-definition))
(get (instance-slots instance) slotd))
(defmethod (setf slot-value-using-class) (value (class symbol-class) instance (slotd slot-definition))
(setf (get (instance-slots instance) slotd)
value))
(defclass symbol-foo (symbol-object)
((a :initform 0)
(b :initform 1)
(c :initform 2))
(:metaclass symbol-class))
シンボルはplistだけを利用するのですが、インスタンスをシンボルの値にするの方が色々応用がききそうです。
(let ((obj (make-instance 'symbol-foo)))
(set (instance-slots obj) obj)
(instance-slots obj))
→ symbol-foo4symbol-foo4
→ #<symbol-foo 4020099DF3>
(symbol-plist 'symbol-foo4)
→
(#<standard-effective-slot-definition a 42202D39D3>
0
#<standard-effective-slot-definition b 42202D4B93>
1
#<standard-effective-slot-definition c 42202D4D2B>
2)
(incf (slot-value symbol-foo4 'a) 100)
→ 100
(symbol-plist 'symbol-foo4)
→
(#<standard-effective-slot-definition a 42202D39D3>
100
#<standard-effective-slot-definition b 42202D4B93>
1
#<standard-effective-slot-definition c 42202D4D2B>
2)
alist、plistをストレージにする
(defclass alist-class (slotted-class)
())
(defclass alist-object (slotted-object)
()
(:metaclass alist-class))
(defmethod allocate-instance ((class alist-class) &rest initargs)
(allocate-slotted-instance (class-wrapper class)
(mapcar (lambda (s)
(cons s (make-unbound-marker)))
(class-slots class))))
(defmethod slot-value-using-class ((class alist-class) instance (slotd slot-definition))
(cdr (assoc slotd (instance-slots instance))))
(defmethod (setf slot-value-using-class)
(value (class alist-class) instance (slotd slot-definition))
(setf (cdr (assoc slotd (instance-slots instance)))
value))
(defclass alist-foo (alist-object)
((a :initform 0)
(b :initform 1)
(c :initform 2))
(:metaclass alist-class))
構造が似ているだけに、シンボルのplistと大差ありません。
シンボルのplistやリストをオブジェクトと連携させた際の応用としては、古えのAIプログラム等は、シンボルのplistやリスト操作を駆使したものが多いので、そういうリストとシンボルの塊のプログラムにマッピングをして見通しの良いプログラムに段階的に変換したりするのに使えたりするかもしれません。
(let ((obj (make-instance 'alist-foo)))
(incf (slot-value obj 'c) 100)
(instance-slots obj))
→
((#<standard-effective-slot-definition a 402019DFB3> . 0)
(#<standard-effective-slot-definition b 402019E01B> . 1)
(#<standard-effective-slot-definition c 402019E083> . 102)) ハッシュテーブルをストレージにする
ハッシュテーブルをストレージにするのは先日試しました
データ効率向上以外の応用としては、クロージャー+ハッシュテーブルなプログラムをクラスを利用したものに変換するのに使えたりするかもしれません。
標準的でないベクタ構成をストレージにする
AoS
AoSな構成については先日書きました。
1990年代のMOPの応用例の考察として、LispマシンにあったAREAというGC対象外の手動でメモリ管理する領域にインスタンスのストレージを確保する、というのがちょくちょく出てきます。
大きい配列をそのような領域に確保するという目的には丁度良いかもしれません。
SoA
AoSの逆のSoAについてはAoSと似たような応用が考えられますが、配列要素にガッチリ型を指定可能なので、型検査のメリットを活かすスロットの一つの実現方法としてSoAを利用するというのもありかなと思ったりしています。
構造体をストレージにする
(defclass struct-class (slotted-class)
())
(defmethod ensure-class-using-class :before ((class struct-class) name &rest initargs)
(eval `(defstruct ,(intern (concatenate 'string (string (class-name class)) (string '-struct)))
,@(mapcar (lambda (s)
(list (slot-definition-name s) (make-unbound-marker)))
(class-slots class)))))
(defclass struct-object (slotted-object)
()
(:metaclass struct-class))
(defmethod allocate-instance ((class struct-class) &rest initargs)
(allocate-slotted-instance (class-wrapper class)
(funcall (fdefinition
(intern
(concatenate 'string
(string 'make-)
(string (class-name class))
(string '-struct)))))))
(defmethod slot-value-using-class ((class struct-class) instance (slotd slot-definition))
(slot-value (instance-slots instance) (slot-definition-name slotd)))
(defmethod (setf slot-value-using-class) (value (class struct-class) instance (slotd slot-definition))
(setf (slot-value (instance-slots instance) (slot-definition-name slotd))
value))
(defclass struct-foo (struct-object)
((a :initform 0)
(b :initform 1)
(c :initform 2))
(:metaclass struct-class))
段々屋上屋っぽくなってきましたが、これも既存の構造体メインで構築したプログラムを、段階的に徐々に変換するのに使えたりもすかもしれません(上例ではクラス定義時に構造体を定義していますが)
(let ((obj (make-instance 'struct-foo)))
(incf (slot-value obj 'c) 100)
(instance-slots obj))
→ #S(struct-foo-struct :a 0 :b 1 :c 102) オブジェクトをストレージにする
(defclass class-class (slotted-class)
())
(defmethod ensure-class-using-class :before ((class class-class) name &rest initargs &key direct-slots)
(ensure-class-using-class (find-class 'standard-class)
(intern (concatenate 'string (string name) (string '-storage)))
:direct-slots direct-slots))
(defclass class-object (slotted-object)
()
(:metaclass class-class))
(defmethod allocate-instance ((class class-class) &rest initargs)
(allocate-slotted-instance (class-wrapper class)
(make-instance (intern (concatenate 'string
(string (class-name class))
(string '-storage))))))
(defmethod slot-value-using-class ((class class-class) instance (slotd slot-definition))
(slot-value (instance-slots instance) (slot-definition-name slotd)))
(defmethod (setf slot-value-using-class) (value (class class-class) instance (slotd slot-definition))
(setf (slot-value (instance-slots instance) (slot-definition-name slotd))
value))
完全に屋上屋ですが、既存の定義をニコイチにしてスロット名をつけかえたりできるかもしれません。
(defclass class-foo (class-object)
((a :initform 0)
(b :initform 1)
(c :initform 2))
(:metaclass class-class))(let ((obj (make-instance 'class-foo)))
(incf (slot-value obj 'c) 100)
(describe (instance-slots obj)))
⇒
#<class-foo-storage 40200BA7F3> is a class-foo-storage
a 0
b 1
c 102
まとめ
当初の計画ではデータ構造ごとにエントリーを書いていればallocate-instanceアドベントカレンダーの25日間はしのげるかなと思ったのですが、話が広げられないので今回一つにまとめて書いてしまいました。
あと18ネタをどう捻り出すか……。
■
HTML generated by 3bmd in LispWorks 7.0.0
Tiny CLOS MOPが本家CLOS MOPの進化版だった件
Posted 2020-12-05 23:00:44 GMT
allocate-instance Advent Calendar 2020 6日目の記事です。
今回は、allocate-instanceを含めたInstance Structure Protocol(ISP)について書きたいと思います。
Advances in Object-Oriented Metalevel Architectures and Reflectionというオブジェクト指向プログラミングの本で、ECLOSというCLOS MOPの活用事例の紹介論文があるのですが、この論文の補遺にKiczales先生が1990年代前半に考えていたCLOS MOPのISPの改善案が紹介されています。
- Advances in Object-Oriented Metalevel Architectures and Reflection
- Why the MOP should the mopped
改善案では、
compute-getter-and-setterを導入slot-value-using-class、standard-instance-access、funcallable-standard-instance-accessの廃止
というのが主なところですが、compute-getter-and-setterはTiny CLOS系でお馴染です。
ここで紹介されている改善案とTiny CLOSのISP構成を比較してみると、実際そのまま同じ構成でした。
旧プロトコルの問題としては、
slot-value-using-classとその “setf” にメソッドを定義するユーザ拡張機能方式は、standard-instance-accessのような直のアクセスに比べてパフォーマンスが著しく低かった- オブジェクトのインスタンスに隠しストレージを追加したりする場合に面倒だった。
—等があり、この辺りをcompute-getter-and-setterでslot-valueの下請けのセッターとゲッターをまとめて管理するようにすることで改善できた、としています。
コンセプトを説明するためのコードも記載されているので、試しに既存のCommon Lisp上で動くかを試してみましたが、ISPをまるごと差し替えるのは、それなりに面倒な様子です。
具体的には、クラスの再定義時のインスタンス情報の更新プロトコルも併せて修正する必要がありそうです。
まとめ
Tiny CLOS系のMOPと、CLOS MOPで結構違うのがスロットのカスタマイズの作法ですが、Tiny CLOS方式の方が見通し良くコードも簡潔にカスタマイズできます。
パフォーマンスに関しては、Common Lisp処理系でもCLOS MOPの枠内での工夫があるので、そこまでの違いはなさそうな気はします。
AMOPがCommon LispのMOPの決定版の地位を確立したところまでは良かったのですが、それ以降は停滞してしまいました。
CLOS MOPはANSI規格で定義されているわけではないので、処理系ごとに色々できそうですが、AMOPという定番がある故にそこから逸脱することも難しく色々微妙なことになっています……。
コード
(defpackage "899d6e7c-87b9-559a-8075-8452920d48fc"
(:use c2cl slotted-objects)
(:shadow slot-value class-slots))
(in-package "899d6e7c-87b9-559a-8075-8452920d48fc")
(defclass new-standard-class (standard-class)
((nfields :initform nil)
(getters-n-setters :initform '())
(slots :initform '() :accessor class-slots)))
(defmethod validate-superclass ((c new-standard-class) (s standard-class))
T)
(defmethod allocate-instance ((class new-standard-class) &rest initargs)
(allocate-slotted-instance (class-wrapper class)
(make-sequence 'vector (cl:slot-value class 'nfields)
:initial-element (make-unbound-marker))))
(defgeneric compute-getter-and-setter (class eslotd eslotds field-allocator))
(defmethod compute-getter-and-setter ((class standard-class)
(eslotd standard-effective-slot-definition)
eslotds
field-allocator)
(ecase (slot-definition-allocation eslotd)
(:instance (list eslotd
(funcall field-allocator)
(lambda (ignore-obj val)
(declare (ignore ignore-obj))
val)
(lambda (ignore-obj val new)
(declare (ignore val ignore-obj))
new)))
(:class (let ((cell (cons (make-unbound-marker) nil)))
(list eslotd
nil
(lambda (ignore-obj ignore-val)
(declare (ignore ignore-obj ignore-val))
(car cell))
(lambda (ignore-obj ignore-val new)
(declare (ignore ignore-obj ignore-val))
(setf (car cell) new)))))))
#+lispworks
(defun make-wrapper (class eslotds)
(let ((wrapper (clos::make-wrapper-standard (length eslotds))))
(clos::initialize-wrapper wrapper)
(setf (elt wrapper 1)
(mapcar #'slot-definition-name eslotds))
(setf (clos::wrapper-class wrapper)
class)
(setf (elt wrapper 4)
eslotds)
wrapper))
(defmethod finalize-inheritance ((class new-standard-class))
(setf (class-precedence-list class)
(compute-class-precedence-list class))
(setf (cl:slot-value class 'slots) (compute-slots class))
(let* ((eslotds (class-slots class))
(nfields 0)
(field-allocator (lambda ()
(prog1
nfields
(incf nfields)))))
(setf (cl:slot-value class 'getters-n-setters)
(mapcar (lambda (eslotd)
(compute-getter-and-setter class eslotd eslotds field-allocator))
eslotds))
(setf (cl:slot-value class 'nfields) nfields)
(setf (class-default-initargs class)
(compute-default-initargs class))
(setf (clos::class-wrapper class)
(make-wrapper class eslotds)))
nil)
(defgeneric get-field (object field))
(defmethod get-field ((object standard-object) field)
(elt (instance-slots object) field))
(defgeneric set-field (object field value))
(defmethod set-field ((object standard-object) field value)
(setf (elt (instance-slots object) field)
value))
(defun slot-value (object slot-name)
(let* ((class (class-of object))
(eslotd (find slot-name (class-slots class)
:key #'slot-definition-name)))
(destructuring-bind (field getter setter)
(cdr (assoc eslotd (cl:slot-value class 'getters-n-setters)))
(declare (ignore setter))
(funcall getter object (and field (get-field object field))))))
(defun (setf slot-value) (new object slot-name)
(let* ((class (class-of object))
(eslotd (find slot-name (class-slots class)
:key #'slot-definition-name)))
(destructuring-bind (field getter setter)
(cdr (assoc eslotd (cl:slot-value class 'getters-n-setters)))
(declare (ignore getter))
(if field
(set-field object
field
(funcall setter object (get-field object field) new))
(funcall setter object nil new)))))
■
HTML generated by 3bmd in LispWorks 7.0.0
履歴付きスロットなインスタンス
Posted 2020-12-04 18:27:55 GMT
allocate-instance Advent Calendar 2020 5日目の記事です。
allocate-instanceをいじくるネタを捻り出す毎日ですが、今回は履歴付きスロットを実現してみたいと思います。
今回も共通の処理は、slotted-objectsにまとめたものを利用します。
履歴付きスロットとは
スロットの更新履歴を全部保存しておいて、後から参照できるようなスロットです。
実例はこれまで目にしたことはないもののMOPの文献等でたまに用例として出てきたりします。
履歴を保存するデータ構造は色々な方法で簡単に作成できると思うので、allocate-instanceがそのようなデータ構造を確保してしまう方が、allocate-instanceよりも上のレベルであれこれするより素直で直截的かと思うので、allocate-instanceのカスタマイズ向きな用例かもしれません。
今回は素朴な実装ですが、slot-historyという現在の値と履歴のハッシュテーブルを持つオブジェクトを定義して各スロットがそれを保持することにしてみました。
スロットに値をセットする時にタイムスタンプを押しますが、get-internal-real-timeを適当に使っています。
(defpackage "f9685263-15f6-55c9-a3bb-325737df58f2"
(:use :c2cl :slotted-objects))
(in-package "f9685263-15f6-55c9-a3bb-325737df58f2")
(defclass history-slots-class (slotted-class) ())
(defclass history-slots-object (slotted-object)
()
(:metaclass history-slots-class))
(defclass slot-history ()
((cur :initform (make-unbound-marker) :accessor slot-history-value)
(log :initform (make-hash-table) :accessor slot-history-log)))
(defmethod allocate-instance ((class history-slots-class) &rest initargs)
(allocate-slotted-instance (class-wrapper class)
(map 'vector
(lambda (x)
(declare (ignore x))
(make-instance 'slot-history))
(class-slots class))))
(defmethod slot-value-using-class ((class history-slots-class) instance (slotd slot-definition))
(slot-history-value (elt (instance-slots instance) (slot-definition-location slotd))))
(defmethod (setf slot-value-using-class)
(value (class history-slots-class) instance (slotd slot-definition))
(let ((slot (elt (instance-slots instance) (slot-definition-location slotd))))
(setf (gethash (get-internal-real-time) (slot-history-log slot))
value)
(setf (slot-history-value slot) value)))
試してみる
(defclass foo (slotted-object)
((a :initform 0)
(b :initform 1)
(c :initform 2))
(:metaclass history-slots-class))
(defun replay-slots (instance)
(let* ((slots (instance-slots instance))
(timestamps (sort
(loop :for s :across slots
:append (loop :for ts :being :the :hash-keys :of (slot-value s 'log) :collect ts))
#'<)))
(dolist (ts timestamps)
(map nil
(lambda (slot name)
(let ((log (gethash ts (slot-value slot 'log))))
(when log
(format T "~&~S: ~S → ~S~%" ts name log))))
slots
(mapcar #'slot-definition-name (class-slots (class-of instance)))))))
(let ((o (make-instance 'foo)))
;; それぞれのスロットに値を10回セット
(dotimes (i 10)
(sleep (/ 1 (1+ (random 100))))
(setf (slot-value o 'a) i)
(sleep (/ 1 (1+ (random 100))))
(setf (slot-value o 'b) i)
(sleep (/ 1 (1+ (random 100))))
(setf (slot-value o 'c) i))
;; スロット変更履歴再生
(replay-slots o))
11530892: a → 0
11530892: b → 1
11530892: c → 2
11530892: a → 0
11530892: b → 1
11530892: c → 2
11530892: a → 0
11530892: b → 1
11530892: c → 2
11530907: a → 0
11530918: b → 0
11530928: c → 0
11530951: a → 1
11530964: b → 1
11530974: c → 1
11531224: a → 2
11531251: b → 2
11531270: c → 2
11531282: a → 3
11531300: b → 3
11531310: c → 3
11531343: a → 4
11531393: b → 4
11531405: c → 4
11531464: a → 5
11531475: b → 5
11531527: c → 5
11531564: a → 6
11531664: b → 6
11531674: c → 6
11531691: a → 7
11531703: b → 7
11531729: c → 7
11531872: a → 8
11531888: b → 8
11531904: c → 8
11531936: a → 9
11531961: b → 9
11531984: c → 9
まとめ
アクセス時間的にシビアなもので使うには、きっちり実装したものでないと厳しそうですが、デバッグ時に値の変更履歴を確認したい時には、素朴な実装でも活用できそうな気がします。
■
HTML generated by 3bmd in LispWorks 7.0.0
クロージャーなインスタンス
Posted 2020-12-03 16:07:06 GMT
allocate-instance Advent Calendar 2020 4日目の記事です。
インスタンスのストレージをカスタマイズするといっても大抵はスロット付きオブジェクトの値を参照する/設定する、のが基本操作なので、大体の操作をまとめてGitHubに置いてみました。
インスタンスの中身をクロージャーにしてみる
On Lispや、Let Over Lambdaでは、Common Lispのオブジェクト指向システムは使わず、クロージャーとハッシュテーブルだったりマクロを組合せて「オブジェクト指向システムを越えた!」みたいなことをやっていますが、今回は、逆を行ってクロージャーをインスタンスの中身にしてみます。
ちなみに、Common Lispでは、オブジェクト指向システムは普通に使うので、On Lisp、Let Over Lambdaみたいな偏った本だけ読むのではなく、Quicklisp等で流通している皆のコードを読んでみましょう。普通に皆、defclassしています。
上記slotted-objectsとしてまとめたコードを使えば、スロット付きオブジェクトをインスタンスの中身に設定するには、文末のコードのようにallocate-instanceとslot-value-using-classあたりを定義すれば実現できます。
まとめ
インスタンスの中身を関数にすると、リダイレクト等の動的な操作は幾らでも可能になりますが、それはオブジェクトのアロケート時にすることかといわれると微妙です。
実装
(defpackage "72e97df3-26b8-5ff7-b134-8d9338d93e41"
(:use :c2cl :slotted-objects))
(in-package "72e97df3-26b8-5ff7-b134-8d9338d93e41")
(defclass closure-class (slotted-class) ())
(defclass closure-object (slotted-object)
()
(:metaclass closure-class))
(defmethod allocate-instance ((class closure-class) &rest initargs)
(allocate-slotted-instance (class-wrapper class)
(let* ((slotds (class-slots class))
(slot-names (mapcar #'slot-definition-name slotds)))
(eval
`(let (,@(mapcar (lambda (s)
`(,s (make-unbound-marker)))
slot-names))
(lambda (set/get slot val)
(ecase set/get
((:get)
(ecase slot
,@(mapcar (lambda (d n)
`((,d) ,n))
slotds
slot-names)))
((:set)
(ecase slot
,@(mapcar (lambda (d n)
`((,d) (setq ,n val)))
slotds
slot-names))))))))))
(defmethod slot-value-using-class ((class closure-class) instance (slotd slot-definition))
(funcall (instance-slots instance) :get slotd nil))
(defmethod (setf slot-value-using-class)
(value (class closure-class) instance (slotd slot-definition))
(funcall (instance-slots instance) :set slotd value))
動作
(defclass foo (slotted-object)
((a :initform 0)
(b :initform 1)
(c :initform 2))
(:metaclass closure-class))(describe
(make-instance 'foo))
#<foo 4020386BEB> is a foo
a 0
b 1
c 2
(let ((o (make-instance 'foo)))
(let ((slot-a (find 'a (class-slots (find-class 'foo)) :key #'slot-definition-name)))
(funcall (instance-slots o) :set slot-a 100)
(describe o)))
#<foo 4020083683> is a foo
a 100
b 1
c 2
■
HTML generated by 3bmd in LispWorks 7.0.0
AoSなインスタンス
Posted 2020-12-02 17:23:01 GMT
allocate-instance Advent Calendar 2020 3日目の記事です。
以前、MOPでSoAというのを試してみたのですが、今回はSoAの逆のAoSを試してみたいと思います。
AoSとは、構造体を並べた配列でArray of Structuresの略ですが、Common Lispにはdisplaced arrayという配列の一部を別の配列として利用する機能があるので、一本の巨大な配列を細切れにして分配してみます。
AoSを確保する部分とallocate-instaceが骨子ですが、その部分だけを抜き出すと下記のようになります。
(defparameter *aos*
(make-array (1- array-total-size-limit) :initial-element *slot-unbound*))
(defmethod allocate-instance ((class aos-slots-class) &rest initargs)
(alloc-fix-instance (class-wrapper class)
(let* ((len (length (class-slots class)))
(obj (make-array len
:displaced-to *aos*
:displaced-index-offset (class-index class))))
(incf (class-index class) len)
obj)))
試してみる
インスタンスを定義してから10回make-instanceして、ストレージの配列を観察してみます。
(defclass foo (aos-slots-object)
((a :initform 'a)
(b :initform 'b)
(c :initform 'c))
(:metaclass aos-slots-class))
(dotimes (i 10)
(make-instance 'foo))
(subseq *aos* 0 30)
→ #(a b c a b c a b c a b c a b c a b c a b c a b c a b c a b c)
ストレージの配列のを眺めてしまうと、アクセス時に間違って混ざったりちゃいそうに見えますが、displaced arrayのお蔭でインスタンスは個別の領域のみアクセスしています。
実装
大体こんな感じになります。
インスタンスのストレージの中身の操作については、前回の定義を参照してください。
(defclass aos-slots-class (standard-class)
((index :initform 0 :accessor class-index)))
(defmethod shared-initialize :after ((class aos-slots-class) slots &rest initargs)
(setf (class-index class) 0))
(defclass aos-slots-object (standard-object)
()
(:metaclass aos-slots-class))
(defmethod validate-superclass ((class aos-slots-class) (super standard-class))
T)
(defparameter *aos*
(make-array (1- array-total-size-limit) :initial-element *slot-unbound*))
(defmethod allocate-instance ((class aos-slots-class) &rest initargs)
(alloc-fix-instance (class-wrapper class)
(let* ((len (length (class-slots class)))
(obj (make-array len
:displaced-to *aos*
:displaced-index-offset (class-index class))))
(incf (class-index class) len)
obj)))
(defmethod slot-value-using-class
((class aos-slots-class) instance (slotd slot-definition))
(elt (instance-slots instance)
(slot-definition-location slotd)))
(defmethod (setf slot-value-using-class)
(val (class aos-slots-class) instance (slotd slot-definition))
(setf (elt (instance-slots instance)
(slot-definition-location slotd))
val))
(defgeneric initialize-slot-from-initarg (class instance slotd initargs))
(defmethod 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 (member initarg slot-initargs)
(setf (slot-value-using-class class instance slotd)
value)
(return T)))))
(defgeneric initialize-slot-from-initfunction (class instance slotd))
(defmethod initialize-slot-from-initfunction (class instance slotd)
(let ((initfun (slot-definition-initfunction slotd)))
(unless (not initfun)
(setf (slot-value-using-class class instance slotd)
(funcall initfun)))))
(defmethod shared-initialize
((instance aos-slots-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)
まとめ
似たようなものを色々定義していますが、スロットを有するオブジェクトについては一つslotted-class&slotted-objectにまとめられそうです。
Lispにおいてスロットを有すると考えられるオブジェクトは沢山ありますが、
- list(alist、plist)
- symbol
- array
- hash-table
- standard-structure
- standard-object
—あたりは統一的な操作体系でまとめられるでしょう。
定義が長いのでそのうちGitHub等にでも置こうかなと思います。
■
HTML generated by 3bmd in LispWorks 7.0.0
インスタンスの中身をハッシュテーブルにする
Posted 2020-12-02 13:03:55 GMT
allocate-instance Advent Calendar 2020 2日目の記事です。
前回は、Metaobject Protocols Why We Want Them and What Else They Can Doに出てくるインスタンスを中身をハッシュテーブルにしてメモリ効率を上げる手法について紹介しましたが、大抵の実装は、インスタンスの確保まではカスタマイズせずにフックをかけてリダイレクトすることが多いということを述べました。
ということで、今回は、実際にallocate-instanceが確保するストレージをハッシュテーブルにしてみましょう。
インスタンスの構造について
現在の主な処理系が採用しているオブジェクト指向システムの実装は、大抵PCL(Portable Common Loops)をカスタマイズしたものです。
PCLではstandard-objectは、wrapperというクラス定義の情報とスロットを格納する配列から構成されています。
ということで、スロットを格納するオブジェクトをハッシュテーブルに差し替えれば良いのですが、そのためにstandard-objectの内部構造をいじる関数を定義しておきます。
なお、残念ながらECLは、allocate-instanceの下請け関数がCレベルで配列をアロケートするものになっており、Lispレベルではカスタマイズできないようなので今回はパスします(10行程度のCの定義を加えれば任意のオブジェクトを格納場所にできそうではありますが)。
ちなみに他の処理系も正しい作法かどうかは分からないので、その辺りはご了承ください。特に商用処理系はソースが確認できないのでdisassembleの結果から想像して作成していたりします。
(defun alloc-fix-instance (wrapper instance-slots)
#+allegro
(excl::.primcall 'sys::new-standard-instance
wrapper
instance-slots)
#+lispworks
(sys:alloc-fix-instance wrapper instance-slots)
#+sbcl
(let* ((instance (sb-pcl::%make-instance (1+ sb-vm:instance-data-start))))
(setf (sb-kernel::%instance-layout instance) wrapper)
(setf (sb-pcl::std-instance-slots instance) instance-slots)
instance)
#+ccl
(let ((instance (ccl::gvector :instance 0 wrapper nil)))
(setf (ccl::instance.hash instance) (ccl::strip-tag-to-fixnum instance)
(ccl::instance.slots instance) instance-slots)
instance))
(defun class-wrapper (class)
#+allegro (excl::class-wrapper class)
#+lispworks (clos::class-wrapper class)
#+sbcl (sb-pcl::class-wrapper class)
#+ccl (ccl::instance-class-wrapper class))
(defun instance-wrapper (ins)
#+allegro (excl::std-instance-wrapper ins)
#+lispworks (clos::standard-instance-wrapper ins)
#+sbcl (sb-kernel::%instance-layout ins)
#+ccl (ccl::instance.class-wrapper ins))
(defun instance-slots (ins)
#+allegro (excl::std-instance-slots ins)
#+lispworks (clos::standard-instance-static-slots ins)
#+sbcl (sb-pcl::std-instance-slots ins)
#+ccl (ccl::instance.slots ins))
スロット格納をハッシュテーブルにする
上記定義の関数で、standard-objectのスロット格納だけをいじることができるようになったので、hash-table-slots-classを定義してみます。
今回のような場合、クラスのクラス定義とインスタンスのクラス定義をセットで定義することになります。
インスタンスの初期化周りもインスタンスのスロットへのアクセス方法が変更になるので、別途定義してやる必要があります。
処理系実装によっては、うまくstandard-objectの内容を引き継いでくれることもあるようですが、多分、別に定義しておいた方が良いでしょう。
また今回はslot-unbound周りは長くなるので端折ります。
(defvar *slot-unbound*
#+lispworks clos::*slot-unbound*)
(defclass hash-table-slots-class (standard-class)
())
(defclass hash-table-slots-object (standard-object)
()
(:metaclass hash-table-slots-class))
(defmethod validate-superclass ((class hash-table-slots-class) (super standard-class))
T)
(defgeneric initialize-slot-from-initarg (class instance slotd initargs))
(defmethod initialize-slot-from-initarg (class instance slotd initargs)
(declare (ignore class))
(let ((slot-initargs (slot-definition-initargs slotd)))
(loop :for (initarg value) :on initargs :by #'cddr
:do (when (member initarg slot-initargs)
(setf (gethash slotd (instance-slots instance))
value)
(return T)))))
(defgeneric initialize-slot-from-initfunction (class instance slotd))
(defmethod initialize-slot-from-initfunction (class instance slotd)
(declare (ignore class))
(let ((initfun (slot-definition-initfunction slotd)))
(unless (not initfun)
(setf (gethash slotd (instance-slots instance))
(funcall initfun)))))
(defmethod shared-initialize
((instance hash-table-slots-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)
(defmethod allocate-instance ((class hash-table-slots-class) &rest initargs)
(alloc-fix-instance (class-wrapper class)
(let ((tab (make-hash-table)))
(dolist (slotd (class-slots class) tab)
(setf (gethash slotd tab) *slot-unbound*)))))
(defmethod slot-value-using-class
((class hash-table-slots-class) instance (slotd slot-definition))
(gethash slotd (instance-slots instance)))
(defmethod (setf slot-value-using-class)
(val (class hash-table-slots-class) instance (slotd slot-definition))
(setf (gethash slotd (instance-slots instance))
val))
これでこんな感じに動きますが、見た目は何もかわりません……。
(describe (make-instance 'foo))
;>> #<foo 402025BBD3> is a foo
;>> a a
;>> b b
;>> c cもちろん中身はハッシュテーブルになっています。
(let ((o (make-instance 'foo)))
(describe (instance-slots o)))
;>> #<eql Hash Table{3} 4020000D23> is a hash-table
;>> #<standard-effective-slot-definition c 422020876B> c
;>> #<standard-effective-slot-definition b 4220208753> b
;>> #<standard-effective-slot-definition a 4220208723> aまとめ
インスタンスの中身を配列からハッシュテーブルにするだけなのですが、slot-unbound周りを省略したのに結構なコード量です。
上層のプロトコルが全部正しく機能するように一式定義するのは結構手間ですが、そうそうカスタマイズする部分でもないので、妥当といえば妥当かもしれません。
■
HTML generated by 3bmd in LispWorks 7.0.0
allocate-instanceとは
Posted 2020-11-30 16:26:06 GMT
allocate-instance Advent Calendar 2020 1日目の記事です。
Lisp系のニッチなことをテーマにアドベントカレンダーを開催したりしなかったりしていますが、今年は、allocate-instanceをテーマにしてみることにしました。
allocate-instance とは
所謂Common Lisp系のオブジェクトシステム(CLOS)のインスタンスを確保する部分ですが、AMOPでいうとInstance Structure Protocol(以降ISP)辺りの話題となります。
ISPアドベントカレンダーという名前でも良かったのですが、allocate-instanceの方がわかりやすいかなと思ってこっちの名前にしましたが、どっちにしろ参加者が集まりそうにないので五十歩百歩かもしれません。
それはさておき、AMOPのISPの説明を読むと判るように、どちらかといえばスロットのアクセスを基点として、インスタンスの物理的配置までカスタマイズするための構成が説明されています。
今回は、allocate-instanceを基点に考えてみたら面白いかもしれないというチャレンジですが、STKlosのVirtual Slots等は、スロットアクセスを基点に計算をしたりするので、ISP的にはallocate-instanceがなくても良かったりすることもあります。
ちなみにVirtual Slotsの応用は下記の記事等が参考になります。
他、複数オブジェクトをまとめて扱うような操作を実現するのもISPのカスタマイズの一種かなと思います。
allocate-instance の拡張について
スロットアクセスからデータの物理配置までの間のプロトコルをカスタマイズするのに、スロットアクセス側に重きをおく上記Virtual Slotのようなものもあれば、逆にデータ構造側に工夫をしてスロットアクセス側はそれほどカスタマイズしないという構成も考えられます。
古典的な書籍であるThe CLOS PerspectiveにもMOPの話が出てきますが、知識表現のように項目が非常に多いけれど、それぞれの利用頻度は非常に低かったりする場合は、スロットを配列にするのではなく、ハッシュテーブルのようなものの方がメモリ効率が良いだろうというアイデアの一つとして、allocate-instance のカスタマイズが示唆されたりしています。
しかし、この論文でも実際のカスタマイズの詳細については触れられておらず、類似の事例紹介でも大抵はallocate-instance内部で確保するデータ構造をカスタマイズするのではなく、フックを掛けて別のデータオブジェクトにリダイレクトするようなものが殆どのようです。
フックを掛けて別のデータオブジェクトにリダイレクトするようなものとしては文末のコードのような構成が考えられます。
この場合、allocate-instanceをカスタマイズしてはいますが、デフォルトで確保したものは捨てて、別途確保しているという点で無駄なところがあります。
また、類似のものに、オブジェクトのシリアライズやORマッパーの応用がありますが、これらも確保するデータ構造はノーマルなもので、確保時のフックが眼目になります。
今回のアドベントカレンダーは、このように迂回されることが多いallocate-instanceが確保するデータ構造について正面から向き合ってみようというのが大体の主旨です。
(defpackage "e79ba511-fd06-57f8-9038-132961fa529b" (:use :c2cl))(in-package "e79ba511-fd06-57f8-9038-132961fa529b")
(defvar *hash-slots* (make-hash-table))
(defclass hash-table-representation-class (standard-class)
())
(defmethod allocate-instance ((c hash-table-representation-class) &rest args)
(let ((inst (call-next-method)))
(setf (gethash inst *hash-slots*)
(make-hash-table))
inst))
(defmethod slot-value-using-class
((c hash-table-representation-class)
inst
(slot-name slot-definition))
(gethash slot-name
(gethash inst *hash-slots*)
(slot-definition-initform slot-name)))
(defmethod (setf slot-value-using-class)
(newvalue
(c hash-table-representation-class) inst
(slot-name slot-definition))
(setf (gethash slot-name
(gethash inst *hash-slots*)
(slot-definition-initform slot-name))
newvalue))
(defclass foo ()
((a :initform 0 :accessor foo-a)
(b :initform 0 :accessor foo-b)
(c :initform 0 :accessor foo-c))
(:metaclass hash-table-representation-class))
(defparameter *the-foo* (make-instance 'foo))
(list (foo-a *the-foo*)
(foo-b *the-foo*)
(foo-c *the-foo*))
→ (0 0 0)
(setf (foo-a *the-foo*) 42
(foo-b *the-foo*) 43)
;=> 43
(list (foo-a *the-foo*)
(foo-b *the-foo*)
(foo-c *the-foo*))
→ (42 43 0)
■
HTML generated by 3bmd in LispWorks 7.0.0
キーワード引数誕生40周年
Posted 2020-11-24 19:15:57 GMT
MACLISP系Lispではお馴染のキーワード引数ですが、最近だと名前付き引数等々様々な名前で色々な言語に採用されています。
そんなキーワード引数ですが、Lisp族に導入されたのは、いまから丁度40年前の秋の1980-10-05だったようです。
元々はWilliam A. Kornfeld(BAK)氏の発案のDEFUN-KEYEDからMACLISP系Lispに取り込まれCommon Lispでメジャーになった様子。
面白いのが(send foo ':x 42 ':y 30)のようなコロン付きのシンボルは既にFlavorsのメッセージ式で広く使われていたということです。
キーワード引数はどこが大元なのだろうかと思い、ちょっと調べましたが、同時期だとAda(1983)がありました(6.4.2. Default Parameters)
上述のFlavorsようにメッセージのキーワードをキーワード引数と考えれば、Smalltalkが元祖かもしれませんが、どうなのでしょう。
キーワードといえば、&rest、&optional等のlambda list keywordもありますが、これがISLISPのように:rest、:optionalとキーワードシンボルで統一されなかった理由ですが、1980年当時はキーワードシンボルというものは存在せず、:fooもuser:fooの略記(userパッケージのfooシンボル)だったため、:restだとシンボルがユーザープログラム中で不意にeqになってしまう懸念があったりしたようです。
その後Common Lispの仕様の議論でも二回程キーワードシンボルへの統一が話題にのぼりますが、タイミングが悪かったのかスルーされて今に至ります。まあ互換性を尊守したのかもしれませんが。
ちなみに、同時期に範囲コメントの#|...|#も登場していたようです。発案者はAlan Bawden氏でしたが、#|...|#は、最初はかなり評判が悪かった様子……。
■
HTML generated by 3bmd in LispWorks 7.0.0
コメントで二行目以降を字下げする作法
Posted 2020-11-22 21:55:02 GMT
MACLISP系のLispコードのコメント作法については、セミコロンの数の使い分けから丁寧に解説されていることが多いのですが、インラインコメントが複数行になった場合の字下げの習慣については何故か忘れられていることが多いようです。
具体的には下記のようなコードの場合、
;;;; Math Utilities
;;; FIB computes the the Fibonacci function in the traditional
;;; recursive way.
(defun fib (n)
(check-type n integer)
;; At this point we're sure we have an integer argument.
;; Now we can get down to some serious computation.
(cond ((< n 0)
;; Hey, this is just supposed to be a simple example.
;; Did you really expect me to handle the general case?
(error "FIB got ~D as an argument." n))
((< n 2) n) ;fib[0]=0 and fib[1]=1
;; The cheap cases didn't work.
;; Nothing more to do but recurse.
(t (+ (fib (- n 1)) ;The traditional formula
(fib (- n 2)))))) ; is fib[n-1]+fib[n-2].——のThe traditional formula is fib[n-1]+fib[n-2].というコメントが二行に渡っているので二行目以降が字下げされているのが分かるでしょうか。
ANSI CLの規格票(やHyperSpec)にも書いてあったりするのですが、何故忘れられてしまうことが多いのか。
ANSI CL規格で言及されているのは、セミコロン一つのインラインコメントの場合だけですが、MIT系のコードでは複数行に渡る場合はセミコロンの数に拘らず二行目以降は下げるというのが多いようです。
PDP-10のMIDASアセンブリのコードでも同様の作法がみられるので、由来はこの辺りかもしれません。
ちなみに、JonL氏にいたっては普段の文章も二行目以降を字下げするというスタイルで書いていたりします(さすがに全部ではありませんが……)
None of Glenn's problems are due to NIL stuff.
None of the new MacLISP development is particularly NIL stuff
(multiple-values have been on the LISPM for years).
Indeed, the "intermediate" MACLISP dump cost us more than 7K of
address space, and is being dropped. As soon as agreement is
reached about XLISP, then XCOMPLR will replace the currently
bloated complr.追記
なんかこれ似たようなことを書いたことがあった気がするなーと思ったら9年前に書いてました。
当時はインラインコメントでの作法と思っていましたが、インラインに限定はされないようです。
■
HTML generated by 3bmd in LispWorks 7.0.0
続・mopでstandard-objectとsymbolを融合したい
Posted 2020-11-11 20:17:34 GMT
前回はstandard-objectとsymbolの融合として、symbol-valueにインスタンスを設定するという方法を試しましたが、今回はsymbolオブジェクトのplistをインスタンスのスロットに見立てたらどうなるかを試してみたいと思います。
実装してみた
(defclass foo ()
((a :initform 0)
(b :initform 1)
(c :initform 2))
(:metaclass symb-class))
(make-instance 'foo)
→ foo0
(symbol-plist 'foo0)
→ (#<standard-effective-slot-definition c 4020015753> 2 #<standard-effective-slot-definition b 40200156EB> 1 #<standard-effective-slot-definition a 4020015683> 0 class #<symb-class foo 41202C6E8B> clos::class-wrapper #(2445 (a b c) nil #<symb-class foo 41202C6E8B> (#<standard-effective-slot-definition a 4020015683> #<standard-effective-slot-definition b 40200156EB> #<standard-effective-slot-definition c 4020015753>) 3))
(with-slots (a b c) 'foo0
(list a b c))
→ (0 1 2)
(with-slots (a b c) 'foo0
(incf a 100)
(incf b 100)
(incf c 100))
→ 102
(symbol-plist 'foo0)
→ (100 101 102)
オブジェクトシステムのツールがシンボルに対して機能するがの面白いといえば、面白いですが、一連のオブジェクトシステムのツール全部をシンボルオブジェクトに対して有効に使えるようにするのはちょっと難しいのであまり旨味はないですね。
コード
(defpackage "a1a9aa2a-8de2-5040-89dc-acd6b4de23f0" (:use :c2cl))
(in-package "a1a9aa2a-8de2-5040-89dc-acd6b4de23f0")
(defclass slotted-class (standard-class)
())
(defclass symb-class (slotted-class)
())
(defclass symb-object ()
()
(:metaclass symb-class))
(defmethod validate-superclass ((class symb-class) (super standard-class))
T)
#+LispWorks
(defmethod allocate-instance ((class symb-class) &rest initargs)
(let* ((class (clos::ensure-class-finalized class))
(instance (gentemp (string (class-name class)))))
(setf (get instance 'clos::class-wrapper)
(clos::class-wrapper class))
(setf (get instance 'class)
class)
instance))
(defmethod slot-value-using-class
((class (eql (find-class 'symbol))) instance (slotd symbol))
(get instance (find slotd (class-slots (get instance 'class)) :key #'slot-definition-name)))
(let ((lw:*handle-warn-on-redefinition* nil))
(defmethod slot-value-using-class
((class (eql (find-class 'symbol))) instance (slotd slot-definition))
(get instance slotd))
(defmethod slot-value-using-class
((class (eql (find-class 'symbol))) instance (slotd symbol))
(get instance (find slotd (class-slots (get instance 'class)) :key #'slot-definition-name)))
(defmethod (setf slot-value-using-class)
(val (class (eql (find-class 'symbol))) instance (slotd slot-definition))
(setf (get instance slotd) val))
(defmethod (setf slot-value-using-class)
(val (class (eql (find-class 'symbol))) instance (slotd symbol))
(setf (get instance (find slotd (class-slots (get instance 'class)) :key #'slot-definition-name)) val))
(defmethod shared-initialize ((instance symbol) slot-names &rest initargs)
(flet ((initialize-slot-from-initarg (class instance slotd)
(let ((slot-initargs (slot-definition-initargs slotd))
(name slotd))
(loop :for (initarg value) :on initargs :by #'cddr
:do (when (member initarg slot-initargs)
(setf (get instance name)
value)
(return t)))))
(initialize-slot-from-initfunction (class instance slotd)
(let ((initfun (slot-definition-initfunction slotd))
(name slotd))
(unless (not initfun)
(setf (get instance name)
(funcall initfun))))))
(let ((class (get instance 'class)))
(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))
)まとめ
今回は、シンボルをそのままオブジェクトに見立ててみたのですが、オブジェクトシステムは、コンテナとしてのインスタンスでディスパッチするのが便利というところがあるので、コンテナはそのままにしつつストレージの方を配列からハッシュテーブルにしてみたり、シンボルにしてみたり、という方が発展させ甲斐がありそう、という当たり前の結論に到達しました……。
■
HTML generated by 3bmd in LispWorks Personal Edition 7.1.2
mopでstandard-objectとsymbolを融合したい
Posted 2020-11-09 20:39:18 GMT
いまを去ること4年前のことですが、Lisp Meet Up presented by Shibuya.lisp #42の「Mathematicaとオブジェクト指向について」をネットで観覧していて、シンボルをオブジェクトのように扱うネタをみて、Common Lispでもシンボルをオブジェクトのストレージにできるんじゃないかなあと思ったのですが、ブログのネタ帳にメモだけ残してすっかり忘れていました。
Common Lispで似たようなものが作れるのではないかというのは、y2q_actionmanさんもブログでリアクションをしています。
y2q_actionmanさんは、シンボルを中心に新しくシステムを構築していますが、自分は既存のオブジェクト指向システムと融合できるのではないか、という感じだったので、そんな感じのものを今回書いてみました。
ちなみに、発表されていたMathematicaの当該機能はUpSetというものらしいですが、オブジェクト指向システムを簡単に実現できる柔軟な仕組みのようなものみたいです。
基本的な戦略
- シンボルを
gentempで生成する allocate-instanceで生成したオブジェクトを生成したシンボルに代入する
——だけ、なので、make-instanceにフックでも仕掛ければ終了、ともいえますが、インスタンスのオブジェクトに名前(シンボル)を保持するように拡張するという無駄に複雑な方向で実現してみたいと思います。
具体的には、allocate-instanceで確保するベクタの長さを一つ延して先頭に名前を詰めることにします。
実装してみる
こんなクラス定義があるとすると、
(defclass foo (symb-object)
((a :initform 0)
(b :initform 1)
(c :initform 2))
(:metaclass symb-class))(make-instance 'foo)
→ #<foo foo0> (setf (slot-value foo0 'a) 42)
→ 42
(get 'foo0 'a)
→ 42
(symbol-plist 'foo0)
→ (c 2 b 1 a 42)
——というような挙動にしました。
融合というからには、(setf get)でのシンボルのplistへの書き込みもオブジェクトと同期させたいところですが、getを変更するのは大袈裟なので今回は見送っています。
コード
(defpackage "2cd9cb9c-2302-5cc4-9c4c-aafd83e01db4" (:use :c2cl))
(in-package "2cd9cb9c-2302-5cc4-9c4c-aafd83e01db4")
(defclass slotted-class (standard-class)
())
(defclass symb-class (slotted-class)
())
(defclass symb-object ()
()
(:metaclass symb-class))
(defmethod validate-superclass ((class symb-class) (super standard-class))
T)
(defmethod compute-slots :around ((class symb-class))
(let ((slotds (call-next-method)))
(dolist (s slotds)
(setf (slot-definition-location s)
(1+ (position s slotds))))
slotds))
#+LispWorks
(defmethod allocate-instance ((class symb-class) &rest initargs)
(let* ((class (clos::ensure-class-finalized class))
(storage (sys:alloc-g-vector$fixnum
(1+ (length (class-slots class)))
clos::*slot-unbound*))
(instance (sys:alloc-fix-instance (clos::class-wrapper class)
storage))
(name (gentemp (string (class-name class)))))
(setf (elt storage 0) name)
(setf (symbol-value name) instance)
instance))
#+LispWorks
(defun instance-name (instance)
(elt (clos::%svref instance 1) 0))
(defmethod initialize-instance :after ((inst symb-object) &rest initargs)
(let* ((class (class-of inst))
(name (instance-name inst)))
(dolist (slot (class-slots class))
(let ((slot-name (slot-definition-name slot)))
(setf (get name slot-name)
(and (slot-boundp inst slot-name)
(slot-value inst slot-name)))))))
(defmethod slot-value-using-class
((class symb-class) instance (slotd slot-definition))
(standard-instance-access instance
(1+ (position slotd (class-slots class)))))
(defmethod (setf slot-value-using-class)
(val (class symb-class) instance (slotd slot-definition))
(setf (get (instance-name instance) (slot-definition-name slotd))
val)
(setf (standard-instance-access instance
(1+ (position slotd (class-slots class))))
val))
(defmethod print-object ((instance symb-object) stream)
(print-unreadable-object (instance stream :type T)
(format stream "~S" (instance-name instance))))
まとめ
allocate-instanceでsymbolを生成してしまうというのが、一番直截的な感はありますが、色々なプロトコルでsymbolを扱えるようにするのが面倒で今回は妥協しました。
いつかチャレンジしてみたい気もしますが、Common LispのMOPは、そもそもstandard-objectから派生したオブジェクト以外のもの扱うことはできるのでしょうか。
■
HTML generated by 3bmd in LispWorks Personal Edition 7.1.2
atomとnullにpがないのは何故かを考える
Posted 2020-11-08 07:03:01 GMT
Lispの述語(predicate)の名前の末尾には大抵pが付いていて、これが一つのLisp文化を形成していたりもしますが、atomとnullには、末尾には何故かpがついていません。
方言によっては、整合性を持たせるためにatompや、nullpとしているものもありますが、大抵は、歴史的理由として、そのままatomや、nullを継承することが多いようです。
そんな日々でしたが、atomとnullにpが付かなかった理由の仮説を思い付きました。
pが付かなかった仮説: atom や null は Propositional Expressions として記述する気でいたから説
Recursive Functions of Symbolic Expressionsand Their Computation by Machine, Part Iや、LISP I Programmer's manualには、
Propositional Expressionsというものが、述語とならんで解説されていますが、いまでいうブーリアンを返す式です(複合可)。
b.Propositional Expressions and Predicates. A propositional expression is an expression whose possible values are T(for truth) and F(for falsity).
We shall assume that the reader is familiar with the propositional connectives ∧(“and”),∨(“or”), and¬(“not”).
Typical propositional expressions are:
x < y
(x < y)∧(b = c)
x is prime
ここで注目したいのは、x is primeという形式ですが、atomや、nullはこの形式にぴったりではありませんか。
flat[x] = [x is null → x;
x is atom → list[x];
T → append[flat[car[x]];
flat[cdr[x]]]]——と記述するのであればpは不要です。
しかし、残念ながら以降の文献にはis形式は登場せず用例の解説も皆無です。
predp[x]という述語形式に吸収されてしまったのか、もしくは記法としての整合性がなかったのか……。
さらには、同文献中にatom[x]の用例が解説されており、当初はx is atom形式だった、という痕跡もなく、いまいち説得力もありません。
まとめ
is形式の謎の解明が俟たれます。
■
HTML generated by 3bmd in LispWorks Personal Edition 7.1.2
続・(coerce "foo" 'cons)は合法か否か
Posted 2020-10-28 13:15:31 GMT
Franzにcoerceの挙動がバグなのではないかと報告してみましたが、なんと報告メールの送信から三時間強で、バグ番号が振られ次期バージョンで修正するという返事が来ました。
暫定パッチは必要か尋ねられましたが、バグ報告が目的なので必要ないと回答。
LispWorksもそうですが商用処理系では、暫定的に処理系の挙動を修正するパッチを作成してくれることが多いようです。
複雑なlistのサブタイプ指定に対してLispWorksの動作が正確な理由
(coerce "foo" '(cons (eql #\f) (cons (eql #\o) (cons (eql #\f) *))))のような込み入った指定でSBCLがチェックに失敗し、LispWorksが正解する理由ですが、LispWorksのcoerceをdisassembleしてみると、変換の後に指定した型指定子で結果オブジェクトのタイプチェックをしているからのようです。
なるほど、確かに後でチェックすれば間違いはない。
逆に、SBCL等は何の型に変換するかだけを見ているので、型指定子がlistのサブタイプと判定された後はチェックしていません。
SBCLにもバグ報告しようかなと思ったりはしますが、返り値の型が指定より緩い分には返り値の型チェックをするコードを追加すれば良く、大した害もないですし気が向いたら報告します……。
■
HTML generated by 3bmd in LispWorks Personal Edition 7.1.2
(coerce "foo" 'cons)は合法か否か
Posted 2020-10-27 16:47:47 GMT
自作のライブラリで、(coerce "foo" 'cons)や、(coerce "" 'null)のようなコードがAllegro CLでエラーになるので、おやもしかして処理系依存だったかと思いANSI規格を確認してみましたが、
sequenceIf the result-type is a recognizable subtype of list, and the object is a sequence, then the result is a list that has the same elements as object.
——ということなので、合法のようです。
ちょっと趣味的にAllegro CL 4.3(1996)で確認してみましたが、同様のエラーのようです。
そうなると時代的にCLtL1、CLtL2あたりでははっきり決まっていなかったかもしれないので確認してみましたが、明記されたのはANSI CL規格以降のようです。
無駄に深追いしてみる
とりあえず、Allegro CLのcoerceをdisassembleしてみると、excl::vector-to-list*という下請けに渡していることが分かります。
1023: 89 da movl edx,ebx
1025: 3b 56 26 cmpl edx,[esi+38] ; LIST
1028: 0f 85 1e 02 jnz 1576
00 00
1034: 8b 45 dc movl eax,[ebp-36] ; EXCL::LOCAL-0
1037: 89 7d f0 movl [ebp-16],edi
1040: c9 leave
1041: 8b 5e 2a movl ebx,[esi+42] ; EXCL::VECTOR-TO-LIST*このexcl::vector-to-list*自体は、適切にリストに変換できるようですが、前段では、consやnullも出てこずにlistとしか比較していないので、すりぬけてエラーになっているように見えます。
(excl::vector-to-list* "")
→ NIL(excl::vector-to-list* "foo")
→(#\f #\o #\o)
listのサブタイプはconsやnull以外にも複合した指定があるので、別途サブタイプの判定をきっちりしないと
(coerce "foo" '(cons (eql #\f) (cons (eql #\o) (cons (eql #\f) *))))
のようなものを判定できなさそうです。
ちなみに上記は、LispWorksではエラーになりますが、SBCLではエラーになりません(SBCLのバグもみつけてしまったか?)
バグ報告
Allegro CLへのバグはどこに報告したら良いのかと探してみましたが、報告の仕方の解説ページがあったので、こちらに沿って報告してみました。
まとめ
Allegro CL 4.3(1996)でも同様なので、Allegro CL(ExCL)誕生時(1986)からこの仕様で来たような気がしないでもありません。
果してバグ認定されるのか、はたまたAllegro CLの仕様であるとして修正されないのか。
ちなみに、mapも変なところがありますが、話がややこしくなるので、今回は報告を見送りました。
#+Allegro
(map 'null #'identity "foo")
→(#\f #\o #\o)
■
HTML generated by 3bmd in LispWorks Personal Edition 7.1.2
LispWorksのエディタが思いの外Hemlockだった
Posted 2020-10-17 21:13:02 GMT
LispWorksのエディタがHemlock由来というのは、LispWorksの歴史のページにも記載されているのですが、フォークされたのも1987年あたりのようですし、原型は留めていないのかと勝手に想像していました。
Technically, LispWorks's distant origins include Spice Lisp, while the editor began life as a branch of Hemlock, and the CLOS implementation started out as a branch of PCL (Portable Common Loops).
LispWorksを本格的に使い始めて早五年ですが、どれだけHemlockと似ているのか具体的に眺めたことはないなあと思ったので、ちょっと突き合せて眺めてみました。
30のファイルのファイル名が同じ
LispWorksに付属してくるエディタのファイルは94、cmucl付属のHemlockのファイルは111ありますが、30ファイルの名前が一致。
- abbrev.lisp
- auto-save.lisp
- buffer.lisp
- charmacs.lisp
- command.lisp
- comments.lisp
- doccoms.lisp
- echo.lisp
- echocoms.lisp
- filecoms.lisp
- files.lisp
- fill.lisp
- highlight.lisp
- indent.lisp
- interp.lisp
- kbdmac.lisp
- killcoms.lisp
- lispeval.lisp
- lispmode.lisp
- main.lisp
- morecoms.lisp
- overwrite.lisp
- register.lisp
- screen.lisp
- searchcoms.lisp
- streams.lisp
- struct.lisp
- table.lisp
- text.lisp
- window.lisp
パッケージ内のシンボル名の267が一致
外部シンボルで、関数か変数の束縛があるシンボルは、267。内部シンボルだと292、束縛なしだと857のシンボルが一致
ほぼ内容が同じファイルが結構ある
HemlockもLispWorksのエディタもほぼ同じというファイルがそこそこあります。
例えば、abbrev.lispを眺めると、
;;; Hemlock Word Abbreviation Mode
;;; by Jamie W. Zawinski
;;; 24 September 1985オリジナルの作者は、jwz氏だったようです。
1968年生れのようなので当時16歳でしょうか。
まとめ
日々Abbrev Modeを使っていますが高校生時代のjwz作とは知らなんだ。
LispWorksのエディタとよりLispWorksのHemlockという感じですね。
五年も使っているのに、ファイルを詳しく比較するまで気付かなかった理由ですが、LispWorksがオリジナルのヘッダコメントを全部綺麗に削っているので由来がぱっとみでは判然としなかった、というのがあります。
オリジナルのHemlockは、
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.———とパブリックドメインなので、別に問題ないんでしょうけど、同じくHemlock派生のLucidのHelixでは、ちゃんと由来を残していたりします。
;;; -*- Package: Helix; Log: Helix.Log -*-
;;;;
;;;; FILECOMS, Module HELIX
;;;
;;; ***************************************************************************
;;;
;;; Copyright (C) 1987 by Lucid Inc., All Rights Reserved
;;;
;;; ***************************************************************************
;;;
;;; Originally part of the Spice Lisp Hemlock system, by Rob MacLachlan,
;;; Skef Wholey and Bill Chiles, of CMU
;;;
;;; Programmer: Ken D. Olum
;;;
;;; Edit-History:
;;;
;;; Created: Spring 1987—— このように由来の記載が残っていれば、すぐ判るのですが……。
ちなみに、MCLのFredもHemlock由来らしいですが、こちらはオブジェクト指向な感じに書き直されていてほぼ原型を留めていません。
■
HTML generated by 3bmd in LispWorks Personal Edition 7.1.2
named-readtables不要論
Posted 2020-10-12 17:25:13 GMT
リードテーブルの切り換えにnamed-readtablesを愛用しているので不要ということもないのですが、リードテーブルの切り換えという中核の機構が外部のライブラリに依存しているのが少し嫌だったりします。
実際、named-readtablesがメンテナ不在時に壊れたままだったり、ECLのような処理系では頻繁に壊れていたりはするのですが、便利といえば便利なので愛用しています。
そもそもCommon Lispの前身であるLisp Machine Lispでは、ファイル先頭の属性リスト-*- mode: lisp -*-で、パッケージとリードテーブルを切り替えるのが基本でしたが、Common Lispではそれを採用しなかったので、(in-package ...)等を書くことになりました。
しかし、(in-package ...)は標準なのに、(in-readtable ..)等は標準でないのは何故なのか。
*readtableを切り換えるin-syntaxも提案されてはいた
実は、*readtableを切り換えるin-syntaxもKent Pitman(KMP)氏によって提案されてはいたようです。
in-syntaxはHyperSpecのイシューまとめにもありますが、cl-cleanupメーリングリストの方が一連の流れが追えるのでそちらを紹介すると、
KMPの提案は、ほぼin-packageに相当するようなシンプルなものだったようです。
(DEFMACRO IN-SYNTAX (READTABLE)
`(EVAL-WHEN (EVAL COMPILE LOAD)
(SETQ *READTABLE* ,READTABLE)))使い方ですが、パッケージ定義の後で、リードテーブルの変数を定義し、それにリードテーブルを設定、
;;; -----File A-----
(DEFPACKAGE ACME ...)
(DEFVAR *ACME-SYNTAX* (COPY-READTABLE *READTABLE*))以降のファイルは、先頭に適宜in-packageやin-syntaxを書いていくというものです。
(IN-PACKAGE ACME)
(IN-SYNTAX *ACME-SYNTAX*)(SET-MACRO-CHARACTER #\! ...)
なるほど。
良く考えると、カスタマイズされたリードテーブルを使う頻度からして、三行のマクロを都度書けば良いだけなので、毎度書いても大した手間でもないかなという感じです。
場合によっては、named-readtablesのライブラリの依存関係を記述したり、パッケージにインポートしたりの方が手間かもしれません。
ちなみに、1980年代後半〜90年代前半あたりのCommon Lispの大き目のプロジェクトでは、
(defmacro my-module ()
`(eval-when (:compile-toplevel :load-toplevel :execute)
(in-package my-package)
(setq *readtable* *my-syntax*)))のようなものを定義して、
;;; -* mode: lisp -*-
(my-module)...
のようにファイルの先頭に置いておく作法も割合に目にしますが、外部ライブラリのnamed-readtablesの作法に縛られるよりも自由度が高くて管理も楽かもしれません。
名前付きリードテーブルのメリット
一応、named-readtablesのメリットというか、名前付きリードテーブルのメリットを挙げておくと、名前を付けて管理する機構になっているので、find-readtableで任意のリードテーブルを呼び出すことが可能です。
恐らく、元ネタはAllegro CLのnamed readtableだと思いますが、Allegro CLのさらに元ネタは多分、Lisp Machine Lispのsi:find-readtable-named等、リードテーブルに複数の名前を付けることができたAPI由来かなと思います。
in-syntaxは何故標準化されなかったのか
KMPはシンプルに*readtable*変数を設定するだけの提案だったようですが、名前が良くない、それをいったら、*read-base、*read-default-float-format*はどうするんだ、あまり気軽に変更するとcompile-fileやloadで変なことが起きがちになる、仕様のクリーンナップというよりはコンパイラ仕様で議論すべきだった、等々、議論が発散してまとまらなかったようです。
まとめ
KMPが提案してANSI CL規格に入らなかったものは結構ありますが、defsystem、in-syntax等は、後世の人達が結局ライブラリとして自作することになったので、標準化されると良かったなと思うことしきりです。
■
HTML generated by 3bmd in LispWorks Personal Edition 7.1.2
マクロに付くコンパイラマクロの使い道 (2)
Posted 2020-10-05 15:45:04 GMT
三年前のブログネタのメモに、「マクロにコンパイラマクロ allegro clのcompose-stringを改良する」とあったので、Allegro CLのcompose-stringの仕様を確認してみましたが、一体何が気に入らなかったのか思い出せません。
compose-stringの仕様ですが、基本的にコンパイル時(マクロ展開時)に文字列を合成してしまおうというもので、展開時に文字列リテラルとして確定できる場合は、文字列を、確定できない場合は、compose-string-fnを呼び出す式へ展開、という仕様です。
(compose-string "foo" "bar" :[ 3042 :] "foo" newline)
===> "foobarあfoo
"(compose-string "foo" "bar" :[ 3042 :] "foo" newline :eval "foo")
===> (compose-string-fn "foo" "bar" 12354 "foo" #\Newline "foo")三年前の自分の気持ちを察するに、マクロ展開時に色々やりすぎというところだったのかもしれません。
Common Lispでマクロ展開時とコンパイル時を同一視する人は多いですが、厳密にはマクロ展開は、インタプリタ動作時にも実行されるため、あまりマクロ展開での重い仕事はインタプリタを遅くすることになります。
まあSBCLのような処理系が主流の今となっては誰も気にしていないと思いますが。
マクロ展開での重い仕事をコンパイル時に移行する手段としては、コンパイラマクロがありますが、多分、compose-stringをこのような作りに仕立ててみるということがやりたかった気がするので、そういう風なものを作成してみましょう。
compose-stringのマクロ展開を軽くする
とりあえずですが、下請けの、compose-string-fnを定義します。
(defun compose-string-fn (&rest args)
(with-output-to-string (out)
(dolist (a args)
(typecase a
(CHARACTER
(write-char a out))
(INTEGER
(write-char (code-char a) out))
(STRING
(write-string a out))
(T (write-string (string a) out))))))次に、compose-stringの引数を、compose-string-fnが解釈できるような形式に変換する関数を作成します。
(defun compose-string-process-args (&rest args)
(labels ((err (args)
(error "Invalid argument to compose-string: :] in ~S" args))
(compstr (args acc)
(if (endp args)
(nreverse acc)
(typecase (car args)
((OR STRING CHARACTER INTEGER)
(compstr (cdr args)
(cons (car args) acc)))
((EQL :])
(err args))
((EQL :[)
(let ((pos (position :] (cdr args))))
(if pos
(compstr (append
(mapcar (lambda (x)
(parse-integer (write-to-string x) :radix 16.))
(subseq (cdr args) 0 pos))
(nthcdr (1+ pos) (cdr args)))
acc)
(err args))))
((EQL :EVAL)
(compstr (cddr args)
(cons (cadr args)
acc)))
(SYMBOL
(compstr (cons (name-char (string (car args)))
(cdr args))
acc))
(T (err args))))))
(compstr args nil)))これらをcompose-stringとしてまとめます。
(defmacro compose-string (&rest args)
`(compose-string-fn ,@(apply #'compose-string-process-args args)))動作
(compose-string "foo" "bar" :eval 12354 :[ 3042 :] "foo")
===>
(compose-string-fn "foo" "bar" 12354 12354 "foo")コンパイラマクロを追加
とりあえず上記のような動作ですが、引数処理時に全部が文字列であることが判定できる場合は、展開時に文字列を返すような最適化をコンパイラマクロで追加します。
(define-compiler-macro compose-string (&whole w &rest args)
(let ((args (apply #'compose-string-process-args args)))
(if (every #'stringp args)
(apply #'concatenate 'string args)
w)))(compiler-macroexpand '(compose-string "foo" "bar" "foo"))
→ "foobarfoo"多分三年前の自分はこんな動作をさせたかったのでしょう。
一方Allegro CLでの動作は
元々のAllegro CLのcompose-stringでは、:evalオプションがなければ、マクロ展開時に全部計算してしまいます。
大体、上記コンパイラマクロ版の定義と同じですが、再現するとしたら下記にようになるでしょうか。
(defun compose-string-process-args (&rest args)
(labels ((err (args)
(error "Invalid argument to compose-string: :] in ~S" args))
(compstr (args acc)
(if (endp args)
(nreverse acc)
(typecase (car args)
(STRING
(compstr (cdr args)
(typecase (car acc)
(STRING (cons (concatenate 'string
(car acc)
(car args))
(cdr acc)))
(T (cons (car args) acc)))))
(CHARACTER
(compstr (cons (string (car args))
(cdr args))
acc))
((EQL :])
(err args))
((EQL :[)
(let ((pos (position :] (cdr args))))
(if pos
(compstr (append
(mapcar (lambda (x)
(parse-integer (write-to-string x) :radix 16.))
(subseq (cdr args) 0 pos))
(nthcdr (1+ pos) (cdr args)))
acc)
(err args))))
(INTEGER
(compstr (cons (code-char (car args))
(cdr args))
acc))
((EQL :EVAL)
(compstr (cddr args)
(cons `(:eval ,(cadr args))
acc)))
(SYMBOL
(compstr (cons (name-char (string (car args)))
(cdr args))
acc))
(T (err args))))))
(compstr args nil)))
(defun strip-eval-mark (args)
(mapcar (lambda (x)
(etypecase x
(STRING x)
((cons (eql :eval) *)
(cadr x))))
args))
(defmacro compose-string (&rest args)
(let ((args (apply #'compose-string-process-args args)))
(if (every #'stringp args)
(apply #'concatenate 'string args)
`(compose-string-fn ,@(strip-eval-mark args)))))
(compose-string "foo" "bar" :[ 3042 :] "foo")
===> "foobarあfoo"
コンパイラマクロ版を更に改良
前述のマクロにコンパイラマクロを付ける方式だと、compose-string-fnの文字列の融合までは処理されません。
しかし、compose-string-fnの方にもコンパイラマクロを付ければ解決できるでしょう。
(define-compiler-macro compose-string-fn (&whole w &rest args)
(if (every #'stringp args)
(apply #'concatenate 'string args)
w))(compiler-macroexpand '(compose-string-fn "foobarあfoo
"
"foo"))
→ "foobarあfoo
foo" まとめ
以上、インタプリタ動作でのマクロ展開は軽くしつつ、コンパイル動作の場合はコンパイル時に最適化処理はしてしまう、というのを考えてみました。
基本的に引数の最適化処理はコンパイラマクロの主要な使い道(&keyの最適化等)なので、使える場所があったら使ってみるのが良いかなと思います。
参照
■
HTML generated by 3bmd in LispWorks Personal Edition 7.1.2
begin0 prog1 prog2 prognの謎
Posted 2020-09-29 01:28:16 GMT
Common Lispには、prog1、prog2、prognとありますが、Lispは0オリジンなのに、(nth 0)な場所の値を返すprog1、(nth 1)な場所の値を返すprog2、って整合性がないなあ、一方Scheme畑では、美しく、begin0と命名する(Racket等)……という小話がありますが、なぜCommon Lispは1オリジン風なのでしょうか
;;; Welcome to Racket v7.8.
(begin0 0 1 2 3)
→ 0A. 元々の数字はフォームのアリティだったから
Common Lispには、prog1、prog2、prognとありますが、Lisp 1.5まで遡ると、prog2しかありませんでした。
この時のprog2は、2つのフォームをとれるフォームで最後の値を返すものでした。
これが、PDP-6 Lisp(1966)で、prog2が可変長の引数を取れるように進化。値を返す場所は変更なし、ということで、「二番目のフォームの値を返す」もの、という感じになってしまいました。
続いて、progn(1968あたり)、prog1(1977あたり)が続きます。
まとめ
可変長のフォームで、N番目のフォームの値を返す、というのは割合に発明だった気がしますが、命名則としてはねじれたことになってしまったようです。
■
HTML generated by 3bmd in LispWorks 7.0.0
loopにもっと括弧を
Posted 2020-09-27 04:38:31 GMT
以前、ANSI CL規格(INCITS 226-1994)の規格の更新について議論しているログを眺めたことがあったのですが、その中で、Jon L White氏が「loop にもっと括弧を」という意見を出していました。
この議論のログは確かウェブで参照できた筈ですが、今やまったく見付かりません。結構貴重な資料だと思いますが……。
loopをLispyに改善したものといえば、iterateだと思いますが、括弧をつけるだけなら、簡単な処理で実現できるなと思ったので試してみました。
(defmacro for (&rest body)
`(loop
,@(reduce (lambda (res b)
(append res (->loop-clause b)))
body
:initial-value nil)))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun ->loop-clause (xpr)
(case (find (car xpr) '(let) :test #'string-equal)
(let (destructuring-bind (let &rest args)
xpr
(declare (ignore let))
`(for ,@args)))
(otherwise xpr))))
要するにloopに余計な括弧を付与するだけですが、まあまあそれっぽくなります。
(for (let i :from 0)
(let j :from 0)
(repeat 16)
(if (oddp i)
:collect i :into es)
(collect i :into is)
(collect j :into js)
(finally (return (list es is js))))
→ ((1 3 5 7 9 11 13 15)
(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)
(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15))loopだと:do節の後にprognを補ったりしがちですが、括弧で囲むと範囲がはっきりするので安定感があります。
(for (repeat 5)
(do (print 'hello-world)
(terpri)))
▻
▻ hello-world
▻
▻ hello-world
▻
▻ hello-world
▻
▻ hello-world
▻
▻ hello-world
→ nilまとめ
もうちょっと凝ったことをしようと思ったら素直にiterateを使う方が良いとは思いますが、案外上手くいっちゃってる感。
もっとも、JonL氏がいう「もっと括弧を」、というのは恐らくiterateのようなものを指しているのだとは思いますので誤解なきよう。
■
HTML generated by 3bmd in LispWorks Personal Edition 7.1.2
setf可能な場所なのかどうかを確認したい
Posted 2020-09-23 02:00:36 GMT
setf可能な場所なのかどうかを確認したい、というのは、そもそもどういう動機からなのかというと、身近な例では、(setf nthcdr)等と書いた時に、
(let ((x (list 0 1 2 3 4)))
(setf (nthcdr 1 x) (list 'a 'b 'c))
x)
!Error: Undefined operator (setf nthcdr) in form ((setf nthcdr) #:|Store-Var-34450| #:g34451 #:g34452).となってしまい、あれ、(setf nthcdr)って設定されてないんだっけ?というようなことを防止したい、というような動機です。
上記の場合、
(let ((x (list 0 1 2 3 4)))
(setf (cdr (nthcdr 0 x)) (list 'a 'b 'c))
x)
→ (0 a b c)と書き直せば良いのですが。
考えられそうなアプローチ
setfできそうな場所は全部setf対応しておく- setfの展開を制御するユーティリティマクロで頑張ってみる
- 標準規格で定義されているsetfの場所以外のものは一切書かない
等々、色々ありますが、まず、setfして回るのは、処理系を改造することになるので、ちょっと嫌なのと、やるとしてもsetfの展開方法が処理系ごとに結構違っているので、setfを設定するコードの可搬性を担保するのが結構難しい。
次に、ユーティリティマクロで囲んだり、setfの類似品を作る的なところですが、この問題をコードウォークして解決するとしても、局所関数/マクロでsetfを定義できたりするので結構大変でしょう。
標準規格で定義されているsetfの場所以外のものは一切書かない、というのは若干寂しいですが、これはこれでありかなと思います。
標準の(setf place)を一覧にする
標準の(setf place)を全部把握したい、ということで、CLHS: 5.1.2 Kinds of Placesで定義されているものを、列記してみます。
変数名全部
これは問題ないでしょう
標準定義の関数フォーム形式
(setf bit)
(setf c[ad]+r) ;car cdr系全部
(setf char)
(setf class-name)
(setf compiler-macro-function)
(setf documentation)
(setf elt)
(setf fdefinition)
(setf fifth)
(setf fill-pointer)
(setf find-class)
(setf first ... tenth) ; firstからtenthまで
(setf rest)
(setf get)
(setf getf)
(setf gethash)
(setf ldb)
(setf logical-pathname-translations)
(setf macro-function)
(setf mask-field)
(setf nth)
(setf readtable-case)
(setf row-major-aref)
(setf sbit)
(setf schar)
(setf slot-value)
(setf subseq)
(setf svref)
(setf symbol-function)
(setf symbol-plist)
(setf symbol-value)Apply との組み合わせ
上記に加えて、Applyのフォームと組合せ可能なものとして、aref、bit、sbitがあるので、
(setf (apply #'aref))
(setf (apply #'bit))
(setf (apply #'sbit))Values との組み合わせ
上記の関数フォームに組合せ可能なものとして更にvalues
(setf values)the との組み合わせ
さらに組合せ可能なものとして、the
(setf the)setf系マクロ
decf pop pushnew incf push remf あたりのマクロですが、define-modify-macroで定義したように動くので、valuesと組合せて使うことは想定されていない様子。
LispWorksに至ってはエラーになります。
まとめ
標準の組み合わせだけでも、結構複雑な組み合わせは可能です。
(let ((ba (make-array '(4 4)
:element-type 'bit
:initial-element 1))
(bb (make-array '(4 4)
:element-type 'bit
:initial-element 1)))
(setf (values (the bit (apply #'bit ba '(0 0)))
(the bit (apply #'bit bb '(0 0))))
(values 0 0))
(values ba bb))
→ #2A((0 1 1 1) (1 1 1 1) (1 1 1 1) (1 1 1 1))
#2A((0 1 1 1) (1 1 1 1) (1 1 1 1) (1 1 1 1))
(let ((a (make-array '(4 4) :initial-element 0)))
(incf (the integer (apply #'aref a '(1 1))))
a)
→ #2A((0 0 0 0) (0 1 0 0) (0 0 0 0) (0 0 0 0))
便利なsetfマクロですが、あまり複雑なことはしない方が良いのかなと(月並)
ただ、(setf values)については、色々なソースを眺めていても、あまり活用されていない気がするので、もっと活用されても良いかなと思います。
■
HTML generated by 3bmd in LispWorks 7.0.0
束縛部での変数名の重複
Posted 2020-09-22 00:51:35 GMT
LispWorksでコードを書いていて、
(let ((x 42)
(x 69))
x)
→ 42みたいなものがエラーにならなかったので、コンパイラの最適化のバグか何かかと思って他の処理系でも試してみたところ、SBCLやCMUCL、ECLではエラーになるものの他の処理系では特にエラーにならないようです。
もしや規格上は問題ないのかと思ってHyperSpecを確認してみると、特に記載がない様子。
Common Lispはlambdaに展開される訳ではないので、lambdaでの重複チェックとは別になっているのかなと思い、lambdaも確認してみましたが、
((lambda (x x) x) 42 69)
→ 69これもSBCLやCMUCL、ECL、CCL以外では、エラーにならない様子(CCLはこちらはエラーにするらしい)
λリストについても、重複については特に記載がない様子。
Scheme(R7RS)ではエラーと規定されているので、そういうものだと思っていましたが、実際の処理系で試してみると、Schemeの処理系でも動作はまちまちでした。
Scheme流の「エラーという定義だけど、どうエラーを処理するかは規定しない」ってやつでしょうか。
まとめ
束縛部の変数名の重複チェックが緩いのは、バグの元になるので、何らかの方法でユーザーに通知して欲しいですね。
マクロでコード生成するのが頻繁なLisp系言語では特にですが。
SBCLで虫取りが捗るのは、割とこういう類のチェックが充実しているというのもあると思います。
■
HTML generated by 3bmd in LispWorks Personal Edition 7.1.2
thenretの活用
Posted 2020-09-19 23:44:52 GMT
古えのLucid CLのソースを眺めていて、こんなコードに遭遇したのですが、これがなかなか味わい深い。
コードの作者はJonL氏。
(defun find-named-slot (slot-name slotds &optional (no-error-p nil))
(cond ((loop for slotd in slotds
thereis (and (eq slot-name (%slotd-name slotd))
slotd)))
(no-error-p nil)
(t (system-error hhctb))))condの述語部の返り値を活用しているのですが、Franz Lispのifでいうthenretの活用です。
実際に最近の処理系でも動くように書き直すと下記のようになるでしょうか。
(ついでにloopのthereisもfindに置き換え)
(ql:quickload "closer-mop")
(in-package c2cl)(defun find-named-slot (slot-name slotds &optional (no-error-p nil))
(cond ((find slot-name slotds :key #'slot-definition-name))
(no-error-p nil)
(t (error "How the hell can this be?!"))))
(defclass foo ()
(a b c))
(find-named-slot 'a (class-slots (find-class 'foo)))
→ #<standard-effective-slot-definition a 411021F02B>
(find-named-slot 'z (class-slots (find-class 'foo)))
>> Error: How the hell can this be?!
ちなみに、hhctbは、MACLISPのエラーコードで、“How the hell can this be?!”の略みたいです。
色々検索してもヒットしないので、もしかするとJonL氏以外使ってないんじゃないでしょうか。
上記をifの連鎖で書くと下記のようになります。
(defun find-named-slot (slot-name slotds &optional (no-error-p nil))
(let ((slotd (find slot-name slotds :key #'slot-definition-name)))
(if (not (null slotd))
slotd
(if no-error-p
nil
(error "How the hell can this be?!")))))ifで書き直してみると、no-error-pのあたりも含めて、thenretだけでなくcondを上手く活用していることが分かります。
thenretに類似するところでは、orの返り値を活用するというのがありますが、慣れないと少し解読が難しいかも。
(defun find-named-slot (slot-name slotds &optional (no-error-p nil))
(let ((slotd (find slot-name slotds :key #'slot-definition-name)))
(or slotd
(and (not no-error-p)
(error "How the hell can this be?!")))))ちなみにrmsのLispコードではこういうパタンが多用されています。
まとめ
伝統的なLispでの thenret は多値を返さない(せない)のですが、srfi-61では、多値を活かすことができる仕組みになっています。
(cond ((values 0 1) values => values)
(else #f))アナフォリックマクロのit、when-let等もthenretの文脈に近いものがありますが、慣れると結構活用できる気がします。
■
HTML generated by 3bmd in LispWorks Personal Edition 7.1.2
ボディ部にドキュメンテーション文字列しかない場合について
Posted 2020-09-12 20:14:02 GMT
ボディ部にドキュメンテーション文字列しかない場合について、というのは具体的には、
(lambda (x) "λ[[x]]")(defun foo (x)
"λ[[x]]")
のような場合ですが、上記のように書いてしまうと、ドキュメンテーション文字列ではなくて、返り値(フォームの最後の値)となってしまいます。
(mapcar (lambda (x) "λ[[x]]")
'(0 1 2 3))
→ ("λ[[x]]" "λ[[x]]" "λ[[x]]" "λ[[x]]")
(documentation 'foo 'function)
→ NIL
この場合、二通りの解決策があり、返り値として、nilを明示的に書く、空のdeclareを書くことで回避可能です。
(defun foo (x)
"λ[[x]]"
(declare))
(mapcar #'foo
'(0 1 2 3))
→ (NIL NIL NIL NIL)
空のボディを生成してしまうのが悪いのでは?という話もありますが、マクロ等でコード生成した場合に意図せず生成されてしまうことは結構あります。
この場合、(declare)を入れておく方が、明示的にnilという値を入れるより生成するコードが簡単になるかなと思います。
以上、非常にニッチな話でした。
■
HTML generated by 3bmd in LispWorks Personal Edition 7.1.2
単一ファイル構成のプロジェクトの読み込み
Posted 2020-09-11 19:31:26 GMT
ちょっとした内容を単一ファイルに記述し、それをロードして実行させたいことは結構あります。
こういう場合には論理パスを使うのが便利だということを最近発見したので、それについて書きたいと思いますが、その前に一般的な方法も改めて考察してみましょう。
ASDFを使う
ASDFを使うまでもない、という感もあるのですが、Quickproject等、プロジェクトの雛形をさっと作れるツールがあるので、中身が1ファイルしかないといっても対した手間ではないでしょう。
実際Quicklispにも単一ファイル規模のプロジェクトは結構あります。
ただ、quicklispがセットアップできてなかったり、ASDFのシステムがうまく登録されてなかったりで、すったもんだすることは割とあります。
(ql:quickload 'foo)(foo::main)
みたいなファイルを、lisp --load foo.lisp したりするわけですが、おや結局foo.lispはどこに置けば良いのだろう、などということにもなったりもします。
スクリプト化する
スクリプト実行と親和性の高いCLISPのような処理系では、手軽に#!スクリプトとしてまとめられます。
#!/usr/bin/clisp -norc -q(ql:quickload 'foo)
(foo::main)
みたいな感じで書いて、実行可能ファイルにしてパスの通った所に置けば良いので、そこそこお手軽です。ただCLISP以外はCLISP程の手軽さは感じられないことが多いかなと思います。
また、スクリプト的に書くのか、slime上でそこそこLisp的に開発するのかの間で逡巡することもままあるかなという印象です。
読み込み時のパス変数を使う
ファイルを読み込んだ時に、*load-pathname*や、*load-truename*でパスが取得可能なので、このパスから色々することも可能です。
残念ながらLispマシン等で使われていたdefsystemがANSI Common Lispで標準化されなかったため、プロジェクトの読み込み方法が処理系ごとに大きく違ってしまっていた、1990年代〜ASDFというdefsystemが普及する2000年代あたりまでは、これらのロード時/コンパイル時パスをあれこれしてどうにか対処することもあったようです。
全体的にパスを計算する手間が面倒になる上、それに起因するバグも多くなる印象です。
論理パスを使う
論理パスでは物理パスとは独立に任意のパスを新規に定義できます。
例えば、ホームディレクトリのlispディレクトリを“lisp:”という論理ホストに設定することが可能です。
これで何が可能になるのかというと、(load "lisp:foo")で、~/lisp/foo.lispをロードすることが可能になるので、“lisp:”以下に置かれたlispファイルをロードするという行為がかなり手軽になります。
また、論理パスに対応したエディタであれば、論理パスでファイルがすぐ開けるのも便利で開発が捗ります。
(なお対応しているエディタはほぼありません)
論理パスの設定
論理パスは、logical-pathname-translationsで直に設定してしまっても良いですが、ホストマシン全体で設定する方法がCommon Lispの標準に用意されているので、その手順に従うと色々楽だったりします。
“lisp:”を設定する場合、SBCLの場合は、“sys:site;lisp.translations.newest”に
;;; -*- lisp -*-
(("**;*.*.*" #.(merge-pathnames
(make-pathname :name :wild
:type :wild
:version :unspecific
:directory '(:relative "LISP" :wild-inferiors)
:case :common)
(user-homedir-pathname)))))のような記述をすれば、
(load-logical-pathname-translations "lisp")で上記のファイルを読み込むことが可能です。
“sys:site;lisp.translations.newest”が論理パスですが、
(translate-logical-pathname "sys:site;lisp.translations.newest")で物理パスに変換できるので確認できるでしょう。
以上は、load-logical-pathname-translationsの作法に則った設定ですが、面倒臭ければ、/etc/sbclrcに
(setf (logical-pathname-translations "lisp")
`(("**;*.*" ,(merge-pathnames
(make-pathname :name :wild :directory '(:relative "LISP") :case :common)
(user-homedir-pathname)))))のようなものを書いてしまっても良いでしょう。
provide、requireと論理パスの組み合わせ
論理パスを設定しておけば、あまり利用することもないrequireやprovideの機能を活かすことも可能になります。
上記foo.lispの例であれば、foo.lispの中に、(provide "lisp:foo")と宣言し、読み込まれたら"foo"モジュールが登録されるようにておきます。
読み込みは、
(require "lisp:foo" "lisp:foo")のように明示的にパスを指定してやります。
明示的にパスを指定するので、loadと大差ありませんが、loadと違い、再度読み込みの防止機能があるので、まあこれはこれで便利なこともあるでしょう。
ちなみにモジュール名を論理パスと同じにすると管理が楽です。
まとめ
単一ファイル構成のプロジェクトの読み込みについて論理パスが活用できる可能性について書きました。
隅に置いやられている論理パスですが、使い様によっては結構活用できそうなので、今後も活用法を探っていきたいところです。
■
HTML generated by 3bmd in LispWorks Personal Edition 7.1.2
Common Lisp(1984)の仕様の草稿がCHMで公開
Posted 2020-09-06 16:51:49 GMT
1984年に最初の仕様が公開されたCommon Lispですが、仕様は主に電子メールのメーリングリストで議論し、採用する機能を投票で決めたりと時代を先取りしていました。
Spice Lispのマニュアルを土台に叩き台となる仕様をまとめ、議論して、まとめ、というのを繰り返して、Common Lisp the Language(CLtL1)として出版されたのですが、その中間の草稿についてはネット上には資料が公開されていなかったため色々と謎が多かったりもしました。
そんなCommon Lispの草稿ですが、今年の去る五月にComputer History MusiumのSoftware Preservation Groupのページで公開されていたようです。
公開されたのは、
- Colander Edition (1982-07-29)
- Laser Edition (1982-11-16)
- Excelsior Edition (1983-08-05)
- Mary Poppins Edition (1983-11-29)
の四つで、厳密にいうと他にも草稿はあるようですが、Common Lispの草稿として資料に登場するのは大体この四つです。
どんなことが分かるか
興味深いのは、完成版に近いMary Poppins Editionよりは、最初期のColander Editionかと思いますが、例えば、*macroexpand-hook*は、displaceを導入する目的で導入された、と明記されていたりします。
displaceは主にインタプリタのマクロ展開を速くする機構で、一度展開した展開形を保持するという機構です。
この機能ですが、ANSI CLに至るまでに可搬的に実現するのが困難という結論になり、ANSI CLでは何を目的とした機能なのかの説明もぼんやりしたものになっています。
時系列に並べると
- CL草稿:
displaceのため - CLtL1: マクロ展開をキャッシュ化することによってインタプリタ速度の向上に活用できる
- CLtL2: 当初の目的を果すのは難しいのでデバッグで主に使いましょう
- ANSI CL: 大域変数なのでまずい使い方をするとコードの解釈が一意でなくなるという注意書き
となるのですが、どんどん非推奨な機能に追いやられていることが分かります。
他、スペシャル変数に耳当てがない等、お馴染の慣習も徐々に確定していったことが分かります。 (ちなみに耳当てをつけるのは投票で可決され、定数には特に飾りを付けない、というのも同じ投票で可決されています)
関連
まとめ
ANSI CL規格だけからは導入の動機が良く分からない機能は結構あるのですが、最初期まで遡ることが可能だと経緯がより鮮明に見えてきます。
現在でも、投票の詳細については資料がオンラインにないのですが、投票の詳細について公開されるとかなり面白いことになると思います。
■
HTML generated by 3bmd in LispWorks Personal Edition 7.1.2
Lisp₂のマクロはいうほど不衛生でもない
Posted 2020-08-23 15:18:23 GMT
ざっくりした話ですが、Lisp₁のSchemeには衛生マクロがあるが、Common LispのようなLisp₂は、衛生マクロがないので駄目、みたいな意見を持っている人(主にLisp初学者)はそこそこいると思います。しかし、実際のところ、日々Lisp₂のCommon Lispを使っていてリスト操作のマクロが不衛生で困っちゃうということもありません。
欠点を運用でカバーしているのだ、という話もありますが、これが大した運用でもないというのが実感です。
この実際の感覚のあれこれを説明しようと思っても、Common LispのようなLisp₂のマクロ体系とLisp₁のマクロ体系を比較する、ぱっとした方法がないので、実際のところ比較が難しいのですが、両者でも共通している括弧()のレベルから考えてみることにしました。
関数定義の度に新しい括弧を定義する体系を考えてみる
まず、リスト操作のマクロは、Lisp₂とLisp₁とではあまりにも使い勝手が違います。
端的にいってLisp₂のプログラマの感覚でいうと、Lisp₁上のLisp₂のようなリスト操作のマクロは使い物にならないので一切書かないのが安全という感覚だと思いますが、それについては後述するとして、Lisp₂、Lisp₁で共通の機構を考えてみます。
まず、関数/マクロの定義ごとに新しい括弧の種類を定義するとしてみます。
(defun fib (n)
(if (< n 2)
n
(+ (fib (1- n))
(fib (- n 2)))))のようなものを
(defun 【】 (n)
(if (< n 2)
n
(+ 【(1- n)】
【(- n 2)】)))と定義し、
【10】
→ 55のように動くというイメージです。
括弧はリード時に確定するので、それ以降のフェイズで上書きする術を提供しなければ衛生的です。
※なお、Common Lispにはリーダーマクロがあり、ユーザーが新しい括弧を定義することが可能ですが、ユーザー定義部分に関してはプログラマに委ねられています。
Lisp₂の関数/マクロ定義は括弧を定義しているのに感覚として近い
関数/マクロごとに新しい括弧を用意してみることを考えてみましたが、Lisp₂は、Lisp₂のプログラマの感覚からすると、()+シンボルという唯一であることが保証されたオブジェクトの組み合わせで機能するため、定義の度に新しい括弧を定義するのに近いものとなります。
上記で定義した【の文脈でいうと、(fibという唯一な括弧を新しく定義している、とも考えられます。
つまり、リスト操作でのマクロがどれだけ衛生的かというと、上記表現でいう括弧が再定義されない限りにおいて衛生的ということになるかと思います。
逆に括弧が再定義可能ということであれば、関数呼び出しの記述からして破綻させることが可能なので、衛生マクロであろうと無力です(括弧を保護する仕組みが必要)
なお、(+シンボルの組で括弧であるとした場合、実際にはシンボルはユーザーが通常のプログラミングの範囲で操作するため二点問題が考えられます。
- シンボルの競合問題
- プログラムデータが作るスコープでのシャドウイング問題
生成されたプログラムデータに於て、シンボルの競合については、モジュール管理のフェイズでエラーとすることが可能なためプログラマも管理し易いと思いますが、自動生成されるスコープについては管理が難しいと考えられています。
Lisp₂のCommon Lispで具体的な例を挙げると、
(flet ((list (&rest args)
(apply #'vector args)))
(list 0 1 2))のようなコードが自動生成されることを制御する必要がある、ということになりますが、コード生成をしまくるCommon Lispでも実際には問題となることはあまりありません。
これは上述のように、Lisp₂に於ける関数定義では新しい括弧を定義しているような意味合いが強く、変数名と関数名の競合を意識することがないプログラミングスタイルであることが理由だと考えられます。
換言すれば、関数名と変数名が競合しないのがメリットなので、敢えて競合させるようなコードを生成させた挙句に結果として余計な問題に悩んだりしたくないので避けるということかと思います。
関数名と変数名が同一なのがメリットのSchemeにおいて敢えて名前を競合させてデメリットを助長させるようなことはしないのに似ています(もちろんたまにいますが)
(define (foo list args)
(list args))リスト操作のマクロでいうと、Lisp₁の場合は、さらに変数名との競合も考慮する必要があります。
加えてマクロが展開された周辺とも名前の競合を考慮する必要がありますが、Lisp₂のプログラマの感覚からすると制御が難しすぎて実質使い物にならないという感想が多いでしょう。
(だから衛生マクロが登場したともいえますが)
コード生成について
Lisp₂のCommon Lispでは、defmacroが単なるリスト生成であることが殆どですが、マクロでなくともユーザーがプログラムでコードを生成するということが手軽に安直に行なわれています。
この場合、生成されるコードは、機械向けの呪文ではなく、人間が書くようなスタイルのコードが生成されることが多い印象ですが、リスト生成に毛が生えた程度でも人間が読め、制御も可能であるようなコードが生成可能であるというのが大きいと思われます。
defmacroのような手書きのコードから一括生成の大量の自動生成のコードまで連続しているというのがポイントです。
Lisp₂以外で、人間が読めるようなコードを安直に生成している文化はあまり目にしたことがないのですが、どうなのでしょうか。
まとめ
上記では、関数の名前と変数の名前が競合する局面について書きました。
Lisp₂のマクロでの変数名の競合は、一時的な変数名を生成したり(gensym)、スコープを作る構文に展開することで簡単にコントロールできるものとされています。
マクロ展開での変数名(識別子)の競合や生成は、メリットともデメリットともされていて、SchemeでもLisp₂でメリットとされて来たことを取り込もうとする等、人間がコントロールする範囲のものと捉えられている節もあるので今回は省いています。
また、Lisp₁上でも、識別子を展開するのではなく、マクロ定義時に関数オブジェクトを取り込み、それをマクロ展開してしまうことによって、名前の競合を起さないテクニックもあるようです。
これでも良さそうですが、コードの字面とオブジェクトとで乖離してしまうので管理が難しそうです。
結局のところ関数名というのは変数名と違って大域なことが殆どですが、これは大域的な名前を操作してプログラミングするという人間の慣習を反映しているのでしょう。
Lisp₂はこの点とも親和性が高いと思います(たまたま先入観が反映された感は強いですが)
■
HTML generated by 3bmd in LispWorks Personal Edition 7.1.2
Interlisp-DがOSSになって帰ってきた!
Posted 2020-08-20 00:30:51 GMT
ここ最近Interlisp-D復活のプロジェクトが活発でOSS化が進んでいるらしいというのは眺めていましたが、いつの間にやら仮想Interlisp-D環境であるmedleyが最近のOS上で動くようになっているようです。
以前もmedleyは古いOSを用意すれば動かせたりしましたが、最近のOS上でも動かせるというのは非常に嬉しい。
導入
下記はlinux x86_64で導入する場合です。 clang等が必要ですが適宜インストールしましょう。
git clone https://github.com/Interlisp/maiko.gitcd bin
export PATH=.:$PATH
makeright x
上記でビルドが完了すると、maikoディレクトリの直下のマシンアーキテクチャ名のディレクトリ中にldexが生成されていますので、medleyのsysoutイメージを指定して起動できます。
./linux.x86_64/ldex full.sysoutsysoutイメージは、interlisp.orgに記載のあるRon’s Interlisp dropboxでも数種類配布されているので、適宜利用してみるのも良いでしょう。
とりあえず、手元では、古いmedleyで動かしていたイメージが起動しました。
今後の展開
OSS化されたということで、処理系のソース等も読めるようになるのかもしれません(既に読める?)
個人的にはLOOPSを触ってみたいと思っています。
関連
■
HTML generated by 3bmd in LispWorks Personal Edition 7.1.2
S式は前置記法でなくても良い
Posted 2020-07-28 21:59:39 GMT
S式といえば、逆ポーランド記法(前置記法)という印象がありますが、肝要なのはS式というデータでコードを記述することなので、特に前置でなければいけないということもない筈です。
そもそも、点対リストの記法は中置じゃないかと思うのですが、どうなのでしょう。
(a . d)前置であれば、
(. a d)となりそうですが、これでも特に問題はなさそうに思えます。
ちなみにPrologでは、[a|d]というリスト表記は、'.'(a,d)の糖衣構文らしく'.'は前置記法ですが、Lispに由来したものなのかどうなのか。
% az-prolog
%
| ?-'.'(a,d)=[a|d].
yes点対リストの発展形
点対リストのドットは中置ではないかと書きましたが、Plasma(1974)には、この点対リストの記法を発展させたような記法(x op y)をメインに使用します。
なお、私個人の解釈では、Hewitt先生は、点対リストのドットをオペレーターとして解釈し、点対リスト記法を発展させているように見えるのですが、Plasmaの文献を眺めていてもドットを発展させたという記述は見付けられていないので、完全に独自解釈かもしれません。予めご了承下さい……。
少なくとも、リストの二番目に特別な記号があれば○○するというような構文の作り方ではない気がするのですが。
メッセージ送信
Plasmaではメッセージ送信は、(A <= M)と記述し、Lispでいう関数呼び出しに相当します。
矢印は逆転して記述することも可能で、(M => A)でも可です。
また、(A <= [x y z])の省略形はLispの関数フォームのように、(A x y z)と書けます。
この矢印がLispの点対リストの.に相当します。
なお、[x y z]は配列です。
四則演算
四則演算の+,-,*,/等もまた特別扱いされます。
(1 + 1)
→ 2Common Lispで()を再定義するとしたらこんな感じでしょうか
(progn
(flet ((rdseq (srm chr)
(let ((xpr (read-delimited-list #\] srm T)))
(if (= 3 (length xpr))
(let ((op (cadr xpr))
(x (car xpr))
(y (caddr xpr)))
(case op
(≡ (list 'define x y))
((=)
(list x y))
(otherwise (coerce xpr 'vector))))
(coerce xpr 'vector)))))
(set-macro-character #\[ #'rdseq))
(set-syntax-from-char #\] #\))
;;;
(flet ((rdparen (srm chr)
(declare (ignore chr))
(let ((xpr (read-delimited-list #\) srm T)))
(if (= 3 (length xpr))
(let ((op (cadr xpr))
(x (car xpr))
(y (caddr xpr)))
(case op
(<= (cons x (coerce y 'list)))
(=> (cons y (coerce x 'list)))
((+ - * / < > =< >=)
(list op x y))
(otherwise xpr)))
xpr))))
(set-macro-character #\( #'rdparen)))(list
(list <= [42])
(list 42)
(list 0 1 2 3)
([0 1 2 3] => list)
([(42 + 69) (42 - 69) (42 * 69) (42 / 69)] => list))
→ ((42) (42) (0 1 2 3) (0 1 2 3) (111 -27 2898 14/23))ちなみに、(の再定義は危険なので、全角括弧ででも試した方が良いかもしれません……。
定義構文
関数(アクタ)定義は、配列+≡の中置です。
Schemeのように、(define fcn (lambda (arg ...) ...))パタンと、左辺?に引数も記述する(define (fcn arg ...) ...)パタンがあります。
思えば、Lisp 1.5の頃からこの二種類は存在するようなのですが、大元はLisp 1.5なのでしょうか。
Plasmaでは下記のように書けます。
(なお、Plasmaにlambdaはありません)
[tak ≡ (lambda (x y z)
(if (not (x > y))
z
([([(x - 1) y z] => tak)
([(y - 1) z x] => tak)
([(z - 1) x y] => tak)] => tak)))]
[(tak x y z) ≡ (if (not (x > y))
z
([(tak (x - 1) y z)
(tak (y - 1) z x)
(tak (z - 1) x y)] => tak))]
([18 12 6] => tak)
→ 7
Common Lispで再現してみるなら、≡を中置のdefineと考え、二種のパタンそれぞれに展開するマクロにでもなりそうです。
(defmacro define (name expr)
(etypecase name
(cons `(defun ,(car name) (,@(cdr name))
,expr))
(symbol
`(progn
(declaim (function ,name))
(setf (fdefinition ',name) ,expr)))))まとめ
点対リストの記法の発展形をPlasmaを源流と捉えてつらつら書いてみましたが、点対リストの形式(x op y)には、未だ開拓されていない可能性があるようなないような。
(x op y)と書けると一体何が嬉しいのか、という気もしますが、ではLispがこれまで(a . d)と書いてきて一体何が嬉しかったのか、と思わないでもないです。
Hewitt先生の記法のアイデアは中置のS式に限らず結構面白いものが多いので、今後もちょこちょこ紹介していきたいと思います。
(絵文字や上付き/下付きのS式等々……)
参考
- A PLASMA PRIMER / Brian C. Smith, Carl Hewitt (1975)
■
HTML generated by 3bmd in LispWorks Personal Edition 7.1.2
ストリームをreadしてその文字列表現を取り出す
Posted 2020-07-26 16:49:52 GMT
ストリームを読み込んで、一つのS式を得るにはreadを使えば良いのですが、その文字列表現を得るのは結構面倒という話をSNSで見掛けました。
いや、with-output-to-string等を使えばreadの結果を文字列として取り出すのは簡単じゃないかなと思ったのですが、これでは上手く行かない状況があるのかもしれません。
;;; 単純な例
(setq *print-circle* T)(with-output-to-string (out)
(with-input-from-string (in "#0=(0 1 2 3 . #0#)")
(print (read in) out)))
→ "
#1=(0 1 2 3 . #1#) "
例えば、存在しないパッケージを含んだ表現を読み込むとエラーになる場合であったり、
(with-output-to-string (out)
(with-input-from-string (in "(foo:bar baz)")
(print (read in) out)))
!! Error: Reader cannot find package FOO.コメントを読み飛ばしたくない場合であったり、
(with-output-to-string (out)
(with-input-from-string (in "(foo bar #|baz|#)")
(print (read in) out)))
→ "
(FOO BAR) "しかし、これらはreadの挙動ではないので、readした結果の文字列ではない気がしますが……。
とはいえ、Lispのプリティプリンタ等を作成する場合等でCommon Lispのreadをうまいこと流用しつつ都合良くreadの標準の挙動を越えた結果が欲しい場合もあります。
make-echo-stream というマイナー機能
上述のように、コメントを読み飛ばしたくない場合や、存在しないパッケージは無視してシンボルのトークンとして読み込みたい場合、元ストリームのecho-streamを作成した状況で、*read-suppress*をTにしてreadを動かし、echo-streamに軌跡を出力するという技が使えます。
具体的には、
(defun read-to-string (&optional (stream *standard-input*)
(eof-error-p T)
eof-value
recursivep
(junk-allowed T))
(with-output-to-string (outstring)
(let* ((stream (make-echo-stream stream outstring))
(*read-suppress* junk-allowed))
(read stream eof-error-p eof-value recursivep))))こんな感じのものを作成します。
(setq *print-circle* nil)
(dolist (xpr '("#0=(0 1 2 3 . #0#)"
"(foo:bar baz)"
"(foo bar #|baz|#
;; comment)"
))
(with-input-from-string (in xpr)
(print (read-to-string in))))
▻
▻ "#0=(0 1 2 3 . #0#)"
▻ "(foo:bar baz)"
▻ "(foo bar #|baz|#
▻ ;; comment
▻
▻ )"
→ NIL解説
まず、make-echo-streamですが、read系の関数が読み取ったものを出力するというストリームです。エラーログを出力する場面等で便利な気はしますが、結構マイナーな機能です。
HyperSpecでも読み取ったものを文字列として返す例が紹介されています。
次に*read-suppress*ですが、元来これは、#-、#+を処理するための機能であり、Lispのトークンとして読み込めるレベルのものを適切に無視することが可能です。
これらを組み合せるとreadエラーは回避しつつLispのトークンとして読み込み、文字列として出力することが可能です。
参照
■
HTML generated by 3bmd in LispWorks Personal Edition 7.1.2
束縛部を外から与えるフォーム
Posted 2020-07-23 17:31:13 GMT
bit誌1975-01月号 「連載LISP入門 (13) Backtrack法とLisp」にはbindqというフォームが出てきます。
(1974年から1975年にかけてのbit誌での後藤英一先生のLisp連載)
HLISP独自のようですが、M式で書くと、
bindq[x;y;form]のような形式でCommon Lispでいうprogvに似た形式です。
qはquoteのqですが、formがクォートされるので、Common Lispで実装すると、
(defmacro bindq (vars vals form)
`(let (,@(mapcar #'list
(eval vars)
(eval vals)))
,form))となります。
(let ((x 0))
(bindq (list 'x 'y)
(list 'x 42)
(progn (list x y))))
→ (0 42)という動作ですが、クォートされた変数名がレキシカル変数を捕むという表記はCommon Lispの作法からすると気持ち悪いかもしれません……、と書いているうちに、HLISPはレキシカルスコープじゃないし、要するにprogvではないかとどんどん思えてきました。
この記事を書き始めたときには、とりあえずレキシカルスコープでprogv的なもの、ということを考えていたのですが……、とりあえず、このまま続けることにします。
スコープを作るフォームの束縛部のデータ
前述bindqや、progvではフォームの束縛部のデータ型はリストでした。
letでも((var val))はリストですが、クォートされていて実行時に生成されるリストではありません。
上述で実装したbindqは実行時に評価されそうな見た目ですが、マクロ展開時にフォームは固定されます。
マクロ展開時までに確定できれば変数でも大丈夫ですが、評価フェイズによってはエラーになったりするので、Common Lispの構文作法としてはあまり良くないでしょう。
(defvar *vars* '(x y))
(defvar *vals* '(0 42))(bindq *vars* *vals* (list x y))
→ (0 42)
まあでも一つの可能性としては面白いかもしれません。
Plasmaでの束縛部のデータ
リスト以外の束縛部のデータといえば、最近だとClojureが配列を採用していますが、古くは、Plasma(1974)があります。
Plasmaでは、sequenceという配列が[]で表記され、setという集合が{}で表記されていますが、これらが、束縛部で使われます。
(let
{[x = 42] [y = 0]}
...)(labels
{[fib ≡
(cases
(≡> [0] 0)
(≡> [1] 1)
(≡> [=n]
(fib (n - 1) + (fib (n - 2)))))]}
...)
束縛部全体は集合で表記され、変数名と値の対は配列で表記されます。
面白いのが、束縛部を変数として与えることが可能なところで、
[math-definitions =
{[factorial ≡ ..]
[fibonacci ≡ ..]
[cosine ≡ ..]}](labels math-definitions body)という記述が可能とされています。
上記では、labelsのスコープ内に導入しますが、大域環境に定義するenterという機能もあります。
(enter math-definitions)Plasmaはレキシカルスコープな筈ですが、この辺り実際レキシカルスコープで実現するのは難しそうな機能です。
実際どういう実装がされていたのかは謎……。
ちなみに、Common Lispで真似るならこんな感じでしょうか。
マクロ展開時までに束縛部のデータが確定していれば機能しますが、そうでない可能性を考えると脆弱な仕組みということが分かります。
(progn
(flet ((rdset (srm chr)
(let ((tab (make-hash-table :test #'equal)))
(dolist (elt (read-delimited-list #\} srm T) tab)
(if (and (typep elt '(vector T 3))
(member (elt elt 1) '(= ≡)))
(setf (gethash (elt elt 0) tab)
(elt elt 2))
(setf (gethash elt tab)
T))))))
(set-macro-character #\{ #'rdset))
(set-syntax-from-char #\} #\)) (flet ((rdseq (srm chr)
(coerce (read-delimited-list #\] srm T) 'vector)))
(set-macro-character #\[ #'rdseq))
(set-syntax-from-char #\] #\))
)
(defpackage plasma
(:use)
(:export let labels))
(defmacro plasma:let (binds &body body)
(let ((binds (eval binds)))
(check-type binds hash-table)
`(let ,(loop :for var :being :the :hash-keys :of binds :using (:hash-value val)
:collect `(,var ,val))
,@body)))
(plasma:let
{[x = 42] [y = 0]}
(list x y))
===> (let ((x 42) (y 0)) (list x y))
(defvar *binds* {[x = 42] [y = 0]})
(plasma:let *binds* (list x y))
→ (42 0)
まとめ
束縛部を実行時データとして与えるというのは動的すぎるとしても、コンパイル時までに与えるというのは活用できる局面があったりするかもしれません。
実際の所、Common Lispではリード時までに与えるというのはたまにありますが、declare等のコンパイラへの指示等が殆どで、束縛部を後で与えたいということは殆どないとは思いますが。
(defvar *bindspec* '((x 42) (y 0)))(let #.*bindspec* (list x y))
→ (42 0)
参考
- A PLASMA PRIMER / Brian C. Smith, Carl Hewitt (1975)
■
HTML generated by 3bmd in LispWorks Personal Edition 7.1.2
暗黙のprognならぬ暗黙のlet
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