#:g1: 暗黙のcond: コードウォーカー篇

前回は、muLISPの暗黙のcondをリーダーマクロで再現してみましたが、コードウォーキングのお題としても使えそうな気がしたので、今回は暗黙のcondをコードウォーカーを使って再現してみたいと思います。

利用するコードウォーカーについて

今回利用するコードウォーカーはarnesiのwalk-formです。
S式をパーズしてフォームのオブジェクトに変換し、それをアンパーズしてS式に戻す、という方式です。

変換の戦略としては、muLISPの暗黙のcondは、Common Lispの適用フォームとしては不正なので、これを検知して式を変換します。
具体的には、carにconsが来るのはlambda式の時のみなので、それ以外のconsのフォームを暗黙のcondと見做せば良さそうですが、arnesiでは、lambda式は既にlambda-application-formとしてハンドリングされているので、それ以外のfree-application-formの方にメソッドを定義します。

(ql:quickload '(alexandria arnesi))
(defpackage mu
  (:use)
  (:export defun))

(defun get-block-name (env)
  #+sbcl (caar (sb-c::lexenv-blocks env))
  #+lispworks (caar (compiler::compiler-environment-benv env)))

(defmacro return-innermost (val &environment env)
  `(return-from ,(get-block-name env) ,val))

;;;((foo ...) ...) => (when (foo ...) ... (return-innermost ...))
(arnesi:defunwalker-handler arnesi:free-application-form (arnesi:operator arnesi:arguments)
  (typecase arnesi:operator
    (cons (destructuring-bind (pred &rest body)
                              (call-next-method)
            `(when ,pred ,@(butlast body) 
               (return-innermost ,@(last body)))))
    (atom (call-next-method))))

(defmacro mu:defun (name (&rest args) &body body)
  (multiple-value-bind (body decl doc)
                       (alexandria:parse-body body :documentation T)
    `(defun ,name (,@args)
       ,@(if doc `(,doc) `())
       ,@decl 
       ,(arnesi:unwalk-form
         (arnesi:walk-form `(progn ,@body))))))

試してみる

(mu:defun fib (n)
  "fib"
  (declare (optimize (speed 3) (safety 0) (debug 0)))
  (declare (type fixnum n))
  (labels ((fib (n &aux n1 n2)
             ((< n 1) 0)
             ((< n 2) 1)
             (setq n1 (1- n))
             (setq n2 (- n 2))
             (+ (fib n1)
                 (fib n2))))
    (fib n)))
===>
(defun fib (n)
  "fib"
  (declare (optimize (speed 3) (safety 0) (debug 0)))
  (declare (type fixnum n))
  (progn
    (labels ((fib (n &aux n1 n2)
               (when (< n 1) (return-innermost 0))
               (when (< n 2) (return-innermost 1))
               (setq n1 (1- n))
               (setq n2 (- n 2))
               (+ (fib n1) (fib n2))))
      (fib n))))
(fib 40)
→ 102334155

(mu:defun fizzbuzz (n)
  (flet ((fizzp (n) ((zerop (rem n 3)) T) nil)
         (buzzp (n) ((zerop (rem n 5)) T) nil))
    ((buzzp n)
     ((fizzp n) "fizzbuzz")
     "buzz")
    ((fizzp n) "fizz")
    n))
===>
(defun fizzbuzz (n)
  (progn
    (flet ((fizzp (n) (when (zerop (rem n 3)) (return-innermost t)) nil)
           (buzzp (n) (when (zerop (rem n 5)) (return-innermost t)) nil))
      (when (buzzp n) (when (fizzp n) (return-innermost "fizzbuzz")) (return-innermost "buzz"))
      (when (fizzp n) (return-innermost "fizz"))
      n)))
(loop :for i :from 1 :repeat 100 :collect (fizzbuzz i))
→ (1 2 "fizz" 4 "buzz" "fizz" 7 8 "fizz" "buzz" 11 "fizz" 13 14 "fizzbuzz" 16 17 "fizz" 19 "buzz" "fizz" 22 23 "fizz" "buzz" 26 "fizz" 28 29 "fizzbuzz" 31 32 "fizz" 34 "buzz" "fizz" 37 38 "fizz" "buzz" 41 "fizz" 43 44 "fizzbuzz" 46 47 "fizz" 49 "buzz" "fizz" 52 53 "fizz" "buzz" 56 "fizz" 58 59 "fizzbuzz" 61 62 "fizz" 64 "buzz" "fizz" 67 68 "fizz" "buzz" 71 "fizz" 73 74 "fizzbuzz" 76 77 "fizz" 79 "buzz" "fizz" 82 83 "fizz" "buzz" 86 "fizz" 88 89 "fizzbuzz" 91 92 "fizz" 94 "buzz" "fizz" 97 98 "fizz" "buzz")

まとめ

arnesiのwalk-formを利用してmuLISPの暗黙のcondを再現してみました。
SBCLやLispWorksに付属のPCL系のwalk-formでも可能ですが、arnesiのものはカスタマイズしたい部分にメソッドを定義してやるだけなので簡潔かと思います。
ただし、今回のような定義では、arnesiのunwalk-form全体に影響を及ぼしてしまうので、フォームオブジェクトをサブクラス化してカスタマイズに使う等の工夫が必要になるかと思います。

■

HTML generated by 3bmd in LispWorks 7.0.0