#:g1: 手抜きでwith-added-methodsを実装してみる

Posted 2022-01-16 17:11:34 GMT

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

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

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

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

(defpackage "e95807a5-c970-5e32-82b6-328d307de616" 
  (:use c2cl)
  (:shadow generic-function))

(in-package "e95807a5-c970-5e32-82b6-328d307de616")

(deftype generic-function (&rest args) `(cl:generic-function ,@args))

(defmacro generic-function ((&rest args) &body body &environment env) (let ((gf (gensym "anonymous-generic-function-"))) `(load-time-value (defgeneric ,gf (,@args) ,@body))))

(defmacro generic-flet ((&rest local-gfs) &body body) `(flet (,@(mapcar (lambda (gf) (destructuring-bind (name args &body body) gf (let ((gf (gensym "anonymous-generic-function-")) (lf-args (gensym "args"))) `(,name (&rest ,lf-args) (declare (dynamic-extent ,lf-args)) (apply (load-time-value (defgeneric ,gf (,@args) ,@body)) ,lf-args))))) local-gfs)) ,@body))

(defmacro generic-labels ((&rest local-gfs) &body body) `(labels (,@(mapcar (lambda (gf) (destructuring-bind (name args &body body) gf (let ((gf (gensym "anonymous-generic-function-")) (lf-args (gensym "args"))) `(,name (&rest ,lf-args) (declare (dynamic-extent ,lf-args)) (apply (load-time-value (defgeneric ,gf (,@args) ,@body)) ,lf-args))))) local-gfs)) ,@body))

(mapcar (generic-function (x y)
          (:method ((x cons) (y cons))
           (append x y))
          (:method ((x number) (y number))
           (+ x y))
          (:method (x y)
           (list x y)))
        '(42 (0 1 2 3) z)
        '(42 (0 1 2 3) z))(84 (0 1 2 3 0 1 2 3) (z z)) 

(generic-flet ((plus (x y) (:method ((x cons) (y cons)) (append x y)) (:method ((x number) (y number)) (+ x y)) (:method (x y) (list x y)))) (list (plus 8 8) (plus '(1 2 3 4) '(1 2 3 4)) (plus 'z 'z)))(16 (1 2 3 4 1 2 3 4) (z z))

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

(fibonacci 40) → 102334155

with-added-methods

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

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

具体的に考えると、

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

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

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

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

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

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun method-description-p (form)
    (typep form '(cons (eql :method) *))))

(defun copy-generic-function (name gf &key generic-function-class lambda-list declare method-combination method-class argument-precedence-order) (let ((newgf (etypecase gf (GENERIC-FUNCTION (setq generic-function-class (class-of gf)) (setq lambda-list (generic-function-lambda-list gf)) (setq declare (generic-function-declarations gf)) (setq method-combination (generic-function-method-combination gf)) (setq method-class (generic-function-method-class gf)) (setq argument-precedence-order (generic-function-argument-precedence-order gf)) (ensure-generic-function name :generic-function-class generic-function-class :lambda-list lambda-list :declare declare :method-combination method-combination :method-class method-class :method-combination method-combination :argument-precedence-order argument-precedence-order)) (FUNCTION (let ((gf-from-fn (ensure-generic-function name :lambda-list (lw:function-lambda-list gf)))) (add-method gf-from-fn (make-instance 'standard-method :function (lambda (&rest args) (declare (ignore next)) (apply gf args)) :lambda-list (lw:function-lambda-list gf) :specializers (mapcar (constantly (find-class T)) (lw:function-lambda-list gf)))) gf-from-fn)) (NULL (ensure-generic-function name :lambda-list lambda-list))))) (when (typep gf 'generic-function) (dolist (m (generic-function-methods gf)) (add-method newgf (make-instance (generic-function-method-class newgf) :function (method-function m) :lambda-list (method-lambda-list m) :specializers (method-specializers m)))))

newgf))

(defmacro with-added-methods ((function-name lambda-list &rest method-description/option) &body body) `(labels ((,function-name (&rest args) (apply (load-time-value ,(let ((name (gensym "gf"))) `(let ((,name (copy-generic-function ',name ,(if (fboundp function-name) `#',function-name nil) :lambda-list ',lambda-list ,@(remove-if #'method-description-p method-description/option)))) ,@(mapcar (lambda (mf) `(defmethod ,name ,@(cdr mf))) (remove-if-not #'method-description-p method-description/option)) ,name))) args))) ,@body))

試してみる

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

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

とりあえず素のfib

(time (fib 40 #'fib))
Timing the evaluation of (fib 40 #'fib)

User time = 6.907 System time = 0.109 Elapsed time = 6.933 Allocation = 170288 bytes 3995 Page faults 102334155

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

(time
 (with-added-methods (fib (n fib)
                          (:method ((n (eql 5)) fib) 
                           5))
   (fib 20 #'fib)))

Timing the evaluation of (with-added-methods (fib (n fib) (:method ((n (eql 5)) fib) 5)) (fib 20 #'fib))

User time = 1.365 System time = 1.672 Elapsed time = 3.077 Allocation = 132662416 bytes 226350 Page faults Calls to %EVAL 368057 6765

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

(defun foo-fib (n)
  (with-added-methods (fib (n fib)
                        (:method ((n (eql 5)) fib) 5))
    (fib n #'fib)))

(time (foo-fib 40)) Timing the evaluation of (foo-fib 40)

User time = 4.069 System time = 0.084 Elapsed time = 4.075 Allocation = 160912 bytes 4005 Page faults 102334155

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

(defun foo (x) x)

(foo 0) → 0

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

まとめ

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


HTML generated by 3bmd in LispWorks 7.1.3

comments powered by Disqus