MAP系の関数でスペシャルフォームを渡す — #:g1

Posted 2010-12-18 09:21:00 GMT

TAOでは、マクロもFUNCALLできるのですが、Common Lispでは、MAP系の関数には、スペシャルフォームやマクロは通常渡せません。
どうしても、こういうことをしたい、という場合は、マクロにして内部を解析し、MAP系関数の見た目で使えるように仕立てる、というのはそれなりにできそうです。
しかし、この方法だとそのMAP系関数をFUNCALLできないという問題があります。
別にそれで困ることはないのですが、ふと実はコンパイラマクロでできたりするんじゃないかと思ったので無駄に試行錯誤してみました。

とりあえずmy-mapcarを作成(関数)

(defun my-mapcar (fn &rest lists)
  (apply #'mapcar fn lists))

コンパイラマクロを付ける

(define-compiler-macro my-mapcar (fn &rest lists)
  (if (or (equal ''cl:and fn)
          (equal ''cl:or fn)
          (equal ''cl:progn fn))
      (let* ((gs (mapcar (lambda (x)
                           (declare (ignore x))
                           (gensym "VAR-"))
                         lists))
             (fors (mapcan (lambda (g li) (list :for g :in li))
                           gs
                           lists)))
        `(loop ,@fors :collect (,(eval fn) ,@gs)))
      `(mapcar ,fn ,@lists)))

コンパイラマクロはコンパイルしないと効かないので対策

ボディをコンパイルするWITH-COMPILEを作成(この時点で既に脱線している気がする)
(defmacro with-compile (&body body)
  `(funcall (compile nil (f0 ,@body))))

動作を見てみる

(my-mapcar #'list
           '(1 2 3 4)
           '(nil nil nil)
           '(t t t t t))
;=> ((1 NIL T) (2 NIL T) (3 NIL T))

(with-compile (my-mapcar 'and '(1 2 3 4) '(nil nil nil) '(t t t t t))) ;=> (NIL NIL NIL)

(with-compile (my-mapcar 'or '(1 2 3 4) '(nil nil nil) '(t t t t t))) ;=> (1 2 3)

(with-compile (my-mapcar 'progn '(1 2 3 4) '(nil nil nil) '(t t t t t))) ;=> (T T T)

上の例なら動くけれどそもそも高階関数として使いたいのではなかったか。
ということで、

applyに細工して問題を先送り

(sb-ext:without-package-locks
  (define-compiler-macro apply (&whole form function arg farg)
    (if (or (equal '(quote my-mapcar) function)
            (equal '(function my-mapcar)
                   function))
        (if (symbolp farg)
            `(my-mapcar ,arg ,@farg)
            `(my-mapcar ,arg ,@(mapcar (f_ (cons 'quote (list _)))
                                       (eval farg))))
        form)))
(with-compile
  (apply #'my-mapcar
         'and
         '((1 2 3 4)
           (nil nil nil)
           (t t t t t))))
;=> (NIL NIL NIL)

(with-compile (apply #'my-mapcar 'and (list '(1 2 3 4) '(nil nil nil) '(t t t t t)))) ;=> (NIL NIL NIL)

(let ((arg (list '(1 2 3 4) '(nil nil nil) '(t t t t t)))) (with-compile (apply #'my-mapcar 'and arg))) ;=> ((1 2 3 4) (NIL NIL NIL) (T T T T T)) ; うーん、この問題どうしよう…

なにやら色々ややこしい…。
FUNCALLだったら大丈夫だったりしないだろうか、ということで、

FUNCALLも試してみる

(sb-ext:without-package-locks
  (define-compiler-macro funcall (&whole form function arg farg)
    (if (or (equal '(quote my-mapcar) function)
            (equal '(function my-mapcar)
                   function))
        `(my-mapcar ,arg ,@farg)
        form)))
(let ((x '(1 2 3 4))
      (y '(nil nil nil))
      (z '(t t t t t)))
  (with-compile
    (funcall #'my-mapcar 'or x y z)))
;=> (1 2 3)
関数に渡される引数の問題はAPPLYより簡単そう。
しかし、
(let ((x '(1 2 3 4))
      (y '(nil nil nil))
      (z '(t t t t t))
      (f #'my-mapcar))
  (with-compile
    (funcall f 'or x y z)))
;>>> The function OR is undefined.
こういうのは駄目。

結論

結局、どこかに皺寄せがくるようです。

comments powered by Disqus