split up tests into different librariesHEADmaster

1 files changed, 8 insertions, 286 deletions

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)