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

1 files changed, 49 insertions, 40 deletions

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 ()