diff --git a/assemble.rkt b/assemble.rkt index 5fe6cb6..09df986 100644 --- a/assemble.rkt +++ b/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)) diff --git a/test-assemble.rkt b/test-assemble.rkt index 38a810f..3cbc088 100644 --- a/test-assemble.rkt +++ b/test-assemble.rkt @@ -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") \ No newline at end of file + "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") + + + + + +