Cps conversion for full programs?

scmvm/language/scheme.scm

@@ -101,17 +101,17 @@
 
 (define undefined-value (make-symbol "undefined"))
 
-(define (hybrid-conversion expr)
+(define (cps-convert expr ktail)
   ;; M : expr -> aexp
   ;; T-k : expr, (aexp -> cexp) -> cexp
   ;; T-c : expr, aexp -> cexp
   (define (M expr)
     ;; M dispatches to the appropriate transformer
     (match expr
-      [`(lambda (,var) ,expr)
+      [('lambda (var ...) e)
        (let ([$k (gensym "$k")])
-	 `(lambda (,var ,$k) ,(T-c expr $k)))]
-      [_ expr]))
+	 `(lambda (,@var ,$k) ,(T-c e $k)))]
+      [(? atomic?) expr]))
 
   (define (T-k expr k)
     ;; T-k takes an explicit continuation and calls it when done
@@ -126,9 +126,9 @@
         (T-k `((lambda (,@v*) ,body) ,@e*) k)]
       [ ('if exp1 exp2 exp3)
         (T-k exp1 (lambda ($exp1)
-                    (if $exp1
-                        (T-k exp2 k)
-                        (T-k exp3 k))))]
+                    `(if ,$exp1
+                         ,(T-k exp2 k)
+                         ,(T-k exp3 k))))]
       [ ('set! var expr)
         (T-k expr (lambda ($expr)
                     `(set-then! ,var ,$expr ,(k undefined-value))))]
@@ -151,18 +151,31 @@
         (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)
-                              ,(T-c exp3 $k))))
+          `((lambda (,$k)
+              ,(T-k exp1 (lambda (aexp)
+                           `(if ,aexp
+                                ,(T-c exp2 $k)
+                                ,(T-c exp3 $k)))))
             ,c))]
       [ ('set! var expr)
         (T-k expr (lambda ($expr)
-                    `(set-then ,var ,$expr (,c ,undefined-value))))]
+                    `(set-then! ,var ,$expr (,c ,undefined-value))))]
       [ (f e* ...)
-       (T-k f (lambda ($f)
-		(T*-k e* (lambda ($e*)
-			   `(,$f ,@$e* ,c)))))]))
+        (T-k f (lambda ($f)
+		 (T*-k e* (lambda ($e*)
+			    `(,$f ,@$e* ,c)))))]))
   (define-cps-loop T*-k T-k)
-  (T-c expr 'ktail))
+  (T-k expr ktail))
+
+(define (cps-convert-prgm prgm)
+  (if (pair? prgm)
+      (cons (cps-convert-top (car prgm))
+            (cps-convert-prgm (cdr prgm)))
+      '()))
+
+(define (cps-convert-top top)
+  (match top
+    [`(define ,v ,e)
+     (cps-convert e (lambda ($rv) `(define ,v ,$rv)))]
+    [_
+     (cps-convert top (lambda _ `(nop)))]))