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 |

2007-12-02

古えの分割代入機構的let

| 00:20 | 古えの分割代入機構的let - わだばLisperになる を含むブックマーク はてなブックマーク - 古えの分割代入機構的let - わだばLisperになる

いつものごとく、古いソースを眺めていて、古えのletの分割代入バージョンが詳しい説明付きソースをみつけました。

letが登場したのは、1979年位らしいですが、その当時からdestructuring-bindみたいな需要はあったらしく、このファイルでは、分割代入できるletが、そのままletという名前で、setqのバージョンがdesetqという名前で実装されています。

とりあえず、

(LET ((((A (B C) () . D) E () . F) (MUMBLIFY))
      TEMP
      (KEYNO '35)
      ANOTHER-TEMP)
  (DECLARE (SPECIAL F KEYNO))
  (COGITATE (LIST D E) A B C F))
  
; ==>

((LAMBDA (G0005 TEMP KEYNO ANOTHER-TEMP F E D C B G0007 A G0006) 
   (DECLARE (SPECIAL F KEYNO))
   (SETQ G0006 (CAR G0005))
   (SETQ A (CAR G0006))
   (SETQ G0006 (CDR G0006))
   (SETQ G0007 (CAR G0006))
   (SETQ B (CAR G0007))
   (SETQ G0007 (CDR G0007))
   (SETQ C (CAR G0007))
   (SETQ G0006 (CDR G0006))
   (SETQ D (CDR G0006))
   (SETQ G0005 (CDR G0005))
   (SETQ E (CAR G0005))
   (SETQ G0005 (CDR G0005))
   (SETQ F (CDR G0005))
   (COGITATE (LIST D E) A B C F))
 (MUMBLIFY) () '35 () () () () () () () () ())

という変換をするマクロで一時変数に値を移し移ししているのが面白いと思ったので、とりあえず、この説明を参考に自作して遊んでみました。


(defun des (bind sym)
  (let (vars)
    (values 
     (labels ((frob (bind sym)
		(cond ((null bind) nil)	
		      ((atom bind)
		       (push bind vars)
		       `((setq  ,bind ,sym)))
		      ((null (car bind))
		       `((setq ,sym (cdr ,sym))
			 ,@(frob (cdr bind) sym)))
		      ((and (atom (car bind)) (null (cdr bind)))
		       (push (car bind) vars)
		       `((setq ,(car bind) (car ,sym)))) ;last -1
		      ((atom (car bind))
		       (push (car bind) vars)
		       `((setq ,(car bind) (car ,sym))
			 (setq ,sym (cdr ,sym))
			 ,@(frob (cdr bind) sym)))
		      ('T (let ((carcons (gensym)))
			    (push carcons vars)
			    `((setq ,carcons (car ,sym))
			      ,@(frob (car bind) carcons)
			      (setq ,sym (cdr ,sym))
			      ,@(frob (cdr bind) sym)))))))
       (frob bind sym))
     vars)))

(defun cadrat (item)
  (if (consp item) (cadr item) nil))

(defmacro dlet ((&rest bind-specs) &body body)
  (let (cons-binds cons-vars) 
    (let ((vars (mapcar (lambda (item)
			  (if (consp item)
			      (if (consp (car item))
				  (let ((gs (gensym "VAR-")))
				    (multiple-value-bind (bf bv) (des (car item) gs)
				      (push bf cons-binds)
				      (push bv cons-vars))
				    gs)
				  (car item))
			      item))
			bind-specs))
	  (vals (mapcar #'cadrat bind-specs)))
      (let ((cons-vars (apply #'append cons-vars)) ;rebind
	    (cons-binds (apply #'append cons-binds)))
	`((lambda (,@vars ,@cons-vars)
	    ,@(if (eq (caar body) 'declare) ; declareを先頭に
		  `(,(pop body) 
		     ,@cons-binds
		     ,@body)
		  `(,@cons-binds ,@body)))
	  ,@(append vals (mapcar (constantly nil) cons-vars)))))))
;; マクロ展開
(dLET ((((A (B C) () . D) E () . F) (MUMBLIFY))
      TEMP
      (KEYNO '35)
      ANOTHER-TEMP)
  (DECLARE (SPECIAL F KEYNO))
  (COGITATE (LIST D E) A B C F))

;==>
((LAMBDA (#:VAR-3340 TEMP KEYNO ANOTHER-TEMP F E D C B #:G3342 A #:G3341)
   (DECLARE (SPECIAL F KEYNO))
   (SETQ #:G3341 (CAR #:VAR-3340))
   (SETQ A (CAR #:G3341))
   (SETQ #:G3341 (CDR #:G3341))
   (SETQ #:G3342 (CAR #:G3341))
   (SETQ B (CAR #:G3342))
   (SETQ #:G3342 (CDR #:G3342))
   (SETQ C (CAR #:G3342))
   (SETQ #:G3341 (CDR #:G3341))
   (SETQ #:G3341 (CDR #:G3341))
   (SETQ D #:G3341)
   (SETQ #:VAR-3340 (CDR #:VAR-3340))
   (SETQ E (CAR #:VAR-3340))
   (SETQ #:VAR-3340 (CDR #:VAR-3340))
   (SETQ #:VAR-3340 (CDR #:VAR-3340))
   (SETQ F #:VAR-3340)
   (COGITATE (LIST D E) A B C F))
 (MUMBLIFY) NIL '35 NIL NIL NIL NIL NIL NIL NIL NIL NIL)

;; 実行
(dlet ((((a (b c) () . d) e () . f) '((1 (2 3) () . 4) 5 () . 6))
      temp
      (keyno '35)
      another-temp)
  (declare (special f keyno))
  (list (list d e) a b c (symbol-value 'f) keyno another-temp temp))

;=>
((4 5) 1 2 3 6 35 NIL NIL)

いつもの如く行き当たりばったりなコード。

letだと名前がぶつかって厄介なので、dletという名前にしました。

元のソースは参考にしないで作りましたが、なんとなく仕組は分かったので、元はどうやって問題を解決しているのか探ってみたいと思います。

それと確かOn Lispにも似たようなものがあったのと思ったのでそっちも勉強したいです。

ゲスト



トラックバック - http://cadr.g.hatena.ne.jp/g000001/20071202