check-toplevel-bound

assemble.rkt

@@ -341,29 +341,16 @@ EOF
 (define (assemble-op-statement op)  
   (cond 
     [(SetToplevel!? op)
-     (error 'assemble-op-statement)
+     (format "MACHINE.env[MACHINE.env.length - 1 - ~a][~a] = MACHINE.val;"
-     #;(let ([depth (first assembled-inputs)]
+             (SetToplevel!-depth op)
-             [pos (second assembled-inputs)]
+             (SetToplevel!-pos op))]
-             [name (third assembled-inputs)]
-             [env (fourth assembled-inputs)]
-             [val (fifth assembled-inputs)])
-         (format "(~a).valss[~a][~a] = ~a;"
-                 env
-                 depth
-                 pos
-                 val))]
     
     [(CheckToplevelBound!? op)
-     (error 'assemble-op-statement)
+     (format "if (MACHINE.env[MACHINE.env.length - 1 - ~a][~a] === undefined) { throw new Error(\"Not bound: \" + ~s); }"
-     #;(let ([depth (first assembled-inputs)]
+             (CheckToplevelBound!-depth op)
-             [pos (second assembled-inputs)]
+             (CheckToplevelBound!-pos op)
-             [name (third assembled-inputs)]
+             (symbol->string (CheckToplevelBound!-name op)))]
-             [env (fourth assembled-inputs)])
+    
-         (format "if ((~a).valss[~a][~a] === undefined) { throw new Error(\"Not bound: \" + ~a); }"
-                 env
-                 depth
-                 pos
-                 name))]
     [(CheckClosureArity!? op)
      ;; fixme
      (error 'assemble-op-statement)]

test-all.rkt

@@ -3,7 +3,7 @@
 (require "test-find-toplevel-variables.rkt"
          "test-simulator.rkt"
          "test-compiler.rkt"
-
+         "test-assemble.rkt"
          #; test-browser-evaluate
          #; test-package
          )

test-assemble.rkt

@@ -20,7 +20,12 @@
        (syntax/loc #'stx
          (begin
            (printf "Running ~s ...\n" (syntax->datum #'expr))
-           (let ([actual expr])
+           (let ([actual 
+                  (with-handlers ([void
+                                   (lambda (exn)
+                                     (raise-syntax-error #f (format "Runtime error: got ~s" exn)
+                                                         #'stx))])
+                    expr)])
              (unless (equal? actual expected)
                (raise-syntax-error #f (format "Expected ~s, got ~s" expected actual)
                                    #'stx))
@@ -247,6 +252,26 @@
 
 
 
+;; Set-toplevel
+(test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(advisor)))
+                ,(make-AssignImmediateStatement 'val (make-Const "Kathi"))
+                ,(make-PerformStatement (make-SetToplevel! 0 0 'some-variable)))
+              "MACHINE.env[0][0]")
+      "Kathi")
 
 
-
+;; check-toplevel-bound
+(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 'some-variable)))))])
+    (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-PerformStatement (make-SetToplevel! 0 0 'some-variable))
+                ,(make-PerformStatement (make-CheckToplevelBound! 0 0 'another-advisor)))
+              "MACHINE.env[0][0]")
+      "Shriram")

test-simulator.rkt

@@ -223,8 +223,6 @@
 
 ;; AssignPrimOpStatement
 (let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+ - * =)))))])
-  ;; FIXME:  I'm hitting what appears to be a Typed Racket bug that prevents me from inspecting
-  ;; the toplevel structure in the environment... :(
   (test (first (machine-env (run m)))
         (make-toplevel (list (lookup-primitive '+)
                              (lookup-primitive '-)