srfi 126 impl

5 files changed, 222 insertions, 35 deletions

diff --git a/Dockerfile b/Dockerfile
index 3a927cb..fac5a89 100644
--- a/Dockerfile
+++ b/Dockerfile
@@ -1,9 +1,14 @@
 FROM alpine
 RUN apk add --no-cache git
-RUN mkdir /test
-WORKDIR /test
-ADD . srfi-225
+RUN mkdir /dependencies
+WORKDIR /dependencies
 RUN ["git", "clone", "https://github.com/scheme-requests-for-implementation/srfi-69/"]
 RUN ["git", "clone", "https://github.com/scheme-requests-for-implementation/srfi-125/"]
 RUN ["git", "clone", "https://github.com/scheme-requests-for-implementation/srfi-126/"]
 RUN ["git", "clone", "https://github.com/scheme-requests-for-implementation/srfi-146/"]
+RUN ["wget", "https://snow-fort.org/s/ccs.neu.edu/will/r6rs/enums/0.0.1/r6rs-enums-0.0.1.tgz"]
+RUN ["tar", "-xf", "r6rs-enums-0.0.1.tgz"]
+RUN ["wget", "https://snow-fort.org/s/ccs.neu.edu/will/r6rs/lists/0.0.1/r6rs-lists-0.0.1.tgz"]
+RUN ["tar", "-xf", "r6rs-lists-0.0.1.tgz"]
+RUN ["wget", "https://snow-fort.org/s/ccs.neu.edu/will/r6rs/sorting/0.0.1/r6rs-sorting-0.0.1.tgz"]
+RUN ["tar", "-xf", "r6rs-sorting-0.0.1.tgz"]
diff --git a/docker-compose.yml b/docker-compose.yml
index 2571288..da47b23 100644
--- a/docker-compose.yml
+++ b/docker-compose.yml
@@ -1,16 +1,37 @@
-version: "3"
+version: "3.2"
 services:
   srfi_225_test:
     build: .
     volumes:
-      - test-volume:/test
+      - dependencies-volume:/dependencies
+  akku:
+    image: "akkuscm/akku"
+    depends_on:
+      - srfi_225_test
+    volumes:
+      - dependencies-volume:/dependencies
   gauche:
     image: "schemers/gauche"
     depends_on:
       - srfi_225_test
     volumes:
-      - test-volume:/test
-    command: ["gosh", "-I", "/test/srfi-225", "/test/srfi-225/srfi-225-test.scm"]
+      - dependencies-volume:/dependencies
+    command: ["gosh", "-I", "/dependencies/srfi-225", "/dependencies/srfi-225/srfi-225-dependencies.scm"]
+  chibi:
+    image: "schemers/chibi"
+    depends_on:
+      - srfi_225_test
+    volumes:
+      - dependencies-volume:/dependencies
+      - type: bind
+        source: .
+        target: /test/srfi-225
+    command: ["chibi-scheme", "-I", "/test/srfi-225",
+                              "-I", "/dependencies/srfi-126",
+                              "-I", "/dependencies/r6rs-enums-0.0.1",
+                              "-I", "/dependencies/r6rs-lists-0.0.1",
+                              "-I", "/dependencies/r6rs-sorting-0.0.1",
+                              "/test/srfi-225/srfi-225-test.scm"]
 
 volumes:
-  test-volume:
+  dependencies-volume:
diff --git a/srfi-225-test.scm b/srfi-225-test.scm
index cd99344..0ef2768 100644
--- a/srfi-225-test.scm
+++ b/srfi-225-test.scm
@@ -3,6 +3,7 @@
         (srfi 1)
         (prefix (srfi 69) t69:)
         (prefix (srfi 125) t125:)
+        (prefix (srfi 126) t126:)
         (srfi 128)
         (srfi 225))
 
@@ -36,7 +37,7 @@
    (apply make-dtd wrapper-dtd-args)
    counter))
 
