多重ディスパッチの実装 on Parenscript
lisp Advent Calendar 201810日目の記事です。
今年はCommon LispサブセットをJavaScriptに変換するParenscript + three.js な2Dゲームライブラリ（もどき）のcl-web-2d-gameが育ってきたので、テトリスを作ってみたりブロック崩しを作ってみたりして遊んでいました。コンポーネントベースであることもあり、この範囲では特に型ディスパッチが必要になることはありませんでした。
が、A*アルゴリズムを作ったりして遊んでいると、ナビゲーションメッシュ部分を抽象化してみたくなりました。とすると型によるディスパッチが必要になるので、defgeneric, defmethodのサブセットという形で多重ディスパッチを実装することにしました。これは、cl-web-2d-gameの基盤にもなっている、Parenscriptの独自拡張ps-experiment上に実装します。
なお、Parenscript用のCLOSのサブセット実装としてPSOSがあるのですが、今回欲しいのは多重ディスパッチ部分だけだったことと、なんとなく面白そうだったので自前実装しました。
実装しないもの
今回実装するものはdefgenerc, defmethodのサブセットも良いところなので足りないものは多々ありますが、代表的なものは次のあたりでしょうか。
- generic function未定義時に
defmethodしたときのデフォルト定義 eqlによるディスパッチ- 言い換えると型によるディスパッチしかできません
fmakunbound- メソッドコンビネーション
- standardについても
:before,:after,:aroundはありません……
- standardについても
余談ですが、できたらメソッドコンビネーションも実装してみようかと define-method-combination について調べていた副産物が Lisp メソッドコンビネーション Advent Calender 2018の3日目の記事（define-method-combinationを理解する）でした。が、利用する見込みもないのに実装するには少々重いことが分かったため頓挫しました。決して Besiegeにハマっている内にどうでも良くなってきた訳ではないのです。
なお、仕様の全体は一応ps-experimentのREADMEに記載しています。
前提：ps-experiment
今回、Parenscript上にdefmethodのサブセットを起こしていくということで、マクロとして実装する部分はCommon Lispとして、実行時に動作する部分はParenscript (JavaScript) として実装していくことになります。後者の実装にはParenscriptをラップして勝手に色々拡張しているps-experiment *1 を利用します（今回の多重ディスパッチ自体もこのライブラリ内に実装します）。
今回主に使うのはJavaScript関数を定義する defun.ps+ 程度なので、簡単に使用例を見てみます。
基本的には下記のように、普通のdefunのような感覚で関数を定義したりexportしたりできます。
CL-USER> (use-package :ps-experiment) T CL-USER> (defun.ps+ func1 (a b) (+ a b)) FUNC1 CL-USER> (defun.ps+ func2 (a) (+ a 100)) FUNC2 CL-USER> (export 'func2) T
これをJavaScriptコードとして書き出すのが、with-use-ps-packというさえない名前のマクロです。これは、第一引数に渡されたパッケージ（群）を起点に依存パッケージを含めてJavaScriptコードを書き出します。第2引数以降 = form部分に受け取ったものはトップレベルで実行する処理として書き出します。
次のように、先程定義したfunc1やfunc2が書き出され、func2がエクスポートされていることが分かります*2。
CL-USER> (with-use-ps-pack (:this) ; :this は *package* のエイリアス (func2 200)) var commonLispUser = (function() { /* --- import symbols --- */ /* --- define objects --- */ function func1(a, b) { return a + b; }; function func2(a) { return a + 100; }; function __psMainFunc__() { return func2(200); }; /* --- extern symbols --- */ return { 'func2': func2, '_internal': { 'func1': func1, '__psMainFunc__': __psMainFunc__, } }; })(); commonLispUser._internal.__psMainFunc__();"
REPL上で簡単に動作確認をしたい場合、cl-javascript (cl-js)が利用できます。cl-js:run-js関数にJavaScriptコードを渡すことで実行してくれるため、下記のようなjst *3 マクロを定義しておくことで、サクッとREPL上でお試しすることができます。
CL-USER> (defmacro jst (&body body) `(cl-js:run-js (with-use-ps-pack (:this) ,@body))) JST CL-USER> (jst (func2 20)) 120
最後に細かい点ですが、以降ではdefun.ps, defun.ps+と似たような名前のマクロを使い分けています。前者はJavaScript関数のみを、後者はそれに加えてCommon Lisp関数を書き出します。今回両者で共通利用する関数はないのですが、後者であればCommon Lispコンパイラの恩恵（関数の引数違いの警告など）を得られるため、可能な限り後者を利用します。なお、厳密に言うとdefun.psは実装が空でシグネチャが同じCommon Lisp関数も書き出すので、defun.psで定義した関数はdefun.ps+内で利用しても警告なしにコンパイルできます（実行したら勿論エラーですが…）。空関数の定義も避けたい場合はdefun.ps-onlyを利用します。後ろでも少し使います。
実装
基本的なアイディア（データ構造）
後ろに細々と実装が続きますが、基本的なアイディアは単純です。
主要なデータ構造は次のものになります（defstruct.ps+とdefvar.ps+もps-experimentの持ちものですが、名前から動作は推測できると思います）。
(defstruct.ps+ dispatch-item type-list func) (defvar.ps+ *dispatch-list-table* (make-hash-table) "Key: method name, Value: sorted list of dispatch-item")
*dispatch-list-table* には、メソッドごとに dispatch-item のリストを格納します。このdispatch-itemはdefmethodごとに生成されます。例えば次のような定義に対しては、type-listには(type-a nil)が格納され、func には関数の実体（単純化すると(lambda (a b) (print a) (print b))）が格納されます。
(defmethod.ps+ test ((a type-a) b) (print a) (print b))
これを踏まえて、今回実装するdefgenericとdefmethodの役割は次のようになります。
defgeneric*dispatch-list-table*へメソッド名をキーとして空のリストを追加する- メソッド名と同名の関数を
defunする- この関数内では、
dispatch-itemのリストから適用可能な関数を探して呼び出す
- この関数内では、
defmethoddispatch-itemを作成し*dispatch-list-table*内からメソッド名で探したリストに格納するtype-listを生成し、よりspecificな型のものが手前に来るようにソートして格納する- 動的に型の上下関係が変わるケースを想定すると事前ソートはNGだが、そのケースは考えない
funcにはdefmethodで指定した処理をlambda関数にして詰め込む。この際、下記2つのローカル関数を付け加える
ゴール
先にdefgeneric, defmethod自体の実装を見てしまいます。実装に必要な補助関数群は後ろでチクチク見ていきます。
defgeneric
実装
defgeneric.psやdefgeneric.ps+の実体となる defgeneric.ps-onlyは、「基本的なアイディア」の項で述べたものを実装していきます。
(defstruct defgeneric-options (documentation "")) (defmacro defgeneric.ps-only (function-name gf-lambda-list &rest options) (let ((opt (parse-defgeneric-options options)) (call-list (convert-gf-lambda-list-to-call-list gf-lambda-list))) `(progn (def-top-level-form.ps ,(symbolicate '_defgeneric_form_ function-name) ;; -- *dispatch-list-table*へ空のリストを追加 -- (setf (gethash ,(make-table-key function-name) *dispatch-list-table*) (list))) ;; -- メソッド名と同名の関数を定義 -- (defun.ps-only ,function-name ,gf-lambda-list ,(defgeneric-options-documentation opt) ;; -- 最もspecificなメソッドを呼び出す -- ,(call-next-method% :function-name function-name :lambda-list gf-lambda-list :call-list call-list :start-func-index 0)))))
さほど見るべき所もないのですが、メソッドコンビネーションがないのを良いことに、最もspecificなメソッドを呼び出すだけにしているのが特徴と言えば特徴でしょうか。
寄り道ですがdef-top-level-form.psの補足です。ps-experimentでは各種defineが評価されたときに定義を格納する（格納したものをwith-use-ps-packで書き出す）形を取っているため、トップレベルのフォームをParenscriptコードとして認識すことができません。そのため、トップレベルのフォームを定義するための専用のdefineを用意するという苦肉の策に出ています。しかも、再評価時に上書きして良いかを判断するために、第1引数に識別子となるシンボルを渡している辺りがさらに冴えない感じです。
さて、このdefgeneric.ps-onlyを使って、主なインタフェースとなるdefgeneric.psとdefgeneric.ps+を次のように実装します。前者はCommon Lispとしてはいわゆる宣言だけを行うためのものですが、defgenericは定義（form）部分を持たないので後者と全く同じ形になります。
(defmacro defgeneric.ps (function-name gf-lambda-list &rest options) `(progn (defgeneric.ps-only ,function-name ,gf-lambda-list ,@options) (defgeneric ,function-name ,gf-lambda-list ,@options))) (defmacro defgeneric.ps+ (function-name gf-lambda-list &rest options) `(defgeneric.ps ,function-name ,gf-lambda-list ,@options))
展開してみる
展開形も見てみます。
(defgeneric.ps-only some-method (a b) (:documentation "This is a sample method"))
まずはこれが次のようにマクロ展開されて…
(progn (def-top-level-form.ps _defgeneric_form_some-method (setf (gethash "COMMON-LISP-USER::SOME-METHOD" ps-experiment/defines/defmethod::*dispatch-list-table*) (list))) (defun.ps-only some-method (a b) "This is a sample method" (let* ((ps-experiment/defines/defmethod::table-key "COMMON-LISP-USER::SOME-METHOD") (ps-experiment/defines/defmethod::func-index (let ((ps-experiment/defines/defmethod::table-key "COMMON-LISP-USER::SOME-METHOD")) (ps-experiment/defines/defmethod::find-dispatch-func-index ps-experiment/defines/defmethod::table-key (list a b) :from 0 :if-does-not-exist :error)))) (funcall (funcall (ps-experiment/defines/defmethod::get-dispatch-func ps-experiment/defines/defmethod::table-key ps-experiment/defines/defmethod::func-index) ps-experiment/defines/defmethod::func-index) a b))))
次のようなJavaScriptコードになります。
psExperiment_defines_defmethod._internal.DISPATCHLISTTABLE['COMMON-LISP-USER::SOME-METHOD'] = []; /** This is a sample method */ function someMethod(a, b) { var tableKey69; var tableKey = 'COMMON-LISP-USER::SOME-METHOD'; var funcIndex = (tableKey69 = 'COMMON-LISP-USER::SOME-METHOD', psExperiment_defines_defmethod._internal.findDispatchFuncIndex( tableKey69, [a, b], 'from', 0, 'if-does-not-exist', 'error')); return psExperiment_defines_defmethod._internal.getDispatchFunc(tableKey, funcIndex)(funcIndex)(a, b); };
defmethod
実装
defmethod.ps-onlyについても、同様に「基本的なアイディア」で述べたものを実装します。
(defmacro defmethod.ps-only (function-name specialized-lambda-list &body body) (let* (; dispatch-item-type-list = dispatch-types の生成 (dispatch-types (extract-dispatch-types specialized-lambda-list)) (lambda-list (convert-specialized-lambda-list-to-lambda-list specialized-lambda-list)) (call-list (convert-gf-lambda-list-to-call-list lambda-list)) (table-key (make-table-key function-name)) (dispatch-func-index (gensym))) `(def-top-level-form.ps ,(symbolicate '_defmethod_form_ function-name (format nil "_(~{~A~^ ~})" dispatch-types)) ;; dispatch-itemをリストへ追加する（内部でspecificな順にソート） (push-dispatch-func ,table-key ',dispatch-types ;; 外側のlambda: 関数のインデックスを保管（これがdispatch-item-funcの実体） (lambda (,dispatch-func-index) ,(flet ((declare-p (line) (and (listp line) (eq (car line) 'declare)))) ;; 内側のlambda: 処理の実体 `(lambda ,lambda-list ;; declare部の取り出し ,@(loop :for line :in body :until (not (declare-p line)) :collect line) ;; 内部関数としてcall-next-method, next-method-pを実装 (flet ((call-next-method ,lambda-list ,(call-next-method% :function-name function-name :lambda-list lambda-list :call-list call-list :start-func-index `(1+ ,dispatch-func-index))) (next-method-p () (not (null ,(find-dispatch-func-index% :function-name function-name :lambda-list lambda-list :start-func-index `(1+ ,dispatch-func-index) :if-does-not-exist nil))))) ;; 本来の処理の実体 (declareは取り除く) ,@(member-if (lambda (line) (not (declare-p line))) body)))))))))
主にcall-next-methodやnext-method-pの実装のためにやたら長ったらしいです。
ソース中に入れたコメントで概ね雰囲気は掴めるかと思いますが、push-dispatch-func へ渡している関数が二重lambdaになっている点が少々特徴的な部分でしょうか。前述のように、メソッドごとにdispatch-itemがspecificな順にソートされてリストに入っている訳ですが、call-next-methodで次のメソッドを呼び出すためには自身が何番目の要素であるかを知っている必要があります。ということで、外側のlambdaではdispatch-func-indexとして自身が何番目の要素であるかを受け取ります。なお、通常のLispであればリストのcdr部を取っておきたい所ですが、リストはJavaScriptの配列に変換されることを意識してインデックスを利用しています。
内側のlambdaが実際に外から引数を受け取って呼び出される処理の実体です。ここでローカル関数としてcall-next-methodとnext-method-pを実装しています。どちらもstart-func-indexを起点に次のメソッドを探すため、両方を呼ぶと探索が二回走ります。が、next-method-pなんてそんな使わんだろうと思って妥協しています…。
他にそれほど特徴らしいところもありませんが、冒頭のlet*内でspecialized-lambda-listをあれこれパースしている部分の例を見てみます。
例. specialized-lambda-form: (a (b type-b) &key (c 100)) -> dispatch-types: (nil type-b) lambda-list : (a b &key (c 100)) call-list : (a b :c c)
このdefmethod.ps-onlyを使って、主なインタフェースとなるdefmethod.psとdefmethod.ps+を次のように実装します。前者では空のCommon Lispメソッドを実装するためにignore宣言を入れたりエラーを入れたりで少々長くなっています。
(defmacro defmethod.ps (function-name specialized-lambda-list &body body) (let ((args (mapcar (lambda (elem) (if (listp elem) (car elem) elem)) specialized-lambda-list))) `(progn (defmethod.ps-only ,function-name ,specialized-lambda-list ,@body) (defmethod ,function-name ,specialized-lambda-list (declare ,(cons 'ignore (extract-arg-names args))) (error (format nil "~A for ~A is only defined but not implemented as a CL method" ',function-name ',(extract-dispatch-types specialized-lambda-list))))))) (defmacro defmethod.ps+ (function-name specialized-lambda-list &body body) `(progn (defmethod.ps-only ,function-name ,specialized-lambda-list ,@body) (defmethod ,function-name ,specialized-lambda-list ,@body)))
展開してみる
こちらも展開形を見てみます。
(defmethod.ps-only some-method ((a type-a) b) (compute-something a b))
まずはこれが次のようにマクロ展開されて…
(def-top-level-form.ps _defmethod_form_some-method_\(type-a\ nil\) (ps-experiment/defines/defmethod::push-dispatch-func "COMMON-LISP-USER::SOME-METHOD" '(type-a nil) (lambda (#:g1262) (lambda (a b) (flet ((call-next-method (a b) (let* ((ps-experiment/defines/defmethod::table-key "COMMON-LISP-USER::SOME-METHOD") (ps-experiment/defines/defmethod::func-index (let ((ps-experiment/defines/defmethod::table-key "COMMON-LISP-USER::SOME-METHOD")) (ps-experiment/defines/defmethod::find-dispatch-func-index ps-experiment/defines/defmethod::table-key (list a b) :from (1+ #:g1262) :if-does-not-exist :error)))) (funcall (funcall (ps-experiment/defines/defmethod::get-dispatch-func ps-experiment/defines/defmethod::table-key ps-experiment/defines/defmethod::func-index) ps-experiment/defines/defmethod::func-index) a b))) (next-method-p nil (not (null (let ((ps-experiment/defines/defmethod::table-key "COMMON-LISP-USER::SOME-METHOD")) (ps-experiment/defines/defmethod::find-dispatch-func-index ps-experiment/defines/defmethod::table-key (list a b) :from (1+ #:g1262) :if-does-not-exist nil)))))) (compute-something a b))))))
次のようなJavaScriptコードになります。
psExperiment_defines_defmethod._internal.pushDispatchFunc(
'COMMON-LISP-USER::SOME-METHOD',
[typeA, null],
function (g1251) {
return function (a, b) {
var callNextMethod = function (a, b) {
var tableKey90;
var tableKey = 'COMMON-LISP-USER::SOME-METHOD';
var funcIndex = (tableKey90 = 'COMMON-LISP-USER::SOME-METHOD',
psExperiment_defines_defmethod._internal.findDispatchFuncIndex(
tableKey90, [a, b],
'from', g1251 + 1,
'if-does-not-exist', 'error'));
return psExperiment_defines_defmethod._internal.getDispatchFunc(tableKey, funcIndex)(funcIndex)(a, b);
};
var nextMethodP = function () {
var tableKey;
return (tableKey = 'COMMON-LISP-USER::SOME-METHOD',
psExperiment_defines_defmethod._internal.findDispatchFuncIndex(
tableKey, [a, b],
'from', g1251 + 1,
'if-does-not-exist', null))
!= null;
};
return computeSomething(a, b);
};
});
こうしてマクロの中に実装が畳み込まれている様を見ると気分が良いですね :-)
道具作り
あとは淡々と defgenerc.ps-only, defmethod.ps-only の実装で利用していた道具を作っていきます。
大きくは次の2つです。
- Parenscript（JavaScript）側: 実行時の各種補助関数（主に型に関する処理）
- Common Lisp側: マクロ用の各種補助関数（主に
lambda-listのパース）
Parenscript（JavaScript）部分
Parenscript側で行うのは主に型に関する処理です。下記2種類の処理が必要になります。
- 型とインスタンスの比較
- 実行時 = メソッド呼び出し時のディスパッチに利用します
- 型同士の比較
- 定義時 =
defmethodの際に実施するソートに利用します
- 定義時 =
型とインスタンスの比較
型とインスタンスの比較を行うための基本的な関数が以下になります。
(defun.ps instance-dispatch-p (test-instance target-type) (or (null target-type) (instanceof test-instance target-type))) (defun.ps+ instance-list-dispatch-p (test-instance-list target-type-list) "Note: Used for dispatching in execution time" (assert (= (length test-instance-list) (length target-type-list))) (loop for test-instance in test-instance-list for target-type in target-type-list do (unless (instance-dispatch-p test-instance target-type) (return-from instance-list-dispatch-p nil))) t)
まず、下記のような定義と呼び出しを例として、instance-list-dispatch-pの引数の内容をそれぞれ示します。
(defmethod.ps+ some-method ((a type-a) b)...) (some-method x y)
test-instance-list:(x y)target-type-list:(type-a nil)
これをinstance-dispatch-pに渡して1つ1つチェックしていきます。なお、型判別をinstanceofによって行っているため、プリミティブ型を扱えないという重大な制限があります…。当面自身で定義した型だけで利用するつもりですが、そのうち直すかもしれません*4。
さて、ここで定義したinstance-list-dispatch-pを利用して、実行時にディスパッチ可能な関数（のリスト内でのインデックス）を探し出すのが次のfind-dispatch-func-indexです。
(defun.ps+ find-dispatch-func-index (function-name instance-list &key (from 0) (if-does-not-exist :error)) (let ((dispatch-item-list (gethash function-name *dispatch-list-table*))) (unless dispatch-item-list (error "There is no generic function \"~A\"" function-name)) (loop :for i :from from :below (length dispatch-item-list) :do (let ((item (nth i dispatch-item-list))) (when (instance-list-dispatch-p instance-list (dispatch-item-type-list item)) (return-from find-dispatch-func-index i)))) (case if-does-not-exist (:error (error "Can't find a function for ~A" instance-list)) (t nil))))
前述のように、dispatch-item-listはspecificな順にソートされているため、fromから探し始めて最初に見つかったものを返します。また、この関数の利用パターンには下記の2つがあるため、if-does-not-existでディスパッチ可能な関数が見つからない場合の処理を分けています。
- 最初の呼び出し or
call-next-method: 見つからなければエラー next-method-p: 見つからなければnilを返す
型同士の比較
次に、型同士を比較するための関数です。
(defun.ps type-dispatch-p (test-type target-type) (or (and (null test-type) (null target-type)) (and (not (null test-type)) (instance-dispatch-p (new (test-type)) target-type)))) (defun.ps+ type-prior-p (test-type target-type) (and (not (eq test-type target-type)) (type-dispatch-p test-type target-type))) (defun.ps+ compare-dispatch-prior (type-list-a type-list-b) (assert (= (length type-list-a) (length type-list-b))) (dotimes (i (length type-list-a)) (let ((type-a (nth i type-list-a)) (type-b (nth i type-list-b))) (cond ((type-prior-p type-a type-b) (return-from compare-dispatch-prior -1)) ((type-prior-p type-b type-a) (return-from compare-dispatch-prior 1))))) 0)
type-dispatch-pが各型についてのディスパッチ可能性を見ている関数です。型同士を直接比較する術が見つからなかったので、いったんnewしてからインスタンスと型の比較に持ち込んでます。オブジェクト生成のオーバーヘッドはかかりますが、ロード（defmethod）時に走るだけなので無視して良いでしょう。これに同型の判定を加えたtype-prior-pを利用して、型のリストの比較をするcompare-dispatch-priorを組み上げます。返り値はJavaScriptのArray.sort()の仕様に合わせており、次のように利用しています。
(defun.ps sort-dispatch-item-list (list) (list.sort (lambda (a b) (compare-dispatch-prior (dispatch-item-type-list a) (dispatch-item-type-list b)))))
ここまで来れば、後はdefmethod.ps-onlyで利用していたpush-dispatch-funcは次のように構成できます。
;; 重複削除に利用する補助関数 (defun.ps+ same-type-list-p (type-list-a type-list-b) (unless (= (length type-list-a) (length type-list-b)) (return-from same-type-list-p nil)) (dotimes (i (length type-list-a)) (unless (eq (nth i type-list-a) (nth i type-list-b)) (return-from same-type-list-p nil))) t) (defun.ps push-dispatch-func (function-name type-list func) (symbol-macrolet ((item-list (gethash function-name *dispatch-list-table*))) ;; 重複を削除 (setf item-list (item-list.filter (lambda (item) (not (same-type-list-p (dispatch-item-type-list item) type-list))))) ;; 追加 (push (make-dispatch-item :type-list type-list :func func) item-list) ;; specificな順にソート (sort-dispatch-item-list item-list)))
独立した小さな補助関数なので触れる場所がなかったですが、次のget-dispatch-funcもdefmethod.ps-onlyの実装に利用していたものです。
(defun.ps+ get-dispatch-func (function-name index) (dispatch-item-func (nth index (gethash function-name *dispatch-list-table*))))
引数の処理
マクロ実装で利用する補助関数群です。
- ほとんどは引数（
lambda-list）を加工するための関数です - 他、Parenscriptの関数呼び出しを埋め込むための補助関数がいくつかあります
まずは引数の加工関数群ですが、やりたいことは各関数のコメントで分かるでしょうし、実装もひたすらリスト処理しているだけなので、ざっくり並べて終わりにします（全体的に関数名がやたらと長い…）。
;; alexandriaとanaphoraを利用している部分があるので、 ;; 参考のためdefpacageのインポート部分も載せます (defpackage ps-experiment/defines/defmethod ... (:import-from :alexandria :make-keyword :parse-ordinary-lambda-list :symbolicate) (:import-from :anaphora :aif :it)) (defun extract-dispatch-pair (lambda-list) "Ex. (a (b type-b) &key c) -> ((a nil) (b type-b))" (labels ((rec (rest result) (let ((head (car rest))) (if (or (not rest) (and (symbolp head) (string= (subseq (symbol-name head) 0 1) "&"))) (nreverse result) (rec (cdr rest) (cons (if (listp head) head (list head)) result)))))) (rec lambda-list nil))) (defun extract-dispatch-instances (lambda-list) "Ex. (a (b type-b)) -> (a b)" (mapcar #'car (extract-dispatch-pair lambda-list))) (defun extract-dispatch-types (lambda-list) "Ex. (a (b type-b)) -> (nil type-b)" (mapcar #'cadr (extract-dispatch-pair lambda-list))) (defun convert-gf-lambda-list-to-call-list (gf-lambda-list) "Ex. (a b &key c) -> (a b :c c)" (multiple-value-bind (required optional rest keys allow-other-keys aux keyp) (parse-ordinary-lambda-list gf-lambda-list :normalize nil) (declare (ignore allow-other-keys aux keyp)) (labels ((make-a-list (got) (if (listp got) (mapcar (lambda (elem) (if (atom elem) elem (car elem))) got) (list got)))) ;; 下記はかなり雑に処理しているので、&restやら&optionalやらが ;; 同時に使われたりすると正しく処理できない気がします… (mapcan #'make-a-list (list required optional rest (mapcan (lambda (key) (list (make-keyword key) key)) keys)))))) (defun convert-specialized-lambda-list-to-lambda-list (specialized-lambda-list) "Ex. (a (b type-b) &key (c 10)) -> (a b &key (c 10))" (let* ((count-required (aif (position-if (lambda (elem) (and (atom elem) (string= (subseq (symbol-name elem) 0 1) "&"))) specialized-lambda-list) it (length specialized-lambda-list))) (required (subseq specialized-lambda-list 0 count-required)) (rest (nthcdr count-required specialized-lambda-list))) (append (mapcar (lambda (elem) (if (atom elem) elem (car elem))) required) rest)))
次に、Parenscriptの関数呼び出しを埋め込むための補助関数です。
(defun make-table-key (sym) (format nil "~A::~A" (package-name (symbol-package sym)) (symbol-name sym))) (defun find-dispatch-func-index% (&key function-name lambda-list start-func-index (if-does-not-exist :error)) `(let ((table-key ,(make-table-key function-name))) (find-dispatch-func-index table-key (list ,@(extract-dispatch-instances lambda-list)) :from ,start-func-index :if-does-not-exist ,if-does-not-exist))) (defun call-next-method% (&key function-name lambda-list call-list start-func-index) `(let* ((table-key ,(make-table-key function-name)) (func-index ,(find-dispatch-func-index% :function-name function-name :lambda-list lambda-list :start-func-index start-func-index))) (funcall (funcall (get-dispatch-func table-key func-index) func-index) ,@call-list)))
find-dispatch-func-index%はnext-method-pの実装で利用していたもので、ディスパッチ可能なメソッドを探し出す処理を埋め込みます。call-next-method%の方でもこれを利用していますが、こちらは探した上で見つけたものを呼び出す処理を埋め込みます。defgeneric内で定義する関数での最初のメソッドの呼び出しや、call-next-methodの実装で利用していました。
若干悩ましいのが、*dispatch-list-table*のキーを生成するmake-table-key関数です。JavaScript化された時点でシンボルのパッケージ情報が除かれてしまうため、この時点でパッケージ名を含んだ文字列をキーとして生成しています。しかし、失われる情報を利用しているため、JavaScript側でこのキーを生成する術がありません。このため、例えばディスパッチ可能なメソッドを一式を取り出すcompute-applicable-methods関数がこのままでは実装できないという問題に直面することになります。現状の範囲では問題ないため今のところこのままにしています。
さて、あとは、(defgeneric some-method (a) (:documentation "Some document"))のオプション部分 = (:documentation "Some document")を処理するための関数が残っています。とはいえ、:documentationしかサポートしていないので特に見るべきところもないです。
(defun parse-defgeneric-options (options) (let ((result (make-defgeneric-options))) (dolist (opt options) (let ((kind (car opt)) (rest (rest opt))) (ecase kind (:documentation (let ((doc (car rest))) (check-type doc string) (setf (defgeneric-options-documentation result) doc)))))) result))
動作確認
最後にREPL上で動作を確認してみます。
;; --- 各種準備 --- ;; CL-USER> (ql:quickload '(:ps-experiment :cl-js) :silent t) (:PS-EXPERIMENT :CL-JS) CL-USER> (use-package :ps-experiment) T CL-USER> (defmacro jst (&body body) `(cl-js:run-js (with-use-ps-pack (:this) ,@body))) JST ;; ※defclassがないので、defstructで代用… CL-USER> (defstruct.ps+ type-a a) TYPE-A CL-USER> (defstruct.ps+ (type-b (:include type-a))) TYPE-B ;; --- 定義 --- ;; CL-USER> (defgeneric.ps+ test-method (x y)) #<STANDARD-GENERIC-FUNCTION TEST-METHOD #x3020015BE7EF> ;; ※formに文字列しかないと正しく処理できない（コメントとして取り除かれてしまう） ;; というParenscriptのバグがあるので 無駄にnilを入れて回避しています… CL-USER> (defmethod.ps+ test-method ((x type-a) (y type-b)) nil "X is type-a : Y is type-b") #<STANDARD-METHOD TEST-METHOD (TYPE-A TYPE-B)> CL-USER> (defmethod.ps+ test-method ((x type-b) (y type-a)) nil "X is type-b : Y is type-a") #<STANDARD-METHOD TEST-METHOD (TYPE-B TYPE-A)> ;; --- 呼び出し --- ;; CL-USER> (jst (test-method (make-type-a) (make-type-b))) "X is type-a : Y is type-b" CL-USER> (jst (test-method (make-type-b) (make-type-a))) "X is type-b : Y is type-a"
~.ps+を利用してCommmon Lispのメソッドとしても定義しているので、ついでにjstを挟まずにCommon Lispとして実行してみます。同じ結果が返っていることが分かります。
CL-USER> (test-method (make-type-a) (make-type-b)) "X is type-a : Y is type-b" CL-USER> (test-method (make-type-b) (make-type-a)) "X is type-b : Y is type-a"
*1:主に良い名前が思いつかないのが理由でquicklispのリポジトリに未だ登録しておらず…。試してみたい方がいたら ros install eshamster/ps-experiment などでインストールお願いします…
*2:なお、最新版では今回実装する多重ディスパッチ処理用のコード（パッケージ）が手前に付くので少し汚くなります…
*3:JavaScript Testぐらいの意味合い。Japan Standard Timeではないです
*4:プリミティブ型を判定しようとするとtypeofで型を文字列として取り出して文字列比較するみたいな話になるので、ディスパッチのような基礎的な部分に入るオーバーヘッドとしては許容しがたい雰囲気もあり、余り前向きではないです…
