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

repairing test cases that staled earlier

Browse Source
This commit is contained in:
Danny Yoo 2012-09-17 12:40:22 -06:00
parent 1a47b72eeb
commit 7a28a79a23
4 changed files with 164 additions and 166 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
js-assembler/package.rkt
View File

@ -41,6 +41,7 @@
(provide package (provide package
package-anonymous
package-standalone-xhtml package-standalone-xhtml
get-inert-code get-inert-code
get-standalone-code get-standalone-code
@ -101,14 +102,14 @@
;; (define (package-anonymous source-code (define (package-anonymous source-code
;; #:should-follow-children? should-follow? #:should-follow-children? should-follow?
;; #:output-port op) #:output-port op)
;; (fprintf op "(function() {\n") (fprintf op "(function() {\n")
;; (package source-code (package source-code
;; #:should-follow-children? should-follow? #:should-follow-children? should-follow?
;; #:output-port op) #:output-port op)
;; (fprintf op " return invoke; })\n")) (fprintf op " return invoke; })\n"))

272
tests/test-assemble.rkt
View File

@ -94,22 +94,22 @@
;; Assigning a number ;; Assigning a number
(test (E-single (make-AssignImmediateStatement 'val (make-Const 42))) (test (E-single (make-AssignImmediate 'val (make-Const 42)))
"42") "42")
;; Assigning a string ;; Assigning a string
(test (E-single (make-AssignImmediateStatement 'val (make-Const "Danny"))) (test (E-single (make-AssignImmediate 'val (make-Const "Danny")))
"Danny") "Danny")
;; Assigning a cons ;; Assigning a cons
(test (E-single (make-AssignImmediateStatement 'val (make-Const (cons 1 2)))) (test (E-single (make-AssignImmediate 'val (make-Const (cons 1 2))))
"(1 . 2)") "(1 . 2)")
;; Assigning a void ;; Assigning a void
(test (E-single (make-AssignImmediateStatement 'val (make-Const (void)))) (test (E-single (make-AssignImmediate 'val (make-Const (void))))
"#<void>") "#<void>")
;; Assigning to proc means val should still be uninitialized. ;; Assigning to proc means val should still be uninitialized.
(test (E-single (make-AssignImmediateStatement 'proc (make-Const "Danny"))) (test (E-single (make-AssignImmediate 'proc (make-Const "Danny")))
"#<undefined>") "#<undefined>")
;; But we should see the assignment if we inspect M.proc. ;; But we should see the assignment if we inspect M.proc.
(test (E-single (make-AssignImmediateStatement 'proc (make-Const "Danny")) (test (E-single (make-AssignImmediate 'proc (make-Const "Danny"))
"M.proc") "M.proc")
"Danny") "Danny")
@ -135,39 +135,39 @@
;; Assigning to the environment ;; Assigning to the environment
(test (E-many (list (make-PushEnvironment 2 #f) (test (E-many (list (make-PushEnvironment 2 #f)
(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-AssignImmediate (make-EnvLexicalReference 0 #f)
(make-Const 12345))) (make-Const 12345)))
"M.env[1]") "M.env[1]")
"12345") "12345")
(test (E-many (list (make-PushEnvironment 2 #f) (test (E-many (list (make-PushEnvironment 2 #f)
(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-AssignImmediate (make-EnvLexicalReference 0 #f)
(make-Const 12345))) (make-Const 12345)))
"M.env[0]") "M.env[0]")
"#<undefined>") "#<undefined>")
(test (E-many (list (make-PushEnvironment 2 #f) (test (E-many (list (make-PushEnvironment 2 #f)
(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-AssignImmediate (make-EnvLexicalReference 1 #f)
(make-Const 12345))) (make-Const 12345)))
"M.env[0]") "M.env[0]")
"12345") "12345")
;; Toplevel Environment loading ;; Toplevel Environment loading
(test (E-single (make-PerformStatement (make-ExtendEnvironment/Prefix! '(pi))) (test (E-single (make-Perform (make-ExtendEnvironment/Prefix! '(pi)))
"plt.runtime.toWrittenString(M.env[0]).slice(0, 5)") "plt.runtime.toWrittenString(M.env[0]).slice(0, 5)")
"3.141") "3.141")
;; Simple application ;; Simple application
;; (test (E-many (list (make-PerformStatement (make-ExtendEnvironment/Prefix! '(+))) ;; (test (E-many (list (make-Perform (make-ExtendEnvironment/Prefix! '(+)))
;; (make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0)) ;; (make-AssignImmediate 'proc (make-EnvPrefixReference 0 0))
;; (make-PushEnvironment 2 #f) ;; (make-PushEnvironment 2 #f)
;; (make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) ;; (make-AssignImmediate (make-EnvLexicalReference 0 #f)
;; (make-Const 3)) ;; (make-Const 3))
;; (make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) ;; (make-AssignImmediate (make-EnvLexicalReference 1 #f)
;; (make-Const 4)) ;; (make-Const 4))
;; (make-AssignImmediateStatement 'argcount (make-Const 2)) ;; (make-AssignImmediate 'argcount (make-Const 2))
;; (make-AssignPrimOpStatement 'val (make-ApplyPrimitiveProcedure)) ;; (make-AssignPrimOp 'val (make-ApplyPrimitiveProcedure))
;; 'done)) ;; 'done))
;; "7") ;; "7")
@ -175,50 +175,50 @@
;; A do-nothing closure ;; A do-nothing closure
(test (E-many (list (make-GotoStatement (make-Label 'afterLambda)) (test (E-many (list (make-Goto (make-Label 'afterLambda))
'closureStart 'closureStart
(make-GotoStatement (make-Label 'afterLambda)) (make-Goto (make-Label 'afterLambda))
'afterLambda 'afterLambda
(make-AssignPrimOpStatement 'val (make-MakeCompiledProcedure 'closureStart 0 '() 'closureStart))) (make-AssignPrimOp 'val (make-MakeCompiledProcedure 'closureStart 0 '() 'closureStart)))
"M.val.displayName") "M.val.displayName")
"closureStart") "closureStart")
;; A do-nothing closure with a few values ;; A do-nothing closure with a few values
(test (E-many (list (make-GotoStatement (make-Label 'afterLambda)) (test (E-many (list (make-Goto (make-Label 'afterLambda))
'closureStart 'closureStart
(make-GotoStatement (make-Label 'afterLambda)) (make-Goto (make-Label 'afterLambda))
'afterLambda 'afterLambda
(make-PushEnvironment 2 #f) (make-PushEnvironment 2 #f)
(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-AssignImmediate (make-EnvLexicalReference 0 #f)
(make-Const "hello")) (make-Const "hello"))
(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-AssignImmediate (make-EnvLexicalReference 1 #f)
(make-Const "world")) (make-Const "world"))
(make-AssignPrimOpStatement 'val (make-MakeCompiledProcedure 'closureStart 0 (make-AssignPrimOp 'val (make-MakeCompiledProcedure 'closureStart 0
(list 0 1) (list 0 1)
'closureStart))) 'closureStart)))
"M.val.closedVals[1] + ',' + M.val.closedVals[0]") "M.val.closedVals[1] + ',' + M.val.closedVals[0]")
"hello,world") "hello,world")
;; Let's try to install the closure values. ;; Let's try to install the closure values.
(test (E-many (list (make-GotoStatement (make-Label 'afterLambdaBody)) (test (E-many (list (make-Goto (make-Label 'afterLambdaBody))
'closureStart 'closureStart
(make-PerformStatement (make-InstallClosureValues!)) (make-Perform (make-InstallClosureValues!))
(make-GotoStatement (make-Label 'theEnd)) (make-Goto (make-Label 'theEnd))
'afterLambdaBody 'afterLambdaBody
(make-PushEnvironment 2 #f) (make-PushEnvironment 2 #f)
(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-AssignImmediate (make-EnvLexicalReference 0 #f)
(make-Const "hello")) (make-Const "hello"))
(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-AssignImmediate (make-EnvLexicalReference 1 #f)
(make-Const "world")) (make-Const "world"))
(make-AssignPrimOpStatement 'proc (make-MakeCompiledProcedure 'closureStart 0 (make-AssignPrimOp 'proc (make-MakeCompiledProcedure 'closureStart 0
(list 0 1) (list 0 1)
'closureStart)) 'closureStart))
(make-PopEnvironment (make-Const 2) (make-PopEnvironment (make-Const 2)
(make-Const 0)) (make-Const 0))
(make-GotoStatement (make-Label 'closureStart)) (make-Goto (make-Label 'closureStart))
'theEnd) 'theEnd)
"plt.runtime.toWrittenString(M.env.length) + ',' + M.env[1] + ',' + M.env[0]") "plt.runtime.toWrittenString(M.env.length) + ',' + M.env[1] + ',' + M.env[0]")
"2,hello,world") "2,hello,world")
@ -226,69 +226,69 @@
;; get-compiled-procedure-entry ;; get-compiled-procedure-entry
(test (E-many (list (make-GotoStatement (make-Label 'afterLambdaBody)) (test (E-many (list (make-Goto (make-Label 'afterLambdaBody))
'closureStart 'closureStart
(make-PerformStatement (make-InstallClosureValues!)) (make-Perform (make-InstallClosureValues!))
(make-GotoStatement (make-Label 'theEnd)) (make-Goto (make-Label 'theEnd))
'afterLambdaBody 'afterLambdaBody
(make-PushEnvironment 2 #f) (make-PushEnvironment 2 #f)
(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-AssignImmediate (make-EnvLexicalReference 0 #f)
(make-Const "hello")) (make-Const "hello"))
(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-AssignImmediate (make-EnvLexicalReference 1 #f)
(make-Const "world")) (make-Const "world"))
(make-AssignPrimOpStatement 'proc (make-MakeCompiledProcedure 'closureStart 0 (make-AssignPrimOp 'proc (make-MakeCompiledProcedure 'closureStart 0
(list 0 1) (list 0 1)
'closureStart)) 'closureStart))
(make-PopEnvironment (make-Const 2) (make-Const 0)) (make-PopEnvironment (make-Const 2) (make-Const 0))
(make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry)) (make-AssignPrimOp 'val (make-GetCompiledProcedureEntry))
'theEnd) 'theEnd)
"typeof(M.val) + ',' + (M.val === M.proc.label)") "typeof(M.val) + ',' + (M.val === M.proc.label)")
"function,true") "function,true")
;; check-closure-arity. This should succeed. ;; check-closure-arity. This should succeed.
(void (E-many (list (make-GotoStatement (make-Label 'afterLambdaBody)) (void (E-many (list (make-Goto (make-Label 'afterLambdaBody))
'closureStart 'closureStart
(make-PerformStatement (make-InstallClosureValues!)) (make-Perform (make-InstallClosureValues!))
(make-GotoStatement (make-Label 'theEnd)) (make-Goto (make-Label 'theEnd))
'afterLambdaBody 'afterLambdaBody
(make-PushEnvironment 2 #f) (make-PushEnvironment 2 #f)
(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-AssignImmediate (make-EnvLexicalReference 0 #f)
(make-Const "hello")) (make-Const "hello"))
(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-AssignImmediate (make-EnvLexicalReference 1 #f)
(make-Const "world")) (make-Const "world"))
(make-AssignPrimOpStatement 'proc (make-MakeCompiledProcedure 'closureStart 5 (make-AssignPrimOp 'proc (make-MakeCompiledProcedure 'closureStart 5
(list 0 1) (list 0 1)
'closureStart)) 'closureStart))
(make-PopEnvironment (make-Const 2) (make-Const 0)) (make-PopEnvironment (make-Const 2) (make-Const 0))
(make-PerformStatement (make-CheckClosureAndArity! (make-Const 5))) (make-Perform (make-CheckClosureAndArity! (make-Const 5)))
'theEnd))) 'theEnd)))
;; this should fail, since the check is for 1, but the closure expects 5. ;; this should fail, since the check is for 1, but the closure expects 5.
(let/ec return (let/ec return
(with-handlers ([void (with-handlers ([void
(lambda (exn) (return))]) (lambda (exn) (return))])
(E-many (list (make-GotoStatement (make-Label 'afterLambdaBody)) (E-many (list (make-Goto (make-Label 'afterLambdaBody))
'closureStart 'closureStart
(make-PerformStatement (make-InstallClosureValues!)) (make-Perform (make-InstallClosureValues!))
(make-GotoStatement (make-Label 'theEnd)) (make-Goto (make-Label 'theEnd))
'afterLambdaBody 'afterLambdaBody
(make-PushEnvironment 2 #f) (make-PushEnvironment 2 #f)
(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-AssignImmediate (make-EnvLexicalReference 0 #f)
(make-Const "hello")) (make-Const "hello"))
(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-AssignImmediate (make-EnvLexicalReference 1 #f)
(make-Const "world")) (make-Const "world"))
(make-AssignPrimOpStatement 'proc (make-MakeCompiledProcedure 'closureStart 5 (make-AssignPrimOp 'proc (make-MakeCompiledProcedure 'closureStart 5
(list 0 1) (list 0 1)
'closureStart)) 'closureStart))
(make-PopEnvironment (make-Const 2) (make-Const 0)) (make-PopEnvironment (make-Const 2) (make-Const 0))
(make-PerformStatement (make-CheckClosureAndArity! (make-Const 1))) (make-Perform (make-CheckClosureAndArity! (make-Const 1)))
'theEnd))) 'theEnd)))
(error 'expected-failure)) (error 'expected-failure))
@ -296,74 +296,74 @@
(test (E-many `(,(make-AssignImmediateStatement 'val (make-Const 42)) (test (E-many `(,(make-AssignImmediate 'val (make-Const 42))
,(make-TestAndJumpStatement (make-TestFalse (make-Reg 'val)) 'onFalse) ,(make-TestAndJump (make-TestFalse (make-Reg 'val)) 'onFalse)
,(make-AssignImmediateStatement 'val (make-Const 'ok)) ,(make-AssignImmediate 'val (make-Const 'ok))
,(make-GotoStatement (make-Label 'end)) ,(make-Goto (make-Label 'end))
onFalse onFalse
,(make-AssignImmediateStatement 'val (make-Const 'not-ok)) ,(make-AssignImmediate 'val (make-Const 'not-ok))
end)) end))
"ok") "ok")
;; TestAndBranch: try the false branch ;; TestAndBranch: try the false branch
(test (E-many `(,(make-AssignImmediateStatement 'val (make-Const #f)) (test (E-many `(,(make-AssignImmediate 'val (make-Const #f))
,(make-TestAndJumpStatement (make-TestFalse (make-Reg 'val)) 'onFalse) ,(make-TestAndJump (make-TestFalse (make-Reg 'val)) 'onFalse)
,(make-AssignImmediateStatement 'val (make-Const 'not-ok)) ,(make-AssignImmediate 'val (make-Const 'not-ok))
,(make-GotoStatement (make-Label 'end)) ,(make-Goto (make-Label 'end))
onFalse onFalse
,(make-AssignImmediateStatement 'val (make-Const 'ok)) ,(make-AssignImmediate 'val (make-Const 'ok))
end)) end))
"ok") "ok")
;; ;; Test for primitive procedure ;; ;; Test for primitive procedure
;; (test (E-many `(,(make-AssignImmediateStatement 'val (make-Const '+)) ;; (test (E-many `(,(make-AssignImmediate 'val (make-Const '+))
;; ,(make-TestAndJumpStatement (make-TestPrimitiveProcedure (make-Reg 'val)) 'onTrue) ;; ,(make-TestAndJump (make-TestPrimitiveProcedure (make-Reg 'val)) 'onTrue)
;; ,(make-AssignImmediateStatement 'val (make-Const 'ok)) ;; ,(make-AssignImmediate 'val (make-Const 'ok))
;; ,(make-GotoStatement (make-Label 'end)) ;; ,(make-Goto (make-Label 'end))
;; onTrue ;; onTrue
;; ,(make-AssignImmediateStatement 'val (make-Const 'not-ok)) ;; ,(make-AssignImmediate 'val (make-Const 'not-ok))
;; end)) ;; end))
;; "ok") ;; "ok")
;; ;; Give a primitive procedure in val ;; ;; Give a primitive procedure in val
;; (test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+))) ;; (test (E-many `(,(make-Perform (make-ExtendEnvironment/Prefix! '(+)))
;; ,(make-AssignImmediateStatement 'val (make-EnvPrefixReference 0 0)) ;; ,(make-AssignImmediate 'val (make-EnvPrefixReference 0 0))
;; ,(make-TestAndJumpStatement (make-TestPrimitiveProcedure (make-Reg 'val)) 'onTrue) ;; ,(make-TestAndJump (make-TestPrimitiveProcedure (make-Reg 'val)) 'onTrue)
;; ,(make-AssignImmediateStatement 'val (make-Const 'not-ok)) ;; ,(make-AssignImmediate 'val (make-Const 'not-ok))
;; ,(make-GotoStatement (make-Label 'end)) ;; ,(make-Goto (make-Label 'end))
;; onTrue ;; onTrue
;; ,(make-AssignImmediateStatement 'val (make-Const 'ok)) ;; ,(make-AssignImmediate 'val (make-Const 'ok))
;; end)) ;; end))
;; "ok") ;; "ok")
;; ;; Give a primitive procedure in proc, but test val ;; ;; Give a primitive procedure in proc, but test val
;; (test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+))) ;; (test (E-many `(,(make-Perform (make-ExtendEnvironment/Prefix! '(+)))
;; ,(make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0)) ;; ,(make-AssignImmediate 'proc (make-EnvPrefixReference 0 0))
;; ,(make-TestAndJumpStatement (make-TestPrimitiveProcedure (make-Reg 'val)) 'onTrue) ;; ,(make-TestAndJump (make-TestPrimitiveProcedure (make-Reg 'val)) 'onTrue)
;; ,(make-AssignImmediateStatement 'val (make-Const 'not-a-procedure)) ;; ,(make-AssignImmediate 'val (make-Const 'not-a-procedure))
;; ,(make-GotoStatement (make-Label 'end)) ;; ,(make-Goto (make-Label 'end))
;; onTrue ;; onTrue
;; ,(make-AssignImmediateStatement 'val (make-Const 'a-procedure)) ;; ,(make-AssignImmediate 'val (make-Const 'a-procedure))
;; end)) ;; end))
;; "not-a-procedure") ;; "not-a-procedure")
;; ;; Give a primitive procedure in proc and test proc ;; ;; Give a primitive procedure in proc and test proc
;; (test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+))) ;; (test (E-many `(,(make-Perform (make-ExtendEnvironment/Prefix! '(+)))
;; ,(make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0)) ;; ,(make-AssignImmediate 'proc (make-EnvPrefixReference 0 0))
;; ,(make-TestAndJumpStatement (make-TestPrimitiveProcedure (make-Reg 'proc)) 'onTrue) ;; ,(make-TestAndJump (make-TestPrimitiveProcedure (make-Reg 'proc)) 'onTrue)
;; ,(make-AssignImmediateStatement 'val (make-Const 'not-a-procedure)) ;; ,(make-AssignImmediate 'val (make-Const 'not-a-procedure))
;; ,(make-GotoStatement (make-Label 'end)) ;; ,(make-Goto (make-Label 'end))
;; onTrue ;; onTrue
;; ,(make-AssignImmediateStatement 'val (make-Const 'a-procedure)) ;; ,(make-AssignImmediate 'val (make-Const 'a-procedure))
;; end)) ;; end))
;; "a-procedure") ;; "a-procedure")
;; Set-toplevel ;; Set-toplevel
(test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(advisor))) (test (E-many `(,(make-Perform (make-ExtendEnvironment/Prefix! '(advisor)))
,(make-AssignImmediateStatement 'val (make-Const "Kathi")) ,(make-AssignImmediate 'val (make-Const "Kathi"))
,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0) (make-Reg 'val))) ,(make-AssignImmediate (make-EnvPrefixReference 0 0) (make-Reg 'val)))
"M.env[0][0]") "M.env[0][0]")
"Kathi") "Kathi")
@ -372,38 +372,38 @@
(let/ec return (let/ec return
(let ([dont-care (let ([dont-care
(with-handlers ([void (lambda (exn) (return))]) (with-handlers ([void (lambda (exn) (return))])
(E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(some-variable))) (E-many `(,(make-Perform (make-ExtendEnvironment/Prefix! '(some-variable)))
,(make-PerformStatement (make-CheckToplevelBound! 0 0)))))]) ,(make-Perform (make-CheckToplevelBound! 0 0)))))])
(raise "I expected an error"))) (raise "I expected an error")))
;; check-toplevel-bound shouldn't fail here. ;; check-toplevel-bound shouldn't fail here.
(test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(another-advisor))) (test (E-many `(,(make-Perform (make-ExtendEnvironment/Prefix! '(another-advisor)))
,(make-AssignImmediateStatement 'val (make-Const "Shriram")) ,(make-AssignImmediate 'val (make-Const "Shriram"))
,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0) (make-Reg 'val)) ,(make-AssignImmediate (make-EnvPrefixReference 0 0) (make-Reg 'val))
,(make-PerformStatement (make-CheckToplevelBound! 0 0))) ,(make-Perform (make-CheckToplevelBound! 0 0)))
"M.env[0][0]") "M.env[0][0]")
"Shriram") "Shriram")
(test (E-many `(,(make-PushEnvironment 1 #f) (test (E-many `(,(make-PushEnvironment 1 #f)
,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) ,(make-AssignImmediate (make-EnvLexicalReference 0 #f)
(make-Const '(1 2 3))) (make-Const '(1 2 3)))
,(make-AssignImmediateStatement 'argcount (make-Const 1)) ,(make-AssignImmediate 'argcount (make-Const 1))
,(make-PerformStatement (make-SpliceListIntoStack! (make-Const 0)))) ,(make-Perform (make-SpliceListIntoStack! (make-Const 0))))
"M.argcount + ',' + M.env[0] + ',' + M.env[1] + ',' + M.env[2]") "M.argcount + ',' + M.env[0] + ',' + M.env[1] + ',' + M.env[2]")
"3,3,2,1") "3,3,2,1")
(test (E-many `(,(make-PushEnvironment 3 #f) (test (E-many `(,(make-PushEnvironment 3 #f)
,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) ,(make-AssignImmediate (make-EnvLexicalReference 0 #f)
(make-Const "hello")) (make-Const "hello"))
,(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) ,(make-AssignImmediate (make-EnvLexicalReference 1 #f)
(make-Const "world")) (make-Const "world"))
,(make-AssignImmediateStatement (make-EnvLexicalReference 2 #f) ,(make-AssignImmediate (make-EnvLexicalReference 2 #f)
(make-Const '(1 2 3))) (make-Const '(1 2 3)))
,(make-AssignImmediateStatement 'argcount (make-Const 3)) ,(make-AssignImmediate 'argcount (make-Const 3))
,(make-PerformStatement (make-SpliceListIntoStack! (make-Const 2)))) ,(make-Perform (make-SpliceListIntoStack! (make-Const 2))))
"M.argcount + ',' + M.env[0] + ',' + M.env[1] + ',' + M.env[2] + ',' + M.env[3] + ',' + M.env[4]") "M.argcount + ',' + M.env[0] + ',' + M.env[1] + ',' + M.env[2] + ',' + M.env[3] + ',' + M.env[4]")
"5,3,2,1,world,hello") "5,3,2,1,world,hello")
@ -415,10 +415,10 @@
;; testing rest splicing ;; testing rest splicing
(test (E-many `(,(make-PushEnvironment 1 #f) (test (E-many `(,(make-PushEnvironment 1 #f)
,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) ,(make-AssignImmediate (make-EnvLexicalReference 0 #f)
(make-Const "hello")) (make-Const "hello"))
,(make-AssignImmediateStatement 'argcount (make-Const 1)) ,(make-AssignImmediate 'argcount (make-Const 1))
,(make-PerformStatement (make-UnspliceRestFromStack! (make-Const 0) ,(make-Perform (make-UnspliceRestFromStack! (make-Const 0)
(make-Const 1)))) (make-Const 1))))
"M.argcount + ',' + plt.runtime.isList(M.env[0])") "M.argcount + ',' + plt.runtime.isList(M.env[0])")
"1,true") "1,true")
@ -426,18 +426,18 @@
(test (E-many (test (E-many
`(,(make-PushEnvironment 5 #f) `(,(make-PushEnvironment 5 #f)
,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) ,(make-AssignImmediate (make-EnvLexicalReference 0 #f)
(make-Const "hello")) (make-Const "hello"))
,(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) ,(make-AssignImmediate (make-EnvLexicalReference 1 #f)
(make-Const "world")) (make-Const "world"))
,(make-AssignImmediateStatement (make-EnvLexicalReference 2 #f) ,(make-AssignImmediate (make-EnvLexicalReference 2 #f)
(make-Const 'x)) (make-Const 'x))
,(make-AssignImmediateStatement (make-EnvLexicalReference 3 #f) ,(make-AssignImmediate (make-EnvLexicalReference 3 #f)
(make-Const 'y)) (make-Const 'y))
,(make-AssignImmediateStatement (make-EnvLexicalReference 4 #f) ,(make-AssignImmediate (make-EnvLexicalReference 4 #f)
(make-Const 'z)) (make-Const 'z))
,(make-AssignImmediateStatement 'argcount (make-Const 5)) ,(make-AssignImmediate 'argcount (make-Const 5))
,(make-PerformStatement (make-UnspliceRestFromStack! (make-Const 2) (make-Const 3)))) ,(make-Perform (make-UnspliceRestFromStack! (make-Const 2) (make-Const 3))))
"M.argcount + ',' + M.env.length + ',' + plt.runtime.isList(M.env[0]) + ',' + M.env[2] + ',' + M.env[1]") "M.argcount + ',' + M.env.length + ',' + plt.runtime.isList(M.env[0]) + ',' + M.env[2] + ',' + M.env[1]")
"3,3,true,hello,world") "3,3,true,hello,world")
@ -446,16 +446,16 @@
;; Check closure mismatch. Make sure we're getting the right values from the test. ;; Check closure mismatch. Make sure we're getting the right values from the test.
(test (E-many `(procedure-entry (test (E-many `(procedure-entry
;; doesn't matter about the procedure entry... ;; doesn't matter about the procedure entry...
,(make-AssignPrimOpStatement ,(make-AssignPrimOp
'proc 'proc
(make-MakeCompiledProcedure 'procedure-entry 0 (list) 'procedure-entry)) (make-MakeCompiledProcedure 'procedure-entry 0 (list) 'procedure-entry))
,(make-TestAndJumpStatement ,(make-TestAndJump
(make-TestClosureArityMismatch (make-Reg 'proc) (make-Const 0)) (make-TestClosureArityMismatch (make-Reg 'proc) (make-Const 0))
'bad) 'bad)
,(make-AssignImmediateStatement 'val (make-Const 'ok)) ,(make-AssignImmediate 'val (make-Const 'ok))
,(make-GotoStatement (make-Label 'end)) ,(make-Goto (make-Label 'end))
bad bad
,(make-AssignImmediateStatement 'val (make-Const 'bad)) ,(make-AssignImmediate 'val (make-Const 'bad))
end) end)
"M.val") "M.val")
"ok") "ok")
@ -463,48 +463,48 @@
(test (E-many `(procedure-entry (test (E-many `(procedure-entry
;; doesn't matter about the procedure entry... ;; doesn't matter about the procedure entry...
,(make-AssignPrimOpStatement ,(make-AssignPrimOp
'proc 'proc
(make-MakeCompiledProcedure 'procedure-entry 0 (list) 'procedure-entry)) (make-MakeCompiledProcedure 'procedure-entry 0 (list) 'procedure-entry))
,(make-TestAndJumpStatement ,(make-TestAndJump
(make-TestClosureArityMismatch (make-Reg 'proc) (make-Const 1)) (make-TestClosureArityMismatch (make-Reg 'proc) (make-Const 1))
'ok) 'ok)
,(make-AssignImmediateStatement 'val (make-Const 'bad)) ,(make-AssignImmediate 'val (make-Const 'bad))
,(make-GotoStatement (make-Label 'end)) ,(make-Goto (make-Label 'end))
ok ok
,(make-AssignImmediateStatement 'val (make-Const 'ok)) ,(make-AssignImmediate 'val (make-Const 'ok))
end) end)
"M.val") "M.val")
"ok") "ok")
(test (E-many `(procedure-entry (test (E-many `(procedure-entry
;; doesn't matter about the procedure entry... ;; doesn't matter about the procedure entry...
,(make-AssignPrimOpStatement ,(make-AssignPrimOp
'proc 'proc
(make-MakeCompiledProcedure 'procedure-entry (make-ArityAtLeast 2) (list) 'procedure-entry)) (make-MakeCompiledProcedure 'procedure-entry (make-ArityAtLeast 2) (list) 'procedure-entry))
,(make-TestAndJumpStatement ,(make-TestAndJump
(make-TestClosureArityMismatch (make-Reg 'proc) (make-Const 0)) (make-TestClosureArityMismatch (make-Reg 'proc) (make-Const 0))
'ok) 'ok)
,(make-AssignImmediateStatement 'val (make-Const 'bad)) ,(make-AssignImmediate 'val (make-Const 'bad))
,(make-GotoStatement (make-Label 'end)) ,(make-Goto (make-Label 'end))
ok ok
,(make-AssignImmediateStatement 'val (make-Const 'ok)) ,(make-AssignImmediate 'val (make-Const 'ok))
end) end)
"M.val") "M.val")
"ok") "ok")
(test (E-many `(procedure-entry (test (E-many `(procedure-entry
;; doesn't matter about the procedure entry... ;; doesn't matter about the procedure entry...
,(make-AssignPrimOpStatement ,(make-AssignPrimOp
'proc 'proc
(make-MakeCompiledProcedure 'procedure-entry (make-ArityAtLeast 2) (list) 'procedure-entry)) (make-MakeCompiledProcedure 'procedure-entry (make-ArityAtLeast 2) (list) 'procedure-entry))
,(make-TestAndJumpStatement ,(make-TestAndJump
(make-TestClosureArityMismatch (make-Reg 'proc) (make-Const 2)) (make-TestClosureArityMismatch (make-Reg 'proc) (make-Const 2))
'bad) 'bad)
,(make-AssignImmediateStatement 'val (make-Const 'ok)) ,(make-AssignImmediate 'val (make-Const 'ok))
,(make-GotoStatement (make-Label 'end)) ,(make-Goto (make-Label 'end))
bad bad
,(make-AssignImmediateStatement 'val (make-Const 'bad)) ,(make-AssignImmediate 'val (make-Const 'bad))
end) end)
"M.val") "M.val")
"ok") "ok")
@ -517,10 +517,10 @@
,(make-PushImmediateOntoEnvironment (make-Const 4) #f) ,(make-PushImmediateOntoEnvironment (make-Const 4) #f)
procedure-entry procedure-entry
;; doesn't matter about the procedure entry... ;; doesn't matter about the procedure entry...
,(make-AssignPrimOpStatement ,(make-AssignPrimOp
'proc 'proc
(make-MakeCompiledProcedure 'procedure-entry (make-ArityAtLeast 2) (list 0 1) 'procedure-entry)) (make-MakeCompiledProcedure 'procedure-entry (make-ArityAtLeast 2) (list 0 1) 'procedure-entry))
,(make-AssignImmediateStatement 'val (make-CompiledProcedureClosureReference (make-Reg 'proc) 0))) ,(make-AssignImmediate 'val (make-CompiledProcedureClosureReference (make-Reg 'proc) 0)))
"M.val") "M.val")
"4") "4")
@ -528,10 +528,10 @@
,(make-PushImmediateOntoEnvironment (make-Const 4) #f) ,(make-PushImmediateOntoEnvironment (make-Const 4) #f)
procedure-entry procedure-entry
;; doesn't matter about the procedure entry... ;; doesn't matter about the procedure entry...
,(make-AssignPrimOpStatement ,(make-AssignPrimOp
'proc 'proc
(make-MakeCompiledProcedure 'procedure-entry (make-ArityAtLeast 2) (list 0 1) 'procedure-entry)) (make-MakeCompiledProcedure 'procedure-entry (make-ArityAtLeast 2) (list 0 1) 'procedure-entry))
,(make-AssignImmediateStatement 'val (make-CompiledProcedureClosureReference (make-Reg 'proc) 1))) ,(make-AssignImmediate 'val (make-CompiledProcedureClosureReference (make-Reg 'proc) 1)))
"M.val") "M.val")
"3") "3")

