3imp 読んでみる (7)
なかなか stack based に辿りつきません。
コンパイラの前に
record-case の定義の検討を
(define-syntax record-case
(syntax-rules (else)
((_ exp1 (else exp3 ...)) (begin exp3 ...))
((_ exp1 (key vars exp2 ...))
(if (eq? (car exp1) key) (record vars (cdr exp1) exp2 ...)))
((_ exp1 (key vars exp2 ...) c ...)
(if (eq? (car exp1) key)
(record vars (cdr exp1) exp2 ...)
(record-case exp1 c ...)))))なんか Kent Dybvig さんのナニをパクリまくってます。これも含め、試験書いた方が良さげ。とりあえずソースを準備。TDD な原則として微妙ですが以下。
;; heapbased.scm
(define-syntax rec
(syntax-rules ()
((_ a b) (let ([a '()])
(set! a b)))))
(define-syntax recur
(syntax-rules ()
((_ f ([v i] ...) e ...)
((rec f (lambda (v ...) e ...))
i ...))))
(define-syntax record
(syntax-rules ()
((_ (var ...) val exp ...)
(apply (lambda (var ...) exp ...) val))))
(define-syntax record-case
(syntax-rules (else)
((_ exp1 (else exp3 ...)) (begin exp3 ...))
((_ exp1 (key vars exp2 ...))
(if (eq? (car exp1) key) (record vars (cdr exp1) exp2 ...)))
((_ exp1 (key vars exp2 ...) c ...)
(if (eq? (car exp1) key)
(record vars (cdr exp1) exp2 ...)
(record-case exp1 c ...)))))
(define (tail? next)
(eq? (car next) 'return))
(define (compile x next)
(cond
[(symbol? x)
(list 'refer x next)]
[(pair? x)
(record-case x
[quote (obj)
(list 'constant obj next)]
[lambda (vars body)
(list 'close vars (compile body '(return)) next)]
[if (test then else)
(let ([thenc (compile then next)]
[elsec (compile else next)])
(compile test (list 'test thenc elsec)))]
[set! (var x)
(compile x (list 'assign var next))]
[call/cc (x)
(let ([c (list 'conti
(list 'argument
(compile x '(apply))))])
(if (tail? next)
c
(list 'frame next c)))]
[else
(recur loop ([args (cdr x)]
[c (compile (car x) '(apply))])
(if (null? args)
(if (tail? next)
c
(list 'frame next c))
(loop (cdr args)
(compile (car args)
(list 'argument c)))))])]
[else
(list 'constant x next)]))上記がビンゴかダウトかは知りませんが試験を。とりあえず rec から、なんですが使い方としては
(rec var exp)
の exp は lambda 式がデフォルト、で試験して良いのでしょうか。例示されているナニとしては以下で
(rec count
(lambda (x)
(if (null? x)
0
(+ (count (cdr x)) 1))))な式が戻すのは closure だけど count は中でのみ有効な名前になっているはず。あと、戻りな closure の試験を含め、以下
;; test-rec.scm (use gauche.test) (add-load-path ".") (load "heapbased") (test-start "rec") (test-section "3imp sample") (let ((p (rec count (lambda (x) (if (null? x) 0 (+ (count (cdr x)) 1)))))) (test* "nonexistent count" *test-error* count) (test* "rec return closure" 5 (p '(1 2 3 4 5))) ) (test-end)
Makefile 使ってれば emacs で全部完結するのに今日ようやく気づきました。Makefile は微妙ですが以下
SHELL=/bin/sh TARGET=$(wildcard test-*.scm) test: @rm -f test.log @for X in $(TARGET) ; do gosh $$X >> test.log ; done clean: rm -rf *~ test.log
M-x compile で試験できる。次の recur もサンプルで試験か。
;; test-recur.scm (use gauche.test) (add-load-path ".") (load "heapbased") (test-start "recur") (test-section "3imp sample") (test* "returns 5" 5 (recur count ([x '(a b c d e)]) (if (null? x) 0 (+ (count (cdr x)) 1)))) (test-end)
本当はもう少しきちんと試験せねば、なんでしょうがとりあえずこれでスルー。次は record を。これも簡単にこんなカンジ。本当はきちんと試験しないとダメなのでしょうね。
;; test-record.scm
(use gauche.test)
(add-load-path ".")
(load "heapbased")
(test-start "record")
(test-section "3imp sample")
(test* "returns (reverse '(1 2 3))"
'(3 2 1)
(record (a b c) '(1 2 3) (list c b a)))
(test-end)record-case のサンプルは面白そげ。不足気味ですが試験が以下
;; test-record-case.scm (use gauche.test) (add-load-path ".") (load "heapbased") (test-start "record-case") (test-section "3imp sample") (let ([p (rec calc (lambda (x) (if (integer? x) x (record-case x [+ (x y) (+ (calc x) (calc y))] [* (x y) (* (calc x) (calc y))] [- (x) (- 0 (calc x))] [else (error "invalid exp")]))))]) (test* "(p 1) is 1" 1 (p 1)) (test* "(P (+ 2 3)) is 5" 5 (p (+ 2 3))) (test* "(p (* 2 3)) is 6" 6 (p (* 2 3))) (test* "(p (+ (* 2 3) 4) is 10" 10 (p (+ (* 2 3) 4))) (test* "(p (- 5)) is -5" -5 (p (- 5))) (test* "(p (+ (- 5) 5)) is 0" 0 (p (+ (- 5) 5))) (test* "other" *test-error* (p (/ 5 3))) ) (test-end)
一応上記の試験にはパス。かなりええ加減だなぁ。とりあえず tail? の試験を
;; test-compile.scm (use gauche.test) (add-load-path ".") (load "heapbased") (test-start "compile") (test-section "tail?") (test* "not tail" #f (tail? '(halt))) (test* "tail" #t (tail? '(return))) (test-end)
パスしたので本体の試験を検討ですが、とりあえず簡単なのから。
(test-section "constant")
(test* "(compile 1 '(halt)) returns (constant 1 (halt))"
'(constant 1 (halt))
(compile 1 '(halt)))
(test-section "symbol")
(test* "(compile 'x '(halt)) returns (refer x (halt))"
'(refer x (halt))
(compile 'x '(halt)))残りは
- quote
- lambda
- if
- set!
- call/cc
- 手続き
なんですが、ここで再度エントリ投入。
続き
quote は簡単なはず、と以下の試験をでっち上げた。
(test-section "quote")
(test* "(compile '(quote x) '(halt)) returns (constant x (halt))"
'(constant x (halt))
(compile '(quote x) '(halt)))試験失敗。(出力は整形してます
Testing compile ... failed. discrepancies found. Errors are: test (compile '(quote x) '(halt)) returns (constant x (halt)): expects (constant x (halt)) => got (frame (halt) (refer x (argument (refer quote (apply)))))
おかしいな。record-case が微妙? ええと record-case に入ってるとして call/cc なソレに入ってるように見えるぞ。やっぱ define-syntax が微妙なんだな。
ってか試験にパスしたんじゃねぇのかよ、と。よく試験と定義を見てみると key を quote しないと駄目なの? という事に気づく。これは試験が足りてません。とりあえず record-case の define-syntax を以下に修正したら試験パス。
(define-syntax record-case
(syntax-rules (else)
((_ exp1 (else exp3 ...)) (begin exp3 ...))
((_ exp1 (key vars exp2 ...))
(if (eq? (car exp1) 'key) (record vars (cdr exp1) exp2 ...)))
((_ exp1 (key vars exp2 ...) c ...)
(if (eq? (car exp1) 'key)
(record vars (cdr exp1) exp2 ...)
(record-case exp1 c ...)))))しかしどんな試験をしておくべきか。以下は微妙スギ??
(test-section "symbol") (let ([p (lambda (x) (record-case x [quote (obj) (list 'constant obj)] [lambda (vars body) (list 'close vars body)] [else (list 'else)]))]) (test* "(p '(quote x)) returns (constant x)" '(constant x) (p '(quote x))) (test* "(p '(lambda x y)) returns (close x y)" '(close x y) (p '(lambda x y))) (test* "(p '(xxx)) returns (else)" '(else) (p '(xxx))) )
いやはや。とりあえず買い物に行ってきます。
