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

| 02:12 | 末尾再帰的DEFUN - わだばLisperになる を含むブックマーク はてなブックマーク - 末尾再帰的DEFUN - わだばLisperになる

今日は、Arcもいじっていたのですが、なんとなくSAILのMACLISPのコードも漁っていました。

SAILのものは非常に野心的というか、変態的というか、妙なコードが多いのですが、ふと以前から気になっていたTAIL-RECURSIVE-DEFUNのコードを追っ掛けてみることにしました。

実際のコードはこちらです。

SAILの変態っぷりは、恐らくRichard P.Gabriel氏によるところが非常に大きいと思うのですが、何となくこのTAIL-RECURSIVE-DEFUNもそんな香りがします。

とりあえず、探ってみたいのは、このコードです。

(DEFUN (TAIL-RECURSIVE-DEFUN MACRO)(X)
  ((LAMBDA(?F-NAME *TYPE)
    ((LAMBDA(*ARGS *DEFINITION)
      ((LAMBDA(?GO-LABEL)
	(α-GRAB-TAILS *ARGS *DEFINITION ?GO-LABEL)
	(CCODE (DEFUN ?F-NAME *TYPE (*ARGS) (PROG NIL
						  ?GO-LABEL
						  (RETURN (PROGN *DEFINITION))))))
       (GENSYM)))
     (COND (*TYPE (CADDDR X))(T (CADDR X)))
     (COND (*TYPE (CDDDDR X))(T (CDDDR X)))))
   (CADR X)
   (COND ((MEMQ (CADDR X) '(EXPR FEXPR))
	  (LIST (CADDR X)))
	 (T NIL))))
 ;

これは一体何をするものなのか。自動で末尾再帰に変換してくれるのか。それとも他に末尾再帰的な何かの特長があるのか、謎です…。

とりあえず、もの凄くLAMBDAがネストしているのですが、これはLETの役割です。それで、DEFUNになっているのですが、MACLISPでは、DEFUNでマクロも定義でき、この場合、マクロを定義しています。

最終的には、(defun foo (n) ...body)のように展開されたものができるんじゃないかと思います。

それでこのTAIL-RECURSIVE-DEFUNが依存している関数で独自に定義されたものを追っ掛けてみます。

とりあえず、MACLISPからCLへ移植してみました。CLにないMACLISP標準は自作しています。

(DEFUN ANY-MEMQ(X Y)
  (COND ((NULL Y)NIL)
	((ATOM Y)(EQ X Y))
	(T(OR (ANY-MEMQ X (CAR Y))
	      (ANY-MEMQ X (CDR Y))))))

;(any-memq 'x '(y (((((x(((())))))))) z))
;=> t

(defmacro ccode (X) `(DO-CODE ,x))

(DEFUN DO-CODE(X)
  (COND ((NULL X)NIL)
	((ATOM X)
	 ((LAMBDA(CHAR1)
	   (COND ((MEMQ CHAR1 '(? *))X)
		 (T (LIST 'QUOTE X))))
	  (GETCHAR X 1)))
	((AND (ATOM (CAR X))(EQ '* (GETCHAR (CAR X) 1)))
	 (LIST 'APPEND (DO-CODE (CAR X)) (DO-CODE (CDR X))))
	(T(LIST 'CONS (DO-CODE (CAR X)) (DO-CODE (CDR X))))))

(DEFUN α-GRAB-TAILS (ARGS DEF ?GO-LABEL)
 (COND ((ATOM DEF)NIL)
       ((AND (ATOM(CAR DEF)) (EQ 'TAIL-RECUR (CAR DEF)))
	(COND ((EQUAL ARGS (CDR DEF))		;calling with same args!
	       (RPLACA DEF 'GO)
	       (RPLACD DEF (LIST ?GO-LABEL)))
	      (T(DO ((ARGS ARGS (CDR ARGS))
		     (NEWARGS (CDR DEF) (CDR NEWARGS))
		     (SETS NIL (NCONC SETS
				      (COND ((EQ (CAR ARGS) (CAR NEWARGS))
					     NIL)
					    (T (NCONS
						((LAMBDA(SYM)
						  (CONS (CONS (CAR ARGS)SYM)
							(LIST 'SETQ
							      (CAR ARGS)
							      (SUBLIS (MAPCAR 'CAR
									      SETS)
								      (CAR NEWARGS)))))
						 (GENSYM))))))))
		    ((NULL ARGS)
		     ((LAMBDA(L-EXP)
		       (RPLACA DEF (CAR L-EXP))
		       (RPLACD DEF (CDR L-EXP)))
		      (α-OPTIMIZE-λ (MAPCAR 'CDAR SETS)
				    (NCONC (MAPCAR 'CDR SETS)
					   (NCONS(LIST 'GO ?GO-LABEL)))
				    (MAPCAR 'CAAR SETS))))))))
       (T(MAPC (FUNCTION(LAMBDA(DEF)
			 (α-GRAB-TAILS ARGS DEF ?GO-LABEL)))
	       DEF))))

(DEFUN α-OPTIMIZE-λ (VARS BODY BINDINGS)
  (DO ((VARS VARS (CDR VARS))
       (BINDINGS BINDINGS (CDR BINDINGS))
       (NVARS NIL (NCONC NVARS
			 (COND ((ANY-MEMQ (CAR VARS) BODY)(NCONS (CAR VARS)))
			       (T NIL))))
       (NBINS NIL (NCONC NBINS
			 (COND ((ANY-MEMQ (CAR VARS) BODY)(NCONS (CAR BINDINGS)))
			       (T NIL)))))
      ((NULL VARS)(CONS (CONS 'LAMBDA (CONS NVARS BODY))
			NBINS))))

;; オリジナルに割と忠実版
(defmacro TAIL-RECURSIVE-DEFUN (&whole X &body body)
  (declare (ignore body))
  ((LAMBDA(?F-NAME *TYPE)
     ((LAMBDA(*ARGS *DEFINITION)
	((LAMBDA(?GO-LABEL)
	   `(progn
	      ,@(α-GRAB-TAILS *ARGS *DEFINITION ?GO-LABEL)
	      (DEFUN ,?F-NAME ,*TYPE (,@*ARGS) (PROG NIL
						  ,?GO-LABEL
						  (RETURN (PROGN ,@*DEFINITION))))))
	 (GENSYM)))
      (COND (*TYPE (CADDDR X))(T (CADDR X)))
      (COND (*TYPE (CDDDDR X))(T (CDDDR X)))))
   (CADR X)
   (COND ((MEMQ (CADDR X) '(EXPR FEXPR))
	  (LIST (CADDR X)))
	 (T NIL))))

