make 125, 126 impure only

4 files changed, 166 insertions, 220 deletions

diff --git a/srfi-225-test.scm b/srfi-225-test.scm
index c36b062..011cdb7 100644
--- a/srfi-225-test.scm
+++ b/srfi-225-test.scm
@@ -153,7 +153,8 @@
     (test-skip 1))
   (test-group
    "dict-set!"
-   (define d (dict-set! dto (alist->dict '((a . b))) 'a 'c 'a2 'b2))
+   (define d (alist->dict '((a . b))))
+   (dict-set! dto d 'a 'c 'a2 'b2)
    (test-equal 'c (dict-ref dto d 'a ))
    (test-equal 'b2 (dict-ref dto d 'a2)))
 
@@ -171,7 +172,8 @@
     (test-skip 1))
   (test-group
    "dict-adjoin!"
-   (define d (dict-adjoin! dto (alist->dict '((a . b))) 'a 'c 'a2 'b2))
+   (define d (alist->dict '((a . b))))
+   (dict-adjoin! dto d 'a 'c 'a2 'b2)
    (test-equal 'b (dict-ref dto d 'a))
    (test-equal 'b2 (dict-ref dto d 'a2)))
 
@@ -188,7 +190,8 @@
     (test-skip 1))
   (test-group
    "dict-delete!"
-   (define d (dict-delete! dto (alist->dict '((a . b) (c . d))) 'a 'b))
+   (define d (alist->dict '((a . b) (c . d))))
+   (dict-delete! dto d 'a 'b)
    (test-equal (dict->alist dto d) '((c . d))))
 
   (when mutable?
@@ -204,7 +207,8 @@
     (test-skip 1))
   (test-group
    "dict-delete-all!"
-   (define d (dict-delete-all! dto (alist->dict '((a . b) (c . d))) '(a b)))
+   (define d (alist->dict '((a . b) (c . d))))
+   (dict-delete-all! dto d '(a b))
    (test-equal (dict->alist dto d) '((c . d))))
 
   (when mutable?
@@ -221,7 +225,8 @@
     (test-skip 1))
   (test-group
    "dict-replace!"
-   (define d (dict-replace! dto (alist->dict '((a . b) (c . d))) 'a 'b2))
+   (define d (alist->dict '((a . b) (c . d))))
+   (dict-replace! dto d 'a 'b2)
    (test-equal 'b2 (dict-ref dto d 'a))
    (test-equal 'd (dict-ref dto d 'c)))
 
@@ -253,19 +258,17 @@
    "dict-intern!"
    ;; intern existing
    (let ()
-     (define-values
-         (d value)
-       (dict-intern! dto (alist->dict '((a . b))) 'a (lambda () 'd)))
-     (test-equal 'b (dict-ref dto d 'a))
-     (test-equal 'b value))
+    (define d (alist->dict '((a . b))))
+    (define value (dict-intern! dto d 'a (lambda () 'd)))
+    (test-equal 'b (dict-ref dto d 'a))
+    (test-equal 'b value))
    ;; intern missing
    (let ()
-     (define-values
-         (d value)
-       (dict-intern! dto (alist->dict '((a . b))) 'c (lambda () 'd)))
-     (test-equal 'b (dict-ref dto d 'a))
-     (test-equal 'd (dict-ref dto d 'c))
-     (test-equal 'd value)))
+    (define d (alist->dict '((a . b))))
+    (define value (dict-intern! dto d 'c (lambda () 'd)))
+    (test-equal 'b (dict-ref dto d 'a))
+    (test-equal 'd (dict-ref dto d 'c))
+    (test-equal 'd value)))
 
   (when mutable?
     (test-skip 1))
@@ -297,19 +300,21 @@
    "dict-update!"
    ;; update existing
    (let ()
-     (define d (dict-update! dto (alist->dict '((a . "b"))) 'a
-                             (lambda (value)
-                               (string-append value "2"))
-                             error
-                             (lambda (x) (string-append x "1"))))
-     (test-equal "b12" (dict-ref dto d 'a)))
+    (define d (alist->dict '((a . "b"))))
+    (dict-update! dto d 'a
+                  (lambda (value)
+                    (string-append value "2"))
+                  error
+                  (lambda (x) (string-append x "1")))
+    (test-equal "b12" (dict-ref dto d 'a)))
    ;; update missing
    (let ()
-     (define d (dict-update! dto (alist->dict '((a . "b"))) 'c
-                             (lambda (value)
-                               (string-append value "2"))
-                             (lambda () "d1")
-                             (lambda (x) (string-append x "1"))))
+    (define d (alist->dict '((a . "b"))))
+    (dict-update! dto d 'c
+                  (lambda (value)
+                    (string-append value "2"))
+                  (lambda () "d1")
+                  (lambda (x) (string-append x "1")))
      (test-equal "d12" (dict-ref dto d 'c))))
 
   (when mutable?
@@ -341,19 +346,21 @@
    "dict-update/default!"
    ;; update existing
    (let ()
-     (define d (dict-update/default! dto (alist->dict '((a . "b"))) 'a
-                                     (lambda (value)
-                                       (string-append value "2"))
-                                     "d1"))
+    (define d (alist->dict '((a . "b"))))
+    (dict-update/default! dto d 'a
+                          (lambda (value)
+                            (string-append value "2"))
+                          "d1")
      (test-equal "b2" (dict-ref dto d 'a)))
 
    ;; update missing
    (let ()
-     (define d (dict-update/default! dto (alist->dict '((a . "b"))) 'c
-                                     (lambda (value)
-                                       (string-append value "2"))
-                                     "d1"))
-     (test-equal "d12" (dict-ref dto d 'c))))
+    (define d (alist->dict '((a . "b"))))
+    (dict-update/default! dto d 'c
+                          (lambda (value)
+                            (string-append value "2"))
+                          "d1")
+    (test-equal "d12" (dict-ref dto d 'c))))
 
   (when mutable?
     (test-skip 1))
@@ -379,16 +386,17 @@
     (test-skip 1))
   (test-group
    "dict-pop!"
+   (define d (alist->dict '((a . b) (c . d))))
    (define-values
-       (new-dict key value)
-     (dict-pop! dto (alist->dict '((a . b) (c . d)))))
+       (key value)
+     (dict-pop! dto d))
    (test-assert
        (or
-        (and (equal? (dict->alist dto new-dict) '((c . d)))
+        (and (equal? (dict->alist dto d) '((c . d)))
              (equal? key 'a)
              (equal? value 'b))
 
-        (and (equal? (dict->alist dto new-dict) '((a . b)))
+        (and (equal? (dict->alist dto d) '((a . b)))
              (equal? key 'c)
              (equal? value 'd)))))
 
@@ -410,10 +418,11 @@
     (test-skip 1))
   (test-group
    "dict-map!"
-   (define d (dict-map! dto
-                        (lambda (key value)
-                          (string-append value "2"))
-                        (alist->dict '((a . "a") (b . "b")))))
+   (define d (alist->dict '((a . "a") (b . "b"))))
+   (dict-map! dto
+              (lambda (key value)
+                (string-append value "2"))
+              d)
    (test-equal "a2" (dict-ref dto d 'a))
    (test-equal "b2" (dict-ref dto d 'b)))
 
@@ -434,10 +443,11 @@
     (test-skip 1))
   (test-group
    "dict-filter!"
-   (define d (dict-filter! dto
-                           (lambda (key value)
-                             (equal? value 'b))
-                           (alist->dict '((a . b) (c . d)))))
+   (define d (alist->dict '((a . b) (c . d))))
+   (dict-filter! dto
+                 (lambda (key value)
+                   (equal? value 'b))
+                 d)
    (test-equal '((a . b)) (dict->alist dto d)))
 
   (when mutable?
@@ -456,10 +466,11 @@
     (test-skip 1))
   (test-group
    "dict-remove!"
-   (define d (dict-remove! dto
-                           (lambda (key value)
-                             (equal? value 'b))
-                           (alist->dict '((a . b) (c . d)))))
+   (define d (alist->dict '((a . b) (c . d))))
+   (dict-remove! dto
+                 (lambda (key value)
+                   (equal? value 'b))
+                 d)
    (test-equal '((c . d)) (dict->alist dto d)))
 
   (when mutable?
@@ -516,40 +527,44 @@
    "dict-find-update!"
    ;; ignore
    (let ()
-    (define dict (dict-find-update! dto (alist->dict '((a . b))) 'c
+    (define dict (alist->dict '((a . b))))
+    (dict-find-update! dto dict 'c
                               (lambda (insert ignore)
                                 (ignore))
                               (lambda args
-                                (error "shouldn't happen"))))
-     (test-equal '((a . b)) (dict->alist dto dict)))
+                                (error "shouldn't happen")))
+    (test-equal '((a . b)) (dict->alist dto dict)))
 
    ;; insert
    (let ()
-     (define dict (dict-find-update! dto (alist->dict '((a . b))) 'c
-                               (lambda (insert ignore)
-                                 (insert 'd))
-                               (lambda args
-                                 (error "shouldn't happen"))))
-     (test-equal 'b (dict-ref dto dict 'a))
-     (test-equal 'd (dict-ref dto dict 'c)))
+    (define dict (alist->dict '((a . b))))
+    (dict-find-update! dto dict 'c
+                       (lambda (insert ignore)
+                         (insert 'd))
+                       (lambda args
+                         (error "shouldn't happen")))
+    (test-equal 'b (dict-ref dto dict 'a))
+    (test-equal 'd (dict-ref dto dict 'c)))
 
    ;; update
    (let ()
-     (define dict (dict-find-update! dto (alist->dict '((a . b))) 'a
-                               (lambda args
-                                 (error "shouldn't happen"))
-                               (lambda (key value update delete)
-                                 (update 'a2 'b2))))
+    (define dict (alist->dict '((a . b))))
+    (dict-find-update! dto dict 'a
+                       (lambda args
+                         (error "shouldn't happen"))
+                       (lambda (key value update delete)
+                         (update 'a2 'b2)))
      (test-equal '((a2 . b2)) (dict->alist dto dict)))
 
    ;; delete
    (let ()
-     (define dict (dict-find-update! dto (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 dto dict))))
+    (define dict (alist->dict '((a . b) (c . d))))
+    (dict-find-update! dto dict 'a
+                       (lambda args
+                         (error "shouldn't happen"))
+                       (lambda (key value update delete)
+                         (delete)))
+    (test-equal '((c . d)) (dict->alist dto dict))))
 
   (test-group
    "dict-size"
@@ -893,7 +908,7 @@
 (cond-expand
   ((library (srf 125))
    (test-group
-     "srfi-125 mutable"
+     "srfi-125"
      (do-test
        hash-table-dto
        (lambda (alist)
@@ -904,26 +919,13 @@
            alist)
          table)
        (make-default-comparator)
-       #t))
-   (test-group
-     "srfi-125 immutable"
-     (do-test
-       hash-table-dto
-       (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)))
+       #t)))
   (else))
 
 (cond-expand
   ((library (srfi 126))
    (test-group
-     "srfi-126 (r6rs) mutable"
+     "srfi-126 (r6rs)"
      (do-test
        srfi-126-dto
        (lambda (alist)
@@ -934,20 +936,7 @@
            alist)
          table)
        (make-default-comparator)
-       #t))
-   (test-group
-     "srfi-126 (r6rs) immutable"
-     (do-test
-       srfi-126-dto
-       (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)))
+       #t)))
   (else))
 
 (cond-expand
diff --git a/srfi/default-impl.scm b/srfi/default-impl.scm
index e2ff29d..24b20d6 100644
--- a/srfi/default-impl.scm
+++ b/srfi/default-impl.scm
@@ -17,26 +17,41 @@
       (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)
-          (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)
-          (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)
-          (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)
-          (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)))
@@ -85,7 +100,7 @@
           (error "mismatch of key / values argument list" objs))
          (else (let* ((key (car objs))
                       (value (cadr objs))
-                      (new-d (dict-find-update* dto dictionary key
+                      (new-d (dict-find-update*/dict dto dictionary key
                                          (lambda (insert ignore)
                                            (insert value))
                                          (lambda (key old-value update delete)
@@ -108,7 +123,7 @@
         (cond
           ((null? keylist) d)
           (else (let* ((key (car keylist))
-                       (new-d (dict-find-update* dto d key
+                       (new-d (dict-find-update*/dict dto d key
                                           (lambda (_ ignore)
                                             (ignore))
                                           (lambda (key old-value _ delete)
@@ -124,12 +139,19 @@
                     (update key value))))
 
     (define (default-dict-intern dto dictionary key failure)
+      (define pure (dict-pure? dto dictionary))
       (dict-find-update* dto dictionary key
                   (lambda (insert _)
                     (let ((value (failure)))
-                     (values (insert value) value)))
+                     (if pure
+                         (values (insert value) value)   
+                         (begin
+                           (insert value)
+                           value))))
                   (lambda (key value update _)
-                    (values dictionary value))))
+                    (if pure
+                        (values dictionary value)
+                        value))))
 
     (define (default-dict-update dto dictionary key updater failure success)
       (dict-find-update* dto dictionary key
@@ -151,7 +173,9 @@
                           (lambda (key value)
                             (define new-dict
                               (dict-delete-all* dto dictionary (list key)))
-                            (cont new-dict key value))
+                            (if (dict-pure? dto dictionary)
+                                (cont new-dict key value)   
+                                (cont key value)))
                           dictionary))))
       (define empty? (dict-empty? dto dictionary))
       (if empty?
@@ -346,10 +370,13 @@
         (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
-            (set! dict (acc-proc dto dict (car arg) (cdr arg))))))
+            (if pure
+                (set! dict (acc-proc dto dict (car arg) (cdr arg)))   
+                (acc-proc dto dict (car arg) (cdr arg))))))
 
     (define (default-dict-set-accumulator dto dict)
       (if (dict-pure? dto dict)
diff --git a/srfi/srfi-125-impl.scm b/srfi/srfi-125-impl.scm
index a63aba9..9431de8 100644
--- a/srfi/srfi-125-impl.scm
+++ b/srfi/srfi-125-impl.scm
@@ -1,75 +1,47 @@
 (define hash-table-dto
   (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-pure?* dto table)
-     (not (t125-hash-table-mutable? table)))
+     #f)
 
     (define (t125-hash-table-set* dto table . obj)
-      (guard-immutable table
-        (apply t125-hash-table-set! (cons table obj))
-        table))
+      (apply t125-hash-table-set! (cons table obj)))
 
     (define (t125-hash-table-update* dto table key updater fail success)
-      (guard-immutable table
-        (t125-hash-table-update! table key updater fail success)
-        table))
+      (t125-hash-table-update! table key updater fail success))
 
     (define (t125-hash-table-update/default* dto table key proc default)
-      (guard-immutable table
-        (t125-hash-table-update!/default table key proc default)
-        table))
+      (t125-hash-table-update!/default table key proc default))
 
     (define (t125-hash-table-intern* dto table key failure)
-      (guard-immutable table
-        (define val (t125-hash-table-intern! table key failure))
-        (values table val)))
+      (t125-hash-table-intern! table key failure))
 
     (define (t125-hash-table-pop* dto 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))))
+          (let ()
+           (define-values
+             (key value)
+             (t125-hash-table-pop! table))
+           (values table key value))))
 
     (define (t125-hash-table-delete-all* dto table keys)
-      (guard-immutable table
-        (for-each
+      (for-each
           (lambda (key)
             (t125-hash-table-delete! table key))
-          keys)
-        table))
+          keys))
 
     (define (t125-hash-table-map* dto proc table)
-      (guard-immutable table
-        (t125-hash-table-map! proc table)
-        table))
+      (t125-hash-table-map! proc table))
 
     (define (t125-hash-table-filter* dto proc table)
-      (guard-immutable table
-        (t125-hash-table-prune!
+      (t125-hash-table-prune!
           (lambda (key value)
             (not (proc key value)))
-          table)
-        table))
+          table))
 
     (define (t125-hash-table-remove* dto proc table)
-      (guard-immutable table
-        (t125-hash-table-prune! proc table)
-        table))
+      (t125-hash-table-prune! proc table))
 
     (define (t125-hash-table-find-update* dto table key fail success)
       ;; instead of running immediately,
@@ -77,24 +49,18 @@
       ;; to guarantee call in tail position
       (define (make-success-thunk 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))
+          (unless (eq? new-key key)
+            (t125-hash-table-delete! table key))
+          (t125-hash-table-set! table new-key new-value))
         (define (remove)
-          (guard-immutable table
-            (t125-hash-table-delete! table key)
-            table))
+          (t125-hash-table-delete! table key))
         (lambda ()
           (success key value update remove) ))
       (define (make-failure-thunk)
         (define (ignore)
           table)
         (define (insert value)
-          (guard-immutable table
-            (t125-hash-table-set! table key value)
-            table))
+          (t125-hash-table-set! table key value))
         (lambda ()
           (fail insert ignore)))
 
diff --git a/srfi/srfi-126-impl.scm b/srfi/srfi-126-impl.scm
index 815b9cf..b4c9845 100644
--- a/srfi/srfi-126-impl.scm
+++ b/srfi/srfi-126-impl.scm
@@ -1,24 +1,12 @@
 (define srfi-126-dto
   (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-dto-arg proc)
       (lambda (dto . args)
         (apply proc args)))
     
     (define (t126-hashtable-pure?* dto table)
-      (not (t126-hashtable-mutable? table)))
+      #f)
 
     (define (t126-hashtable-ref* dto table key fail success)
       (define-values (value found?) (t126-hashtable-lookup table key))
@@ -30,79 +18,55 @@
       (t126-hashtable-ref table key default))
 
     (define (t126-hashtable-set* dto table . obj)
-      (guard-immutable table
-        (let loop ((obj obj))
+      (let loop ((obj obj))
          (if (null? obj)
              #t
              (begin
                (t126-hashtable-set! table (car obj) (cadr obj))
-               (loop (cddr obj)))))
-        table))
+               (loop (cddr obj))))))
 
     (define (t126-hashtable-delete-all* dto table keys)
-      (guard-immutable table
-        (for-each
+      (for-each
           (lambda (key)
             (t126-hashtable-delete! table key))
-          keys)
-        table))
+          keys))
 
     (define (t126-hashtable-intern* dto table key default)
-      (guard-immutable table
-        (define val (t126-hashtable-intern! table key default))
-        (values table val)))
+      (t126-hashtable-intern! table key default))
 
     (define (t126-hashtable-update/default* dto table key updater default)
-      (guard-immutable table
-        (t126-hashtable-update! table key updater default)
-        table))
+      (t126-hashtable-update! table key updater default))
 
     (define (t126-hashtable-pop* dto 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))))
+          (t126-hashtable-pop! table)))
 
     (define (t126-hashtable-update-all* dto proc table)
-      (guard-immutable table
-        (t126-hashtable-update-all! table proc)
-        table))
+      (t126-hashtable-update-all! table proc))
 
     (define (t126-hashtable-filter* dto proc table)
-      (guard-immutable table
-        (t126-hashtable-prune! table
+      (t126-hashtable-prune! table
                                (lambda (key value)
-                                 (not (proc key value))))
-        table))
+                                 (not (proc key value)))))
 
     (define (t126-hashtable-remove* dto proc table)
-      (guard-immutable table
-        (t126-hashtable-prune! table proc)
-        table))
+      (t126-hashtable-prune! table proc))
 
     (define (t126-hashtable-find-update* dto table key fail success)
       (define (handle-success value)
         (define (update new-key new-value)
-          (guard-immutable table
-            (unless (eq? new-key key)
+          (unless (eq? new-key key)
               (t126-hashtable-delete! table key))
-            (t126-hashtable-set! table new-key new-value)
-            table))
+            (t126-hashtable-set! table new-key new-value))
         (define (remove)
-          (guard-immutable table
-            (t126-hashtable-delete! table key)
-            table))
+          (t126-hashtable-delete! table key))
         (success key value update remove))
       (define (handle-fail)
         (define (ignore)
           table)
         (define (insert value)
-          (guard-immutable table
-            (t126-hashtable-set! table key value)
-            table))
+          (t126-hashtable-set! table key value))
         (fail insert ignore))
 
       (define default (cons #f #f))