Merge pull request #3 from arvyy/master

Implementation update

1 files changed, 219 insertions, 233 deletions

diff --git a/srfi-225-test.scm b/srfi-225-test.scm
index 1ef4231..8a81504 100644
--- a/srfi-225-test.scm
+++ b/srfi-225-test.scm
@@ -75,6 +75,9 @@
   (call/cc (lambda (cont)
              (with-exception-handler
                (lambda (err)
+                 (when expect-success
+                   (display err)
+                   (newline))
                  (unless expect-success
                    (cont #t)))
                (lambda ()
@@ -150,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)))
 
@@ -168,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)))
 
@@ -185,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?
@@ -201,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?
@@ -218,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)))
 
@@ -250,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))
@@ -294,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?
@@ -338,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))
@@ -376,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)))))
 
@@ -407,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)))
 
@@ -431,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?
@@ -453,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?
@@ -513,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"
@@ -635,15 +653,49 @@
 
   (test-group
    "dict-fold"
-   (define value
-     (dict-fold dto
-                (lambda (key value acc)
-                  (append acc (list key value)))
-                '()
-                (alist->dict '((a . b) (c . d)))))
-   (test-assert
-       (or (equal? '(a b c d) value)
-           (equal? '(c d a b) value))))
+   
+   ;; simple case
+   (let ()
+    (define value
+      (dict-fold dto
+                 (lambda (key value acc)
+                   (append acc (list key value)))
+                 '()
+                 (alist->dict '((a . b) (c . d)))))
+    (test-assert
+      (or (equal? '(a b c d) value)
+          (equal? '(c d a b) value))))
+   
+   (let ()
+
+     ;; continuation captured in a middle of fold
+    (define k #f)
+    (define pass 0)
+
+    (define value
+      (dict-fold dto
+                 (lambda (key value acc)
+                   ;; check fold only starts once -- further passes enter in a middle
+                   (test-assert (not (and k
+                                          (null? acc))))
+                   ;; capture continuation on second fold iteration
+                   (when (and (not k)
+                              (not (null? acc)))
+                     (test-assert
+                       (or (equal? '(a b) acc)
+                           (equal? '(c d) acc)))
+                     (call/cc (lambda (cont) (set! k cont))))
+                   (append acc (list key value)))
+                 '()
+                 (alist->dict '((a . b) (c . d)))))
+
+    (test-assert
+      (or (equal? '(a b c d) value)
+          (equal? '(c d a b) value)))
+
+    (when (< pass 3)
+      (set! pass (+ 1 pass))
+      (k #t))))
 
   (test-group
    "dict-map->list"
@@ -683,140 +735,78 @@
                                       (2 . b)
                                       (3 . c)
                                       (4 . d)))))
-      '(1 2 3 4)))
-
-  (test-group
-    "dict-for-each<"
-    (test-for-each (let* ((cmp (dict-comparator dto (alist->dict '())))
-                          (ordering (and cmp (comparator-ordered? cmp))))
-                     ordering)
-      (lambda (proc)
-        (dict-for-each< dto
-                        proc
-                        (alist->dict '((1 . a)
-                                       (2 . b)
-                                       (3 . c)
-                                       (4 . d)))
-                        3))
-      '(1 2)))
-
-  (test-group
-    "dict-for-each<="
-    (test-for-each (let* ((cmp (dict-comparator dto (alist->dict '())))
-                          (ordering (and cmp (comparator-ordered? cmp))))
-                     ordering)
-      (lambda (proc)
-        (dict-for-each<= dto
-                        proc
-                        (alist->dict '((1 . a)
-                                       (2 . b)
-                                       (3 . c)
-                                       (4 . d)))
-                        3))
-      '(1 2 3)))
-
-  (test-group
-    "dict-for-each>"
+      '(1 2 3 4))
+    
     (test-for-each (let* ((cmp (dict-comparator dto (alist->dict '())))
                           (ordering (and cmp (comparator-ordered? cmp))))
                      ordering)
-      (lambda (proc)
-        (dict-for-each> dto
-                        proc
-                        (alist->dict '((1 . a)
-                                       (2 . b)
-                                       (3 . c)
-                                       (4 . d)))
-                        2))
-      '(3 4)))
-
-  (test-group
-    "dict-for-each>="
-    (test-for-each (let* ((cmp (dict-comparator dto (alist->dict '())))
-                          (ordering (and cmp (comparator-ordered? cmp))))
-                     ordering)
-      (lambda (proc)
-        (dict-for-each>= dto
-                        proc
-                        (alist->dict '((1 . a)
-                                       (2 . b)
-                                       (3 . c)
-                                       (4 . d)))
-                        2))
-      '(2 3 4)))
-
-  (test-group
-    "dict-for-each-in-open-interval"
-    (test-for-each (let* ((cmp (dict-comparator dto (alist->dict '())))
-                          (ordering (and cmp (comparator-ordered? cmp))))
-                     ordering)
-      (lambda (proc)
-        (dict-for-each-in-open-interval dto
-                                        proc
-                                        (alist->dict '((1 . a)
-                                                       (2 . b)
-                                                       (3 . c)
-                                                       (4 . d)))
-                                        1 4))
-      '(2 3)))
+                   (lambda (proc)
+                     (dict-for-each dto
+                                    proc
+                                    (alist->dict '((1 . a)
+                                                   (2 . b)
+                                                   (3 . c)
+                                                   (4 . d)))
+                                    2))
+                   '(2 3 4))
 
-  (test-group
-    "dict-for-each-in-closed-interval"
     (test-for-each (let* ((cmp (dict-comparator dto (alist->dict '())))
                           (ordering (and cmp (comparator-ordered? cmp))))
                      ordering)
-      (lambda (proc)
-        (dict-for-each-in-closed-interval dto
-                                        proc
-                                        (alist->dict '((1 . a)
-                                                       (2 . b)
-                                                       (3 . c)
-                                                       (4 . d)))
-                                        1 4))
-      '(1 2 3 4)))
+                   (lambda (proc)
+                     (dict-for-each dto
+                                    proc
+                                    (alist->dict '((1 . a)
+                                                   (2 . b)
+                                                   (3 . c)
+                                                   (4 . d)))
+                                    2
+                                    3))
+                   '(2 3)))
+
+  (test-group
+    "dict->generator"
+    (test-for-each #t
+                   (lambda (proc)
+                     (generator-for-each
+                       (lambda (entry)
+                         (proc (car entry) (cdr entry)))
+                       (dict->generator dto (alist->dict '((1 . a)
+                                                           (2 . b)
+                                                           (3 . c)
+                                                           (4 . d))))))
+                   '(1 2 3 4))
 
-  (test-group
-    "dict-for-each-in-open-closed-interval"
     (test-for-each (let* ((cmp (dict-comparator dto (alist->dict '())))
                           (ordering (and cmp (comparator-ordered? cmp))))
                      ordering)
-      (lambda (proc)
-        (dict-for-each-in-open-closed-interval dto
-                                               proc
-                                               (alist->dict '((1 . a)
-                                                              (2 . b)
-                                                              (3 . c)
-                                                              (4 . d)))
-                                               1 4))
-      '(2 3 4)))
+                   (lambda (proc)
+                     (generator-for-each
+                       (lambda (entry)
+                         (proc (car entry) (cdr entry)))
+                       (dict->generator dto (alist->dict '((1 . a)
+                                                           (2 . b)
+                                                           (3 . c)
+                                                           (4 . d)))
+                                        2)))
+                   '(2 3 4))
 
-  (test-group
-    "dict-for-each-in-closed-open-interval"
     (test-for-each (let* ((cmp (dict-comparator dto (alist->dict '())))
                           (ordering (and cmp (comparator-ordered? cmp))))
                      ordering)
-      (lambda (proc)
-        (dict-for-each-in-closed-open-interval dto
-                                               proc
-                                               (alist->dict '((1 . a)
-                                                              (2 . b)
-                                                              (3 . c)
-                                                              (4 . d)))
-                                               1 4))
-      '(1 2 3)))
-
-  (test-group
-    "make-dict-generator"
-    (test-for-each #t
-      (lambda (proc)
-        (generator-for-each
-          (lambda (entry)
-            (proc (car entry) (cdr entry)))
-          (make-dict-generator dto (alist->dict '((1 . a)
-                                                  (2 . b)
-                                                  (3 . c))))))
-      '(1 2 3)))
+                   (lambda (proc)
+                     (generator-for-each
+                       (lambda (entry)
+                         (proc (car entry) (cdr entry)))
+                       (dict->generator dto (alist->dict '((1 . a)
+                                                           (2 . b)
+                                                           (3 . c)
+                                                           (4 . d)))
+                                        2 3)))
+                   '(2 3)))
 
+  (when mutable?
+    (test-skip 1))
   (test-group
     "dict-set-accumulator"
     (define acc (dict-set-accumulator dto (alist->dict '())))
@@ -824,7 +814,19 @@
     (acc (cons 2 'b))
     (acc (cons 2 'c))
     (test-assert (dict=? dto equal? (acc (eof-object)) (alist->dict '((1 . a) (2 . c))))))
+  
+  (unless mutable?
+    (test-skip 1))
+  (test-group
+    "dict-set!-accumulator"
+    (define acc (dict-set!-accumulator dto (alist->dict '())))
+    (acc (cons 1 'a))
+    (acc (cons 2 'b))
+    (acc (cons 2 'c))
+    (test-assert (dict=? dto equal? (acc (eof-object)) (alist->dict '((1 . a) (2 . c))))))
 
+  (when mutable?
+    (test-skip 1))
   (test-group
     "dict-adjoin-accumulator"
     (define acc (dict-adjoin-accumulator dto (alist->dict '())))
@@ -832,6 +834,16 @@
     (acc (cons 2 'b))
     (acc (cons 2 'c))
     (test-assert (dict=? dto equal? (acc (eof-object)) (alist->dict '((1 . a) (2 . b))))))
+  
+  (unless mutable?
+    (test-skip 1))
+  (test-group
+    "dict-adjoin!-accumulator"
+    (define acc (dict-adjoin!-accumulator dto (alist->dict '())))
+    (acc (cons 1 'a))
+    (acc (cons 2 'b))
+    (acc (cons 2 'c))
+    (test-assert (dict=? dto equal? (acc (eof-object)) (alist->dict '((1 . a) (2 . b))))))
 
   ;; check all procs were called
   (for-each
@@ -849,10 +861,10 @@
  (define minimal-alist-dto
    (make-dto
     dictionary?-id (dto-ref alist-dto dictionary?-id)
-    dict-mutable?-id (dto-ref alist-dto dict-mutable?-id)
+    dict-pure?-id (dto-ref alist-dto dict-pure?-id)
     dict-size-id (dto-ref alist-dto dict-size-id)
     dict-find-update-id (dto-ref alist-dto dict-find-update-id)
-    dict-for-each-id (dto-ref alist-dto dict-for-each-id)
+    dict-map-id (dto-ref alist-dto dict-map-id)
     dict-comparator-id (dto-ref alist-dto dict-comparator-id)))
  (do-test
   minimal-alist-dto
@@ -894,9 +906,9 @@
   (else))
 
 (cond-expand
-  ((library (srf 125))
+  ((library (srfi 125))
    (test-group
-     "srfi-125 mutable"
+     "srfi-125"
      (do-test
        hash-table-dto
        (lambda (alist)
@@ -907,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)
@@ -937,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