;; バッサリとMACLISP特有の部分を切り捨てた版
(defmacro TAIL-RECURSIVE-DEFUN (?f-name *args &body *definition)
  (let ((?GO-LABEL (gensym)))
    `(progn
       ,(α-GRAB-TAILS *ARGS *DEFINITION ?GO-LABEL)
       (DEFUN ,?F-NAME (,@*ARGS) 
	 (PROG NIL
	    ,?GO-LABEL
	       (RETURN (PROGN ,@*DEFINITION)))))))


;; ML標準の関数達
(defun ncons (n) (list n))

(defun memq (x y)
  (member x y :test #'eq))

(defun getchar (x index)
  (values (intern (string (char (string x) (1- index))))))
 ; 

中身の動作なのですが、とりあえず、

(α-GRAB-TAILS '(x y z) '(tail-recur) 'go)
;-> ((LAMBDA () (SETQ X NIL) (SETQ Y NIL) (SETQ Z NIL) (GO GO))) 

(α-GRAB-TAILS '(x y z) '(tail-recur x) 'go)
;-> ((LAMBDA () (SETQ Y NIL) (SETQ Z NIL) (GO GO))) 

(α-GRAB-TAILS '(x y z) '(tail-recur y z x) 'go)
;-> ((LAMBDA (#:G2999) (SETQ X Y) (SETQ Y Z) (SETQ Z #:G2999) (GO GO)) X) 

(α-GRAB-TAILS '(x y z) '( y z x) 'go)
;-> (Y Z X) 

(do-code '(?foobarbaz hello one))
;(CONS ?FOOBARBAZ (CONS 'HELLO (CONS 'ONE NIL))) 

(do-code '(*foobarbaz hello one))
;(APPEND *FOOBARBAZ (CONS 'HELLO (CONS 'ONE NIL))) 

(tail-recursive-defun xyz (x y z)
  tail-recur
  (list x y z))
; マクロ展開結果
;->
(PROGN
 ((LAMBDA () (SETQ X (LIST X Y Z)) (SETQ Y NIL) (SETQ Z NIL) (GO #:G2995)))
 (DEFUN XYZ (X Y Z)
   (PROG ()
    #:G2995
     (RETURN
      (PROGN
       ((LAMBDA ()
          (SETQ X (LIST X Y Z))
          (SETQ Y NIL)
          (SETQ Z NIL)
          (GO #:G2995))))))))

という感じです。

α-OPTIMIZE-λは、どうやら不要な変数束縛を取り除いて簡略化するもののようで、これは理解できました。

これを呼び出しているα-GRAB-TAILSが良く分からないのですが、名前からすると、末尾部分を抽出するもののようなのですが、動きが良く分からない…。

何がどう末尾再帰なのか…、纏められないままエントリを終わります(笑)