Merge branch 'master' of https://github.com/johnwcowan/srfi-225

6 files changed, 78 insertions, 187 deletions

diff --git a/srfi/225.sld b/srfi/225.sld
index 7e93f20..d9d38ec 100644
--- a/srfi/225.sld
+++ b/srfi/225.sld
@@ -23,34 +23,22 @@
     ;; lookup
     dict-ref
     dict-ref/default
+    dict-comparator
 
     ;; 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-find-update
-    dict-find-update!
 
     ;; whole dictionary
     dict-size
@@ -63,20 +51,16 @@
     dict-fold
     dict-map->list
     dict->alist
-    dict-comparator
 
     ;; iteration
     dict-for-each
     dict->generator
     dict-set-accumulator
-    dict-set!-accumulator
     dict-adjoin-accumulator
-    dict-adjoin!-accumulator
 
     ;; dictionary type descriptors
     dto?
     make-dto
-    make-alist-dto
     dto-ref
 
     ;; exceptions
@@ -126,17 +110,12 @@
     dict-update/default-id
     dict-values-id
     dict=?-id
-    dict->generator-id
-
-    ;; basic DTOs
-    alist-eqv-dto
-    alist-equal-dto)
+    dict->generator-id)
 
     ;; implementations
     (include "indexes.scm")
     (include "externals.scm")
     (include "default-impl.scm")
-    (include "alist-impl.scm")
 
     ;; library-dependent DTO exports
     ;; and implementations
diff --git a/srfi/default-impl.scm b/srfi/default-impl.scm
index 24b20d6..ef1eb6c 100644
--- a/srfi/default-impl.scm
+++ b/srfi/default-impl.scm
@@ -13,46 +13,6 @@
     (define default-dict-size (not-implemented "dict-size"))
     (define default-dict-find-update (not-implemented "dict-find-update"))
 
-    (define (dict-find-update* dto dict key fail success)
-      (if (dict-pure? dto dict)
-          (dict-find-update dto dict key fail success)
-          (dict-find-update! dto dict key fail success)))
-    
-    (define (dict-find-update*/dict dto dict key fail success)
-      (if (dict-pure? dto dict)
-          (dict-find-update dto dict key fail success)
-          (begin
-            (dict-find-update! dto dict key fail success)
-            dict)))
-
-    (define (dict-delete-all* dto dict keys)
-      (if (dict-pure? dto dict)
-          (dict-delete-all dto dict keys)
-          (begin
-            (dict-delete-all! dto dict keys)
-            dict)))
-
-    (define (dict-update* dto dict key updater fail success)
-      (if (dict-pure? dto dict)
-          (dict-update dto dict key updater fail success)
-          (begin
-            (dict-update! dto dict key updater fail success)
-            dict)))
-
-    (define (dict-filter* dto pred dictionary)
-      (if (dict-pure? dto dictionary)
-          (dict-filter dto pred dictionary)
-          (begin
-            (dict-filter! dto pred dictionary)
-            dictionary)))
-
-    (define (dict-replace* dto dict key val)
-      (if (dict-pure? dto dict)
-          (dict-replace dto dict key val)
-          (begin
-            (dict-replace! dto dict key val)
-            dict)))
-
     (define (default-dict-empty? dto dictionary)
       (= 0 (dict-size dto dictionary)))
 
