add hack to support foment and CHICKEN 5.3.0

1 files changed, 47 insertions, 31 deletions

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