primitive procedure testing
This commit is contained in:
Danny Yoo
parent
488137a6af
commit
0de23ee06e
72
assemble.rkt
72
assemble.rkt
|
|
@ -223,11 +223,16 @@ EOF
|
|||
(assemble-op-statement (PerformStatement-op stmt))]
|
||||
|
||||
[(TestAndBranchStatement? stmt)
|
||||
(error 'assemble-stmt)
|
||||
#;(format "if(~a){return ~a();}"
|
||||
(assemble-op-expression (TestAndBranchStatement-op stmt)
|
||||
(list (make-Reg (TestAndBranchStatement-register stmt))))
|
||||
(assemble-location (make-Label (TestAndBranchStatement-label stmt))))]
|
||||
(let*: ([test : PrimitiveTest (TestAndBranchStatement-op stmt)])
|
||||
(cond
|
||||
[(eq? test 'false?)
|
||||
(format "if (! ~a) { return ~a(); }"
|
||||
(assemble-reg (make-Reg (TestAndBranchStatement-register stmt)))
|
||||
(assemble-label (make-Label (TestAndBranchStatement-label stmt))))]
|
||||
[(eq? test 'primitive-procedure?)
|
||||
(format "if (typeof(~a) === 'function') { return ~a(); };"
|
||||
(assemble-reg (make-Reg (TestAndBranchStatement-register stmt)))
|
||||
(assemble-label (make-Label (TestAndBranchStatement-label stmt))))]))]
|
||||
|
||||
[(GotoStatement? stmt)
|
||||
(format "return ~a();"
|
||||
|
|
@ -272,6 +277,8 @@ EOF
|
|||
(format "[~a, ~a]"
|
||||
(loop (car val))
|
||||
(loop (cdr val)))]
|
||||
[(boolean? val)
|
||||
(if val "true" "false")]
|
||||
[(empty? val)
|
||||
(format "undefined")]
|
||||
[else
|
||||
|
|
@ -327,60 +334,7 @@ EOF
|
|||
(LookupToplevelAddress-pos op))]
|
||||
|
||||
[(GetControlStackLabel? op)
|
||||
(format "MACHINE.control[MACHINE.control.length-1].label")]
|
||||
|
||||
#;[(compiled-procedure-env)
|
||||
#;(format "(~a.env)" (assemble-input (first inputs)))]
|
||||
#;[(make-compiled-procedure)
|
||||
(format "(new Closure(~a, ~a))"
|
||||
(second assembled-inputs)
|
||||
(first assembled-inputs))]
|
||||
#;[(false?)
|
||||
(format "(!(~a))" (assemble-input (first inputs)))]
|
||||
#;[(cons)
|
||||
(format "[~a]" (string-join (map assemble-input inputs) ","))]
|
||||
#;[(list)
|
||||
(cond [(empty? inputs)
|
||||
"undefined"]
|
||||
[else
|
||||
(let: loop : String ([assembled-inputs : (Listof String) assembled-inputs])
|
||||
(cond
|
||||
[(empty? assembled-inputs)
|
||||
"undefined"]
|
||||
[else
|
||||
(format "[~a, ~a]"
|
||||
(first assembled-inputs)
|
||||
(loop (rest assembled-inputs)))]))])]
|
||||
#;[(apply-primitive-procedure)
|
||||
(format "~a(~a)"
|
||||
(first assembled-inputs)
|
||||
;; FIXME: this doesn't look quite right...
|
||||
(third assembled-inputs))]
|
||||
#;[(lexical-address-lookup)
|
||||
(format "(~a).valss[~a][~a]"
|
||||
(third assembled-inputs)
|
||||
(first assembled-inputs)
|
||||
(second assembled-inputs))]
|
||||
#;[(toplevel-lookup)
|
||||
(let ([depth (first assembled-inputs)]
|
||||
[pos (second assembled-inputs)]
|
||||
[name (third assembled-inputs)]
|
||||
[env (fourth assembled-inputs)])
|
||||
(format "(~a).valss[~a][~a]" env depth pos))]
|
||||
#;[(primitive-procedure?)
|
||||
(format "(typeof(~a) === 'function')"
|
||||
(first assembled-inputs))]
|
||||
#;[(extend-environment)
|
||||
(format "new ExtendedEnvironment(~a, ~a)"
|
||||
(second assembled-inputs)
|
||||
(first assembled-inputs))]
|
||||
#;[(extend-environment/prefix)
|
||||
(format "new ExtendedPrefixEnvironment(~a, ~a)"
|
||||
(second assembled-inputs)
|
||||
(first assembled-inputs))]
|
||||
#;[(read-control-label)
|
||||
"fixme"]
|
||||
))
|
||||
(format "MACHINE.control[MACHINE.control.length-1].label")]))
|
||||
|
||||
|
||||
(: assemble-op-statement (PrimitiveCommand -> String))
|
||||
|
|
|
|||
|
|
@ -29,39 +29,39 @@
|
|||
|
||||
;; evaluating single expression
|
||||
(define -E (delay (make-evaluate
|
||||
(lambda (a-statement+inspector op)
|
||||
(let* ([a-statement (car a-statement+inspector)]
|
||||
[inspector (cdr a-statement+inspector)]
|
||||
[snippet (assemble-statement a-statement)]
|
||||
[code
|
||||
(string-append
|
||||
"(function() { "
|
||||
runtime
|
||||
"return function(success, fail, params){" snippet
|
||||
(format "success(String(~a)); };" inspector)
|
||||
"});")])
|
||||
(displayln snippet)
|
||||
(display code op))))))
|
||||
(lambda (a-statement+inspector op)
|
||||
(let* ([a-statement (car a-statement+inspector)]
|
||||
[inspector (cdr a-statement+inspector)]
|
||||
[snippet (assemble-statement a-statement)]
|
||||
[code
|
||||
(string-append
|
||||
"(function() { "
|
||||
runtime
|
||||
"return function(success, fail, params){" snippet
|
||||
(format "success(String(~a)); };" inspector)
|
||||
"});")])
|
||||
(displayln snippet)
|
||||
(display code op))))))
|
||||
(define (E-single a-statement (inspector "MACHINE.val"))
|
||||
(evaluated-value ((force -E) (cons a-statement inspector))))
|
||||
|
||||
;; evaluating many expressions[.
|
||||
(define -E-many (delay (make-evaluate
|
||||
(lambda (a-statement+inspector op)
|
||||
(let* ([a-statement (car a-statement+inspector)]
|
||||
[inspector (cdr a-statement+inspector)])
|
||||
|
||||
(display "(function() { " op)
|
||||
(display runtime op)
|
||||
|
||||
(display "var myInvoke = " op)
|
||||
(assemble/write-invoke a-statement op)
|
||||
(display ";" op)
|
||||
|
||||
(fprintf op
|
||||
"return function(succ, fail, params) { myInvoke(function(v) { succ(String(~a));}, fail, params); }"
|
||||
inspector)
|
||||
(display "})" op))))))
|
||||
(lambda (a-statement+inspector op)
|
||||
(let* ([a-statement (car a-statement+inspector)]
|
||||
[inspector (cdr a-statement+inspector)])
|
||||
|
||||
(display "(function() { " op)
|
||||
(display runtime op)
|
||||
|
||||
(display "var myInvoke = " op)
|
||||
(assemble/write-invoke a-statement op)
|
||||
(display ";" op)
|
||||
|
||||
(fprintf op
|
||||
"return function(succ, fail, params) { myInvoke(function(v) { succ(String(~a));}, fail, params); }"
|
||||
inspector)
|
||||
(display "})" op))))))
|
||||
(define (E-many stmts (inspector "MACHINE.val"))
|
||||
(evaluated-value ((force -E-many) (cons stmts inspector))))
|
||||
|
||||
|
|
@ -86,12 +86,12 @@
|
|||
"undefined")
|
||||
;; But we should see the assignment if we inspect MACHINE.proc.
|
||||
(test (E-single (make-AssignImmediateStatement 'proc (make-Const "Danny"))
|
||||
"MACHINE.proc")
|
||||
"MACHINE.proc")
|
||||
"Danny")
|
||||
|
||||
|
||||
(test (E-single (make-PushEnvironment 1)
|
||||
"MACHINE.env.length")
|
||||
"MACHINE.env.length")
|
||||
"1")
|
||||
(test (E-single (make-PushEnvironment 20)
|
||||
"MACHINE.env.length")
|
||||
|
|
@ -146,7 +146,7 @@
|
|||
(make-ApplyPrimitiveProcedure 2 'done))
|
||||
'done))
|
||||
"7")
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -175,4 +175,78 @@
|
|||
(list (make-EnvLexicalReference 0)
|
||||
(make-EnvLexicalReference 1)))))
|
||||
"MACHINE.val.closedVals[0] + ',' + MACHINE.val.closedVals[1]")
|
||||
"hello,world")
|
||||
"hello,world")
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(test (E-many `(,(make-AssignImmediateStatement 'val (make-Const 42))
|
||||
,(make-TestAndBranchStatement 'false? 'val 'onFalse)
|
||||
,(make-AssignImmediateStatement 'val (make-Const 'ok))
|
||||
,(make-GotoStatement (make-Label 'end))
|
||||
onFalse
|
||||
,(make-AssignImmediateStatement 'val (make-Const 'not-ok))
|
||||
end))
|
||||
"ok")
|
||||
|
||||
;; TestAndBranch: try the false branch
|
||||
(test (E-many `(,(make-AssignImmediateStatement 'val (make-Const #f))
|
||||
,(make-TestAndBranchStatement 'false? 'val 'onFalse)
|
||||
,(make-AssignImmediateStatement 'val (make-Const 'not-ok))
|
||||
,(make-GotoStatement (make-Label 'end))
|
||||
onFalse
|
||||
,(make-AssignImmediateStatement 'val (make-Const 'ok))
|
||||
end))
|
||||
"ok")
|
||||
|
||||
;; Test for primitive procedure
|
||||
(test (E-many `(,(make-AssignImmediateStatement 'val (make-Const '+))
|
||||
,(make-TestAndBranchStatement 'primitive-procedure? '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! '(+)))
|
||||
,(make-AssignPrimOpStatement 'val (make-LookupToplevelAddress 0 0 '+))
|
||||
,(make-TestAndBranchStatement 'primitive-procedure? 'val 'onTrue)
|
||||
,(make-AssignImmediateStatement 'val (make-Const 'not-ok))
|
||||
,(make-GotoStatement (make-Label 'end))
|
||||
onTrue
|
||||
,(make-AssignImmediateStatement 'val (make-Const 'ok))
|
||||
end))
|
||||
"ok")
|
||||
|
||||
;; Give a primitive procedure in proc, but test val
|
||||
(test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
|
||||
,(make-AssignPrimOpStatement 'proc (make-LookupToplevelAddress 0 0 '+))
|
||||
,(make-TestAndBranchStatement 'primitive-procedure? '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! '(+)))
|
||||
,(make-AssignPrimOpStatement 'proc (make-LookupToplevelAddress 0 0 '+))
|
||||
,(make-TestAndBranchStatement 'primitive-procedure? 'proc 'onTrue)
|
||||
,(make-AssignImmediateStatement 'val (make-Const 'not-a-procedure))
|
||||
,(make-GotoStatement (make-Label 'end))
|
||||
onTrue
|
||||
,(make-AssignImmediateStatement 'val (make-Const 'a-procedure))
|
||||
end))
|
||||
"a-procedure")
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user