Fix letrec

semantics.rkt

@@ -163,7 +163,7 @@
      (let-values ([(args body) (match-sc n)])
        (step-sc rstack st args body))]
     [(indirect-node? n)
-     (update-stack (λ (stack) (push-addr stack (indirect-addr n))) st)]))
+     (update-stack (λ (_) (push-addr rstack (indirect-addr n))) st)]))
 
 (: get-arg (-> Heap Addr Addr))
 (define (get-arg heap addr)
@@ -187,39 +187,36 @@
 
 (: instantiate-and-allocate (-> CoreExpr Globals Heap (Values Heap Addr)))
 (define (instantiate-and-allocate e env heap)
-  (let ([res (instantiate-expr e env heap)])
+  (let-values ([(heap addr-or-node) (instantiate-expr e env heap)])
     (cond
-      [(number? res)
-       (values heap res)]
+      [(allocated-addr? addr-or-node)
+       (values heap addr-or-node)]
       [else
-       (allocate-node (car res) (cdr res))])))
+       (allocate-node heap (unallocated-node-get addr-or-node))])))
 
 (: instantiate-and-assign (-> CoreExpr Globals Heap Addr Heap))
 (define (instantiate-and-assign e env heap addr)
-  (let ([res (instantiate-expr e env heap)])
+  (let-values ([(heap addr-or-node) (instantiate-expr e env heap)])
     (cond
-      [(number? res)
-       (update-heap heap addr (list 'Indirect res))]
+      [(allocated-addr? addr-or-node)
+       (update-heap heap addr (indirect-node addr-or-node))]
       [else
-       (let ([heap (car res)]
-             [node (cdr res)])
-         (update-heap heap addr node))])))
+       (update-heap heap addr (unallocated-node-get addr-or-node))])))
 
-(: instantiate-expr (-> CoreExpr Globals Heap (∪ Addr (Pair Heap Node))))
+(: instantiate-expr (-> CoreExpr Globals Heap (Values Heap (∪ Addr Unallocated-Node))))
 (define (instantiate-expr e env heap)
   (match e
-    [(? integer?) (cons heap e)]
+    [(? integer?) (values heap (unallocated-node e))]
     [(list f a)
      (let*-values ([(heap addr-f) (instantiate-and-allocate f env heap)]
                    [(heap addr-a) (instantiate-and-allocate a env heap)])
-       (cons heap (list addr-f addr-a)))]
-    [(? symbol?) (lookup-globals env e)]
+       (values heap (unallocated-node (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)])
        (instantiate-expr e env heap))]
     [(list 'letrec binds e)
      (let-values ([(env heap) (instantiate-rec-binds binds env heap)])
-       (print heap)
        (instantiate-expr e env heap))]
     [_ (error "unimplemented")]))
 
@@ -272,9 +269,12 @@
 (define (unallocated-node? a)
   (pair? a))
 
+(: allocated-addr? (-> (∪ Addr Unallocated-Node) Boolean : Addr))
+(define (allocated-addr? a)
+  (number? a))
+
 (: unallocated-node (-> Node Unallocated-Node))
 (define (unallocated-node a)
   (cons 'Unallocated a))
 
-
 (provide (all-defined-out))

tests/eval.rkt

@@ -31,4 +31,4 @@
 (check-equal? (exp-final-node (ap-exp 'K 100 99)) 100)
 (check-equal? (exp-final-node `(let ((x ,(ap-exp 'S 'K 'K 3)) (y 5)) ,(ap-exp 'K 'x 'x))) 3)
 (check-equal? (exp-final-node `(let ((x ,(ap-exp 'S 'K 'K 3)) (y 5)) ,(ap-exp 'K 'y 'x))) 5)
-;; (check-equal? (exp-final-node `(letrec ((y x) (x ,(ap-exp 'S 'K 'K 3))) ,(ap-exp 'K 'y 'x))) 5)
+(check-equal? (exp-final-node `(letrec ((y x) (x ,(ap-exp 'S 'K 'K 3))) ,(ap-exp 'K 'y 'x))) 3)