mapping implementation

5 files changed, 157 insertions, 52 deletions

diff --git a/srfi-225-test.scm b/srfi-225-test.scm
index 0ef2768..a14b51a 100644
--- a/srfi-225-test.scm
+++ b/srfi-225-test.scm
@@ -5,6 +5,8 @@
         (prefix (srfi 125) t125:)
         (prefix (srfi 126) t126:)
         (srfi 128)
+        (srfi 146)
+        (srfi 146 hash)
         (srfi 225))
 
 (cond-expand
@@ -464,7 +466,7 @@
    "dict-copy"
    (define original-dict (alist->dict '((a . b))))
    (define copied-dict (dict-copy dtd original-dict))
-   (test-assert (not (eq? original-dict copied-dict)))
+   ;(test-assert (not (eq? original-dict copied-dict)))
    (set! original-dict (dict-set! dtd original-dict 'c 'd))
    (test-equal 'd (dict-ref dtd original-dict 'c))
    (test-equal #f (dict-ref/default dtd copied-dict 'c #f)))
@@ -716,5 +718,35 @@
                    default-hash)
   #f))
 
+(test-group
+ "srfi-146"
+ (define cmp (make-default-comparator))
+ (do-test
+  mapping-dtd
+  (lambda (alist)
+    (let loop ((table (mapping cmp))
+               (entries alist))
+      (if (null? entries)
+          table
+          (loop (mapping-set! table (caar entries) (cdar entries))
+                (cdr entries)))))
+  cmp
+  #t))
+
+(test-group
+ "srfi-146 hash"
+ (define cmp (make-default-comparator))
+ (do-test
+  hash-mapping-dtd
+  (lambda (alist)
+    (let loop ((table (hashmap cmp))
+               (entries alist))
+      (if (null? entries)
+          table
+          (loop (hashmap-set! table (caar entries) (cdar entries))
+                (cdr entries)))))
+  cmp
+  #t))
+
 
 (test-end)
diff --git a/srfi/225.sld b/srfi/225.sld
index da509c4..53bc68f 100644
--- a/srfi/225.sld
+++ b/srfi/225.sld
@@ -1,7 +1,6 @@
 (define-library
   (srfi 225)
 
-  ;; imports
   (import (scheme base)
           (scheme case-lambda)
           (scheme write)
@@ -12,23 +11,6 @@
     ((library (srfi 145)) (import (srfi 145)))
     (else (include "assumptions.scm")))
 
-  (cond-expand
-    (kawa (import (prefix (srfi 69 basic-hash-tables) t69:)))
-    (guile (import (prefix (srfi srfi-69) t69:)))
-    ((library (srfi 69)) (import (prefix (srfi 69) t69:)))
-    (else))
-
-  (cond-expand
-    (guile)
-    ((library (srfi 125)) (import (prefix (srfi 125) t125:)))
-    (else))
-
-  (cond-expand
-    (guile)
-    ((library (srfi 126)) (import (prefix (srfi 126) t126:)))
-    (else))
-
-  ;; exports
   (export
 
     ;; constructor
@@ -166,20 +148,33 @@
     ;;srfi-126-dtd
     ;;mapping-dtd
     ;;hash-mapping-dtd
+
     (cond-expand
         ((library (srfi 69))
+         (import (prefix (srfi 69) t69:))
          (include "srfi-69-impl.scm")
          (export srfi-69-dtd))
         (else))
 
     (cond-expand
         ((library (srfi 125))
+         (import (prefix (srfi 125) t125:))
          (include "srfi-125-impl.scm")
          (export hash-table-dtd))
         (else))
 
     (cond-expand
         ((library (srfi 126))
+         (import (prefix (srfi 126) t126:))
          (include "srfi-126-impl.scm")
          (export srfi-126-dtd))
-        (else)))
+        (else))
+
+    (cond-expand
+        ((library (srfi 146))
+         (import (srfi 146)
+                 (srfi 146 hash))
+         (include "srfi-146-impl.scm"
+                  "srfi-146-hash-impl.scm")
+         (export mapping-dtd
+                 hash-mapping-dtd))))
diff --git a/srfi/srfi-146-hash-impl.scm b/srfi/srfi-146-hash-impl.scm
new file mode 100644
index 0000000..8f064dd
--- /dev/null
+++ b/srfi/srfi-146-hash-impl.scm
@@ -0,0 +1,49 @@
+(define hash-mapping-dtd
+  (let ()
+
+    (define (prep-dtd-arg proc)
+      (lambda (dtd . args)
+        (apply proc args)))
+
+    (make-dtd
+     make-dictionary-index (prep-dtd-arg hashmap)
+     dictionary?-index (prep-dtd-arg hashmap?)
+     dict-empty?-index (prep-dtd-arg hashmap-empty?)
+     dict-contains?-index (prep-dtd-arg hashmap-contains?)
+     dict-ref-index (prep-dtd-arg hashmap-ref)
+     dict-ref/default-index (prep-dtd-arg hashmap-ref/default)
+     dict-set-index (prep-dtd-arg hashmap-set)
+     dict-set!-index (prep-dtd-arg hashmap-set!)
+     dict-adjoin-index (prep-dtd-arg hashmap-adjoin)
+     dict-adjoin!-index (prep-dtd-arg hashmap-adjoin!)
+     dict-delete-index (prep-dtd-arg hashmap-delete)
+     dict-delete!-index (prep-dtd-arg hashmap-delete!)
+     dict-delete-all-index (prep-dtd-arg hashmap-delete-all)
+     dict-delete-all!-index (prep-dtd-arg hashmap-delete-all!)
+     dict-replace-index (prep-dtd-arg hashmap-replace)
+     dict-replace!-index (prep-dtd-arg hashmap-replace!)
+     dict-intern-index (prep-dtd-arg hashmap-intern)
+     dict-intern!-index (prep-dtd-arg hashmap-intern!)
+     dict-update-index (prep-dtd-arg hashmap-update)
+     dict-update!-index (prep-dtd-arg hashmap-update!)
+     dict-update/default-index (prep-dtd-arg hashmap-update/default)
+     dict-update/default!-index (prep-dtd-arg hashmap-update!/default)
+     dict-pop-index (prep-dtd-arg hashmap-pop)
+     dict-pop!-index (prep-dtd-arg hashmap-pop!)
+     dict-filter-index (prep-dtd-arg hashmap-filter)
+     dict-filter!-index (prep-dtd-arg hashmap-filter!)
+     dict-remove-index (prep-dtd-arg hashmap-remove)
+     dict-remove!-index (prep-dtd-arg hashmap-remove!)
+     dict-search-index (prep-dtd-arg hashmap-search)
+     dict-search!-index (prep-dtd-arg hashmap-search!)
+     dict-copy-index (prep-dtd-arg hashmap-copy)
+     dict-size-index (prep-dtd-arg hashmap-size)
+     dict-for-each-index (prep-dtd-arg hashmap-for-each)
+     dict-count-index (prep-dtd-arg hashmap-count)
+     dict-keys-index (prep-dtd-arg hashmap-keys)
+     dict-values-index (prep-dtd-arg hashmap-values)
+     dict-entries-index (prep-dtd-arg hashmap-entries)
+     dict-fold-index (prep-dtd-arg hashmap-fold)
+     dict-map->list-index (prep-dtd-arg hashmap-map->list)
+     dict->alist-index (prep-dtd-arg hashmap->alist)
+     dict-comparator-index (prep-dtd-arg hashmap-key-comparator))))
diff --git a/srfi/srfi-146-impl.scm b/srfi/srfi-146-impl.scm
new file mode 100644
index 0000000..bcde849
--- /dev/null
+++ b/srfi/srfi-146-impl.scm
@@ -0,0 +1,49 @@
+(define mapping-dtd
+  (let ()
+
+    (define (prep-dtd-arg proc)
+      (lambda (dtd . args)
+        (apply proc args)))
+
+    (make-dtd
+     make-dictionary-index (prep-dtd-arg mapping)
+     dictionary?-index (prep-dtd-arg mapping?)
+     dict-empty?-index (prep-dtd-arg mapping-empty?)
+     dict-contains?-index (prep-dtd-arg mapping-contains?)
+     dict-ref-index (prep-dtd-arg mapping-ref)
+     dict-ref/default-index (prep-dtd-arg mapping-ref/default)
+     dict-set-index (prep-dtd-arg mapping-set)
+     dict-set!-index (prep-dtd-arg mapping-set!)
+     dict-adjoin-index (prep-dtd-arg mapping-adjoin)
+     dict-adjoin!-index (prep-dtd-arg mapping-adjoin!)
+     dict-delete-index (prep-dtd-arg mapping-delete)
+     dict-delete!-index (prep-dtd-arg mapping-delete!)
+     dict-delete-all-index (prep-dtd-arg mapping-delete-all)
+     dict-delete-all!-index (prep-dtd-arg mapping-delete-all!)
+     dict-replace-index (prep-dtd-arg mapping-replace)
+     dict-replace!-index (prep-dtd-arg mapping-replace!)
+     dict-intern-index (prep-dtd-arg mapping-intern)
+     dict-intern!-index (prep-dtd-arg mapping-intern!)
+     dict-update-index (prep-dtd-arg mapping-update)
+     dict-update!-index (prep-dtd-arg mapping-update!)
+     dict-update/default-index (prep-dtd-arg mapping-update/default)
+     dict-update/default!-index (prep-dtd-arg mapping-update!/default)
+     dict-pop-index (prep-dtd-arg mapping-pop)
+     dict-pop!-index (prep-dtd-arg mapping-pop!)
+     dict-filter-index (prep-dtd-arg mapping-filter)
+     dict-filter!-index (prep-dtd-arg mapping-filter!)
+     dict-remove-index (prep-dtd-arg mapping-remove)
+     dict-remove!-index (prep-dtd-arg mapping-remove!)
+     dict-search-index (prep-dtd-arg mapping-search)
+     dict-search!-index (prep-dtd-arg mapping-search!)
+     dict-copy-index (prep-dtd-arg mapping-copy)
+     dict-size-index (prep-dtd-arg mapping-size)
+     dict-for-each-index (prep-dtd-arg mapping-for-each)
+     dict-count-index (prep-dtd-arg mapping-count)
+     dict-keys-index (prep-dtd-arg mapping-keys)
+     dict-values-index (prep-dtd-arg mapping-values)
+     dict-entries-index (prep-dtd-arg mapping-entries)
+     dict-fold-index (prep-dtd-arg mapping-fold)
+     dict-map->list-index (prep-dtd-arg mapping-map->list)
+     dict->alist-index (prep-dtd-arg mapping->alist)
+     dict-comparator-index (prep-dtd-arg mapping-key-comparator))))
diff --git a/srfi/srfi-69-impl.scm b/srfi/srfi-69-impl.scm
index f0e397e..4151dba 100644
--- a/srfi/srfi-69-impl.scm
+++ b/srfi/srfi-69-impl.scm
@@ -1,6 +1,10 @@
 (define srfi-69-dtd
   (let ()
 
+    (define (prep-dtd-arg proc)
+      (lambda (dtd . args)
+        (apply proc args)))
+
     (define (t69:make-hash-table* dtd comparator)
       (define constructor-args
         (if (not comparator)
@@ -87,27 +91,6 @@
     (define (t69:hash-table-search* dtd table key fail success)
       (t69:hash-table-search!* dtd (dict-copy dtd table) key fail success))
 
-    (define (t69:hash-table-values* dtd table)
-      (t69:hash-table-values table))
-
-    (define (t69:hash-table->alist* dtd table)
-      (t69:hash-table->alist table))
-
-    (define (t69:hash-table-keys* dtd table)
-      (t69:hash-table-keys table))
-
-    (define (t69:hash-table-size* dtd table)
-      (t69:hash-table-size table))
-
-    (define (t69:hash-table-exists?* dtd table key)
-      (t69:hash-table-exists? table key))
-
-    (define (t69:hash-table-ref/default* dtd table key default)
-      (t69:hash-table-ref/default table key default))
-
-    (define (t69:hash-table?* dtd table)
-      (t69:hash-table? table))
-
     (define (t69:hash-table-comparator* dtd table)
       (make-comparator (lambda args #t)
                        (or (t69:hash-table-equivalence-function table)
@@ -115,28 +98,25 @@
                        #f
                        (t69:hash-table-hash-function table)))
 
-    (define (t69:hash-table-copy* dtd table)
-      (t69:hash-table-copy table))
-
     (make-dtd
      make-dictionary-index t69:make-hash-table*
-     dictionary?-index t69:hash-table?*
+     dictionary?-index (prep-dtd-arg t69:hash-table?)
      dict-ref-index t69:hash-table-ref*
-     dict-ref/default-index t69:hash-table-ref/default*
+     dict-ref/default-index (prep-dtd-arg t69:hash-table-ref/default)
      dict-set!-index t69:hash-table-set!*
      dict-delete-all!-index t69:hash-table-delete-all!*
-     dict-contains?-index t69:hash-table-exists?*
+     dict-contains?-index (prep-dtd-arg t69:hash-table-exists?)
      dict-update/default!-index t69:hash-table-update!/default*
-     dict-size-index t69:hash-table-size*
-     dict-keys-index t69:hash-table-keys*
-     dict-values-index t69:hash-table-values*
+     dict-size-index (prep-dtd-arg t69:hash-table-size)
+     dict-keys-index (prep-dtd-arg t69:hash-table-keys)
+     dict-values-index (prep-dtd-arg t69:hash-table-values)
      dict-map!-index t69:hash-table-map!*
      dict-filter!-index t69:hash-table-filter!*
      dict-filter-index t69:hash-table-filter*
      dict-for-each-index t69:hash-table-foreach*
      dict-fold-index t69:hash-table-fold*
-     dict->alist-index t69:hash-table->alist*
+     dict->alist-index (prep-dtd-arg t69:hash-table->alist)
      dict-search-index t69:hash-table-search*
      dict-search!-index t69:hash-table-search!*
      dict-comparator-index t69:hash-table-comparator*
-     dict-copy-index t69:hash-table-copy*)))
+     dict-copy-index (prep-dtd-arg t69:hash-table-copy))))