test local scope override of dynamic scope subtyping

1 files changed, 197 insertions, 0 deletions

diff --git a/tests/run.scm b/tests/run.scm
new file mode 100644
index 0000000..392dac6
--- /dev/null
+++ b/tests/run.scm
@@ -0,0 +1,197 @@
+#| Copyright 2024 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.
+ |#
+
+(import (scheme base)
+        (mcgoron srfi 64)
+        (SAHP)
+        (srfi 64) (srfi 252))
+
+(test-runner-factory factory)
+(test-runner-current (test-runner-create))
+(set-verbosity! '(fails group-stack))
+
+(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 "subtyping"
+  (define sub (make-new-SAHP))
+  (define (test-for-all)
+    (test-assert "exact integer" (sub 0))
+    (test-assert "integer" (sub 1.0))
+    (test-assert "rational" (sub 1/2))
+    (test-assert "real" (sub +inf.0))
+    (test-assert "complex" (sub 1+2i))
+    (test-assert "not implemented"
+                 (guard (c
+                         (else
+                          (SAHP-implementation-not-found-error? c)))
+                   (sub "not a number")
+                   #f)))
+  (define (test-for-some)
+    (test-assert "exact integer" (sub 0))
+    (test-assert "integer" (sub 1.0))
+    (test-assert "rational" (sub 1/2))
+    (test-assert "not for complex"
+                 (guard (c
+                         (else
+                          (SAHP-implementation-not-found-error? c)))
+                   (sub +inf.0))))
+  (test-group "local scope"
+    (test-group "subtypes flow downwards"
+      (letrec-SAHP ((sub ('number (lambda (x) #t))))
+        (test-assert "exact integer" (sub 0))
+        (test-assert "integer" (sub 1.0))
+        (test-assert "rational" (sub 1/2))
+        (test-assert "real" (sub +inf.0))
+        (test-assert "complex" (sub 1+2i))
+        (test-assert "not implemented"
+                     (guard (c
+                             (else
+                              (SAHP-implementation-not-found-error? c)))
+                       (sub "not a number")
+                       #f))))
+    (test-group "subtypes do not flow upwards"
+      (letrec-SAHP ((sub ('rational (lambda (x) #t))))
+        (test-assert "exact integer" (sub 0))
+        (test-assert "integer" (sub 1.0))
+        (test-assert "rational" (sub 1/2))
+        (test-assert "not for complex"
+                     (guard (c
+                             (else
+                              (SAHP-implementation-not-found-error? c)))
+                       (sub +inf.0))))))
+  (test-group "dynamic scope"
+    (test-group "subtypes flow downwards"
+      (parameterize-SAHP ((sub ('number (lambda (x) #t))))
+        (test-for-all)))
+    (test-group "subtypes do not flow upwards"
+      (parameterize-SAHP ((sub ('rational (lambda (x) #t))))
+        (test-for-some)))
+    (test-group "local scope overrides dynamic scope subtyping"
+      (parameterize-SAHP ((sub ('number (lambda (x) 1))))
+        (letrec-SAHP ((sub ('rational (lambda (x) 2))))
+          (test-equal 2 (sub 0))
+          (test-equal 2 (sub 1/2))
+          (test-equal 1 (sub 1+2i)))))))