trying to make conform work.

compile.rkt

@@ -91,9 +91,7 @@
     [(eq? linkage 'return)
      (make-instruction-sequence `(,(make-AssignPrimOpStatement 'proc
                                                                (make-GetControlStackLabel))
-                                  ,(make-PopEnvironment 
+                                  ,(make-PopEnvironment cenv 0)
-                                    cenv
-                                    0)
                                   ,(make-PopControlFrame)
                                   ,(make-GotoStatement (make-Reg 'proc))))]
     [(eq? linkage 'next)
@@ -332,7 +330,7 @@
        (end-with-compiled-application-linkage 
         compiled-linkage
         extended-cenv
-        (compile-proc-appl extended-cenv n target compiled-linkage))
+        (compile-proc-appl cenv extended-cenv n target compiled-linkage))
        
        primitive-branch
        (end-with-linkage
@@ -351,13 +349,13 @@
 
 
 
-(: compile-proc-appl (Natural Natural Target Linkage -> InstructionSequence))
+(: compile-proc-appl (Natural Natural Natural Target Linkage -> InstructionSequence))
 ;; Three fundamental cases for general compiled-procedure application.
 ;;    1.  Non-tail calls that write to val
 ;;    2.  Calls in argument position that write to the environment
 ;;    3.  Tail calls.
 ;; The Other cases should be excluded.
-(define (compile-proc-appl cenv n target linkage)
+(define (compile-proc-appl cenv-without-args cenv-with-args n target linkage)
   (cond [(and (eq? target 'val)
               (not (eq? linkage 'return)))
          ;; This case happens for a function call that isn't in
@@ -388,16 +386,23 @@
          (make-instruction-sequence
           `(,(make-AssignPrimOpStatement 'val 
                                          (make-GetCompiledProcedureEntry))
-            ,(make-PopEnvironment (ensure-natural (- cenv n))
+            ,(make-PopEnvironment (ensure-natural (- cenv-with-args n))
                                   n)
             ,(make-GotoStatement (make-Reg 'val))))]
         
         [(and (not (eq? target 'val))
               (eq? linkage 'return))
-         ;; This case should be impossible: return linkage should only
+         ;; This case happens for set!, which may install the results of an
-         ;; occur when we're in tail position, and we're in tail position
+         ;; application directly into the environment.
-         ;; only when the target is the val register.
+         (let ([proc-return (make-label 'procReturn)])
-         (error 'compile "return linkage, target not val: ~s" target)]))
+           (end-with-linkage linkage 
+                             cenv-without-args
+                             (make-instruction-sequence
+                              `(,(make-PushControlFrame proc-return)
+                                ,(make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry))
+                                ,(make-GotoStatement (make-Reg 'val))
+                                ,proc-return
+                                ,(make-AssignImmediateStatement target (make-Reg 'val))))))]))
 
 
 (: compile-let1 (Let1 Natural Target Linkage -> InstructionSequence))

tests/conform/program0.sch

@@ -285,11 +285,11 @@
 (define res (lambda (pair) (cdr pair)))
 (define conforms?
   (lambda (t1 t2)
-    (letrec ((nodes-with-red-edges-out (box '()))
+    (letrec ((nodes-with-red-edges-out '())
              (add-red-edge!
               (lambda (from-node to-node)
                 (set-red-edges! from-node (adjoin to-node (red-edges from-node)))
-                (set-box! nodes-with-red-edges-out (adjoin from-node (unbox nodes-with-red-edges-out)))))
+                (set! nodes-with-red-edges-out (adjoin from-node nodes-with-red-edges-out))))
              (greenify-red-edges!
               (lambda (from-node)
                 (set-green-edges! from-node (append (red-edges from-node) (green-edges from-node)))
@@ -323,7 +323,7 @@
                                      loop)
                                    (blue-edges t2))))))))))
       (let ((result (does-conform t1 t2)))
-        (for-each (if result greenify-red-edges! delete-red-edges!) (unbox nodes-with-red-edges-out))
+        (for-each (if result greenify-red-edges! delete-red-edges!) nodes-with-red-edges-out)
         result))))
 (define equivalent? (lambda (a b) (if (conforms? a b) (conforms? b a) '#f)))
 (define classify
@@ -457,23 +457,23 @@
                             (loop new-g new-count)))))))))
       (let ((graph (make-graph (adjoin any-node (adjoin none-node (graph-nodes (clean-graph g)))))))
         (loop graph (length (graph-nodes graph)))))))
-(define a (box '()))
+(define a '())
-(define b (box '()))
+(define b '())
-(define c (box '()))
+(define c '())
-(define d (box '()))
+(define d '())
 (define reset
   (lambda ()
-    (set-box! a (make-node 'a '()))
+    (set! a (make-node 'a '()))
-    (set-box! b (make-node 'b '()))
+    (set! b (make-node 'b '()))
-    (set-blue-edges! (unbox a) (list (make-blue-edge 'phi any-node (unbox b))))
+    (set-blue-edges! a (list (make-blue-edge 'phi any-node b)))
-    (set-blue-edges! (unbox b) (list (make-blue-edge 'phi any-node (unbox a)) (make-blue-edge 'theta any-node (unbox b))))
+    (set-blue-edges! b (list (make-blue-edge 'phi any-node a) (make-blue-edge 'theta any-node b)))
-    (set-box! c (make-node '"c" '()))
+    (set! c (make-node '"c" '()))
-    (set-box! d (make-node '"d" '()))
+    (set! d (make-node '"d" '()))
-    (set-blue-edges! (unbox c) (list (make-blue-edge 'theta any-node (unbox b))))
+    (set-blue-edges! c (list (make-blue-edge 'theta any-node b)))
-    (set-blue-edges! (unbox d) (list (make-blue-edge 'phi any-node (unbox c)) (make-blue-edge 'theta any-node (unbox d))))
+    (set-blue-edges! d (list (make-blue-edge 'phi any-node c) (make-blue-edge 'theta any-node d)))
     '(made a b c d)))
 (define test
-  (lambda () (reset) (map name (graph-nodes (make-lattice (make-graph (list (unbox a) (unbox b) (unbox c) (unbox d) any-node none-node)) '#t)))))
+  (lambda () (reset) (map name (graph-nodes (make-lattice (make-graph (list a b c d any-node none-node)) '#t)))))
 (define go
   (lambda ()
     (reset)