Merge pull request #3 from arvyy/master

125 & 126 based implementations

5 files changed, 322 insertions, 34 deletions

diff --git a/dictionaries-impl.scm b/dictionaries-impl.scm
index 60e5b86..f97cf0e 100644
--- a/dictionaries-impl.scm
+++ b/dictionaries-impl.scm
@@ -12,9 +12,25 @@
  (register-plist!)) 
 
 (cond-expand
-  ((or srfi-69 srfi-125 chibi kawa)
-   (begin
-     (let ()
-      (include "srfi-69-impl.scm")
-      (register-srfi-69!))))
+  ((library (srfi 126))
+   (let ()
+    (include "srfi-126-impl.scm")
+    (register-srfi-126!)))
+  (else))
+
+(cond-expand
+  ((and (library (srfi 125))
+        (not (library (srfi 69))))
+   (let ()
+    (include "srfi-125-impl.scm")
+    (register-srfi-125!)))
+  (else))
+
+(cond-expand
+  ((or kawa
+       (and (library (srfi 69))
+            (not (library (srfi 125)))))
+   (let ()
+    (include "srfi-69-impl.scm")
+    (register-srfi-69!)))
   (else))
diff --git a/dictionaries-test.scm b/dictionaries-test.scm
index ede4fe7..309c97e 100644
--- a/dictionaries-test.scm
+++ b/dictionaries-test.scm
@@ -1,32 +1,45 @@
 (import (scheme base)
-        (srfi 1)
-        (dictionaries))
+        (scheme case-lambda)
+        (srfi 1))
 
 (cond-expand
-  ((or srfi-64 kawa) 
-    (import (srfi 64)))
+  ((library (srfi 64)) 
+   (import (srfi 64)))
   (chibi 
     (begin
       (import (except (chibi test) test-equal))
       (define-syntax test-equal
         (syntax-rules ()
-          ((_ args ...) (test args ...))))
-      ))
+          ((_ args ...) (test args ...))))))
   (else (error "No testing framework")))
 
