fix default implementation

2 files changed, 26 insertions, 11 deletions

diff --git a/srfi/default-impl.scm b/srfi/default-impl.scm
index 4253f6a..dfd3f58 100644
--- a/srfi/default-impl.scm
+++ b/srfi/default-impl.scm
@@ -77,12 +77,12 @@
 
     (define (default-dict-delete-all* dtd dictionary dict-search-proc keylist)
       (let loop ((keylist keylist)
-                 (dictionary dictionary))
+                 (d dictionary))
         (cond
-         ((null? keylist) dictionary)
+         ((null? keylist) d)
          (else (let*-values
                    (((key) (car keylist))
-                    ((new-d _) (dict-search-proc dtd dictionary key
+                    ((new-d _) (dict-search-proc dtd d key
                                                  (lambda (_ ignore)
                                                    (ignore #f))
                                                  (lambda (key old-value _ delete)
@@ -198,7 +198,7 @@
          (lambda (key)
            (not (pred key (dict-ref dtd dictionary key))))
          keys))
-      (dict-delete-all-proc dtd dictionary keys))
+      (dict-delete-all-proc dtd dictionary keys-to-delete))
 
     (define (default-dict-filter dtd pred dictionary)
       (default-dict-filter* dtd dict-delete-all pred dictionary))
@@ -218,11 +218,20 @@
     (define (default-dict-remove! dtd pred dictionary)
       (default-dict-remove* dtd dict-filter! pred dictionary))
 
+    (define (create-fresh-dict-from-existing dtd dictionary)
+      (call/cc
+       (lambda (k)
+         (with-exception-handler
+             (lambda (err)
+               (k (make-dictionary dtd #f)))
+           (lambda ()
+             (make-dictionary dtd (dict-comparator dictionary)))))))
+
     (define (default-dict-copy dtd dictionary)
-      (define dict (make-dictionary (dict-comparator dtd dictionary)))
+      (define dict (create-fresh-dict-from-existing dtd dictionary))
       (dict-for-each dtd
                      (lambda (key value)
-                       (set! dict (dict-set! dtd key value)))
+                       (set! dict (dict-set! dtd dict key value)))
                      dictionary)
       dict)
 
diff --git a/srfi/externals.scm b/srfi/externals.scm
index 8fee936..34c8450 100644
--- a/srfi/externals.scm
+++ b/srfi/externals.scm
@@ -11,12 +11,18 @@
   (message dictionary-message)
   (irritants dictionary-irritants))
 
+(define-syntax dtd-ref-stx
+  (syntax-rules ()
+    ((_ dtd index)
+     (begin
+       (vector-ref (procvec dtd) index)))))
+
 (define-syntax define/dict-proc
   (syntax-rules ()
     ((_ proc index)
      (define (proc dtd . args)
        (assume (dtd? dtd))
-       (apply (vector-ref (procvec dtd) index) dtd args)))))
+       (apply (dtd-ref-stx dtd index) dtd args)))))
 
 (define/dict-proc make-dictionary make-dictionary-index)
 (define/dict-proc dictionary? dictionary?-index)
@@ -35,7 +41,7 @@
 
     ((dtd dict key failure success)
      (assume (dtd? dtd))
-     ((vector-ref (procvec dtd) dict-ref-index) dtd dict key failure success))))
+     ((dtd-ref-stx 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)
@@ -63,7 +69,7 @@
 
     ((dtd dict key updater failure success)
      (assume (dtd? dtd))
-     ((vector-ref (procvec dtd) dict-update-index) dtd dict key updater failure success))))
+     ((dtd-ref-stx dtd dict-update-index) dtd dict key updater failure success))))
 
 (define dict-update!
   (case-lambda
@@ -77,7 +83,7 @@
 
     ((dtd dict key updater failure success)
      (assume (dtd? dtd))
-     ((vector-ref (procvec dtd) dict-update!-index) dtd dict key updater failure success))))
+     ((dtd-ref-stx 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)
@@ -106,7 +112,7 @@
 (define/dict-proc dict-comparator dict-comparator-index)
 
 (define (dtd-ref dtd procindex)
-  (vector-ref (procvec dtd) procindex))
+  (dtd-ref-stx dtd procindex))
 
 (define (make-modified-dtd dtd . lst)
   (define vec (vector-copy (procvec dtd)))