TR7

2 files changed, 326 insertions, 0 deletions

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