35
tests/test-parse-bytecode.rkt
View File

@ -227,19 +227,20 @@
;; the letrec gets translated into a closure call ;; the letrec gets translated into a closure call
(begin (check-true (match (run-my-parse '(letrec ([omega (lambda () (omega))])
(reset-lam-label-counter!/unit-testing) (omega)))
(check-equal? (run-my-parse '(letrec ([omega (lambda () (omega))]) [(struct Top ((struct Prefix (list))
(omega))) (struct App ((struct Lam ('omega 0
(make-Top (make-Prefix '()) #f
(make-App (make-Lam 'omega 0 #f (make-App (make-EmptyClosureReference 'omega 0 #f 'lamEntry1) '()) (struct App ((struct EmptyClosureReference ('omega 0 #f _))
'() 'lamEntry1) (list)))
'())))) (list) _))
(list)))))
#t]))
;; FIXME: make this a real test. ;; FIXME: make this a real test.
(begin (begin
(reset-lam-label-counter!/unit-testing)
(void (run-my-parse #'(letrec ([e (lambda (y) (void (run-my-parse #'(letrec ([e (lambda (y)
(if (= y 0) (if (= y 0)
#t #t
@ -292,14 +293,12 @@
(make-App (make-PrimitiveKernelValue 'current-continuation-marks) '())))) (make-App (make-PrimitiveKernelValue 'current-continuation-marks) '()))))
(begin (reset-lam-label-counter!/unit-testing) (begin (check-true (match (run-my-parse #'(case-lambda))
(check-true (match (run-my-parse #'(case-lambda))
[(struct Top ((struct Prefix (list)) [(struct Top ((struct Prefix (list))
(struct CaseLam (_ (list) 'lamEntry1)))) (struct CaseLam (_ (list) _))))
#t]))) #t])))
(begin (reset-lam-label-counter!/unit-testing) (begin (check-true (match (run-my-parse #'(case-lambda [(x) x]
(check-true (match (run-my-parse #'(case-lambda [(x) x]
[(x y) x] [(x y) x]
[(x y) y])) [(x y) y]))
[(struct Top ((struct Prefix (list)) [(struct Top ((struct Prefix (list))
@ -309,20 +308,20 @@
#f #f
(struct LocalRef ('0 '#f)) (struct LocalRef ('0 '#f))
'() '()
'lamEntry2)) _))
(struct Lam (_ (struct Lam (_
2 2
#f #f
(struct LocalRef ('0 '#f)) (struct LocalRef ('0 '#f))
'() '()
'lamEntry3)) _))
(struct Lam (_ (struct Lam (_
2 2
#f #f
(struct LocalRef ('1 '#f)) (struct LocalRef ('1 '#f))
'() '()
'lamEntry4))) _)))
'lamEntry1)))) _))))
#t]))) #t])))

6
tests/test-parse.rkt
View File

@ -1,7 +1,6 @@
#lang racket/base #lang racket/base
(require "../parser/baby-parser.rkt" (require "../parser/baby-parser.rkt"
"../parser/lam-entry-gensym.rkt"
"../compiler/lexical-structs.rkt" "../compiler/lexical-structs.rkt"
"../compiler/expression-structs.rkt" "../compiler/expression-structs.rkt"
(for-syntax racket/base)) (for-syntax racket/base))
@ -16,7 +15,6 @@
(syntax/loc #'stx (syntax/loc #'stx
(begin (begin
(printf "Running ~s ...\n" (syntax->datum #'expr)) (printf "Running ~s ...\n" (syntax->datum #'expr))
(reset-lam-label-counter!/unit-testing)
(let ([expected expt] (let ([expected expt]
[actual [actual
(with-handlers ([void (with-handlers ([void
@ -25,8 +23,8 @@
#'stx))]) #'stx))])
expr)]) expr)])
(unless (equal? actual expected) (unless (equal? actual expected)
(raise-syntax-error #f (format "Expected ~s, got ~s" expected actual) (printf (format "Expected ~s, got ~s, at ~s" expected actual
#'stx)) (syntax-line #'stx))))
(printf "ok.\n\n")))))])) (printf "ok.\n\n")))))]))