Improve CPS.

Goodbye soup. Thanks to "Compiling with Continuations" by Appel.

1 files changed, 29 insertions, 51 deletions

diff --git a/csc/ir1.csc b/csc/ir1.csc
index 26b885b..d82cf12 100644
--- a/csc/ir1.csc
+++ b/csc/ir1.csc
@@ -14,13 +14,9 @@
     if?
     import?
     ir1=?
+    lambda-arguments
     lambda-body
-    lambda-case-alternate
-    lambda-case-arguments
-    lambda-case-body
-    lambda-case-gensyms
-    lambda-case-rest
-    lambda-case?
+    lambda-rest
     lambda?
     letrec-expression
     letrec-gensyms
@@ -45,7 +41,6 @@
     make-define-syntax
     make-if
     make-lambda
-    make-lambda-case
     make-letrec
     make-lexical-ref
     make-lexical-set
@@ -56,6 +51,8 @@
     sequence-tail
     sequence?)
   (import (scheme base)
+          (only (csc list)
+            all)
           (only (csc loop) loop return))
   (begin
     ; This library defines the intermediate representation IR1. An expression
@@ -151,37 +148,16 @@
 
 
     ; <lambda> body
-    ; A closure. body is an expression of type <lambda-case>.
+    ; A closure. Arguments is a list of lexical-refs.
+    ; Rest is a lexical ref or #f if the lambda doesn't take a rest parameter.
     (define-record-type <lambda>
-      (make-lambda body)
+      (make-lambda arguments rest body)
       lambda?
+      (arguments lambda-arguments)
+      (rest lambda-rest)
       (body lambda-body))
 
 
-    ; <lambda-case> arguments rest gensyms body alternate
-    ; One clause of a case-lambda. A lambda expression in Scheme is treated as
-    ; a case-lambda with one clause.
-    ;
-    ; arguments is a list of the procedures arguments, as symbols. rest is the
-    ; name of the rest argument, or #f. gensyms is a list of gensyms
-    ; corresponding to all arguments: first all of the normal arguments, then
-    ; the rest argument if any.
-    ;
-    ; body is the name of the clause (??). If the procedure is called with an
-    ; appropriate number of arguments, body is evaluated in tail position.
-    ; Otherwise if there is an alternate, it should be a <lambda-case>
-    ; expression, representing the next clause to try. If alternate is #f, an
-    ; error is signaled.
-    (define-record-type <lambda-case>
-      (make-lambda-case arguments rest gensyms body alternate)
-      lambda-case?
-      (arguments lambda-case-arguments)
-      (rest lambda-case-rest)
-      (gensyms lambda-case-gensyms)
-      (body lambda-case-body)
-      (alternate lambda-case-alternate))
-
-
     ; <letrec> in-order? names gensyms values expression
     ; Lexical binding, like Scheme's letrec, or letrec* if in-order? is true.
     ; names are the original binding names, gensyms are gensyms corresponding
@@ -233,25 +209,27 @@
             (ir1=? (sequence-head x) (sequence-head y))
             (ir1=? (sequence-tail x) (sequence-tail y))))
         ((and (lambda? x) (lambda? y))
-          (ir1=? (lambda-body x) (lambda-body y)))
-        ((and (lambda-case? x) (lambda-case? y))
-          (and
-            (equal? (lambda-case-arguments x) (lambda-case-arguments y))
-            (eq? (lambda-case-rest x) (lambda-case-rest y))
-            (ir1=? (lambda-case-body x) (lambda-case-body y))
-            (or (and (null? (lambda-case-alternate x))
-                     (null? (lambda-case-alternate y)))
-                (ir1=? (lambda-case-alternate x) (lambda-case-alternate y)))))
+          (let ((x-args (lambda-arguments x))
+                (x-rest (lambda-rest x))
+                (y-args (lambda-arguments y))
+                (y-rest (lambda-rest y)))
+            (and (= (length x-args) (length y-args))
+                 (all ir1=? x-args y-args)
+                 (or (and (not x-rest) (not y-rest))
+                     (ir1=? x-rest y-rest))
+                 (ir1=? (lambda-body x) (lambda-body y)))))
         ((and (letrec? x) (letrec? y))
-          (and
-            (boolean=? (letrec-in-order? x) (letrec-in-order? y))
-            (map symbol=? (letrec-names x) (letrec-names y))
-            (= (length (letrec-values x)) (length (letrec-values y)))
-            (loop for x-val in (letrec-values x)
-                  for y-val in (letrec-values y)
-                  unless (ir1=? x-val y-val) return #f
-                  finally (return #t))
-            (ir1=? (letrec-expression x) (letrec-expression y))))
+          (let ((x-names (letrec-names x))
+                (x-values (letrec-values x))
+                (y-names (letrec-names y))
+                (y-values (letrec-values y)))
+            (and
+              (boolean=? (letrec-in-order? x) (letrec-in-order? y))
+              (= (length x-names) (length y-names))
+              (all symbol=? x-names y-names)
+              (= (length x-values) (length y-values))
+              (all ir1=? x-values y-values)
+              (ir1=? (letrec-expression x) (letrec-expression y)))))
         (else #f)))