make macro generators, test on chibi. Currently broken in CHICKEN-5 due to a bug in compiled syntax-rules macros

8 files changed, 70 insertions, 50 deletions

diff --git a/cuprate.egg b/cuprate.egg
index 90c7d09..875c533 100644
--- a/cuprate.egg
+++ b/cuprate.egg
@@ -10,6 +10,10 @@
                (component-dependencies cuprate.rewriters)
                (csc-options "-R" "r7rs" "-X" "r7rs"))
              (extension cuprate.rewriters
-               (source "lib/cuprate/rewriters.chicken.sld")
+               (source "lib/cuprate/rewriters.sld")
+               (component-dependencies cuprate.rewriters.chicken)
+               (csc-options "-R" "r7rs" "-X" "r7rs"))
+             (extension cuprate.rewriters.chicken
+               (source "lib/cuprate/rewriters/chicken.sld")
                (csc-options "-R" "r7rs" "-X" "r7rs"))
                )))
diff --git a/lib/cuprate.scm b/lib/cuprate.scm
index 72b74e6..b37afbe 100644
--- a/lib/cuprate.scm
+++ b/lib/cuprate.scm
@@ -306,16 +306,50 @@
 ;;; Wrappers and semi-compatability with SRFI-64
 ;;; ;;;;;;;;;;;;
 
