work

11 files changed, 1311 insertions, 0 deletions

diff --git a/srfi/225-impl.scm b/srfi/225-impl.scm
new file mode 100644
index 0000000..f24c180
--- /dev/null
+++ b/srfi/225-impl.scm
@@ -0,0 +1,13 @@
+(include "indexes.scm")
+(include "externals.scm")
+(include "default-impl.scm")
+(include "alist-impl.scm")
+(include "plist-impl.scm")
+
+(cond-expand
+  ((library (srfi 69))
+   (define srfi-69-dtd
+     (let ()
+       (include "srfi-69-impl.scm")
+       (make-srfi-69-dtd))))
+  (else))
diff --git a/srfi/225.scm b/srfi/225.scm
new file mode 120000
index 0000000..74d5e72
--- /dev/null
+++ b/srfi/225.scm
@@ -0,0 +1 @@
+225.sld
\ No newline at end of file
diff --git a/srfi/225.sld b/srfi/225.sld
new file mode 100644
index 0000000..c009606
--- /dev/null
+++ b/srfi/225.sld
@@ -0,0 +1,179 @@
+(define-library
+  (srfi 225)
+
+  ;; imports
+  (import (scheme base)
+          (scheme case-lambda)
+          (scheme write)
+          (srfi 1)
+          (srfi 128))
+
+  (cond-expand
+    ((library (srfi 145)) (import (srfi 145)))
+    (else (include "assumptions.scm")))
+
+  (cond-expand
+    (kawa (import (prefix (srfi 69 basic-hash-tables) t69:)))
+    (guile (import (prefix (srfi srfi-69) t69:)))
+    ((library (srfi 69)) (import (prefix (srfi 69) t69:)))
+    (else))
+
+  (cond-expand
+    (guile)
+    ((library (srfi 125)) (import (prefix (srfi 125) t125:)))
+    (else))
+
+  (cond-expand
+    (guile)
+    ((library (srfi 126)) (import (srfi 126)))
+    (else))
+
+  ;; exports
+  (export
+
+    ;; constructor
+    make-dictionary
+
+    ;; predicates
+    dictionary?
+    dict-empty?
+    dict-contains?
+
+    ;; lookup
+    dict-ref
+    dict-ref/default
+
+    ;; 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-search
+    dict-search!
+
+    ;; whole dictionary
+    dict-copy
+    dict-size
+    dict-for-each
+    dict-count
+    dict-any
+    dict-every
+    dict-keys
+    dict-values
+    dict-entries
+    dict-fold
+    dict-map->list
+    dict->alist
+    dict-comparator
+
+    ;; dictionary type descriptors
+    dtd?
+    make-dtd
+    dtd
+    make-modified-dtd
+    make-alist-dtd
+    dtd-ref
+
+    ;; exceptions
+    dictionary-error?
+    dictionary-message
+    dictionary-irritants
+
+    ;; proc indeces
+    make-dictionary-index
+    dictionary?-index
+    dict-empty?-index
+    dict-contains?-index
+    dict-ref-index
+    dict-ref/default-index
+    dict-set-index
+    dict-set!-index
+    dict-adjoin-index
+    dict-adjoin!-index
+    dict-delete-index
+    dict-delete!-index
+    dict-delete-all-index
+    dict-delete-all!-index
+    dict-replace-index
+    dict-replace!-index
+    dict-intern-index
+    dict-intern!-index
+    dict-update-index
+    dict-update!-index
+    dict-update/default-index
+    dict-update/default!-index
+    dict-pop-index
+    dict-pop!-index
+    dict-map-index
+    dict-map!-index
+    dict-filter-index
+    dict-filter!-index
+    dict-remove-index
+    dict-remove!-index
+    dict-search-index
+    dict-search!-index
+    dict-copy-index
+    dict-size-index
+    dict-for-each-index
+    dict-count-index
+    dict-any-index
+    dict-every-index
+    dict-keys-index
+    dict-values-index
+    dict-entries-index
+    dict-fold-index
+    dict-map->list-index
+    dict->alist-index
+    dict-comparator-index
+
+    ;; 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))
+         (include "srfi-69-impl.scm")
+         (export srfi-69-dtd))
+        (else))
+
+    (cond-expand
+        ((library (srfi 125))
+         (include "srfi-125-impl.scm")
+         (export hash-table-dtd))
+        (else)))
diff --git a/srfi/alist-impl.scm b/srfi/alist-impl.scm
new file mode 100644
index 0000000..4463d1c
--- /dev/null
+++ b/srfi/alist-impl.scm
@@ -0,0 +1,123 @@
+(define (make-alist-dtd key=)
+
+  (define (make-alist dtd comparator)
+    (when comparator
+      (raise (dictionary-error "alist dtd doesn't accept comparator" dtd)))
+    '())
+
+  (define (alist? dtd l)
+    (and (list? l)
+         (or (null? l)
+             (pair? (car l)))))
+
+  (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-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-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-delete! dtd key alist)
+    (filter!
+     (lambda (entry)
+       (not (key= (car entry) key)))
+     alist))
+
+  (define (alist-search* dtd alist-delete-proc alist key failure success)
+    (define (handle-success pair)
+      (define old-key (car pair))
+      (define old-value (cdr pair))
+      (define (update new-key new-value obj)
+        (cond
+         ((and (eq? old-key
+                    new-key)
+               (eq? old-value
+                    new-value))
+          (values alist obj))
+         (else
+          (let ((new-list
+                 (alist-cons
+                  new-key new-value
+                  (alist-delete-proc dtd old-key alist))))
+            (values new-list obj)))))
+      (define (remove obj)
+        (values (alist-delete-proc dtd old-key alist) obj))
+      (success old-key old-value update remove))
+
+    (define (handle-failure)
+      (define (insert value obj)
+        (values (alist-cons key value alist)
+                obj))
+      (define (ignore obj)
+        (values alist obj))
+      (failure insert ignore))
+    (cond
+     ((assoc key alist key=) => handle-success)
+     (else (handle-failure))))
+
+  (define (alist-search dtd alist key failure success)
+    (alist-search* dtd alist-delete alist key failure success))
+
+  (define (alist-search! dtd alist key failure success)
+    (alist-search* dtd alist-delete! alist key failure success))
+
+  (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)
+    (make-comparator (lambda args #t)
+                     key=
+                     #f
+                     #f))
+
+  (make-dtd
+   make-dictionary-index make-alist
+   dictionary?-index alist?
+   dict-map-index alist-map
+   dict-map!-index alist-map!
+   dict-filter-index alist-filter
+   dict-filter!-index alist-filter!
+   dict-search-index alist-search
+   dict-search!-index alist-search!
+   dict-size-index alist-size
+   dict-for-each-index alist-foreach
+   dict->alist-index alist->alist
+   dict-comparator-index 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..649b6be
--- /dev/null
+++ b/srfi/default-impl.scm
@@ -0,0 +1,369 @@
+(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-make-dictionary (not-implemented "make-dictionary"))
+    (define default-dictionary? (not-implemented "dictionary?"))
+    (define default-dict-size (not-implemented "dict-size"))
+    (define default-dict-search (not-implemented "dict-search"))
+    (define default-dict-search! (not-implemented "dict-search!"))
+    (define default-dict-for-each (not-implemented "dict-for-each"))
+
+    (define (default-dict-empty? dtd dictionary)
+      (= 0 (dict-size dtd dictionary)))
+
+    (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)
+      (define-values
+          (new-dict result)
+        (dict-search dtd dictionary key
+                     (lambda (_ ignore)
+                       (ignore (failure)))
+                     (lambda (key value update _)
+                       (update key value (success value)))))
+      result)
+
+    (define (default-dict-ref/default dtd dictionary key default)
+      (dict-ref dtd dictionary key
+                (lambda () default)
+                (lambda (x) x)))
+
+    ;; private
+    (define (default-dict-set* dtd dictionary dict-search-proc 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*-values
+                   (((key) (car objs))
+                    ((value) (cadr objs))
+                    ((new-d _) (dict-search-proc dtd dictionary key
+                                                 (lambda (insert ignore)
+                                                   (insert value #f))
+                                                 (lambda (key old-value update delete)
+                                                   (update key (if use-old? old-value value) #f)))))
+                 (loop (cddr objs)
+                       new-d))))))
+
+    (define (default-dict-set dtd dictionary . objs)
+      (default-dict-set* dtd dictionary dict-search #f objs))
+
+    (define (default-dict-set! dtd dictionary . objs)
+      (default-dict-set* dtd dictionary dict-search! #f objs))
+
+    (define (default-dict-adjoin dtd dictionary . objs)
+      (default-dict-set* dtd dictionary dict-search #t objs))
+
+    (define (default-dict-adjoin! dtd dictionary . objs)
+      (default-dict-set* dtd dictionary dict-search! #t objs))
+
+    (define (default-dict-delete dtd dictionary . keys)
+      (dict-delete-all dtd dictionary keys))
+
+    (define (default-dict-delete! dtd dictionary . keys)
+      (dict-delete-all! dtd dictionary keys))
+
+    (define (default-dict-delete-all* dtd dictionary dict-search-proc keylist)
+      (let loop ((keylist keylist)
+                 (dictionary dictionary))
+        (cond
+         ((null? keylist) dictionary)
+         (else (let*-values
+                   (((key) (car keylist))
+                    ((new-d _) (dict-search-proc dtd dictionary key
+                                                 (lambda (_ ignore)
+                                                   (ignore #f))
+                                                 (lambda (key old-value _ delete)
+                                                   (delete #f)))))
+                 (loop (cdr keylist)
+                       new-d))))))
+
+    (define (default-dict-delete-all dtd dictionary keylist)
+      (default-dict-delete-all* dtd dictionary dict-search keylist))
+
+    (define (default-dict-delete-all! dtd dictionary keylist)
+      (default-dict-delete-all* dtd dictionary dict-search! keylist))
+
+    (define (default-dict-replace* dtd dictionary dict-search-proc key value)
+      (define-values
+          (new-dict _)
+        (dict-search-proc dtd dictionary key
+                          (lambda (_ ignore)
+                            (ignore #f))
+                          (lambda (key old-value update _)
+                            (update key value #f))))
+      new-dict)
+
+    (define (default-dict-replace dtd dictionary key value)
+      (default-dict-replace* dtd dictionary dict-search key value))
+
+    (define (default-dict-replace! dtd dictionary key value)
+      (default-dict-replace* dtd dictionary dict-search! key value))
+
+    (define (default-dict-intern* dtd dictionary dict-search-proc key failure)
+      (dict-search-proc dtd dictionary key
+                        (lambda (insert _)
+                          (let ((value (failure)))
+                            (insert value value)))
+                        (lambda (key value update _)
+                          (update key value value))))
+
+    (define (default-dict-intern dtd dictionary key failure)
+      (default-dict-intern* dtd dictionary dict-search key failure))
+
+    (define (default-dict-intern! dtd dictionary key failure)
+      (default-dict-intern* dtd dictionary dict-search! key failure))
+
+    (define (default-dict-update* dtd dictionary dict-search-proc key updater failure success)
+      (define-values
+          (new-dict _)
+        (dict-search-proc dtd dictionary key
+                          (lambda (insert ignore)
+                            (insert (updater (failure)) #f))
+                          (lambda (key value update _)
+                            (update key (updater (success value)) #f))))
+      new-dict)
+
+    (define (default-dict-update dtd dictionary key updater failure success)
+      (default-dict-update* dtd dictionary dict-search key updater failure success))
+
+    (define (default-dict-update! dtd dictionary key updater failure success)
+      (default-dict-update* dtd dictionary dict-search! key updater failure success))
+
+    (define (default-dict-update/default* dtd dictionary dict-update-proc key updater default)
+      (dict-update-proc dtd dictionary key updater
+                        (lambda () default)
+                        (lambda (x) x)))
+
+    (define (default-dict-update/default dtd dictionary key updater default)
+      (default-dict-update/default* dtd dictionary dict-update key updater default))
+
+    (define (default-dict-update/default! dtd dictionary key updater default)
+      (default-dict-update/default* dtd dictionary dict-update! key updater default))
+
+    (define (default-dict-pop* dtd dictionary dict-delete-proc)
+      (define (do-pop)
+        (call/cc
+         (lambda (cont)
+           (dict-for-each dtd
+                          (lambda (key value)
+                            (define new-dict
+                              (dict-delete-proc dtd dictionary key))
+                            (cont new-dict key value))
+                          dictionary))))
+      (define empty? (dict-empty? dtd dictionary))
+      (if empty?
+          (error "popped empty dictionary")
+          (do-pop)))
+
+    (define (default-dict-pop dtd dictionary)
+      (default-dict-pop* dtd dictionary dict-delete))
+
+    (define (default-dict-pop! dtd dictionary)
+      (default-dict-pop* dtd dictionary dict-delete!))
+
+    (define (default-dict-map* dtd dict-replace-proc 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-proc dtd dict key val))))))
+
+    (define (default-dict-map dtd mapper dictionary)
+      (default-dict-map* dtd dict-replace mapper dictionary))
+
+    (define (default-dict-map! dtd mapper dictionary)
+      (default-dict-map* dtd dict-replace! mapper dictionary))
+
+    (define (default-dict-filter* dtd dict-delete-all-proc 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-proc dtd dictionary keys))
+
+    (define (default-dict-filter dtd pred dictionary)
+      (default-dict-filter* dtd dict-delete-all pred dictionary))
+
+    (define (default-dict-filter! dtd pred dictionary)
+      (default-dict-filter* dtd dict-delete-all! pred dictionary))
+
+    (define (default-dict-remove* dtd dict-filter-proc pred dictionary)
+      (dict-filter-proc dtd
+                        (lambda (key value)
+                          (not (pred key value)))
+                        dictionary))
+
+    (define (default-dict-remove dtd pred dictionary)
+      (default-dict-remove* dtd dict-filter pred dictionary))
+
+    (define (default-dict-remove! dtd pred dictionary)
+      (default-dict-remove* dtd dict-filter! pred dictionary))
+
+    (define (default-dict-copy dtd dictionary)
+      (dict-map dtd
+                (lambda (key value) 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"))
+
+    (let ()
+      (define null-dtd (make-dtd-private (make-vector dict-procedures-count #f)))
+      (define default-dtd
+        (make-modified-dtd
+         null-dtd
+         make-dictionary-index default-make-dictionary
+         dictionary?-index default-dictionary?
+         dict-empty?-index default-dict-empty?
+         dict-contains?-index default-dict-contains?
+         dict-ref-index default-dict-ref
+         dict-ref/default-index default-dict-ref/default
+         dict-set-index default-dict-set
+         dict-set!-index default-dict-set!
+         dict-adjoin-index default-dict-adjoin
+         dict-adjoin!-index default-dict-adjoin!
+         dict-delete-index default-dict-delete
+         dict-delete!-index default-dict-delete!
+         dict-delete-all-index default-dict-delete-all
+         dict-delete-all!-index default-dict-delete-all!
+         dict-replace-index default-dict-replace
+         dict-replace!-index default-dict-replace!
+         dict-intern-index default-dict-intern
+         dict-intern!-index default-dict-intern!
+         dict-update-index default-dict-update
+         dict-update!-index default-dict-update!
+         dict-update/default-index default-dict-update/default
+         dict-update/default!-index default-dict-update/default!
+         dict-pop-index default-dict-pop
+         dict-pop!-index default-dict-pop!
+         dict-map-index default-dict-map
+         dict-map!-index default-dict-map!
+         dict-filter-index default-dict-filter
+         dict-filter!-index default-dict-filter!
+         dict-remove-index default-dict-remove
+         dict-remove!-index default-dict-remove!
+         dict-search-index default-dict-search
+         dict-search!-index default-dict-search!
+         dict-copy-index default-dict-copy
+         dict-size-index default-dict-size
+         dict-for-each-index default-dict-for-each
+         dict-count-index default-dict-count
+         dict-any-index default-dict-any
+         dict-every-index default-dict-every
+         dict-keys-index default-dict-keys
+         dict-values-index default-dict-values
+         dict-entries-index default-dict-entries
+         dict-fold-index default-dict-fold
+         dict-map->list-index default-dict-map->list
+         dict->alist-index default-dict->alist
+         dict-comparator-index default-dict-comparator))
+
+      ;; 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..8fee936
--- /dev/null
+++ b/srfi/externals.scm
@@ -0,0 +1,140 @@
+;; 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))
+
+(define-syntax define/dict-proc
+  (syntax-rules ()
+    ((_ proc index)
+     (define (proc dtd . args)
+       (assume (dtd? dtd))
+       (apply (vector-ref (procvec dtd) index) dtd args)))))
+
+(define/dict-proc make-dictionary make-dictionary-index)
+(define/dict-proc dictionary? dictionary?-index)
+(define/dict-proc dict-empty? dict-empty?-index)
+(define/dict-proc dict-contains? dict-contains?-index)
+
+(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))
+     ((vector-ref (procvec dtd) dict-ref-index) dtd dict key failure success))))
+
+(define/dict-proc dict-ref/default dict-ref/default-index)
+(define/dict-proc dict-set dict-set-index)
+(define/dict-proc dict-set! dict-set!-index)
+(define/dict-proc dict-adjoin dict-adjoin-index)
+(define/dict-proc dict-adjoin! dict-adjoin!-index)
+(define/dict-proc dict-delete dict-delete-index)
+(define/dict-proc dict-delete! dict-delete!-index)
+(define/dict-proc dict-delete-all dict-delete-all-index)
+(define/dict-proc dict-delete-all! dict-delete-all!-index)
+(define/dict-proc dict-replace dict-replace-index)
+(define/dict-proc dict-replace! dict-replace!-index)
+(define/dict-proc dict-intern dict-intern-index)
+(define/dict-proc dict-intern! dict-intern!-index)
+
+(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))
+     ((vector-ref (procvec dtd) dict-update-index) 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))
+     ((vector-ref (procvec dtd) dict-update!-index) dtd dict key updater failure success))))
+
+(define/dict-proc dict-update/default dict-update/default-index)
+(define/dict-proc dict-update/default! dict-update/default!-index)
+(define/dict-proc dict-pop dict-pop-index)
+(define/dict-proc dict-pop! dict-pop!-index)
+(define/dict-proc dict-map dict-map-index)
+(define/dict-proc dict-map! dict-map!-index)
+(define/dict-proc dict-filter dict-filter-index)
+(define/dict-proc dict-filter! dict-filter!-index)
+(define/dict-proc dict-remove dict-remove-index)
+(define/dict-proc dict-remove! dict-remove!-index)
+(define/dict-proc dict-search dict-search-index)
+(define/dict-proc dict-search! dict-search!-index)
+(define/dict-proc dict-copy dict-copy-index)
+(define/dict-proc dict-size dict-size-index)
+(define/dict-proc dict-for-each dict-for-each-index)
+(define/dict-proc dict-count dict-count-index)
+(define/dict-proc dict-any dict-any-index)
+(define/dict-proc dict-every dict-every-index)
+(define/dict-proc dict-keys dict-keys-index)
+(define/dict-proc dict-values dict-values-index)
+(define/dict-proc dict-entries dict-entries-index)
+(define/dict-proc dict-fold dict-fold-index)
+(define/dict-proc dict-map->list dict-map->list-index)
+(define/dict-proc dict->alist dict->alist-index)
+(define/dict-proc dict-comparator dict-comparator-index)
+
+(define (dtd-ref dtd procindex)
+  (vector-ref (procvec 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-index (car lst))
+          (proc (cadr lst)))
+      (unless (procedure? proc)
+        (error "Not a procedure" proc))
+      (vector-set! vec proc-index 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..da99b57
--- /dev/null
+++ b/srfi/indexes.scm
@@ -0,0 +1,53 @@
+;; procedure index definitions
+
+(define proc-index 0)
+(define (proc-index-inc)
+  (define v proc-index)
+  (set! proc-index (+ 1 proc-index))
+  v)
+(define make-dictionary-index (proc-index-inc))
+(define dictionary?-index (proc-index-inc))
+(define dict-empty?-index (proc-index-inc))
+(define dict-contains?-index (proc-index-inc))
+(define dict-ref-index (proc-index-inc))
+(define dict-ref/default-index (proc-index-inc))
+(define dict-set-index (proc-index-inc))
+(define dict-set!-index (proc-index-inc))
+(define dict-adjoin-index (proc-index-inc))
+(define dict-adjoin!-index (proc-index-inc))
+(define dict-delete-index (proc-index-inc))
+(define dict-delete!-index (proc-index-inc))
+(define dict-delete-all-index (proc-index-inc))
+(define dict-delete-all!-index (proc-index-inc))
+(define dict-replace-index (proc-index-inc))
+(define dict-replace!-index (proc-index-inc))
+(define dict-intern-index (proc-index-inc))
+(define dict-intern!-index (proc-index-inc))
+(define dict-update-index (proc-index-inc))
+(define dict-update!-index (proc-index-inc))
+(define dict-update/default-index (proc-index-inc))
+(define dict-update/default!-index (proc-index-inc))
+(define dict-pop-index (proc-index-inc))
+(define dict-pop!-index (proc-index-inc))
+(define dict-map-index (proc-index-inc))
+(define dict-map!-index (proc-index-inc))
+(define dict-filter-index (proc-index-inc))
+(define dict-filter!-index (proc-index-inc))
+(define dict-remove-index (proc-index-inc))
+(define dict-remove!-index (proc-index-inc))
+(define dict-search-index (proc-index-inc))
+(define dict-search!-index (proc-index-inc))
+(define dict-copy-index (proc-index-inc))
+(define dict-size-index (proc-index-inc))
+(define dict-for-each-index (proc-index-inc))
+(define dict-count-index (proc-index-inc))
+(define dict-any-index (proc-index-inc))
+(define dict-every-index (proc-index-inc))
+(define dict-keys-index (proc-index-inc))
+(define dict-values-index (proc-index-inc))
+(define dict-entries-index (proc-index-inc))
+(define dict-fold-index (proc-index-inc))
+(define dict-map->list-index (proc-index-inc))
+(define dict->alist-index (proc-index-inc))
+(define dict-comparator-index (proc-index-inc))
+(define dict-procedures-count (proc-index-inc))
diff --git a/srfi/plist-impl.scm b/srfi/plist-impl.scm
new file mode 100644
index 0000000..e73bc94
--- /dev/null
+++ b/srfi/plist-impl.scm
@@ -0,0 +1,124 @@
+(define plist-dtd
+  (let ()
+
+    (define (make-plist dtd comparator)
+      (when comparator
+        (raise (dictionary-error "plist dtd doesn't accept comparator" dtd)))
+      '())
+
+    (define (plist? dtd l)
+      (and (list? l)
+           (or (null? l)
+               (symbol? (car l)))))
+
+    (define (plist-map dtd proc plist)
+      (plist-map! dtd proc (dict-copy dtd plist)))
+
+    (define (plist-map! dtd proc plist)
+      (let loop ((pl plist))
+        (cond
+         ((null? pl) plist)
+         ((null? (cdr pl)) (error "Malformed plist" plist))
+         (else
+          (let ((key (car pl))
+                (value (cadr pl))
+                (rest (cddr pl)))
+            (set-car! (cdr pl)
+                      (proc key value))
+            (loop rest))))))
+
+    (define (plist-filter dtd pred plist)
+      (plist-filter! dtd pred (dict-copy dtd plist)))
+
+    (define (plist-filter! dtd pred plist)
+      (define head (cons #f plist))
+      (let loop ((pl plist)
+                 (parent-cell head))
+        (cond
+         ((null? pl) (cdr head))
+         ((null? (cdr pl)) (error "Malformed plist" plist))
+         (else
+          (let ((key (car pl))
+                (value (cadr pl))
+                (rest (cddr pl)))
+            (if (pred key value)
+                (loop rest
+                      (cdr pl))
+                (loop (begin
+                        (set-cdr! parent-cell rest)
+                        rest)
+                      parent-cell)))))))
+
+    ;; head is a pair, whose cdr is the plist
+    ;; if found, returns a pair, whose cdr is rest of plist, and cadr is key that was searched for
+    ;; if not found, returns #f
+    ;;
+    ;; the pair indirection is used so that calling set-cdr! on the result allows the plist to be mutated
+    (define (find-plist-entry key head)
+      (define plist (cdr head))
+      (cond
+       ((null? plist) #f)
+       ((equal? key (car plist)) head)
+       (else (find-plist-entry key (cdr plist)))))
+
+    (define (plist-search dtd plist key failure success)
+      (plist-search! dtd (dict-copy dtd plist) key failure success))
+
+    (define (plist-search! dtd plist key failure success)
+      (define plist-head (cons #t plist))
+      (define (handle-success head)
+        (define key-cell (cdr head))
+        (define val-cell (cddr head))
+        (define (update new-key new-value obj)
+          (set-car! key-cell new-key)
+          (set-car! val-cell new-value)
+          (values plist obj))
+        (define (remove obj)
+          (set-cdr! head (cddr (cdr head)))
+          (values (cdr plist-head) obj))
+        (success (car key-cell) (car val-cell) update remove))
+
+      (define (handle-failure)
+        (define (insert value obj)
+          (values (cons key (cons value plist))
+                  obj))
+        (define (ignore obj)
+          (values plist obj))
+        (failure insert ignore))
+      (cond
+       ((find-plist-entry key plist-head) => handle-success)
+       (else (handle-failure))))
+
+    (define (plist-copy dtd plist)
+      (list-copy plist))
+
+    (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-comparator dtd plist)
+      (make-comparator symbol?
+                       equal?
+                       #f
+                       #f))
+
+    (make-dtd
+     make-dictionary-index make-plist
+     dictionary?-index plist?
+     dict-map-index plist-map
+     dict-map!-index plist-map!
+     dict-filter-index plist-filter
+     dict-filter!-index plist-filter!
+     dict-search-index plist-search
+     dict-search!-index plist-search!
+     dict-copy-index plist-copy
+     dict-size-index plist-size
+     dict-for-each-index plist-foreach
+     dict-comparator-index plist-comparator)
+    ))
diff --git a/srfi/srfi-125-impl.scm b/srfi/srfi-125-impl.scm
new file mode 100644
index 0000000..61863b5
--- /dev/null
+++ b/srfi/srfi-125-impl.scm
@@ -0,0 +1,160 @@
+(define hash-table-dtd
+  (let ()
+
+    (define (t125:make-hash-table* dtd comparator)
+      (t125:hash-table comparator))
+
+    (define (t125:hash-table-set!* dtd table . obj)
+      (apply t125:hash-table-set! (cons table obj))
+      table)
+
+    (define (t125:hash-table-update!* dtd table key updater fail success)
+      (t125:hash-table-update! table key updater fail success)
+      table)
+
+    (define (t125:hash-table-update!/default* dtd table key proc default)
+      (t125:hash-table-update!/default table key proc default)
+      table)
+
+    (define (t125:hash-table-intern!* dtd table key failure)
+      (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")
+          (call-with-values
+              (lambda () (t125:hash-table-pop! table))
+            (lambda (key value) (values table key value)))))
+
+    (define (t125:hash-table-delete-all!* dtd table keys)
+      (for-each
+       (lambda (key)
+         (t125:hash-table-delete! table key))
+       keys)
+      table)
+
+    (define (t125:hash-table-map!* dtd proc table)
+      (t125:hash-table-map! proc table)
+      table)
+
+    (define (t125:hash-table-filter!* dtd proc table)
+      (t125:hash-table-prune!
+       (lambda (key value)
+         (not (proc key value)))
+       table)
+      table)
+
+    (define (t125:hash-table-filter* dtd proc table)
+      (dict-filter! dtd proc (dict-copy dtd table)))
+
+    (define (t125:hash-table-remove!* dtd proc table)
+      (t125:hash-table-prune! proc table)
+      table)
+
+    (define (t125:hash-table-remove* dtd proc table)
+      (dict-remove! dtd proc (dict-copy dtd table)))
+
+    (define (t125:hash-table-search!* dtd table key fail success)
+      (define (handle-success value)
+        (define (update new-key new-value obj)
+          (unless (eq? new-key key)
+            (t125:hash-table-delete! table key))
+          (t125:hash-table-set! table new-key new-value)
+          (values table obj))
+        (define (remove obj)
+          (t125: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)
+          (t125:hash-table-set! table key value)
+          (values table obj))
+        (fail insert ignore))
+
+      (define default (cons #f #f))
+      (t125:hash-table-ref table key handle-fail handle-success))
+
+    (define (t125:hash-table-search* dtd table key fail success)
+      (t125:hash-table-search!* dtd (dict-copy dtd table) key fail 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))
+
+    (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
+     make-dictionary-index t125:make-hash-table*
+     dictionary?-index t125:hash-table?*
+     dict-empty?-index t125:hash-table-empty?*
+     dict-contains?-index t125:hash-table-contains?*
+     dict-ref-index t125:hash-table-ref*
+     dict-ref/default-index t125:hash-table-ref/default*
+     dict-set!-index t125:hash-table-set!*
+     dict-delete-all!-index t125:hash-table-delete-all!*
+     dict-intern!-index t125:hash-table-intern!*
+     dict-update!-index t125:hash-table-update!*
+     dict-update/default!-index t125:hash-table-update!/default*
+     dict-pop!-index t125:hash-table-pop!*
+     dict-map!-index t125:hash-table-map!*
+     dict-filter!-index t125:hash-table-filter!*
+     dict-filter-index t125:hash-table-filter*
+     dict-remove!-index t125:hash-table-remove!*
+     dict-remove-index t125:hash-table-remove*
+     dict-search!-index t125:hash-table-search!*
+     dict-search-index t125:hash-table-search*
+     dict-size-index t125:hash-table-size*
+     dict-for-each-index t125:hash-table-for-each*
+     dict-keys-index t125:hash-table-keys*
+     dict-values-index t125:hash-table-values*
+     dict-entries-index t125:hash-table-entries*
+     dict-fold-index t125:hash-table-fold*
+     dict-map->list-index t125:hash-table-map->list*
+     dict->alist-index t125:hash-table->alist*
+     dict-comparator-index t125:hash-table-comparator*
+     dict-copy-index t125:hash-table-copy*)))
diff --git a/srfi/srfi-69-impl.scm b/srfi/srfi-69-impl.scm
new file mode 100644
index 0000000..f0e397e
--- /dev/null
+++ b/srfi/srfi-69-impl.scm
@@ -0,0 +1,142 @@
+(define srfi-69-dtd
+  (let ()
+
+    (define (t69:make-hash-table* dtd comparator)
+      (define constructor-args
+        (if (not comparator)
+            '()
+            (let ((pred (comparator-equality-predicate comparator))
+                  (hash (comparator-hash-function comparator)))
+              (if hash
+                  (list pred hash)
+                  (list pred)))))
+      (apply t69:make-hash-table constructor-args))
+
+    (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-filter* dtd proc table)
+      (dict-filter! dtd proc (dict-copy dtd table)))
+
+    (define (t69:hash-table-fold* dtd proc knil table)
+      (t69:hash-table-fold table proc knil))
+
+    (define (t69:hash-table-search!* dtd table key fail success)
+      (define (handle-success value)
+        (define (update new-key new-value obj)
+          (unless (eq? new-key key)
+            (t69:hash-table-delete! table key))
+          (t69:hash-table-set! table new-key new-value)
+          (values table obj))
+        (define (remove obj)
+          (t69: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)
+          (t69:hash-table-set! table key value)
+          (values table obj))
+        (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-search* dtd table key fail success)
+      (t69:hash-table-search!* dtd (dict-copy dtd table) key fail success))
+
+    (define (t69:hash-table-values* dtd table)
+      (t69:hash-table-values table))
+
+    (define (t69:hash-table->alist* dtd table)
+      (t69:hash-table->alist table))
+
+    (define (t69:hash-table-keys* dtd table)
+      (t69:hash-table-keys table))
+
+    (define (t69:hash-table-size* dtd table)
+      (t69:hash-table-size table))
+
+    (define (t69:hash-table-exists?* dtd table key)
+      (t69:hash-table-exists? table key))
+
+    (define (t69:hash-table-ref/default* dtd table key default)
+      (t69:hash-table-ref/default table key default))
+
+    (define (t69:hash-table?* dtd table)
+      (t69:hash-table? table))
+
+    (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)))
+
+    (define (t69:hash-table-copy* dtd table)
+      (t69:hash-table-copy table))
+
+    (make-dtd
+     make-dictionary-index t69:make-hash-table*
+     dictionary?-index t69:hash-table?*
+     dict-ref-index t69:hash-table-ref*
+     dict-ref/default-index t69:hash-table-ref/default*
+     dict-set!-index t69:hash-table-set!*
+     dict-delete-all!-index t69:hash-table-delete-all!*
+     dict-contains?-index t69:hash-table-exists?*
+     dict-update/default!-index t69:hash-table-update!/default*
+     dict-size-index t69:hash-table-size*
+     dict-keys-index t69:hash-table-keys*
+     dict-values-index t69:hash-table-values*
+     dict-map!-index t69:hash-table-map!*
+     dict-filter!-index t69:hash-table-filter!*
+     dict-filter-index t69:hash-table-filter*
+     dict-for-each-index t69:hash-table-foreach*
+     dict-fold-index t69:hash-table-fold*
+     dict->alist-index t69:hash-table->alist*
+     dict-search-index t69:hash-table-search*
+     dict-search!-index t69:hash-table-search!*
+     dict-comparator-index t69:hash-table-comparator*
+     dict-copy-index t69:hash-table-copy*)))