split up tests into different librariesHEADmaster

4 files changed, 373 insertions, 286 deletions

diff --git a/tests/basic.scm b/tests/basic.scm
new file mode 100644
index 0000000..5f2beea
--- /dev/null
+++ b/tests/basic.scm
@@ -0,0 +1,303 @@
+#| Copyright 2025 Peter McGoron
+ |
+ | Licensed under the Apache License, Version 2.0 (the "License");
+ |
+ | you may not use this file except in compliance with the License.
+ | You may obtain a copy of the License at
+ |
+ |     http://www.apache.org/licenses/LICENSE-2.0
+ |
+ | Unless required by applicable law or agreed to in writing, software
+ | distributed under the License is distributed on an "AS IS" BASIS,
+ | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ | See the License for the specific language governing permissions and
+ | limitations under the License.
+ |#
+
+(define (test-creating-SAHP)
+  (define iref (make-new-SAHP))
+  (define (iref-works-with-vector v)
+    (let loop ((i 0))
+      (cond
+        ((= i (vector-length v)) #t)
+        ((= (vector-ref v i) (iref v i)) (loop (+ i 1)))
+        (else #f))))
+  (define (iref-works-with-bytevector v)
+    (let loop ((i 0))
+      (cond
+        ((= i (bytevector-length v)) #t)
+        ((= (bytevector-u8-ref v i) (iref v i)) (loop (+ i 1)))
+        (else #f))))
+  (define (override-vector-in-dynamic-scope procedure)
+    (lambda (v)
+      (define cntr 0)
+      (parameterize-SAHP ((iref ('vector
+                                 (lambda (v i)
+                                   (set! cntr (+ cntr 1))
+                                   (vector-ref v i)))))
+        (procedure v (lambda () cntr)))))
+  (set-global-SAHP! iref 'vector vector-ref)
+  (set-global-SAHP! iref 'bytevector bytevector-u8-ref)
+  (test-group "iref"
+    (test-group "global scope"
+      (test-group "on vectors"
+        (test-property iref-works-with-vector
+                       (list (vector-generator-of (exact-integer-generator)))))
+      (test-group "on bytevectors"
+        (test-property iref-works-with-bytevector
+                       (list (bytevector-generator))))
+      (test-group "undefined raises error"
+        (test-assert
+         (guard (c
+                 ((SAHP-implementation-not-found-error? c) #t)
+                 (else #f))
+           (iref '() 0)))))
+    (test-group "dynamic scope"
+      (test-group "override in dynamic scope"
+        (let ()
+          (define (impl v cntr)
+            (test-assert "works" (iref-works-with-vector v))
+            (test-equal "counted" (vector-length v) (cntr)))
+          (test-property (override-vector-in-dynamic-scope impl)
+                         (list (vector-generator-of (exact-integer-generator))))))
+      (test-group "override in dynamic scope does not affect other implementations"
+        (let ()
+          (define (impl bc cntr)
+            (test-assert "works" (iref-works-with-bytevector bc))
+            (test-equal "did not count" 0 (cntr)))
+          (test-property (override-vector-in-dynamic-scope impl)
+                         (list (bytevector-generator))))))
+    (test-group "local scope"
+      (test-group "override in local scope doesnt affect global scope"
+        (let ()
+          (define (override v)
+            (define cntr 0)
+            (letrec-SAHP ((iref ('vector
+                                 (lambda (v i)
+                                   (set! cntr (+ cntr 1))
+                                   (vector-ref v i)))))
+              (and (iref-works-with-vector v)
+                   (= cntr 0))))
+          (test-property override
+                         (list (vector-generator-of
+                                (exact-integer-generator))))))
+      (test-group "override in local scope affects lexical scope"
+        (let ()
+          (define (override v)
+            (define cntr 0)
+            (letrec-SAHP ((iref ('vector
+                                 (lambda (v i)
+                                   (set! cntr (+ cntr 1))
+                                   (vector-ref v i)))))
+              (let loop ((i 0))
+                (cond
+                  ((= i (vector-length v)) (= cntr i))
+                  ((= (vector-ref v i) (iref v i)) (loop (+ i 1)))
+                  (else #f)))))
+          (test-property override
+                         (list (vector-generator-of
+                                (exact-integer-generator))))))
+      (test-group "override in local scope overrides dynamic scope"
+        (let ()
+          (define (override v)
+            (define cntr 0)
+            (letrec-SAHP ((iref ('vector
+                                 (lambda (v i)
+                                   (set! cntr (+ cntr 1))
+                                   (vector-ref v i)))))
+              (parameterize-SAHP ((iref ('vector vector-ref)))
+                (let loop ((i 0))
+                  (cond
+                    ((= i (vector-length v)) (= cntr i))
+                    ((= (vector-ref v i) (iref v i)) (loop (+ i 1)))
+                    (else #f))))))
+          (test-property override
+                         (list (vector-generator-of
+                                (exact-integer-generator))))))
+      (test-group "override in local scope only affects that type"
+        (let ()
+          (define (override bv)
+            (define cntr 0)
+            (letrec-SAHP ((iref ('vector
+                                 (lambda (v i)
+                                   (set! cntr (+ cntr 1))
+                                   (vector-ref v i)))))
+              (let loop ((i 0))
+                (cond
+                  ((= i (bytevector-length bv)) (= cntr 0))
+                  ((= (bytevector-u8-ref bv i) (iref bv i)) (loop (+ i 1)))
+                  (else #f)))))
+          (test-property override (list (bytevector-generator))))))))
+
+(define (test-numeric-tower-subtyping)
+  (define sub (make-new-SAHP))
+  (define test-all-numbers
+    (case-lambda
+      (() (test-all-numbers sub))
+      ((sub)
+       (test-group "implemented"
+         (test-property sub (list (gsampling (number-generator)))))
+       (test-assert "not implemented"
+                    (guard (c
+                            (else
+                             (SAHP-implementation-not-found-error? c)))
+                      (sub "not a number")
+                      #f)))))
+  (define test-some-numbers
+    (case-lambda
+      (() (test-some-numbers sub))
+      ((sub)
+       (test-group "exact rationals and integers"
+         (test-property sub
+                        (list (gsampling
+                               (exact-rational-generator)
+                               (exact-integer-generator)))))
+       (test-assert "not for complex"
+                    (guard (c
+                            (else
+                             (SAHP-implementation-not-found-error? c)))
+                      (sub +inf.0))))))
+  (test-group "numeric tower subtyping"
+    (test-group "local scope"
+      (test-group "type expression flow downwards"
+        (letrec-SAHP ((sub ('number (lambda (x) #t))))
+          (test-all-numbers sub)))
+      (test-group "subtypes do not flow upwards"
+        (letrec-SAHP ((sub ('exact-rational (lambda (x) #t))))
+          (test-some-numbers sub))))
+    (test-group "dynamic scope"
+      (test-group "subtypes flow downwards"
+        (parameterize-SAHP ((sub ('number (lambda (x) #t))))
+          (test-all-numbers sub)))
+      (test-group "subtypes do not flow upwards"
+        (parameterize-SAHP ((sub ('exact-rational (lambda (x) #t))))
+          (test-some-numbers sub)))
+      (test-group "local scope overrides dynamic scope subtyping"
+        (parameterize-SAHP ((sub ('number (lambda (x) 1))))
+          (letrec-SAHP ((sub ('exact-rational (lambda (x) 2))))
+            (let ()
+              (define (test-local n)
+                (= 2 (sub n)))
+              (define (test-dynamic n)
+                (= 1 (sub n)))
+              (test-group "local"
+                (test-property test-local
+                               (list
+                                (gsampling (exact-rational-generator)))))
+              (test-group "dynamic"
+                (test-property test-dynamic
+                               (list
+                                (gsampling (inexact-complex-generator)))))))))
+      (test-group "local scope overrides dynamic scope subtyping even with overridable"
+        (parameterize-SAHP ((sub ('number (lambda (x) 1))))
+          (letrec-SAHP ((sub ('exact-rational '(overridable) (lambda (x) 2))))
+            (let ()
+              (define (test-local n)
+                (= 2 (sub n)))
+              (define (test-dynamic n)
+                (= 1 (sub n)))
+              (test-group "local"
+                (test-property test-local
+                               (list
+                                (gsampling (exact-rational-generator)))))
+              (test-group "dynamic"
+                (test-property test-dynamic
+                               (list
+                                (gsampling (inexact-complex-generator))))))))))
+    (test-group "global scope"
+      (let ()
+        (define (test-global n)
+          (= 1 (sub n)))
+        (define (test-dynamic n)
+          (= 2 (sub n)))
+        (define-global-SAHP (sub ('number x))
+          1)
+        (test-group "subtypes flow downwards"
+          (test-all-numbers))
+        (test-group "dynamic scope overrides global scope"
+          (parameterize-SAHP ((sub ('exact-rational (lambda (x) 2))))
+            (test-group "dynamic"
+              (test-property test-dynamic
+                             (list
+                              (gsampling (exact-rational-generator)))))
+            (test-group "global"
+              (test-property test-global
+                             (list
+                              (gsampling (inexact-complex-generator)))))))
+        (test-group "dynamic scope overrides global scope even with overridable"
+          (parameterize-SAHP ((sub ('exact-rational '(overridable) (lambda (x) 2))))
+            (test-group "dynamic"
+              (test-property test-dynamic
+                             (list
+                              (gsampling (exact-rational-generator)))))
+            (test-group "global"
+              (test-property test-global
+                             (list
+                              (gsampling (inexact-complex-generator)))))))
+        (test-group "local scope overrides dynamic scope overrides global scope"
+          (parameterize-SAHP ((sub ('exact-rational (lambda (x) 2))))
+            (letrec-SAHP ((sub ('exact-integer (lambda (x) 3))))
+              (let ()
+                (define (test-local n)
+                  (= 3 (sub n)))
+                (test-group "dynamic"
+                  (test-property test-dynamic
+                                 (list
+                                  (gsampling (exact-rational-generator)))))
+                (test-group "global"
+                  (test-property test-global
+                                 (list
+                                  (gsampling (inexact-complex-generator)))))
+                (test-group "local"
+                  (test-property test-local
+                                 (list
+                                  (gsampling (exact-integer-generator)))))))))
+        (test-group "local scope overrides dynamic scope overrides global scope even when overridable"
+          (parameterize-SAHP ((sub
+                               ('exact-rational
+                                '(overridable)
+                                (lambda (x) 2))))
+            (letrec-SAHP ((sub
+                           ('exact-integer
+                            '(overridable)
+                            (lambda (x) 3))))
+              (let ()
+                (define (test-local n)
+                  (= 3 (sub n)))
+                (test-group "dynamic"
+                  (test-property test-dynamic
+                                 (list
+                                  (gsampling (exact-rational-generator)))))
+                (test-group "global"
+                  (test-property test-global
+                                 (list
+                                  (gsampling (inexact-complex-generator)))))
+                (test-group "local"
+                  (test-property test-local
+                                 (list
+                                  (gsampling (exact-integer-generator)))))))))))))
+
+(define (test-overrides)
+  (define sub (make-new-SAHP))
+  (test-group "overrides"
+    (define-global-SAHP (sub ('exact-rational x))
+      1)
+    (test-group "non-overridable in local scope has precedence over global scope"
+      (letrec-SAHP ((sub ('number (lambda (x) 2))))
+        (test-property (lambda (x) (= (sub x) 2))
+                       (list (gsampling
+                              (inexact-real-generator)
+                              (exact-rational-generator))))))
+    (test-group "override in local scope to global scope"
+      (letrec-SAHP ((sub ('number
+                          '(overridable)
+                          (lambda (x) 2))))
+        (let ()
+          (define (is-local-scope x)
+            (= (sub x) 2))
+          (define (is-global-scope x)
+            (= (sub x) 1))
+          (test-property is-local-scope
+                         (list (inexact-complex-generator)))
+          (test-property is-global-scope
+                         (list (exact-rational-generator))))))))
\ No newline at end of file
diff --git a/tests/basic.sld b/tests/basic.sld
new file mode 100644
index 0000000..91d5abd
--- /dev/null
+++ b/tests/basic.sld
@@ -0,0 +1,29 @@
+#| Copyright 2025 Peter McGoron
+ |
+ | Licensed under the Apache License, Version 2.0 (the "License");
+ |
+ | you may not use this file except in compliance with the License.
+ | You may obtain a copy of the License at
+ |
+ |     http://www.apache.org/licenses/LICENSE-2.0
+ |
+ | Unless required by applicable law or agreed to in writing, software
+ | distributed under the License is distributed on an "AS IS" BASIS,
+ | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ | See the License for the specific language governing permissions and
+ | limitations under the License.
+ |#
+
+(define-library (SAHP test basic)
+  (import (scheme base) (scheme case-lambda)
+          (SAHP) (SAHP test shim) (srfi 64) (srfi 194) (srfi 252))
+  (cond-expand (chicken (import (chicken condition)))
+               (else))
+  (export basic-test)
+  (include "basic.scm")
+  (begin
+    (define (basic-test)
+      (setup-runner)
+      (test-creating-SAHP)
+      (test-numeric-tower-subtyping)
+      (test-overrides))))
diff --git a/tests/run.scm b/tests/run.scm
index 3a5c81a..3148ed0 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -1,4 +1,4 @@
-#| Copyright 2024 Peter McGoron
+#| Copyright 2025 Peter McGoron
  |
  | Licensed under the Apache License, Version 2.0 (the "License");
  |
@@ -14,290 +14,12 @@
  | limitations under the License.
  |#
 
-(import (scheme base)
-        (mcgoron srfi 64)
-        (SAHP)
-        (srfi 64) (srfi 194) (srfi 252))
+(cond-expand
+  (chicken (import r7rs (mcgoron srfi 64)))
+  (else))
 
-(test-runner-factory factory)
-(test-runner-current (test-runner-create))
-(set-verbosity! '(fails group-stack))
+(load "shim.sld")
+(load "basic.sld")
 
-(define iref (make-new-SAHP))
-(set-global-SAHP! iref 'vector vector-ref)
-(set-global-SAHP! iref 'bytevector bytevector-u8-ref)
-
-(define (iref-works-with-vector v)
-  (let loop ((i 0))
-    (cond
-      ((= i (vector-length v)) #t)
-      ((= (vector-ref v i) (iref v i)) (loop (+ i 1)))
-      (else #f))))
-
-(define (iref-works-with-bytevector v)
-  (let loop ((i 0))
-    (cond
-      ((= i (bytevector-length v)) #t)
-      ((= (bytevector-u8-ref v i) (iref v i)) (loop (+ i 1)))
-      (else #f))))
-
-(define (override-vector-in-dynamic-scope procedure)
-  (lambda (v)
-    (define cntr 0)
-    (parameterize-SAHP ((iref ('vector
-                               (lambda (v i)
-                                 (set! cntr (+ cntr 1))
-                                 (vector-ref v i)))))
-      (procedure v (lambda () cntr)))))
-
-(test-group "iref"
-  (test-group "global scope"
-    (test-group "on vectors"
-      (test-property iref-works-with-vector
-                     (list (vector-generator-of (exact-integer-generator)))))
-    (test-group "on bytevectors"
-      (test-property iref-works-with-bytevector
-                     (list (bytevector-generator))))
-    (test-group "undefined raises error"
-      (test-assert
-       (guard (c
-               ((SAHP-implementation-not-found-error? c) #t)
-               (else #f))
-         (iref '() 0)))))
-  (test-group "dynamic scope"
-    (test-group "override in dynamic scope"
-      (define (impl v cntr)
-        (test-assert "works" (iref-works-with-vector v))
-        (test-equal "counted" (vector-length v) (cntr)))
-      (test-property (override-vector-in-dynamic-scope impl)
-                     (list (vector-generator-of (exact-integer-generator)))))
-    (test-group "override in dynamic scope does not affect other implementations"
-      (define (impl bc cntr)
-        (test-assert "works" (iref-works-with-bytevector bc))
-        (test-equal "did not count" 0 (cntr)))
-      (test-property (override-vector-in-dynamic-scope impl)
-                     (list (bytevector-generator)))))
-  (test-group "local scope"
-    (test-group "override in local scope doesnt affect global scope"
-      (define (override v)
-        (define cntr 0)
-        (letrec-SAHP ((iref ('vector
-                             (lambda (v i)
-                               (set! cntr (+ cntr 1))
-                               (vector-ref v i)))))
-          (and (iref-works-with-vector v)
-               (= cntr 0))))
-      (test-property override
-                     (list (vector-generator-of
-                            (exact-integer-generator)))))
-    (test-group "override in local scope affects lexical scope"
-      (define (override v)
-        (define cntr 0)
-        (letrec-SAHP ((iref ('vector
-                             (lambda (v i)
-                               (set! cntr (+ cntr 1))
-                               (vector-ref v i)))))
-          (let loop ((i 0))
-            (cond
-              ((= i (vector-length v)) (= cntr i))
-              ((= (vector-ref v i) (iref v i)) (loop (+ i 1)))
-              (else #f)))))
-      (test-property override
-                     (list (vector-generator-of
-                            (exact-integer-generator)))))
-    (test-group "override in local scope overrides dynamic scope"
-      (define (override v)
-        (define cntr 0)
-        (letrec-SAHP ((iref ('vector
-                             (lambda (v i)
-                               (set! cntr (+ cntr 1))
-                               (vector-ref v i)))))
-          (parameterize-SAHP ((iref ('vector vector-ref)))
-            (let loop ((i 0))
-              (cond
-                ((= i (vector-length v)) (= cntr i))
-                ((= (vector-ref v i) (iref v i)) (loop (+ i 1)))
-                (else #f))))))
-      (test-property override
-                     (list (vector-generator-of
-                            (exact-integer-generator)))))
-    (test-group "override in local scope only affects that type"
-      (define (override bv)
-        (define cntr 0)
-        (letrec-SAHP ((iref ('vector
-                             (lambda (v i)
-                               (set! cntr (+ cntr 1))
-                               (vector-ref v i)))))
-          (let loop ((i 0))
-            (cond
-              ((= i (bytevector-length bv)) (= cntr 0))
-              ((= (bytevector-u8-ref bv i) (iref bv i)) (loop (+ i 1)))
-              (else #f)))))
-      (test-property override (list (bytevector-generator))))))
-
-(test-group "numeric tower subtyping"
-  (define sub (make-new-SAHP))
-  (define test-all-numbers
-    (case-lambda
-      (() (test-all-numbers sub))
-      ((sub)
-       (test-group "implemented"
-         (test-property sub (list (gsampling (number-generator)))))
-       (test-assert "not implemented"
-                    (guard (c
-                            (else
-                             (SAHP-implementation-not-found-error? c)))
-                      (sub "not a number")
-                      #f)))))
-  (define test-some-numbers
-    (case-lambda
-      (() (test-some-numbers sub))
-      ((sub)
-       (test-group "exact rationals and integers"
-         (test-property sub
-                        (list (gsampling
-                               (exact-rational-generator)
-                               (exact-integer-generator)))))
-       (test-assert "not for complex"
-                    (guard (c
-                            (else
-                             (SAHP-implementation-not-found-error? c)))
-                      (sub +inf.0))))))
-  (test-group "local scope"
-    (test-group "type expression flow downwards"
-      (letrec-SAHP ((sub ('number (lambda (x) #t))))
-        (test-all-numbers sub)))
-    (test-group "subtypes do not flow upwards"
-      (letrec-SAHP ((sub ('exact-rational (lambda (x) #t))))
-        (test-some-numbers sub))))
-  (test-group "dynamic scope"
-    (test-group "subtypes flow downwards"
-      (parameterize-SAHP ((sub ('number (lambda (x) #t))))
-        (test-all-numbers sub)))
-    (test-group "subtypes do not flow upwards"
-      (parameterize-SAHP ((sub ('exact-rational (lambda (x) #t))))
-        (test-some-numbers sub)))
-    (test-group "local scope overrides dynamic scope subtyping"
-      (parameterize-SAHP ((sub ('number (lambda (x) 1))))
-        (letrec-SAHP ((sub ('exact-rational (lambda (x) 2))))
-          (define (test-local n)
-            (= 2 (sub n)))
-          (define (test-dynamic n)
-            (= 1 (sub n)))
-          (test-group "local"
-            (test-property test-local
-                           (list
-                            (gsampling (exact-rational-generator)))))
-          (test-group "dynamic"
-            (test-property test-dynamic
-                           (list
-                            (gsampling (inexact-complex-generator))))))))
-    (test-group "local scope overrides dynamic scope subtyping even with overridable"
-      (parameterize-SAHP ((sub ('number (lambda (x) 1))))
-        (letrec-SAHP ((sub ('exact-rational '(overridable) (lambda (x) 2))))
-          (define (test-local n)
-            (= 2 (sub n)))
-          (define (test-dynamic n)
-            (= 1 (sub n)))
-          (test-group "local"
-            (test-property test-local
-                           (list
-                            (gsampling (exact-rational-generator)))))
-          (test-group "dynamic"
-            (test-property test-dynamic
-                           (list
-                            (gsampling (inexact-complex-generator)))))))))
-  (test-group "global scope"
-    (define-global-SAHP (sub ('number x))
-      1)
-    (define (test-global n)
-      (= 1 (sub n)))
-    (define (test-dynamic n)
-      (= 2 (sub n)))
-    (test-group "subtypes flow downwards"
-      (test-all-numbers))
-    (test-group "dynamic scope overrides global scope"
-      (parameterize-SAHP ((sub ('exact-rational (lambda (x) 2))))
-        (test-group "dynamic"
-          (test-property test-dynamic
-                         (list
-                          (gsampling (exact-rational-generator)))))
-        (test-group "global"
-          (test-property test-global
-                         (list
-                          (gsampling (inexact-complex-generator)))))))
-    (test-group "dynamic scope overrides global scope even with overridable"
-      (parameterize-SAHP ((sub ('exact-rational '(overridable) (lambda (x) 2))))
-        (test-group "dynamic"
-          (test-property test-dynamic
-                         (list
-                          (gsampling (exact-rational-generator)))))
-        (test-group "global"
-          (test-property test-global
-                         (list
-                          (gsampling (inexact-complex-generator)))))))
-    (test-group "local scope overrides dynamic scope overrides global scope"
-      (parameterize-SAHP ((sub ('exact-rational (lambda (x) 2))))
-        (letrec-SAHP ((sub ('exact-integer (lambda (x) 3))))
-          (define (test-local n)
-            (= 3 (sub n)))
-          (test-group "dynamic"
-            (test-property test-dynamic
-                           (list
-                            (gsampling (exact-rational-generator)))))
-          (test-group "global"
-            (test-property test-global
-                           (list
-                            (gsampling (inexact-complex-generator)))))
-          (test-group "local"
-            (test-property test-local
-                           (list
-                            (gsampling (exact-integer-generator))))))))
-    (test-group "local scope overrides dynamic scope overrides global scope even when overridable"
-      (parameterize-SAHP ((sub
-                           ('exact-rational
-                            '(overridable)
-                            (lambda (x) 2))))
-        (letrec-SAHP ((sub
-                       ('exact-integer
-                        '(overridable)
-                        (lambda (x) 3))))
-          (define (test-local n)
-            (= 3 (sub n)))
-          (test-group "dynamic"
-            (test-property test-dynamic
-                           (list
-                            (gsampling (exact-rational-generator)))))
-          (test-group "global"
-            (test-property test-global
-                           (list
-                            (gsampling (inexact-complex-generator)))))
-          (test-group "local"
-            (test-property test-local
-                           (list
-                            (gsampling (exact-integer-generator))))))))))
-
-(test-group "overrides"
-  (define sub (make-new-SAHP))
-  (define-global-SAHP (sub ('exact-rational x))
-    1)
-  (test-group "non-overridable in local scope has precedence over global scope"
-    (letrec-SAHP ((sub ('number (lambda (x) 2))))
-      (test-property (lambda (x) (= (sub x) 2))
-                     (list (gsampling
-                            (inexact-real-generator)
-                            (exact-rational-generator))))))
-  (test-group "override in local scope to global scope"
-    (letrec-SAHP ((sub ('number
-                        '(overridable)
-                        (lambda (x) 2))))
-      (define (is-local-scope x)
-        (= (sub x) 2))
-      (define (is-global-scope x)
-        (= (sub x) 1))
-      (test-property is-local-scope
-                     (list (inexact-complex-generator)))
-      (test-property is-global-scope
-                     (list (exact-rational-generator))))))
-
-;;; TODO: tests of override
+(import (SAHP test basic))
+(basic-test)
diff --git a/tests/shim.sld b/tests/shim.sld
new file mode 100644
index 0000000..1ac18a6
--- /dev/null
+++ b/tests/shim.sld
@@ -0,0 +1,33 @@
+#| Copyright 2025 Peter McGoron
+ |
+ | Licensed under the Apache License, Version 2.0 (the "License");
+ |
+ | you may not use this file except in compliance with the License.
+ | You may obtain a copy of the License at
+ |
+ |     http://www.apache.org/licenses/LICENSE-2.0
+ |
+ | Unless required by applicable law or agreed to in writing, software
+ | distributed under the License is distributed on an "AS IS" BASIS,
+ | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ | See the License for the specific language governing permissions and
+ | limitations under the License.
+ |#
+
+(define-library (SAHP test shim)
+  (import (scheme base))
+  (cond-expand
+    (mcgoron-srfi-64
+     (begin
+       (import (mcgoron srfi 64)
+               (srfi 64))
+       (define (setup-runner)
+         (test-runner-factory factory)
+         (test-runner-current (test-runner-create))
+         (set-verbosity! '(fails group-stack)))))
+    (else
+     (begin
+       (import (srfi 64))
+       (define (setup-runner)
+         (test-runner-current (test-runner-create))))))
+  (export setup-runner))