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,10 +107,6 @@
 
 (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
@@ -122,6 +121,7 @@
   (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)))]
@@ -135,6 +135,11 @@
     [ ('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))])
@@ -147,6 +152,7 @@
   (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)))]
@@ -163,12 +169,26 @@
     [ ('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-cps-loop T*-k T-k)
-  (T-c prgm ktail))
 
-(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)))))