continuing to shrink code down. Eliminating the use of simulator in test suite; I don't think we'll need the simulator any more.
This commit is contained in:
Danny Yoo
parent
9e11017b7e
commit
0de37fae86
|
|
@ -1423,7 +1423,7 @@
|
|||
|
||||
|
||||
;; Compiled branch
|
||||
(make-PerformStatement (make-CheckClosureArity! (make-Reg 'argcount)))
|
||||
(make-PerformStatement (make-CheckClosureAndArity! (make-Reg 'argcount)))
|
||||
(compile-compiled-procedure-application cenv
|
||||
number-of-arguments
|
||||
'dynamic
|
||||
|
|
|
|||
|
|
@ -280,7 +280,6 @@
|
|||
(define-type PrimitiveOperator (U GetCompiledProcedureEntry
|
||||
MakeCompiledProcedure
|
||||
MakeCompiledProcedureShell
|
||||
ApplyPrimitiveProcedure
|
||||
|
||||
|
||||
MakeBoxedEnvironmentValue
|
||||
|
|
@ -312,15 +311,6 @@
|
|||
#:transparent)
|
||||
|
||||
|
||||
;; Applies the primitive procedure that's stored in the proc register, using
|
||||
;; the argcount number of values that are bound in the environment as arguments
|
||||
;; to that primitive.
|
||||
(define-struct: ApplyPrimitiveProcedure ()
|
||||
#:transparent)
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -356,14 +346,12 @@
|
|||
TestTrue
|
||||
TestOne
|
||||
TestZero
|
||||
TestPrimitiveProcedure
|
||||
TestClosureArityMismatch
|
||||
))
|
||||
(define-struct: TestFalse ([operand : OpArg]) #:transparent)
|
||||
(define-struct: TestTrue ([operand : OpArg]) #:transparent)
|
||||
(define-struct: TestOne ([operand : OpArg]) #:transparent)
|
||||
(define-struct: TestZero ([operand : OpArg]) #:transparent)
|
||||
(define-struct: TestPrimitiveProcedure ([operand : OpArg]) #:transparent)
|
||||
(define-struct: TestClosureArityMismatch ([closure : OpArg]
|
||||
[n : OpArg]) #:transparent)
|
||||
|
||||
|
|
@ -375,13 +363,10 @@
|
|||
[pos : Natural])
|
||||
#:transparent)
|
||||
|
||||
;; Check the closure procedure value in 'proc and make sure it can accept the
|
||||
;; # of arguments (stored as a number in the argcount register.).
|
||||
(define-struct: CheckClosureArity! ([num-args : OpArg])
|
||||
;; Check the closure procedure value in 'proc and make sure it's a closure
|
||||
;; that can accept the right arguments (stored as a number in the argcount register.).
|
||||
(define-struct: CheckClosureAndArity! ([num-args : OpArg])
|
||||
#:transparent)
|
||||
(define-struct: CheckPrimitiveArity! ([num-args : OpArg])
|
||||
#:transparent)
|
||||
|
||||
|
||||
|
||||
;; Extends the environment with a prefix that holds
|
||||
|
|
@ -481,8 +466,7 @@
|
|||
|
||||
(define-type PrimitiveCommand (U
|
||||
CheckToplevelBound!
|
||||
CheckClosureArity!
|
||||
CheckPrimitiveArity!
|
||||
CheckClosureAndArity!
|
||||
|
||||
ExtendEnvironment/Prefix!
|
||||
InstallClosureValues!
|
||||
|
|
|
|||
|
|
@ -128,8 +128,6 @@
|
|||
(MakeCompiledProcedureShell-arity op)
|
||||
(MakeCompiledProcedureShell-display-name op))]
|
||||
|
||||
[(ApplyPrimitiveProcedure? op)
|
||||
op]
|
||||
|
||||
[(MakeBoxedEnvironmentValue? op)
|
||||
op]
|
||||
|
|
|
|||
|
|
@ -36,9 +36,6 @@
|
|||
(assemble-arity (MakeCompiledProcedureShell-arity op))
|
||||
(assemble-display-name (MakeCompiledProcedureShell-display-name op)))]
|
||||
|
||||
[(ApplyPrimitiveProcedure? op)
|
||||
(format "M.proc(M)")]
|
||||
|
||||
[(CaptureEnvironment? op)
|
||||
(format "M.env.slice(0, M.env.length - ~a)"
|
||||
(CaptureEnvironment-skip op))]
|
||||
|
|
|
|||
|
|
@ -21,18 +21,11 @@
|
|||
(CheckToplevelBound!-pos op))]
|
||||
|
||||
|
||||
[(CheckClosureArity!? op)
|
||||
[(CheckClosureAndArity!? op)
|
||||
(format "if(!(M.proc instanceof RT.Closure)){RT.raiseOperatorIsNotClosure(M,M.proc);}if(!RT.isArityMatching(M.proc.racketArity,~a)){RT.raiseArityMismatchError(M, M.proc,~a);}"
|
||||
(assemble-oparg (CheckClosureArity!-num-args op))
|
||||
(assemble-oparg (CheckClosureArity!-num-args op)))]
|
||||
(assemble-oparg (CheckClosureAndArity!-num-args op))
|
||||
(assemble-oparg (CheckClosureAndArity!-num-args op)))]
|
||||
|
||||
|
||||
[(CheckPrimitiveArity!? op)
|
||||
(format "if(!RT.isArityMatching(M.proc.racketArity,~a)){RT.raiseArityMismatchError(M,M.proc,~a);}"
|
||||
(assemble-oparg (CheckPrimitiveArity!-num-args op))
|
||||
(assemble-oparg (CheckPrimitiveArity!-num-args op)))]
|
||||
|
||||
|
||||
[(ExtendEnvironment/Prefix!? op)
|
||||
(let: ([names : (Listof (U Symbol False GlobalBucket ModuleVariable)) (ExtendEnvironment/Prefix!-names op)])
|
||||
(format "M.env.push([~a]);M.env[M.env.length-1].names=[~a];"
|
||||
|
|
|
|||
|
|
@ -236,9 +236,9 @@ EOF
|
|||
(format "if(~a===0)"
|
||||
(assemble-oparg (TestZero-operand test)))]
|
||||
|
||||
[(TestPrimitiveProcedure? test)
|
||||
(format "if(typeof(~a)==='function')"
|
||||
(assemble-oparg (TestPrimitiveProcedure-operand test)))]
|
||||
;; [(TestPrimitiveProcedure? test)
|
||||
;; (format "if(typeof(~a)==='function')"
|
||||
;; (assemble-oparg (TestPrimitiveProcedure-operand test)))]
|
||||
|
||||
[(TestClosureArityMismatch? test)
|
||||
(format "if(!RT.isArityMatching((~a).racketArity,~a))"
|
||||
|
|
@ -435,10 +435,10 @@ EOF
|
|||
(format "if(~a===0){~a}"
|
||||
(assemble-oparg (TestZero-operand test))
|
||||
jump)]
|
||||
[(TestPrimitiveProcedure? test)
|
||||
(format "if(typeof(~a)==='function'){~a}"
|
||||
(assemble-oparg (TestPrimitiveProcedure-operand test))
|
||||
jump)]
|
||||
;; [(TestPrimitiveProcedure? test)
|
||||
;; (format "if(typeof(~a)==='function'){~a}"
|
||||
;; (assemble-oparg (TestPrimitiveProcedure-operand test))
|
||||
;; jump)]
|
||||
[(TestClosureArityMismatch? test)
|
||||
(format "if(!RT.isArityMatching((~a).racketArity,~a)){~a}"
|
||||
(assemble-oparg (TestClosureArityMismatch-closure test))
|
||||
|
|
|
|||
|
|
@ -112,8 +112,8 @@
|
|||
(list (MakeCompiledProcedure-label op))]
|
||||
[(MakeCompiledProcedureShell? op)
|
||||
(list (MakeCompiledProcedureShell-label op))]
|
||||
[(ApplyPrimitiveProcedure? op)
|
||||
empty]
|
||||
;; [(ApplyPrimitiveProcedure? op)
|
||||
;; empty]
|
||||
[(CaptureEnvironment? op)
|
||||
empty]
|
||||
[(CaptureControl? op)
|
||||
|
|
@ -258,8 +258,8 @@
|
|||
(list (MakeCompiledProcedure-label op))]
|
||||
[(MakeCompiledProcedureShell? op)
|
||||
(list (MakeCompiledProcedureShell-label op))]
|
||||
[(ApplyPrimitiveProcedure? op)
|
||||
empty]
|
||||
;; [(ApplyPrimitiveProcedure? op)
|
||||
;; empty]
|
||||
[(CaptureEnvironment? op)
|
||||
empty]
|
||||
[(CaptureControl? op)
|
||||
|
|
@ -279,7 +279,7 @@
|
|||
;; currently written this way because I'm hitting some bad type-checking behavior.
|
||||
#;([(CheckToplevelBound!? op)
|
||||
empty]
|
||||
[(CheckClosureArity!? op)
|
||||
[(CheckClosureAndArity!? op)
|
||||
empty]
|
||||
[(CheckPrimitiveArity!? op)
|
||||
empty]
|
||||
|
|
|
|||
|
|
@ -308,15 +308,15 @@
|
|||
[else
|
||||
'ok]))]
|
||||
|
||||
[(CheckClosureArity!? op)
|
||||
[(CheckClosureAndArity!? op)
|
||||
(let: ([clos : SlotValue (machine-proc m)])
|
||||
(cond
|
||||
[(closure? clos)
|
||||
(if (arity-match? (closure-arity clos)
|
||||
(ensure-natural (evaluate-oparg m (CheckClosureArity!-num-args op))))
|
||||
(ensure-natural (evaluate-oparg m (CheckClosureAndArity!-num-args op))))
|
||||
'ok
|
||||
(error 'check-closure-arity "arity mismatch: passed ~s args to ~s"
|
||||
(ensure-natural (evaluate-oparg m (CheckClosureArity!-num-args op)))
|
||||
(ensure-natural (evaluate-oparg m (CheckClosureAndArity!-num-args op)))
|
||||
(closure-display-name clos)))]
|
||||
[else
|
||||
(error 'check-closure-arity "not a closure: ~s" clos)]))]
|
||||
|
|
@ -654,23 +654,7 @@
|
|||
(MakeCompiledProcedureShell-arity op)
|
||||
'()
|
||||
(MakeCompiledProcedureShell-display-name op)))]
|
||||
|
||||
[(ApplyPrimitiveProcedure? op)
|
||||
(let: ([prim : SlotValue (machine-proc m)]
|
||||
[args : (Listof PrimitiveValue)
|
||||
(map ensure-primitive-value (take (machine-env m)
|
||||
(ensure-natural (machine-argcount m))))])
|
||||
(cond
|
||||
[(primitive-proc? prim)
|
||||
(target-updater! m (ensure-primitive-value
|
||||
(parameterize ([current-output-port
|
||||
(current-simulated-output-port)])
|
||||
(apply (primitive-proc-f prim)
|
||||
m
|
||||
args))))]
|
||||
[else
|
||||
(error 'apply-primitive-procedure)]))]
|
||||
|
||||
|
||||
[(CaptureEnvironment? op)
|
||||
(target-updater! m (make-CapturedEnvironment (drop (machine-env m)
|
||||
(CaptureEnvironment-skip op))))]
|
||||
|
|
|
|||
|
|
@ -2,9 +2,9 @@
|
|||
|
||||
(require "test-parse.rkt"
|
||||
"test-parse-bytecode.rkt"
|
||||
"test-simulator.rkt"
|
||||
"test-compiler.rkt"
|
||||
"test-compiler-2.rkt"
|
||||
;; "test-simulator.rkt"
|
||||
;; "test-compiler.rkt"
|
||||
;; "test-compiler-2.rkt"
|
||||
"test-assemble.rkt"
|
||||
"test-browser-evaluate.rkt"
|
||||
"test-package.rkt"
|
||||
|
|
|
|||
|
|
@ -265,7 +265,7 @@
|
|||
(list 0 1)
|
||||
'closureStart))
|
||||
(make-PopEnvironment (make-Const 2) (make-Const 0))
|
||||
(make-PerformStatement (make-CheckClosureArity! (make-Const 5)))
|
||||
(make-PerformStatement (make-CheckClosureAndArity! (make-Const 5)))
|
||||
'theEnd)))
|
||||
|
||||
;; this should fail, since the check is for 1, but the closure expects 5.
|
||||
|
|
@ -288,7 +288,7 @@
|
|||
(list 0 1)
|
||||
'closureStart))
|
||||
(make-PopEnvironment (make-Const 2) (make-Const 0))
|
||||
(make-PerformStatement (make-CheckClosureArity! (make-Const 1)))
|
||||
(make-PerformStatement (make-CheckClosureAndArity! (make-Const 1)))
|
||||
'theEnd)))
|
||||
(error 'expected-failure))
|
||||
|
||||
|
|
@ -315,15 +315,15 @@
|
|||
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))
|
||||
onTrue
|
||||
,(make-AssignImmediateStatement 'val (make-Const 'not-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))
|
||||
;; onTrue
|
||||
;; ,(make-AssignImmediateStatement 'val (make-Const 'not-ok))
|
||||
;; end))
|
||||
;; "ok")
|
||||
|
||||
;; ;; Give a primitive procedure in val
|
||||
;; (test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
|
||||
|
|
@ -336,16 +336,16 @@
|
|||
;; 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))
|
||||
onTrue
|
||||
,(make-AssignImmediateStatement 'val (make-Const 'a-procedure))
|
||||
end))
|
||||
"not-a-procedure")
|
||||
;; ;; 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))
|
||||
;; onTrue
|
||||
;; ,(make-AssignImmediateStatement '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! '(+)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user