primitive procedure testing

assemble.rkt

@@ -223,11 +223,16 @@ EOF
      (assemble-op-statement (PerformStatement-op stmt))]
     
     [(TestAndBranchStatement? stmt)
-     (error 'assemble-stmt)
+     (let*: ([test : PrimitiveTest (TestAndBranchStatement-op stmt)])
-     #;(format "if(~a){return ~a();}"
+            (cond
-             (assemble-op-expression (TestAndBranchStatement-op stmt)
+              [(eq? test 'false?)
-                                     (list (make-Reg (TestAndBranchStatement-register stmt))))
+               (format "if (! ~a) { return ~a(); }"
-             (assemble-location (make-Label (TestAndBranchStatement-label stmt))))]
+                       (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")]
+     (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"]
-    ))
 
 
 (: assemble-op-statement (PrimitiveCommand -> String))

test-assemble.rkt

@@ -29,39 +29,39 @@
 
 ;; evaluating single expression
 (define -E (delay (make-evaluate
-           (lambda (a-statement+inspector op)
+                   (lambda (a-statement+inspector op)
-             (let* ([a-statement (car a-statement+inspector)]
+                     (let* ([a-statement (car a-statement+inspector)]
-                    [inspector (cdr a-statement+inspector)]
+                            [inspector (cdr a-statement+inspector)]
-                    [snippet (assemble-statement a-statement)]
+                            [snippet (assemble-statement a-statement)]
-                    [code
+                            [code
-                     (string-append
+                             (string-append
-                      "(function() { "
+                              "(function() { "
-                      runtime
+                              runtime
-                      "return function(success, fail, params){" snippet
+                              "return function(success, fail, params){" snippet
-                      (format "success(String(~a)); };" inspector)
+                              (format "success(String(~a)); };" inspector)
-                      "});")])
+                              "});")])
-               (displayln snippet)
+                       (displayln snippet)
-               (display code op))))))
+                       (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)
+                        (lambda (a-statement+inspector op)
-             (let* ([a-statement (car a-statement+inspector)]
+                          (let* ([a-statement (car a-statement+inspector)]
-                    [inspector (cdr a-statement+inspector)])
+                                 [inspector (cdr a-statement+inspector)])
                             
-               (display "(function() { " op)
+                            (display "(function() { " op)
-               (display runtime op)
+                            (display runtime op)
                             
-               (display "var myInvoke = " op)
+                            (display "var myInvoke = " op)
-               (assemble/write-invoke a-statement op)
+                            (assemble/write-invoke a-statement op)
-               (display ";" op)
+                            (display ";" op)
                             
-               (fprintf op 
+                            (fprintf op 
-                        "return function(succ, fail, params) { myInvoke(function(v) { succ(String(~a));}, fail, params); }"
+                                     "return function(succ, fail, params) { myInvoke(function(v) { succ(String(~a));}, fail, params); }"
-                        inspector)
+                                     inspector)
-               (display "})" op))))))
+                            (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")
@@ -176,3 +176,77 @@
                                                                                        (make-EnvLexicalReference 1)))))
               "MACHINE.val.closedVals[0] + ',' + MACHINE.val.closedVals[1]")
       "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")
+
+
+
+
+
+