repairing test cases that staled earlier
This commit is contained in:
Danny Yoo
parent
1a47b72eeb
commit
7a28a79a23
|
|
@ -41,6 +41,7 @@
|
|||
|
||||
|
||||
(provide package
|
||||
package-anonymous
|
||||
package-standalone-xhtml
|
||||
get-inert-code
|
||||
get-standalone-code
|
||||
|
|
@ -101,14 +102,14 @@
|
|||
|
||||
|
||||
|
||||
;; (define (package-anonymous source-code
|
||||
;; #:should-follow-children? should-follow?
|
||||
;; #:output-port op)
|
||||
;; (fprintf op "(function() {\n")
|
||||
;; (package source-code
|
||||
;; #:should-follow-children? should-follow?
|
||||
;; #:output-port op)
|
||||
;; (fprintf op " return invoke; })\n"))
|
||||
(define (package-anonymous source-code
|
||||
#:should-follow-children? should-follow?
|
||||
#:output-port op)
|
||||
(fprintf op "(function() {\n")
|
||||
(package source-code
|
||||
#:should-follow-children? should-follow?
|
||||
#:output-port op)
|
||||
(fprintf op " return invoke; })\n"))
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -94,22 +94,22 @@
|
|||
|
||||
|
||||
;; Assigning a number
|
||||
(test (E-single (make-AssignImmediateStatement 'val (make-Const 42)))
|
||||
(test (E-single (make-AssignImmediate 'val (make-Const 42)))
|
||||
"42")
|
||||
;; Assigning a string
|
||||
(test (E-single (make-AssignImmediateStatement 'val (make-Const "Danny")))
|
||||
(test (E-single (make-AssignImmediate 'val (make-Const "Danny")))
|
||||
"Danny")
|
||||
;; 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)")
|
||||
;; Assigning a void
|
||||
(test (E-single (make-AssignImmediateStatement 'val (make-Const (void))))
|
||||
(test (E-single (make-AssignImmediate 'val (make-Const (void))))
|
||||
"#<void>")
|
||||
;; 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>")
|
||||
;; 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")
|
||||
"Danny")
|
||||
|
||||
|
|
@ -135,39 +135,39 @@
|
|||
|
||||
;; Assigning to the environment
|
||||
(test (E-many (list (make-PushEnvironment 2 #f)
|
||||
(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
|
||||
(make-AssignImmediate (make-EnvLexicalReference 0 #f)
|
||||
(make-Const 12345)))
|
||||
"M.env[1]")
|
||||
"12345")
|
||||
(test (E-many (list (make-PushEnvironment 2 #f)
|
||||
(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
|
||||
(make-AssignImmediate (make-EnvLexicalReference 0 #f)
|
||||
(make-Const 12345)))
|
||||
"M.env[0]")
|
||||
"#<undefined>")
|
||||
(test (E-many (list (make-PushEnvironment 2 #f)
|
||||
(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f)
|
||||
(make-AssignImmediate (make-EnvLexicalReference 1 #f)
|
||||
(make-Const 12345)))
|
||||
"M.env[0]")
|
||||
"12345")
|
||||
|
||||
|
||||
;; 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)")
|
||||
"3.141")
|
||||
|
||||
|
||||
|
||||
;; Simple application
|
||||
;; (test (E-many (list (make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
|
||||
;; (make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0))
|
||||
;; (test (E-many (list (make-Perform (make-ExtendEnvironment/Prefix! '(+)))
|
||||
;; (make-AssignImmediate 'proc (make-EnvPrefixReference 0 0))
|
||||
;; (make-PushEnvironment 2 #f)
|
||||
;; (make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
|
||||
;; (make-AssignImmediate (make-EnvLexicalReference 0 #f)
|
||||
;; (make-Const 3))
|
||||
;; (make-AssignImmediateStatement (make-EnvLexicalReference 1 #f)
|
||||
;; (make-AssignImmediate (make-EnvLexicalReference 1 #f)
|
||||
;; (make-Const 4))
|
||||
;; (make-AssignImmediateStatement 'argcount (make-Const 2))
|
||||
;; (make-AssignPrimOpStatement 'val (make-ApplyPrimitiveProcedure))
|
||||
;; (make-AssignImmediate 'argcount (make-Const 2))
|
||||
;; (make-AssignPrimOp 'val (make-ApplyPrimitiveProcedure))
|
||||
;; 'done))
|
||||
;; "7")
|
||||
|
||||
|
|
@ -175,50 +175,50 @@
|
|||
|
||||
|
||||
;; A do-nothing closure
|
||||
(test (E-many (list (make-GotoStatement (make-Label 'afterLambda))
|
||||
(test (E-many (list (make-Goto (make-Label 'afterLambda))
|
||||
'closureStart
|
||||
(make-GotoStatement (make-Label 'afterLambda))
|
||||
(make-Goto (make-Label 'afterLambda))
|
||||
'afterLambda
|
||||
(make-AssignPrimOpStatement 'val (make-MakeCompiledProcedure 'closureStart 0 '() 'closureStart)))
|
||||
(make-AssignPrimOp 'val (make-MakeCompiledProcedure 'closureStart 0 '() 'closureStart)))
|
||||
"M.val.displayName")
|
||||
"closureStart")
|
||||
|
||||
|
||||
;; 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
|
||||
(make-GotoStatement (make-Label 'afterLambda))
|
||||
(make-Goto (make-Label 'afterLambda))
|
||||
'afterLambda
|
||||
(make-PushEnvironment 2 #f)
|
||||
(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
|
||||
(make-AssignImmediate (make-EnvLexicalReference 0 #f)
|
||||
(make-Const "hello"))
|
||||
(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f)
|
||||
(make-AssignImmediate (make-EnvLexicalReference 1 #f)
|
||||
(make-Const "world"))
|
||||
(make-AssignPrimOpStatement 'val (make-MakeCompiledProcedure 'closureStart 0
|
||||
(make-AssignPrimOp 'val (make-MakeCompiledProcedure 'closureStart 0
|
||||
(list 0 1)
|
||||
'closureStart)))
|
||||
"M.val.closedVals[1] + ',' + M.val.closedVals[0]")
|
||||
"hello,world")
|
||||
|
||||
;; 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
|
||||
(make-PerformStatement (make-InstallClosureValues!))
|
||||
(make-GotoStatement (make-Label 'theEnd))
|
||||
(make-Perform (make-InstallClosureValues!))
|
||||
(make-Goto (make-Label 'theEnd))
|
||||
|
||||
'afterLambdaBody
|
||||
(make-PushEnvironment 2 #f)
|
||||
(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
|
||||
(make-AssignImmediate (make-EnvLexicalReference 0 #f)
|
||||
(make-Const "hello"))
|
||||
(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f)
|
||||
(make-AssignImmediate (make-EnvLexicalReference 1 #f)
|
||||
(make-Const "world"))
|
||||
(make-AssignPrimOpStatement 'proc (make-MakeCompiledProcedure 'closureStart 0
|
||||
(make-AssignPrimOp 'proc (make-MakeCompiledProcedure 'closureStart 0
|
||||
(list 0 1)
|
||||
'closureStart))
|
||||
(make-PopEnvironment (make-Const 2)
|
||||
(make-Const 0))
|
||||
(make-GotoStatement (make-Label 'closureStart))
|
||||
(make-Goto (make-Label 'closureStart))
|
||||
'theEnd)
|
||||
"plt.runtime.toWrittenString(M.env.length) + ',' + M.env[1] + ',' + M.env[0]")
|
||||
"2,hello,world")
|
||||
|
|
@ -226,69 +226,69 @@
|
|||
|
||||
|
||||
;; get-compiled-procedure-entry
|
||||
(test (E-many (list (make-GotoStatement (make-Label 'afterLambdaBody))
|
||||
(test (E-many (list (make-Goto (make-Label 'afterLambdaBody))
|
||||
|
||||
'closureStart
|
||||
(make-PerformStatement (make-InstallClosureValues!))
|
||||
(make-GotoStatement (make-Label 'theEnd))
|
||||
(make-Perform (make-InstallClosureValues!))
|
||||
(make-Goto (make-Label 'theEnd))
|
||||
|
||||
'afterLambdaBody
|
||||
(make-PushEnvironment 2 #f)
|
||||
(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
|
||||
(make-AssignImmediate (make-EnvLexicalReference 0 #f)
|
||||
(make-Const "hello"))
|
||||
(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f)
|
||||
(make-AssignImmediate (make-EnvLexicalReference 1 #f)
|
||||
(make-Const "world"))
|
||||
(make-AssignPrimOpStatement 'proc (make-MakeCompiledProcedure 'closureStart 0
|
||||
(make-AssignPrimOp 'proc (make-MakeCompiledProcedure 'closureStart 0
|
||||
(list 0 1)
|
||||
'closureStart))
|
||||
(make-PopEnvironment (make-Const 2) (make-Const 0))
|
||||
(make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry))
|
||||
(make-AssignPrimOp 'val (make-GetCompiledProcedureEntry))
|
||||
'theEnd)
|
||||
"typeof(M.val) + ',' + (M.val === M.proc.label)")
|
||||
"function,true")
|
||||
|
||||
|
||||
;; 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
|
||||
(make-PerformStatement (make-InstallClosureValues!))
|
||||
(make-GotoStatement (make-Label 'theEnd))
|
||||
(make-Perform (make-InstallClosureValues!))
|
||||
(make-Goto (make-Label 'theEnd))
|
||||
|
||||
'afterLambdaBody
|
||||
(make-PushEnvironment 2 #f)
|
||||
(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
|
||||
(make-AssignImmediate (make-EnvLexicalReference 0 #f)
|
||||
(make-Const "hello"))
|
||||
(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f)
|
||||
(make-AssignImmediate (make-EnvLexicalReference 1 #f)
|
||||
(make-Const "world"))
|
||||
(make-AssignPrimOpStatement 'proc (make-MakeCompiledProcedure 'closureStart 5
|
||||
(make-AssignPrimOp 'proc (make-MakeCompiledProcedure 'closureStart 5
|
||||
(list 0 1)
|
||||
'closureStart))
|
||||
(make-PopEnvironment (make-Const 2) (make-Const 0))
|
||||
(make-PerformStatement (make-CheckClosureAndArity! (make-Const 5)))
|
||||
(make-Perform (make-CheckClosureAndArity! (make-Const 5)))
|
||||
'theEnd)))
|
||||
|
||||
;; this should fail, since the check is for 1, but the closure expects 5.
|
||||
(let/ec return
|
||||
(with-handlers ([void
|
||||
(lambda (exn) (return))])
|
||||
(E-many (list (make-GotoStatement (make-Label 'afterLambdaBody))
|
||||
(E-many (list (make-Goto (make-Label 'afterLambdaBody))
|
||||
|
||||
'closureStart
|
||||
(make-PerformStatement (make-InstallClosureValues!))
|
||||
(make-GotoStatement (make-Label 'theEnd))
|
||||
(make-Perform (make-InstallClosureValues!))
|
||||
(make-Goto (make-Label 'theEnd))
|
||||
|
||||
'afterLambdaBody
|
||||
(make-PushEnvironment 2 #f)
|
||||
(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
|
||||
(make-AssignImmediate (make-EnvLexicalReference 0 #f)
|
||||
(make-Const "hello"))
|
||||
(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f)
|
||||
(make-AssignImmediate (make-EnvLexicalReference 1 #f)
|
||||
(make-Const "world"))
|
||||
(make-AssignPrimOpStatement 'proc (make-MakeCompiledProcedure 'closureStart 5
|
||||
(make-AssignPrimOp 'proc (make-MakeCompiledProcedure 'closureStart 5
|
||||
(list 0 1)
|
||||
'closureStart))
|
||||
(make-PopEnvironment (make-Const 2) (make-Const 0))
|
||||
(make-PerformStatement (make-CheckClosureAndArity! (make-Const 1)))
|
||||
(make-Perform (make-CheckClosureAndArity! (make-Const 1)))
|
||||
'theEnd)))
|
||||
(error 'expected-failure))
|
||||
|
||||
|
|
@ -296,74 +296,74 @@
|
|||
|
||||
|
||||
|
||||
(test (E-many `(,(make-AssignImmediateStatement 'val (make-Const 42))
|
||||
,(make-TestAndJumpStatement (make-TestFalse (make-Reg 'val)) 'onFalse)
|
||||
,(make-AssignImmediateStatement 'val (make-Const 'ok))
|
||||
,(make-GotoStatement (make-Label 'end))
|
||||
(test (E-many `(,(make-AssignImmediate 'val (make-Const 42))
|
||||
,(make-TestAndJump (make-TestFalse (make-Reg 'val)) 'onFalse)
|
||||
,(make-AssignImmediate 'val (make-Const 'ok))
|
||||
,(make-Goto (make-Label 'end))
|
||||
onFalse
|
||||
,(make-AssignImmediateStatement 'val (make-Const 'not-ok))
|
||||
,(make-AssignImmediate 'val (make-Const 'not-ok))
|
||||
end))
|
||||
"ok")
|
||||
|
||||
;; TestAndBranch: try the false branch
|
||||
(test (E-many `(,(make-AssignImmediateStatement 'val (make-Const #f))
|
||||
,(make-TestAndJumpStatement (make-TestFalse (make-Reg 'val)) 'onFalse)
|
||||
,(make-AssignImmediateStatement 'val (make-Const 'not-ok))
|
||||
,(make-GotoStatement (make-Label 'end))
|
||||
(test (E-many `(,(make-AssignImmediate 'val (make-Const #f))
|
||||
,(make-TestAndJump (make-TestFalse (make-Reg 'val)) 'onFalse)
|
||||
,(make-AssignImmediate 'val (make-Const 'not-ok))
|
||||
,(make-Goto (make-Label 'end))
|
||||
onFalse
|
||||
,(make-AssignImmediateStatement 'val (make-Const 'ok))
|
||||
,(make-AssignImmediate 'val (make-Const 'ok))
|
||||
end))
|
||||
"ok")
|
||||
|
||||
;; ;; Test for primitive procedure
|
||||
;; (test (E-many `(,(make-AssignImmediateStatement 'val (make-Const '+))
|
||||
;; ,(make-TestAndJumpStatement (make-TestPrimitiveProcedure (make-Reg 'val)) 'onTrue)
|
||||
;; ,(make-AssignImmediateStatement 'val (make-Const 'ok))
|
||||
;; ,(make-GotoStatement (make-Label 'end))
|
||||
;; (test (E-many `(,(make-AssignImmediate 'val (make-Const '+))
|
||||
;; ,(make-TestAndJump (make-TestPrimitiveProcedure (make-Reg 'val)) 'onTrue)
|
||||
;; ,(make-AssignImmediate 'val (make-Const 'ok))
|
||||
;; ,(make-Goto (make-Label 'end))
|
||||
;; onTrue
|
||||
;; ,(make-AssignImmediateStatement 'val (make-Const 'not-ok))
|
||||
;; ,(make-AssignImmediate 'val (make-Const 'not-ok))
|
||||
;; end))
|
||||
;; "ok")
|
||||
|
||||
;; ;; Give a primitive procedure in val
|
||||
;; (test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
|
||||
;; ,(make-AssignImmediateStatement 'val (make-EnvPrefixReference 0 0))
|
||||
;; ,(make-TestAndJumpStatement (make-TestPrimitiveProcedure (make-Reg 'val)) 'onTrue)
|
||||
;; ,(make-AssignImmediateStatement 'val (make-Const 'not-ok))
|
||||
;; ,(make-GotoStatement (make-Label 'end))
|
||||
;; (test (E-many `(,(make-Perform (make-ExtendEnvironment/Prefix! '(+)))
|
||||
;; ,(make-AssignImmediate 'val (make-EnvPrefixReference 0 0))
|
||||
;; ,(make-TestAndJump (make-TestPrimitiveProcedure (make-Reg 'val)) 'onTrue)
|
||||
;; ,(make-AssignImmediate 'val (make-Const 'not-ok))
|
||||
;; ,(make-Goto (make-Label 'end))
|
||||
;; onTrue
|
||||
;; ,(make-AssignImmediateStatement 'val (make-Const 'ok))
|
||||
;; ,(make-AssignImmediate 'val (make-Const 'ok))
|
||||
;; end))
|
||||
;; "ok")
|
||||
|
||||
;; ;; Give a primitive procedure in proc, but test val
|
||||
;; (test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
|
||||
;; ,(make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0))
|
||||
;; ,(make-TestAndJumpStatement (make-TestPrimitiveProcedure (make-Reg 'val)) 'onTrue)
|
||||
;; ,(make-AssignImmediateStatement 'val (make-Const 'not-a-procedure))
|
||||
;; ,(make-GotoStatement (make-Label 'end))
|
||||
;; (test (E-many `(,(make-Perform (make-ExtendEnvironment/Prefix! '(+)))
|
||||
;; ,(make-AssignImmediate 'proc (make-EnvPrefixReference 0 0))
|
||||
;; ,(make-TestAndJump (make-TestPrimitiveProcedure (make-Reg 'val)) 'onTrue)
|
||||
;; ,(make-AssignImmediate 'val (make-Const 'not-a-procedure))
|
||||
;; ,(make-Goto (make-Label 'end))
|
||||
;; onTrue
|
||||
;; ,(make-AssignImmediateStatement 'val (make-Const 'a-procedure))
|
||||
;; ,(make-AssignImmediate 'val (make-Const 'a-procedure))
|
||||
;; end))
|
||||
;; "not-a-procedure")
|
||||
|
||||
;; ;; Give a primitive procedure in proc and test proc
|
||||
;; (test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
|
||||
;; ,(make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0))
|
||||
;; ,(make-TestAndJumpStatement (make-TestPrimitiveProcedure (make-Reg 'proc)) 'onTrue)
|
||||
;; ,(make-AssignImmediateStatement 'val (make-Const 'not-a-procedure))
|
||||
;; ,(make-GotoStatement (make-Label 'end))
|
||||
;; (test (E-many `(,(make-Perform (make-ExtendEnvironment/Prefix! '(+)))
|
||||
;; ,(make-AssignImmediate 'proc (make-EnvPrefixReference 0 0))
|
||||
;; ,(make-TestAndJump (make-TestPrimitiveProcedure (make-Reg 'proc)) 'onTrue)
|
||||
;; ,(make-AssignImmediate 'val (make-Const 'not-a-procedure))
|
||||
;; ,(make-Goto (make-Label 'end))
|
||||
;; onTrue
|
||||
;; ,(make-AssignImmediateStatement 'val (make-Const 'a-procedure))
|
||||
;; ,(make-AssignImmediate 'val (make-Const 'a-procedure))
|
||||
;; end))
|
||||
;; "a-procedure")
|
||||
|
||||
|
||||
|
||||
;; Set-toplevel
|
||||
(test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(advisor)))
|
||||
,(make-AssignImmediateStatement 'val (make-Const "Kathi"))
|
||||
,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0) (make-Reg 'val)))
|
||||
(test (E-many `(,(make-Perform (make-ExtendEnvironment/Prefix! '(advisor)))
|
||||
,(make-AssignImmediate 'val (make-Const "Kathi"))
|
||||
,(make-AssignImmediate (make-EnvPrefixReference 0 0) (make-Reg 'val)))
|
||||
"M.env[0][0]")
|
||||
"Kathi")
|
||||
|
||||
|
|
@ -372,38 +372,38 @@
|
|||
(let/ec return
|
||||
(let ([dont-care
|
||||
(with-handlers ([void (lambda (exn) (return))])
|
||||
(E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(some-variable)))
|
||||
,(make-PerformStatement (make-CheckToplevelBound! 0 0)))))])
|
||||
(E-many `(,(make-Perform (make-ExtendEnvironment/Prefix! '(some-variable)))
|
||||
,(make-Perform (make-CheckToplevelBound! 0 0)))))])
|
||||
(raise "I expected an error")))
|
||||
|
||||
;; check-toplevel-bound shouldn't fail here.
|
||||
(test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(another-advisor)))
|
||||
,(make-AssignImmediateStatement 'val (make-Const "Shriram"))
|
||||
,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0) (make-Reg 'val))
|
||||
,(make-PerformStatement (make-CheckToplevelBound! 0 0)))
|
||||
(test (E-many `(,(make-Perform (make-ExtendEnvironment/Prefix! '(another-advisor)))
|
||||
,(make-AssignImmediate 'val (make-Const "Shriram"))
|
||||
,(make-AssignImmediate (make-EnvPrefixReference 0 0) (make-Reg 'val))
|
||||
,(make-Perform (make-CheckToplevelBound! 0 0)))
|
||||
"M.env[0][0]")
|
||||
"Shriram")
|
||||
|
||||
|
||||
|
||||
(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-AssignImmediateStatement 'argcount (make-Const 1))
|
||||
,(make-PerformStatement (make-SpliceListIntoStack! (make-Const 0))))
|
||||
,(make-AssignImmediate 'argcount (make-Const 1))
|
||||
,(make-Perform (make-SpliceListIntoStack! (make-Const 0))))
|
||||
"M.argcount + ',' + M.env[0] + ',' + M.env[1] + ',' + M.env[2]")
|
||||
"3,3,2,1")
|
||||
|
||||
|
||||
(test (E-many `(,(make-PushEnvironment 3 #f)
|
||||
,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
|
||||
,(make-AssignImmediate (make-EnvLexicalReference 0 #f)
|
||||
(make-Const "hello"))
|
||||
,(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f)
|
||||
,(make-AssignImmediate (make-EnvLexicalReference 1 #f)
|
||||
(make-Const "world"))
|
||||
,(make-AssignImmediateStatement (make-EnvLexicalReference 2 #f)
|
||||
,(make-AssignImmediate (make-EnvLexicalReference 2 #f)
|
||||
(make-Const '(1 2 3)))
|
||||
,(make-AssignImmediateStatement 'argcount (make-Const 3))
|
||||
,(make-PerformStatement (make-SpliceListIntoStack! (make-Const 2))))
|
||||
,(make-AssignImmediate 'argcount (make-Const 3))
|
||||
,(make-Perform (make-SpliceListIntoStack! (make-Const 2))))
|
||||
"M.argcount + ',' + M.env[0] + ',' + M.env[1] + ',' + M.env[2] + ',' + M.env[3] + ',' + M.env[4]")
|
||||
"5,3,2,1,world,hello")
|
||||
|
||||
|
|
@ -415,10 +415,10 @@
|
|||
|
||||
;; testing rest splicing
|
||||
(test (E-many `(,(make-PushEnvironment 1 #f)
|
||||
,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
|
||||
,(make-AssignImmediate (make-EnvLexicalReference 0 #f)
|
||||
(make-Const "hello"))
|
||||
,(make-AssignImmediateStatement 'argcount (make-Const 1))
|
||||
,(make-PerformStatement (make-UnspliceRestFromStack! (make-Const 0)
|
||||
,(make-AssignImmediate 'argcount (make-Const 1))
|
||||
,(make-Perform (make-UnspliceRestFromStack! (make-Const 0)
|
||||
(make-Const 1))))
|
||||
"M.argcount + ',' + plt.runtime.isList(M.env[0])")
|
||||
"1,true")
|
||||
|
|
@ -426,18 +426,18 @@
|
|||
|
||||
(test (E-many
|
||||
`(,(make-PushEnvironment 5 #f)
|
||||
,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
|
||||
,(make-AssignImmediate (make-EnvLexicalReference 0 #f)
|
||||
(make-Const "hello"))
|
||||
,(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f)
|
||||
,(make-AssignImmediate (make-EnvLexicalReference 1 #f)
|
||||
(make-Const "world"))
|
||||
,(make-AssignImmediateStatement (make-EnvLexicalReference 2 #f)
|
||||
,(make-AssignImmediate (make-EnvLexicalReference 2 #f)
|
||||
(make-Const 'x))
|
||||
,(make-AssignImmediateStatement (make-EnvLexicalReference 3 #f)
|
||||
,(make-AssignImmediate (make-EnvLexicalReference 3 #f)
|
||||
(make-Const 'y))
|
||||
,(make-AssignImmediateStatement (make-EnvLexicalReference 4 #f)
|
||||
,(make-AssignImmediate (make-EnvLexicalReference 4 #f)
|
||||
(make-Const 'z))
|
||||
,(make-AssignImmediateStatement 'argcount (make-Const 5))
|
||||
,(make-PerformStatement (make-UnspliceRestFromStack! (make-Const 2) (make-Const 3))))
|
||||
,(make-AssignImmediate 'argcount (make-Const 5))
|
||||
,(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]")
|
||||
"3,3,true,hello,world")
|
||||
|
||||
|
|
@ -446,16 +446,16 @@
|
|||
;; Check closure mismatch. Make sure we're getting the right values from the test.
|
||||
(test (E-many `(procedure-entry
|
||||
;; doesn't matter about the procedure entry...
|
||||
,(make-AssignPrimOpStatement
|
||||
,(make-AssignPrimOp
|
||||
'proc
|
||||
(make-MakeCompiledProcedure 'procedure-entry 0 (list) 'procedure-entry))
|
||||
,(make-TestAndJumpStatement
|
||||
,(make-TestAndJump
|
||||
(make-TestClosureArityMismatch (make-Reg 'proc) (make-Const 0))
|
||||
'bad)
|
||||
,(make-AssignImmediateStatement 'val (make-Const 'ok))
|
||||
,(make-GotoStatement (make-Label 'end))
|
||||
,(make-AssignImmediate 'val (make-Const 'ok))
|
||||
,(make-Goto (make-Label 'end))
|
||||
bad
|
||||
,(make-AssignImmediateStatement 'val (make-Const 'bad))
|
||||
,(make-AssignImmediate 'val (make-Const 'bad))
|
||||
end)
|
||||
"M.val")
|
||||
"ok")
|
||||
|
|
@ -463,48 +463,48 @@
|
|||
|
||||
(test (E-many `(procedure-entry
|
||||
;; doesn't matter about the procedure entry...
|
||||
,(make-AssignPrimOpStatement
|
||||
,(make-AssignPrimOp
|
||||
'proc
|
||||
(make-MakeCompiledProcedure 'procedure-entry 0 (list) 'procedure-entry))
|
||||
,(make-TestAndJumpStatement
|
||||
,(make-TestAndJump
|
||||
(make-TestClosureArityMismatch (make-Reg 'proc) (make-Const 1))
|
||||
'ok)
|
||||
,(make-AssignImmediateStatement 'val (make-Const 'bad))
|
||||
,(make-GotoStatement (make-Label 'end))
|
||||
,(make-AssignImmediate 'val (make-Const 'bad))
|
||||
,(make-Goto (make-Label 'end))
|
||||
ok
|
||||
,(make-AssignImmediateStatement 'val (make-Const 'ok))
|
||||
,(make-AssignImmediate 'val (make-Const 'ok))
|
||||
end)
|
||||
"M.val")
|
||||
"ok")
|
||||
|
||||
(test (E-many `(procedure-entry
|
||||
;; doesn't matter about the procedure entry...
|
||||
,(make-AssignPrimOpStatement
|
||||
,(make-AssignPrimOp
|
||||
'proc
|
||||
(make-MakeCompiledProcedure 'procedure-entry (make-ArityAtLeast 2) (list) 'procedure-entry))
|
||||
,(make-TestAndJumpStatement
|
||||
,(make-TestAndJump
|
||||
(make-TestClosureArityMismatch (make-Reg 'proc) (make-Const 0))
|
||||
'ok)
|
||||
,(make-AssignImmediateStatement 'val (make-Const 'bad))
|
||||
,(make-GotoStatement (make-Label 'end))
|
||||
,(make-AssignImmediate 'val (make-Const 'bad))
|
||||
,(make-Goto (make-Label 'end))
|
||||
ok
|
||||
,(make-AssignImmediateStatement 'val (make-Const 'ok))
|
||||
,(make-AssignImmediate 'val (make-Const 'ok))
|
||||
end)
|
||||
"M.val")
|
||||
"ok")
|
||||
|
||||
(test (E-many `(procedure-entry
|
||||
;; doesn't matter about the procedure entry...
|
||||
,(make-AssignPrimOpStatement
|
||||
,(make-AssignPrimOp
|
||||
'proc
|
||||
(make-MakeCompiledProcedure 'procedure-entry (make-ArityAtLeast 2) (list) 'procedure-entry))
|
||||
,(make-TestAndJumpStatement
|
||||
,(make-TestAndJump
|
||||
(make-TestClosureArityMismatch (make-Reg 'proc) (make-Const 2))
|
||||
'bad)
|
||||
,(make-AssignImmediateStatement 'val (make-Const 'ok))
|
||||
,(make-GotoStatement (make-Label 'end))
|
||||
,(make-AssignImmediate 'val (make-Const 'ok))
|
||||
,(make-Goto (make-Label 'end))
|
||||
bad
|
||||
,(make-AssignImmediateStatement 'val (make-Const 'bad))
|
||||
,(make-AssignImmediate 'val (make-Const 'bad))
|
||||
end)
|
||||
"M.val")
|
||||
"ok")
|
||||
|
|
@ -517,10 +517,10 @@
|
|||
,(make-PushImmediateOntoEnvironment (make-Const 4) #f)
|
||||
procedure-entry
|
||||
;; doesn't matter about the procedure entry...
|
||||
,(make-AssignPrimOpStatement
|
||||
,(make-AssignPrimOp
|
||||
'proc
|
||||
(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")
|
||||
"4")
|
||||
|
||||
|
|
@ -528,10 +528,10 @@
|
|||
,(make-PushImmediateOntoEnvironment (make-Const 4) #f)
|
||||
procedure-entry
|
||||
;; doesn't matter about the procedure entry...
|
||||
,(make-AssignPrimOpStatement
|
||||
,(make-AssignPrimOp
|
||||
'proc
|
||||
(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")
|
||||
"3")
|
||||
|
||||
|
|
|
|||
|
|
@ -227,19 +227,20 @@
|
|||
|
||||
|
||||
;; the letrec gets translated into a closure call
|
||||
(begin
|
||||
(reset-lam-label-counter!/unit-testing)
|
||||
(check-equal? (run-my-parse '(letrec ([omega (lambda () (omega))])
|
||||
(omega)))
|
||||
(make-Top (make-Prefix '())
|
||||
(make-App (make-Lam 'omega 0 #f (make-App (make-EmptyClosureReference 'omega 0 #f 'lamEntry1) '())
|
||||
'() 'lamEntry1)
|
||||
'()))))
|
||||
(check-true (match (run-my-parse '(letrec ([omega (lambda () (omega))])
|
||||
(omega)))
|
||||
[(struct Top ((struct Prefix (list))
|
||||
(struct App ((struct Lam ('omega 0
|
||||
#f
|
||||
(struct App ((struct EmptyClosureReference ('omega 0 #f _))
|
||||
(list)))
|
||||
(list) _))
|
||||
(list)))))
|
||||
#t]))
|
||||
|
||||
|
||||
;; FIXME: make this a real test.
|
||||
(begin
|
||||
(reset-lam-label-counter!/unit-testing)
|
||||
(void (run-my-parse #'(letrec ([e (lambda (y)
|
||||
(if (= y 0)
|
||||
#t
|
||||
|
|
@ -292,14 +293,12 @@
|
|||
(make-App (make-PrimitiveKernelValue 'current-continuation-marks) '()))))
|
||||
|
||||
|
||||
(begin (reset-lam-label-counter!/unit-testing)
|
||||
(check-true (match (run-my-parse #'(case-lambda))
|
||||
(begin (check-true (match (run-my-parse #'(case-lambda))
|
||||
[(struct Top ((struct Prefix (list))
|
||||
(struct CaseLam (_ (list) 'lamEntry1))))
|
||||
(struct CaseLam (_ (list) _))))
|
||||
#t])))
|
||||
|
||||
(begin (reset-lam-label-counter!/unit-testing)
|
||||
(check-true (match (run-my-parse #'(case-lambda [(x) x]
|
||||
(begin (check-true (match (run-my-parse #'(case-lambda [(x) x]
|
||||
[(x y) x]
|
||||
[(x y) y]))
|
||||
[(struct Top ((struct Prefix (list))
|
||||
|
|
@ -309,20 +308,20 @@
|
|||
#f
|
||||
(struct LocalRef ('0 '#f))
|
||||
'()
|
||||
'lamEntry2))
|
||||
_))
|
||||
(struct Lam (_
|
||||
2
|
||||
#f
|
||||
(struct LocalRef ('0 '#f))
|
||||
'()
|
||||
'lamEntry3))
|
||||
_))
|
||||
(struct Lam (_
|
||||
2
|
||||
#f
|
||||
(struct LocalRef ('1 '#f))
|
||||
'()
|
||||
'lamEntry4)))
|
||||
'lamEntry1))))
|
||||
_)))
|
||||
_))))
|
||||
#t])))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
#lang racket/base
|
||||
|
||||
(require "../parser/baby-parser.rkt"
|
||||
"../parser/lam-entry-gensym.rkt"
|
||||
"../compiler/lexical-structs.rkt"
|
||||
"../compiler/expression-structs.rkt"
|
||||
(for-syntax racket/base))
|
||||
|
|
@ -16,7 +15,6 @@
|
|||
(syntax/loc #'stx
|
||||
(begin
|
||||
(printf "Running ~s ...\n" (syntax->datum #'expr))
|
||||
(reset-lam-label-counter!/unit-testing)
|
||||
(let ([expected expt]
|
||||
[actual
|
||||
(with-handlers ([void
|
||||
|
|
@ -25,8 +23,8 @@
|
|||
#'stx))])
|
||||
expr)])
|
||||
(unless (equal? actual expected)
|
||||
(raise-syntax-error #f (format "Expected ~s, got ~s" expected actual)
|
||||
#'stx))
|
||||
(printf (format "Expected ~s, got ~s, at ~s" expected actual
|
||||
(syntax-line #'stx))))
|
||||
(printf "ok.\n\n")))))]))
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user