TR7

7 files changed, 385 insertions, 37 deletions

diff --git a/README.md b/README.md
index 0be6336..415f16b 100644
--- a/README.md
+++ b/README.md
@@ -8,8 +8,13 @@ to not affect the rest of the test system.
 TODO: excise all conditional inclusion by turning them into library
 forms. This will pave the way for porting to R6RS.
 
-Cuprate supports CHICKEN-5, Foment, Chibi, SKINT, Gauche, and Sagittarius.
-TR7, STKLOS, Mosh, Chez, Guile, Racket, and Loko support soon.
+implementation-specific things (sans `define-test-application`, which is
+a hack) are put into implementation libraries that export all relevant
+identifiers. Rewriters take a first argument that is the rewritng closure,
+that can do cycle detection.
+
+Cuprate supports TR7, CHICKEN-5, Foment, Chibi, SKINT, Gauche, and
+Sagittarius. STKLOS, Mosh, Chez, Guile, Racket, and Loko support soon.
 
 ## API
 
@@ -197,35 +202,56 @@ to rewrite it in a low-level macro system. (If your implementation does
 not offer a low-level macro system, then bug the maintainer of your
 implementation to fix hygiene in their macro expander.)
 
+This library requires SRFI-225. In the `compat` directory there is a
+partial implementation of SRFI-225 that only works with alists, called
+`micro-srfi-225`, that only requires base R6RS/R7RS. You can use this if
+all you need is to run the tests.
+
 ## Instructions Per Implementation
 
-### CHICKEN
+### CHICKEN-5
 
-Just run `chicken-install cuprate`. Because of a bug with compiled
-syntax-rules patterns, `define-test-application` has limited support.
+There is an SRFI-225 port for CHICKEN-5, so just run `chicken-install
+cuprate`. Because of a bug with compiled syntax-rules patterns,
+`define-test-application` has limited support.
 
 ### Foment
 
-You will need `srfi-225`. The [reference implementation][SRFI-225] will
-work out of the box. Test bodies cannot return multiple values.
+Tested with the latest checkout as of 2025-11-03.
 
-[SRFI-225]: https://github.com/scheme-requests-for-implementation/srfi-225
+The reference implementation SRFI-225 will work out of the box. Test
+bodies cannot return multiple values. Because of a bug with compiled
+syntax-rules patterns, `define-test-application` has limited support.
 
 ### Chibi
 
-You will need `srfi-225`.
+Tested with 0.10.
+
+The reference implementation of SRFI-225 will work out of the box.
 
 ### TR7
 
-I tried but there were some issues with loading sublibraries.
+Tested to work with 2.0.7.
+
+To use SRFI-225, you will also need SRFI-128. Mini-SRFI-225 will also
+work here.
+
+There is an issue with `call/cc` escaping out of `parameterize`d blocks.
+This doesn't affect any of the test cases, but this may break some code.
 
 ### Gauche
 
-You will need `srfi-225`. I had to explicitly remove some of the conditional
-exports from the reference implementation of SRFI 225 in order to get it
-to work.
+Tested with 0.9.15.
+
+I had to explicitly remove some of the conditional exports from the
+reference implementation of SRFI 225 in order to get it to work.
 
 ### SKINT
 
 Tested to work on SKINT 0.6.7, with SRFIs. SKINT bundles SRFI-225, so all
 you need to do is point SKINT to `lib` to use `cuprate`.