@@ -78,7 +38,7 @@
                 (lambda (x) #t)))
 
     (define (default-dict-ref dto dictionary key failure success)
-      (dict-find-update* dto dictionary key
+      (dict-find-update dto dictionary key
                      (lambda (insert ignore)
                        (failure))
                      (lambda (key value update remove)
@@ -100,7 +60,7 @@
           (error "mismatch of key / values argument list" objs))
          (else (let* ((key (car objs))
                       (value (cadr objs))
-                      (new-d (dict-find-update*/dict dto dictionary key
+                      (new-d (dict-find-update dto dictionary key
                                          (lambda (insert ignore)
                                            (insert value))
                                          (lambda (key old-value update delete)
@@ -115,7 +75,7 @@
       (default-dict-set* dto dictionary #t objs))
 
     (define (default-dict-delete dto dictionary . keys)
-      (dict-delete-all* dto dictionary keys))
+      (dict-delete-all dto dictionary keys))
 
     (define (default-dict-delete-all dto dictionary keylist)
       (let loop ((keylist keylist)
@@ -123,7 +83,7 @@
         (cond
           ((null? keylist) d)
           (else (let* ((key (car keylist))
-                       (new-d (dict-find-update*/dict dto d key
+                       (new-d (dict-find-update dto d key
                                           (lambda (_ ignore)
                                             (ignore))
                                           (lambda (key old-value _ delete)
@@ -132,36 +92,29 @@
                         new-d))))))
 
     (define (default-dict-replace dto dictionary key value)
-      (dict-find-update* dto dictionary key
+      (dict-find-update dto dictionary key
                   (lambda (_ ignore)
                     (ignore))
                   (lambda (key old-value update _)
                     (update key value))))
 
     (define (default-dict-intern dto dictionary key failure)
-      (define pure (dict-pure? dto dictionary))
-      (dict-find-update* dto dictionary key
+      (dict-find-update dto dictionary key
                   (lambda (insert _)
                     (let ((value (failure)))
-                     (if pure
-                         (values (insert value) value)   
-                         (begin
-                           (insert value)
-                           value))))
+                     (values (insert value) value)))
                   (lambda (key value update _)
-                    (if pure
-                        (values dictionary value)
-                        value))))
+                    (values dictionary value))))
 
     (define (default-dict-update dto dictionary key updater failure success)
-      (dict-find-update* dto dictionary key
+      (dict-find-update dto dictionary key
                   (lambda (insert ignore)
                     (insert (updater (failure))))
                   (lambda (key value update _)
                     (update key (updater (success value))))))
 
     (define (default-dict-update/default dto dictionary key updater default)
-      (dict-update* dto dictionary key updater
+      (dict-update dto dictionary key updater
                     (lambda () default)
                     (lambda (x) x)))
 
@@ -172,10 +125,8 @@
            (dict-for-each dto
                           (lambda (key value)
                             (define new-dict
-                              (dict-delete-all* dto dictionary (list key)))
-                            (if (dict-pure? dto dictionary)
-                                (cont new-dict key value)   
-                                (cont key value)))
+                              (dict-delete-all dto dictionary (list key)))
+                            (cont new-dict key value))
                           dictionary))))
       (define empty? (dict-empty? dto dictionary))
       (if empty?
@@ -191,10 +142,10 @@
          (lambda (key)
            (not (pred key (dict-ref dto dictionary key))))
          keys))
-      (dict-delete-all* dto dictionary keys-to-delete))
+      (dict-delete-all dto dictionary keys-to-delete))
 
     (define (default-dict-remove dto pred dictionary)
-      (dict-filter* dto (lambda (key value)
+      (dict-filter dto (lambda (key value)
                           (not (pred key value)))
                     dictionary))
 
@@ -295,12 +246,8 @@
             any))
       (define (accept el)
         (and (upper el) (lower el)))
-      (define map-proc
-        (if (dict-pure? dto dict)
-            dict-map
-            dict-map!))
       
-      (map-proc 
+      (dict-map 
         dto
         (lambda (key value)
           (when (accept key)
@@ -370,23 +317,16 @@
         (call/cc get-next-value)))
 
     (define (default-dict-accumulator dto dict acc-proc)
-      (define pure (dict-pure? dto dict))
       (lambda (arg)
         (if (eof-object? arg)
             dict
-            (if pure
-                (set! dict (acc-proc dto dict (car arg) (cdr arg)))   
-                (acc-proc dto dict (car arg) (cdr arg))))))
+            (set! dict (acc-proc dto dict (car arg) (cdr arg))))))
 
     (define (default-dict-set-accumulator dto dict)
-      (if (dict-pure? dto dict)
-          (default-dict-accumulator dto dict dict-set)
-          (default-dict-accumulator dto dict dict-set!)))
+      (default-dict-accumulator dto dict dict-set))
 
     (define (default-dict-adjoin-accumulator dto dict)
-      (if (dict-pure? dto dict)
-          (default-dict-accumulator dto dict dict-adjoin)
-          (default-dict-accumulator dto dict dict-adjoin!)))
+      (default-dict-accumulator dto dict dict-adjoin))
 
     (let ()
       (define null-dto (make-dto-private (make-vector dict-procedures-count #f)))
diff --git a/srfi/externals.scm b/srfi/externals.scm
index d08f4a4..f1045e5 100644
--- a/srfi/externals.scm
+++ b/srfi/externals.scm
@@ -26,38 +26,6 @@
        (assume (dto? dto))
        (apply (dto-ref-stx dto index) dto args)))))
 
-;; define mutable and immutable versions of a procedure (such as dict-set! and dict-set)
-;; with appropriate assertion for dict-mutable? value
-;; when dto 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 dto dict . args)
-         (assume (dto? dto))
-         (assume (not ((dto-ref-stx dto dict-pure?-id) dto dict)) index)
-         (apply (dto-ref-stx dto index) dto dict args))
-       (define (proc-immutable dto dict . args)
-         (assume (dto? dto))
-         (assume ((dto-ref-stx dto dict-pure?-id) dto dict) index)
-         (apply (dto-ref-stx dto index) dto 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 dto 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 dto proc dict)
-         (assume (dto? dto))
-         (assume (not ((dto-ref-stx dto dict-pure?-id) dto dict)) index)
-         ((dto-ref-stx dto index) dto proc dict))
-       (define (proc-immutable dto proc dict)
-         (assume (dto? dto))
-         (assume ((dto-ref-stx dto dict-pure?-id) dto dict) index)
-         ((dto-ref-stx dto index) dto proc dict))))))
-
 (define/dict-proc dictionary? dictionary?-id)
 (define/dict-proc dict-empty? dict-empty?-id)
 (define/dict-proc dict-contains? dict-contains?-id)
