More CPS.

5 files changed, 72 insertions, 4 deletions

diff --git a/csc/cps-test.csc b/csc/cps-test.csc
index 5bd6c1a..0aead27 100644
--- a/csc/cps-test.csc
+++ b/csc/cps-test.csc
@@ -3,12 +3,15 @@
           map->alist)
         (only (csc ir1)
           make-constant
+          make-define-syntax
+          make-if
           make-lexical-ref
           make-lexical-set
           make-library-ref)
         (only (csc ir2)
           ir2=?
           make-atom
+          make-branch
           make-kargs
           make-ktail
           make-update)
@@ -73,3 +76,26 @@
                 (make-update (make-lexical-ref 'var #f)
                              (make-lexical-ref 'generated-symbol #f) 1))))
     (soup->alist (ir1->ir2 (make-lexical-set (make-lexical-ref 'var #f) (make-constant 5))))))
+
+
+(test no-op-define-syntax
+  (assert-equal soup=?
+    (list
+      (cons 0 (make-kargs '() (make-atom (make-constant #f) 1)))
+      (cons 1 (make-ktail)))
+    (soup->alist (ir1->ir2 (make-define-syntax 'name '(transformer))))))
+
+
+(test branch
+  (assert-equal soup=?
+    (list
+      (cons 0 (make-kargs '() (make-atom (make-constant #t) 2)))
+      (cons 1 (make-ktail))
+      (cons 2 (make-kargs (list (make-lexical-ref 'generated-symbol #f))
+                (make-branch (make-lexical-ref 'generated-symbol #f)
+                  3 4)))
+      (cons 3 (make-kargs '() (make-atom (make-constant 1) 1)))
+      (cons 4 (make-kargs '() (make-atom (make-constant 2) 1))))
+    (soup->alist (ir1->ir2 (make-if (make-constant #t)
+                             (make-constant 1)
+                             (make-constant 2))))))
diff --git a/csc/cps.csc b/csc/cps.csc
index 26e0591..e60e198 100644
--- a/csc/cps.csc
+++ b/csc/cps.csc
@@ -8,6 +8,11 @@
             merge)
           (only (csc ir1)
             constant?
+            define-syntax?
+            if-alternate
+            if-consequent
+            if-test
+            if?
             lexical-ref?
             lexical-set-expression
             lexical-set-ref
@@ -20,6 +25,7 @@
             make-lexical-ref)
           (only (csc ir2)
             make-atom
+            make-branch
             make-kargs
             make-ktail
             make-update)
@@ -62,6 +68,23 @@
               (make-soup (cons id (make-kargs (list ref)
                                     (make-update (library-define-ref expr) ref continuation))))
               (to-cps (library-define-expression expr) id next-id))))
+        ((define-syntax? expr)
+          ; no-op
+          (values (make-atom (make-constant #f) continuation) (make-soup)))
+        ((if? expr)
+          (let-values (((id) (next-id))
+                       ((test-ref) (new-ref))
+                       ((true-id) (next-id))
+                       ((false-id) (next-id))
+                       ((true-expr true-soup) (to-cps (if-consequent expr) continuation next-id))
+                       ((false-expr false-soup) (to-cps (if-alternate expr) continuation next-id)))
+            (cps-merge
+              (merge true-soup false-soup
+                (make-soup (cons id (make-kargs (list test-ref)
+                                      (make-branch test-ref true-id false-id)))
+                           (cons true-id (make-kargs '() true-expr))
+                           (cons false-id (make-kargs '() false-expr))))
+              (to-cps (if-test expr) id next-id))))
         (else (error "unexpected type in to-cps" expr))))
 
 
diff --git a/csc/ir1.csc b/csc/ir1.csc
index 76faef9..cf745c6 100644
--- a/csc/ir1.csc
+++ b/csc/ir1.csc
@@ -212,9 +212,8 @@
             (ir1=? (lexical-set-expression x) (lexical-set-expression y))))
         ((and (library-define? x) (library-define? y))
           (and
-            (symbol=? (library-define-name x) (library-define-name y))
-            (ir1=? (library-define-expression x) (library-define-expression y))
-            (equal? (library-define-library x) (library-define-library y))))
+            (ir1=? (library-define-ref x) (library-define-ref y))
+            (ir1=? (library-define-expression x) (library-define-expression y))))
         ((and (if? x) (if? y))
           (and
             (ir1=? (if-test x) (if-test y))
diff --git a/csc/ir2.csc b/csc/ir2.csc
index 6ab0705..bd2c1b6 100644
--- a/csc/ir2.csc
+++ b/csc/ir2.csc
@@ -3,12 +3,17 @@
     atom-continuation
     atom-expression
     atom?
+    branch-atom
+    branch-false
+    branch-true
+    branch?
     ir2=?
     kargs-expression
     kargs-refs
     kargs?
     ktail?
     make-atom
+    make-branch
     make-kargs
     make-ktail
     make-update
@@ -96,6 +101,17 @@
       (continuation update-continuation))
 
 
+    ; Evaluates the given atom.
+    ; If it is true, continue with continuation true.
+    ; If false, continue with continuation false.
+    (define-record-type <branch>
+      (make-branch atom true false)
+      branch?
+      (atom branch-atom)
+      (true branch-true)
+      (false branch-false))
+
+
     ; CPS continuations.
 
 
@@ -134,6 +150,10 @@
                          return #f
                        finally (return #t))
                  (ir2=? (kargs-expression x) (kargs-expression y)))))
+        ((and (branch? x) (branch? y))
+          (and (ir1=? (branch-atom x) (branch-atom y))
+               (= (branch-true x) (branch-true y))
+               (= (branch-false x) (branch-false y))))
         (else #f)))
 
 
diff --git a/csc/testing.csc b/csc/testing.csc
index aad2a63..ecf5547 100644
--- a/csc/testing.csc
+++ b/csc/testing.csc
@@ -63,7 +63,7 @@
           (let ((x left)
                 (y right))
             (unless (cmp x y)
-              (fatalf "Fatal: {} is not equal to {}.\nleft is {}\nright is {}" 'left 'right x y))))
+              (fatalf "Fatal:\n  {}\nis not equal to\n  {}.\nleft is\n  {}\nright is\n  {}" 'left 'right x y))))
         ((assert-equal left right)
           (assert-equal equal? left right))))