still trying to figure out why the lexical scoping is breaking up

simulator-helpers.rkt

@@ -1,9 +1,97 @@
 #lang racket/base
 
 (require "simulator-structs.rkt")
-(provide ensure-primitive-value-box)
+(provide ensure-primitive-value-box
+         ensure-primitive-value
+         PrimitiveValue->racket
+         racket->PrimitiveValue)
 (define (ensure-primitive-value-box x)
   (if (and (box? x)
            (PrimitiveValue? (unbox x)))
       x
       (error 'ensure-primitive-value-box "~s" x)))
+
+
+
+;; Make sure the value is primitive.
+(define (ensure-primitive-value val)
+  (let loop ([v val])
+    (cond
+      [(string? v)
+       v]
+      [(symbol? v)
+       v]
+      [(number? v)
+       v]
+      [(boolean? v)
+       v]
+      [(null? v)
+       v]
+      [(void? v)
+       v]
+      [(MutablePair? v)
+       v]
+      [(primitive-proc? v)
+       v]
+      [(closure? v)
+       v]
+      [(undefined? v)
+       v]
+      [(vector? v)
+       v]
+      [else
+       (error 'ensure-primitive-value "~s" v)])))
+
+
+
+(define (PrimitiveValue->racket v)
+  (cond
+    [(string? v)
+     v]
+    [(number? v)
+     v]
+    [(symbol? v)
+     v]
+    [(boolean? v)
+     v]
+    [(null? v)
+     v]
+    [(void? v)
+     v]
+    [(undefined? v)
+     (letrec ([x x]) x)]
+    [(primitive-proc? v)
+     v]
+    [(closure? v)
+     v]
+    [(vector? v)
+     (apply vector (map PrimitiveValue->racket (vector->list v)))]
+    [(MutablePair? v)
+     (cons (PrimitiveValue->racket (MutablePair-h v))
+           (PrimitiveValue->racket (MutablePair-t v)))]))
+
+
+(define (racket->PrimitiveValue v)
+  (cond
+    [(string? v)
+     v]
+    [(number? v)
+     v]
+    [(symbol? v)
+     v]
+    [(boolean? v)
+     v]
+    [(null? v)
+     v]
+    [(void? v)
+     v]
+    [(eq? v (letrec ([x x]) x))
+     (make-undefined)]
+    [(procedure? v)
+     (error 'racket->PrimitiveValue "Can't coerse procedure")]
+    [(vector? v)
+     (apply vector (map racket->PrimitiveValue (vector->list v)))]
+    [(pair? v)
+     (make-MutablePair (racket->PrimitiveValue (car v))
+                       (racket->PrimitiveValue (cdr v)))]))
+

simulator-primitives.rkt

@@ -4,8 +4,7 @@
          racket/math
          (for-syntax racket/base))
 
-(provide lookup-primitive
+(provide lookup-primitive)
-         PrimitiveValue->racket)
 
 
 (define-syntax (make-lookup stx)
@@ -82,7 +81,7 @@
                                                      display
                                                      displayln
                                                      newline
-                                                     
+                                                     symbol->string
                                                      
                                                      (my-cons cons)
                                                      (my-list list)
@@ -96,29 +95,3 @@
                                                         call-with-current-continuation)))
 
 
-
-(define (PrimitiveValue->racket v)
-  (cond
-    [(string? v)
-     v]
-    [(number? v)
-     v]
-    [(symbol? v)
-     v]
-    [(boolean? v)
-     v]
-    [(null? v)
-     v]
-    [(void? v)
-     v]
-    [(undefined? v)
-     (letrec ([x x]) x)]
-    [(primitive-proc? v)
-     v]
-    [(closure? v)
-     v]
-    [(vector? v)
-     (apply vector (map PrimitiveValue->racket (vector->list v)))]
-    [(MutablePair? v)
-     (cons (PrimitiveValue->racket (MutablePair-h v))
-           (PrimitiveValue->racket (MutablePair-t v)))]))

simulator.rkt

@@ -15,8 +15,10 @@
                [lookup-primitive (Symbol -> PrimitiveValue)])
 
 (require/typed "simulator-helpers.rkt"
-               [ensure-primitive-value-box (Any -> (Boxof PrimitiveValue))])
+               [ensure-primitive-value-box (SlotValue -> (Boxof PrimitiveValue))]
-
+               [ensure-primitive-value (SlotValue -> PrimitiveValue)]
+               [racket->PrimitiveValue (Any -> PrimitiveValue)])
+             
 
 (provide new-machine can-step? step! current-instruction
          current-simulated-output-port
@@ -296,7 +298,7 @@
 (define (evaluate-oparg m an-oparg)
   (cond
     [(Const? an-oparg)
-     (ensure-primitive-value (Const-const an-oparg))]
+     (racket->PrimitiveValue (Const-const an-oparg))]
     
     [(Label? an-oparg)
      (Label-name an-oparg)]
@@ -351,35 +353,6 @@
       (error 'ensure-closure)))
 
 
-(: 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]
-          [(void? v)
-           v]
-          [(cons? v)
-           (make-MutablePair (loop (car v)) (loop (cdr v)))]
-          [(MutablePair? v)
-           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.

test-compiler.rkt

@@ -2,7 +2,7 @@
 
 (require "simulator.rkt"
          "simulator-structs.rkt"
-         "simulator-primitives.rkt"
+         "simulator-helpers.rkt"
          "compile.rkt"
          "parse.rkt")
 

test-conform.rkt

@@ -19,7 +19,8 @@
   (let loop ([steps 0])
     (when debug?
       (when (can-step? m)
-        (printf "|env|=~s, |control|=~s,  instruction=~s\n" 
+        (printf "pc=~s, |env|=~s, |control|=~s,  instruction=~s\n" 
+                (machine-pc m)
                 (length (machine-env m))
                 (length (machine-control m))
                 (current-instruction m))))
@@ -61,6 +62,7 @@
                                    #'stx))
              (printf "ok. ~s steps.\n\n" num-steps)))))]))
 
+(current-simulated-output-port (current-output-port))
 
 (test (read (open-input-file "tests/conform/program0.sch"))
       (port->string (open-input-file "tests/conform/expected0.txt"))

tests/conform/program0.sch

@@ -87,6 +87,10 @@
 (define set-internal-node-blue-edges! (lambda (node edges) (vector-set! node '3 edges)))
 (define make-node
   (lambda (name blue-edges)
+    (displayln "name:")
+    (displayln name)
+    (displayln "blue-edges:")
+    (displayln blue-edges)
     (let ((name (if (symbol? name) (symbol->string name) name))
           (blue-edges (if (null? blue-edges) 'NOT-A-NODE-YET (car blue-edges))))
       (make-internal-node name '() '() blue-edges))))
@@ -211,7 +215,12 @@
        (map (lambda (class) (fix (car class))) classes)
        (fix-table (already-met graph))
        (fix-table (already-joined graph))))))
+
+
+(displayln 'here)
+
 (define none-node (make-node 'none '(#t)))
+(displayln 'here5)
 (define none-node? (lambda (node) (eq? node none-node)))
 (define any-node (make-node 'any ('())))
 (define any-node? (lambda (node) (eq? node any-node)))
@@ -229,6 +238,7 @@
         (if (none-node? from-node)
             (begin '#t)
             (if (memq to-node (red-edges from-node)) (begin '#t) (begin '#f))))))
+(displayln 'here4)
 (define sig
   (let ((none-comma-any (cons none-node any-node)))
     (lambda (op node)
@@ -236,6 +246,7 @@
         (if (not (null? the-edge)) (cons (arg-node the-edge) (res-node the-edge)) none-comma-any)))))
 (define arg (lambda (pair) (car pair)))
 (define res (lambda (pair) (cdr pair)))
+(displayln 'here3)
 (define conforms?
   (lambda (t1 t2)
     (letrec ((nodes-with-red-edges-out '())
@@ -327,6 +338,11 @@
 (define blue-edge-operate
   (lambda (arg-fn res-fn graph op sig1 sig2)
     (make-blue-edge op (arg-fn graph (arg sig1) (arg sig2)) (res-fn graph (res sig1) (res sig2)))))
+
+
+(displayln 'here2)
+
+
 (define meet
   (lambda (graph node1 node2)
     (if (eq? node1 node2)
@@ -462,4 +478,4 @@
       (newline))))
 
 
-(void ((letrec ((loop (lambda (n) (if (zero? n) 'done (begin (go) (loop (- n '1))))))) loop) '10)))
+#;(void ((letrec ((loop (lambda (n) (if (zero? n) 'done (begin (go) (loop (- n '1))))))) loop) '10)))