@@ -79,12 +47,12 @@
      ((dto-ref-stx dto dict-ref-id) dto dict key failure success))))
 
 (define/dict-proc dict-ref/default dict-ref/default-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-proc dict-set dict-set-id)
+(define/dict-proc dict-adjoin dict-adjoin-id)
+(define/dict-proc dict-delete dict-delete-id)
+(define/dict-proc dict-delete-all dict-delete-all-id)
+(define/dict-proc dict-replace dict-replace-id)
+(define/dict-proc dict-intern dict-intern-id)
 
 (define dict-update
   (case-lambda
@@ -98,30 +66,14 @@
 
     ((dto dict key updater failure success)
      (assume (dto? dto))
-     (assume ((dto-ref-stx dto dict-pure?-id) dto dict))
-     ((dto-ref-stx dto dict-update-id) dto dict key updater failure success))))
-
-(define dict-update!
-  (case-lambda
-    ((dto dict key updater)
-     (dict-update dto dict key updater
-                  (lambda () (error "Key not found in dictionary" dict key))
-                  values))
-
-    ((dto dict key updater failure)
-     (dict-update dto dict key  updater failure values))
-
-    ((dto dict key updater failure success)
-     (assume (dto? dto))
-     (assume (not ((dto-ref-stx dto dict-pure?-id) dto dict)))
      ((dto-ref-stx dto dict-update-id) dto 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-find-update dict-find-update! dict-find-update-id)
+(define/dict-proc dict-update/default dict-update/default-id)
+(define/dict-proc dict-pop dict-pop-id)
+(define/dict-proc dict-map dict-map-id)
+(define/dict-proc dict-filter dict-filter-id)
+(define/dict-proc dict-remove dict-remove-id)
+(define/dict-proc dict-find-update dict-find-update-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)
@@ -146,8 +98,8 @@
     ((dto dict start) (dict->generator dto dict start #f))
     ((dto dict start end) ((dto-ref-stx dto dict->generator-id) dto dict start end))))
 
-(define/dict-proc-pair dict-set-accumulator dict-set!-accumulator dict-set-accumulator-id)
-(define/dict-proc-pair dict-adjoin-accumulator dict-adjoin!-accumulator dict-adjoin-accumulator-id)
+(define/dict-proc dict-set-accumulator dict-set-accumulator-id)
+(define/dict-proc dict-adjoin-accumulator dict-adjoin-accumulator-id)
 
 (define (dto-ref dto procindex)
   (dto-ref-stx dto procindex))
diff --git a/srfi/srfi-125-impl.scm b/srfi/srfi-125-impl.scm
index 736a27c..b3affe4 100644
--- a/srfi/srfi-125-impl.scm
+++ b/srfi/srfi-125-impl.scm
@@ -5,27 +5,32 @@
      #f)
 
     (define (t125-hash-table-set* dto table . obj)
-      (apply t125-hash-table-set! (cons table obj)))
+      (apply t125-hash-table-set! (cons table obj))
+      table)
 
     (define (t125-hash-table-update* dto table key updater fail success)
-      (t125-hash-table-update! table key updater fail success))
+      (t125-hash-table-update! table key updater fail success)
+      table)
 
     (define (t125-hash-table-update/default* dto table key proc default)
-      (t125-hash-table-update!/default table key proc default))
+      (t125-hash-table-update!/default table key proc default)
+      table)
 
     (define (t125-hash-table-intern* dto table key failure)
-      (t125-hash-table-intern! table key failure))
+      (values table (t125-hash-table-intern! table key failure)))
 
     (define (t125-hash-table-pop* dto table)
       (if (t125-hash-table-empty? table)
           (error "popped empty dictionary")
-          (t125-hash-table-pop! table)))
+          (call-with-values (lambda () (t125-hash-table-pop! table))
+                            (lambda (key value) (values table key value)))))
 
     (define (t125-hash-table-delete-all* dto table keys)
       (for-each
           (lambda (key)
             (t125-hash-table-delete! table key))
-          keys))
+          keys)
+      table)
 
     (define (t125-hash-table-map* dto proc table)
       (t125-hash-table-map! proc table))
