Cleaner cps interface

scmvm/language/scheme.scm

@@ -23,6 +23,9 @@
       (symbol? x)
       (boolean? x)))
 
+(define (primitive? x)
+  (memq x '(+ - * / = < > <= >=)))
+
 (define-syntax-rule (define-cps-loop name unit)
   (define (name v* k)
     (if (null? v*)
@@ -104,71 +107,88 @@
 
 (define undefined-value (make-symbol "undefined"))
 
-(define (cps-convert-prgm prgm 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 ...) e)
-       (let ([$k (gensym "$k")])
-	 `(lambda (,@var ,$k) ,(T-c e $k)))]
-      [(? atomic?) expr]))
+(define (M expr)
+  ;; M dispatches to the appropriate transformer
+  (match expr
+    [('lambda (var ...) e)
+     (let ([$k (gensym "$k")])
+       `(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
-    ;; As an invariant, T-k cannot nest a T-c call directly
-    (match expr
-      [`(lambda . ,_) (k (M expr))]
-      [ (? atomic?)   (k (M expr))]
-      [ ('begin e) (T-k e k)]
-      [ ('begin e e* ...)
-        (T-k e (lambda _ (T-k `(begin ,@e*) k)))]
-      [ ('let ([v* e*] ...) body)
-        (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))))]
-      [ ('set! var expr)
-        (T-k expr (lambda ($expr)
-                    `(set-then! ,var ,$expr ,(k undefined-value))))]
-      [(f e* ...)
-       (let* ([$rv (gensym "$rv")]
-	      [cont `(lambda (,$rv) ,(k $rv))])
-	 (T-k f (lambda ($f)
-		  (T*-k e* (lambda ($e*)
-			     `(,$f ,@$e* ,cont))))))]))
+(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
+  (match expr
+    [`(lambda . ,_) (k (M expr))]
+    [ (? atomic?)   (k (M expr))]
+    [ ('define v e) (T-k `(define-then! ,v ,e) k)]
+    [ ('begin e) (T-k e k)]
+    [ ('begin e e* ...)
+      (T-k e (lambda _ (T-k `(begin ,@e*) k)))]
+    [ ('let ([v* e*] ...) body)
+      (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))))]
+    [ ('set! var expr)
+      (T-k expr (lambda ($expr)
+                  `(set-then! ,var ,$expr ,(k undefined-value))))]
+    [((? primitive? f) e* ...)
+     (let* ([$rv (gensym "$rv")]
+            [cont `(lambda (,$rv) ,(k $rv))])
+       (T*-k e* (lambda ($e*)
+                  `((cps ,f) ,@$e* ,cont))))]
+    [(f e* ...)
+     (let* ([$rv (gensym "$rv")]
+	    [cont `(lambda (,$rv) ,(k $rv))])
+       (T-k f (lambda ($f)
+		(T*-k e* (lambda ($e*)
+			   `(,$f ,@$e* ,cont))))))]))
 
-  (define (T-c expr c)
-    ;; T-c takes a symbolic continuation, and uses it to construct CPS
-    (match expr
-      [`(lambda . ,_) `(,c ,(M expr))]
-      [ (? atomic?)   `(,c ,(M expr))]
-      [ ('begin e) (T-c e c)]
-      [ ('begin e e* ...)
-        (T-k e (lambda _ (T-c `(begin ,@e*) c)))]
-      [ ('let ([v* e*] ...) body)
-        (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)))))
-            ,c))]
-      [ ('set! var expr)
-        (T-k expr (lambda ($expr)
-                    `(set-then! ,var ,$expr (,c ,undefined-value))))]
-      [ (f e* ...)
-        (T-k f (lambda ($f)
-		 (T*-k e* (lambda ($e*)
-			    `(,$f ,@$e* ,c)))))]))
-  (define-cps-loop T*-k T-k)
-  (T-c prgm ktail))
+(define (T-c expr c)
+  ;; T-c takes a symbolic continuation, and uses it to construct CPS
+  (match expr
+    [`(lambda . ,_) `(,c ,(M expr))]
+    [ (? atomic?)   `(,c ,(M expr))]
+    [ ('define v e) (T-c `(define-then! ,v ,e) c)]
+    [ ('begin e) (T-c e c)]
+    [ ('begin e e* ...)
+      (T-k e (lambda _ (T-c `(begin ,@e*) c)))]
+    [ ('let ([v* e*] ...) body)
+      (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)))))
+          ,c))]
+    [ ('set! var expr)
+      (T-k expr (lambda ($expr)
+                  `(set-then! ,var ,$expr (,c ,undefined-value))))]
+    [ ((? primitive? f) e* ...)
+      (T*-k e* (lambda ($e*)
+                 `((cps ,f) ,@$e* ,c)))]
+    [ (f e* ...)
+      (T-k f (lambda ($f)
+	       (T*-k e* (lambda ($e*)
+			  `(,$f ,@$e* ,c)))))]))
 
-(define* (ir-convert prgm #:key (ktail 'ktail))
-  (cps-convert-prgm (desugar-prgm prgm) ktail))
+(define (cps-convert-prgm prgm)
+  (T-c `(begin ,@prgm) 'ktail))
+
+(define-cps-loop T*-k T-k)
+
+(define (ir-convert prgm)
+  (cps-convert-prgm (desugar-prgm prgm)))
+
+;; Useful for testing
+;; (define (cps prim)
+;;   (lambda vars
+;;     (let* ([rev (reverse vars)]
+;;            [k (car rev)]
+;;            [args (reverse (cdr rev))])
+;;       (k (apply prim args)))))