Merge remote-tracking branch 'arvyy/master'

12 files changed, 173 insertions, 217 deletions

diff --git a/docker-compose.yml b/docker-compose.yml
index 3aa9e00..8ea257e 100644
--- a/docker-compose.yml
+++ b/docker-compose.yml
@@ -24,6 +24,18 @@ services:
         source: .
         target: /test/srfi-225
     command: "sh /test/srfi-225/docker-chibi.sh"
+  kawa:
+    image: "schemers/kawa"
+    depends_on:
+      - srfi_225_test
+    volumes:
+      - dependencies-volume:/dependencies
+      - target:/target
+      - type: bind
+        source: .
+        target: /test/srfi-225
+    command: "sh /test/srfi-225/docker-kawa.sh"
 
 volumes:
   dependencies-volume:
+  target:
diff --git a/docker-kawa.sh b/docker-kawa.sh
index 64de401..bf3ad2e 100644
--- a/docker-kawa.sh
+++ b/docker-kawa.sh
@@ -1,4 +1,4 @@
-mkdir /target
+rm -r /target/*
 
 for i in\
     "srfi-27/srfi/27"\
@@ -18,6 +18,7 @@ for i in\
 do
     CLASSPATH=target kawa -d target -C "dependencies/$i.sld"
 done
-
 CLASSPATH=target kawa --r7rs -d target -C "test/srfi-225/srfi/225.sld"
-CLASSPATH=target kawa --r7rs "test/srfi-225/srfi-225-test.scm"
+
+cd "/test/srfi-225"
+CLASSPATH=/target kawa --r7rs "srfi-225-test.scm"
diff --git a/makefile b/makefile
index 20e4509..5e7b2ef 100644
--- a/makefile
+++ b/makefile
@@ -9,6 +9,9 @@ test-chibi-docker:
 test-gauche-docker:
 	docker-compose run --rm gauche
 
+test-kawa-docker:
+	docker-compose run --rm kawa
+
 test-chibi:
 	chibi-scheme -I . srfi-225-test.scm
 
diff --git a/srfi-225-test.scm b/srfi-225-test.scm
index 9de1e7b..68402bc 100644
--- a/srfi-225-test.scm
+++ b/srfi-225-test.scm
@@ -135,34 +135,6 @@
    (test-equal (dict-ref/default dtd (alist->dict '((a . b))) 'a 'c) 'b)
    (test-equal (dict-ref/default dtd (alist->dict '((a* . b))) 'a 'c) 'c))
   
-  (test-group
-    "dict-min-key"
-    (define dict (alist->dict '((2 . a) (1 . b) (3 . c))))
-    (call/cc (lambda (cont)
-               (with-exception-handler
-                 (lambda (err)
-                   (unless (let* ((cmp (dict-comparator dtd (alist->dict '())))
-                                  (ordering (and cmp (comparator-ordering-predicate cmp))))
-                             ordering)
-                     (cont #t)))
-                 (lambda ()
-                   (define key (dict-min-key dtd dict))
-                   (test-equal 1 key))))))
-  
-  (test-group
-    "dict-max-key"
-    (define dict (alist->dict '((2 . a) (3 . b) (1 . c))))
-    (call/cc (lambda (cont)
-               (with-exception-handler
-                 (lambda (err)
-                   (unless (let* ((cmp (dict-comparator dtd (alist->dict '())))
-                                  (ordering (and cmp (comparator-ordering-predicate cmp))))
-                             ordering)
-                     (cont #t)))
-                 (lambda ()
-                   (define key (dict-max-key dtd dict))
-                   (test-equal 3 key))))))
-
   (when mutable?
     (test-skip 1))
   (test-group
@@ -716,7 +688,7 @@
   (test-group
     "dict-for-each<"
     (test-for-each (let* ((cmp (dict-comparator dtd (alist->dict '())))
-                          (ordering (and cmp (comparator-ordering-predicate cmp))))
+                          (ordering (and cmp (comparator-ordered? cmp))))
                      ordering)
       (lambda (proc)
         (dict-for-each< dtd 
@@ -731,7 +703,7 @@
   (test-group
     "dict-for-each<="
     (test-for-each (let* ((cmp (dict-comparator dtd (alist->dict '())))
-                          (ordering (and cmp (comparator-ordering-predicate cmp))))
+                          (ordering (and cmp (comparator-ordered? cmp))))
                      ordering)
       (lambda (proc)
         (dict-for-each<= dtd 
@@ -746,7 +718,7 @@
   (test-group
     "dict-for-each>"
     (test-for-each (let* ((cmp (dict-comparator dtd (alist->dict '())))
-                          (ordering (and cmp (comparator-ordering-predicate cmp))))
+                          (ordering (and cmp (comparator-ordered? cmp))))
                      ordering)
       (lambda (proc)
         (dict-for-each> dtd 
@@ -761,7 +733,7 @@
   (test-group
     "dict-for-each>="
     (test-for-each (let* ((cmp (dict-comparator dtd (alist->dict '())))
-                          (ordering (and cmp (comparator-ordering-predicate cmp))))
+                          (ordering (and cmp (comparator-ordered? cmp))))
                      ordering)
       (lambda (proc)
         (dict-for-each>= dtd 
@@ -776,7 +748,7 @@
   (test-group
     "dict-for-each-in-open-interval"
     (test-for-each (let* ((cmp (dict-comparator dtd (alist->dict '())))
-                          (ordering (and cmp (comparator-ordering-predicate cmp))))
+                          (ordering (and cmp (comparator-ordered? cmp))))
                      ordering)
       (lambda (proc)
         (dict-for-each-in-open-interval dtd 
@@ -791,7 +763,7 @@
   (test-group
     "dict-for-each-in-closed-interval"
     (test-for-each (let* ((cmp (dict-comparator dtd (alist->dict '())))
-                          (ordering (and cmp (comparator-ordering-predicate cmp))))
+                          (ordering (and cmp (comparator-ordered? cmp))))
                      ordering)
       (lambda (proc)
         (dict-for-each-in-closed-interval dtd 
@@ -806,7 +778,7 @@
   (test-group
     "dict-for-each-in-open-closed-interval"
     (test-for-each (let* ((cmp (dict-comparator dtd (alist->dict '())))
-                          (ordering (and cmp (comparator-ordering-predicate cmp))))
+                          (ordering (and cmp (comparator-ordered? cmp))))
                      ordering)
       (lambda (proc)
         (dict-for-each-in-open-closed-interval dtd 
@@ -821,7 +793,7 @@
   (test-group
     "dict-for-each-in-closed-open-interval"
     (test-for-each (let* ((cmp (dict-comparator dtd (alist->dict '())))
-                          (ordering (and cmp (comparator-ordering-predicate cmp))))
+                          (ordering (and cmp (comparator-ordered? cmp))))
                      ordering)
       (lambda (proc)
         (dict-for-each-in-closed-open-interval dtd 
@@ -864,7 +836,7 @@
   ;; check all procs were called
   (for-each
    (lambda (index)
-     (when (= 0 (vector-ref counter index))
+     (when (> 0 (vector-ref counter index))
        (error "Untested procedure" index)))
    (iota (vector-length counter))))
 
@@ -886,8 +858,7 @@
   minimal-alist-dtd
   alist-copy
   #f
-  #f
-  ))
+  #f))
 
 (test-group
  "alist"
@@ -903,24 +874,10 @@
   "alist dict-comparator"
   (test-assert (not (dict-comparator alist-equal-dtd '())))))
 
-(test-group
- "plist"
- (do-test
-  plist-dtd
-  (lambda (alist)
-    (apply append
-           (map (lambda (pair)
-                  (list (car pair) (cdr pair)))
-                alist)))
-  #f
-  #f)
- (test-group
-  "plist dict-comparator"
-  (test-assert (not (dict-comparator plist-dtd '())))))
-
 (cond-expand
   ((and (library (srfi 69))
-        (not gauche)) ;; gauche has bug with comparator retrieval from srfi 69 table
+        (not gauche) ;; gauche has bug with comparator retrieval from srfi 69 table
+        )
    (test-group
      "srfi-69"
      (do-test
diff --git a/srfi-225.html b/srfi-225.html
index 7c6584c..75fe5e9 100644
--- a/srfi-225.html
+++ b/srfi-225.html
@@ -334,7 +334,7 @@ the proc-id variable for <code>dict-map-id</code> and <code>dict-map!</code> is
 <p>Note that it is not an error to omit any of these, but some dictionary procedures may be unavailable.</p>
 <p>There are additional proc-id variables that may be provided with corresponding procedures in order to increase efficiency.  For example, it is not necessary to provide a <code>dict-ref</code> procedure, because the default version is built on top of <code>dict-alter</code> or <code>dict-alter!</code>.  But if the underlying dictionary provides its own <code>-ref</code> procedure, it may be more efficient to specify it to <code>make-dtd</code> using <code>dict-ref-id</code>.  Here is the list of additional proc-id variables:</p>
 <ul>
-<li><code>dict->alist-id</code></li>
+<li><code>dict-&gt;alist-id</code></li>
 <li><code>dict-adjoin-accumulator-id</code></li>
 <li><code>dict-adjoin-id</code></li>
 <li><code>dict-any-id</code></li>
@@ -354,14 +354,12 @@ the proc-id variable for <code>dict-map-id</code> and <code>dict-map!</code> is
 <li><code>dict-for-each-in-closed-open-interval-id</code></li>
 <li><code>dict-for-each-in-open-closed-interval-id</code></li>
 <li><code>dict-for-each-in-open-interval-id</code></li>
-<li><code>dict-for-each>-id</code></li>
-<li><code>dict-for-each>=-id</code></li>
+<li><code>dict-for-each&gt;-id</code></li>
+<li><code>dict-for-each&gt;=-id</code></li>
 <li><code>dict-intern-id</code></li>
 <li><code>dict-keys-id</code></li>
-<li><code>dict-map->list-id</code></li>
+<li><code>dict-map-&gt;list-id</code></li>
 <li><code>dict-map-id</code></li>
-<li><code>dict-max-key-id</code></li>
-<li><code>dict-min-key-id</code></li>
 <li><code>dict-pop-id</code></li>
 <li><code>dict-ref-id</code></li>
 <li><code>dict-ref/default-id</code></li>
@@ -407,7 +405,130 @@ and <code>equal?</code> respectively.</p>
 <p>The sample implementation is found in the GitHub repository.</p>
 <p>The following list of dependencies is designed to ease defining
 new dictionary types that may not have complete dictionary APIs:</p>
-<b>FIXME</b>
+
+<dl>
+    <dt>dict-empty?</dt>
+    <dd>dict-size</dd>
+
+    <dt>dict=?</dt>
+    <dd>dict-ref</dd>
+    <dd>dict-keys</dd>
+    <dd>dict-size</dd>
+
+    <dt>dict-contains?</dt>
+    <dd>dict-ref</dd>
+
+    <dt>dict-ref</dt>
+    <dd>dict-mutable?</dd>
+    <dd>dict-alter or dict-alter!</dd>
+
+    <dt>dict-ref/default</dt>
+    <dd>dict-ref</dd>
+
+    <dt>dict-set</dt>
+    <dd>dict-alter</dd>
+
+    <dt>dict-adjoin</dt>
+    <dd>dict-alter</dd>
+
+    <dt>dict-delete</dt>
+    <dd>dict-delete-all</dt>
+
+    <dt>dict-delete-all</dt>
+    <dd>dict-alter</dd>
+
+    <dt>dict-replace</dt>
+    <dd>dict-alter</dd>
+
+    <dt>dict-intern</dt>
+    <dd>dict-alter</dt>
+
+    <dt>dict-update</dt>
+    <dd>dict-alter</dt>
+
+    <dt>dict-update/default</dt>
+    <dd>dict-update</dd>
+
+    <dt>dict-pop</dt>
+    <dd>dict-for-each</dd>
+    <dd>dict-delete-all</dd>
+    <dd>dict-empty?</dd>
+
+    <dt>dict-map</dt>
+    <dd>dict-keys</dd>
+    <dd>dict-ref</dd>
+    <dd>dict-replace</dd>
+
+    <dt>dict-filter</dt>
+    <dd>dict-keys</dd>
+    <dd>dict-ref</dd>
+    <dd>dict-delete-all</dd>
+
+    <dt>dict-remove</dt>
+    <dd>dict-filter</dd>
+
+    <dt>dict-count</dt>
+    <dd>dict-fold</dt>
+
+    <dt>dict-any</dt>
+    <dd>dict-for-each</dd>
+
+    <dt>dict-every</dt>
+    <dd>dict-for-each</dd>
+
+    <dt>dict-keys</dt>
+    <dd>dict-fold</dd>
+
+    <dt>dict-values</dt>
+    <dd>dict-fold</dd>
+
+    <dt>dict-entries</dt>
+    <dd>dict-fold</dd>
+
+    <dt>dict-fold</dt>
+    <dd>dict-for-each</dd>
+
+    <dt>dict-map-&gt;list</dt>
+    <dd>dict-fold</dd>
+
+    <dt>dict-&gt;alist</dt>
+    <dd>dict-map-&gt;list</dd>
+
+    <dt>dict-for-each&lt;</dt>
+    <dd>dict-for-each</dd>
+
+    <dt>dict-for-each&lt;=</dt>
+    <dd>dict-for-each</dd>
+
+    <dt>dict-for-each&gt;</dt>
+    <dd>dict-for-each</dd>
+
+    <dt>dict-for-each&gt;=</dt>
+    <dd>dict-for-each</dd>
+
+    <dt>dict-for-each-in-open-interval</dt>
+    <dd>dict-for-each</dd>
+
+    <dt>dict-for-each-in-closed-interval</dt>
+    <dd>dict-for-each</dd>
+
+    <dt>dict-for-each-in-open-closed-interval</dt>
+    <dd>dict-for-each</dd>
+
+    <dt>dict-for-each-in-closed-open-interval</dt>
+    <dd>dict-for-each</dd>
+
+    <dt>make-dict-generator</dt>
+    <dd>dict-entries</dd>
+
+    <dt>dict-set-accumulator</dt>
+    <dd>dict-set</dd>
+
+    <dt>dict-adjoin-accumulator</dt>
+    <dd>dict-set</dd>
+
+</dl>
+
 <h2 id="acknowledgements">Acknowledgements</h2>
 
 <p>Thanks to the participants on the mailing list.</p>
diff --git a/srfi/225.sld b/srfi/225.sld
index 6e389a7..a410b62 100644
--- a/srfi/225.sld
+++ b/srfi/225.sld
@@ -23,8 +23,6 @@
     ;; lookup
     dict-ref
     dict-ref/default
-    dict-min-key
-    dict-max-key
 
     ;; mutation
     dict-set
@@ -104,8 +102,6 @@
     dict-mutable?-id
     dict-ref-id
     dict-ref/default-id
-    dict-min-key-id
-    dict-max-key-id
     dict-set-id
     dict-adjoin-id
     dict-delete-id
@@ -144,7 +140,6 @@
     dict-adjoin-accumulator-id
 
     ;; basic DTDs
-    plist-dtd
     alist-eqv-dtd
     alist-equal-dtd)
 
@@ -153,7 +148,6 @@
     (include "externals.scm")
     (include "default-impl.scm")
     (include "alist-impl.scm")
-    (include "plist-impl.scm")
 
     ;; library-dependent DTD exports
     ;; and implementations
diff --git a/srfi/default-impl.scm b/srfi/default-impl.scm
index d5bfdec..72c1f7f 100644
--- a/srfi/default-impl.scm
+++ b/srfi/default-impl.scm
@@ -74,27 +74,6 @@
                 (lambda () default)
                 (lambda (x) x)))
     
-    (define (default-dict-find-key dtd dict cmp-proc)
-      (define cmp (dict-comparator dtd dict))
-      (define keys (dict-keys dtd dict))
-      (when (not cmp)
-        (raise (dictionary-error "dictionary doesn't have comparator")))
-      (when (null? keys)
-        (error "Cannot find min/max key in empty dictionary"))
-      (let loop ((best (car keys))
-                 (keys (cdr keys)))
-        (cond
-          ((null? keys) best)
-          ((cmp-proc cmp (car keys) best)
-           (loop (car keys) (cdr keys)))
-          (else (loop best (cdr keys))))))
-    
-    (define (default-dict-min-key dtd dict)
-      (default-dict-find-key dtd dict <?))
-    
-    (define (default-dict-max-key dtd dict)
-      (default-dict-find-key dtd dict >?))
-
     ;; private
     (define (default-dict-set* dtd dictionary use-old? objs)
       (let loop ((objs objs)
@@ -387,8 +366,6 @@
          dict-mutable?-id default-dict-mutable?
          dict-ref-id default-dict-ref
          dict-ref/default-id default-dict-ref/default
-         dict-min-key-id default-dict-min-key
-         dict-max-key-id default-dict-max-key
          dict-set-id default-dict-set
          dict-adjoin-id default-dict-adjoin
          dict-delete-id default-dict-delete
diff --git a/srfi/externals.scm b/srfi/externals.scm
index 5d77c86..519bccf 100644
--- a/srfi/externals.scm
+++ b/srfi/externals.scm
@@ -79,8 +79,6 @@
      ((dtd-ref-stx dtd dict-ref-id) dtd dict key failure success))))
 
 (define/dict-proc dict-ref/default dict-ref/default-id)
-(define/dict-proc dict-min-key dict-min-key-id)
-(define/dict-proc dict-max-key dict-max-key-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)
diff --git a/srfi/indexes.scm b/srfi/indexes.scm
index f71a76e..a353de8 100644
--- a/srfi/indexes.scm
+++ b/srfi/indexes.scm
@@ -12,8 +12,6 @@
 (define dict-mutable?-id (proc-id-inc))
 (define dict-ref-id (proc-id-inc))
 (define dict-ref/default-id (proc-id-inc))
-(define dict-min-key-id (proc-id-inc))
-(define dict-max-key-id (proc-id-inc))
 (define dict-set-id (proc-id-inc))
 (define dict-adjoin-id (proc-id-inc))
 (define dict-delete-id (proc-id-inc))
diff --git a/srfi/plist-impl.scm b/srfi/plist-impl.scm
deleted file mode 100644
index d291870..0000000
--- a/srfi/plist-impl.scm
+++ /dev/null
@@ -1,111 +0,0 @@
-(define plist-dtd
-  (let ()
-
-    (define (plist? dtd l)
-      (and (list? l)
-           (or (null? l)
-               (symbol? (car l)))))
-
-    (define (plist-map dtd proc plist)
-      (let loop ((pl plist)
-                 (new-pl/rev '()))
-        (cond
-         ((null? pl) (reverse new-pl/rev))
-         ((null? (cdr pl)) (error "Malformed plist" plist))
-         (else
-          (let ((key (car pl))
-                (value (cadr pl))
-                (rest (cddr pl)))
-            (loop rest
-                  (append (list (proc key value) key) new-pl/rev)))))))
-
-    (define (plist-filter dtd pred plist)
-      (let loop ((pl plist)
-                 (new-pl/rev '()))
-        (cond
-         ((null? pl) (reverse new-pl/rev))
-         ((null? (cdr pl)) (error "Malformed plist" plist))
-         (else
-          (let ((key (car pl))
-                (value (cadr pl))
-                (rest (cddr pl)))
-            (if (pred key value)
-                (loop rest
-                      (append (list value key) new-pl/rev))
-                (loop rest
-                      new-pl/rev)))))))
-
-    (define (find-plist-entry key plist)
-      (cond
-       ((null? plist) #f)
-       ((eq? key (car plist)) plist)
-       (else (find-plist-entry key (cddr plist)))))
-    
-    (define (plist-delete key-to-delete plist)
-      (let loop ((pl plist)
-                 (new-pl/rev '()))
-        (cond
-          ((null? pl) (reverse new-pl/rev))
-          ((null? (cdr pl)) (error "Malformed plist"))
-          (else (let ((key (car pl))
-                      (value (cadr pl))
-                      (rest (cddr pl)))
-                  (if (eq? key-to-delete key)
-                      (loop rest new-pl/rev)
-                      (loop rest (append (list value key) new-pl/rev))))))))
-
-    (define (plist-alter dtd plist key failure success)
-      (define (handle-success pair)
-        (define old-key (car pair))
-        (define old-value (cadr pair))
-        (define (update new-key new-value)
-          (cond
-            ((and (eq? old-key
-                       new-key)
-                  (eq? old-value
-                       new-value))
-             plist)
-            (else
-              (let ((new-list
-                      (append (list new-key new-value)
-                              (plist-delete old-key plist))))
-                new-list))))
-        (define (remove)
-          (plist-delete old-key plist))
-        (success old-key old-value update remove))
-
-      (define (handle-failure)
-        (define (insert value)
-          (append (list key value) plist))
-        (define (ignore)
-          plist)
-        (failure insert ignore))
-      (cond
-        ((find-plist-entry key plist) => handle-success)
-        (else (handle-failure))))
-
-    (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-mutable? dtd plist)
-      #f)
-
-    (define (plist-comparator dtd plist)
-      #f)
-
-    (make-dtd
-     dictionary?-id plist?
-     dict-mutable?-id plist-mutable?
-     dict-map-id plist-map
-     dict-filter-id plist-filter
-     dict-alter-id plist-alter
-     dict-size-id plist-size
-     dict-for-each-id plist-foreach
-     dict-comparator-id plist-comparator)))
diff --git a/srfi/srfi-146-hash-impl.scm b/srfi/srfi-146-hash-impl.scm
index 323e259..a86fd03 100644
--- a/srfi/srfi-146-hash-impl.scm
+++ b/srfi/srfi-146-hash-impl.scm
@@ -18,8 +18,11 @@
                               ;; and force it into tail call
                               (call/cc (lambda (k2)
                                          (define result 
-                                           (failure (lambda (value) (k2 (insert value #f)))
-                                                    (lambda () (k2 (ignore #f)))))
+                                           ;; calls to insert / ignore / update / remove
+                                           ;; can return unspecified amount of values,
+                                           ;; hence call-with-values approach
+                                           (failure (lambda (value) (call-with-values (lambda () (insert value #f)) k2))
+                                                    (lambda () (call-with-values (lambda () (ignore #f)) k2))))
                                          ;; neither insert nor ignore called -- return result to top level escape
                                          (k result))))
                             (lambda (key value update remove)
@@ -28,8 +31,8 @@
                                            (success 
                                              key
                                              value
-                                             (lambda (new-key new-value) (k2 (update new-key new-value #f)))
-                                             (lambda () (k2 (remove #f)))))
+                                             (lambda (new-key new-value) (call-with-values (lambda () (update new-key new-value #f)) k2))
+                                             (lambda () (call-with-values (lambda () (remove #f)) k2))))
                                          (k result))))))
           new-dict)))
 
diff --git a/srfi/srfi-146-impl.scm b/srfi/srfi-146-impl.scm
index 49b4737..a5d3aa6 100644
--- a/srfi/srfi-146-impl.scm
+++ b/srfi/srfi-146-impl.scm
@@ -18,8 +18,11 @@
                               ;; and force it into tail call
                               (call/cc (lambda (k2)
                                          (define result 
-                                           (failure (lambda (value) (k2 (insert value #f)))
-                                                    (lambda () (k2 (ignore #f)))))
+                                           ;; calls to insert / ignore / update / remove
+                                           ;; can return unspecified amount of values,
+                                           ;; hence call-with-values approach
+                                           (failure (lambda (value) (call-with-values (lambda () (insert value #f)) k2))
+                                                    (lambda () (call-with-values (lambda () (ignore #f)) k2))))
                                          ;; neither insert nor ignore called -- return result to top level escape
                                          (k result))))
                             (lambda (key value update remove)
@@ -28,8 +31,8 @@
                                            (success 
                                              key
                                              value
-                                             (lambda (new-key new-value) (k2 (update new-key new-value #f)))
-                                             (lambda () (k2 (remove #f)))))
+                                             (lambda (new-key new-value) (call-with-values (lambda () (update new-key new-value #f)) k2))
+                                             (lambda () (call-with-values (lambda () (remove #f)) k2))))
                                          (k result))))))
           new-dict)))