@@ -34,10 +39,12 @@
       (t125-hash-table-prune!
           (lambda (key value)
             (not (proc key value)))
-          table))
+          table)
+      table)
 
     (define (t125-hash-table-remove* dto proc table)
-      (t125-hash-table-prune! proc table))
+      (t125-hash-table-prune! proc table)
+      table)
 
     (define (t125-hash-table-find-update* dto table key fail success)
       ;; instead of running immediately,
@@ -47,19 +54,21 @@
         (define (update new-key new-value)
           (unless (eq? new-key key)
             (t125-hash-table-delete! table key))
-          (t125-hash-table-set! table new-key new-value))
+          (t125-hash-table-set! table new-key new-value)
+          table)
         (define (remove)
-          (t125-hash-table-delete! table key))
+          (t125-hash-table-delete! table key)
+          table)
         (lambda ()
           (success key value update remove) ))
       (define (make-failure-thunk)
         (define (ignore)
           table)
         (define (insert value)
-          (t125-hash-table-set! table key value))
+          (t125-hash-table-set! table key value)
+          table)
         (lambda ()
           (fail insert ignore)))
-
       (define thunk (t125-hash-table-ref table key make-failure-thunk make-success-thunk))
       (thunk))
 
diff --git a/srfi/srfi-126-impl.scm b/srfi/srfi-126-impl.scm
index b4c9845..4bdb53d 100644
--- a/srfi/srfi-126-impl.scm
+++ b/srfi/srfi-126-impl.scm
@@ -23,50 +23,60 @@
              #t
              (begin
                (t126-hashtable-set! table (car obj) (cadr obj))
-               (loop (cddr obj))))))
+               (loop (cddr obj)))))
+      table)
 
     (define (t126-hashtable-delete-all* dto table keys)
       (for-each
           (lambda (key)
             (t126-hashtable-delete! table key))
-          keys))
+          keys)
+      table)
 
     (define (t126-hashtable-intern* dto table key default)
-      (t126-hashtable-intern! table key default))
+      (values table (t126-hashtable-intern! table key default)))
 
     (define (t126-hashtable-update/default* dto table key updater default)
-      (t126-hashtable-update! table key updater default))
+      (t126-hashtable-update! table key updater default)
+      table)
 
     (define (t126-hashtable-pop* dto table)
       (if (t126-hashtable-empty? table)
           (error "popped empty dictionary")
-          (t126-hashtable-pop! table)))
+          (call-with-values (lambda () (t126-hashtable-pop! table))
+                            (lambda (key value) (values table key value)))))
 
     (define (t126-hashtable-update-all* dto proc table)
-      (t126-hashtable-update-all! table proc))
+      (t126-hashtable-update-all! table proc)
+      table)
 
     (define (t126-hashtable-filter* dto proc table)
       (t126-hashtable-prune! table
                                (lambda (key value)
-                                 (not (proc key value)))))
+                                 (not (proc key value))))
+      table)
 
     (define (t126-hashtable-remove* dto proc table)
-      (t126-hashtable-prune! table proc))
+      (t126-hashtable-prune! table proc)
+      table)
 
     (define (t126-hashtable-find-update* dto table key fail success)
       (define (handle-success value)
         (define (update new-key new-value)
           (unless (eq? new-key key)
               (t126-hashtable-delete! table key))
-            (t126-hashtable-set! table new-key new-value))
+          (t126-hashtable-set! table new-key new-value)
+          table)
         (define (remove)
-          (t126-hashtable-delete! table key))
+          (t126-hashtable-delete! table key)
+          table)
         (success key value update remove))
       (define (handle-fail)
         (define (ignore)
           table)
         (define (insert value)
-          (t126-hashtable-set! table key value))
+          (t126-hashtable-set! table key value)
+          table)
         (fail insert ignore))
 
       (define default (cons #f #f))
diff --git a/srfi/srfi-69-impl.scm b/srfi/srfi-69-impl.scm
index dfa9b76..02e3d4a 100644
--- a/srfi/srfi-69-impl.scm
+++ b/srfi/srfi-69-impl.scm
@@ -21,7 +21,8 @@
             table
             (begin
               (t69-hash-table-set! table (car obj) (cadr obj))
-              (loop (cddr obj))))))
+              (loop (cddr obj)))))
+      table)
 
     (define (t69-hash-table-update!/default* dto table key proc default)
       (t69-hash-table-update!/default table key proc default)