-(define (do-test real-dtd alist->dict comparator)
+(define (do-test real-dtd alist->dict comparator test-get-comparator)
 
   (define-values
       (dtd counter)
@@ -600,12 +601,15 @@
    "dict-comparator"
    ;; extremelly basic generic test; more useful specific tests defined separately
    ;; for each dtd
-   (test-assert (comparator? (dict-comparator dtd (alist->dict '((a . b)))))))
+   (when test-get-comparator
+     (test-assert (comparator? (dict-comparator dtd (alist->dict '((a . b))))))))
 
   ;; check all procs were called
   (for-each
    (lambda (index)
-     (when (= 0 (vector-ref counter index))
+     (when (and (= 0 (vector-ref counter index))
+                (or test-get-comparator
+                    (not (= index dict-comparator-index))))
        (error "Untested procedure" index)))
    (iota (vector-length counter))))
 
@@ -626,7 +630,8 @@
  (do-test
   default-dtd
   alist-copy
-  #f))
+  #f
+  #t))
 
 (test-group
   "alist"
@@ -635,7 +640,8 @@
    ;; copy to a mutable list
    ;; so that mutating procedures don't fail
    alist-copy
-   #f)
+   #f
+   #t)
 
   ;; TODO test alist handling with different alist-dtd variants
   ;; TODO test comparator
@@ -650,7 +656,8 @@
              (map (lambda (pair)
                     (list (car pair) (cdr pair)))
                   alist)))
-    #f)
+    #f
+    #t)
   ;; TODO test comparator
   )
 
@@ -668,7 +675,8 @@
   (make-comparator (lambda args #t)
                    equal?
                    #f
-                   #f))
+                   #f)
+  #t)
  ;; TODO test comparator
  )
 
@@ -686,28 +694,27 @@
   (make-comparator (lambda args #t)
                    equal?
                    #f
-                   default-hash))
+                   default-hash)
+  #t)
  ;; TODO test comparator
  )
 
-#|
-(cond-expand
-  (guile)
-  ((library (srfi 126))
-   (test-group
-     "srfi-126 (r6rs)"
-     (include "srfi-126-impl.scm")
-     (clear-registry!)
-     (register-srfi-126!)
-     (do-test (lambda (alist)
-                (define table (make-eqv-hashtable))
-                (for-each
-                  (lambda (pair)
-                    (hashtable-set! table (car pair) (cdr pair)))
-                  alist)
-                table))))
-  (else))
-|#
+(test-group
+ "srfi-126 (r6rs)"
+ (do-test
+  srfi-126-dtd
+  (lambda (alist)
+    (define table (t126:make-eqv-hashtable))
+    (for-each
+     (lambda (pair)
+       (t126:hashtable-set! table (car pair) (cdr pair)))
+     alist)
+    table)
+  (make-comparator (lambda args #t)
+                   equal?
+                   #f
+                   default-hash)
+  #f))
 
 
 (test-end)
diff --git a/srfi/225.sld b/srfi/225.sld
index c009606..da509c4 100644
--- a/srfi/225.sld
+++ b/srfi/225.sld
@@ -25,7 +25,7 @@
 
   (cond-expand
     (guile)
-    ((library (srfi 126)) (import (srfi 126)))
+    ((library (srfi 126)) (import (prefix (srfi 126) t126:)))
     (else))
 
   ;; exports
@@ -176,4 +176,10 @@
         ((library (srfi 125))
          (include "srfi-125-impl.scm")
          (export hash-table-dtd))
+        (else))
+
+    (cond-expand
+        ((library (srfi 126))
+         (include "srfi-126-impl.scm")
+         (export srfi-126-dtd))
         (else)))
diff --git a/srfi/srfi-126-impl.scm b/srfi/srfi-126-impl.scm
new file mode 100644
index 0000000..177a835
--- /dev/null
+++ b/srfi/srfi-126-impl.scm
@@ -0,0 +1,148 @@
+(define srfi-126-dtd
+  (let ()
+
+    (define (prep-dtd-arg proc)
+      (lambda (dtd . args)
+        (apply proc args)))
+
+    (define (t126:make-hashtable* dtd comparator)
+      (t126:make-hashtable (comparator-hash-function comparator)
+                           (comparator-equality-predicate comparator)))
+
+    (define (t126:hashtable-ref* dtd table key fail success)
+      (define-values (value found?) (t126:hashtable-lookup table key))
+      (if found?
+          (success value)
+          (fail)))
+
+    (define (t126:hashtable-ref/default* dtd table key default)
+      (t126:hashtable-ref table key default))
+
+    (define (t126:hashtable-set!* dtd table . obj)
+      (let loop ((obj obj))
+        (if (null? obj)
+            table
+            (begin
+              (t126:hashtable-set! table (car obj) (cadr obj))
+              (loop (cddr obj))))))
+
+    (define (t126:hashtable-delete-all!* dtd table keys)
+      (for-each
+       (lambda (key)
+         (t126:hashtable-delete! table key))
+       keys)
+      table)
+
+    (define (t126:hashtable-intern!* dtd table key default)
+      (define val (t126:hashtable-intern! table key default))
+      (values table val))
+
+    (define (t126:hashtable-update/default!* dtd table key updater default)
+      (t126:hashtable-update! table key updater default)
+      table)
+
+    (define (t126:hashtable-pop!* dtd table)
+      (if (t126:hashtable-empty? table)
+          (error "popped empty dictionary")
+          (call-with-values
+              (lambda () (t126:hashtable-pop! table))
+            (lambda (key value) (values table key value)))))
+
+    (define (t126:hashtable-update-all!* dtd proc table)
+      (t126:hashtable-update-all! table proc)
+      table)
+
+    (define (t126:hashtable-filter!* dtd proc table)
+      (t126:hashtable-prune! table
+                             (lambda (key value)
+                               (not (proc key value))))
+      table)
+
+    (define (t126:hashtable-filter* dtd proc table)
+      (dict-filter! dtd proc (dict-copy dtd table)))
+
+    (define (t126:hashtable-remove!* dtd proc table)
+      (t126:hashtable-prune! table proc)
+      table)
+
+    (define (t126:hashtable-remove* dtd proc table)
+      (dict-remove! dtd proc (dict-copy dtd table)))
+
+    (define (t126:hashtable-search!* dtd table key fail success)
+      (define (handle-success value)
+        (define (update new-key new-value obj)
+          (unless (eq? new-key key)
+            (t126:hashtable-delete! table key))
+          (t126:hashtable-set! table new-key new-value)
+          (values table obj))
+        (define (remove obj)
+          (t126:hashtable-delete! table key)
+          (values table obj))
+        (success key value update remove))
+      (define (handle-fail)
+        (define (ignore obj)
+          (values table obj))
+        (define (insert value obj)
+          (t126:hashtable-set! table key value)
+          (values table obj))
+        (fail insert ignore))
+
+      (define default (cons #f #f))
+      (define found (t126:hashtable-ref table key default))
+      (if (eq? default found)
+          (handle-fail)
+          (handle-success found)))
+
+    (define (t126:hashtable-search* dtd table key fail success)
+      (dict-search! dtd (dict-copy dtd table) key fail success))
+
+    (define (t126:hashtable-for-each* dtd proc table)
+      (t126:hashtable-walk table proc)
+      table)
+
+    (define (t126:hashtable-map->lset* dtd proc table)
+      (t126:hashtable-map->lset table proc))
+
+    (define (t126:hashtable-keys* dtd table)
+      (vector->list (t126:hashtable-keys table)))
+
+    (define (t126:hashtable-values* dtd table)
+      (vector->list (t126:hashtable-values table)))
+
+    (define (t126:hashtable-entries* dtd table)
+      (call-with-values
+          (lambda () (t126:hashtable-entries table))
+        (lambda (keys vals)
+          (values
+           (vector->list keys)
+           (vector->list vals)))))
+
+    (define (t126:hashtable-copy* dtd table)
+      (t126:hashtable-copy table #t))
+
+    (make-dtd
+     make-dictionary-index t126:make-hashtable*
+     dictionary?-index (prep-dtd-arg t126:hashtable?)
+     dict-empty?-index (prep-dtd-arg t126:hashtable-empty?)
+     dict-contains?-index (prep-dtd-arg t126:hashtable-contains?)
+     dict-ref-index t126:hashtable-ref*
+     dict-ref/default-index t126:hashtable-ref/default*
+     dict-set!-index t126:hashtable-set!*
+     dict-delete-all!-index t126:hashtable-delete-all!*
+     dict-intern!-index t126:hashtable-intern!*
+     dict-update/default!-index t126:hashtable-update/default!*
+     dict-pop!-index t126:hashtable-pop!*
+     dict-map!-index t126:hashtable-update-all!*
+     dict-filter!-index t126:hashtable-filter!*
+     dict-filter-index t126:hashtable-filter*
+     dict-remove!-index t126:hashtable-remove!*
+     dict-remove-index t126:hashtable-remove*
+     dict-search!-index t126:hashtable-search!*
+     dict-search-index t126:hashtable-search*
+     dict-size-index (prep-dtd-arg t126:hashtable-size)
+     dict-for-each-index t126:hashtable-for-each*
+     dict-keys-index t126:hashtable-keys*
+     dict-values-index t126:hashtable-values*
+     dict-entries-index t126:hashtable-entries*
+     dict-map->list-index t126:hashtable-map->lset*
+     dict-copy-index t126:hashtable-copy*)))