add srfi69 impl

9 files changed, 223 insertions, 55 deletions

diff --git a/alist-impl.scm b/alist-impl.scm
index a77d74f..8f832dc 100644
--- a/alist-impl.scm
+++ b/alist-impl.scm
@@ -1,9 +1,9 @@
-(define (make-alist-impl)
+(define (register-alist!)
   
-  (define (alist? vec l)
+  (define (alist? l)
     (and (list? l) (every pair? l)))
 
-  (define (alist-map! vec proc alist)
+  (define (alist-map! proc alist)
     (map 
       (lambda (e)
         (define key (car e))
@@ -11,13 +11,13 @@
         (cons key (proc key value))) 
       alist))
 
-  (define (alist-filter! vec pred alist)
+  (define (alist-filter! pred alist)
     (filter
       (lambda (e)
         (pred (car e) (cdr e))) 
       alist))
 
-  (define (alist-search! vec alist key failure success)
+  (define (alist-search! alist key failure success)
     (define (handle-success pair)
       (define old-key (car pair))
       (define old-value (cdr pair))
@@ -49,29 +49,26 @@
       ((assoc key alist) => handle-success)
       (else (handle-failure))))
 
-  (define (alist-size vec alist)
+  (define (alist-size alist)
     (define keys (map car alist))
     (define (fold-proc el set)
       (lset-adjoin equal? set el))
     (define key-set (fold fold-proc '() keys))
     (length key-set))
 
-  (define (alist-foreach vec proc alist)
+  (define (alist-foreach proc alist)
     (define (proc* e)
       (proc (car e) (cdr e)))
     (for-each proc* alist))
   
-  (define (alist->alist vec alist)
+  (define (alist->alist alist)
     alist)
 
-
-  (define vec (vector-copy model-vec))
-  (vector-set! vec d? alist?)
-  (vector-set! vec dmap! alist-map!)
-  (vector-set! vec dfilter! alist-filter!)
-  (vector-set! vec dsearch! alist-search!)
-  (vector-set! vec dsize alist-size)
-  (vector-set! vec dfor-each alist-foreach)
-  (vector-set! vec d->alist alist->alist)
-
-  vec)
+  (register-dictionary! 
+    'dictionary? alist?
+    'dict-map! alist-map!
+    'dict-filter! alist-filter!
+    'dict-search! alist-search!
+    'dict-size alist-size
+    'dict-for-each alist-foreach
+    'dict->alist alist->alist))
diff --git a/dictionaries-impl.scm b/dictionaries-impl.scm
index a4ecc5c..60e5b86 100644
--- a/dictionaries-impl.scm
+++ b/dictionaries-impl.scm
@@ -1,5 +1,20 @@
 (include "indexes.scm")
 (include "internals.scm")
-(include "alist-impl.scm")
-(include "plist-impl.scm")
 (include "externals.scm")
+
+;; register
+(let ()
+ (include "alist-impl.scm")
+ (register-alist!))
+
+(let ()
+ (include "plist-impl.scm")
+ (register-plist!)) 
+
+(cond-expand
+  ((or srfi-69 srfi-125 chibi kawa)
+   (begin
+     (let ()
+      (include "srfi-69-impl.scm")
+      (register-srfi-69!))))
+  (else))
diff --git a/dictionaries-test.scm b/dictionaries-test.scm
index 0736261..ede4fe7 100644
--- a/dictionaries-test.scm
+++ b/dictionaries-test.scm
@@ -1,8 +1,28 @@
 (import (scheme base)
         (srfi 1)
-        (srfi 64)
         (dictionaries))
 
+(cond-expand
+  ((or srfi-64 kawa) 
+    (import (srfi 64)))
+  (chibi 
+    (begin
+      (import (except (chibi test) test-equal))
+      (define-syntax test-equal
+        (syntax-rules ()
+          ((_ args ...) (test args ...))))
+      ))
+  (else (error "No testing framework")))
+
+(cond-expand
+  ((or srfi-125 chibi)
+   (import (srfi 125)))
+  (kawa
+    (import (srfi 69 basic-hash-tables)))
+  (srfi-69
+    (import (srfi 69)))
+  (else))
+
 (define (do-test alist->dict)
 
   (test-group
@@ -123,9 +143,15 @@
     (define-values
       (new-dict key value)
       (dict-pop! (alist->dict '((a . b) (c . d))) error))
-    (test-equal (dict->alist new-dict) '((c . d)))
-    (test-equal key 'a)
-    (test-equal value 'b))
+    (test-assert
+      (or 
+        (and (equal? (dict->alist new-dict) '((c . d)))
+             (equal? key 'a)
+             (equal? value 'b))
+        
+        (and (equal? (dict->alist new-dict) '((a . b)))
+             (equal? key 'c)
+             (equal? value 'd)))))
 
   (test-group
     "dict-map!"
@@ -216,7 +242,9 @@
            (lambda (key value)
              (set! lst (append lst (list key value))))
            (alist->dict '((a . b) (c . d))))
-    (test-equal '(a b c d) lst))
+    (test-assert
+      (or (equal? '(a b c d) lst)
+          (equal? '(c d a b) lst))))
 
   (test-group
     "dict-count"
@@ -275,21 +303,28 @@
     "dict-keys"
     (define keys
       (dict-keys (alist->dict '((a . b) (c . d)))))
-    (test-equal '(a c) keys))
+    (test-assert
+      (or (equal? '(a c) keys)
+          (equal? '(c a) keys))))
 
   (test-group
     "dict-values"
     (define vals
       (dict-values (alist->dict '((a . b) (c . d)))))
-    (test-equal '(b d) vals))
+    (test-assert
+      (or (equal? '(b d) vals)
+          (equal? '(d b) vals))))
 
   (test-group
     "dict-entries"
     (define-values
       (keys vals)
       (dict-entries (alist->dict '((a . b) (c . d)))))
-    (test-equal '(a c) keys)
-    (test-equal '(b d) vals))
+    (test-assert
+      (or (and (equal? '(a c) keys)
+               (equal? '(b d) vals))
+          (and (equal? '(c a) keys)
+               (equal? '(d b) vals)))))
 
   (test-group
     "dict-fold"
@@ -299,7 +334,9 @@
                (append acc (list key value)))
              '()
              (alist->dict '((a . b) (c . d)))))
-    (test-equal value '(a b c d)))
+    (test-assert
+      (or (equal? '(a b c d) value)
+          (equal? '(c d a b) value))))
 
   (test-group
     "dict-map->list"
@@ -309,13 +346,17 @@
                (string-append (symbol->string key)
                               value))
              (alist->dict '((a . "b") (c . "d")))))
-    (test-equal '("ab" "cd") lst))
+    (test-assert
+      (or (equal? '("ab" "cd") lst)
+          (equal? '("cd" "ab") lst))))
 
   (test-group
     "dict->alist"
     (define alist
       (dict->alist  (alist->dict '((a . b) (c . d)))))
-    (test-equal alist '((a . b) (c . d)))))
+    (test-assert
+      (or (equal? '((a . b) (c . d)) alist)
+          (equal? '((c . d) (a . b)) alist)))))
 
 (test-begin "Dictionaries")
 
@@ -332,4 +373,18 @@
                     (list (car pair) (cdr pair))) 
                   alist)))))
 
+(cond-expand
+  ((or srfi-69 srfi-125 chibi kawa)
+   (begin
+     (test-group
+       "srfi-69"
+       (do-test (lambda (alist) 
+                  (define table (make-hash-table equal?))
+                  (for-each
+                    (lambda (pair)
+                      (hash-table-set! table (car pair) (cdr pair)))
+                    alist)
+                  table)))))
+  (else))
+
 (test-end)
diff --git a/dictionaries.scm b/dictionaries.scm
index b16cd01..1920f6f 100644
--- a/dictionaries.scm
+++ b/dictionaries.scm
@@ -3,6 +3,13 @@
   (import (scheme base)
           (scheme case-lambda)
           (srfi 1))
+  
+  (cond-expand
+    ((and srfi-69 (not srfi-125)) (import (srfi 69)))
+    (srfi-125 (import (srfi 125)))
+    (chibi (import (srfi 125)))
+    (kawa (import (srfi 69 basic-hash-tables))))
+  
   (export 
     
     ;; predicates
diff --git a/dictionaries.sld b/dictionaries.sld
new file mode 120000
index 0000000..3dfc689
--- /dev/null
+++ b/dictionaries.sld
@@ -0,0 +1 @@
+dictionaries.scm
\ No newline at end of file
diff --git a/externals.scm b/externals.scm
index 8d8cf2e..2edd261 100644
--- a/externals.scm
+++ b/externals.scm
@@ -1,7 +1,4 @@
-(define registry
-  (list
-    (make-alist-impl)
-    (make-plist-impl)))
+(define registry '())
 
 (define (lookup dictionary fail-on-notfound?)
   (let loop ((r registry))
@@ -28,7 +25,7 @@
   (do ((lst lst (cddr lst)))
       ((null? lst))
       (when (null? (cdr lst))
-        (error "Uneven amount of arguments"))
+        (error "Uneven amount of arguments" lst))
       (let ((proc-name (car lst))
             (proc (cadr lst)))
         (define index
diff --git a/plist-impl.scm b/plist-impl.scm
index 8fa41a1..f7f0571 100644
--- a/plist-impl.scm
+++ b/plist-impl.scm
@@ -1,11 +1,11 @@
-(define (make-plist-impl)
+(define (register-plist!)
   
-  (define (plist? vec l)
+  (define (plist?  l)
     (and (list? l)
          (not (null? l))
          (symbol? (car l))))
 
-  (define (plist-map! vec proc plist)
+  (define (plist-map!  proc plist)
     (let loop ((pl plist))
      (cond
        ((null? pl) plist)
@@ -18,7 +18,7 @@
                      (proc key value))
            (loop rest))))))
 
-  (define (plist-filter! vec pred plist)
+  (define (plist-filter!  pred plist)
     (define head (cons #f plist))
     (let loop ((pl plist)
                (parent-cell head))
@@ -49,7 +49,7 @@
       ((equal? key (car plist)) head)
       (else (find-plist-entry key (cdr plist)))))
   
-  (define (plist-search! vec plist key failure success)
+  (define (plist-search!  plist key failure success)
     (define plist-head (cons #t plist))
     (define (handle-success head)
       (define key-cell (cdr head))
@@ -74,7 +74,7 @@
       ((find-plist-entry key plist-head) => handle-success)
       (else (handle-failure))))
 
-  (define (plist-size vec plist)
+  (define (plist-size  plist)
     (define keys
       (let loop ((pl plist)
                  (keys '()))
@@ -87,19 +87,17 @@
     (define key-set (fold fold-proc '() keys))
     (length key-set))
 
-  (define (plist-foreach vec proc plist)
+  (define (plist-foreach  proc plist)
     (let loop ((pl plist))
      (if (null? pl) #t
          (begin
            (proc (car pl) (cadr pl))
            (loop (cddr pl))))))
-
-  (define vec (vector-copy model-vec))
-  (vector-set! vec d? plist?)
-  (vector-set! vec dmap! plist-map!)
-  (vector-set! vec dfilter! plist-filter!)
-  (vector-set! vec dsearch! plist-search!)
-  (vector-set! vec dsize plist-size)
-  (vector-set! vec dfor-each plist-foreach)
-
-  vec)
+  
+  (register-dictionary! 
+    'dictionary? plist?
+    'dict-map! plist-map!
+    'dict-filter! plist-filter!
+    'dict-search! plist-search!
+    'dict-size plist-size
+    'dict-for-each plist-foreach))
diff --git a/readme.md b/readme.md
new file mode 100644
index 0000000..26850d3
--- /dev/null
+++ b/readme.md
@@ -0,0 +1,10 @@
+Running tests:
+
+Kawa
+`kawa dictionaries-test.scm`
+
+Chibi
+`chibi-scheme -I . dictionaries-test.scm`
+
+Gauche
+`gosh -I . dictionaries-test.scm`
diff --git a/srfi-69-impl.scm b/srfi-69-impl.scm
new file mode 100644
index 0000000..3f8a602
--- /dev/null
+++ b/srfi-69-impl.scm
@@ -0,0 +1,88 @@
+(define (register-srfi-69!)
+  
+  (define (hash-table-ref* table key fail success)
+    (define default (cons #f #f))
+    (define found (hash-table-ref/default table key default))
+    (if (eq? found default)
+        (fail)
+        (success found)))
+  
+  (define (hash-table-set!* table . obj)
+    (let loop ((obj obj))
+     (if (null? obj)
+         table
+         (begin
+           (hash-table-set! table (car obj) (cadr obj))
+           (loop (cddr obj))))))
+  
+  (define (hash-table-update!/default* table key proc default)
+    (hash-table-update!/default table key proc default)
+    table)
+  
+  (define (hash-table-delete-all!* table keys)
+    (for-each
+      (lambda (key)
+        (hash-table-delete! table key))
+      keys)
+    table)
+  
+  (define (hash-table-foreach* proc table)
+    (hash-table-walk table proc))
+  
+  (define (hash-table-map* proc table)
+    (hash-table-walk table (lambda (key value)
+                             (hash-table-set! table key (proc key value))))
+    table)
+  
+  (define (hash-table-filter* proc table)
+    (hash-table-walk table 
+                     (lambda (key value)
+                       (unless (proc key value)
+                         (hash-table-delete! table key))))
+    table)
+  
+  (define (hash-table-fold* proc knil table)
+    (hash-table-fold table proc knil))
+  
+  (define (hash-table-search* table key fail success)
+    (define (handle-success value)
+      (define (update new-key new-value obj)
+        (unless (eq? new-key key)
+          (hash-table-delete! table key))
+        (hash-table-set! table new-key new-value)
+        (values table obj))
+      (define (remove obj)
+        (hash-table-delete! table key)
+        (values table obj))
+      (success key value update remove))
+    (define (handle-fail)
+      (define (ignore obj) 
+        (values table obj))
+      (define (insert value obj)
+        (hash-table-set! table key value)
+        (values table obj))
+      (fail insert ignore))
+    
+    (define default (cons #f #f))
+    (define found (hash-table-ref/default table key default))
+    (if (eq? default found)
+        (handle-fail)
+        (handle-success found)))
+  
+  (register-dictionary!
+    'dictionary? hash-table?
+    'dict-ref hash-table-ref*
+    'dict-ref/default hash-table-ref/default
+    'dict-set! hash-table-set!*
+    'dict-delete-all! hash-table-delete-all!*
+    'dict-contains? hash-table-exists?
+    'dict-update/default! hash-table-update!/default*
+    'dict-size hash-table-size
+    'dict-keys hash-table-keys
+    'dict-values hash-table-values
+    'dict-map! hash-table-map*
+    'dict-filter! hash-table-filter*
+    'dict-for-each hash-table-foreach*
+    'dict-fold hash-table-fold*
+    'dict->alist hash-table->alist
+    'dict-search! hash-table-search*))