+(define-syntax define-test-application
+  (syntax-rules ()
+    ((_ name (args ...))
+     (define-test-application "loop" name (args ...) () ()))
+    ((_ "loop" name ((default) args ...) (rest ...) ids)
+     (define-test-application "loop" name (args ...)
+       ((#f default) rest ...) ids))
+    ((_ "loop" name (arg args ...) (rest ...) (ids ...))
+     (define-test-application "loop" name (args ...)
+       ((arg tmp) rest ...) (tmp ids ...)))
+    ((_ "loop" name () stuff ids)
+     (define-test-application "reverse1" name stuff ids ()))
+    ((_ "reverse1" name (pair rest ...) ids (acc ...))
+     (define-test-application "reverse1" name (rest ...) ids (pair acc ...)))
+    ((_ "reverse1" name () ids pairs)
+     (define-test-application "reverse2" name ids () pairs))
+    ((_ "reverse2" name (id1 id2 ...) (acc ...) pairs)
+     (define-test-application "reverse2" name (id2 ...) (id1 acc ...) pairs))
+    ((_ "reverse2" name () (ids ...) (pairs ...))
+     (define-syntax name
+       (syntax-rules ...* ()
+         ((_ ids ...) (name #f ids ...))
+         ((_ test-name ids ...)
+          (test-application test-name pairs ...)))))))
+
 (define-syntax test-application
   (syntax-rules ()
-    ((_ test-name (name expr) ...)
-     (call-as-test test-name (lambda ()
-                               (test-set! 'form (quote (expr ...)))
-                               (let ((name (let ((tmp expr))
-                                             (test-set! (quote name) tmp)
-                                             tmp))
-                                     ...)
-                                 (test-set! 'success? (name ...))))))))
+    ((_ test-name (%name %expr) ...)
+     (test-application "generate" test-name ((%name %expr) ...) ()))
+    ((_ "generate" test-name ((#f expr) rest ...) (acc ...))
+     (test-application "generate" test-name (rest ...) ((tmp expr) acc ...)))
+    ((_ "generate" test-name ((sym expr) rest ...) (acc ...))
+     (test-application "generate" test-name (rest ...)
+                       ((sym (let ((tmp expr))
+                               (test-set! (quote sym) tmp)
+                               tmp)) acc ...)))
+    ((_ "generate" test-name () (acc ...))
+     (test-application "reverse" test-name (acc ...) ()))
+    ((_ "reverse" test-name (a b ...) (c ...))
+     (test-application "reverse" test-name (b ...) (a c ...)))
+    ((_ "reverse" test-name () ((name expr) ...))
+     (call-as-test test-name
+                   (lambda ()
+                     (let ((name expr) ...) (test-set! 'success? (name ...))))))))
 
 (define-syntax test-body
   (syntax-rules ()
@@ -324,42 +358,17 @@
                           (test-set! 'success?
                                      (let () body ...)))))))
 
-(define-syntax test-equal
-  (syntax-rules ()
-    ((_ name %expected %actual)
-     (test-application name
-                       (procedure equal?)
-                       (expected %expected)
-                       (actual %actual)))))
-
-(define-syntax test-eqv
-  (syntax-rules ()
-    ((_ name %expected %actual)
-     (test-application name
-                       (procedure eqv?)
-                       (expected %expected)
-                       (actual %actual)))))
-
-
-(define-syntax test-eq
-  (syntax-rules ()
-    ((_ name %expected %actual)
-     (test-application name
-                       (procedure eq?)
-                       (expected %expected)
-                       (actual %actual)))))
+(define-test-application test-equal ((equal?) expected actual))
+(define-test-application test-eqv ((eqv?) expected actual))
+(define-test-application test-eq ((eq?) expected actual))
+(define-test-application test-predicate (predicate value))
+(define-test-application test-binary (predicate expected actual))
 
 (define (%test-approximate expected actual error)
   (<= (abs (- expected actual)) error))
 
-(define-syntax test-approximate
-  (syntax-rules ()
-    ((_ name %expected %actual %error)
-     (test-application name
-                       (procedure %test-approximate)
-                       (expected %expected)
-                       (actual %actual)
-                       (error %error)))))
+(define-test-application test-approximate
+  ((%test-approximate) expected actual error))
 
 (define-syntax test-error
   (syntax-rules ()
diff --git a/lib/cuprate.sld b/lib/cuprate.sld
index 9b7e166..41847ed 100644
--- a/lib/cuprate.sld
+++ b/lib/cuprate.sld
@@ -21,6 +21,7 @@
    ;; SRFI-64 style assertions
    call-as-test call-as-group
    test-application test-body
+   define-test-application
    test-equal test-eqv test-eq test-approximate
    test-error expect-to-fail
    test-skip-all
@@ -58,6 +59,6 @@
                (define (alist->default-dictionary x)
                  (alist->hashmap (make-default-comparator) x))))
     (else (begin
-            (define default-test-info-dto eqv-alist-dto)
+            (define default-test-dto eqv-alist-dto)
             (define (alist->default-dictionary x) x))))
   (include "cuprate.scm"))
\ No newline at end of file
diff --git a/lib/cuprate/rewriters.sld b/lib/cuprate/rewriters.sld
new file mode 100644
index 0000000..a375cc8
--- /dev/null
+++ b/lib/cuprate/rewriters.sld
@@ -0,0 +1,7 @@
+(define-library (cuprate rewriters)
+  (import (scheme base))
+  (export rewriters rewrite)
+  (cond-expand
+    (chicken-5 (import (cuprate rewriters chicken)))
+    (foment (import (cuprate rewriters foment)))
+    (else (import (cuprate rewriters r7rs)))))
\ No newline at end of file
diff --git a/lib/cuprate/rewriters.chicken.sld b/lib/cuprate/rewriters/chicken.sld
index 82a275c..f92f998 100644
--- a/lib/cuprate/rewriters.chicken.sld
+++ b/lib/cuprate/rewriters/chicken.sld
@@ -1,4 +1,4 @@
-(define-library (cuprate rewriters)
+(define-library (cuprate rewriters chicken)
   (import (scheme base) (scheme write)
           (chicken memory representation)
           (chicken condition))
diff --git a/lib/cuprate/rewriters.foment.sld b/lib/cuprate/rewriters/foment.sld
index 24c26d8..6f88ea5 100644
--- a/lib/cuprate/rewriters.foment.sld
+++ b/lib/cuprate/rewriters/foment.sld
@@ -1,4 +1,4 @@
-(define-library (cuprate rewriters)
+(define-library (cuprate rewriters foment)
   (import (scheme base)
           (only (foment base)
                 error-object-type
diff --git a/lib/cuprate/rewriters.r7rs.sld b/lib/cuprate/rewriters/r7rs.sld
index 3996db6..b231f81 100644
--- a/lib/cuprate/rewriters.r7rs.sld
+++ b/lib/cuprate/rewriters/r7rs.sld
@@ -1,12 +1,12 @@
-(define-library (cuprate rewriters)
+(define-library (cuprate rewriters r7rs)
   (import (scheme base))
-  (export rewriiters rewrite)
+  (export rewriters rewrite)
   (begin
     (define (default-on-pair pair)
-      (cons (test-rewrite (car pair))
-            (test-rewrite (cdr pair))))
+      (cons (rewrite (car pair))
+            (rewrite (cdr pair))))
     (define (default-on-vector vec)
-      (vector-map test-rewrite vec))
+      (vector-map rewrite vec))
     (define (default-on-error error)
       (let ((msg (error-object-message error))
             (irritants (error-object-irritants error)))
diff --git a/tests/impl.scm b/tests/impl.scm
index 27e3b72..840d590 100644
--- a/tests/impl.scm
+++ b/tests/impl.scm
@@ -114,7 +114,6 @@
   (test-group "after test"
     (let ((called? #f)
           (pair (cons #f #f)))
-      (define inside-test-info)
       (test-body "after test is called with previous test-info"
         (parameterize ((test-info
                         (dict-set! (test-dto) dummy-dict