suzanne.soy/whalesong
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

some testing on letrec

Browse Source
This commit is contained in:
Danny Yoo 2011-03-25 18:35:12 -04:00
parent c75385278c
commit 32e1f1a5dc
4 changed files with 91 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
assemble.rkt
View File

@ -156,6 +156,8 @@ EOF
[(RestoreEnvironment!? op) [(RestoreEnvironment!? op)
empty] empty]
[(RestoreControl!? op) [(RestoreControl!? op)
empty]
[(FixClosureShellMap!? op)
empty])) empty]))
(unique/eq? (unique/eq?
@ -440,7 +442,17 @@ EOF
[(RestoreEnvironment!? op) [(RestoreEnvironment!? op)
"MACHINE.env = MACHINE.env[MACHINE.env.length - 2].slice(0);"] "MACHINE.env = MACHINE.env[MACHINE.env.length - 2].slice(0);"]
[(RestoreControl!? op) [(RestoreControl!? op)
"MACHINE.control = MACHINE.env[MACHINE.env.length - 1].slice(0);"])) "MACHINE.control = MACHINE.env[MACHINE.env.length - 1].slice(0);"]
[(FixClosureShellMap!? op)
(format "MACHINE.env[MACHINE.env.length - 1 - ~a].closedVals = [~a]"
(FixClosureShellMap!-depth op)
(string-join (map assemble-env-reference/closure-capture
;; The closure values are in reverse order
;; to make it easier to push, in bulk, into
;; the environment (which is also in reversed order)
;; during install-closure-values.
(reverse (FixClosureShellMap!-closed-vals op)))
", "))]))
(: assemble-input (OpArg -> String)) (: assemble-input (OpArg -> String))

6
parse.rkt
View File

@ -455,8 +455,10 @@
;; Semantics: allocate a closure shell for each lambda form in procs. ;; Semantics: allocate a closure shell for each lambda form in procs.
;; Install them in reverse order, so that the closure shell for the last element ;; Install them in reverse order, so that the closure shell for the last element
;; in procs is at stack position 0. ;; in procs is at stack position 0.
(make-LetRec (map (lambda (rhs) (parse rhs new-cenv)) (make-LetRec (map (lambda (rhs name) (parameterize ([current-defined-name name])
rhss) (parse rhs new-cenv)))
rhss
vars)
(parse `(begin ,@body) new-cenv)))] (parse `(begin ,@body) new-cenv)))]
[else [else
(let ([new-cenv (extend-lexical-environment/boxed-names cenv (reverse vars))]) (let ([new-cenv (extend-lexical-environment/boxed-names cenv (reverse vars))])

20
test-compiler.rkt
View File

@ -713,6 +713,26 @@
'(()())) '(()()))
(let ([op (open-output-string)])
(parameterize ([current-simulated-output-port op])
(test
'(letrec ([a (lambda (x)
(display "a") (display x) (c (add1 x)))]
[b (lambda (k)
(display "b") (display k) (e (add1 k)))]
[c (lambda (y)
(display "c") (display y) (b (add1 y)))]
[d (lambda (z)
(display "d") (display z) z)]
[e (lambda (x)
(display "e") (display x) (d (add1 x)))])
(a 0))
4))
(unless (string=? "a0c1b2e3d4" (get-output-string op))
(error 'letrec-failed)))
#;(test (read (open-input-file "tests/conform/program0.sch")) #;(test (read (open-input-file "tests/conform/program0.sch"))
(port->string (open-input-file "tests/conform/expected0.txt"))) (port->string (open-input-file "tests/conform/expected0.txt")))

82
test-parse.rkt
View File

@ -278,50 +278,76 @@
(make-Top (make-Prefix '()) (make-Constant 42))) (make-Top (make-Prefix '()) (make-Constant 42)))
(test (parse '(letrec ([omega (lambda () (omega))])
(omega)))
(make-Top (make-Prefix '())
(make-LetRec (list (make-Lam 'omega 0 (make-App (make-LocalRef 0 #f)
(list)) '(0) 'lamEntry1))
(make-App (make-LocalRef 0 #f) (list)))))
(test (parse '(letrec ([a (lambda () (b))]
[b (lambda () (c))]
[c (lambda () (a))])
(a)))
(make-Top (make-Prefix '())
(make-LetRec (list (make-Lam 'a 0 (make-App (make-LocalRef 0 #f) '()) '(1) 'lamEntry1)
(make-Lam 'b 0 (make-App (make-LocalRef 0 #f) '()) '(0) 'lamEntry2)
(make-Lam 'c 0 (make-App (make-LocalRef 0 #f) '()) '(2) 'lamEntry3))
(make-App (make-LocalRef 2 #f) '()))))
(test (parse '(letrec ([x (lambda (x) x)] (test (parse '(letrec ([x (lambda (x) x)]
[y (lambda (x) x)]) [y (lambda (x) x)])
(set! x x)
(x y))) (x y)))
(make-Top (make-Prefix '()) (make-Top (make-Prefix '())
(make-LetVoid 2 (make-LetVoid 2
(make-Seq (make-Seq
(list (list
(make-InstallValue 0 (make-InstallValue 1
(make-Lam 'x 1 (make-LocalRef 0 #f) '() 'lamEntry1) (make-Lam 'x 1 (make-LocalRef 0 #f) '() 'lamEntry1)
#t) #t)
(make-InstallValue 1 (make-InstallValue 0
(make-Lam 'y 1 (make-LocalRef 0 #f) '() 'lamEntry2) (make-Lam 'y 1 (make-LocalRef 0 #f) '() 'lamEntry2)
#t) #t)
;; stack layout: ??? x y ;; stack layout: ??? x y
(make-App (make-LocalRef 1 #t) (make-Seq (list (make-Seq (list (make-InstallValue 1 (make-LocalRef 1 #t) #t)
(list (make-LocalRef 2 #t))))) (make-Constant (void))))
(make-App (make-LocalRef 2 #t)
(list (make-LocalRef 1 #t)))))))
#t))) #t)))
(test (parse '(letrec ([x (lambda (x) (y x))] #;(test (parse '(letrec ([x (lambda (x) (y x))]
[y (lambda (x) (x y))]) [y (lambda (x) (x y))])
(x y))) (x y)))
(make-Top (make-Prefix '()) (make-Top (make-Prefix '())
(make-LetVoid 2 (make-LetVoid 2
(make-Seq (make-Seq
(list (list
(make-InstallValue 0 (make-InstallValue 0
(make-Lam 'x 1 (make-Lam 'x 1
(make-App (make-LocalRef 1 #t) (make-App (make-LocalRef 1 #t)
(list (make-LocalRef 2 #f))) (list (make-LocalRef 2 #f)))
'(1) '(1)
'lamEntry1) 'lamEntry1)
#t) #t)
(make-InstallValue 1 (make-InstallValue 1
(make-Lam 'y 1 (make-Lam 'y 1
(make-App (make-LocalRef 2 #f) (make-App (make-LocalRef 2 #f)
(list (make-LocalRef 1 #t))) (list (make-LocalRef 1 #t)))
'(1) '(1)
'lamEntry2) 'lamEntry2)
#t) #t)
;; stack layout: ??? x y ;; stack layout: ??? x y
(make-App (make-LocalRef 1 #t) (make-App (make-LocalRef 1 #t)
(list (make-LocalRef 2 #t))))) (list (make-LocalRef 2 #t)))))
#t))) #t)))
(test (parse '(let ([x 0]) (test (parse '(let ([x 0])
(lambda () (lambda ()