diff --git a/semantics.rkt b/semantics.rkt index 8e65454..6f4c253 100644 --- a/semantics.rkt +++ b/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)))) diff --git a/tests/eval.rkt b/tests/eval.rkt index 4537d4f..5dbf034 100644 --- a/tests/eval.rkt +++ b/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))