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

fixing tests for the simulator

Browse Source
This commit is contained in:
Danny Yoo 2011-03-20 22:24:49 -04:00
parent 80ad749022
commit 4f8217d5c6
4 changed files with 33 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
simulator-structs.rkt
View File

@ -57,7 +57,8 @@
) )
#:transparent) #:transparent)
(define-struct: toplevel ([vals : (Listof PrimitiveValue)]) (define-struct: toplevel ([names : (Listof (U #f Symbol))]
[vals : (Listof PrimitiveValue)])
#:transparent #:transparent
#:mutable) #:mutable)

8
simulator.rkt
View File

@ -197,7 +197,7 @@
(cond (cond
[(undefined? (list-ref (toplevel-vals a-top) (CheckToplevelBound!-pos op))) [(undefined? (list-ref (toplevel-vals a-top) (CheckToplevelBound!-pos op)))
(error 'check-toplevel-bound! "Unbound identifier ~s" (error 'check-toplevel-bound! "Unbound identifier ~s"
(CheckToplevelBound!-name op))] (list-ref (toplevel-names a-top) (CheckToplevelBound!-pos op)))]
[else [else
'ok]))] 'ok]))]
@ -216,7 +216,8 @@
[(ExtendEnvironment/Prefix!? op) [(ExtendEnvironment/Prefix!? op)
(env-push! m (env-push! m
(make-toplevel (map (lambda: ([id/false : (U Symbol False)]) (make-toplevel (ExtendEnvironment/Prefix!-names op)
(map (lambda: ([id/false : (U Symbol False)])
(if (symbol? id/false) (if (symbol? id/false)
(lookup-primitive id/false) (lookup-primitive id/false)
#f)) #f))
@ -285,8 +286,7 @@
[(MakeCompiledProcedure? op) [(MakeCompiledProcedure? op)
(target-updater! m (make-closure (MakeCompiledProcedure-label op) (target-updater! m (make-closure (MakeCompiledProcedure-label op)
(MakeCompiledProcedure-arity op) (MakeCompiledProcedure-arity op)
(map (lambda: ([r : EnvReference]) (map (lambda: ([d : Natural]) (env-ref m d))
(lookup-env-reference/closure-capture m r))
(MakeCompiledProcedure-closed-vals op)) (MakeCompiledProcedure-closed-vals op))
(MakeCompiledProcedure-display-name op)))] (MakeCompiledProcedure-display-name op)))]

3
test-all.rkt
View File

@ -6,4 +6,5 @@
"test-assemble.rkt" "test-assemble.rkt"
"test-browser-evaluate.rkt" "test-browser-evaluate.rkt"
"test-package.rkt" "test-package.rkt"
#;"test-conform.rkt") #;"test-conform.rkt"
#;"test-conform-browser.rkt")

52
test-simulator.rkt
View File

@ -273,30 +273,31 @@
;; AssignPrimOpStatement ;; AssignPrimOpStatement
(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+ - * =)))))]) (let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+ - * =)))))])
(test (first (machine-env (run m))) (test (first (machine-env (run m)))
(make-toplevel (list (lookup-primitive '+) (make-toplevel '(+ - * =)
(list (lookup-primitive '+)
(lookup-primitive '-) (lookup-primitive '-)
(lookup-primitive '*) (lookup-primitive '*)
(lookup-primitive '=))))) (lookup-primitive '=)))))
(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(some-variable))) (let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(some-variable)))
,(make-AssignImmediateStatement 'val (make-Const "Danny")) ,(make-AssignImmediateStatement 'val (make-Const "Danny"))
,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0 'some-variable) (make-Reg 'val))))]) ,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0) (make-Reg 'val))))])
(test (machine-env (run m)) (test (machine-env (run m))
(list (make-toplevel (list "Danny"))))) (list (make-toplevel '(some-variable) (list "Danny")))))
(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(some-variable another))) (let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(some-variable another)))
,(make-AssignImmediateStatement 'val (make-Const "Danny")) ,(make-AssignImmediateStatement 'val (make-Const "Danny"))
,(make-AssignImmediateStatement (make-EnvPrefixReference 0 1 'another) (make-Reg 'val))))]) ,(make-AssignImmediateStatement (make-EnvPrefixReference 0 1) (make-Reg 'val))))])
(test (machine-env (run m)) (test (machine-env (run m))
(list (make-toplevel (list (make-undefined) "Danny"))))) (list (make-toplevel '(some-variable another) (list (make-undefined) "Danny")))))
(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(some-variable))) (let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(some-variable)))
,(make-AssignImmediateStatement 'val (make-Const "Danny")) ,(make-AssignImmediateStatement 'val (make-Const "Danny"))
,(make-PushEnvironment 5 #f) ,(make-PushEnvironment 5 #f)
,(make-AssignImmediateStatement (make-EnvPrefixReference 5 0 'some-variable) (make-Reg 'val))))]) ,(make-AssignImmediateStatement (make-EnvPrefixReference 5 0) (make-Reg 'val))))])
(test (machine-env (run m)) (test (machine-env (run m))
(list (make-undefined) (make-undefined) (make-undefined) (make-undefined) (make-undefined) (list (make-undefined) (make-undefined) (make-undefined) (make-undefined) (make-undefined)
(make-toplevel (list "Danny"))))) (make-toplevel '(some-variable) (list "Danny")))))
@ -304,7 +305,7 @@
;; check-toplevel-bound ;; check-toplevel-bound
;; This should produce an error. ;; This should produce an error.
(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(some-variable))) (let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(some-variable)))
,(make-PerformStatement (make-CheckToplevelBound! 0 0 'some-variable))))]) ,(make-PerformStatement (make-CheckToplevelBound! 0 0))))])
(with-handlers ((exn:fail? (lambda (exn) (with-handlers ((exn:fail? (lambda (exn)
(void)))) (void))))
@ -314,8 +315,8 @@
;; check-toplevel-bound shouldn't fail here. ;; check-toplevel-bound shouldn't fail here.
(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(some-variable))) (let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(some-variable)))
,(make-AssignImmediateStatement 'val (make-Const "Danny")) ,(make-AssignImmediateStatement 'val (make-Const "Danny"))
,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0 'some-variable) (make-Reg 'val)) ,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0) (make-Reg 'val))
,(make-PerformStatement (make-CheckToplevelBound! 0 0 'some-variable))))]) ,(make-PerformStatement (make-CheckToplevelBound! 0 0))))])
(void (run m))) (void (run m)))
@ -372,8 +373,7 @@
'val 'val
(make-MakeCompiledProcedure 'procedure-entry (make-MakeCompiledProcedure 'procedure-entry
0 0
(list (make-EnvLexicalReference 0 #f) (list 0 2)
(make-EnvLexicalReference 2 #f))
'procedure-entry)) 'procedure-entry))
,(make-GotoStatement (make-Label 'end)) ,(make-GotoStatement (make-Label 'end))
procedure-entry procedure-entry
@ -386,33 +386,33 @@
;; make-compiled-procedure: Capturing a toplevel. ;; make-compiled-procedure: Capturing a toplevel.
(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(x y z))) (let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(x y z)))
,(make-AssignImmediateStatement 'val (make-Const "x")) ,(make-AssignImmediateStatement 'val (make-Const "x"))
,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0 'x) (make-Reg 'val)) ,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0) (make-Reg 'val))
,(make-AssignImmediateStatement 'val (make-Const "y")) ,(make-AssignImmediateStatement 'val (make-Const "y"))
,(make-AssignImmediateStatement (make-EnvPrefixReference 0 1 'y) (make-Reg 'val)) ,(make-AssignImmediateStatement (make-EnvPrefixReference 0 1) (make-Reg 'val))
,(make-AssignImmediateStatement 'val (make-Const "z")) ,(make-AssignImmediateStatement 'val (make-Const "z"))
,(make-AssignImmediateStatement (make-EnvPrefixReference 0 2 'z) (make-Reg 'val)) ,(make-AssignImmediateStatement (make-EnvPrefixReference 0 2) (make-Reg 'val))
,(make-AssignPrimOpStatement ,(make-AssignPrimOpStatement
'val 'val
(make-MakeCompiledProcedure 'procedure-entry (make-MakeCompiledProcedure 'procedure-entry
0 0
(list (make-EnvWholePrefixReference 0)) (list 0)
'procedure-entry)) 'procedure-entry))
,(make-GotoStatement (make-Label 'end)) ,(make-GotoStatement (make-Label 'end))
procedure-entry procedure-entry
end end
))]) ))])
(test (machine-val (run m)) (test (machine-val (run m))
(make-closure 'procedure-entry 0 (list (make-toplevel (list "x" "y" "z"))) (make-closure 'procedure-entry 0 (list (make-toplevel '(x y z) (list "x" "y" "z")))
'procedure-entry))) 'procedure-entry)))
;; make-compiled-procedure: Capturing both a toplevel and some lexical values ;; make-compiled-procedure: Capturing both a toplevel and some lexical values
(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(x y z))) (let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(x y z)))
,(make-AssignImmediateStatement 'val (make-Const "x")) ,(make-AssignImmediateStatement 'val (make-Const "x"))
,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0 'x) (make-Reg 'val)) ,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0) (make-Reg 'val))
,(make-AssignImmediateStatement 'val (make-Const "y")) ,(make-AssignImmediateStatement 'val (make-Const "y"))
,(make-AssignImmediateStatement (make-EnvPrefixReference 0 1 'y) (make-Reg 'val)) ,(make-AssignImmediateStatement (make-EnvPrefixReference 0 1) (make-Reg 'val))
,(make-AssignImmediateStatement 'val (make-Const "z")) ,(make-AssignImmediateStatement 'val (make-Const "z"))
,(make-AssignImmediateStatement (make-EnvPrefixReference 0 2 'z) (make-Reg 'val)) ,(make-AssignImmediateStatement (make-EnvPrefixReference 0 2) (make-Reg 'val))
,(make-PushEnvironment 3 #f) ,(make-PushEnvironment 3 #f)
,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-Const 'larry)) ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-Const 'larry))
@ -422,9 +422,7 @@
'val 'val
(make-MakeCompiledProcedure 'procedure-entry (make-MakeCompiledProcedure 'procedure-entry
0 0
(list (make-EnvWholePrefixReference 3) (list 3 0 2)
(make-EnvLexicalReference 0 #f)
(make-EnvLexicalReference 2 #f))
'procedure-entry)) 'procedure-entry))
,(make-PopEnvironment 3 0) ,(make-PopEnvironment 3 0)
,(make-GotoStatement (make-Label 'end)) ,(make-GotoStatement (make-Label 'end))
@ -434,7 +432,7 @@
(test (machine-val (run m)) (test (machine-val (run m))
(make-closure 'procedure-entry (make-closure 'procedure-entry
0 0
(list (make-toplevel (list "x" "y" "z")) (list (make-toplevel '(x y z) (list "x" "y" "z"))
'larry 'larry
'moe) 'moe)
'procedure-entry))) 'procedure-entry)))
@ -442,7 +440,7 @@
;; Test toplevel lookup ;; Test toplevel lookup
(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+))) (let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
,(make-AssignImmediateStatement 'val (make-EnvPrefixReference 0 0 '+))))]) ,(make-AssignImmediateStatement 'val (make-EnvPrefixReference 0 0))))])
(test (machine-val (run m)) (test (machine-val (run m))
(lookup-primitive '+))) (lookup-primitive '+)))
@ -470,7 +468,7 @@
;; ApplyPrimitiveProcedure ;; ApplyPrimitiveProcedure
;; Adding two numbers ;; Adding two numbers
(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+))) (let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
,(make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0 '+)) ,(make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0))
,(make-PushEnvironment 2 #f) ,(make-PushEnvironment 2 #f)
,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-Const 126389)) ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-Const 126389))
,(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-Const 42)) ,(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-Const 42))
@ -480,7 +478,7 @@
(+ 126389 42)) (+ 126389 42))
(test (machine-env (run m)) (test (machine-env (run m))
(list 126389 42 (make-toplevel (list (lookup-primitive '+)))))) (list 126389 42 (make-toplevel '(+) (list (lookup-primitive '+))))))
;; GetControlStackLabel ;; GetControlStackLabel