+; use include instead of import
+; so that registering is done in isolated way
+(include "indexes.scm")
+(include "internals.scm")
+(include "externals.scm")
+
+(define (clear-registry!)
+  (set! registry '()))
+
 (cond-expand
-  ((or srfi-125 chibi)
+  (kawa (import (srfi 69 basic-hash-tables)))
+  ((library (srfi 125))
    (import (srfi 125)))
-  (kawa
-    (import (srfi 69 basic-hash-tables)))
-  (srfi-69
-    (import (srfi 69)))
+  ((library (srfi 69))
+   (import (srfi 69)))
+  (else))
+
+(cond-expand
+  ((library (srfi 126))
+   (import (srfi 126)))
   (else))
 
 (define (do-test alist->dict)
 
   (test-group
     "dictionary?"
+    (test-assert (not (dictionary? 'foo)))
     (test-assert (dictionary? (alist->dict '())))
     (test-assert (dictionary? (alist->dict '((a . b))))))
 
@@ -75,7 +88,7 @@
 
   (test-group
     "dict-replace!"
-    (define d (dict-replace! '((a . b) (c . d)) 'a 'b2))
+    (define d (dict-replace! (alist->dict '((a . b) (c . d))) 'a 'b2))
     (test-equal 'b2 (dict-ref d 'a))
     (test-equal 'd (dict-ref d 'c)))
 
@@ -185,7 +198,7 @@
     (let ()
      (define-values 
        (dict value)
-       (dict-search!  '((a . b)) 'c
+       (dict-search! (alist->dict '((a . b))) 'c
               (lambda (insert ignore)
                 (ignore 'foo))
               (lambda args
@@ -362,10 +375,20 @@
 
 (test-group 
   "alist"
+  (include "alist-impl.scm")
+  (clear-registry!)
+  (register-alist!)
   (do-test (lambda (alist) alist)))
 
 (test-group
   "plist"
+  ; empty list isn't valid plist dictionary, thus alist impl also has to be
+  ; added just for this edge case
+  (include "alist-impl.scm")
+  (include "plist-impl.scm")
+  (clear-registry!)
+  (register-plist!)
+  (register-alist!)
   (do-test 
     (lambda (alist) 
       (apply append 
@@ -374,17 +397,50 @@
                   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))
+  ((or kawa
+       (library (srfi 69))
+       (library (srfi 125)))
+   (test-group
+     "srfi-69"
+     (include "srfi-69-impl.scm")
+     (clear-registry!)
+     (register-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)))))
+
+(cond-expand
+  ((library (srfi 125))
+   (test-group
+     "srfi-125"
+     (include "srfi-125-impl.scm")
+     (clear-registry!)
+     (register-srfi-125!)
+     (do-test (lambda (alist) 
+                (define table (make-hash-table equal?))
+                (for-each
+                  (lambda (pair)
+                    (hash-table-set! table (car pair) (cdr pair)))
+                  alist)
+                table)))))
+
+(cond-expand
+  ((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)))))
 
 (test-end)
diff --git a/dictionaries.scm b/dictionaries.scm
index 1920f6f..e90d1f9 100644
--- a/dictionaries.scm
+++ b/dictionaries.scm
@@ -5,10 +5,17 @@
           (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))))
+    (kawa (import (srfi 69 basic-hash-tables)))
+    ((library (srfi 69)) (import (srfi 69))) 
+    (else))
+  
+  (cond-expand
+    ((library (srfi 125)) (import (srfi 125))) 
+    (else))
+  
+  (cond-expand
+    ((library (srfi 126)) (import (srfi 126)))
+    (else))
   
   (export 
     
diff --git a/srfi-125-impl.scm b/srfi-125-impl.scm
new file mode 100644
index 0000000..b683a2a
--- /dev/null
+++ b/srfi-125-impl.scm
@@ -0,0 +1,93 @@
+(define (register-srfi-125!)
+  
+  (define (hash-table-set!* table . obj)
+    (apply hash-table-set! (cons table obj))
+    table)
+  
+  (define (hash-table-update!* table key updater fail success)
+    (hash-table-update! table key updater fail success)
+    table)
+  
+  (define (hash-table-update!/default* table key proc default)
+    (hash-table-update!/default table key proc default)
+    table)
+  
+  (define (hash-table-intern!* table key failure)
+    (define val (hash-table-intern! table key failure))
+    (values table val))
+  
+  (define (hash-table-pop!* table fail)
+    (if (hash-table-empty? table)
+        (fail)
+        (call-with-values
+          (lambda () (hash-table-pop! table))
+          (lambda (key value) (values table key value)))))
+  
+  (define (hash-table-delete-all!* table keys)
+    (for-each
+      (lambda (key)
+        (hash-table-delete! table key))
+      keys)
+    table)
+  
+  (define (hash-table-map!* proc table)
+    (hash-table-map! proc table)
+    table)
+  
+  (define (hash-table-filter* proc table)
+    (hash-table-prune! 
+      (lambda (key value)
+        (not (proc key value)))
+      table)
+    table)
+  
+  (define (hash-table-remove!* proc table)
+    (hash-table-prune! proc table)
+    table)
+  
+  (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))
+    (hash-table-ref table key handle-fail handle-success))
+  
+  (register-dictionary!
+    'dictionary? hash-table?
+    'dict-empty? hash-table-empty?
+    'dict-contains? hash-table-contains?
+    '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-intern! hash-table-intern!*
+    'dict-update! hash-table-update!*
+    'dict-update/default! hash-table-update!/default*
+    'dict-pop! hash-table-pop!*
+    'dict-map! hash-table-map!*
+    'dict-filter! hash-table-filter*
+    'dict-remove! hash-table-remove!*
+    'dict-search! hash-table-search* 
+    'dict-size hash-table-size
+    'dict-for-each hash-table-for-each
+    'dict-keys hash-table-keys
+    'dict-values hash-table-values
+    'dict-entries hash-table-entries
+    'dict-fold hash-table-fold
+    'dict-map->list hash-table-map->list
+    'dict->alist hash-table->alist))
diff --git a/srfi-126-impl.scm b/srfi-126-impl.scm
new file mode 100644
index 0000000..ab27603
--- /dev/null
+++ b/srfi-126-impl.scm
@@ -0,0 +1,116 @@
+(define (register-srfi-126!)
+  
+  (define (hashtable-ref* table key fail success)
+    (define-values (value found?) (hashtable-lookup table key))
+    (if found?
+        (success value)
+        (fail)))
+  
+  (define (hashtable-ref/default* table key default)
+    (hashtable-ref table key default))
+  
+  (define (hashtable-set!* table . obj)
+    (let loop ((obj obj))
+     (if (null? obj)
+         table
+         (begin
+           (hashtable-set! table (car obj) (cadr obj))
+           (loop (cddr obj))))))
+  
+  (define (hashtable-delete-all!* table keys)
+    (for-each
+      (lambda (key)
+        (hashtable-delete! table key))
+      keys)
+    table)
+  
+  (define (hashtable-intern!* table key default)
+    (define val (hashtable-intern! table key default))
+    (values table val))
+  
+  (define (hashtable-update!* table key updater fail success)
+    (define d (cons #f #f))
+    (define val (hashtable-update! table key proc d))
+    (if (eq? d val)
+        (fail)
+        (success d)))
+  
+  (define (hashtable-update/default!* table key updater default)
+    (hashtable-update! table key proc default)
+    table)
+
+  (define (hashtable-pop!* table fail)
+    (if (hashtable-empty? table)
+        (fail)
+        (call-with-values
+          (lambda () (hashtable-pop! table))
+          (lambda (key value) (values table key value)))))
+  
+  (define (hashtable-update-all!* proc table)
+    (hashtable-update-all! table proc)
+    table)
+  
+  (define (hashtable-filter!* proc table)
+    (hashtable-prune! table 
+                      (lambda (key value) 
+                        (not (proc key value))))
+    table)
+  
+  (define (hashtable-remove!* proc table)
+    (hashtable-prune! table proc)
+    table)
+  
+  (define (hashtable-search* table key fail success)
+    (define (handle-success value)
+      (define (update new-key new-value obj)
+        (unless (eq? new-key key)
+          (hashtable-delete! table key))
+        (hashtable-set! table new-key new-value)
+        (values table obj))
+      (define (remove obj)
+        (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)
+        (hashtable-set! table key value)
+        (values table obj))
+      (fail insert ignore))
+    
+    (define default (cons #f #f))
+    (define found (hashtable-ref table key default))
+    (if (eq? default found)
+        (handle-fail)
+        (handle-success found)))
+  
+  (define (hashtable-for-each* proc table)
+    (hashtable-walk table proc)
+    table)
+  
+  (define (hashtable-map->lset* proc table)
+    (hashtable-map->lset table proc))
+  
+  (register-dictionary!
+    'dictionary? hashtable?
+    'dict-empty? hashtable-empty?
+    'dict-contains? hashtable-contains?
+    'dict-ref hashtable-ref*
+    'dict-ref/default hashtable-ref/default*
+    'dict-set! hashtable-set!*
+    'dict-delete-all! hashtable-delete-all!*
+    'dict-intern! hashtable-intern!*
+    'dict-update! hashtable-update!*
+    'dict-update/default! hashtable-update/default!*
+    'dict-pop! hashtable-pop!*
+    'dict-map! hashtable-update-all!*
+    'dict-filter! hashtable-filter!*
+    'dict-remove! hashtable-remove!*
+    'dict-search! hashtable-search*
+    'dict-size hashtable-size
+    'dict-for-each hashtable-for-each*
+    'dict-keys hashtable-keys
+    'dict-values hashtable-values
+    'dict-entries hashtable-entry-lists
+    'dict-map->list hashtable-map->lset*))