Hatena::Groupcadr

わだばLisperになる このページをアンテナに追加 RSSフィード

2004 | 12 |
2005 | 01 | 02 | 07 | 10 | 11 |
2006 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2007 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2008 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2009 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2010 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2011 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 11 |

2008-01-31

末尾再帰的DEFUN (2)

| 04:53 | 末尾再帰的DEFUN (2) - わだばLisperになる を含むブックマーク はてなブックマーク - 末尾再帰的DEFUN (2) - わだばLisperになる

何となく釈然としないまま、一旦放置した末尾再帰的DEFUNですが、何となく眺めていると末尾再帰をgo-toに変換するんじゃないのかなあ、という気がしてきました。

つまり明示的に末尾再帰で書かれたものを、完全なループに変換するという目的のものだったのではないかと思えてきました。

そう考えると、関数呼び出しの個所をgo-toに変換すれば良いのですが、

(defun fib (n &optional (a1 1) (a2 0))
  (if (< n 2)
      a1
      (fib (1- n) (+ a1 a2) a1))))

のような末尾再帰の定義は

(defun fib (n &optional (a1 1) (a2 0))
  (prog ()
    L   (if (< n 2)
	    (return a1)
	    ((lambda (t1 t2 t3) (setq n t1 a1 t2 a2 t3) (go L)) (1- n) (+ a1 a2) a1)))))

のようにすれば、マクロで置き換えるのも、そんなに大変でもないかなと。

本当は、

(defun fib (n &optional (a1 1) (a2 0))
  (prog ()
    L   (if (< n 2)
	    (return a1)
	    (progn (setq n (1- n) a1 (+ a1 a2) a2 a1) (go L))))))

という風にするべきな気もします。スタックの使われ方とか、その辺に違いがありそうですが、disassemしても良く分からなかったので、とりあえず、lambdaの方で行くことにしました。

それで、この場合、PROGの中に展開されるので、最終的に値を返すところには、returnを付けないといけない訳なのですが、それがどこなのか判別するのは至難の技なので、逆にRETURNの中に展開してしまうことにしました。オリジナルもこういう感じなのですが、こういうことなのかも知れません。

(defun fib (n &optional (a1 1) (a2 0))
  (prog ()
    L   (return (if (< n 2)
		    a1
		    ((lambda (t1 t2 t3) (setq n t1 a1 t2 a2 t3) (go L)) (1- n) (+ a1 a2) a1))))))

そんなこんなでいつものごとくガチャガチャと自分なりに作ってみました。

RETURN式の中から外にgotoとかして良いのかしら、とか思ったりしますが、これって手法としてはありななんですかねえ。

;; 動作
(tail-recursive-defun fib (n &optional (a1 1) (a2 0)) 
  (if (< n 2)
      a1
      (fib (1- n) (+ a1 a2) a1)))

;; マクロ展開=>
(DEFUN FIB (N &OPTIONAL (A1 1) (A2 0))
  (PROG ()
     #:G3105
     (RETURN
       (IF (< N 2) 
	   A1
	   ((LAMBDA (#:G3106 #:G3107 #:G3108)
	      (SETQ N #:G3106 A1 #:G3107 A2 #:G3108)
	      (GO #:G3105))
	    (1- N) (+ A1 A2) A1)))))

;; 定義 --------
;; 関数呼び出し部分をgo-to付きのlambda式で置き換え
(defun fn-to-lambda (new old expr)
  (flet ((self (x) (fn-to-lambda new old x)))
    (cond ((atom expr) expr)
	  ((and (consp expr) (eq (car expr) old))
	   (cons new (mapcar #'self (cdr expr))))
	  ('T (cons (funcall #'self (car expr)) (mapcar #'self (cdr expr)))))))

;; 関数をgo-to付きのlambda式に変換
(defun funcall-to-goto (args gotag)
  (let ((syms (mapcar (lambda (x) `(,x ,(gensym))) args)))
    `(lambda ,(mapcar #'cadr syms) (setq ,@(mapcan #'identity syms)) (go ,gotag))))

;; 余計なパラメータを削除
(defun remove-&param (expr)
  (mapcar (lambda (x) (if (consp x) (car x) x))
	  (remove-if (lambda (x) (member x '(&optional &rest &key))) expr)))

;; 本体
(defmacro tail-recursive-defun (name args &body body)
  (let ((go-tag (gensym))
	(decl (if (eq 'declare (and (consp (car body)) (caar body)))
		  `(,(pop body))
		  ())))
    `(defun ,name ,args
       ,@decl
       (prog ()
	  ,go-tag
	  (return
	    ,@(fn-to-lambda (funcall-to-goto (remove-&param args) go-tag) name 
			    body))))))
 ;