EoPL reading (69) 2.2 An Abstraction for Inductive Data Type

Exercise 2.7 の実装に着手して unparse-expression 見ながら進めててイヤな記述を発見。

           (if-exp (test-exp true-exp false-exp)
                   (list 'if test-exp true-exp false-exp))

これ、明らかに試験不足だな。以下な試験な出力が

(test* "unparse (8)"
       '(if (null? l) x y)
       (unparse-expression '(if-exp (app-exp (var-exp null?) (var-exp l))
				    (var-exp x)
				    (var-exp y))))

こうなります。

test unparse (8), expects (if (null? l) x y) ==> ERROR: GOT (if (app-exp (var-exp null?) (var-exp l)) (var-exp x) (var-exp y))

当然と言えば当然か。とりあえずここから見ないと駄目。で、ちゃっちゃとヤッツケたのが以下。

;;		   (list 'if test-exp true-exp false-exp))
		   (list 'if 
			 (unparse-expression test-exp) 
			 (unparse-expression true-exp) 
			 (unparse-expression false-exp)))

ただ、これをそのまんま lexical-address に転用は微妙。むむむ、と言いつつ以下をでっち上げた。

(add-load-path ".")
(load "define-datatype")
(load "expression")
(load "variable-reference")

(define (lexical-address exp)
  (define (lexical-address-inner rslt dict l)
    (cases expression exp
	   (lit-exp (datum) (car datum))
	   (var-exp (id)
		    (let f ((d 0) (p 0) (dict dict) (v (car id)))
		      (cond ((null? dict) (free-info v))
			    ((memq v (car dict))
			     (let f-inner ((p p) (dict (car dict)))
			       (if (eq? v (car dict))
				   (lex-info v d p)
				   (f-inner (+ p 1) (cdr dict)))))
			    (else
			     (f (+ d 1) 0 (cdr dict) v)))))
	   (if-exp (test-exp true-exp false-exp)
		   (lexical-address-inner
		    (lexical-address-inner
		     (lexical-address-inner 
		      (lexical-address-inner (append rslt '(if)) dict (cdr l))
		      dict test-exp)
		     dict true-exp)
		    dict false-exp))
	   (lambda-exp (ids body)
		       (lexical-address-inner (append rslt `(lambda ids))
					      (cons ids dict) body))
	   (app-exp (rands)
		    (let f ((rslt rslt) (rands rands))
		      (cond ((null? rands) rslt)
			    (f (append rslt 
				       (lexical-address-inner '() dict (car rands)))
			       (cdr rands)))))))
  (lexical-address-inner '() '() exp))

なんか微妙。とりあえず以下な試験にパスしてます。

(use gauche.test)

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

(test-start "lexical-address")
(test-section "lexical-address")
(test* "(lexical-address 1) should return 1"
       1
       (lexical-address '(lit-exp 1)))
(test* "(lexical-address 'a) should return '(free-info a)"
       '(free-info a)
       (lexical-address '(var-exp a)))

(test-end)

ええと、今気がついたんですが、lexical-address って parse 済みのナニが対象って考えていいのかなぁ。段々違うような気がしてきたんですが、構わず進めてみます。手続き書いちゃったし。
で、以下な試験を追加したらループする。

(test* "(lexical-address '(app-exp (var-exp a) (var-eexp b))) should return '((free-info a) (free-info b))"
       '((free-info a) (free-info b))
       (lexical-address '(app-exp (var-exp a) (var-exp b))))

うーん。微妙。で、app-exp な部分をこうしてみたら

	   (app-exp (rands)
		    rands)

こんな出力。

test (lexical-address '(app-exp (var-exp a) (var-eexp b))) should return '((free-info a) (free-info b)), expects ((free-info a) (free-info b)) ==> ERROR: GOT ((var-exp a) (var-exp b))

ちゃんとリストになって渡されてる。繰り返しとかループする訳ないしなぁ、と言いつつ実装を以下に。

	   (app-exp (rands)
		    (lexical-address-inner '() dict (car rands)))

これでもループする。むむむ、と言いつつ実装の上部分を見ると

(define (lexical-address exp)
  (define (lexical-address-inner rslt dict l)
    (cases expression exp

そりゃ再起したらいつまでも同じナニを見るわな。cases の部分を以下に修正。

    (cases expression l

で、試験動かしたら出力が以下。

test (lexical-address '(app-exp (var-exp a) (var-eexp b))) should return '((free-info a) (free-info b)), expects ((free-info a) (free-info b)) ==> ERROR: GOT (free-info a free-info b)

とほほ。やっぱリストにしないと駄目なのか。こんなカンジに修正。

	   (app-exp (rands)
		    (let f ((rslt rslt) (rands rands))
		      (cond ((null? rands) rslt)
			    (else
			     (f (append rslt 
					(list (lexical-address-inner '() dict (car rands))))
				(cdr rands))))))

なんか微妙にキタナい。もう少し綺麗に書けんかな。

続き

ちょっとだけ現実トウヒのつもりがどハマり。lambda な試験を書きました。最初は

((lambda (x y) (+ x y)) a b)

みたいな試験書いたんですがパスせず。最初からこんな複雑なのはダメだろ、と言いつつ以下な試験を書いてます。

(test* "(lexical-address '(lambda-exp (x y) (+ x y)) should return (lambda (x y) ((free-info +) (lex-info x 0 0) (lex-info y 0 1)))"
       '(lambda (x y) ((free-info +) (lex-info x 0 0) (lex-info y 0 1)))
       (lexical-address '(lambda-exp (x y) (app-exp (var-exp +) (var-exp x) (var-exp y)))))

横に長い。lambda な分岐は当初以下な実装になってました。

	   (lambda-exp (ids body)
		       (lexical-address-inner (append rslt `(lambda ids))
					      (cons ids dict) body))

試験にパスしない。これ、body の中身を一つづつ変換して append してるので

(lambda (x y) (free-info +) (lex-info x 0 0) (lex-info y 0 1))

みたいになる。あと上記実装だと以下な出力になる。

(lambda ids (free-info +) (lex-info x 0 0) (lex-info y 0 1))

これは微妙なので以下に修正。

	   (lambda-exp (ids body)
		       (lexical-address-inner (append rslt `(lambda ,ids))
					      (cons ids dict) body))

あと、body だけ別腹で消化させるように修正。

	   (lambda-exp (ids body)
		       (append (append rslt `(lambda ,ids))
			       (lexical-address-inner '()
						      (cons ids dict)
						      body)))

まだ出力が同じなんでリストでくるんで以下。

	   (lambda-exp (ids body)
		       (append (append rslt `(lambda ,ids))
			       (list (lexical-address-inner '()
							    (cons ids dict)
							    body))))

これで試験にパス。なんつーか微妙杉。現実に戻ります。