Add unallocated node type

printer.rkt

@@ -114,13 +114,15 @@
 (: ppr-node (-> Node ISeq))
 (define (ppr-node a)
   (cond
-    [(integer? a)
+    [(integer-node? a)
      (iseq-append "NNum " (number->string a))]
-    [(not (eq? (car a) 'define))
+    [(ap-node? a)
-     (let ([fun (first a)]
+     (let ([fun (ap-fun a)]
-           [arg (second a)])
+           [arg (ap-arg a)])
        (iseq-append "NAp " (ppr-addr fun) " " (ppr-addr arg)))]
-    [else (iseq-append "NSupercomb " (symbol->string (caadr a)))]))
+    [(sc-node? a) (iseq-append "NSupercomb " (symbol->string (caadr a)))]
+    [(indirect-node? a) (iseq-append "Indirect " (ppr-addr (indirect-addr a)))]
+    [else (error "Impossible: Undefined node encountered")]))
 
 (: ppr-stack-node (-> Heap Node ISeq))
 (define (ppr-stack-node heap node)

semantics.rkt

@@ -10,10 +10,51 @@
 (define-type Stack (Listof Addr))
 (define-type Dump Null)
 (define-type Heap (TreeListof Node))
-(define-type Node (∪ (List Addr Addr) CoreScDefn Integer))
+(define-type Node (∪ (List Addr Addr) CoreScDefn Integer (List 'Indirect Addr) 'Undef))
 (define-type Globals (Immutable-HashTable Name Addr))
 (define-type Stats Nonnegative-Integer)
 
+
+(: ap-node? (-> Node Boolean : (List Addr Addr)))
+(define (ap-node? a)
+  (and (pair? a) (number? (car a)) (pair? (cdr a)) (null? (cddr a))))
+
+(: undef-node? (-> Any Boolean : 'Undef))
+(define (undef-node? a)
+  (eqv? a 'Undef))
+
+(: indirect-node? (-> Node Boolean : (List 'Indirect Addr)))
+(define (indirect-node? a)
+  (and (pair? a) (eqv? (car a) 'Indirect)))
+
+(: indirect-node (-> Addr (∩ (List 'Indirect Addr) Node)))
+(define (indirect-node a)
+  (list 'Indirect a))
+
+(: integer-node? (-> Node Boolean : Integer))
+(define (integer-node? a)
+  (integer? a))
+
+(: sc-node? (-> Node Boolean : CoreScDefn))
+(define (sc-node? a)
+  (and (pair? a) (eqv? (car a) 'define)))
+
+(: ap-fun (-> (List Addr Addr) Addr))
+(define (ap-fun a)
+  (first a))
+
+(: ap-arg (-> (List Addr Addr) Addr))
+(define (ap-arg a)
+  (second a))
+
+(: match-sc (-> CoreScDefn (Values (Listof Name) CoreExpr)))
+(define (match-sc scdef)
+  (values (cdadr scdef) (caddr scdef)))
+
+(: indirect-addr (-> (List 'Indirect Addr) Addr))
+(define (indirect-addr a)
+  (second a))
+
 (: empty-heap Heap)
 (define empty-heap
   (treelist))
@@ -31,6 +72,10 @@
 (: empty-stack Stack)
 (define empty-stack '())
 
+(: push-addr (-> Stack Addr (Pairof Addr Stack)))
+(define (push-addr st n)
+  (cons n st))
+
 (: incr-stats (-> Stats Stats))
 (define incr-stats add1)
 
@@ -110,11 +155,15 @@
 
 (: step-node (-> Stack State Node State))
 (define (step-node rstack st n)
-  (match n
+  (cond
-    [(? integer?) (error "A number cannot be stepped any further!")]
+    [(integer-node? n) (error "A number cannot be stepped any further!")]
-    [(list a _) (update-stack (λ (x) (cons a x)) st)]
+    [(ap-node? n) (update-stack (λ (stack) (push-addr stack (ap-fun n))) st)]
-    [(list 'define (list name args ...) body)
+    [(undef-node? n) (error "An undefined node is being stepped!")]
-     (step-sc rstack st args body)]))
+    [(sc-node? n)
+     (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)]))
 
 (: get-arg (-> Heap Addr Addr))
 (define (get-arg heap addr)
@@ -138,15 +187,26 @@
 
 (: instantiate-and-allocate (-> CoreExpr Globals Heap (Values Heap Addr)))
 (define (instantiate-and-allocate e env heap)
-  (let ([res (instantiate e env heap)])
+  (let ([res (instantiate-expr e env heap)])
     (cond
       [(number? res)
        (values heap res)]
       [else
        (allocate-node (car res) (cdr res))])))
 
-(: instantiate (-> CoreExpr Globals Heap (∪ Addr (Pair Heap Node))))
+(: instantiate-and-assign (-> CoreExpr Globals Heap Addr Heap))
-(define (instantiate e env heap)
+(define (instantiate-and-assign e env heap addr)
+  (let ([res (instantiate-expr e env heap)])
+    (cond
+      [(number? res)
+       (update-heap heap addr (list 'Indirect res))]
+      [else
+       (let ([heap (car res)]
+             [node (cdr res)])
+         (update-heap heap addr node))])))
+
+(: instantiate-expr (-> CoreExpr Globals Heap (∪ Addr (Pair Heap Node))))
+(define (instantiate-expr e env heap)
   (match e
     [(? integer?) (cons heap e)]
     [(list f a)
@@ -156,9 +216,36 @@
     [(? symbol?) (lookup-globals env e)]
     [(list 'let binds e)
      (let-values ([(env heap) (instantiate-binds binds env heap)])
-       (instantiate e 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")]))
 
+(: instantiate-rec-binds (-> CoreBinds Globals Heap (Values Globals Heap)))
+(define (instantiate-rec-binds binds env heap)
+  (let-values ([(addrs env heap)
+                (for/fold
+                    ([addrs : (Listof Addr) '()]
+                     [env : Globals env]
+                     [heap : Heap heap])
+                    ([bind : CoreBind binds])
+                  (let-values ([(heap addr) (allocate-node heap 'Undef)])
+                    (values (cons addr addrs) (update-globals env (first bind) addr) heap)))])
+    (values env (for/fold
+        ([heap : Heap heap])
+        ([bind : CoreBind binds]
+         [addr : Addr (reverse addrs)])
+                  (instantiate-rec-bind addr bind env heap)))))
+
+(: instantiate-rec-bind (-> Addr CoreBind Globals Heap Heap))
+(define (instantiate-rec-bind addr bind env heap)
+  (let ([x (first bind)]
+        [e (second bind)])
+    (let ([heap (instantiate-and-assign e env heap addr)])
+      heap)))
+
 (: instantiate-binds (-> CoreBinds Globals Heap (Values Globals Heap)))
 (define (instantiate-binds binds old-env heap)
   (for/fold
@@ -175,5 +262,19 @@
       (values (update-globals new-env x addr) heap))))
 
 
+(define-type Unallocated-Node (Pair 'Unallocated Node))
+
+(: unallocated-node-get (-> Unallocated-Node Node))
+(define (unallocated-node-get a)
+  (cdr a))
+
+(: unallocated-node? (-> (∪ Addr Unallocated-Node) Boolean : Unallocated-Node))
+(define (unallocated-node? a)
+  (pair? a))
+
+(: unallocated-node (-> Node Unallocated-Node))
+(define (unallocated-node a)
+  (cons 'Unallocated a))
+
 
 (provide (all-defined-out))

tests/eval.rkt

@@ -31,3 +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)