2014-06-18-02-ファンクタの0x11対応 - 6

>> Site top >> weblog >> 月別アーカイブ >> 2014年06月のlog >> 2014-06-18-02-ファンクタの0x11対応 - 6

最終更新日付：2014/06/18 23:50:00

ファンクタの0x11対応 - 6

2014 年 06 月 18 日

人間、頑張ればできる‥‥‥というが、頑張った結果として成功したのに、それが単なるまぐれのような気がしてならないという時というのがあるものだ。先日から書いている bind マクロの問題、解決してしまった。

基本的な考え方は、コピーの仕方を知っているのはそれを作った bind マクロだけなのだから、そこでコピーのための関数を作っておき、__binded-expr に持ち回らせようというものだ。ごちゃごちゃ書くのはこれくらいにして、出来上がったコードをみよう。__binded-expr と関連するメソッドは以下のようになった。

(defclass __binded-expr (functor)
  ((bindee  :initarg  :bindee
            :accessor __binded-expr-bindee)
   (params  :type     :simple-vector
            :initarg  :params
            :accessor __binded-expr-params)
   (cloner  :type     :function
            :initarg  :cloner
            :accessor __binded-expr-cloner)
   (closure :type     :function
            :initarg  :closure
            :accessor __binded-expr-closure)))

(defmethod clone ((func __binded-expr))
  (funcall (__binded-expr-cloner func) func))

(defmethod functor-function ((func __binded-expr))
  (__binded-expr-closure func))

ポイントは、バインドする複数の値を simple-vector に収めたことで、これでコピーが簡単になる。また、ファンクタとしての関数（レキシカルクロージャ）を内部保有できるようになったので、functor-function の実装では単純にそれを返却すれば良くなった。うん、全てが理想的だ。では、問題の bind マクロをどうやればそんないい感じになるのだろうか。こうなっている。

(defmacro bind (func &rest args)
  (let ((max-arg 0)
        (arg-hash (make-hash-table)))
    (labels ((get-argsym (idx)
               (let ((is-new nil)
                     (ret (gethash idx arg-hash)))
                 (unless ret
                   (setf ret (gensym (format nil "ARG~A-" idx)))
                   (setf (gethash idx arg-hash) ret)
                   (setf is-new t)
                   (when (< max-arg idx)
                     (setf max-arg idx)))
                 (values ret is-new)))
             (make-lambda-list (idx lambda-list ignore-list)
               (if (< max-arg idx)
                   (values (nreverse lambda-list)
                           (nreverse ignore-list))
                   (multiple-value-bind (sym is-new) (get-argsym idx)
                     (cl:push sym lambda-list)
                     (when is-new
                       (cl:push sym ignore-list))
                     (make-lambda-list (1+ idx) lambda-list ignore-list))))
             (imp (args acc1 acc2 prm-sym &optional (idx 0))
               (if (null args)
                   (values (nreverse acc1)
                           (nreverse acc2))
                   (let* ((item (car args))
                          (ret  (is-placeholder item)))
                     (if (< 0 ret)
                         (cl:push (get-argsym ret) acc2)
                         (progn
                           (cl:push `(svref ,prm-sym ,idx) acc2)
                           (cl:push `(opr= (svref ,prm-sym ,idx) ,(car args)) acc1)
                           (incf idx)))
                     (imp (cdr args) acc1 acc2 prm-sym idx)))))
      (let ((g-imp    (gensym "IMP"))
            (g-fnc    (gensym "FNC"))
            (g-bindee (gensym "BINDEE"))
            (g-bd-fnc (gensym "BD-FNC"))
            (g-params (gensym "PARAMS"))
            (g-cloner (gensym "CLONER")))
        (multiple-value-bind (arg-lst prm-lst) (imp args nil nil g-params)
          (multiple-value-bind (lambda-list ignore-list) (make-lambda-list 1 nil nil)
            `(labels ((,g-imp (,g-bindee ,g-params ,g-cloner)
                        (declare (type simple-vector ,g-params))
                        (let ((,g-bd-fnc (functor-function ,g-bindee)))
                          (declare (type function ,g-bd-fnc))
                          (make-instance '__binded-expr
                                         :bindee ,g-bindee :params ,g-params :cloner ,g-cloner
                                         :closure (lambda (,@lambda-list)
                                                    ,(when ignore-list
                                                           `(declare (ignore ,@ignore-list)))
                                                    (funcall ,g-bd-fnc ,@prm-lst))))))
               (let* ((,g-bindee (clone ,func))
                      (,g-params (make-array ,(length arg-lst) :initial-element nil))
                      (,g-cloner (lambda (,g-fnc)
                                   (,g-imp (clone (__binded-expr-bindee ,g-fnc))
                                           (clone (__binded-expr-params ,g-fnc))
                                           (__binded-expr-cloner ,g-fnc)))))
                 ,@arg-lst
                 (,g-imp ,g-bindee ,g-params ,g-cloner)))))))))

まぁ、その‥‥‥なんだ。これを文章で説明する自信はない。それに、これをちゃんと読んでくれる方がいるとも思っていない。なので、先日のマクロ展開をもう一度やってみよう。展開結果を見た方がいいよね。(stl:bind #'mult3 :1 2 3) は今度は以下のように展開される。なお、これは見易さのために gensym を普通のシンボルに置き換えた上、多少の整形を加えてある。

(labels ((imp (bindee params cloner)
           (declare (type simple-vector params))
           (let ((bd-fnc (stl:functor-function bindee)))
             (declare (type function bd-fnc))
             (make-instance 'stl::__binded-expr
                            :bindee bindee :params params :cloner cloner
                            :closure (lambda (arg1)
                                       nil
                                       (funcall bd-fnc arg1
                                                (svref params 0)
                                                (svref params 1)))))))
  (let* ((bindee (stl:clone #'mult3))
         (params (make-array 2 :initial-element nil))
         (cloner (lambda (fnc)
                   (imp (stl:clone (stl::__binded-expr-bindee fnc))
                        (stl:clone (stl::__binded-expr-params fnc))
                        (stl::__binded-expr-cloner fnc)))))
    (stl:opr= (svref params 0) 2)
    (stl:opr= (svref params 1) 3)
    (imp bindee params cloner)))

__binded-expr を実際に作成するローカル関数は、そのオブジェクトをコピーするための処理としてオブジェクト自体が保有している。マクロでそのあたりまでを全て生成しておけば全てが解決するというポイント、これに気付いた時はもう目から鱗が落ちたような気がした。まぁ実際に CL-STL を使うことを考えるとレキシカルクロージャを使ってしまうから bind マクロの出番はまずないんだけどな。

コメント

このページにコメントする

このページのタグ

Page tag : Common Lisp

Page tag : STLとその移植

Copyright(C) 2005-2017 project-enigma.
Generated by CL-PREFAB.