add hack to support foment and CHICKEN 5.3.0

5 files changed, 128 insertions, 47 deletions

diff --git a/lib/cuprate.define-test-application.scm b/lib/cuprate.define-test-application.scm
new file mode 100644
index 0000000..f28eb37
--- /dev/null
+++ b/lib/cuprate.define-test-application.scm
@@ -0,0 +1,25 @@
+(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-named-application test-name pairs ...)))))))
+
diff --git a/lib/cuprate.scm b/lib/cuprate.scm
index b37afbe..8265571 100644
--- a/lib/cuprate.scm
+++ b/lib/cuprate.scm
@@ -306,51 +306,67 @@
 ;;; 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
+(define-syntax test-named-application
   (syntax-rules ()
     ((_ test-name (%name %expr) ...)
-     (test-application "generate" test-name ((%name %expr) ...) ()))
+     (test-named-application "generate" test-name ((%name %expr) ...) ()))
     ((_ "generate" test-name ((#f expr) rest ...) (acc ...))
-     (test-application "generate" test-name (rest ...) ((tmp expr) acc ...)))
+     (test-named-application "generate" test-name (rest ...) ((tmp expr) acc ...)))
     ((_ "generate" test-name ((sym expr) rest ...) (acc ...))
-     (test-application "generate" test-name (rest ...)
+     (test-named-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 ...) ()))
+     (test-named-application "reverse" test-name (acc ...) ()))
     ((_ "reverse" test-name (a b ...) (c ...))
-     (test-application "reverse" test-name (b ...) (a c ...)))
+     (test-named-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-application
+  (syntax-rules ()
+    ((_ test-name (%fun expr ...))
+     (test-application "generate-temporaries"
+                       test-name
+                       1
+                       (expr ...)
+                       (tmp)
+                       ((tmp (let ((tmp %fun))
+                               (test-set! 'fun tmp)
+                               tmp)))))
+    ((_ "generate-temporaries" test-name n (e expr ...) (tmps ...) (bindings ...))
+     (test-application "generate-temporaries"
+                       test-name
+                       (+ n 1)
+                       (expr ...)
+                       (tmp tmps ...)
+                       ((tmp (let ((tmp e))
+                               (test-set! (string->symbol
+                                           (string-append
+                                            "arg-"
+                                            (number->string n)))
+                                          e)))
+                        bindings ...)))
+    ((_ "generate-temporaries" test-name _ () (tmps ...) bindings)
+     (test-application "reverse"
+                       test-name
+                       (tmps ...)
+                       ()
+                       bindings))
+    ((_ "reverse" test-name (a b ...) (c ...) bindings)
+     (test-application "reverse"
+                       test-name
+                       (b ...)
+                       (a c ...)
+                       bindings))
+    ((_ "reverse" test-name () form bindings)
+     (call-as-test test-name
+                   (lambda ()
+                     (let bindings (test-set! 'success? form)))))))
+
 (define-syntax test-body
   (syntax-rules ()
     ((_ name body ...)
diff --git a/lib/cuprate.simple-define-test-application.scm b/lib/cuprate.simple-define-test-application.scm
new file mode 100644
index 0000000..463364a
--- /dev/null
+++ b/lib/cuprate.simple-define-test-application.scm
@@ -0,0 +1,39 @@
+;;; Some buggy implementations do not rename temporaries on the left
+;;; hand side of a syntax-rules application. This is for implementations
+;;; that cannot work around this issue with a low-level mcaro system.
+;;; 
+;;; This shim is used to support the essential cases. This can be extended
+;;; to support more cases as desired.
+
+(define-syntax define-test-application
+  (syntax-rules ()
+    ((_ name ((predicate) value))
+     (define-syntax name
+       (syntax-rules ()
+         ((_ tmp) (name #f tmp))
+         ((_ test-name tmp)
+          (test-named-application test-name (#f predicate) (value tmp))))))
+    ((_ name (predicate value))
+     (define-syntax name
+       (syntax-rules ()
+         ((_ tmp1 tmp2) (name #f tmp1 tmp2))
+         ((_ test-name tmp1 tmp2)
+          (test-named-application test-name (predicate tmp1) (value tmp2))))))
+    ((_ name ((predicate) expected actual))
+     (define-syntax name
+       (syntax-rules ()
+         ((_ tmp1 tmp2) (name #f tmp1 tmp2))
+         ((_ test-name tmp1 tmp2)
+          (test-named-application test-name (#f predicate) (expected tmp1) (actual tmp2))))))
+    ((_ name (predicate expected actual))
+     (define-syntax name
+       (syntax-rules ()
+         ((_ tmp0 tmp1 tmp2) (name #f tmp0 tmp1 tmp2))
+         ((_ test-name tmp0 tmp1 tmp2)
+          (test-named-application test-name (predicate tmp0) (expected tmp1) (actual tmp2))))))
+    ((_ name ((predicate) a1 a2 a3))
+     (define-syntax name
+       (syntax-rules ()
+         ((_ t1 t2 t3) (name #f t1 t2 t3))
+         ((_ test-name t1 t2 t3)
+          (test-named-application test-name (#f predicate) (a1 t1) (a2 t2) (a3 t3))))))))
\ No newline at end of file
diff --git a/lib/cuprate.sld b/lib/cuprate.sld
index 41847ed..abd1bc1 100644
--- a/lib/cuprate.sld
+++ b/lib/cuprate.sld
@@ -20,7 +20,8 @@
    default-on-exception-in-group
    ;; SRFI-64 style assertions
    call-as-test call-as-group
-   test-application test-body
+   define-test-application test-predicate test-binary
+   test-named-application test-application test-body
    define-test-application
    test-equal test-eqv test-eq test-approximate
    test-error expect-to-fail
@@ -35,16 +36,16 @@
       test-info?
       (dict unwrap-test-info set-test-info!))
     (define assertion-violation error))
+  (cond-expand
+    ((or foment chicken-5) (include "cuprate.simple-define-test-application.scm"))
+    (else (include "cuprate.define-test-application.scm")))
   ;; Pretty printing
   (cond-expand
     (chicken (import (only (chicken pretty-print) pretty-print)))
-    (foment (import (srfi 166))
-            (begin (define (pretty-print obj)
-                     (show #t (pretty obj))
-                     (newline))))
-    (chibi (import (srfi 166))
-           (begin (define (pretty-print obj)
-                    (show #t (pretty obj)))))
+    ((or foment chibi) (import (srfi 166))
+                           (begin (define (pretty-print obj)
+                                    (show #t (pretty obj))
+                                    (newline))))
     (gauche (import (scheme show))
             (begin (define (pretty-print obj)
                      (show #t (pretty obj)))))
diff --git a/lib/cuprate/rewriters/foment.sld b/lib/cuprate/rewriters/foment.sld
index 6f88ea5..248e2ef 100644
--- a/lib/cuprate/rewriters/foment.sld
+++ b/lib/cuprate/rewriters/foment.sld
@@ -7,18 +7,18 @@
   (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)))
-        `(error (type ,(test-rewrite (error-object-type error)))
-                (who ,(test-rewrite (error-object-who error)))
-                (kind ,(test-rewrite (error-object-kind error)))
-                (msg ,(test-rewrite (error-object-message error)))
-                (irritants ,@(map test-rewrite (error-object-irritants error))))))
+        `(error (type ,(rewrite (error-object-type error)))
+                (who ,(rewrite (error-object-who error)))
+                (kind ,(rewrite (error-object-kind error)))
+                (msg ,(rewrite (error-object-message error)))
+                (irritants ,@(map rewrite (error-object-irritants error))))))
     (define rewriters
       (make-parameter `((,pair? . ,default-on-pair)
                         (,vector? . ,default-on-vector)