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))))
これで試験にパス。なんつーか微妙杉。現実に戻ります。