Add a diff library.

I was hesitant to add a diff library, but it was surprisingly easy. A
straightforward application of dynamic programming.

12 files changed, 549 insertions, 191 deletions

diff --git a/csc/compare-test.csc b/csc/compare-test.csc
new file mode 100644
index 0000000..6df177f
--- /dev/null
+++ b/csc/compare-test.csc
@@ -0,0 +1,82 @@
+(import (scheme base)
+        (only (csc match)
+          define-match-record-type)
+        (only (csc testing)
+          assert-equal
+          test)
+        (csc compare))
+
+
+(test diff-list
+  (assert-equal
+    " (
+   1
+  -2
+   3
+  +3.5
+   4
+ )
+"
+    (diff '(1 2 3 4) '(1 3 3.5 4))))
+
+
+(define-match-record-type <test-type>
+  (make-test-type a b)
+  test-type?
+  %test-type
+  (a test-type-a)
+  (b test-type-b))
+
+
+(test diff-record
+  (assert-equal
+    " (
+   (a .
+     5
+   )
+   (b .
+    -5
+    +6
+   )
+   (type .
+     <test-type>
+   )
+ )
+"
+    (diff (make-test-type 5 5) (make-test-type 5 6) (cons test-type? %test-type))))
+
+
+(test diff-multiline-string
+  (assert-equal
+    " (
+   (type .
+     string
+   )
+   (value .
+     (
+       line-one
+      -line-two
+       line-three
+     )
+   )
+ )
+"
+    (diff "line-one\nline-two\nline-three" "line-one\nline-three")))
+
+
+(test diff-vector
+  (assert-equal
+    " (
+   (type .
+     vector
+   )
+   (value .
+     (
+       1
+      -2
+       3
+     )
+   )
+ )
+"
+    (diff #(1 2 3) #(1 3))))
diff --git a/csc/compare.csc b/csc/compare.csc
new file mode 100644
index 0000000..c9716bf
--- /dev/null
+++ b/csc/compare.csc
@@ -0,0 +1,219 @@
+(define-library (csc compare)
+  (export diff)
+  (import (scheme base)
+          (only (csc format) fprintf)
+          (only (csc loop)
+            loop
+            return)
+          (only (csc match) match)
+          (only (csc sort) sort)
+          (only (csc strings)
+            contains
+            split)
+          (only (csc vec)
+            vec
+            vec-append))
+  (begin
+    ; compare is inspired by Go's cmp.Diff.
+
+
+    (define (apply-transformer t x)
+      (if (list? t)
+        (loop for transformer in t
+              do (set! x (apply-transformer transformer x))
+              finally (return x))
+        (if ((car t) x)
+          ((cdr t) x)
+          x)))
+
+
+    (define (alist? l)
+      (match l
+        (((key . _) . _)
+          (symbol? key))
+        (_ #f)))
+
+
+    (define (transform x transformers)
+      (define x* (apply-transformer transformers x))
+      (cond
+        ((alist? x*)
+          (sort (lambda (a b) (string<? (symbol->string (car a)) (symbol->string (car b))))
+            (map (lambda (elem)
+                   (cons (car elem) (transform (cdr elem) transformers)))
+                 x*)))
+        ((list? x*)
+          (map (lambda (elem) (transform elem transformers))
+               x*))
+        (else x*)))
+
+
+    ; As always, I copied the algorithm from Wikipedia
+    (define (lcs x y cmp)
+      (define x-vals (list->vector x))
+      (define y-vals (list->vector y))
+      (define table (make-vector (* (+ 1 (vector-length x-vals)) (+ 1 (vector-length y-vals))) 0))
+      (define (index i j)
+        (+ j (* i (+ 1 (vector-length y-vals)))))
+      (loop for i from 1 to (vector-length x-vals)
+            do (loop for j from 1 to (vector-length y-vals)
+                     if (cmp (vector-ref x-vals (- i 1)) (vector-ref y-vals (- j 1)))
+                       do (vector-set! table (index i j) (+ 1 (vector-ref table (index (- i 1) (- j 1)))))
+                     else
+                       do (vector-set! table (index i j) (max (vector-ref table (index (- i 1) j))
+                                                              (vector-ref table (index i (- j 1)))))))
+      (let loop ((i (vector-length x-vals))
+                 (j (vector-length y-vals))
+                 (lcs '()))
+        (cond
+          ((or (= 0 i) (= 0 j)) lcs)
+          ((cmp (vector-ref x-vals (- i 1)) (vector-ref y-vals (- j 1)))
+            (loop (- i 1) (- j 1) (cons (vector-ref x-vals (- i 1)) lcs)))
+          ((> (vector-ref table (index i (- j 1))) (vector-ref table (index (- i 1) j)))
+            (loop i (- j 1) lcs))
+          (else (loop (- i 1) j lcs)))))
+
+
+    (define (pretty w x indent)
+      (cond
+        ((list? x)
+          (fprintf w "{}(\n" indent)
+          (loop with new-indent = (string-append indent "  ")
+                for v in x
+                do (pretty w v new-indent))
+          (fprintf w "{})\n" indent))
+        ((and (pair? x)
+              (symbol? (car x)))
+          (fprintf w "{}({} .\n" indent (car x))
+          (pretty w (cdr x) (string-append indent "  "))
+          (fprintf w "{})\n" indent))
+        (else (fprintf w "{}{}\n" indent x))))
+
+
+    (define (diff* w x y indent)
+      (cond
+        ((or (and (boolean? x) (boolean? y))
+             (and (char? x) (char? y))
+             (and (symbol? x) (symbol? y))
+             (and (number? x) (number? y))
+             (and (string? x) (string? y)))
+          (if (equal? x y)
+            (begin
+              (fprintf w "{} {}\n" indent x)
+              #t)
+            (begin
+              (fprintf w "{}-{}\n{}+{}\n" indent x indent y)
+              #f)))
+        ((and (alist? x) (alist? y))
+          (fprintf w "{} (\n" indent)
+          (let ((key-lcs (lcs (map car x) (map car y) symbol=?))
+                (indent* (string-append indent "  "))
+                (equal #t))
+            (loop if (null? key-lcs)
+                    if (null? x)
+                      if (null? y)
+                        do (return)
+                      else
+                        do (pretty w (car y) (string-append indent* "+"))
+                           (set! y (cdr y))
+                           (set! equal #f)
+                    else
+                      do (pretty w (car x) (string-append indent* "-"))
+                         (set! x (cdr x))
+                         (set! equal #f)
+                  else
+                    if (symbol=? (caar x) (caar y) (car key-lcs))
+                      do (fprintf w "{} ({} .\n" indent* (car key-lcs))
+                         (set! equal (and (diff* w (cdar x) (cdar y) (string-append indent* "  "))
+                                          equal))
+                         (fprintf w "{} )\n" indent*)
+                         (set! x (cdr x))
+                         (set! y (cdr y))
+                         (set! key-lcs (cdr key-lcs))
+                    else if (symbol=? (caar x) (car key-lcs))
+                      do (pretty w (car y) (string-append indent* "+"))
+                         (set! y (cdr y))
+                         (set! equal #f)
+                    else
+                      do (pretty w (car x) (string-append indent* "-"))
+                         (set! x (cdr x))
+                         (set! equal #f))
+            (fprintf w "{} )\n" indent)
+            equal))
+        ((and (list? x) (list? y))
+          (fprintf w "{} (\n" indent)
+          (let* ((common (lcs x y equal?))
+                 (indent* (string-append indent "  "))
+                 (equal #t))
+            (loop if (null? common)
+                    if (null? x)
+                      if (null? y)
+                        do (return)
+                      else
+                        do (pretty w (car y) (string-append indent* "+"))
+                           (set! y (cdr y))
+                           (set! equal #f)
+                    else if (null? y)
+                      do (pretty w (car x) (string-append indent* "-"))
+                         (set! x (cdr x))
+                         (set! equal #f)
+                    else
+                      do (diff* w (car x) (car y) indent*)
+                         (set! x (cdr x))
+                         (set! y (cdr y))
+                         (set! equal #f)
+                  else
+                    if (equal? (car x) (car y))
+                      do (pretty w (car x) (string-append indent* " "))
+                         (set! x (cdr x))
+                         (set! y (cdr y))
+                         (set! common (cdr common))
+                    else if (equal? (car x) (car common))
+                      do (pretty w (car y) (string-append indent* "+"))
+                         (set! y (cdr y))
+                         (set! equal #f)
+                    else if (equal? (car y) (car common))
+                      do (pretty w (car x) (string-append indent* "-"))
+                         (set! x (cdr x))
+                         (set! equal #f)
+                    else
+                      do (diff* w (car x) (car y) indent*)
+                         (set! x (cdr x))
+                         (set! y (cdr y))
+                         (set! equal #f))
+            (fprintf w "{} )\n" indent)
+            equal))))
+
+
+    (define default-transformers
+      (list
+        (cons (lambda (s)
+                (and (string? s)
+                     (contains s "\n")))
+              (lambda (s)
+                (list (cons 'type 'string)
+                      (cons 'value (split s "\n")))))
+        (cons vector? (lambda (v)
+                        (list (cons 'type 'vector)
+                              (cons 'value (vector->list v)))))
+        (cons bytevector? (lambda (b)
+                            (list (cons 'type 'bytevector)
+                                  (cons 'value (loop for i below (bytevector-length b)
+                                                     collect (string-append "0x" (number->string (bytevector-u8-ref b i))))))))))
+
+
+    ; Returns a string diff between x and y. Diff knows how to compare lists,
+    ; alists and other primitive types. Any user-defined type needs a
+    ; transformer. Each transformer is a pair of type predicate that the
+    ; transformer matches on, and a function that transforms a value of that
+    ; type into an alist.
+    ;
+    ; Potential future enhancements:
+    ; - support vector and bytevector
+    ; - split strings into lines
+    (define (diff x y . transformers)
+      (define d (open-output-string))
+      (define t* (cons default-transformers transformers))
+      (if (diff* d (transform x t*) (transform y t*) "")
+        ""
+        (get-output-string d)))))
diff --git a/csc/cps-test.csc b/csc/cps-test.csc
index c72aca6..9881a2d 100644
--- a/csc/cps-test.csc
+++ b/csc/cps-test.csc
@@ -1,6 +1,14 @@
 (import (scheme base)
-        (only (csc gensym) gensym)
+        (only (csc gensym)
+          gensym
+          gensym?)
         (only (csc ir1)
+          %constant
+          %lexical-ref
+          %library-ref
+          constant?
+          lexical-ref?
+          library-ref?
           make-call
           make-constant
           make-define-syntax
@@ -12,7 +20,16 @@
           make-library-ref
           make-sequence)
         (only (csc ir2)
-          ir2=?
+          %apply
+          %branch
+          %closure
+          %fix
+          %primitive
+          %variable
+          apply?
+          branch?
+          closure?
+          fix?
           make-apply
           make-atom
           make-branch
@@ -23,13 +40,29 @@
           make-klabel
           make-ktail
           make-primitive
-          make-variable)
+          make-variable
+          primitive?
+          variable?)
         (only (csc testing)
           assert-equal
           test)
         (csc cps))
 
 
+(define transform-ir2
+  (list
+    (cons constant? %constant)
+    (cons lexical-ref? %lexical-ref)
+    (cons library-ref? %library-ref)
+    (cons variable? %variable)
+    (cons primitive? %primitive)
+    (cons branch? %branch)
+    (cons apply? %apply)
+    (cons closure? %closure)
+    (cons fix? %fix)
+    (cons gensym? (lambda (x) 'gensym))))
+
+
 (define (test-ref name)
   (make-lexical-ref name (gensym)))
 
@@ -39,42 +72,47 @@
 
 
 (test atom-const
-  (assert-equal ir2=?
+  (assert-equal
     (make-apply (test-ref 'tail) (list (make-constant 5)))
-    (ir1->ir2 (make-constant 5) tail)))
+    (ir1->ir2 (make-constant 5) tail)
+    transform-ir2))
 
 
 (test atom-lexical-ref
-  (assert-equal ir2=?
+  (assert-equal
     (make-apply (test-ref 'tail) (list (test-ref 'var)))
-    (ir1->ir2 (test-ref 'var) tail)))
+    (ir1->ir2 (test-ref 'var) tail)
+    transform-ir2))
 
 
 (test atom-library-ref
-  (assert-equal ir2=?
+  (assert-equal
     (make-primitive 'peek (list (make-library-ref 'var '(csc builtins)) (make-constant 0))
                           (list (test-ref 'generated-symbol))
       (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol))))
-    (ir1->ir2 (make-library-ref 'var '(csc builtins)) tail)))
+    (ir1->ir2 (make-library-ref 'var '(csc builtins)) tail)
+    transform-ir2))
 
 
 (test lexical-set
-  (assert-equal ir2=?
+  (assert-equal
     (make-primitive 'poke (list (make-constant 5) (test-ref 'var) (make-constant 0)) '()
       (make-apply (test-ref 'tail) (list (make-constant #f))))
     (ir1->ir2 (make-lexical-set (test-ref 'var) (make-constant 5))
-              tail)))
+              tail)
+    transform-ir2))
 
 
 (test no-op-define-syntax
-  (assert-equal ir2=?
+  (assert-equal
     (make-apply (test-ref 'tail) (list (make-constant #f)))
     (ir1->ir2 (make-define-syntax 'name '(transformer))
-              tail)))
+              tail)
+    transform-ir2))
 
 
 (test branch
-  (assert-equal ir2=?
+  (assert-equal
     (make-fix
       (list
         (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) #f
@@ -85,11 +123,12 @@
     (ir1->ir2 (make-if (make-constant #t)
                 (make-constant 1)
                 (make-constant 2))
-              tail)))
+              tail)
+    transform-ir2))
 
 
 (test call-closure
-  (assert-equal ir2=?
+  (assert-equal
     (make-fix
       (list
         (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) #f
@@ -98,21 +137,23 @@
                                                  (make-constant 1)
                                                  (make-constant 2))))
     (ir1->ir2 (make-call (test-ref 'f) (list (make-constant 1) (make-constant 2)))
-              tail)))
+              tail)
+    transform-ir2))
 
 
 (test sequence
-  (assert-equal ir2=?
+  (assert-equal
     (make-primitive 'poke (list (make-constant 5) (test-ref 'a) (make-constant 0)) '()
       (make-primitive 'poke (list (make-constant 6) (test-ref 'b) (make-constant 0)) '()
         (make-apply (test-ref 'tail) (list (make-constant #f)))))
     (ir1->ir2 (make-sequence (make-lexical-set (test-ref 'a) (make-constant 5))
                              (make-lexical-set (test-ref 'b) (make-constant 6)))
-              tail)))
+              tail)
+    transform-ir2))
 
 
 (test closure
-  (assert-equal ir2=?
+  (assert-equal
     (make-fix
       (list
         (make-closure (test-ref 'generated-symbol)
@@ -126,13 +167,14 @@
                 (list (test-ref 'a) (test-ref 'b))
                 (test-ref 'c)
                 (make-constant 5))
-              tail)))
+              tail)
+    transform-ir2))
 
 
 (test letrec-functions
   (define x (test-ref 'x))
   (define f (gensym))
-  (assert-equal ir2=?
+  (assert-equal
     (make-fix
       (list
         (make-closure (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'x)) #f
@@ -146,11 +188,12 @@
       (make-letrec #f '(f) (list f)
                    (list (make-lambda (list x) #f x))
         (make-call (make-lexical-ref 'f f) (list (make-constant 10))))
-      tail)))
+      tail)
+    transform-ir2))
 
 
 (test letrec-in-order
-  (assert-equal ir2=?
+  (assert-equal
     (make-primitive 'alloc (list (make-constant 1)) (list (test-ref 'b))
       (make-primitive 'alloc (list (make-constant 1)) (list (test-ref 'a))
         (make-fix
@@ -168,7 +211,8 @@
               (make-lambda (list (test-ref 'x)) #f (make-constant 5))
               (make-constant 2))
         (make-constant 10))
-      tail)))
+      tail)
+    transform-ir2))
 
 
 ; What does the following letrec return?
@@ -178,7 +222,7 @@
 (test letrec-very-cool
   (define f (gensym))
   (define x (gensym))
-  (assert-equal ir2=?
+  (assert-equal
     (make-primitive 'alloc (list (make-constant 1)) (list (test-ref 'x))
       (make-fix
         (list
@@ -199,12 +243,13 @@
         (list (make-lambda '() #f (make-lexical-ref 'x x))
               (make-call (make-lexical-ref 'f f) '()))
         (make-lexical-ref 'x x))
-      tail)))
+      tail)
+    transform-ir2))
 
 
 (test set-argument
   (define test-sym (gensym))
-  (assert-equal ir2=?
+  (assert-equal
     (make-fix
       (list
         (make-closure (test-ref 'f) (list (test-ref 'generated-symbol)
@@ -226,11 +271,12 @@
                 (list (make-lambda (list (make-lexical-ref 'x test-sym)) #f
                         (make-lexical-set (make-lexical-ref 'x test-sym) (make-constant 10))))
                 (make-constant 5))
-              tail)))
+              tail)
+    transform-ir2))
 
 (test set-function
   (define test-sym (gensym))
-  (assert-equal ir2=?
+  (assert-equal
     (make-primitive 'alloc (list (make-constant 1)) (list (test-ref 'f))
       (make-fix
         (list
@@ -245,7 +291,8 @@
                 (list test-sym)
                 (list (make-lambda '() #f (make-constant 10)))
                 (make-lexical-set (make-lexical-ref 'f test-sym) (make-constant 5)))
-              tail)))
+              tail)
+    transform-ir2))
 
 
 (define (test-var)
@@ -257,7 +304,7 @@
   (define f-sym (gensym))
   (define ret-sym (gensym))
   (define x-sym (gensym))
-  (assert-equal ir2=?
+  (assert-equal
     (make-primitive 'alloc (list (make-constant 1)) (list (test-var))
       (make-fix
         (list
@@ -277,4 +324,5 @@
                            (make-closure (make-lexical-ref 'f f-sym) (list (make-lexical-ref 'ret ret-sym) (make-lexical-ref 'x x-sym)) #f
                              (make-primitive 'poke (list (make-lexical-ref 'x x-sym) (make-lexical-ref 'a a-sym) (make-constant 0)) '()
                                (make-apply (make-lexical-ref 'ret ret-sym) (list (make-constant #f))))))
-                         (make-apply (make-lexical-ref 'f f-sym) (list (make-library-ref 'tail '(csc builtins)) (make-constant 10))))))))
+                         (make-apply (make-lexical-ref 'f f-sym) (list (make-library-ref 'tail '(csc builtins)) (make-constant 10))))))
+    transform-ir2))
diff --git a/csc/gensym.csc b/csc/gensym.csc
index 252f77c..480cbc2 100644
--- a/csc/gensym.csc
+++ b/csc/gensym.csc
@@ -2,7 +2,8 @@
   (export
     gensym
     gensym->int
-    gensym=?)
+    gensym=?
+    gensym?)
   (import (scheme base))
   (begin
 
diff --git a/csc/ir1.csc b/csc/ir1.csc
index 33588c9..942f8f9 100644
--- a/csc/ir1.csc
+++ b/csc/ir1.csc
@@ -23,7 +23,6 @@
     if-consequent
     if-test
     if?
-    ir1=?
     lambda-arguments
     lambda-body
     lambda-rest
@@ -193,64 +192,4 @@
       (names letrec-names)
       (gensyms letrec-gensyms)
       (values letrec-values)
-      (expression letrec-expression))
-
-
-    (define (ir1=? x y)
-      (cond
-        ((and (constant? x) (constant? y))
-          (equal? (constant-expression x) (constant-expression y)))
-        ((and (lexical-ref? x) (lexical-ref? y))
-          (symbol=? (lexical-ref-name x) (lexical-ref-name y)))
-        ((and (library-ref? x) (library-ref? y))
-          (symbol=? (library-ref-name x) (library-ref-name y))
-          (equal? (library-ref-library x) (library-ref-library y)))
-        ((and (lexical-set? x) (lexical-set? y))
-          (and
-            (ir1=? (lexical-set-ref x) (lexical-set-ref y))
-            (ir1=? (lexical-set-expression x) (lexical-set-expression y))))
-        ((and (library-define? x) (library-define? y))
-          (and
-            (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))
-            (ir1=? (if-consequent x) (if-consequent y))
-            (ir1=? (if-alternate x) (if-alternate y))))
-        ((and (call? x) (call? y))
-          (and
-            (ir1=? (call-procedure x) (call-procedure y))
-            (= (length (call-arguments x)) (length (call-arguments y)))
-            (loop for x-arg in (call-arguments x)
-                  for y-arg in (call-arguments y)
-                  unless (ir1=? x-arg y-arg)
-                    return #f
-                  finally (return #t))))
-        ((and (sequence? x) (sequence? y))
-          (and
-            (ir1=? (sequence-head x) (sequence-head y))
-            (ir1=? (sequence-tail x) (sequence-tail y))))
-        ((and (lambda? x) (lambda? 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))
-          (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)))))
+      (expression letrec-expression))))
diff --git a/csc/ir2.csc b/csc/ir2.csc
index 462a4a4..7ab2803 100644
--- a/csc/ir2.csc
+++ b/csc/ir2.csc
@@ -27,7 +27,6 @@
     fix-body
     fix-functions
     fix?
-    ir2=?
     kargs-expression
     kargs-refs
     kargs?
@@ -72,7 +71,6 @@
   (import (scheme base)
           (only (csc ir1)
             constant?
-            ir1=?
             lexical-ref-gensym
             lexical-ref-name
             lexical-ref?
@@ -183,48 +181,4 @@
       fix?
       %fix
       (functions fix-functions)
-      (body fix-body))
-
-
-    (define (atom=? x y)
-      (if (and (variable? x) (variable? y))
-        #t
-        (ir1=? x y)))
-
-
-    (define (closure=? x y)
-      (and (closure? x) (closure? y)
-        (let ((x-args (closure-arguments x))
-              (x-rest (closure-rest x))
-              (y-args (closure-arguments y))
-              (y-rest (closure-rest y)))
-          (and (atom=? (closure-name x) (closure-name y))
-               (= (length x-args) (length y-args))
-               (all atom=? x-args y-args)
-               (or (and (not x-rest) (not y-rest))
-                   (and x-rest y-rest (atom=? x-rest y-rest)))
-               (ir2=? (closure-body x) (closure-body y))))))
-
-
-    (define (ir2=? x y)
-      (match (cons x y)
-        (((% %primitive x-oper x-args x-res x-cont) . (% %primitive y-oper y-args y-res y-cont))
-          (and (symbol=? x-oper y-oper)
-               (= (length x-args) (length y-args))
-               (all atom=? x-args y-args)
-               (= (length x-res) (length y-res))
-               (all atom=? x-res y-res)
-               (ir2=? x-cont y-cont)))
-        (((% %branch x-atom x-true x-false) . (% %branch y-atom y-true y-false))
-          (and (atom=? x-atom y-atom)
-               (ir2=? x-true y-true)
-               (ir2=? x-false y-false)))
-        (((% %apply x-proc x-args) . (% %apply y-proc y-args))
-          (and (atom=? x-proc y-proc)
-               (= (length x-args) (length y-args))
-               (all atom=? x-args y-args)))
-        (((% %fix x-funs x-body) . (% %fix y-funs y-body))
-          (and (= (length x-funs) (length y-funs))
-               (all closure=? x-funs y-funs)
-               (ir2=? x-body y-body)))
-        (_ #f)))))
+      (body fix-body))))
diff --git a/csc/loop.csc b/csc/loop.csc
index dbd6200..ffe0f3f 100644
--- a/csc/loop.csc
+++ b/csc/loop.csc
@@ -16,7 +16,9 @@
     (define-syntax return
       (syntax-rules ()
         ((return expr)
-          (raise (make-return-exception (lambda () expr))))))
+          (raise (make-return-exception (lambda () expr))))
+        ((return)
+          (return #f))))
 
 
     (define-record-type <loop-termination>
diff --git a/csc/macros-test.csc b/csc/macros-test.csc
index db78324..d1b8d2c 100644
--- a/csc/macros-test.csc
+++ b/csc/macros-test.csc
@@ -1,31 +1,70 @@
 (import (scheme base)
+        (only (csc gensym)
+          gensym
+          gensym?)
         (only (csc ir1)
+          %call
+          %constant
+          %define-syntax
+          %if
+          %lambda
+          %letrec
+          %lexical-ref
+          %lexical-set
+          %library-define
+          %library-ref
+          %sequence
+          call?
           constant-expression
           constant?
-          ir1=?
+          define-syntax?
+          if?
+          lambda?
+          letrec?
           lexical-ref-name
           lexical-ref?
           lexical-set-expression
           lexical-set?
+          library-define?
+          library-ref?
           make-constant
+          make-lambda
           make-letrec
           make-lexical-ref
           make-library-ref
-          make-sequence)
+          make-sequence
+          sequence?)
         (only (csc testing)
           assert-equal
           test)
         (csc macros))
 
 
+(define transform-ir1
+  (list
+    (cons constant? %constant)
+    (cons lexical-ref? %lexical-ref)
+    (cons library-ref? %library-ref)
+    (cons lexical-set? %lexical-set)
+    (cons library-define? %library-define)
+    (cons define-syntax? %define-syntax)
+    (cons if? %if)
+    (cons call? %call)
+    (cons sequence? %sequence)
+    (cons lambda? %lambda)
+    (cons letrec? %letrec)
+    (cons gensym? (lambda (x) 'gensym))))
+
+
 (test builtin-quote
-  (assert-equal ir1=?
+  (assert-equal
     (make-constant '(test 1 2 3))
-    (expand '(quote (test 1 2 3)) builtins-environment)))
+    (expand '(quote (test 1 2 3)) builtins-environment)
+    transform-ir1))
 
 
 (test builtin-syntax-rules-literal
-  (assert-equal ir1=?
+  (assert-equal
     (make-constant 1)
     (expand
       '(builtin-let-syntax
@@ -36,11 +75,12 @@
              ((foo b)
                1)))
          (foo b))
-      builtins-environment)))
+      builtins-environment)
+    transform-ir1))
 
 
 (test builtin-syntax-rules-underscore
-  (assert-equal ir1=?
+  (assert-equal
     (make-constant 0)
     (expand
       '(builtin-let-syntax
@@ -48,11 +88,12 @@
            (syntax-rules ()
              ((foo _) 0)))
          (foo ignored))
-      builtins-environment)))
+      builtins-environment)
+    transform-ir1))
 
 
 (test builtin-syntax-rules-substitution
-  (assert-equal ir1=?
+  (assert-equal
     (make-constant 5)
     (expand
       '(builtin-let-syntax
@@ -60,11 +101,12 @@
            (syntax-rules ()
              ((foo x) x)))
          (foo 5))
-      builtins-environment)))
+      builtins-environment)
+    transform-ir1))
 
 
 (test builtin-syntax-rules-nil
-  (assert-equal ir1=?
+  (assert-equal
     (make-constant 1)
     (expand
       '(builtin-let-syntax
@@ -73,11 +115,12 @@
              ((foo x) 0)
              ((foo) 1)))
          (foo))
-      builtins-environment)))
+      builtins-environment)
+    transform-ir1))
 
 
 (test builtin-syntax-rules-improper-list
-  (assert-equal ir1=?
+  (assert-equal
     (make-constant 1)
     (expand
       '(builtin-let-syntax
@@ -85,11 +128,12 @@
            (syntax-rules ()
              ((foo a . b) a)))
          (foo 1 2 3))
-      builtins-environment)))
+      builtins-environment)
+    transform-ir1))
 
 
 (test builtin-syntax-rules-quoted
-  (assert-equal ir1=?
+  (assert-equal
     (make-constant 'a)
     (expand
       '(builtin-let-syntax
@@ -97,11 +141,12 @@
            (syntax-rules ()
              ((foo x) (quote x))))
          (foo a))
-      builtins-environment)))
+      builtins-environment)
+    transform-ir1))
 
 
 (test builtin-syntax-rules-constant
-  (assert-equal ir1=?
+  (assert-equal
     (make-constant 2)
     (expand
       '(builtin-let-syntax
@@ -111,11 +156,12 @@
              ((foo "def") 1)
              ((foo "ghi") 2)))
          (foo "ghi"))
-      builtins-environment)))
+      builtins-environment)
+    transform-ir1))
 
 
 (test builtin-syntax-rules-ellipsis
-  (assert-equal ir1=?
+  (assert-equal
     (make-constant 5)
     (expand
       '(builtin-let-syntax
@@ -123,11 +169,12 @@
            (syntax-rules ()
              ((foo x ...) (x ...))))
          (foo quote 5))
-      builtins-environment)))
+      builtins-environment)
+    transform-ir1))
 
 
 (test builtin-syntax-rules-ellipsis-improper
-  (assert-equal ir1=?
+  (assert-equal
     (make-constant 5)
     (expand
       '(builtin-let-syntax
@@ -135,11 +182,12 @@
            (syntax-rules ()
              ((foo x ... . y) (x ... y))))
          (foo quote . 5))
-      builtins-environment)))
+      builtins-environment)
+    transform-ir1))
 
 
 (test builtin-syntax-rules-ellipsis-zip
-  (assert-equal ir1=?
+  (assert-equal
     (make-constant '((1 . 3) (2 . 4)))
     (expand
       '(builtin-let-syntax
@@ -148,11 +196,12 @@
              ((zip (x ...) (y ...))
                (quote ((x . y) ...)))))
          (zip (1 2) (3 4)))
-      builtins-environment)))
+      builtins-environment)
+    transform-ir1))
 
 
 (test builtin-syntax-rules-ellipsis-nested
-  (assert-equal ir1=?
+  (assert-equal
     (make-constant '(1 2 3 4 5))
     (expand
       '(builtin-let-syntax
@@ -161,11 +210,12 @@
              ((append (x ...) ...)
                (quote (x ... ...)))))
          (append (1 2) (3 4) () (5)))
-      builtins-environment)))
+      builtins-environment)
+    transform-ir1))
 
 
 (test builtin-syntax-rules-ellipsis-custom
-  (assert-equal ir1=?
+  (assert-equal
     (make-constant 5)
     (expand
       '(builtin-let-syntax
@@ -173,33 +223,40 @@
            (syntax-rules ::: ()
              ((foo x :::) (x :::))))
          (foo quote 5))
-      builtins-environment)))
+      builtins-environment)
+    transform-ir1))
+
+
+(define (test-ref sym)
+  (make-lexical-ref sym (gensym)))
 
 
 (test builtin-lambda-rest
-  (assert-equal ir1=?
+  (assert-equal
     (make-lambda (list
-                   (make-lexical-ref 'a #f)
-                   (make-lexical-ref 'b #f)
-                   (make-lexical-ref 'c #f))
-                 (make-lexical-ref 'd #f)
+                   (test-ref 'a)
+                   (test-ref 'b)
+                   (test-ref 'c))
+                 (test-ref 'd)
                  (make-sequence (make-constant #f) (make-constant 5)))
     (expand
       '(lambda
          (a b c . d) (quote 5))
-      builtins-environment)))
+      builtins-environment)
+    transform-ir1))
 
 
 (test builtin-case-lambda-defines
-  (assert-equal ir1=?
-    (make-lambda (list (make-lexical-ref 'x #f)) #f
+  (assert-equal
+    (make-lambda (list (test-ref 'x)) #f
       (make-letrec #t '(a b) #f
         (list (make-constant 6)
-              (make-lexical-ref 'a #f))
+              (test-ref 'a))
         (make-sequence (make-constant #f) (make-constant 7))))
     (expand
       '(lambda (x)
         (builtin-define a (quote 6))
         (builtin-define b a)
         (quote 7))
-      builtins-environment)))
+      builtins-environment)
+    transform-ir1))
diff --git a/csc/match.csc b/csc/match.csc
index ad9b56a..f6ed477 100644
--- a/csc/match.csc
+++ b/csc/match.csc
@@ -25,7 +25,7 @@
             (define (matcher x)
               (unless (predicate x)
                 (raise *no-match*))
-              (list (field-getter* x) ...))))))
+              (list (cons 'type 'name) (cons 'field-name* (field-getter* x)) ...))))))
 
 
     (define-syntax match-pattern
@@ -51,7 +51,7 @@
              (match-pattern (car y) pattern result result* ...)
              (raise *no-match*))))
         ((match-pattern x (% record-matcher . patterns) result result* ...)
-          (match-pattern (record-matcher x) patterns result result* ...))
+          (match-pattern (map cdr (cdr (record-matcher x))) patterns result result* ...))
         ((match-pattern x (pattern . rest) result result* ...)
          (let ((y x))
            (if (pair? y)
diff --git a/csc/strings-test.csc b/csc/strings-test.csc
index 2e6d240..49f8d20 100644
--- a/csc/strings-test.csc
+++ b/csc/strings-test.csc
@@ -44,6 +44,30 @@
     (assert (not-found-error? got-exception))))
 
 
+(test contains
+  (assert-equal
+    #t
+    (contains "abc" "b")))
+
+
+(test doesnt-contain
+  (assert-equal
+    #f
+    (contains "abc" "d")))
+
+
+(test contains-empty
+  (assert-equal
+    #t
+    (contains "" "")))
+
+
+(test empty-contains
+  (assert-equal
+    #f
+    (contains "" "a")))
+
+
 (test join-,
   (assert-equal "a,b,c" (join "," "a" "b" "c")))
 
@@ -58,3 +82,14 @@
 
 (test join-empty
   (assert-equal "abc" (join "" "a" "b" "c")))
+
+
+(test split-empty
+  (assert-equal '("") (split "" " ")))
+
+(test split
+  (assert-equal '("a" "b") (split "a b" " ")))
+
+
+(test split-trailing-empty
+  (assert-equal '("a" "") (split "a " " ")))
diff --git a/csc/strings.csc b/csc/strings.csc
index 737c91b..0259697 100644
--- a/csc/strings.csc
+++ b/csc/strings.csc
@@ -1,14 +1,17 @@
 (define-library (csc strings)
   (export
+    contains
     find
     join
     not-found-error?
     prefix?
+    split
     str-quote)
   (import (scheme base)
           (only (scheme case-lambda) case-lambda)
           (only (scheme write) write)
-          (only (csc list) intercalate))
+          (only (csc list) intercalate)
+          (only (csc loop) loop))
   (begin
 
 
@@ -42,5 +45,21 @@
                  (else (loop (+ 1 i))))))))
 
 
+    (define (contains s substr)
+      (if (string=? "" substr)
+        #t
+        (guard (e ((not-found-error? e) #f))
+          (find substr s)
+          #t)))
+
+
     (define (join sep . strings)
-      (apply string-append (intercalate sep strings)))))
+      (apply string-append (intercalate sep strings)))
+
+
+    (define (split s sep)
+      (loop for s* = s then (string-copy s* (+ i (string-length sep)))
+            for i = (guard (e ((not-found-error? e) (string-length s*)))
+                      (find sep s*))
+            collect (substring s* 0 i)
+            while (< i (string-length s*))))))
diff --git a/csc/testing.csc b/csc/testing.csc
index ecf5547..e46d300 100644
--- a/csc/testing.csc
+++ b/csc/testing.csc
@@ -6,6 +6,7 @@
     test
     test-main)
   (import (scheme base)
+          (only (csc compare) diff)
           (only (csc format)
             printf
             sprintf))
@@ -59,11 +60,12 @@
 
     (define-syntax assert-equal
       (syntax-rules ()
-        ((assert-equal cmp left right)
-          (let ((x left)
-                (y right))
-            (unless (cmp x y)
-              (fatalf "Fatal:\n  {}\nis not equal to\n  {}.\nleft is\n  {}\nright is\n  {}" 'left 'right x y))))
+        ((assert-equal left right transformers ...)
+          (let* ((x left)
+                 (y right)
+                 (d (diff x y transformers ...)))
+            (unless (string=? "" d)
+              (fatalf "Fatal:\n  {}\nis not equal to\n  {}.\nleft is\n  {}\nright is\n  {}\ndiff (-left +right):\n{}" 'left 'right x y d))))
         ((assert-equal left right)
           (assert-equal equal? left right))))