Struggling here a bit, removing env from cps until scope issues are fixed

scmvm/language/scheme.scm

@@ -75,8 +75,8 @@
 
 ;; Desugaring
 ;; Transforms to simplify the language
-;; - lambdas and lets can only have 1 expression in body position
-;; - defines are decomposed to lets that bind their values and wrap their continuations
+;; - lambdas, lets and letrecs can only have 1 expression in body position
+;; - defines are decomposed to letrecs that bind their values and wrap their continuations
 ;; <prgm> ::= <exp> ...
 ;; <exp>  ::= (lambda (<var> ...) <exp>)
 ;;          | (if <exp> <exp> <exp>)
@@ -96,9 +96,9 @@
 (define (desugar-define def cont)
   (match def
     [`(define ,(name params ...) . ,e*)
-     `(letrec ([,name ,(desugar-exp `(lambda ,params ,@e*))]) ,@(desugar-top cont))]
+     `(letrec ([,name ,(desugar-exp `(lambda ,params ,@e*))]) (begin ,@(desugar-top cont)))]
     [`(define ,name ,exp)
-     `(letrec ([,name ,(desugar-exp exp)]) ,@(desugar-top cont))]))
+     `(letrec ([,name ,(desugar-exp exp)]) (begin ,@(desugar-top cont)))]))
 
 (define (desugar-exp exp)
   (match exp
@@ -155,82 +155,76 @@
 (define (ref-uniq r v*)
   (map (lambda (n) (cdr (environment-assq r n))) v*))
 
-(define (M expr r)
+(define (M expr)
   ;; M dispatches to the appropriate transformer
   ;; expr -> aexp
   (match expr
     [('lambda (v* ...) e)
-     (let ([$k (gensym "$k-")]
-           [r0 (extend-uniq r v*)])
-       `(lambda (,@(ref-uniq r0 v*) ,$k) ,(T-c e $k r0)))]
+     (let ([$k (gensym "$k-")])
+       `(lambda (,@v* ,$k) ,(T-c e $k)))]
     [(? primitive?) `(cps-prim ,expr)]
-    [(? symbol?) (cdr (environment-assq r expr))]
+    [(? symbol?) expr]
     [(? atomic?) expr]))
 
-(define (T-c expr c r)
+(define (T-c expr c)
   ;; T-c takes a symbolic continuation, and uses it to construct CPS
   ;; (expr * aexp) -> cexp
   (match expr
-    [`(lambda . ,_) `(,c ,(M expr r))]
-    [ (? atomic?)   `(,c ,(M expr r))]
-    [ ('define v e)
-      (let ([r0 (extend-uniq r (list v))])
-        (T-k e (lambda ($e) `(letrec ([,@(ref-uniq r0 (list v)) ,$e]) ,c)) r0))]
-    [ ('begin e) (T-c e c r)]
+    [`(lambda . ,_) `(,c ,(M expr))]
+    [ (? atomic?)   `(,c ,(M expr))]
+    [ ('letrec ([v e]) body)
+      (T-k e (lambda ($e)
+               (T-k body (lambda ($body) `(letrec ([,v ,$e]) (,c ,$body))))))]
+    [ ('begin e) (T-c e c)]
     [ ('begin e e* ...)
       (T-k e (lambda _
-               (T-c `(begin ,@e*) c r)) r)]
+               (T-c `(begin ,@e*) c)))]
     [ ('let ([v* e*] ...) body)
-      (let ([r0 (extend-uniq r v*)])
-        (T-c `((lambda (,@(ref-uniq r0 v*)) ,body) ,@e*) c r0))]
+      (T-c `((lambda (,@v*) ,body) ,@e*) c)]
     [ ('if exp1 exp2 exp3)
       (let ([$k (gensym "$k-")]) ;; Bind cont to avoid blow up
         `((lambda (,$k)
             ,(T-k exp1 (lambda (aexp)
                          `(if ,aexp
-                              ,(T-c exp2 $k r)
-                              ,(T-c exp3 $k r))) r))
+                              ,(T-c exp2 $k)
+                              ,(T-c exp3 $k)))))
           ,c))]
     [ ('set! var expr)
       (T-k expr (lambda ($expr)
-                  `(set-then! ,var ,$expr (,c ,undefined-value))) r)]
+                  `(set-then! ,var ,$expr (,c ,undefined-value))))]
     [ (f e* ...)
       (T-k f (lambda ($f)
 	       (T*-k e* (lambda ($e*)
-			  `(,$f ,@$e* ,c)) r)) r)]))
+			  `(,$f ,@$e* ,c)))))]))
 
-(define (T-k expr k r)
+(define (T-k expr k)
   ;; T-k takes an explicit continuation and calls it when done
   ;; As an invariant, T-k cannot nest a T-c call directly
   ;; (expr * (aexp -> cexp) -> cexp)
   (match expr
-    [`(lambda . ,_) (k (M expr r))]
-    [(? atomic?)   (k (M expr r))]
-    [('define v e)
-     (let ([r0 (extend-uniq r (list v))])
+    [`(lambda . ,_) (k (M expr))]
+    [(? atomic?)   (k (M expr))]
+    [('letrec ([v e]) body)
      (T-k e
-            (lambda ($e) `(letrec ([,@(ref-uniq r0 (list v)) ,$e]) ,(k)))
-            r0))]
-    [('begin e) (T-k e k r)]
+          (lambda ($e)
+            (T-k body
+                 (lambda ($body) `(letrec ([,v ,$e]) ,(k $body))))))]
+    [('begin e) (T-k e k)]
     [('begin e e* ...)
      (T-k e
           (lambda _
-            (T-k `(begin ,@e*) k r))
-          r)]
+            (T-k `(begin ,@e*) k)))]
     [('let ([v* e*] ...) body)
-     (let ([r0 (extend-uniq r v*)])
-       (T-k `((lambda (,@(ref-uniq r0 v*)) ,body) ,@e*) k r0))]
+     (T-k `((lambda (,@v*) ,body) ,@e*) k)]
     [('if exp1 exp2 exp3)
      (T-k exp1
           (lambda ($exp1)
             `(if ,$exp1
-                 ,(T-k exp2 k r)
-                 ,(T-k exp3 k r)))
-          r)]
+                 ,(T-k exp2 k)
+                 ,(T-k exp3 k))))]
     [('set! var expr)
      (T-k expr (lambda ($expr)
-                 `(set-then! ,var ,$expr ,(k undefined-value)))
-          r)]
+                 `(set-then! ,var ,$expr ,(k undefined-value))))]
     [(f e* ...)
      (let* ([$rv (gensym "$rv-")]
 	    [cont `(lambda (,$rv) ,(k $rv))])
@@ -238,24 +232,18 @@
             (lambda ($f)
 	      (T*-k e*
                     (lambda ($e*)
-		      `(,$f ,@$e* ,cont))
-                    r))
-            r))]))
+		      `(,$f ,@$e* ,cont))))))]))
 
 ;; (expr* * (aexp* -> cexp) -> cexp)
-(define (T*-k v* k r)
+(define (T*-k v* k)
   (if (null? v*)
       (k '())
       (T-k (car v*)
            (lambda (t) (T*-k (cdr v*)
-                             (lambda (t*) (k (cons t t*)))
-                             r))
-           r)))
-
+                             (lambda (t*) (k (cons t t*))))))))
 
 (define (cps-convert-prgm prgm tail)
-  (let ([r (make-environment)])
-    (T-c `(begin ,@prgm) tail (environment-extend r (list (cons tail tail))))))
+  (T-c prgm tail))
 
 (define* (ir-convert prgm #:optional (tail 'ktail))
   (cps-convert-prgm (desugar-top prgm) tail))