Put a lid on the T-k issues

scmvm/language/scheme.scm

@@ -111,7 +111,7 @@
    [(define? (car prgm))
     (let-values ([(bindings cont) (collect-bindings prgm)])
       `(letrec ,bindings ,(desugar-body cont)))]
-   [else (cons (desugar-exp (car prgm)) (desugar-top (cdr exp)))]))
+   [else (cons (desugar-exp (car prgm)) (desugar-top (cdr prgm)))]))
 
 (define (desugar-exp exp)
   (match exp
@@ -170,6 +170,66 @@
   (let ([v0 (uniq-var v)])
     (values (environment-extend r (list (cons v v0))) v0)))
 
+(define (cps-aexp expr r)
+  (match expr
+    [('lambda (v* ...) e)
+     (let-values
+         ([($k) (gensym "$k-")]
+          [(r0 v*0) (uniq-names r v*)])
+       `(lambda (,@v*0 ,$k) ,(cps-cexp-fo e $k r0)))]
+    [(? primitive?) `(cps-prim ,expr)]
+    ((? symbol?)
+     (let ([kons (environment-assq r expr)])
+       (if kons (cdr kons) (signal-exception "Undefined variable:" expr))))
+    [(? atomic?) expr]))
+
+(define (cps-cexp-fo expr c r)
+  (match expr
+    [ ('quote _) `(,c ,expr)]
+    [`(lambda . ,_) `(,c ,(cps-aexp expr r))]
+    [ (? atomic?) `(,c ,(cps-aexp expr r))]
+    [ (f e* ...)
+      (cps-cexp-ho
+       f
+       (lambda ($f)
+         (cps-cexp-map
+          e*
+          (lambda ($e*)
+            `(,$f ,@$e* ,c))
+          r))
+       r)]))
+
+(define (cps-cexp-ho expr k r)
+  (match expr
+    [ ('quote _) (k expr)]
+    [`(lambda . ,_) (k (cps-aexp expr r))]
+    [ (? atomic?) (k (cps-aexp expr r))]
+    [ (f e* ...)
+      (let ([$rv (gensym "$rv-")])
+        (cps-cexp-ho
+         f
+         (lambda ($f)
+           (cps-cexp-map
+            e*
+            (lambda ($e*)
+              `(,$f ,@$e* (lambda (,$rv) ,(k $rv))))
+            r))
+         r))]))
+
+(define (cps-cexp-map exprs k r)
+  ;; exp* * (aexp -> cexp) -> cexp
+  (if (pair? exprs)
+      (cps-cexp-ho
+       (car exprs)
+       (lambda ($e)
+         (cps-cexp-map
+          (cdr exprs)
+          (lambda ($e*)
+            (k (cons $e $e*)))
+          r))
+       r)
+      (k '())))
+
 (define (M expr r)
   ;; M dispatches to the appropriate transformer
   ;; expr -> aexp
@@ -195,7 +255,8 @@
     [ ('letrec ([v* e*] ...) body)
       (let-values ([(r0 v*0) (uniq-names r v*)])
         (T*-k e* (lambda ($e*)
-                   (T-k body (lambda ($body) `(letrec ,(zip v*0 $e*) (,c ,$body))) r0))
+                   `(letrec ,(zip v*0 $e*)
+                      ,(T-c body c r0)))
              r0))]
     [ ('begin e) (T-c e c r)]
     [ ('begin e e* ...)
@@ -257,13 +318,12 @@
        (T-k e (lambda ($e)
                 `(set-then! ,v0 ,$e ,(k undefined-value))) r))]
     [(f e* ...)
-     (let* ([$rv (gensym "$rv-")]
-            [$k  (gensym "$k-")])
+     (let ([$rv (gensym "$rv-")])
        (T-k f
             (lambda ($f)
-	      (T*-k e*
+              (T*-k e*
                     (lambda ($e*)
-                      (k `((lambda (,$k) (,$f ,@$e* ,$k)) (lambda (,$rv) ,$rv))))
+                      `(,$f ,@$e* (lambda (,$rv) ,(k $rv))))
                     r))
             r))]))