summaryrefslogtreecommitdiffstats
path: root/srfi
diff options
context:
space:
mode:
authorGravatar John Cowan 2021-11-07 13:26:39 -0500
committerGravatar John Cowan 2021-11-07 13:26:39 -0500
commit4a41fcd464fd24b700196bd00e7633050229d192 (patch)
treeaafee35678d420ded7346f8137ee20808ec5ba37 /srfi
parenteditorial (diff)
parentfix 'remove' test (diff)
Merge remote-tracking branch 'arvyy/master'
Diffstat (limited to '')
-rw-r--r--srfi-125-impl.scm93
-rw-r--r--srfi-126-impl.scm122
-rw-r--r--srfi-225-test.scm1039
-rw-r--r--srfi-225.html4
-rw-r--r--srfi-69-impl.scm88
-rw-r--r--srfi/225.sld197
-rw-r--r--srfi/alist-impl.scm88
-rw-r--r--srfi/assumptions.scm7
-rw-r--r--srfi/default-impl.scm440
-rw-r--r--srfi/externals.scm183
-rw-r--r--srfi/indexes.scm53
-rw-r--r--srfi/plist-impl.scm111
-rw-r--r--srfi/srfi-125-impl.scm172
-rw-r--r--srfi/srfi-126-impl.scm157
-rw-r--r--srfi/srfi-146-hash-impl.scm64
-rw-r--r--srfi/srfi-146-impl.scm64
-rw-r--r--srfi/srfi-69-impl.scm105
17 files changed, 2682 insertions, 305 deletions
diff --git a/srfi-125-impl.scm b/srfi-125-impl.scm
deleted file mode 100644
index 67da668..0000000
--- a/srfi-125-impl.scm
+++ /dev/null
@@ -1,93 +0,0 @@
-(define (register-srfi-125!)
-
- (define (hash-table-set!* table . obj)
- (apply hash-table-set! (cons table obj))
- table)
-
- (define (hash-table-update!* table key updater fail success)
- (hash-table-update! table key updater fail success)
- table)
-
- (define (hash-table-update!/default* table key proc default)
- (hash-table-update!/default table key proc default)
- table)
-
- (define (hash-table-intern!* table key failure)
- (define val (hash-table-intern! table key failure))
- (values table val))
-
- (define (hash-table-pop!* table)
- (if (hash-table-empty? table)
- (error "popped empty dictionary")
- (call-with-values
- (lambda () (hash-table-pop! table))
- (lambda (key value) (values table key value)))))
-
- (define (hash-table-delete-all!* table keys)
- (for-each
- (lambda (key)
- (hash-table-delete! table key))
- keys)
- table)
-
- (define (hash-table-map!* proc table)
- (hash-table-map! proc table)
- table)
-
- (define (hash-table-filter* proc table)
- (hash-table-prune!
- (lambda (key value)
- (not (proc key value)))
- table)
- table)
-
- (define (hash-table-remove!* proc table)
- (hash-table-prune! proc table)
- table)
-
- (define (hash-table-search* table key fail success)
- (define (handle-success value)
- (define (update new-key new-value obj)
- (unless (eq? new-key key)
- (hash-table-delete! table key))
- (hash-table-set! table new-key new-value)
- (values table obj))
- (define (remove obj)
- (hash-table-delete! table key)
- (values table obj))
- (success key value update remove))
- (define (handle-fail)
- (define (ignore obj)
- (values table obj))
- (define (insert value obj)
- (hash-table-set! table key value)
- (values table obj))
- (fail insert ignore))
-
- (define default (cons #f #f))
- (hash-table-ref table key handle-fail handle-success))
-
- (register-dictionary!
- 'dictionary? hash-table?
- 'dict-empty? hash-table-empty?
- 'dict-contains? hash-table-contains?
- 'dict-ref hash-table-ref
- 'dict-ref/default hash-table-ref/default
- 'dict-set! hash-table-set!*
- 'dict-delete-all! hash-table-delete-all!*
- 'dict-intern! hash-table-intern!*
- 'dict-update! hash-table-update!*
- 'dict-update/default! hash-table-update!/default*
- 'dict-pop! hash-table-pop!*
- 'dict-map! hash-table-map!*
- 'dict-filter! hash-table-filter*
- 'dict-remove! hash-table-remove!*
- 'dict-search! hash-table-search*
- 'dict-size hash-table-size
- 'dict-for-each hash-table-for-each
- 'dict-keys hash-table-keys
- 'dict-values hash-table-values
- 'dict-entries hash-table-entries
- 'dict-fold hash-table-fold
- 'dict-map->list hash-table-map->list
- 'dict->alist hash-table->alist))
diff --git a/srfi-126-impl.scm b/srfi-126-impl.scm
deleted file mode 100644
index 1ba75eb..0000000
--- a/srfi-126-impl.scm
+++ /dev/null
@@ -1,122 +0,0 @@
-(define (register-srfi-126!)
-
- (define (hashtable-ref* table key fail success)
- (define-values (value found?) (hashtable-lookup table key))
- (if found?
- (success value)
- (fail)))
-
- (define (hashtable-ref/default* table key default)
- (hashtable-ref table key default))
-
- (define (hashtable-set!* table . obj)
- (let loop ((obj obj))
- (if (null? obj)
- table
- (begin
- (hashtable-set! table (car obj) (cadr obj))
- (loop (cddr obj))))))
-
- (define (hashtable-delete-all!* table keys)
- (for-each
- (lambda (key)
- (hashtable-delete! table key))
- keys)
- table)
-
- (define (hashtable-intern!* table key default)
- (define val (hashtable-intern! table key default))
- (values table val))
-
- (define (hashtable-update/default!* table key updater default)
- (hashtable-update! table key updater default)
- table)
-
- (define (hashtable-pop!* table)
- (if (hashtable-empty? table)
- (error "popped empty dictionary")
- (call-with-values
- (lambda () (hashtable-pop! table))
- (lambda (key value) (values table key value)))))
-
- (define (hashtable-update-all!* proc table)
- (hashtable-update-all! table proc)
- table)
-
- (define (hashtable-filter!* proc table)
- (hashtable-prune! table
- (lambda (key value)
- (not (proc key value))))
- table)
-
- (define (hashtable-remove!* proc table)
- (hashtable-prune! table proc)
- table)
-
- (define (hashtable-search* table key fail success)
- (define (handle-success value)
- (define (update new-key new-value obj)
- (unless (eq? new-key key)
- (hashtable-delete! table key))
- (hashtable-set! table new-key new-value)
- (values table obj))
- (define (remove obj)
- (hashtable-delete! table key)
- (values table obj))
- (success key value update remove))
- (define (handle-fail)
- (define (ignore obj)
- (values table obj))
- (define (insert value obj)
- (hashtable-set! table key value)
- (values table obj))
- (fail insert ignore))
-
- (define default (cons #f #f))
- (define found (hashtable-ref table key default))
- (if (eq? default found)
- (handle-fail)
- (handle-success found)))
-
- (define (hashtable-for-each* proc table)
- (hashtable-walk table proc)
- table)
-
- (define (hashtable-map->lset* proc table)
- (hashtable-map->lset table proc))
-
- (define (hashtable-keys* table)
- (vector->list (hashtable-keys table)))
-
- (define (hashtable-values* table)
- (vector->list (hashtable-values table)))
-
- (define (hashtable-entries* table)
- (call-with-values
- (lambda () (hashtable-entries table))
- (lambda (keys vals)
- (values
- (vector->list keys)
- (vector->list vals)))))
-
- (register-dictionary!
- 'dictionary? hashtable?
- 'dict-empty? hashtable-empty?
- 'dict-contains? hashtable-contains?
- 'dict-ref hashtable-ref*
- 'dict-ref/default hashtable-ref/default*
- 'dict-set! hashtable-set!*
- 'dict-delete-all! hashtable-delete-all!*
- 'dict-intern! hashtable-intern!*
- 'dict-update/default! hashtable-update/default!*
- 'dict-pop! hashtable-pop!*
- 'dict-map! hashtable-update-all!*
- 'dict-filter! hashtable-filter!*
- 'dict-remove! hashtable-remove!*
- 'dict-search! hashtable-search*
- 'dict-size hashtable-size
- 'dict-for-each hashtable-for-each*
- 'dict-keys hashtable-keys*
- 'dict-values hashtable-values*
- 'dict-entries hashtable-entries*
- 'dict-map->list hashtable-map->lset*))
diff --git a/srfi-225-test.scm b/srfi-225-test.scm
new file mode 100644
index 0000000..9de1e7b
--- /dev/null
+++ b/srfi-225-test.scm
@@ -0,0 +1,1039 @@
+(import (scheme base)
+ (scheme case-lambda)
+ (scheme write)
+ (srfi 1)
+ (srfi 128)
+ (srfi 158)
+ (srfi 225))
+
+(cond-expand
+ ((library (srfi 69))
+ (import (prefix (srfi 69) t69-)))
+ (else))
+
+(cond-expand
+ ((library (srfi 125))
+ (import (prefix (srfi 125) t125-)))
+ (else))
+
+(cond-expand
+ ((library (srfi 126))
+ (import (prefix (srfi 126) t126-)))
+ (else))
+
+(cond-expand
+ ((and (library (srfi 146))
+ (library (srfi 146 hash)))
+ (import (srfi 146)
+ (srfi 146 hash)))
+ (else))
+
+(cond-expand
+ (chibi
+ (import (rename (except (chibi test) test-equal)
+ (test test-equal)
+ (test-group test-group*)))
+ (define test-skip-count 0)
+ (define (test-skip n)
+ (set! test-skip-count n))
+ (define-syntax test-group
+ (syntax-rules ()
+ ((_ name body ...)
+ (test-group*
+ name
+ (if (> test-skip-count 0)
+ (set! test-skip-count (- test-skip-count 1))
+ (let ()
+ body ...)))))))
+ (else
+ (import (srfi 64))))
+
+;; returns new wrapper dtd
+;; which counts how often each dtd's method was called
+;; verify that all functions were tested
+(define (wrap-dtd dtd)
+ (define proc-count (+ 1 dict-adjoin-accumulator-id))
+ (define counter (make-vector proc-count 0))
+ (define wrapper-dtd-args
+ (let loop ((indexes (iota proc-count))
+ (args '()))
+ (if (null? indexes)
+ args
+ (let* ((index (car indexes))
+ (real-proc (dtd-ref dtd index))
+ (wrapper-proc (lambda args
+ (vector-set! counter index (+ 1 (vector-ref counter index)))
+ (apply real-proc args))))
+ (loop (cdr indexes)
+ (append (list index wrapper-proc)
+ args))))))
+ (values
+ (apply make-dtd wrapper-dtd-args)
+ counter))
+
+(define (test-for-each expect-success for-each-proc expected-keys)
+ (call/cc (lambda (cont)
+ (with-exception-handler
+ (lambda (err)
+ (unless expect-success
+ (cont #t)))
+ (lambda ()
+ (define lst '())
+ (for-each-proc
+ (lambda (key value)
+ (set! lst (append lst (list key)))))
+ (test-equal (length lst) (length expected-keys))
+ (for-each
+ (lambda (key)
+ (test-assert (find (lambda (key*) (equal? key key*))
+ expected-keys)))
+ lst))))))
+
+(define (do-test real-dtd alist->dict comparator mutable?)
+
+ (define-values
+ (dtd counter)
+ (wrap-dtd real-dtd))
+
+ (test-group
+ "dictionary?"
+ (test-assert (not (dictionary? dtd 'foo)))
+ (test-assert (dictionary? dtd (alist->dict '())))
+ (test-assert (dictionary? dtd (alist->dict '((a . b))))))
+
+ (test-group
+ "dict-empty?"
+ (test-assert (dict-empty? dtd (alist->dict '())))
+ (test-assert (not (dict-empty? dtd (alist->dict '((a . b)))))))
+
+ (test-group
+ "dict-contains?"
+ (test-assert (not (dict-contains? dtd (alist->dict '()) 'a)))
+ (test-assert (not (dict-contains? dtd (alist->dict '((b . c))) 'a)))
+ (test-assert (dict-contains? dtd (alist->dict '((a . b))) 'a)))
+
+ (test-group
+ "dict=?"
+ (define dict1 (alist->dict '((a . 1) (b . 2))))
+ (define dict2 (alist->dict '((b . 2) (a . 1))))
+ (define dict3 (alist->dict '((a . 1))))
+ (define dict4 (alist->dict '((a . 2) (b . 2))))
+
+ (test-assert (dict=? dtd = dict1 dict2))
+ (test-assert (not (dict=? dtd = dict1 dict3)))
+ (test-assert (not (dict=? dtd = dict3 dict1)))
+ (test-assert (not (dict=? dtd = dict1 dict4)))
+ (test-assert (not (dict=? dtd = dict4 dict1))))
+
+ (test-group
+ "dict-ref"
+ (test-assert (dict-ref dtd (alist->dict '((a . b))) 'a (lambda () #f) (lambda (x) #t)))
+ (test-assert (dict-ref dtd (alist->dict '((a . b))) 'b (lambda () #t) (lambda (x) #f))))
+
+ (test-group
+ "dict-ref/default"
+ (test-equal (dict-ref/default dtd (alist->dict '((a . b))) 'a 'c) 'b)
+ (test-equal (dict-ref/default dtd (alist->dict '((a* . b))) 'a 'c) 'c))
+
+ (test-group
+ "dict-min-key"
+ (define dict (alist->dict '((2 . a) (1 . b) (3 . c))))
+ (call/cc (lambda (cont)
+ (with-exception-handler
+ (lambda (err)
+ (unless (let* ((cmp (dict-comparator dtd (alist->dict '())))
+ (ordering (and cmp (comparator-ordering-predicate cmp))))
+ ordering)
+ (cont #t)))
+ (lambda ()
+ (define key (dict-min-key dtd dict))
+ (test-equal 1 key))))))
+
+ (test-group
+ "dict-max-key"
+ (define dict (alist->dict '((2 . a) (3 . b) (1 . c))))
+ (call/cc (lambda (cont)
+ (with-exception-handler
+ (lambda (err)
+ (unless (let* ((cmp (dict-comparator dtd (alist->dict '())))
+ (ordering (and cmp (comparator-ordering-predicate cmp))))
+ ordering)
+ (cont #t)))
+ (lambda ()
+ (define key (dict-max-key dtd dict))
+ (test-equal 3 key))))))
+
+ (when mutable?
+ (test-skip 1))
+ (test-group
+ "dict-set"
+ (define dict-original (alist->dict '((a . b))))
+ (define d (dict-set dtd dict-original 'a 'c 'a2 'b2))
+ (test-equal 'c (dict-ref dtd d 'a ))
+ (test-equal 'b2 (dict-ref dtd d 'a2))
+ (test-equal 'b (dict-ref dtd dict-original' a))
+ (test-equal #f (dict-ref/default dtd dict-original 'a2 #f)))
+
+ (unless mutable?
+ (test-skip 1))
+ (test-group
+ "dict-set!"
+ (define d (dict-set! dtd (alist->dict '((a . b))) 'a 'c 'a2 'b2))
+ (test-equal 'c (dict-ref dtd d 'a ))
+ (test-equal 'b2 (dict-ref dtd d 'a2)))
+
+ (when mutable?
+ (test-skip 1))
+ (test-group
+ "dict-adjoin"
+ (define dict-original (alist->dict '((a . b))))
+ (define d (dict-adjoin dtd dict-original 'a 'c 'a2 'b2))
+ (test-equal 'b (dict-ref dtd d 'a))
+ (test-equal 'b2 (dict-ref dtd d 'a2))
+ (test-equal #f (dict-ref/default dtd dict-original 'a2 #f)))
+
+ (unless mutable?
+ (test-skip 1))
+ (test-group
+ "dict-adjoin!"
+ (define d (dict-adjoin! dtd (alist->dict '((a . b))) 'a 'c 'a2 'b2))
+ (test-equal 'b (dict-ref dtd d 'a))
+ (test-equal 'b2 (dict-ref dtd d 'a2)))
+
+ (when mutable?
+ (test-skip 1))
+ (test-group
+ "dict-delete"
+ (define dict-original (alist->dict '((a . b) (c . d))))
+ (define d (dict-delete dtd dict-original 'a 'b))
+ (test-equal (dict->alist dtd d) '((c . d)))
+ (test-equal 'b (dict-ref dtd dict-original 'a)))
+
+ (unless mutable?
+ (test-skip 1))
+ (test-group
+ "dict-delete!"
+ (define d (dict-delete! dtd (alist->dict '((a . b) (c . d))) 'a 'b))
+ (test-equal (dict->alist dtd d) '((c . d))))
+
+ (when mutable?
+ (test-skip 1))
+ (test-group
+ "dict-delete-all"
+ (define dict-original (alist->dict '((a . b) (c . d))))
+ (define d (dict-delete-all dtd dict-original '(a b)))
+ (test-equal (dict->alist dtd d) '((c . d)))
+ (test-equal 'b (dict-ref dtd dict-original 'a)))
+
+ (unless mutable?
+ (test-skip 1))
+ (test-group
+ "dict-delete-all!"
+ (define d (dict-delete-all! dtd (alist->dict '((a . b) (c . d))) '(a b)))
+ (test-equal (dict->alist dtd d) '((c . d))))
+
+ (when mutable?
+ (test-skip 1))
+ (test-group
+ "dict-replace"
+ (define dict-original (alist->dict '((a . b) (c . d))))
+ (define d (dict-replace dtd dict-original 'a 'b2))
+ (test-equal 'b2 (dict-ref dtd d 'a))
+ (test-equal 'd (dict-ref dtd d 'c))
+ (test-equal 'b (dict-ref dtd dict-original 'a)))
+
+ (unless mutable?
+ (test-skip 1))
+ (test-group
+ "dict-replace!"
+ (define d (dict-replace! dtd (alist->dict '((a . b) (c . d))) 'a 'b2))
+ (test-equal 'b2 (dict-ref dtd d 'a))
+ (test-equal 'd (dict-ref dtd d 'c)))
+
+ (when mutable?
+ (test-skip 1))
+ (test-group
+ "dict-intern"
+ ;; intern existing
+ (let ()
+ (define-values
+ (d value)
+ (dict-intern dtd (alist->dict '((a . b))) 'a (lambda () 'd)))
+ (test-equal 'b (dict-ref dtd d 'a))
+ (test-equal 'b value))
+ ;; intern missing
+ (let ()
+ (define dict-original (alist->dict '((a . b))))
+ (define-values
+ (d value)
+ (dict-intern dtd dict-original 'c (lambda () 'd)))
+ (test-equal 'b (dict-ref dtd d 'a))
+ (test-equal 'd (dict-ref dtd d 'c))
+ (test-equal 'd value)
+ (test-equal #f (dict-ref/default dtd dict-original 'c #f))))
+
+ (unless mutable?
+ (test-skip 1))
+ (test-group
+ "dict-intern!"
+ ;; intern existing
+ (let ()
+ (define-values
+ (d value)
+ (dict-intern! dtd (alist->dict '((a . b))) 'a (lambda () 'd)))
+ (test-equal 'b (dict-ref dtd d 'a))
+ (test-equal 'b value))
+ ;; intern missing
+ (let ()
+ (define-values
+ (d value)
+ (dict-intern! dtd (alist->dict '((a . b))) 'c (lambda () 'd)))
+ (test-equal 'b (dict-ref dtd d 'a))
+ (test-equal 'd (dict-ref dtd d 'c))
+ (test-equal 'd value)))
+
+ (when mutable?
+ (test-skip 1))
+ (test-group
+ "dict-update"
+ ;; update existing
+ (define dict-original (alist->dict '((a . "b"))))
+ (let ()
+ (define d (dict-update dtd dict-original 'a
+ (lambda (value)
+ (string-append value "2"))
+ error
+ (lambda (x) (string-append x "1"))))
+ (test-equal "b12" (dict-ref dtd d 'a))
+ (test-equal "b" (dict-ref dtd dict-original 'a)))
+ ;; update missing
+ (let ()
+ (define d (dict-update dtd dict-original 'c
+ (lambda (value)
+ (string-append value "2"))
+ (lambda () "d1")
+ (lambda (x) (string-append x "1"))))
+ (test-equal "d12" (dict-ref dtd d 'c))
+ (test-equal #f (dict-ref/default dtd dict-original 'c #f))))
+
+ (unless mutable?
+ (test-skip 1))
+ (test-group
+ "dict-update!"
+ ;; update existing
+ (let ()
+ (define d (dict-update! dtd (alist->dict '((a . "b"))) 'a
+ (lambda (value)
+ (string-append value "2"))
+ error
+ (lambda (x) (string-append x "1"))))
+ (test-equal "b12" (dict-ref dtd d 'a)))
+ ;; update missing
+ (let ()
+ (define d (dict-update! dtd (alist->dict '((a . "b"))) 'c
+ (lambda (value)
+ (string-append value "2"))
+ (lambda () "d1")
+ (lambda (x) (string-append x "1"))))
+ (test-equal "d12" (dict-ref dtd d 'c))))
+
+ (when mutable?
+ (test-skip 1))
+ (test-group
+ "dict-update/default"
+ ;; update existing
+ (define dict-original (alist->dict '((a . "b"))))
+ (let ()
+ (define d (dict-update/default dtd dict-original 'a
+ (lambda (value)
+ (string-append value "2"))
+ "d1"))
+ (test-equal "b2" (dict-ref dtd d 'a))
+ (test-equal "b" (dict-ref dtd dict-original 'a)))
+
+ ;; update missing
+ (let ()
+ (define d (dict-update/default dtd dict-original 'c
+ (lambda (value)
+ (string-append value "2"))
+ "d1"))
+ (test-equal "d12" (dict-ref dtd d 'c))
+ (test-equal #f (dict-ref/default dtd dict-original 'c #f))))
+
+ (unless mutable?
+ (test-skip 1))
+ (test-group
+ "dict-update/default!"
+ ;; update existing
+ (let ()
+ (define d (dict-update/default! dtd (alist->dict '((a . "b"))) 'a
+ (lambda (value)
+ (string-append value "2"))
+ "d1"))
+ (test-equal "b2" (dict-ref dtd d 'a)))
+
+ ;; update missing
+ (let ()
+ (define d (dict-update/default! dtd (alist->dict '((a . "b"))) 'c
+ (lambda (value)
+ (string-append value "2"))
+ "d1"))
+ (test-equal "d12" (dict-ref dtd d 'c))))
+
+ (when mutable?
+ (test-skip 1))
+ (test-group
+ "dict-pop"
+ (define dict-original (alist->dict '((a . b) (c . d))))
+ (define-values
+ (new-dict key value)
+ (dict-pop dtd dict-original))
+ (test-assert
+ (or
+ (and (equal? (dict->alist dtd new-dict) '((c . d)))
+ (equal? key 'a)
+ (equal? value 'b))
+
+ (and (equal? (dict->alist dtd new-dict) '((a . b)))
+ (equal? key 'c)
+ (equal? value 'd))))
+ (test-assert 'b (dict-ref dtd dict-original 'a))
+ (test-assert 'd (dict-ref dtd dict-original 'c)))
+
+ (unless mutable?
+ (test-skip 1))
+ (test-group
+ "dict-pop!"
+ (define-values
+ (new-dict key value)
+ (dict-pop! dtd (alist->dict '((a . b) (c . d)))))
+ (test-assert
+ (or
+ (and (equal? (dict->alist dtd new-dict) '((c . d)))
+ (equal? key 'a)
+ (equal? value 'b))
+
+ (and (equal? (dict->alist dtd new-dict) '((a . b)))
+ (equal? key 'c)
+ (equal? value 'd)))))
+
+ (when mutable?
+ (test-skip 1))
+ (test-group
+ "dict-map"
+ (define dict-original (alist->dict '((a . "a") (b . "b"))))
+ (define d (dict-map dtd
+ (lambda (key value)
+ (string-append value "2"))
+ dict-original))
+ (test-equal "a2" (dict-ref dtd d 'a))
+ (test-equal "b2" (dict-ref dtd d 'b))
+ (test-equal "a" (dict-ref dtd dict-original 'a))
+ (test-equal "b" (dict-ref dtd dict-original 'b)))
+
+ (unless mutable?
+ (test-skip 1))
+ (test-group
+ "dict-map!"
+ (define d (dict-map! dtd
+ (lambda (key value)
+ (string-append value "2"))
+ (alist->dict '((a . "a") (b . "b")))))
+ (test-equal "a2" (dict-ref dtd d 'a))
+ (test-equal "b2" (dict-ref dtd d 'b)))
+
+ (when mutable?
+ (test-skip 1))
+ (test-group
+ "dict-filter"
+ (define dict-original (alist->dict '((a . b) (c . d))))
+
+ (define d (dict-filter dtd
+ (lambda (key value)
+ (equal? value 'b))
+ dict-original))
+ (test-equal '((a . b)) (dict->alist dtd d))
+ (test-equal 'd (dict-ref dtd dict-original 'c)))
+
+ (unless mutable?
+ (test-skip 1))
+ (test-group
+ "dict-filter!"
+ (define d (dict-filter! dtd
+ (lambda (key value)
+ (equal? value 'b))
+ (alist->dict '((a . b) (c . d)))))
+ (test-equal '((a . b)) (dict->alist dtd d)))
+
+ (when mutable?
+ (test-skip 1))
+ (test-group
+ "dict-remove"
+ (define dict-original (alist->dict '((a . b) (c . d))))
+ (define d (dict-remove dtd
+ (lambda (key value)
+ (equal? value 'b))
+ dict-original))
+ (test-equal '((c . d)) (dict->alist dtd d))
+ (test-equal 'b (dict-ref dtd dict-original 'a)))
+
+ (unless mutable?
+ (test-skip 1))
+ (test-group
+ "dict-remove!"
+ (define d (dict-remove! dtd
+ (lambda (key value)
+ (equal? value 'b))
+ (alist->dict '((a . b) (c . d)))))
+ (test-equal '((c . d)) (dict->alist dtd d)))
+
+ (when mutable?
+ (test-skip 1))
+ (test-group
+ "dict-alter"
+ ;; ignore
+ (let ()
+ (define dict (dict-alter dtd (alist->dict '((a . b))) 'c
+ (lambda (insert ignore)
+ (ignore))
+ (lambda args
+ (error "shouldn't happen"))))
+ (test-equal '((a . b)) (dict->alist dtd dict)))
+
+ ;; insert
+ (let ()
+ (define dict-original (alist->dict '((a . b))))
+ (define dict (dict-alter dtd dict-original 'c
+ (lambda (insert ignore)
+ (insert 'd))
+ (lambda args
+ (error "shouldn't happen"))))
+ (test-equal 'b (dict-ref dtd dict 'a))
+ (test-equal 'd (dict-ref dtd dict 'c))
+ (test-equal #f (dict-ref/default dtd dict-original 'c #f)))
+
+ ;; update
+ (let ()
+ (define dict-original (alist->dict '((a . b))))
+ (define dict (dict-alter dtd dict-original 'a
+ (lambda args
+ (error "shouldn't happen"))
+ (lambda (key value update delete)
+ (update 'a2 'b2))))
+ (test-equal '((a2 . b2)) (dict->alist dtd dict))
+ (test-equal #f (dict-ref/default dtd dict-original 'a2 #f))
+ (test-equal 'b (dict-ref dtd dict-original 'a)))
+
+ ;; delete
+ (let ()
+ (define dict-original (alist->dict '((a . b) (c . d))))
+ (define dict (dict-alter dtd dict-original 'a
+ (lambda args
+ (error "shouldn't happen"))
+ (lambda (key value update delete)
+ (delete))))
+ (test-equal '((c . d)) (dict->alist dtd dict))
+ (test-equal 'b (dict-ref dtd dict-original 'a))))
+
+ (unless mutable?
+ (test-skip 1))
+ (test-group
+ "dict-alter!"
+ ;; ignore
+ (let ()
+ (define dict (dict-alter! dtd (alist->dict '((a . b))) 'c
+ (lambda (insert ignore)
+ (ignore))
+ (lambda args
+ (error "shouldn't happen"))))
+ (test-equal '((a . b)) (dict->alist dtd dict)))
+
+ ;; insert
+ (let ()
+ (define dict (dict-alter! dtd (alist->dict '((a . b))) 'c
+ (lambda (insert ignore)
+ (insert 'd))
+ (lambda args
+ (error "shouldn't happen"))))
+ (test-equal 'b (dict-ref dtd dict 'a))
+ (test-equal 'd (dict-ref dtd dict 'c)))
+
+ ;; update
+ (let ()
+ (define dict (dict-alter! dtd (alist->dict '((a . b))) 'a
+ (lambda args
+ (error "shouldn't happen"))
+ (lambda (key value update delete)
+ (update 'a2 'b2))))
+ (test-equal '((a2 . b2)) (dict->alist dtd dict)))
+
+ ;; delete
+ (let ()
+ (define dict (dict-alter! dtd (alist->dict '((a . b) (c . d))) 'a
+ (lambda args
+ (error "shouldn't happen"))
+ (lambda (key value update delete)
+ (delete))))
+ (test-equal '((c . d)) (dict->alist dtd dict))))
+
+ (test-group
+ "dict-size"
+ (test-equal 2 (dict-size dtd (alist->dict '((a . b) (c . d)))))
+ (test-equal 0 (dict-size dtd (alist->dict '()))))
+
+ (test-group
+ "dict-count"
+ (define count (dict-count dtd
+ (lambda (key value)
+ (equal? value 'b))
+ (alist->dict '((a . b) (c . d)))))
+ (test-equal count 1))
+
+ (test-group
+ "dict-any"
+
+ (let ()
+ (define value
+ (dict-any dtd
+ (lambda (key value)
+ (if (equal? 'b value) 'foo #f))
+ (alist->dict '((a . b) (c . d)))))
+ (test-equal value 'foo))
+
+ (let ()
+ (define value
+ (dict-any dtd
+ (lambda (key value)
+ (if (equal? 'e value) 'foo #f))
+ (alist->dict '((a . b) (c . d)))))
+ (test-equal value #f)))
+
+ (test-group
+ "dict-every"
+ (let ()
+ (define value
+ (dict-every dtd
+ (lambda (key value)
+ (if (equal? 'b value) 'foo #f))
+ (alist->dict '((a . b) (c . b)))))
+ (test-equal value 'foo))
+
+ (let ()
+ (define value
+ (dict-every dtd
+ (lambda (key value)
+ (if (equal? 'b value) 'foo #f))
+ (alist->dict '())))
+ (test-equal value #t))
+
+ (let ()
+ (define value
+ (dict-every dtd
+ (lambda (key value)
+ (if (equal? 'b value) 'foo #f))
+ (alist->dict '((a . b) (c . d)))))
+ (test-equal value #f)))
+
+ (test-group
+ "dict-keys"
+ (define keys
+ (dict-keys dtd (alist->dict '((a . b) (c . d)))))
+ (test-assert
+ (or (equal? '(a c) keys)
+ (equal? '(c a) keys))))
+
+ (test-group
+ "dict-values"
+ (define vals
+ (dict-values dtd (alist->dict '((a . b) (c . d)))))
+ (test-assert
+ (or (equal? '(b d) vals)
+ (equal? '(d b) vals))))
+
+ (test-group
+ "dict-entries"
+ (define-values
+ (keys vals)
+ (dict-entries dtd (alist->dict '((a . b) (c . d)))))
+ (test-assert
+ (or (and (equal? '(a c) keys)
+ (equal? '(b d) vals))
+ (and (equal? '(c a) keys)
+ (equal? '(d b) vals)))))
+
+ (test-group
+ "dict-fold"
+ (define value
+ (dict-fold dtd
+ (lambda (key value acc)
+ (append acc (list key value)))
+ '()
+ (alist->dict '((a . b) (c . d)))))
+ (test-assert
+ (or (equal? '(a b c d) value)
+ (equal? '(c d a b) value))))
+
+ (test-group
+ "dict-map->list"
+ (define lst
+ (dict-map->list dtd
+ (lambda (key value)
+ (string-append (symbol->string key)
+ value))
+ (alist->dict '((a . "b") (c . "d")))))
+ (test-assert
+ (or (equal? '("ab" "cd") lst)
+ (equal? '("cd" "ab") lst))))
+
+ (test-group
+ "dict->alist"
+ (define alist
+ (dict->alist dtd (alist->dict '((a . b) (c . d)))))
+ (test-assert
+ (or (equal? '((a . b) (c . d)) alist)
+ (equal? '((c . d) (a . b)) alist))))
+
+ (test-group
+ "dict-comparator"
+ ;; extremelly basic generic test; more useful specific tests defined separately
+ ;; for each dtd
+ (let ((cmp (dict-comparator dtd (alist->dict '((a . b))))))
+ (test-assert (or (not cmp)
+ (comparator? cmp)))))
+
+ (test-group
+ "dict-for-each"
+ (test-for-each #t
+ (lambda (proc)
+ (dict-for-each dtd
+ proc
+ (alist->dict '((1 . a)
+ (2 . b)
+ (3 . c)
+ (4 . d)))))
+ '(1 2 3 4)))
+
+ (test-group
+ "dict-for-each<"
+ (test-for-each (let* ((cmp (dict-comparator dtd (alist->dict '())))
+ (ordering (and cmp (comparator-ordering-predicate cmp))))
+ ordering)
+ (lambda (proc)
+ (dict-for-each< dtd
+ proc
+ (alist->dict '((1 . a)
+ (2 . b)
+ (3 . c)
+ (4 . d)))
+ 3))
+ '(1 2)))
+
+ (test-group
+ "dict-for-each<="
+ (test-for-each (let* ((cmp (dict-comparator dtd (alist->dict '())))
+ (ordering (and cmp (comparator-ordering-predicate cmp))))
+ ordering)
+ (lambda (proc)
+ (dict-for-each<= dtd
+ proc
+ (alist->dict '((1 . a)
+ (2 . b)
+ (3 . c)
+ (4 . d)))
+ 3))
+ '(1 2 3)))
+
+ (test-group
+ "dict-for-each>"
+ (test-for-each (let* ((cmp (dict-comparator dtd (alist->dict '())))
+ (ordering (and cmp (comparator-ordering-predicate cmp))))
+ ordering)
+ (lambda (proc)
+ (dict-for-each> dtd
+ proc
+ (alist->dict '((1 . a)
+ (2 . b)
+ (3 . c)
+ (4 . d)))
+ 2))
+ '(3 4)))
+
+ (test-group
+ "dict-for-each>="
+ (test-for-each (let* ((cmp (dict-comparator dtd (alist->dict '())))
+ (ordering (and cmp (comparator-ordering-predicate cmp))))
+ ordering)
+ (lambda (proc)
+ (dict-for-each>= dtd
+ proc
+ (alist->dict '((1 . a)
+ (2 . b)
+ (3 . c)
+ (4 . d)))
+ 2))
+ '(2 3 4)))
+
+ (test-group
+ "dict-for-each-in-open-interval"
+ (test-for-each (let* ((cmp (dict-comparator dtd (alist->dict '())))
+ (ordering (and cmp (comparator-ordering-predicate cmp))))
+ ordering)
+ (lambda (proc)
+ (dict-for-each-in-open-interval dtd
+ proc
+ (alist->dict '((1 . a)
+ (2 . b)
+ (3 . c)
+ (4 . d)))
+ 1 4))
+ '(2 3)))
+
+ (test-group
+ "dict-for-each-in-closed-interval"
+ (test-for-each (let* ((cmp (dict-comparator dtd (alist->dict '())))
+ (ordering (and cmp (comparator-ordering-predicate cmp))))
+ ordering)
+ (lambda (proc)
+ (dict-for-each-in-closed-interval dtd
+ proc
+ (alist->dict '((1 . a)
+ (2 . b)
+ (3 . c)
+ (4 . d)))
+ 1 4))
+ '(1 2 3 4)))
+
+ (test-group
+ "dict-for-each-in-open-closed-interval"
+ (test-for-each (let* ((cmp (dict-comparator dtd (alist->dict '())))
+ (ordering (and cmp (comparator-ordering-predicate cmp))))
+ ordering)
+ (lambda (proc)
+ (dict-for-each-in-open-closed-interval dtd
+ proc
+ (alist->dict '((1 . a)
+ (2 . b)
+ (3 . c)
+ (4 . d)))
+ 1 4))
+ '(2 3 4)))
+
+ (test-group
+ "dict-for-each-in-closed-open-interval"
+ (test-for-each (let* ((cmp (dict-comparator dtd (alist->dict '())))
+ (ordering (and cmp (comparator-ordering-predicate cmp))))
+ ordering)
+ (lambda (proc)
+ (dict-for-each-in-closed-open-interval dtd
+ proc
+ (alist->dict '((1 . a)
+ (2 . b)
+ (3 . c)
+ (4 . d)))
+ 1 4))
+ '(1 2 3)))
+
+ (test-group
+ "make-dict-generator"
+ (test-for-each #t
+ (lambda (proc)
+ (generator-for-each
+ (lambda (entry)
+ (proc (car entry) (cdr entry)))
+ (make-dict-generator dtd (alist->dict '((1 . a)
+ (2 . b)
+ (3 . c))))))
+ '(1 2 3)))
+
+ (test-group
+ "dict-set-accumulator"
+ (define acc (dict-set-accumulator dtd (alist->dict '())))
+ (acc (cons 1 'a))
+ (acc (cons 2 'b))
+ (acc (cons 2 'c))
+ (test-assert (dict=? dtd equal? (acc (eof-object)) (alist->dict '((1 . a) (2 . c))))))
+
+ (test-group
+ "dict-adjoin-accumulator"
+ (define acc (dict-adjoin-accumulator dtd (alist->dict '())))
+ (acc (cons 1 'a))
+ (acc (cons 2 'b))
+ (acc (cons 2 'c))
+ (test-assert (dict=? dtd equal? (acc (eof-object)) (alist->dict '((1 . a) (2 . b))))))
+
+ ;; check all procs were called
+ (for-each
+ (lambda (index)
+ (when (= 0 (vector-ref counter index))
+ (error "Untested procedure" index)))
+ (iota (vector-length counter))))
+
+(test-begin "Dictionaries")
+
+(test-group
+ "default"
+ ;; test defaults by overring only procedures that raise error otherwise
+ (define alist-dtd (make-alist-dtd equal?))
+ (define minimal-alist-dtd
+ (make-dtd
+ dictionary?-id (dtd-ref alist-dtd dictionary?-id)
+ dict-mutable?-id (dtd-ref alist-dtd dict-mutable?-id)
+ dict-size-id (dtd-ref alist-dtd dict-size-id)
+ dict-alter-id (dtd-ref alist-dtd dict-alter-id)
+ dict-for-each-id (dtd-ref alist-dtd dict-for-each-id)
+ dict-comparator-id (dtd-ref alist-dtd dict-comparator-id)))
+ (do-test
+ minimal-alist-dtd
+ alist-copy
+ #f
+ #f
+ ))
+
+(test-group
+ "alist"
+ (do-test
+ (make-alist-dtd equal?)
+ ;; copy to a mutable list instead of using identity function
+ ;; so that mutating procedures don't fail
+ alist-copy
+ #f
+ #f)
+
+ (test-group
+ "alist dict-comparator"
+ (test-assert (not (dict-comparator alist-equal-dtd '())))))
+
+(test-group
+ "plist"
+ (do-test
+ plist-dtd
+ (lambda (alist)
+ (apply append
+ (map (lambda (pair)
+ (list (car pair) (cdr pair)))
+ alist)))
+ #f
+ #f)
+ (test-group
+ "plist dict-comparator"
+ (test-assert (not (dict-comparator plist-dtd '())))))
+
+(cond-expand
+ ((and (library (srfi 69))
+ (not gauche)) ;; gauche has bug with comparator retrieval from srfi 69 table
+ (test-group
+ "srfi-69"
+ (do-test
+ srfi-69-dtd
+ (lambda (alist)
+ (define table (t69-make-hash-table equal?))
+ (for-each
+ (lambda (pair)
+ (t69-hash-table-set! table (car pair) (cdr pair)))
+ alist)
+ table)
+ (make-default-comparator)
+ #t)))
+ (else))
+
+(cond-expand
+ ((library (srf 125))
+ (test-group
+ "srfi-125 mutable"
+ (do-test
+ hash-table-dtd
+ (lambda (alist)
+ (define table (t125-hash-table-empty-copy (t125-make-hash-table equal?)))
+ (for-each
+ (lambda (pair)
+ (t125-hash-table-set! table (car pair) (cdr pair)))
+ alist)
+ table)
+ (make-default-comparator)
+ #t))
+ (test-group
+ "srfi-125 immutable"
+ (do-test
+ hash-table-dtd
+ (lambda (alist)
+ (define table (t125-hash-table-empty-copy (t125-make-hash-table equal?)))
+ (for-each
+ (lambda (pair)
+ (t125-hash-table-set! table (car pair) (cdr pair)))
+ alist)
+ (t125-hash-table-copy table #f))
+ (make-default-comparator)
+ #f)))
+ (else))
+
+(cond-expand
+ ((library (srfi 126))
+ (test-group
+ "srfi-126 (r6rs) mutable"
+ (do-test
+ srfi-126-dtd
+ (lambda (alist)
+ (define table (t126-make-eqv-hashtable))
+ (for-each
+ (lambda (pair)
+ (t126-hashtable-set! table (car pair) (cdr pair)))
+ alist)
+ table)
+ (make-default-comparator)
+ #t))
+ (test-group
+ "srfi-126 (r6rs) immutable"
+ (do-test
+ srfi-126-dtd
+ (lambda (alist)
+ (define table (t126-make-eqv-hashtable))
+ (for-each
+ (lambda (pair)
+ (t126-hashtable-set! table (car pair) (cdr pair)))
+ alist)
+ (t126-hashtable-copy table #f))
+ (make-default-comparator)
+ #f)))
+ (else))
+
+(cond-expand
+ ((and (library (srfi 146))
+ (library (srfi 146 hash)))
+ (test-group
+ "srfi-146"
+ (define cmp (make-default-comparator))
+ (do-test
+ mapping-dtd
+ (lambda (alist)
+ (let loop ((table (mapping cmp))
+ (entries alist))
+ (if (null? entries)
+ table
+ (loop (mapping-set! table (caar entries) (cdar entries))
+ (cdr entries)))))
+ cmp
+ #f)
+ (test-group
+ "srfi-146 dict-comparator"
+ (test-equal cmp (dict-comparator mapping-dtd (mapping cmp)))))
+
+ (test-group
+ "srfi-146 hash"
+ (define cmp (make-default-comparator))
+ (do-test
+ hash-mapping-dtd
+ (lambda (alist)
+ (let loop ((table (hashmap cmp))
+ (entries alist))
+ (if (null? entries)
+ table
+ (loop (hashmap-set! table (caar entries) (cdar entries))
+ (cdr entries)))))
+ cmp
+ #f)
+ (test-group
+ "srfi-146 hash dict-comparator"
+ (test-equal cmp (dict-comparator hash-mapping-dtd (hashmap cmp))))))
+ (else))
+
+(test-end)
diff --git a/srfi-225.html b/srfi-225.html
index 5f86263..7c6584c 100644
--- a/srfi-225.html
+++ b/srfi-225.html
@@ -80,8 +80,8 @@ Consequently, previous examples don't affect later ones.
<blockquote><pre>
(define dicta '((5 . 6) (3 . 4) (1 . 2))
(define dictb '((1 . 2) (3 . 4))
-(dict=? aed dict dicta) => #t
-(dict=? aed dict dictb) => #f</pre></blockquote>
+(dict=? aed = dict dicta) => #t
+(dict=? aed = dict dictb) => #f</pre></blockquote>
<p><code>(dict-mutable?</code>&nbsp;<em>dtd dict</em><code>)</code></p>
<p>Returns <code>#t</code> if the dictionary type supports mutations and <code>#f</code> if it supports functional updates.</p>
<blockquote><pre>
diff --git a/srfi-69-impl.scm b/srfi-69-impl.scm
deleted file mode 100644
index 09f92d2..0000000
--- a/srfi-69-impl.scm
+++ /dev/null
@@ -1,88 +0,0 @@
-(define (register-srfi-69!)
-
- (define (hash-table-ref* table key fail success)
- (define default (cons #f #f))
- (define found (hash-table-ref/default table key default))
- (if (eq? found default)
- (fail)
- (success found)))
-
- (define (hash-table-set!* table . obj)
- (let loop ((obj obj))
- (if (null? obj)
- table
- (begin
- (hash-table-set! table (car obj) (cadr obj))
- (loop (cddr obj))))))
-
- (define (hash-table-update!/default* table key proc default)
- (hash-table-update!/default table key proc default)
- table)
-
- (define (hash-table-delete-all!* table keys)
- (for-each
- (lambda (key)
- (hash-table-delete! table key))
- keys)
- table)
-
- (define (hash-table-foreach* proc table)
- (hash-table-walk table proc))
-
- (define (hash-table-map* proc table)
- (hash-table-walk table (lambda (key value)
- (hash-table-set! table key (proc key value))))
- table)
-
- (define (hash-table-filter* proc table)
- (hash-table-walk table
- (lambda (key value)
- (unless (proc key value)
- (hash-table-delete! table key))))
- table)
-
- (define (hash-table-fold* proc knil table)
- (hash-table-fold table proc knil))
-
- (define (hash-table-search* table key fail success)
- (define (handle-success value)
- (define (update new-key new-value obj)
- (unless (eq? new-key key)
- (hash-table-delete! table key))
- (hash-table-set! table new-key new-value)
- (values table obj))
- (define (remove obj)
- (hash-table-delete! table key)
- (values table obj))
- (success key value update remove))
- (define (handle-fail)
- (define (ignore obj)
- (values table obj))
- (define (insert value obj)
- (hash-table-set! table key value)
- (values table obj))
- (fail insert ignore))
-
- (define default (cons #f #f))
- (define found (hash-table-ref/default table key default))
- (if (eq? default found)
- (handle-fail)
- (handle-success found)))
-
- (register-dictionary!
- 'dictionary? hash-table?
- 'dict-ref hash-table-ref*
- 'dict-ref/default hash-table-ref/default
- 'dict-set! hash-table-set!*
- 'dict-delete-all! hash-table-delete-all!*
- 'dict-contains? hash-table-exists?
- 'dict-update/default! hash-table-update!/default*
- 'dict-size hash-table-size
- 'dict-keys hash-table-keys
- 'dict-values hash-table-values
- 'dict-map! hash-table-map*
- 'dict-filter! hash-table-filter*
- 'dict-for-each hash-table-foreach*
- 'dict-fold hash-table-fold*
- 'dict->alist hash-table->alist
- 'dict-search! hash-table-search*))
diff --git a/srfi/225.sld b/srfi/225.sld
new file mode 100644
index 0000000..6e389a7
--- /dev/null
+++ b/srfi/225.sld
@@ -0,0 +1,197 @@
+(define-library
+ (srfi 225)
+
+ (import (scheme base)
+ (scheme case-lambda)
+ (scheme write)
+ (srfi 1)
+ (srfi 128))
+
+ (cond-expand
+ ((library (srfi 145)) (import (srfi 145)))
+ (else (include "assumptions.scm")))
+
+ (export
+
+ ;; predicates
+ dictionary?
+ dict-empty?
+ dict-contains?
+ dict=?
+ dict-mutable?
+
+ ;; lookup
+ dict-ref
+ dict-ref/default
+ dict-min-key
+ dict-max-key
+
+ ;; mutation
+ dict-set
+ dict-set!
+ dict-adjoin
+ dict-adjoin!
+ dict-delete
+ dict-delete!
+ dict-delete-all
+ dict-delete-all!
+ dict-replace
+ dict-replace!
+ dict-intern
+ dict-intern!
+ dict-update
+ dict-update!
+ dict-update/default
+ dict-update/default!
+ dict-pop
+ dict-pop!
+ dict-map
+ dict-map!
+ dict-filter
+ dict-filter!
+ dict-remove
+ dict-remove!
+ dict-alter
+ dict-alter!
+
+ ;; whole dictionary
+ dict-size
+ dict-count
+ dict-any
+ dict-every
+ dict-keys
+ dict-values
+ dict-entries
+ dict-fold
+ dict-map->list
+ dict->alist
+ dict-comparator
+
+ ;; iteration
+ dict-for-each
+ dict-for-each<
+ dict-for-each<=
+ dict-for-each>
+ dict-for-each>=
+ dict-for-each-in-open-interval
+ dict-for-each-in-closed-interval
+ dict-for-each-in-open-closed-interval
+ dict-for-each-in-closed-open-interval
+
+ ;; generator procedures
+ make-dict-generator
+ dict-set-accumulator
+ dict-adjoin-accumulator
+
+ ;; dictionary type descriptors
+ dtd?
+ make-dtd
+ dtd
+ make-alist-dtd
+ dtd-ref
+
+ ;; exceptions
+ dictionary-error
+ dictionary-error?
+ dictionary-message
+ dictionary-irritants
+
+ ;; proc indeces
+ dictionary?-id
+ dict-empty?-id
+ dict-contains?-id
+ dict=?-id
+ dict-mutable?-id
+ dict-ref-id
+ dict-ref/default-id
+ dict-min-key-id
+ dict-max-key-id
+ dict-set-id
+ dict-adjoin-id
+ dict-delete-id
+ dict-delete-all-id
+ dict-replace-id
+ dict-intern-id
+ dict-update-id
+ dict-update/default-id
+ dict-pop-id
+ dict-map-id
+ dict-filter-id
+ dict-remove-id
+ dict-alter-id
+ dict-size-id
+ dict-count-id
+ dict-any-id
+ dict-every-id
+ dict-keys-id
+ dict-values-id
+ dict-entries-id
+ dict-fold-id
+ dict-map->list-id
+ dict->alist-id
+ dict-comparator-id
+ dict-for-each-id
+ dict-for-each<-id
+ dict-for-each<=-id
+ dict-for-each>-id
+ dict-for-each>=-id
+ dict-for-each-in-open-interval-id
+ dict-for-each-in-closed-interval-id
+ dict-for-each-in-open-closed-interval-id
+ dict-for-each-in-closed-open-interval-id
+ make-dict-generator-id
+ dict-set-accumulator-id
+ dict-adjoin-accumulator-id
+
+ ;; basic DTDs
+ plist-dtd
+ alist-eqv-dtd
+ alist-equal-dtd)
+
+ ;; implementations
+ (include "indexes.scm")
+ (include "externals.scm")
+ (include "default-impl.scm")
+ (include "alist-impl.scm")
+ (include "plist-impl.scm")
+
+ ;; library-dependent DTD exports
+ ;; and implementations
+ ;;
+ ;;srfi-69-dtd
+ ;;hash-table-dtd
+ ;;srfi-126-dtd
+ ;;mapping-dtd
+ ;;hash-mapping-dtd
+
+ (cond-expand
+ ((library (srfi 69))
+ (import (prefix (srfi 69) t69-))
+ (include "srfi-69-impl.scm")
+ (export srfi-69-dtd))
+ (else))
+
+ (cond-expand
+ ((library (srfi 125))
+ (import (prefix (srfi 125) t125-))
+ (include "srfi-125-impl.scm")
+ (export hash-table-dtd))
+ (else))
+
+ (cond-expand
+ ((library (srfi 126))
+ (import (prefix (srfi 126) t126-))
+ (include "srfi-126-impl.scm")
+ (export srfi-126-dtd))
+ (else))
+
+ (cond-expand
+ ((and (library (srfi 146))
+ (library (srfi 146 hash)))
+ (import (srfi 146)
+ (srfi 146 hash))
+ (include "srfi-146-impl.scm"
+ "srfi-146-hash-impl.scm")
+ (export mapping-dtd
+ hash-mapping-dtd))
+ (else)))
diff --git a/srfi/alist-impl.scm b/srfi/alist-impl.scm
new file mode 100644
index 0000000..4400602
--- /dev/null
+++ b/srfi/alist-impl.scm
@@ -0,0 +1,88 @@
+(define (make-alist-dtd key=)
+
+ (define (alist? dtd l)
+ (and (list? l)
+ (or (null? l)
+ (pair? (car l)))))
+
+ (define (alist-mutable? dtd alist)
+ #f)
+
+ (define (alist-map dtd proc alist)
+ (map
+ (lambda (e)
+ (define key (car e))
+ (define value (cdr e))
+ (cons key (proc key value)))
+ alist))
+
+ (define (alist-filter dtd pred alist)
+ (filter
+ (lambda (e)
+ (pred (car e) (cdr e)))
+ alist))
+
+ (define (alist-delete dtd key alist)
+ (filter
+ (lambda (entry)
+ (not (key= (car entry) key)))
+ alist))
+
+ (define (alist-alter dtd 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
+ (let ((new-list
+ (alist-cons
+ new-key new-value
+ (alist-delete dtd old-key alist))))
+ new-list))))
+ (define (remove)
+ (alist-delete dtd old-key alist))
+ (success old-key old-value update remove))
+
+ (define (handle-failure)
+ (define (insert value)
+ (alist-cons key value alist))
+ (define (ignore)
+ alist)
+ (failure insert ignore))
+ (cond
+ ((assoc key alist key=) => handle-success)
+ (else (handle-failure))))
+
+ (define (alist-size dtd alist)
+ (length alist))
+
+ (define (alist-foreach dtd proc alist)
+ (define (proc* e)
+ (proc (car e) (cdr e)))
+ (for-each proc* alist))
+
+ (define (alist->alist dtd alist)
+ alist)
+
+ (define (alist-comparator dtd dictionary)
+ #f)
+
+ (make-dtd
+ dictionary?-id alist?
+ dict-mutable?-id alist-mutable?
+ dict-map-id alist-map
+ dict-filter-id alist-filter
+ dict-alter-id alist-alter
+ dict-size-id alist-size
+ dict-for-each-id alist-foreach
+ dict->alist-id alist->alist
+ dict-comparator-id alist-comparator))
+
+(define alist-eqv-dtd (make-alist-dtd eqv?))
+(define alist-equal-dtd (make-alist-dtd equal?))
diff --git a/srfi/assumptions.scm b/srfi/assumptions.scm
new file mode 100644
index 0000000..86ef435
--- /dev/null
+++ b/srfi/assumptions.scm
@@ -0,0 +1,7 @@
+(define-syntax assume
+ (syntax-rules ()
+ ((assume expression message ...)
+ (or expression
+ (error "invalid assumption" (quote expression) (list message ...))))
+ ((assume . _)
+ (syntax-error "invalid assume syntax"))))
diff --git a/srfi/default-impl.scm b/srfi/default-impl.scm
new file mode 100644
index 0000000..d5bfdec
--- /dev/null
+++ b/srfi/default-impl.scm
@@ -0,0 +1,440 @@
+(define default-dtd
+ (let ()
+
+ ;; implementation of "default" dtd, used as a filler for undefined
+ ;; functions in other dtds
+
+ ;; primitives
+ (define (not-implemented name)
+ (lambda (dtd . args)
+ (raise (dictionary-error (string-append name " not implemented") dtd))))
+ (define default-dictionary? (not-implemented "dictionary?"))
+ (define default-dict-mutable? (not-implemented "dict-mutable?"))
+ (define default-dict-size (not-implemented "dict-size"))
+ (define default-dict-alter (not-implemented "dict-alter"))
+
+ (define (dict-alter* dtd dict key fail success)
+ (if (dict-mutable? dtd dict)
+ (dict-alter! dtd dict key fail success)
+ (dict-alter dtd dict key fail success)))
+
+ (define (dict-delete-all* dtd dict keys)
+ (if (dict-mutable? dtd dict)
+ (dict-delete-all! dtd dict keys)
+ (dict-delete-all dtd dict keys)))
+
+ (define (dict-update* dtd dict key updater fail success)
+ (if (dict-mutable? dtd dict)
+ (dict-update! dtd dict key updater fail success)
+ (dict-update dtd dict key updater fail success)))
+
+ (define (dict-filter* dtd pred dictionary)
+ (if (dict-mutable? dtd dictionary)
+ (dict-filter! dtd pred dictionary)
+ (dict-filter dtd pred dictionary)))
+
+ (define (dict-replace* dtd dict key val)
+ (if (dict-mutable? dtd dict)
+ (dict-replace! dtd dict key val)
+ (dict-replace dtd dict key val)))
+
+ (define (default-dict-empty? dtd dictionary)
+ (= 0 (dict-size dtd dictionary)))
+
+ (define (default-dict=? dtd = dict1 dict2)
+ (define (check-entries* keys)
+ (cond
+ ((null? keys) #t)
+ (else (let* ((key (car keys))
+ (d1-value (dict-ref dtd dict1 key)))
+ (dict-ref dtd dict2 key
+ (lambda () #f)
+ (lambda (d2-value)
+ (if (= d1-value d2-value)
+ (check-entries* (cdr keys))
+ #f)))))))
+ (and (= (dict-size dtd dict1)
+ (dict-size dtd dict2))
+ (check-entries* (dict-keys dtd dict1))))
+
+ (define (default-dict-contains? dtd dictionary key)
+ (dict-ref dtd dictionary key
+ (lambda () #f)
+ (lambda (x) #t)))
+
+ (define (default-dict-ref dtd dictionary key failure success)
+ (dict-alter* dtd dictionary key
+ (lambda (insert ignore)
+ (failure))
+ (lambda (key value update remove)
+ (success value))))
+
+ (define (default-dict-ref/default dtd dictionary key default)
+ (dict-ref dtd dictionary key
+ (lambda () default)
+ (lambda (x) x)))
+
+ (define (default-dict-find-key dtd dict cmp-proc)
+ (define cmp (dict-comparator dtd dict))
+ (define keys (dict-keys dtd dict))
+ (when (not cmp)
+ (raise (dictionary-error "dictionary doesn't have comparator")))
+ (when (null? keys)
+ (error "Cannot find min/max key in empty dictionary"))
+ (let loop ((best (car keys))
+ (keys (cdr keys)))
+ (cond
+ ((null? keys) best)
+ ((cmp-proc cmp (car keys) best)
+ (loop (car keys) (cdr keys)))
+ (else (loop best (cdr keys))))))
+
+ (define (default-dict-min-key dtd dict)
+ (default-dict-find-key dtd dict <?))
+
+ (define (default-dict-max-key dtd dict)
+ (default-dict-find-key dtd dict >?))
+
+ ;; private
+ (define (default-dict-set* dtd dictionary use-old? objs)
+ (let loop ((objs objs)
+ (dictionary dictionary))
+ (cond
+ ((null? objs)
+ dictionary)
+ ((null? (cdr objs))
+ (error "mismatch of key / values argument list" objs))
+ (else (let* ((key (car objs))
+ (value (cadr objs))
+ (new-d (dict-alter* dtd dictionary key
+ (lambda (insert ignore)
+ (insert value))
+ (lambda (key old-value update delete)
+ (update key (if use-old? old-value value))))))
+ (loop (cddr objs)
+ new-d))))))
+
+ (define (default-dict-set dtd dictionary . objs)
+ (default-dict-set* dtd dictionary #f objs))
+
+ (define (default-dict-adjoin dtd dictionary . objs)
+ (default-dict-set* dtd dictionary #t objs))
+
+ (define (default-dict-delete dtd dictionary . keys)
+ (dict-delete-all* dtd dictionary keys))
+
+ (define (default-dict-delete-all dtd dictionary keylist)
+ (let loop ((keylist keylist)
+ (d dictionary))
+ (cond
+ ((null? keylist) d)
+ (else (let* ((key (car keylist))
+ (new-d (dict-alter* dtd d key
+ (lambda (_ ignore)
+ (ignore))
+ (lambda (key old-value _ delete)
+ (delete)))))
+ (loop (cdr keylist)
+ new-d))))))
+
+ (define (default-dict-replace dtd dictionary key value)
+ (dict-alter* dtd dictionary key
+ (lambda (_ ignore)
+ (ignore))
+ (lambda (key old-value update _)
+ (update key value))))
+
+ (define (default-dict-intern dtd dictionary key failure)
+ (dict-alter* dtd dictionary key
+ (lambda (insert _)
+ (let ((value (failure)))
+ (values (insert value) value)))
+ (lambda (key value update _)
+ (values dictionary value))))
+
+ (define (default-dict-update dtd dictionary key updater failure success)
+ (dict-alter* dtd dictionary key
+ (lambda (insert ignore)
+ (insert (updater (failure))))
+ (lambda (key value update _)
+ (update key (updater (success value))))))
+
+ (define (default-dict-update/default dtd dictionary key updater default)
+ (dict-update* dtd dictionary key updater
+ (lambda () default)
+ (lambda (x) x)))
+
+ (define (default-dict-pop dtd dictionary)
+ (define (do-pop)
+ (call/cc
+ (lambda (cont)
+ (dict-for-each dtd
+ (lambda (key value)
+ (define new-dict
+ (dict-delete-all* dtd dictionary (list key)))
+ (cont new-dict key value))
+ dictionary))))
+ (define empty? (dict-empty? dtd dictionary))
+ (if empty?
+ (error "popped empty dictionary")
+ (do-pop)))
+
+ (define (default-dict-map dtd mapper dictionary)
+ (define keys (dict-keys dtd dictionary))
+ (let loop ((keys keys)
+ (dict dictionary))
+ (if (null? keys)
+ dict
+ (let* ((key (car keys))
+ (val (mapper key (dict-ref dtd dict key))))
+ (loop (cdr keys)
+ (dict-replace* dtd dict key val))))))
+
+ (define (default-dict-filter dtd pred dictionary)
+ (define keys (dict-keys dtd dictionary))
+ (define keys-to-delete
+ (filter
+ (lambda (key)
+ (not (pred key (dict-ref dtd dictionary key))))
+ keys))
+ (dict-delete-all* dtd dictionary keys-to-delete))
+
+ (define (default-dict-remove dtd pred dictionary)
+ (dict-filter* dtd (lambda (key value)
+ (not (pred key value)))
+ dictionary))
+
+ (define (default-dict-count dtd pred dictionary)
+ (dict-fold dtd
+ (lambda (key value acc)
+ (if (pred key value)
+ (+ 1 acc)
+ acc))
+ 0
+ dictionary))
+
+ (define (default-dict-any dtd pred dictionary)
+ (call/cc
+ (lambda (cont)
+ (dict-for-each dtd
+ (lambda (key value)
+ (define ret (pred key value))
+ (when ret
+ (cont ret)))
+ dictionary)
+ #f)))
+
+ (define (default-dict-every dtd pred dictionary)
+ (define last #t)
+ (call/cc
+ (lambda (cont)
+ (dict-for-each dtd
+ (lambda (key value)
+ (define ret (pred key value))
+ (when (not ret)
+ (cont #f))
+ (set! last ret))
+ dictionary)
+ last)))
+
+ (define (default-dict-keys dtd dictionary)
+ (reverse
+ (dict-fold dtd
+ (lambda (key value acc)
+ (cons key acc))
+ '()
+ dictionary)))
+
+ (define (default-dict-values dtd dictionary)
+ (reverse
+ (dict-fold dtd
+ (lambda (key value acc)
+ (cons value acc))
+ '()
+ dictionary)))
+
+ (define (default-dict-entries dtd dictionary)
+ (define pair
+ (dict-fold dtd
+ (lambda (key value acc)
+ (cons (cons key (car acc))
+ (cons value (cdr acc))))
+ (cons '() '())
+ dictionary))
+ (values (reverse (car pair))
+ (reverse (cdr pair))))
+
+ (define (default-dict-fold dtd proc knil dictionary)
+ (define acc knil)
+ (dict-for-each dtd
+ (lambda (key value)
+ (set! acc (proc key value acc)))
+ dictionary)
+ acc)
+
+ (define (default-dict-map->list dtd proc dictionary)
+ (define reverse-lst
+ (dict-fold dtd
+ (lambda (key value lst)
+ (cons (proc key value) lst))
+ '()
+ dictionary))
+ (reverse reverse-lst))
+
+ (define (default-dict->alist dtd dictionary)
+ (dict-map->list dtd
+ cons
+ dictionary))
+
+ (define default-dict-comparator (not-implemented "dict-comparator"))
+
+ (define default-dict-for-each (not-implemented "dict-for-each"))
+
+ (define (default-dict-for-each/filtered dtd pred proc dict)
+ (dict-for-each dtd
+ (lambda (key value)
+ (when (pred key)
+ (proc key value)))
+ dict))
+
+ (define (default-dict-for-each< dtd proc dict key)
+ (define cmp (dict-comparator dtd dict))
+ (define (pred k)
+ (<? cmp k key))
+ (default-dict-for-each/filtered dtd pred proc dict))
+
+ (define (default-dict-for-each<= dtd proc dict key)
+ (define cmp (dict-comparator dtd dict))
+ (define (pred k)
+ (<=? cmp k key))
+ (default-dict-for-each/filtered dtd pred proc dict))
+
+ (define (default-dict-for-each> dtd proc dict key)
+ (define cmp (dict-comparator dtd dict))
+ (define (pred k)
+ (>? cmp k key))
+ (default-dict-for-each/filtered dtd pred proc dict))
+
+ (define (default-dict-for-each>= dtd proc dict key)
+ (define cmp (dict-comparator dtd dict))
+ (define (pred k)
+ (>=? cmp k key))
+ (default-dict-for-each/filtered dtd pred proc dict))
+
+ (define (default-dict-for-each-in-open-interval dtd proc dict key1 key2)
+ (define cmp (dict-comparator dtd dict))
+ (define (pred k)
+ (<? cmp key1 k key2))
+ (default-dict-for-each/filtered dtd pred proc dict))
+
+ (define (default-dict-for-each-in-closed-interval dtd proc dict key1 key2)
+ (define cmp (dict-comparator dtd dict))
+ (define (pred k)
+ (<=? cmp key1 k key2))
+ (default-dict-for-each/filtered dtd pred proc dict))
+
+ (define (default-dict-for-each-in-open-closed-interval dtd proc dict key1 key2)
+ (define cmp (dict-comparator dtd dict))
+ (define (pred k)
+ (and (<? cmp key1 k)
+ (<=? cmp k key2)))
+ (default-dict-for-each/filtered dtd pred proc dict))
+
+ (define (default-dict-for-each-in-closed-open-interval dtd proc dict key1 key2)
+ (define cmp (dict-comparator dtd dict))
+ (define (pred k)
+ (and (<=? cmp key1 k)
+ (<? cmp k key2)))
+ (default-dict-for-each/filtered dtd pred proc dict))
+
+ (define (default-make-dict-generator dtd dict)
+ (define-values (keys vals)
+ (dict-entries dtd dict))
+ (lambda ()
+ (if (null? keys)
+ (eof-object)
+ (let ((key (car keys))
+ (value (car vals)))
+ (set! keys (cdr keys))
+ (set! vals (cdr vals))
+ (cons key value)))))
+
+ (define (default-dict-accumulator dtd dict acc-proc)
+ (lambda (arg)
+ (if (eof-object? arg)
+ dict
+ (set! dict (acc-proc dtd dict (car arg) (cdr arg))))))
+
+ (define (default-dict-set-accumulator dtd dict)
+ (if (dict-mutable? dtd dict)
+ (default-dict-accumulator dtd dict dict-set!)
+ (default-dict-accumulator dtd dict dict-set)))
+
+ (define (default-dict-adjoin-accumulator dtd dict)
+ (if (dict-mutable? dtd dict)
+ (default-dict-accumulator dtd dict dict-adjoin!)
+ (default-dict-accumulator dtd dict dict-adjoin)))
+
+ (let ()
+ (define null-dtd (make-dtd-private (make-vector dict-procedures-count #f)))
+ (define default-dtd
+ (make-modified-dtd
+ null-dtd
+ dictionary?-id default-dictionary?
+ dict-empty?-id default-dict-empty?
+ dict-contains?-id default-dict-contains?
+ dict=?-id default-dict=?
+ dict-mutable?-id default-dict-mutable?
+ dict-ref-id default-dict-ref
+ dict-ref/default-id default-dict-ref/default
+ dict-min-key-id default-dict-min-key
+ dict-max-key-id default-dict-max-key
+ dict-set-id default-dict-set
+ dict-adjoin-id default-dict-adjoin
+ dict-delete-id default-dict-delete
+ dict-delete-all-id default-dict-delete-all
+ dict-replace-id default-dict-replace
+ dict-intern-id default-dict-intern
+ dict-update-id default-dict-update
+ dict-update/default-id default-dict-update/default
+ dict-pop-id default-dict-pop
+ dict-map-id default-dict-map
+ dict-filter-id default-dict-filter
+ dict-remove-id default-dict-remove
+ dict-alter-id default-dict-alter
+ dict-size-id default-dict-size
+ dict-count-id default-dict-count
+ dict-any-id default-dict-any
+ dict-every-id default-dict-every
+ dict-keys-id default-dict-keys
+ dict-values-id default-dict-values
+ dict-entries-id default-dict-entries
+ dict-fold-id default-dict-fold
+ dict-map->list-id default-dict-map->list
+ dict->alist-id default-dict->alist
+ dict-comparator-id default-dict-comparator
+
+ dict-for-each-id default-dict-for-each
+ dict-for-each<-id default-dict-for-each<
+ dict-for-each<=-id default-dict-for-each<=
+ dict-for-each>-id default-dict-for-each>
+ dict-for-each>=-id default-dict-for-each>=
+ dict-for-each-in-open-interval-id default-dict-for-each-in-open-interval
+ dict-for-each-in-closed-interval-id default-dict-for-each-in-closed-interval
+ dict-for-each-in-open-closed-interval-id default-dict-for-each-in-open-closed-interval
+ dict-for-each-in-closed-open-interval-id default-dict-for-each-in-closed-open-interval
+
+ ;; generator procedures
+ make-dict-generator-id default-make-dict-generator
+ dict-set-accumulator-id default-dict-set-accumulator
+ dict-adjoin-accumulator-id default-dict-adjoin-accumulator))
+
+ ;; sanity check
+ (vector-for-each
+ (lambda (proc index)
+ (unless (and proc (procedure? proc))
+ (error "Missing or wrong default procedure definition" proc index)))
+ (procvec default-dtd)
+ (list->vector (iota dict-procedures-count)))
+
+ default-dtd)))
diff --git a/srfi/externals.scm b/srfi/externals.scm
new file mode 100644
index 0000000..5d77c86
--- /dev/null
+++ b/srfi/externals.scm
@@ -0,0 +1,183 @@
+;; procedure definitions that don't rely on concrete implementations
+
+(define-record-type <dtd>
+ (make-dtd-private procvec)
+ dtd?
+ (procvec procvec))
+
+(define-record-type <dtd-err>
+ (make-dictionary-error message irritants)
+ dictionary-error?
+ (message dictionary-message)
+ (irritants dictionary-irritants))
+
+;; shorthand access to dtd procedure by index
+(define-syntax dtd-ref-stx
+ (syntax-rules ()
+ ((_ dtd index)
+ (begin
+ (vector-ref (procvec dtd) index)))))
+
+;; shorthand to define proc with using proc index
+(define-syntax define/dict-proc
+ (syntax-rules ()
+ ((_ proc index)
+ (define (proc dtd . args)
+ (assume (dtd? dtd))
+ (apply (dtd-ref-stx dtd index) dtd args)))))
+
+;; define mutable and immutable versions of a procedure (such as dict-set! and dict-set)
+;; with appropriate assertion for dict-mutable? value
+;; when dtd is first arg, and dict is second arg
+(define-syntax define/dict-proc-pair
+ (syntax-rules ()
+ ((_ proc-immutable proc-mutable index)
+ (begin
+ (define (proc-mutable dtd dict . args)
+ (assume (dtd? dtd))
+ (assume ((dtd-ref-stx dtd dict-mutable?-id) dtd dict) index)
+ (apply (dtd-ref-stx dtd index) dtd dict args))
+ (define (proc-immutable dtd dict . args)
+ (assume (dtd? dtd))
+ (assume (not ((dtd-ref-stx dtd dict-mutable?-id) dtd dict)) index)
+ (apply (dtd-ref-stx dtd index) dtd dict args))))))
+
+;; define mutable and immutable versions of a procedure (such as dict-set! and dict-set)
+;; with appropriate assertion for dict-mutable? value
+;; when dtd is first arg, and dict is third arg (ie filter, map shape signature)
+(define-syntax define/dict-proc-pair*
+ (syntax-rules ()
+ ((_ proc-immutable proc-mutable index)
+ (begin
+ (define (proc-mutable dtd proc dict)
+ (assume (dtd? dtd))
+ (assume ((dtd-ref-stx dtd dict-mutable?-id) dtd dict) index)
+ ((dtd-ref-stx dtd index) dtd proc dict))
+ (define (proc-immutable dtd proc dict)
+ (assume (dtd? dtd))
+ (assume (not ((dtd-ref-stx dtd dict-mutable?-id) dtd dict)) index)
+ ((dtd-ref-stx dtd index) dtd proc dict))))))
+
+(define/dict-proc dictionary? dictionary?-id)
+(define/dict-proc dict-empty? dict-empty?-id)
+(define/dict-proc dict-contains? dict-contains?-id)
+(define/dict-proc dict-mutable? dict-mutable?-id)
+(define/dict-proc dict=? dict=?-id)
+
+(define dict-ref
+ (case-lambda
+ ((dtd dict key)
+ (dict-ref dtd dict key
+ (lambda () (error "Key not found in dictionary" dict key))
+ values))
+
+ ((dtd dict key failure)
+ (dict-ref dtd dict key failure values))
+
+ ((dtd dict key failure success)
+ (assume (dtd? dtd))
+ ((dtd-ref-stx dtd dict-ref-id) dtd dict key failure success))))
+
+(define/dict-proc dict-ref/default dict-ref/default-id)
+(define/dict-proc dict-min-key dict-min-key-id)
+(define/dict-proc dict-max-key dict-max-key-id)
+(define/dict-proc-pair dict-set dict-set! dict-set-id)
+(define/dict-proc-pair dict-adjoin dict-adjoin! dict-adjoin-id)
+(define/dict-proc-pair dict-delete dict-delete! dict-delete-id)
+(define/dict-proc-pair dict-delete-all dict-delete-all! dict-delete-all-id)
+(define/dict-proc-pair dict-replace dict-replace! dict-replace-id)
+(define/dict-proc-pair dict-intern dict-intern! dict-intern-id)
+
+(define dict-update
+ (case-lambda
+ ((dtd dict key updater)
+ (dict-update dtd dict key updater
+ (lambda () (error "Key not found in dictionary" dict key))
+ values))
+
+ ((dtd dict key updater failure)
+ (dict-update dtd dict key updater failure values))
+
+ ((dtd dict key updater failure success)
+ (assume (dtd? dtd))
+ (assume (not ((dtd-ref-stx dtd dict-mutable?-id) dtd dict)))
+ ((dtd-ref-stx dtd dict-update-id) dtd dict key updater failure success))))
+
+(define dict-update!
+ (case-lambda
+ ((dtd dict key updater)
+ (dict-update dtd dict key updater
+ (lambda () (error "Key not found in dictionary" dict key))
+ values))
+
+ ((dtd dict key updater failure)
+ (dict-update dtd dict key updater failure values))
+
+ ((dtd dict key updater failure success)
+ (assume (dtd? dtd))
+ (assume ((dtd-ref-stx dtd dict-mutable?-id) dtd dict))
+ ((dtd-ref-stx dtd dict-update-id) dtd dict key updater failure success))))
+
+(define/dict-proc-pair dict-update/default dict-update/default! dict-update/default-id)
+(define/dict-proc-pair dict-pop dict-pop! dict-pop-id)
+(define/dict-proc-pair* dict-map dict-map! dict-map-id)
+(define/dict-proc-pair* dict-filter dict-filter! dict-filter-id)
+(define/dict-proc-pair* dict-remove dict-remove! dict-remove-id)
+(define/dict-proc-pair dict-alter dict-alter! dict-alter-id)
+(define/dict-proc dict-size dict-size-id)
+(define/dict-proc dict-count dict-count-id)
+(define/dict-proc dict-any dict-any-id)
+(define/dict-proc dict-every dict-every-id)
+(define/dict-proc dict-keys dict-keys-id)
+(define/dict-proc dict-values dict-values-id)
+(define/dict-proc dict-entries dict-entries-id)
+(define/dict-proc dict-fold dict-fold-id)
+(define/dict-proc dict-map->list dict-map->list-id)
+(define/dict-proc dict->alist dict->alist-id)
+(define/dict-proc dict-comparator dict-comparator-id)
+(define/dict-proc dict-for-each dict-for-each-id)
+(define/dict-proc dict-for-each< dict-for-each<-id)
+(define/dict-proc dict-for-each<= dict-for-each<=-id)
+(define/dict-proc dict-for-each> dict-for-each>-id)
+(define/dict-proc dict-for-each>= dict-for-each>=-id)
+(define/dict-proc dict-for-each-in-open-interval dict-for-each-in-open-interval-id)
+(define/dict-proc dict-for-each-in-closed-interval dict-for-each-in-closed-interval-id)
+(define/dict-proc dict-for-each-in-open-closed-interval dict-for-each-in-open-closed-interval-id)
+(define/dict-proc dict-for-each-in-closed-open-interval dict-for-each-in-closed-open-interval-id)
+(define/dict-proc make-dict-generator make-dict-generator-id)
+(define/dict-proc dict-set-accumulator dict-set-accumulator-id)
+(define/dict-proc dict-adjoin-accumulator dict-adjoin-accumulator-id)
+
+(define (dtd-ref dtd procindex)
+ (dtd-ref-stx dtd procindex))
+
+(define (make-modified-dtd dtd . lst)
+ (define vec (vector-copy (procvec dtd)))
+ (do ((lst lst (cddr lst)))
+ ((null? lst))
+ (when (null? (cdr lst))
+ (error "Uneven amount of arguments" lst))
+ (let ((proc-id (car lst))
+ (proc (cadr lst)))
+ (unless (procedure? proc)
+ (error "Not a procedure" proc))
+ (vector-set! vec proc-id proc)))
+ (make-dtd-private vec))
+
+(define (make-dtd . lst)
+ (apply make-modified-dtd default-dtd lst))
+
+(define-syntax dtd-helper
+ (syntax-rules ()
+ ((_ (arg ...) (index proc) rest ...)
+ (dtd-helper (arg ... index proc) rest ...))
+ ((_ (arg ...))
+ (make-dtd arg ...))))
+
+(define-syntax dtd
+ (syntax-rules ()
+ ((_ (index proc) ...)
+ (dtd-helper () (index proc) ...))))
+
+(define (dictionary-error message . irritants)
+ (make-dictionary-error message irritants))
diff --git a/srfi/indexes.scm b/srfi/indexes.scm
new file mode 100644
index 0000000..f71a76e
--- /dev/null
+++ b/srfi/indexes.scm
@@ -0,0 +1,53 @@
+;; procedure index definitions
+
+(define proc-id 0)
+(define (proc-id-inc)
+ (define v proc-id)
+ (set! proc-id (+ 1 proc-id))
+ v)
+(define dictionary?-id (proc-id-inc))
+(define dict-empty?-id (proc-id-inc))
+(define dict-contains?-id (proc-id-inc))
+(define dict=?-id (proc-id-inc))
+(define dict-mutable?-id (proc-id-inc))
+(define dict-ref-id (proc-id-inc))
+(define dict-ref/default-id (proc-id-inc))
+(define dict-min-key-id (proc-id-inc))
+(define dict-max-key-id (proc-id-inc))
+(define dict-set-id (proc-id-inc))
+(define dict-adjoin-id (proc-id-inc))
+(define dict-delete-id (proc-id-inc))
+(define dict-delete-all-id (proc-id-inc))
+(define dict-replace-id (proc-id-inc))
+(define dict-intern-id (proc-id-inc))
+(define dict-update-id (proc-id-inc))
+(define dict-update/default-id (proc-id-inc))
+(define dict-pop-id (proc-id-inc))
+(define dict-map-id (proc-id-inc))
+(define dict-filter-id (proc-id-inc))
+(define dict-remove-id (proc-id-inc))
+(define dict-alter-id (proc-id-inc))
+(define dict-size-id (proc-id-inc))
+(define dict-count-id (proc-id-inc))
+(define dict-any-id (proc-id-inc))
+(define dict-every-id (proc-id-inc))
+(define dict-keys-id (proc-id-inc))
+(define dict-values-id (proc-id-inc))
+(define dict-entries-id (proc-id-inc))
+(define dict-fold-id (proc-id-inc))
+(define dict-map->list-id (proc-id-inc))
+(define dict->alist-id (proc-id-inc))
+(define dict-comparator-id (proc-id-inc))
+(define dict-for-each-id (proc-id-inc))
+(define dict-for-each<-id (proc-id-inc))
+(define dict-for-each<=-id (proc-id-inc))
+(define dict-for-each>-id (proc-id-inc))
+(define dict-for-each>=-id (proc-id-inc))
+(define dict-for-each-in-open-interval-id (proc-id-inc))
+(define dict-for-each-in-closed-interval-id (proc-id-inc))
+(define dict-for-each-in-open-closed-interval-id (proc-id-inc))
+(define dict-for-each-in-closed-open-interval-id (proc-id-inc))
+(define make-dict-generator-id (proc-id-inc))
+(define dict-set-accumulator-id (proc-id-inc))
+(define dict-adjoin-accumulator-id (proc-id-inc))
+(define dict-procedures-count (proc-id-inc)) ;; only used for tracking backing vector size
diff --git a/srfi/plist-impl.scm b/srfi/plist-impl.scm
new file mode 100644
index 0000000..d291870
--- /dev/null
+++ b/srfi/plist-impl.scm
@@ -0,0 +1,111 @@
+(define plist-dtd
+ (let ()
+
+ (define (plist? dtd l)
+ (and (list? l)
+ (or (null? l)
+ (symbol? (car l)))))
+
+ (define (plist-map dtd proc plist)
+ (let loop ((pl plist)
+ (new-pl/rev '()))
+ (cond
+ ((null? pl) (reverse new-pl/rev))
+ ((null? (cdr pl)) (error "Malformed plist" plist))
+ (else
+ (let ((key (car pl))
+ (value (cadr pl))
+ (rest (cddr pl)))
+ (loop rest
+ (append (list (proc key value) key) new-pl/rev)))))))
+
+ (define (plist-filter dtd pred plist)
+ (let loop ((pl plist)
+ (new-pl/rev '()))
+ (cond
+ ((null? pl) (reverse new-pl/rev))
+ ((null? (cdr pl)) (error "Malformed plist" plist))
+ (else
+ (let ((key (car pl))
+ (value (cadr pl))
+ (rest (cddr pl)))
+ (if (pred key value)
+ (loop rest
+ (append (list value key) new-pl/rev))
+ (loop rest
+ new-pl/rev)))))))
+
+ (define (find-plist-entry key plist)
+ (cond
+ ((null? plist) #f)
+ ((eq? key (car plist)) plist)
+ (else (find-plist-entry key (cddr plist)))))
+
+ (define (plist-delete key-to-delete plist)
+ (let loop ((pl plist)
+ (new-pl/rev '()))
+ (cond
+ ((null? pl) (reverse new-pl/rev))
+ ((null? (cdr pl)) (error "Malformed plist"))
+ (else (let ((key (car pl))
+ (value (cadr pl))
+ (rest (cddr pl)))
+ (if (eq? key-to-delete key)
+ (loop rest new-pl/rev)
+ (loop rest (append (list value key) new-pl/rev))))))))
+
+ (define (plist-alter dtd plist key failure success)
+ (define (handle-success pair)
+ (define old-key (car pair))
+ (define old-value (cadr pair))
+ (define (update new-key new-value)
+ (cond
+ ((and (eq? old-key
+ new-key)
+ (eq? old-value
+ new-value))
+ plist)
+ (else
+ (let ((new-list
+ (append (list new-key new-value)
+ (plist-delete old-key plist))))
+ new-list))))
+ (define (remove)
+ (plist-delete old-key plist))
+ (success old-key old-value update remove))
+
+ (define (handle-failure)
+ (define (insert value)
+ (append (list key value) plist))
+ (define (ignore)
+ plist)
+ (failure insert ignore))
+ (cond
+ ((find-plist-entry key plist) => handle-success)
+ (else (handle-failure))))
+
+ (define (plist-size dtd plist)
+ (/ (length plist) 2))
+
+ (define (plist-foreach dtd proc plist)
+ (let loop ((pl plist))
+ (if (null? pl) #t
+ (begin
+ (proc (car pl) (cadr pl))
+ (loop (cddr pl))))))
+
+ (define (plist-mutable? dtd plist)
+ #f)
+
+ (define (plist-comparator dtd plist)
+ #f)
+
+ (make-dtd
+ dictionary?-id plist?
+ dict-mutable?-id plist-mutable?
+ dict-map-id plist-map
+ dict-filter-id plist-filter
+ dict-alter-id plist-alter
+ dict-size-id plist-size
+ dict-for-each-id plist-foreach
+ dict-comparator-id plist-comparator)))
diff --git a/srfi/srfi-125-impl.scm b/srfi/srfi-125-impl.scm
new file mode 100644
index 0000000..5705613
--- /dev/null
+++ b/srfi/srfi-125-impl.scm
@@ -0,0 +1,172 @@
+(define hash-table-dtd
+ (let ()
+
+ (define-syntax guard-immutable
+ (syntax-rules ()
+ ((_ table body ... final-expr)
+ (if (t125-hash-table-mutable? table)
+ (let ()
+ body ...
+ final-expr)
+ (let ((table (t125-hash-table-copy table #t)))
+ body ...
+ (let ((table (t125-hash-table-copy table #f)))
+ final-expr))))))
+
+ (define (t125-hash-table-mutable?* dtd table)
+ (t125-hash-table-mutable? table))
+
+ (define (t125-hash-table-set* dtd table . obj)
+ (guard-immutable table
+ (apply t125-hash-table-set! (cons table obj))
+ table))
+
+ (define (t125-hash-table-update* dtd table key updater fail success)
+ (guard-immutable table
+ (t125-hash-table-update! table key updater fail success)
+ table))
+
+ (define (t125-hash-table-update/default* dtd table key proc default)
+ (guard-immutable table
+ (t125-hash-table-update!/default table key proc default)
+ table))
+
+ (define (t125-hash-table-intern* dtd table key failure)
+ (guard-immutable table
+ (define val (t125-hash-table-intern! table key failure))
+ (values table val)))
+
+ (define (t125-hash-table-pop* dtd table)
+ (if (t125-hash-table-empty? table)
+ (error "popped empty dictionary")
+ (guard-immutable table
+ (define-values
+ (key value)
+ (t125-hash-table-pop! table))
+ (values table key value))))
+
+ (define (t125-hash-table-delete-all* dtd table keys)
+ (guard-immutable table
+ (for-each
+ (lambda (key)
+ (t125-hash-table-delete! table key))
+ keys)
+ table))
+
+ (define (t125-hash-table-map* dtd proc table)
+ (guard-immutable table
+ (t125-hash-table-map! proc table)
+ table))
+
+ (define (t125-hash-table-filter* dtd proc table)
+ (guard-immutable table
+ (t125-hash-table-prune!
+ (lambda (key value)
+ (not (proc key value)))
+ table)
+ table))
+
+ (define (t125-hash-table-remove* dtd proc table)
+ (guard-immutable table
+ (t125-hash-table-prune! proc table)
+ table))
+
+ (define (t125-hash-table-alter* dtd table key fail success)
+ (define (handle-success value)
+ (define (update new-key new-value)
+ (guard-immutable table
+ (unless (eq? new-key key)
+ (t125-hash-table-delete! table key))
+ (t125-hash-table-set! table new-key new-value)
+ table))
+ (define (remove)
+ (guard-immutable table
+ (t125-hash-table-delete! table key)
+ table))
+ (success key value update remove))
+ (define (handle-fail)
+ (define (ignore)
+ table)
+ (define (insert value)
+ (guard-immutable table
+ (t125-hash-table-set! table key value)
+ table))
+ (fail insert ignore))
+
+ (define default (cons #f #f))
+ (t125-hash-table-ref table key handle-fail handle-success))
+
+ (define (t125-hash-table-comparator* dtd table)
+ (make-comparator (lambda args #t)
+ (t125-hash-table-equivalence-function table)
+ #f
+ (t125-hash-table-hash-function table)))
+
+ (define (t125-hash-table-copy* dtd table)
+ (t125-hash-table-copy table #t))
+
+ (define (t125-hash-table-size* dtd table)
+ (t125-hash-table-size table))
+
+ (define (t125-hash-table-for-each* dtd proc table)
+ (t125-hash-table-for-each proc table))
+
+ (define (t125-hash-table-keys* dtd table)
+ (t125-hash-table-keys table))
+
+ (define (t125-hash-table-values* dtd table)
+ (t125-hash-table-values table))
+
+ (define (t125-hash-table-entries* dtd table)
+ (t125-hash-table-entries table))
+
+ (define (t125-hash-table-fold* dtd proc knil table)
+ (t125-hash-table-fold proc knil table))
+
+ (define (t125-hash-table-map->list* dtd proc table)
+ (t125-hash-table-map->list proc table))
+
+ (define (t125-hash-table->alist* dtd table)
+ (t125-hash-table->alist table))
+
+ (define (t125-hash-table?* dtd table)
+ (t125-hash-table? table))
+
+ (define (t125-hash-table-empty?* dtd table)
+ (t125-hash-table-empty? table))
+
+ (define (t125-hash-table-contains?* dtd table key)
+ (t125-hash-table-contains? table key))
+
+ (define (t125-hash-table-ref* dtd table key failure success)
+ (t125-hash-table-ref table key failure success))
+
+ (define (t125-hash-table-ref/default* dtd table key default)
+ (t125-hash-table-ref/default table key default))
+
+ (make-dtd
+ dictionary?-id t125-hash-table?*
+ dict-mutable?-id t125-hash-table-mutable?*
+ dict-empty?-id t125-hash-table-empty?*
+ dict-contains?-id t125-hash-table-contains?*
+ dict-ref-id t125-hash-table-ref*
+ dict-ref/default-id t125-hash-table-ref/default*
+ dict-set-id t125-hash-table-set*
+ dict-delete-all-id t125-hash-table-delete-all*
+ dict-intern-id t125-hash-table-intern*
+ dict-update-id t125-hash-table-update*
+ dict-update/default-id t125-hash-table-update/default*
+ dict-pop-id t125-hash-table-pop*
+ dict-map-id t125-hash-table-map*
+ dict-filter-id t125-hash-table-filter*
+ dict-remove-id t125-hash-table-remove*
+ dict-alter-id t125-hash-table-alter*
+ dict-size-id t125-hash-table-size*
+ dict-for-each-id t125-hash-table-for-each*
+ dict-keys-id t125-hash-table-keys*
+ dict-values-id t125-hash-table-values*
+ dict-entries-id t125-hash-table-entries*
+ dict-fold-id t125-hash-table-fold*
+ dict-map->list-id t125-hash-table-map->list*
+ dict->alist-id t125-hash-table->alist*
+ dict-comparator-id t125-hash-table-comparator*)))
diff --git a/srfi/srfi-126-impl.scm b/srfi/srfi-126-impl.scm
new file mode 100644
index 0000000..d5de302
--- /dev/null
+++ b/srfi/srfi-126-impl.scm
@@ -0,0 +1,157 @@
+(define srfi-126-dtd
+ (let ()
+
+ (define-syntax guard-immutable
+ (syntax-rules ()
+ ((_ table body ... final-expr)
+ (if (t126-hashtable-mutable? table)
+ (let ()
+ body ...
+ final-expr)
+ (let ((table (t126-hashtable-copy table #t)))
+ body ...
+ (let ((table (t126-hashtable-copy table #f)))
+ final-expr))))))
+
+ (define (prep-dtd-arg proc)
+ (lambda (dtd . args)
+ (apply proc args)))
+
+ (define (t126-hashtable-ref* dtd table key fail success)
+ (define-values (value found?) (t126-hashtable-lookup table key))
+ (if found?
+ (success value)
+ (fail)))
+
+ (define (t126-hashtable-ref/default* dtd table key default)
+ (t126-hashtable-ref table key default))
+
+ (define (t126-hashtable-set* dtd table . obj)
+ (guard-immutable table
+ (let loop ((obj obj))
+ (if (null? obj)
+ #t
+ (begin
+ (t126-hashtable-set! table (car obj) (cadr obj))
+ (loop (cddr obj)))))
+ table))
+
+ (define (t126-hashtable-delete-all* dtd table keys)
+ (guard-immutable table
+ (for-each
+ (lambda (key)
+ (t126-hashtable-delete! table key))
+ keys)
+ table))
+
+ (define (t126-hashtable-intern* dtd table key default)
+ (guard-immutable table
+ (define val (t126-hashtable-intern! table key default))
+ (values table val)))
+
+ (define (t126-hashtable-update/default* dtd table key updater default)
+ (guard-immutable table
+ (t126-hashtable-update! table key updater default)
+ table))
+
+ (define (t126-hashtable-pop* dtd table)
+ (if (t126-hashtable-empty? table)
+ (error "popped empty dictionary")
+ (guard-immutable table
+ (define-values
+ (key value)
+ (t126-hashtable-pop! table))
+ (values table key value))))
+
+ (define (t126-hashtable-update-all* dtd proc table)
+ (guard-immutable table
+ (t126-hashtable-update-all! table proc)
+ table))
+
+ (define (t126-hashtable-filter* dtd proc table)
+ (guard-immutable table
+ (t126-hashtable-prune! table
+ (lambda (key value)
+ (not (proc key value))))
+ table))
+
+ (define (t126-hashtable-remove* dtd proc table)
+ (guard-immutable table
+ (t126-hashtable-prune! table proc)
+ table))
+
+ (define (t126-hashtable-alter* dtd table key fail success)
+ (define (handle-success value)
+ (define (update new-key new-value)
+ (guard-immutable table
+ (unless (eq? new-key key)
+ (t126-hashtable-delete! table key))
+ (t126-hashtable-set! table new-key new-value)
+ table))
+ (define (remove)
+ (guard-immutable table
+ (t126-hashtable-delete! table key)
+ table))
+ (success key value update remove))
+ (define (handle-fail)
+ (define (ignore)
+ table)
+ (define (insert value)
+ (guard-immutable table
+ (t126-hashtable-set! table key value)
+ table))
+ (fail insert ignore))
+
+ (define default (cons #f #f))
+ (define found (t126-hashtable-ref table key default))
+ (if (eq? default found)
+ (handle-fail)
+ (handle-success found)))
+
+ (define (t126-hashtable-for-each* dtd proc table)
+ (t126-hashtable-walk table proc)
+ table)
+
+ (define (t126-hashtable-map->lset* dtd proc table)
+ (t126-hashtable-map->lset table proc))
+
+ (define (t126-hashtable-keys* dtd table)
+ (vector->list (t126-hashtable-keys table)))
+
+ (define (t126-hashtable-values* dtd table)
+ (vector->list (t126-hashtable-values table)))
+
+ (define (t126-hashtable-entries* dtd table)
+ (call-with-values
+ (lambda () (t126-hashtable-entries table))
+ (lambda (keys vals)
+ (values
+ (vector->list keys)
+ (vector->list vals)))))
+
+ (define (t126-hashtable-comparator* dtd table)
+ #f)
+
+ (make-dtd
+ dictionary?-id (prep-dtd-arg t126-hashtable?)
+ dict-mutable?-id (prep-dtd-arg t126-hashtable-mutable?)
+ dict-empty?-id (prep-dtd-arg t126-hashtable-empty?)
+ dict-contains?-id (prep-dtd-arg t126-hashtable-contains?)
+ dict-ref-id t126-hashtable-ref*
+ dict-ref/default-id t126-hashtable-ref/default*
+ dict-set-id t126-hashtable-set*
+ dict-delete-all-id t126-hashtable-delete-all*
+ dict-intern-id t126-hashtable-intern*
+ dict-update/default-id t126-hashtable-update/default*
+ dict-pop-id t126-hashtable-pop*
+ dict-map-id t126-hashtable-update-all*
+ dict-filter-id t126-hashtable-filter*
+ dict-remove-id t126-hashtable-remove*
+ dict-alter-id t126-hashtable-alter*
+ dict-size-id (prep-dtd-arg t126-hashtable-size)
+ dict-for-each-id t126-hashtable-for-each*
+ dict-keys-id t126-hashtable-keys*
+ dict-values-id t126-hashtable-values*
+ dict-entries-id t126-hashtable-entries*
+ dict-map->list-id t126-hashtable-map->lset*
+ dict-comparator-id t126-hashtable-comparator*)))
diff --git a/srfi/srfi-146-hash-impl.scm b/srfi/srfi-146-hash-impl.scm
new file mode 100644
index 0000000..323e259
--- /dev/null
+++ b/srfi/srfi-146-hash-impl.scm
@@ -0,0 +1,64 @@
+(define hash-mapping-dtd
+ (let ()
+
+ (define (prep-dtd-arg proc)
+ (lambda (dtd . args)
+ (apply proc args)))
+
+ (define (hashmap-alter* dtd dict key failure success)
+ (call/cc
+ ;; escape from whole hashmap-search entirely, when success / failure
+ ;; return something other than through passed in continuation procedures
+ (lambda (k)
+ (define-values
+ (new-dict ignored)
+ (hashmap-search dict key
+ (lambda (insert ignore)
+ ;; handle when continuation procedure is called
+ ;; and force it into tail call
+ (call/cc (lambda (k2)
+ (define result
+ (failure (lambda (value) (k2 (insert value #f)))
+ (lambda () (k2 (ignore #f)))))
+ ;; neither insert nor ignore called -- return result to top level escape
+ (k result))))
+ (lambda (key value update remove)
+ (call/cc (lambda (k2)
+ (define result
+ (success
+ key
+ value
+ (lambda (new-key new-value) (k2 (update new-key new-value #f)))
+ (lambda () (k2 (remove #f)))))
+ (k result))))))
+ new-dict)))
+
+ (make-dtd
+ dictionary?-id (prep-dtd-arg hashmap?)
+ dict-mutable?-id (lambda _ #f)
+ dict-empty?-id (prep-dtd-arg hashmap-empty?)
+ dict-contains?-id (prep-dtd-arg hashmap-contains?)
+ dict-ref-id (prep-dtd-arg hashmap-ref)
+ dict-ref/default-id (prep-dtd-arg hashmap-ref/default)
+ dict-set-id (prep-dtd-arg hashmap-set)
+ dict-adjoin-id (prep-dtd-arg hashmap-adjoin)
+ dict-delete-id (prep-dtd-arg hashmap-delete)
+ dict-delete-all-id (prep-dtd-arg hashmap-delete-all)
+ dict-replace-id (prep-dtd-arg hashmap-replace)
+ dict-intern-id (prep-dtd-arg hashmap-intern)
+ dict-update-id (prep-dtd-arg hashmap-update)
+ dict-update/default-id (prep-dtd-arg hashmap-update/default)
+ dict-pop-id (prep-dtd-arg hashmap-pop)
+ dict-filter-id (prep-dtd-arg hashmap-filter)
+ dict-remove-id (prep-dtd-arg hashmap-remove)
+ dict-alter-id hashmap-alter*
+ dict-size-id (prep-dtd-arg hashmap-size)
+ dict-for-each-id (prep-dtd-arg hashmap-for-each)
+ dict-count-id (prep-dtd-arg hashmap-count)
+ dict-keys-id (prep-dtd-arg hashmap-keys)
+ dict-values-id (prep-dtd-arg hashmap-values)
+ dict-entries-id (prep-dtd-arg hashmap-entries)
+ dict-fold-id (prep-dtd-arg hashmap-fold)
+ dict-map->list-id (prep-dtd-arg hashmap-map->list)
+ dict->alist-id (prep-dtd-arg hashmap->alist)
+ dict-comparator-id (prep-dtd-arg hashmap-key-comparator))))
diff --git a/srfi/srfi-146-impl.scm b/srfi/srfi-146-impl.scm
new file mode 100644
index 0000000..49b4737
--- /dev/null
+++ b/srfi/srfi-146-impl.scm
@@ -0,0 +1,64 @@
+(define mapping-dtd
+ (let ()
+
+ (define (prep-dtd-arg proc)
+ (lambda (dtd . args)
+ (apply proc args)))
+
+ (define (mapping-alter* dtd dict key failure success)
+ (call/cc
+ ;; escape from whole hashmap-search entirely, when success / failure
+ ;; return something other than through passed in continuation procedures
+ (lambda (k)
+ (define-values
+ (new-dict ignored)
+ (mapping-search dict key
+ (lambda (insert ignore)
+ ;; handle when continuation procedure is called
+ ;; and force it into tail call
+ (call/cc (lambda (k2)
+ (define result
+ (failure (lambda (value) (k2 (insert value #f)))
+ (lambda () (k2 (ignore #f)))))
+ ;; neither insert nor ignore called -- return result to top level escape
+ (k result))))
+ (lambda (key value update remove)
+ (call/cc (lambda (k2)
+ (define result
+ (success
+ key
+ value
+ (lambda (new-key new-value) (k2 (update new-key new-value #f)))
+ (lambda () (k2 (remove #f)))))
+ (k result))))))
+ new-dict)))
+
+ (make-dtd
+ dictionary?-id (prep-dtd-arg mapping?)
+ dict-mutable?-id (lambda _ #f)
+ dict-empty?-id (prep-dtd-arg mapping-empty?)
+ dict-contains?-id (prep-dtd-arg mapping-contains?)
+ dict-ref-id (prep-dtd-arg mapping-ref)
+ dict-ref/default-id (prep-dtd-arg mapping-ref/default)
+ dict-set-id (prep-dtd-arg mapping-set)
+ dict-adjoin-id (prep-dtd-arg mapping-adjoin)
+ dict-delete-id (prep-dtd-arg mapping-delete)
+ dict-delete-all-id (prep-dtd-arg mapping-delete-all)
+ dict-replace-id (prep-dtd-arg mapping-replace)
+ dict-intern-id (prep-dtd-arg mapping-intern)
+ dict-update-id (prep-dtd-arg mapping-update)
+ dict-update/default-id (prep-dtd-arg mapping-update/default)
+ dict-pop-id (prep-dtd-arg mapping-pop)
+ dict-filter-id (prep-dtd-arg mapping-filter)
+ dict-remove-id (prep-dtd-arg mapping-remove)
+ dict-alter-id mapping-alter*
+ dict-size-id (prep-dtd-arg mapping-size)
+ dict-for-each-id (prep-dtd-arg mapping-for-each)
+ dict-count-id (prep-dtd-arg mapping-count)
+ dict-keys-id (prep-dtd-arg mapping-keys)
+ dict-values-id (prep-dtd-arg mapping-values)
+ dict-entries-id (prep-dtd-arg mapping-entries)
+ dict-fold-id (prep-dtd-arg mapping-fold)
+ dict-map->list-id (prep-dtd-arg mapping-map->list)
+ dict->alist-id (prep-dtd-arg mapping->alist)
+ dict-comparator-id (prep-dtd-arg mapping-key-comparator))))
diff --git a/srfi/srfi-69-impl.scm b/srfi/srfi-69-impl.scm
new file mode 100644
index 0000000..fe4edf3
--- /dev/null
+++ b/srfi/srfi-69-impl.scm
@@ -0,0 +1,105 @@
+(define srfi-69-dtd
+ (let ()
+
+ (define (prep-dtd-arg proc)
+ (lambda (dtd . args)
+ (apply proc args)))
+
+ (define (t69-hash-table-mutable?* dtd table)
+ #t)
+
+ (define (t69-hash-table-ref* dtd table key fail success)
+ (define default (cons #f #f))
+ (define found (t69-hash-table-ref/default table key default))
+ (if (eq? found default)
+ (fail)
+ (success found)))
+
+ (define (t69-hash-table-set!* dtd table . obj)
+ (let loop ((obj obj))
+ (if (null? obj)
+ table
+ (begin
+ (t69-hash-table-set! table (car obj) (cadr obj))
+ (loop (cddr obj))))))
+
+ (define (t69-hash-table-update!/default* dtd table key proc default)
+ (t69-hash-table-update!/default table key proc default)
+ table)
+
+ (define (t69-hash-table-delete-all!* dtd table keys)
+ (for-each
+ (lambda (key)
+ (t69-hash-table-delete! table key))
+ keys)
+ table)
+
+ (define (t69-hash-table-foreach* dtd proc table)
+ (t69-hash-table-walk table proc))
+
+ (define (t69-hash-table-map!* dtd proc table)
+ (t69-hash-table-walk table (lambda (key value)
+ (t69-hash-table-set! table key (proc key value))))
+ table)
+
+ (define (t69-hash-table-filter!* dtd proc table)
+ (t69-hash-table-walk table
+ (lambda (key value)
+ (unless (proc key value)
+ (t69-hash-table-delete! table key))))
+ table)
+
+ (define (t69-hash-table-fold* dtd proc knil table)
+ (t69-hash-table-fold table proc knil))
+
+ (define (t69-hash-table-alter!* dtd table key fail success)
+ (define (handle-success value)
+ (define (update new-key new-value)
+ (unless (eq? new-key key)
+ (t69-hash-table-delete! table key))
+ (t69-hash-table-set! table new-key new-value)
+ table)
+ (define (remove)
+ (t69-hash-table-delete! table key)
+ table)
+ (success key value update remove))
+ (define (handle-fail)
+ (define (ignore)
+ table)
+ (define (insert value)
+ (t69-hash-table-set! table key value)
+ table)
+ (fail insert ignore))
+
+ (define default (cons #f #f))
+ (define found (t69-hash-table-ref/default table key default))
+ (if (eq? default found)
+ (handle-fail)
+ (handle-success found)))
+
+ (define (t69-hash-table-comparator* dtd table)
+ (make-comparator (lambda args #t)
+ (or (t69-hash-table-equivalence-function table)
+ equal?)
+ #f
+ (t69-hash-table-hash-function table)))
+
+ (make-dtd
+ dictionary?-id (prep-dtd-arg t69-hash-table?)
+ dict-mutable?-id t69-hash-table-mutable?*
+ dict-ref-id t69-hash-table-ref*
+ dict-ref/default-id (prep-dtd-arg t69-hash-table-ref/default)
+ dict-set-id t69-hash-table-set!*
+ dict-delete-all-id t69-hash-table-delete-all!*
+ dict-contains?-id (prep-dtd-arg t69-hash-table-exists?)
+ dict-update/default-id t69-hash-table-update!/default*
+ dict-size-id (prep-dtd-arg t69-hash-table-size)
+ dict-keys-id (prep-dtd-arg t69-hash-table-keys)
+ dict-values-id (prep-dtd-arg t69-hash-table-values)
+ dict-map-id t69-hash-table-map!*
+ dict-filter-id t69-hash-table-filter!*
+ dict-for-each-id t69-hash-table-foreach*
+ dict-fold-id t69-hash-table-fold*
+ dict->alist-id (prep-dtd-arg t69-hash-table->alist)
+ dict-alter-id t69-hash-table-alter!*
+ dict-comparator-id t69-hash-table-comparator*)))