EoPL reading (37) 1.3.1 Free and Bound Variables

scheme EoPL

Exercise.1-31

対象は BNF に書いてある通り。変数名とレキシカルなアドレスのナニなリストを持ち回れば良いのでしょうか。あー、結果も必要ですね。
ざっくり以下なカンジ?

(define (lexical-address exp)
  (define (lexical-address-inner rslt argl l)
    (if (null? l)
        rslt
        (cond ((symbol? l) ;; symbol の時は argl を探索 )
              ((eqv? (car l) 'lambda)
                ;; lambda の時は argl を更新 )
              ((eqv? (car l) 'if)
                ;; この分岐が必要かどうかも不明 )
              (else
                ;; げ。どうしよう )))
    )
  (lexical-address-inner '() '() exp)
  )

ええと、lambda が入れ子になった時が argl の更新が必要なので、ってか rslt に結果を格納しようとしてるのでアレだな。最後は結果を戻すのでこれで良いのかな?

              (else
                (lexical-address-inner (lexical-address-inner rslt argl (car l))
                                       argl
                                       (cdr l)))

てーコトは if な分岐も上記と似たカンジで良いのか。lambda な分岐も argl を更新して body を渡せば良いんですね。あと、rslt をどう更新すりゃ良いんでしょ。
最初は単純な再帰から考えた方が良さげな気もしますが argl の持ち回りとかが逆に面倒そげ。とりあえず symbol? な分岐ができたら簡単な試験は通せそうな気がする。ええと assq とかで探索するとしたら argl はどんなリストになってりゃ良いんでしょ。
例えば例示されている以下の手続きであれば

(lambda (a b c)        ;; ((a (0 0)) (b (0 1)) (c (0 2)))
  (if (eqv? b c)  
    ((lambda (c)       ;; ((a (1 0)) (b (1 1)) (c (0 0)))
       (cons a c)) a)
    b))

lambda なブロックの中だけで argl を使い回せれば良いのでしょうが、これはこれで大丈夫な風にも見えるようなそうでもないような。
argl を作る手順としては

  • まず引数パースしてリスト作る
  • argl が '() ならそのまま戻す
  • そうでなかったら argl を順に取り出していきながら最初に作ったリストとマッチング
    • マッチしたら置き換え
    • そうでなければレキシカルアドレスなリストの car 要素を +1 して置き換え

あら? ちょっとシミュレイトしてみる。
例えば以下なケースで、*1 な箇所で考えてみる

(lambda (a b c)
  (if (eqv? b c)  
    ((lambda (c) ;; *1

ええと、argl は以下

((a (0 0)) (b (0 1)) (c (0 2)))

で、マッチングするリストは以下

((c (0 0)))

ええと、これって最後までマッチしないケースってどうするんだろ。あ、マッチした場合にはリストから取れば良いのか。で、argl をパースし終わって残ってたらリストに追加してやれば良い、と。ちなみに以下のケースだと

;; argl が以下
((a (0 0)) (b (0 1)) (c (0 2)))

;; 新たな引数
((c (0 0)) (d (0 1)))

って試験書いてナニした方が早いな。かなり今日は調子が悪い模様。以下な試験を書いた。

(use gauche.test)

(add-load-path ".")
(load "lexical-address")

(test-start "lexical-address")
(test-section "lexical-address")

(test-section "make-argl")
(test* "(make-argl '() '(a b c)) should return ((a (0 0)) (b (0 1)) (c (0 1)))"
       '((a (0 0)) (b (0 1)) (c (0 2)))
       (make-argl '() '(a b c)))
(test-end)

まだ手続き本体はスルー状態。make-argl の一部を書いてみました。

(define (make-argl argl1 lst)
  (define (make-new-argl l)
    (define (make-new-argl-inner rslt d p l)
      (if (null? l)
	  rslt
	  (make-new-argl-inner (append rslt (list (list (car l) (list d p))))
			       d
			       (+ p 1)
			       (cdr l))))
    (make-new-argl-inner '() 0 0 l))
  (let ((argl2 (make-new-argl lst)))
    (if (null? argl1)
	argl2
	;; 一旦スルー
	))
  )

(define (lexical-address l)
  )

一応試験にはパスしています。次は例示されている以下なナニ。

(test* "(make-argl '((a (0 0)) (b (0 1)) (c (0 2))) '(c)) should return 
        ((a (1 0)) (b (1 1)) (c 0 0))"
       '((a (1 0)) (b (1 1)) (c 0 0))
       (make-argl '((a (0 0)) (b (0 1)) (c (0 2))) '(c)))

実装できたんですが、もの凄いコトになってしまいました。あまりにも微妙なので今からリファクタリング実施。
で、出てきたのが以下。あまりにも微妙杉。

(define (make-argl argl1 lst)
  (define (make-new-argl l)
    (define (make-new-argl-inner rslt d p l)
      (if (null? l)
	  rslt
	  (make-new-argl-inner (append rslt (list (list (car l) (list d p))))
			       d
			       (+ p 1)
			       (cdr l))))
    (make-new-argl-inner '() 0 0 l))
  (let ((argl2 (make-new-argl lst)))
    (if (null? argl1)
	argl2
	(let f ((l1 argl1) (l2 argl2) (rslt '()))
	  (if (null? l1) 
	      rslt
	      (cond ((eq? (caar l1) (caar l2))
		     (f (cdr l1) (cdr l2) (append rslt (list (car l2)))))
		    (else
		     (let ((tmp1 (caar l1)) (tmp2 (cadr (car l1))))
		       (let ((tmp3 (list (cons tmp1 
					       (list (cons (+ 1 (car tmp2)) 
							   (cdr tmp2)))))))
			 (f (cdr l1) l2 (append rslt tmp3)))))))
	  )
	))
  )

(define (lexical-address l)
  )

まだデキ上がりでもないし、上記の手続き、ぱっと見微妙スギる。今日はへろへろ具合が微妙なカンジなのでもう寝ます。