start moving implementation-dependent code into separate libraries

2 files changed, 2 insertions, 276 deletions

diff --git a/compat/micro-srfi-225/srfi/225.scm b/compat/micro-srfi-225/srfi/225.scm
deleted file mode 100644
index 0e563d6..0000000
--- a/compat/micro-srfi-225/srfi/225.scm
+++ /dev/null
@@ -1,267 +0,0 @@
-#| © 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
index 9e97d76..69274d8 100644
--- a/compat/micro-srfi-225/srfi/225.sld
+++ b/compat/micro-srfi-225/srfi/225.sld
@@ -1,5 +1,5 @@
 (define-library (srfi 225)
-  (import (scheme base) (scheme case-lambda) (scheme write))
+  (import (micro-srfi-225))
   (export
    eqv-alist-dto
    ;; predicates
@@ -49,11 +49,4 @@
    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
+   dictionary-irritants))
\ No newline at end of file