EoPL reading (71) 2.2 An Abstraction for Inductive Data Type
もっぺん問題を読んで整理
- Figure 2.2 な BNF に沿った形で parse と unparse 修正
- lexical-address 手続き実装
- lex-info とか free-info な variant 使う
- unparse を lex-info とか free-info を val-exp に置き換えるよう修正
現状、最初のはなんとかなってて lexical-address の if な試験を云々、というあたりで昨晩死亡した模様。ちょっと (?) ぐちゃぐちゃになってる感満点なので、試験を一から書きなおしてみることにする。
あ、そういえば readingGauche のレビュー担当だった事を思いだしたぞ。とりあえず晩に確認ってコトで今は試験の書き直しに着手 (を
まず expression の試験から。
(use gauche.test)
(add-load-path ".")
(load "define-datatype")
(load "expression")
(test-start "expression")
(test-section "expression")
(test* "expression is ..."
'((lit-exp var-exp if-exp lambda-exp app-exp)
(lit-exp datum)
(var-exp id)
(if-exp test-exp true-exp false-exp)
(lambda-exp ids body)
(app-exp rands))
expression)
(test-section "expression?")
(test* "(lit-exp) is expression"
#t
(expression? '(lit-exp)))
(test* "(var-exp) is expression"
#t
(expression? '(var-exp)))
(test* "(if-exp) is expression"
#t
(expression? '(if-exp)))
(test* "(lambda-exp) is expression"
#t
(expression? '(lambda-exp)))
(test* "(app-exp) is expression"
#t
(expression? '(app-exp)))
(test-section "lit-exp")
(test* "(lit-exp 1) is (lit-exp 1)"
'(lit-exp 1)
(lit-exp 1))
(test-section "var-exp")
(test* "(var-exp 'x) is (var-exp x)"
'(var-exp x)
(var-exp 'x))
(test-section "if-exp")
(test* "(if-exp (var-exp x) (lit-exp 1) (lit-exp 2)) is ..."
'(if-exp (var-exp x) (lit-exp 1) (lit-exp 2))
(if-exp (var-exp 'x) (lit-exp 1) (lit-exp 2)))
(test-section "lambda-exp")
(test* "(lambda-exp (x) (lit-exp 1)) is ..."
'(lambda-exp (x) (lit-exp 1))
(lambda-exp '(x) (lit-exp 1)))
(test-section "app-exp")
(test* "(app-exp (var-exp x) (lit-exp 1)) is ..."
'(app-exp (var-exp x) (lit-exp 1))
(app-exp (var-exp 'x) (lit-exp 1)))
(test-end)いっちゃん下の app-exp なナニがパスしない。expression の定義は以下です。
(define-datatype expression expression? (lit-exp (datum number?)) (var-exp (id symbol?)) (if-exp (test-exp expression?) (true-exp expression?) (false-exp expression?)) (lambda-exp (ids (list-of symbol?)) (body expression?)) (app-exp (rands (list-of expression?))))
そりゃ通らんよなぁ。cases な定義は無理矢理なんとかしたんですが、define-datatype なナニに手を入れてませんので試験にパスしないで当たり前と言えば当たり前。
しかし今回の無理矢理な修正はやはりダウトなのかなぁ。define-datatype 的には以下な部分でダウト認定されている模様。
(define Variant-name
(let ((expected-length (length '(Field-name ...)))
(field-names '(Field-name ...))
(pred-names '(Pred? ...))
(preds (list (lambda (x) (Pred? x)) ...)))
(lambda args
(if (not (= (length args) expected-length))
(define-datatype:report-error 'Variant-name
(string-append
"Expected ~s arguments but got ~s arguments."
"~n Fields are: ~s ~n Args are: ~s.")
expected-length (length args) '(Field-name ...) args))
(for-each
(lambda (a f p pname)
(if (not (p a))
(define-datatype:report-error 'Variant-name "~n Bad ~a field (~s ~s) ==> #f."
f pname a)))
args
field-names
preds
pred-names)
(cons 'Variant-name args))))expected-length と (length args) が等しくありません。ってかよく考えたら lambda-exp の ids は普通にリストで済ませてるんだから app-exp の場合も
'(app-exp ((var-exp x) (lit-exp 1)))
って書け、とゆー事か。これなら cases の微妙な修正も不要だな。とりあえず app-exp な試験は以下で通す方向で。
(test-section "app-exp")
(test* "(app-exp '((var-exp x) (lit-exp 1))) is ..."
'(app-exp ((var-exp x) (lit-exp 1)))
(app-exp '((var-exp x) (lit-exp 1))))cases の以下な部分もコメントアウト。
(syntax-rules (else)
((_ Variant (else Body0 Body1 ...))
(begin Body0 Body1 ...))
; ((_ Variant (Purported-variant-name (Purported-field-name)
; Body0 Body1 ...))
; (apply (lambda (Purported-field-name) Body0 Body1 ...)
; (list (cdr Variant))))次は parse と unparse を確認。試験を以下に修正。一応カバーしてるはずなんですが。
(use gauche.test)
(add-load-path ".")
(load "define-datatype")
(load "expression")
(load "occurs-free")
(load "parse")
(test-start "parse")
(test-section "unparse-expression")
(test* "unparse 1"
1
(unparse-expression '(lit-exp 1)))
(test* "unparse 'a"
'a
(unparse-expression '(var-exp a)))
(test* "unparse (if x 1 2)"
'(if x 1 2)
(unparse-expression '(if-exp (var-exp x) (lit-exp 1) (lit-exp 2))))
(test* "unparse (lambda (x) x)"
'(lambda (x) x)
(unparse-expression '(lambda-exp (x) (var-exp x))))
(test* "unparse ((lambda (x) x) a)"
'((lambda (x) x) a)
(unparse-expression '(app-exp ((lambda-exp (x) (var-exp x)) (var-exp a)))))
(test* "unparse (lambda (x) (f x y))"
'(lambda (x) (f x y))
(unparse-expression '(lambda-exp (x) (app-exp ((var-exp f) (var-exp x) (var-exp y))))))
(test* "unparse (lambda (x) (x))"
'(lambda (x) (x))
(unparse-expression '(lambda-exp (x) (app-exp ((var-exp x))))))
(test* "unparse (lambda (x y z) x)"
'(lambda (x y z) x)
(unparse-expression '(lambda-exp (x y z) (var-exp x))))
(test* "unparse (lambda () x)"
'(lambda () x)
(unparse-expression '(lambda-exp () (var-exp x))))
(test* "unparse (if (null? l) x y)"
'(if (null? l) x y)
(unparse-expression '(if-exp (app-exp ((var-exp null?) (var-exp l)))
(var-exp x)
(var-exp y))))
(test-section "parse-expression")
(test* "parse 1"
'(lit-exp 1)
(parse-expression 1))
(test* "parse 'a"
'(var-exp a)
(parse-expression 'a))
(test* "parse (if x 1 2)"
'(if-exp (var-exp x) (lit-exp 1) (lit-exp 2))
(parse-expression '(if x 1 2)))
(test* "parse (lambda (x) x)"
'(lambda-exp (x) (var-exp x))
(parse-expression '(lambda (x) x)))
(test* "parse ((lambda (x) x) a)"
'(app-exp ((lambda-exp (x) (var-exp x)) (var-exp a)))
(parse-expression '((lambda (x) x) a)))
(test* "string is undefined"
*test-error*
(parse-expression "a"))
(test* "parse (a b c)"
'(app-exp ((var-exp a) (var-exp b) (var-exp c)))
(parse-expression '(a b c)))
(test* "parse ((lambda (x) (+ x x)) a)"
'(app-exp ((lambda-exp (x) (app-exp ((var-exp +) (var-exp x) (var-exp x)))) (var-exp a)))
(parse-expression '((lambda (x) (+ x x)) a)))
(test* "parse (lambda (x) (x))"
'(lambda-exp (x) (app-exp ((var-exp x))))
(parse-expression '(lambda (x) (x))))
(test-end)で、上記は app-exp のリストのあたりでパスしないはず。と思ったら parse は全部パスしてやんの。って上書きしてなかったのか (とほほ
ええと、unparse は大丈夫ですね。あら、駄目だな。cases の定義の以下もコメントアウトの必要あり、でした。
;; ((_ Variant (Purported-variant-name (Purported-field-name) ;; Body0 Body1 ...) ;; Clause ...) ;; (if (eq? (car Variant) 'Purported-variant-name) ;; (apply (lambda (Purported-field-name) Body0 Body1 ...) ;; (list (cdr Variant))) ;; (define-datatype:case-helper Variant Clause ...)))
unparse はこれで OK でした。parse が微妙。unparse と parse がごっちゃになりつつ、まず以下な試験が NG。
(test* "parse (if x 1 2)"
'(if-exp (var-exp x) (lit-exp 1) (lit-exp 2))
(parse-expression '(if x 1 2)))実装は、って見てみると
((eqv? (car datum) 'if) (if-exp (cadr datum) (caddr datum) (cadddr datum)))
これは駄目っしょ。以下に修正か。
((eqv? (car datum) 'if) (if-exp (parse-expression (cadr datum)) (parse-expression (caddr datum)) (parse-expression (cadddr datum))))
あとは app-exp あたりの処理が未実装なはずなのでそれがなんとかなれば OK かな。で、実装を見てみたら以下。
(else (let f ((rslt '(app-exp)) (datum datum)) (if (null? datum) rslt (f (append rslt (list (parse-expression (car datum)))) (cdr datum)))))))
ええと、最初の app-exp セットして append してるのでナニ。最後に app-exp を付ければ良いだろ、ってコトで以下。
(else (let f ((rslt '()) (datum datum)) (if (null? datum) (cons 'app-exp (list rslt)) (f (append rslt (list (parse-expression (car datum)))) (cdr datum)))))))
なんか小手先な感じ満点ですが、以下な試験のみ NG。
(test* "parse (if (null? l) x y)"
'(if-exp (app-exp ((var-exp null?) (var-exp l))) (var-exp x) (var-exp y))
(parse-expression (if (null? l) x y)))不具合なメセジが以下なんですが
test parse (if (null? l) x y): expects (if-exp (app-exp ((var-exp null?) (var-exp l))) (var-exp x) (var-exp y)) => got #<error "unbound variable: l">
これはどーゆー意味か、と。
あ、こうか。
(test* "parse (if (null? l) x y)"
'(if-exp (app-exp ((var-exp null?) (var-exp l))) (var-exp x) (var-exp y))
(parse-expression '(if (null? l) x y)))修正で試験パス。次は occurs-free な試験。実装に手を入れたのは lambda-exp の引数のチェックの部分のみ。
(add-load-path ".")
(load "define-datatype")
(load "expression")
(define occurs-free?
(lambda (var exp)
(cases expression exp
(lit-exp (num) #f)
(var-exp (id) (eqv? id var))
(if-exp (test-exp true-exp false-exp)
(or (occurs-free? test-exp)
(occurs-free? true-exp)
(occurs-free? false-exp)))
(lambda-exp (ids body)
(and (not (memq var ids))
(occurs-free? var body)))
(app-exp (rands)
(let f ((rands rands))
(cond ((null? rands) #f)
((occurs-free? var (car rands)) #t)
(else
(f (cdr rands)))))))))試験についても app-exp と lambda-exp の括弧の追加のみ。
(use gauche.test)
(add-load-path ".")
(load "define-datatype")
(load "expression")
(load "occurs-free")
(test-start "occurs-free?")
(test-section "var-exp")
(test* "not occurs free (var-exp)"
#f
(occurs-free? 'x '(var-exp y)))
(test* "occurs free (var-exp)"
#t
(occurs-free? 'y '(var-exp y)))
(test-section "lambda-exp")
(test* "occurs free y (lambda (x) y)"
#t
(occurs-free? 'y '(lambda-exp (x) (var-exp y))))
(test* "not occurs free y (lambda (y) y)"
#f
(occurs-free? 'y '(lambda-exp (y) (var-exp y))))
(test* "not occurs free y (lambda (x) x)"
#f
(occurs-free? 'y '(lambda-exp (x) (var-exp x))))
(test-section "app-exp")
(test* "occurs free y (lambda"
#t
(occurs-free? 'y '(app-exp ((lambda-exp (x) (var-exp y)) (var-exp y)))))
(test* "occurs free (app-exp)"
#t
(occurs-free? 'y '(app-exp ((lambda-exp (y) (var-exp y)) (var-exp y)))))
(test* "not occurs free (app-exp)"
#f
(occurs-free? 'y '(app-exp ((lambda-exp (y) (var-exp y)) (var-exp x)))))
(test-end)逆言えばこの程度の修正で直ってくれないと困ります。ええと、これで lexical-address なソレに戻れるのか。とりあえず、expression 方式に沿って以下の定義の試験を書く。
(add-load-path ".") (load "define-datatype") (define-datatype variable-reference variable-reference? (lex-info (id symbol?) (depth number?) (position number?)) (free-info (id symbol?)))
試験が以下。
(use gauche.test)
(add-load-path ".")
(load "define-datatype")
(load "variable-reference")
(test-start "variable-reference")
(test* "variable-reference is ..."
'((lex-info free-info)
(lex-info id depth position)
(free-info id))
variable-reference)
(test-section "variable-reference?")
(test* "(lex-info) is variable-reference"
#t
(variable-reference? '(lex-info)))
(test* "(free-info) is variable-reference"
#t
(variable-reference? '(free-info)))
(test-section "lex-info")
(test* "(lex-info x 0 0) is (lex-info x 0 0)"
'(lex-info x 0 0)
(lex-info 'x 0 0))
(test-section "free-info")
(test* "(free-info x) is (free-info x)"
'(free-info x)
(free-info 'x))
(test-end)これはとりあえずパスして当然な試験。ようやく lexical-address の試験です。スデに書いてあるんですがキタナくて貼りたくないです。見栄えを修正して以下。
(use gauche.test)
(add-load-path ".")
(load "lexical-address")
(test-start "lexical-address")
(test-section "lexical-address")
(test* "'(lit-exp 1) "
1
(lexical-address '(lit-exp 1)))
(test* "(var-exp a) "
'(free-info a)
(lexical-address '(var-exp a)))
(test* "(app-exp ((var-exp a) (var-eexp b)))"
'((free-info a) (free-info b))
(lexical-address '(app-exp ((var-exp a) (var-exp b)))))
(test* "(lambda-exp (x y) (app-exp (((var-exp +) (var-exp x) (var-exp y)))))"
'(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))))))
(test* "(app-exp ((lambda-exp
(x y)
(app-exp ((var-exp +) (var-exp x) (var-exp y))))
(var-exp a) (var-exp b)))"
'((lambda (x y) ((free-info +) (lex-info x 0 0) (lex-info y 0 1)))
(free-info a) (free-info b))
(lexical-address '(app-exp
((lambda-exp
(x y)
(app-exp ((var-exp +) (var-exp x) (var-exp y))))
(var-exp a) (var-exp b)))))
(test* "(if-exp (app-exp ((var-ex =) (var-exp x) (var-exp y)))
(var-exp x)
(var-exp y))"
'(if ((free-info =) (free-info x) (free-info y))
(free-info x)
(free-info y))
(lexical-address '(if-exp
(app-exp ((var-exp =) (var-exp x) (var-exp y)))
(var-exp x)
(var-exp y))))
(test-end)if の試験がパスしてません。これは実装が微妙。修正元は微妙杉るので略。修正後のソレが以下です。
(add-load-path ".")
(load "define-datatype")
(load "expression")
(load "variable-reference")
(define (lexical-address exp)
(define (lexical-address-inner rslt dict l)
(cases expression l
(lit-exp (datum) datum)
(var-exp (id)
(let f ((d 0) (p 0) (dict dict))
(cond ((null? dict) (free-info id))
((memq id (car dict))
(let f-inner ((p p) (dict (car dict)))
(if (eq? id (car dict))
(lex-info id d p)
(f-inner (+ p 1) (cdr dict)))))
(else
(f (+ d 1) 0 (cdr dict))))))
(if-exp (test-exp true-exp false-exp)
(append rslt
(list 'if
(lexical-address-inner '() dict test-exp)
(lexical-address-inner '() dict true-exp)
(lexical-address-inner '() dict false-exp))))
(lambda-exp (ids body)
(append (append rslt `(lambda ,ids))
(list (lexical-address-inner '()
(cons ids dict)
body))))
(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))))))
))
(lexical-address-inner '() '() exp))なんつーか微妙。以下な試験も追加してます。
(test* "(lambda-exp (x y)
(if-exp (app-exp ((var-exp =) (var-exp y) (lit-exp 0)))
(var-exp x)
(app-exp ((var-exp +) (var-exp x) (var-exp y)))))"
'(lambda (x y) (if ((free-info =) (lex-info y 0 1) 0)
(lex-info x 0 0)
((free-info +) (lex-info x 0 0) (lex-info y 0 1))))
(lexical-address '(lambda-exp
(x y)
(if-exp (app-exp ((var-exp =) (var-exp y) (lit-exp 0)))
(var-exp x)
(app-exp ((var-exp +) (var-exp x) (var-exp y)))))))一応 lexical-address 自体は OK なのかなぁ。lambda をネストさせてみるか。
(test* "(lambda-exp (x y z)
(app-exp (lambda-exp (x y) (app-exp ((var-exp +)
(var-exp x)
(var-exp y)
(var-exp z)))
(var-exp y) (var-exp x))))"
'(lambda (x y z)
((lambda (x y) ((free-info +)
(lex-info x 0 0)
(lex-info y 0 1)
(lex-info z 1 2)))
(lex-info y 0 1) (lex-info x 0 0)))
(lexical-address '(lambda-exp (x y z)
(app-exp ((lambda-exp
(x y)
(app-exp ((var-exp +)
(var-exp x)
(var-exp y)
(var-exp z))))
(var-exp y) (var-exp x))))))試験の作成自体に若干試行錯誤しましたがパス。unparse 云々は別途。
