Remove $void CPS expression type

[bpt/guile.git] / module / language / cps.scm

diff --git a/module/language/cps.scm b/module/language/cps.scm
index 2867a4a..ee20197 100644 (file)
--- a/module/language/cps.scm
+++ b/module/language/cps.scm
@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013, 2014 Free Software Foundation, Inc.
+;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -27,8 +27,8 @@
 ;;; $letk binds a set of mutually recursive continuations, each one an
 ;;; instance of $cont.  A $cont declares the name of a continuation, and
 ;;; then contains as a subterm the particular continuation instance:
-;;; $kif for test continuations, $kargs for continuations that bind
-;;; values, etc.
+;;; $kargs for continuations that bind values, $ktail for the tail
+;;; continuation, etc.
 ;;;
 ;;; $continue nodes call continuations.  The expression contained in the
 ;;; $continue node determines the value or values that are passed to the
@@ -92,7 +92,7 @@
 ;;;   - $letk, $letrec, and $continue are terms.
 ;;;
 ;;;   - $cont is a continuation, containing a continuation body ($kargs,
-;;;     $kif, etc).
+;;;     $ktail, etc).
 ;;;
 ;;;   - $continue terms contain an expression ($call, $const, $fun,
 ;;;     etc).
@@ -119,10 +119,10 @@
             $cont
 
             ;; Continuation bodies.
-            $kif $kreceive $kargs $kfun $ktail $kclause
+            $kreceive $kargs $kfun $ktail $kclause
 
             ;; Expressions.
-            $void $const $prim $fun $closure
+            $const $prim $fun $closure $branch
             $call $callk $primcall $values $prompt
 
             ;; First-order CPS root.
@@ -181,7 +181,6 @@
 
 ;; Continuations
 (define-cps-type $cont k cont)
-(define-cps-type $kif kt kf)
 (define-cps-type $kreceive arity k)
 (define-cps-type $kargs names syms body)
 (define-cps-type $kfun src meta self tail clause)
@@ -189,11 +188,11 @@
 (define-cps-type $kclause arity cont alternate)
 
 ;; Expressions.
-(define-cps-type $void)
 (define-cps-type $const val)
 (define-cps-type $prim name)
 (define-cps-type $fun free body) ; Higher-order.
 (define-cps-type $closure label nfree) ; First-order.
+(define-cps-type $branch k exp)
 (define-cps-type $call proc args)
 (define-cps-type $callk k proc args) ; First-order.
 (define-cps-type $primcall name args)
@@ -238,11 +237,9 @@
      (make-$arity req opt rest kw allow-other-keys?))))
 
 (define-syntax build-cont-body
-  (syntax-rules (unquote $kif $kreceive $kargs $kfun $ktail $kclause)
+  (syntax-rules (unquote $kreceive $kargs $kfun $ktail $kclause)
     ((_ (unquote exp))
      exp)
-    ((_ ($kif kt kf))
-     (make-$kif kt kf))
     ((_ ($kreceive req rest kargs))
      (make-$kreceive (make-$arity req '() rest '() #f) kargs))
     ((_ ($kargs (name ...) (unquote syms) body))
@@ -266,10 +263,9 @@
 
 (define-syntax build-cps-exp
   (syntax-rules (unquote
-                 $void $const $prim $fun $closure
+                 $const $prim $fun $closure $branch
                  $call $callk $primcall $values $prompt)
     ((_ (unquote exp)) exp)
-    ((_ ($void)) (make-$void))
     ((_ ($const val)) (make-$const val))
     ((_ ($prim name)) (make-$prim name))
     ((_ ($fun free body)) (make-$fun free (build-cps-cont body)))
@@ -286,6 +282,7 @@
     ((_ ($values (unquote args))) (make-$values args))
     ((_ ($values (arg ...))) (make-$values (list arg ...)))
     ((_ ($values args)) (make-$values args))
+    ((_ ($branch k exp)) (make-$branch k (build-cps-exp exp)))
     ((_ ($prompt escape? tag handler))
      (make-$prompt escape? tag handler))))
 
@@ -354,8 +351,6 @@
     (('k sym body)
      (build-cps-cont
        (sym ,(parse-cps body))))
-    (('kif kt kf)
-     (build-cont-body ($kif kt kf)))
     (('kreceive req rest k)
      (build-cont-body ($kreceive req rest k)))
     (('kargs names syms body)
@@ -383,8 +378,6 @@
     ;; Calls.
     (('continue k exp)
      (build-cps-term ($continue k (src exp) ,(parse-cps exp))))
-    (('void)
-     (build-cps-exp ($void)))
     (('const exp)
      (build-cps-exp ($const exp)))
     (('prim name)
@@ -404,6 +397,8 @@
      (build-cps-exp ($callk k proc arg)))
     (('primcall name arg ...)
      (build-cps-exp ($primcall name arg)))
+    (('branch k exp)
+     (build-cps-exp ($branch k ,(parse-cps exp))))
     (('values arg ...)
      (build-cps-exp ($values arg)))
     (('prompt escape? tag handler)
@@ -425,8 +420,6 @@
      `(letk ,(map unparse-cps conts) ,(unparse-cps body)))
     (($ $cont sym body)
      `(k ,sym ,(unparse-cps body)))
-    (($ $kif kt kf)
-     `(kif ,kt ,kf))
     (($ $kreceive ($ $arity req () rest '() #f) k)
      `(kreceive ,req ,rest ,k))
     (($ $kargs () () body)
@@ -444,8 +437,6 @@
     ;; Calls.
     (($ $continue k src exp)
      `(continue ,k ,(unparse-cps exp)))
-    (($ $void)
-     `(void))
     (($ $const val)
      `(const ,val))
     (($ $prim name)
@@ -467,6 +458,8 @@
      `(callk ,k ,proc ,@args))
     (($ $primcall name args)
      `(primcall ,name ,@args))
+    (($ $branch k exp)
+     `(branch ,k ,(unparse-cps exp)))
     (($ $values args)
      `(values ,@args))
     (($ $prompt escape? tag handler)
@@ -623,10 +616,9 @@
          (($ $continue k src exp)
           (match exp
             (($ $prompt escape? tag handler) (proc k handler))
+            (($ $branch kt) (proc k kt))
             (_ (proc k)))))))
 
-    (($ $kif kt kf) (proc kt kf))
-
     (($ $kreceive arity k) (proc k))
 
     (($ $kclause arity ($ $cont kbody) #f) (proc kbody))