+
+### STKlos
+
+STKlos currently does not include files from the directory of the library.
+This will probably be fixed in 2.11, but that has not been released yet.
diff --git a/compat/micro-srfi-225/srfi/225.scm b/compat/micro-srfi-225/srfi/225.scm
new file mode 100644
index 0000000..0e563d6
--- /dev/null
+++ b/compat/micro-srfi-225/srfi/225.scm
@@ -0,0 +1,267 @@
+#| © 2021 John Cowan, Arvydas Silanskas.
+     2025 Peter McGoron (additions)
+
+Permission is hereby granted, free of charge, to any person obtaining a
+copy of this software and associated documentation files (the "Software"),
+to deal in the Software without restriction, including without limitation
+the rights to use, copy, modify, merge, publish, distribute, sublicense,
+and/or sell copies of the Software, and to permit persons to whom the
+Software is furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice (including the next
+paragraph) shall be included in all copies or substantial portions of the
+Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
+THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+DEALINGS IN THE SOFTWARE.
+ |#
+
+(define eqv-alist-dto (vector #f))
+(define (dto? x) (eq? x eqv-alist-dto))
+(define (dto-ref dto proc-id)
+  (error 'dto-ref "not supported in micro-srfi-225" dto proc-id))
+
+(define (dict-contains? dto dict key)
+  (cond
+    ((assv key dict) #t)
+    (else #f)))
+
+(define (dict=? dto = dict1 dict2)
+  (let loop ((dict1 dict1)
+             (dict2 dict2))
+    (cond
+      ((and (null? dict1) (null? dict2)) #t)
+      ((or (null? dict1) (null? dict2)) #f)
+      (else (and (eqv? (caar dict1) (caar dict2))
+                 (= (cdar dict1) (cdar dict2))
+                 (loop (cdr dict1) (cdr dict2)))))))
+
+(define (dictionary? dto l)
+  (or (null? l)
+      (and (pair? (car l))
+           (dictionary? dto (cdr l)))))
+
+(define (dict-pure? dto alist) #t)
+
+(define (dict-map dto proc alist)
+  (map
+   (lambda (e)
+     (define key (car e))
+     (define value (cdr e))
+     (cons key (proc key value)))
+   alist))
+
+(define (dict-filter dto pred alist)
+  (let loop ((alist alist))
+    (cond
+      ((null? alist) '())
+      ((pred (caar alist) (cdar alist))
+       (cons (car alist) (loop (cdr alist))))
+      (else (loop (cdr alist))))))
+
+(define (dict-remove dto pred alist)
+  (dict-filter dto (lambda (x y) (not (pred x y))) alist))
+
+(define (dict-count dto pred dict)
+  (do ((dict dict (cdr dict))
+       (count 0 (if (pred (caar dict) (cdar dict))
+                    (+ count 1)
+                    count)))
+      ((null? dict) count)))
+
+(define (dict-any dto pred dict)
+  (let loop ((dict dict))
+    (cond
+      ((null? dict) #f)
+      (else (or (pred (caar dict) (cdar dict))
+                (loop (cdr dict)))))))
+
+(define (dict-every dto pred dict)
+  (let loop ((dict dict))
+    (cond
+      ((null? dict) #t)
+      (else (and (pred (caar dict) (cdar dict))
+                 (loop (cdr dict)))))))
+
+(define (dict-keys dto dict) (map car dict))
+(define (dict-values dto dict) (map cdr dict))
+(define (dict-entries dto dict)
+  (values (map car dict)
+          (map cdr dict)))
+
+(define (dict-fold dto proc knil dict)
+  (if (null? dict)
+      knil
+      (dict-fold dto proc (proc (caar dict) (cdar dict) knil)
+                 (cdr dict))))
+
+(define (dict-map->list dto proc dict)
+  (map (lambda (pair) (proc (car pair) (cdr pair))) dict))
+
+(define (dict-for-each dto proc dict)
+  (for-each (lambda (pair) (proc (car pair) (cdr pair))) dict))
+
+(define (dict->generator dto dict)
+  (lambda ()
+    (if (null? dict)
+        (eof-object)
+        (let ((pair (car dict)))
+          (set! dict (cdr dict))
+          pair))))
+
+(define (dict-set!-accumulator dto dict)
+  (lambda (pair)
+    (cond
+      ((pair? pair)
+       (set! dict (dict-set! dto dict (car pair) (cdr pair))))
+      ((eof-object? pair) dict)
+      (else (error 'dict-set!-accumulator "not a pair" pair)))))
+
+(define (dict-adjoin!-accumulator dto dict)
+  (lambda (pair)
+    (cond
+      ((pair? pair)
+       (set! dict (dict-adjoin! dto dict (car pair) (cdr pair))))
+      ((eof-object? pair) dict)
+      (else (error 'dict-adjoin!-accumulator "not a pair" pair)))))
+
+(define (dict-delete-all! dto alist keys)
+  (dict-remove dto
+               (lambda (key value) (memv key keys))
+               alist))
+
+(define (dict-delete! dto alist . keys)
+  (dict-delete-all! dto alist keys))
+
+(define (default-dict-intern! dto dictionary key failure)
+  (dict-find-update! dto dictionary key
+                     (lambda (insert _)
+                       (let ((value (failure)))
+                         (values (insert value) value)))
+                     (lambda (key value update _)
+                       (values dictionary value))))
+
+(define (dict-find-update! dto alist key failure success)
+  (define (handle-success pair)
+    (define old-key (car pair))
+    (define old-value (cdr pair))
+    (define (update new-key new-value)
+      (cond
+        ((and (eq? old-key new-key)
+              (eq? old-value new-value))
+         alist)
+        (else
+         (cons (cons new-key new-value)
+               (dict-delete! dto alist old-key)))))
+    (define (remove)
+      (dict-delete! dto alist old-key))
+    (success old-key old-value update remove))
+  (define (handle-failure)
+    (define (insert value)
+      (cons (cons key value) alist))
+    (define (ignore)
+      alist)
+    (failure insert ignore))
+  (cond
+    ((assv key alist) => handle-success)
+    (else (handle-failure))))
+
+(define (dict-pop! dto dictionary)
+  (define (do-pop)
+    (call/cc
+     (lambda (cont)
+       (dict-for-each dto
+                      (lambda (key value)
+                        (define new-dict
+                          (dict-delete-all! dto dictionary (list key)))
+                        (cont new-dict key value))
+                      dictionary))))
+  (define empty? (dict-empty? dto dictionary))
+  (if empty?
+      (error 'dict-pop! "popped empty dictionary")
+      (do-pop)))
+
+(define dict-update!
+  (case-lambda
+    ((dto dict key updater)
+     (dict-update! dto dict key updater
+                   (lambda () (error 'dict-update! "key not found" dto dict key))))
+    ((dto dict key updater failure)
+     (dict-update! dto dict key updater failure values))
+    ((dto dictionary key updater failure success)
+     (dict-find-update! dto dictionary key
+                        (lambda (insert ignore)
+                          (insert (updater (failure))))
+                        (lambda (key value update _)
+                          (update key (updater (success value))))))))
+
+(define (dict-update/default! dto dictionary key updater default)
+  (dict-update! dto dictionary key updater
+                (lambda () default)
+                (lambda (x) x)))
+
+
+(define dict-ref
+  (case-lambda
+    ((dto dict key)
+     (dict-ref dto dict key (lambda () (error 'dict-ref
+                                              "key not found"
+                                              dto dict key))))
+    ((dto dict key failure)
+     (dict-ref dto dict key failure values))
+    ((dto dict key failure success)
+     (cond
+       ((assv key dict) => (lambda (x) (success (cdr x))))
+       (else (failure))))))
+
+(define (dict-ref/default dto dict key default)
+  (cond
+    ((assv key dict) => cdr)
+    (else default)))
+
+(define dict-set!
+  (case-lambda
+    ((dto dict) dict)
+    ((dto dict key value . rest)
+     (apply dict-set!
+            dto
+            (dict-find-update! dto dict key
+                               (lambda (insert ignore) (insert value))
+                               (lambda (key old-value update remove) (update key value)))
+            rest))))
+
+(define dict-adjoin!
+  (case-lambda
+    ((dto dict) dict)
+    ((dto dict key value . rest)
+     (apply dict-set!
+            dto
+            (dict-find-update! dto dict key
+                               (lambda (insert ignore) (insert value))
+                               (lambda (key old-value update remove) dict))
+            rest))))
+
+(define (dict-size dto alist) (length alist))
+(define (dict-empty? dto alist) (null? alist))
+(define (dict->alist dto alist) alist)
+(define (dict-comparator dto dictionary) #f)
+
+(define (dict-replace! dto dictionary key value)
+  (dict-find-update! dto dictionary key
+                     (lambda (_ ignore)
+                       (ignore))
+                     (lambda (key old-value update _)
+                       (update key value))))
+
+(define (dict-intern! dto dictionary key failure)
+  (dict-find-update! dto dictionary key
+                     (lambda (insert _)
+                       (let ((value (failure)))
+                         (values (insert value) value)))
+                     (lambda (key value update _)
+                       (values dictionary value))))
\ No newline at end of file
diff --git a/compat/micro-srfi-225/srfi/225.sld b/compat/micro-srfi-225/srfi/225.sld
new file mode 100644
index 0000000..9e97d76
--- /dev/null
+++ b/compat/micro-srfi-225/srfi/225.sld
@@ -0,0 +1,59 @@
+(define-library (srfi 225)
+  (import (scheme base) (scheme case-lambda) (scheme write))
+  (export
+   eqv-alist-dto
+   ;; predicates
+   dictionary?
+   dict-empty?
+   dict-contains?
+   dict=?
+   dict-pure?
+   ;; lookup
+   dict-ref
+   dict-ref/default
+   dict-comparator
+   ;; mutation
+   dict-set!
+   dict-adjoin!
+   dict-delete!
+   dict-delete-all!
+   dict-replace!
+   dict-intern!
+   dict-update!
+   dict-update/default!
+   dict-pop!
+   dict-map
+   dict-filter
+   dict-remove
+   dict-find-update!
+   ;; whole dictionary
+   dict-size
+   dict-count
+   dict-any
+   dict-every
+   dict-keys
+   dict-values
+   dict-entries
+   dict-fold
+   dict-map->list
+   dict->alist
+   ;; iteration
+   dict-for-each
+   dict->generator
+   dict-set!-accumulator
+   dict-adjoin!-accumulator
+   ;; dictionary type descriptors
+   dto?
+   dto-ref
+   ;; exceptions
+   dictionary-error
+   dictionary-error?
+   dictionary-message
+   dictionary-irritants)
+  (begin
+    (define-record-type <derror>
+      (dictionary-error message irritants)
+      dictionary-error?
+      (message dictionary-message)
+      (irritants dictionary-irritants)))
+  (include "225.scm"))
\ No newline at end of file
diff --git a/lib/cuprate-impl.scm b/lib/cuprate-impl.scm
index 8265571..94f1902 100644
--- a/lib/cuprate-impl.scm
+++ b/lib/cuprate-impl.scm
@@ -276,7 +276,7 @@
      (tests . 0)
      (name . #f)
      (name-stack . ())
-     (never-print-dto . ,equal-alist-dto)
+     (never-print-dto . ,default-test-dto)
      (pretty-print . ,pretty-print)
      (never-print . ,(map (lambda (x) (cons x x))
                           '(skip-test? when-test-skipped before-test! setup-test!
@@ -433,8 +433,7 @@
 
 (define (test-exit)
   (display "==== EXITING TEST SUITE =====\n")
-  (call-with-values (lambda () (inspect-test-info values))
-    display-report)
+  (display-report (test-info-dict))
   (exit (if (zero? (test-ref/default 'failed 0))
             0
             1)))
diff --git a/tests/chibi.sh b/tests/chibi.sh
index 6f77933..47ab2c1 100755
--- a/tests/chibi.sh
+++ b/tests/chibi.sh
@@ -1,3 +1,3 @@
 #!/bin/sh
 
-chibi-scheme -A "../lib" -A "../compat/srfi-225" -l run.scm
+chibi-scheme -A "../lib" -A "../compat/micro-srfi-225" -l run.scm
diff --git a/tests/impl.scm b/tests/impl.scm
index 0047e34..a4ad2b3 100644
--- a/tests/impl.scm
+++ b/tests/impl.scm
@@ -151,25 +151,22 @@
       (and called? (not (test-contains? 'setup-test-test)))))
   (test-group "on-exception"
     (test-body "not called"
-      (call/cc
-       (lambda (return)
-         (define inside-test-info
-           (dict-set! (test-dto)
-                      dummy-dict
-                      'exception-not-called?
-                      #t
-                      'on-exception-in-test
-                      (lambda (exn return)
-                        (test-set! 'exception-not-called? #f)
-                        (return))
-                      'after-test
-                      (lambda (previous-dict)
-                        (return (dict-ref (test-dto)
-                                          previous-dict
-                                          'exception-not-called?)))))
-         (parameterize ((test-info inside-test-info))
-           (call-as-test #f (lambda () #f)))
-         #f)))
+      (define inside-test-info
+        (dict-set! (test-dto)
+                   dummy-dict
+                   'exception-not-called?
+                   #t
+                   'on-exception-in-test
+                   (lambda (exn return)
+                     (test-set! 'exception-not-called? #f)
+                     (return))
+                   'after-test
+                   (lambda (previous-dict)
+                     (dict-ref (test-dto)
+                               previous-dict
+                               'exception-not-called?))))
+      (parameterize ((test-info inside-test-info))
+        (call-as-test #f (lambda () #f))))
     (let* ((message "exception message")
            (caught #f))
       (test-body "called"
diff --git a/tests/tr7.sh b/tests/tr7.sh
index 2aad823..d47dbe5 100755
--- a/tests/tr7.sh
+++ b/tests/tr7.sh
@@ -1,3 +1,3 @@
 #!/bin/sh
 
-TR7_EXT_PATH=".sld" TR7_LIB_PATH="../lib:../compat/srfi-225" tr7i run.scm
+TR7_LIB_PATH="../lib:../compat/micro-srfi-225" tr7i run.scm