changed the allowed set of primitives so we typecheck a bit better. Added chekc-toplevel-bound

simulator-prims.rkt

@@ -23,7 +23,7 @@
                 cname]
                ...
                [else
-                (void)]
+                (make-undefined)]
                )))))]))
 
 

simulator-structs.rkt

@@ -5,9 +5,19 @@
 (require "il-structs.rkt")
 
 
-(define-struct: machine ([val : Any]
+(define-type PrimitiveValue (Rec PrimitiveValue (U String Number Symbol Boolean Null
-                         [proc : Any]
+                                                   primitive-proc 
-                         [env : (Listof Any)]
+                                                   closure
+                                                   undefined
+                                                   (Pairof PrimitiveValue PrimitiveValue)
+                                                   )))
+(define-type SlotValue (U PrimitiveValue toplevel))
+
+
+
+(define-struct: machine ([val : SlotValue]
+                         [proc : SlotValue]
+                         [env : (Listof SlotValue)]
                          [control : (Listof frame)]
 
                          [pc : Natural]                  ;; program counter
@@ -25,11 +35,18 @@
   #:transparent)
 
 
+
+
+
 ;; Primitive procedure wrapper
-(define-struct: primitive-proc ([f : (Any * -> Any)])
+(define-struct: primitive-proc ([f : (PrimitiveValue * -> PrimitiveValue)])
   #:transparent)
 
 ;; Compiled procedure closures
 (define-struct: closure ([label : Symbol]
-                         [vals : (Listof Any)])
+                         [vals : (Listof SlotValue)])
   #:transparent)
+
+;; undefined value
+(define-struct: undefined ()
+  #:transparent)

simulator.rkt

@@ -20,7 +20,7 @@
 
 (: new-machine ((Listof Statement) -> machine))
 (define (new-machine program-text)
-  (make-machine (void) (void) '() '() 0 (list->vector program-text)))
+  (make-machine (make-undefined) (make-undefined) '() '() 0 (list->vector program-text)))
 
 
 (: can-step? (machine -> Boolean))
@@ -75,7 +75,7 @@
 (: step-assign-immediate (machine AssignImmediateStatement -> machine))
 (define (step-assign-immediate m stmt)
   (let: ([t : Target (AssignImmediateStatement-target stmt)]
-         [v : Any (evaluate-oparg m (AssignImmediateStatement-value stmt))])
+         [v : SlotValue (evaluate-oparg m (AssignImmediateStatement-value stmt))])
         (cond [(eq? t 'proc)
                (proc-update m v)]
               [(eq? t 'val)
@@ -92,7 +92,7 @@
       [(= n 0)
        m]
       [else
-       (loop (env-push m (void))
+       (loop (env-push m (make-undefined))
              (sub1 n))])))
 
 (: step-pop-environment (machine PopEnvironment -> machine))
@@ -146,7 +146,13 @@
                                         
                                         (machine-val m)))]
           [(CheckToplevelBound!? op)
-           (error 'step-perform)]
+           (let: ([a-top : toplevel (ensure-toplevel (env-ref m (CheckToplevelBound!-depth op)))])
+                 (cond
+                   [(undefined? (list-ref (toplevel-vals a-top) (CheckToplevelBound!-pos op)))
+                    (error 'check-toplevel-bound! "Unbound identifier ~s" (CheckToplevelBound!-name op))]
+                   [else
+                    m]))]
+
           [(ExtendEnvironment/Prefix!? op)
            (env-push m 
                      (make-toplevel (map lookup-primitive 
@@ -157,11 +163,11 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 
-(: evaluate-oparg (machine OpArg -> Any))
+(: evaluate-oparg (machine OpArg -> SlotValue))
 (define (evaluate-oparg m an-oparg)
   (cond
     [(Const? an-oparg)
-     (Const-const an-oparg)]
+     (ensure-primitive-value (Const-const an-oparg))]
     [(Label? an-oparg)
      (Label-name an-oparg)]
     [(Reg? an-oparg)
@@ -174,10 +180,39 @@
     [(EnvLexicalReference? an-oparg)
      (list-ref (machine-env m) (EnvLexicalReference-depth an-oparg))]
     [(EnvWholePrefixReference? an-oparg)
-     ;; TODO: check that the value is a prefix value.
+     (unless (toplevel? (list-ref (machine-env m)
+                                  (EnvWholePrefixReference-depth an-oparg)))
+       (error 'evaluate-oparg "Internal error: not a toplevel at depth ~s"
+              (EnvWholePrefixReference-depth an-oparg)))
      (list-ref (machine-env m) (EnvWholePrefixReference-depth an-oparg))]))
 
 
+(: ensure-primitive-value (Any -> PrimitiveValue))
+;; Make sure the value is primitive.
+(define (ensure-primitive-value val)
+  (let: loop : PrimitiveValue ([v : Any val])
+        (cond
+          [(string? v)
+           v]
+          [(symbol? v)
+           v]
+          [(number? v)
+           v]
+          [(boolean? v)
+           v]
+          [(null? v)
+           v]
+          [(cons? v)
+           (cons (loop (car v)) (loop (cdr v)))]
+          [(primitive-proc? v)
+           v]
+          [(closure? v)
+           v]
+          [(undefined? v)
+           v]
+          [else
+           (error 'ensure-primitive-value "Unable to coerse Const ~s to a primitive value" v)])))
+
 (: ensure-symbol (Any -> Symbol))
 ;; Make sure the value is a symbol.
 (define (ensure-symbol v)
@@ -205,19 +240,19 @@
 
   
 
-(: val-update (machine Any -> machine))
+(: val-update (machine SlotValue -> machine))
 (define (val-update m v)
   (match m
     [(struct machine (val proc env control pc text))
      (make-machine v proc env control pc text)]))
 
-(: proc-update (machine Any -> machine))
+(: proc-update (machine SlotValue -> machine))
 (define (proc-update m v)
     (match m
     [(struct machine (val proc env control pc text))
      (make-machine val v env control pc text)]))
 
-(: env-push (machine Any -> machine))
+(: env-push (machine SlotValue -> machine))
 (define (env-push m v)
   (match m
     [(struct machine (val proc env control pc text))
@@ -229,7 +264,7 @@
     [(struct machine (val proc env control pc text))
      (list-ref env i)]))
 
-(: env-mutate (machine Natural Any -> machine))
+(: env-mutate (machine Natural SlotValue -> machine))
 (define (env-mutate m i v)
   (match m
     [(struct machine (val proc env control pc text))

test-simulator.rkt

@@ -47,12 +47,12 @@
 
 ;; Assigning to val
 (let ([m (new-machine `(,(make-AssignImmediateStatement 'val (make-Const 42))))])
-  (test (machine-val m) (void))
+  (test (machine-val m) (make-undefined))
   (test (machine-val (step m)) 42))
 
 ;; Assigning to proc
 (let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const 42))))])
-  (test (machine-proc m) (void))
+  (test (machine-proc m) (make-undefined))
   (test (machine-proc (step m)) 42))
 
 
@@ -67,19 +67,19 @@
 (let* ([m (new-machine `(,(make-PushEnvironment 2)
                          ,(make-AssignImmediateStatement (make-EnvLexicalReference 1) (make-Const 42))))]
        [m (run m)])
-  (test (machine-env m) `(,(void) 42)))
+  (test (machine-env m) `(,(make-undefined) 42)))
 
 
 ;; Assigning to another environment reference
 (let* ([m (new-machine `(,(make-PushEnvironment 2)
                          ,(make-AssignImmediateStatement (make-EnvLexicalReference 0) (make-Const 42))))]
        [m (run m)])
-  (test (machine-env m) `(42 ,(void))))
+  (test (machine-env m) `(42 ,(make-undefined))))
 
 
 ;; PushEnv
 (let ([m (new-machine `(,(make-PushEnvironment 20)))])
-  (test (machine-env (run m)) (build-list 20 (lambda (i) (void)))))
+  (test (machine-env (run m)) (build-list 20 (lambda (i) (make-undefined)))))
 
 
 ;; PopEnv
@@ -233,14 +233,14 @@
 (let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(some-variable)))
                         ,(make-AssignImmediateStatement 'val (make-Const "Danny"))
                         ,(make-PerformStatement (make-SetToplevel! 0 0 'some-variable))))])
-  (run m)
+  (void (run m))
   ;; FIXME:  I'm hitting what appears to be a Typed Racket bug that prevents me from inspecting
   ;; the toplevel structure in the environment... :(
   )
 (let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(some-variable another)))
                         ,(make-AssignImmediateStatement 'val (make-Const "Danny"))
                         ,(make-PerformStatement (make-SetToplevel! 0 1 'another))))])
-  (run m)
+  (void (run m))
   ;; FIXME:  I'm hitting what appears to be a Typed Racket bug that prevents me from inspecting
   ;; the toplevel structure in the environment... :(
   )
@@ -248,7 +248,29 @@
                         ,(make-AssignImmediateStatement 'val (make-Const "Danny"))
                         ,(make-PushEnvironment 5)
                         ,(make-PerformStatement (make-SetToplevel! 5 0 'some-variable))))])
-  (run m)
+  (void (run m))
   ;; FIXME:  I'm hitting what appears to be a Typed Racket bug that prevents me from inspecting
   ;; the toplevel structure in the environment... :(
   )
+
+
+
+
+
+;; check-toplevel-bound
+;; This should produce an error.
+(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(some-variable)))
+                        ,(make-PerformStatement (make-CheckToplevelBound! 0 0 'some-variable))))])
+  (with-handlers ((exn:fail? (lambda (exn)
+                               (void))))
+    
+    (run m)
+    (raise "I expected an error")))
+
+;; check-toplevel-bound shouldn't fail here.
+(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(some-variable)))
+                        ,(make-AssignImmediateStatement 'val (make-Const "Danny"))
+                        ,(make-PerformStatement (make-SetToplevel! 0 0 'some-variable))
+                        ,(make-PerformStatement (make-CheckToplevelBound! 0 0 'some-variable))))])
+  (void (run m)))
+