Minor

semantics.rkt

@@ -34,6 +34,17 @@
 (: incr-stats (-> Stats Stats))
 (define incr-stats add1)
 
+(: update-heap-undef (-> Heap Addr Node Heap))
+(define (update-heap-undef heap addr node)
+  (if (eq? (treelist-ref heap addr) 'Undef)
+      (update-heap heap addr node)
+      (error "Address in heap is not undefined")))
+
+(: update-heap (-> Heap Addr Node Heap))
+(define (update-heap heap addr node)
+  (treelist-set heap addr node))
+
+
 (: update-globals (-> Globals Name Addr Globals))
 (define (update-globals globals name addr)
   (hash-set globals name addr))
@@ -121,18 +132,21 @@
                     (if (null? stack)
                         (error "Not enough arguments to apply the supercombinator")
                         (values (update-globals globals arg-name (get-arg heap (car stack))) (cdr stack))))]
-                  [(new-heap addr) (instantiate-body body new-env heap)])
+                  [(heap node) (instantiate-body body new-env heap)]
+                  [(heap addr) (allocate-node heap node)])
       (let ([new-stack (cons addr new-stack)])
-        (struct-copy State state [stack new-stack] [heap new-heap])))))
+        (struct-copy State state [stack new-stack] [heap heap])))))
 
-(: instantiate-body (-> CoreExpr Globals Heap (Values Heap Addr)))
+(: instantiate-body (-> CoreExpr Globals Heap (∪ Addr (-> Addr Heap))))
 (define (instantiate-body e env heap)
   (match e
-    [(? integer?) (allocate-node heap e)]
+    [(? integer?) (λ (x : Addr) (update-heap-undef heap x e))]
     [(list f a)
-     (let*-values ([(heap0 addr-f) (instantiate-body f env heap)]
-                   [(heap1 addr-a) (instantiate-body a env heap0)])
-       (allocate-node heap1 (list addr-f addr-a)))]
+     (let*-values ([(heap node0) (instantiate-body f env heap)]
+                   [(heap node1) (instantiate-body a env heap)]
+                   [(heap addr-f) (allocate-node heap node0)]
+                   [(heap addr-a) (allocate-node heap node1)])
+       (allocate-node heap (list addr-f addr-a)))]
     [(? symbol?) (values heap (lookup-globals env e))]
     [(list 'let binds e)
      (let-values ([(env heap) (instantiate-binds binds env heap)])
@@ -151,7 +165,8 @@
 (define (instantiate-bind bind old-env new-env heap)
   (let ([x (first bind)]
         [e (second bind)])
-    (let-values ([(heap addr) (instantiate-body e old-env heap)])
+    (let*-values ([(heap node) (instantiate-body e old-env heap)]
+                  [(heap addr) (allocate-node heap node)])
       (values (update-globals new-env x addr) heap))))
 
 

tests/eval.rkt

@@ -1,6 +1,7 @@
 #lang typed/racket
 (require "../semantics.rkt")
 (require "../ast.rkt")
+(require "../printer.rkt")
 (require typed/rackunit)
 
 (: exp->program (-> CoreExpr CoreProgram))