guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] GNU Guile branch, wip-r6rs-libraries, updated. release_1


From: Julian Graham
Subject: [Guile-commits] GNU Guile branch, wip-r6rs-libraries, updated. release_1-9-8-81-g72196ef
Date: Sun, 21 Mar 2010 05:04:09 +0000

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=72196ef70f6550bae305e98a348d06ad887eff6e

The branch, wip-r6rs-libraries has been updated
       via  72196ef70f6550bae305e98a348d06ad887eff6e (commit)
      from  c90df2cc6c3b7ef04c0628b8a6f34f7595d54cce (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 72196ef70f6550bae305e98a348d06ad887eff6e
Author: Julian Graham <address@hidden>
Date:   Sat Mar 20 20:51:37 2010 -0400

    Fixes and test cases for R6RS (rnrs hashtables) library.
    
    * module/rnrs/6/hashtables.scm: Assorted bugfixes, esp. for wrapping
      single-argument hash functions.
    * test-suite/Makefile.am: Add tests/r6rs-hashtables.test to SCM_TESTS.
    * test-suite/tests/r6rs-hashtables.test: New file.

-----------------------------------------------------------------------

Summary of changes:
 module/rnrs/6/hashtables.scm          |   53 ++++++----
 test-suite/Makefile.am                |    1 +
 test-suite/tests/r6rs-hashtables.test |  178 +++++++++++++++++++++++++++++++++
 3 files changed, 213 insertions(+), 19 deletions(-)
 create mode 100644 test-suite/tests/r6rs-hashtables.test

diff --git a/module/rnrs/6/hashtables.scm b/module/rnrs/6/hashtables.scm
index a314972..1afa91b 100644
--- a/module/rnrs/6/hashtables.scm
+++ b/module/rnrs/6/hashtables.scm
@@ -42,7 +42,7 @@
          string-hash
          string-ci-hash
          symbol-hash)
-  (import (rename (only (guile) string-hash-ci string-hash hashq)
+  (import (rename (only (guile) string-hash-ci string-hash hashq hashv)
                  (string-hash-ci string-ci-hash))
          (only (ice-9 optargs) define*)
          (rename (only (srfi :69) make-hash-table
@@ -52,7 +52,7 @@
                                   hash-table-ref/default
                                   hash-table-set!
                                   hash-table-delete!
-                                  hash-table-exists
+                                  hash-table-exists?
                                   hash-table-update!/default
                                   hash-table-copy
                                   hash-table-equivalence-function
@@ -67,7 +67,9 @@
   (define r6rs:hashtable 
     (make-record-type-descriptor 
      'r6rs:hashtable #f #f #t #t 
-     '#((mutable wrapped-table) (immutable mutable))))
+     '#((mutable wrapped-table)
+       (immutable orig-hash-function)
+       (immutable mutable))))
 
   (define hashtable? (record-predicate r6rs:hashtable))
   (define make-r6rs-hashtable 
@@ -75,24 +77,34 @@
                         r6rs:hashtable #f #f)))
   (define r6rs:hashtable-wrapped-table (record-accessor r6rs:hashtable 0))
   (define r6rs:hashtable-set-wrapped-table! (record-mutator r6rs:hashtable 0))
-  (define hashtable-mutable? (record-accessor r6rs:hashtable 1))
+  (define r6rs:hashtable-orig-hash-function (record-accessor r6rs:hashtable 1))
+  (define r6rs:hashtable-mutable? (record-accessor r6rs:hashtable 2))
+
+  (define hashtable-mutable? r6rs:hashtable-mutable?)
+
+  (define hash-by-value ((@@ (srfi srfi-69) caller-with-default-size) hashv))
+  (define (wrap-hash-function proc) (lambda (key obj) (proc key)))
 
   (define* (make-eq-hashtable #:optional k)
     (make-r6rs-hashtable 
-     (if k (make-hash-table eq? hashq k) (make-hash-table eq? hashq))
+     (if k (make-hash-table eq? hashq k) (make-hash-table eq? symbol-hash))
+     symbol-hash
      #t))
 
   (define* (make-eqv-hashtable #:optional k)
     (make-r6rs-hashtable 
-     (if k (make-hash-table eqv? hashv k) (make-hash-table eqv? hashv))
+     (if k (make-hash-table eqv? hashv k) (make-hash-table eqv? hash-by-value))
+     hash-by-value
      #t))
 
   (define* (make-hashtable hash-function equiv #:optional k)
-    (make-r6rs-hashtable
-     (if k 
-        (make-hash-table equiv hash-function k)
-        (make-hash-table equiv hash-function))
-     #t))
+    (let ((wrapped-hash-function (wrap-hash-function hash-function)))
+      (make-r6rs-hashtable
+       (if k 
+          (make-hash-table equiv wrapped-hash-function k)
+          (make-hash-table equiv wrapped-hash-function))
+       hash-function
+       #t)))
  
   (define (hashtable-size hashtable)
     (hash-table-size (r6rs:hashtable-wrapped-table hashtable)))
@@ -102,12 +114,12 @@
      (r6rs:hashtable-wrapped-table hashtable) key default))
 
   (define (hashtable-set! hashtable key obj)
-    (if (hashtable-mutable? hashtable)
+    (if (r6rs:hashtable-mutable? hashtable)
        (hash-table-set! (r6rs:hashtable-wrapped-table hashtable) key obj))
     *unspecified*)
 
   (define (hashtable-delete! hashtable key)
-    (if (hashtable-mutable? hashtable)
+    (if (r6rs:hashtable-mutable? hashtable)
        (hash-table-delete! (r6rs:hashtable-wrapped-table hashtable) key))
     *unspecified*)
 
@@ -115,7 +127,7 @@
     (hash-table-exists? (r6rs:hashtable-wrapped-table hashtable) key))
 
   (define (hashtable-update! hashtable key proc default)
-    (if (hashtable-mutable? hashtable)
+    (if (r6rs:hashtable-mutable? hashtable)
        (hash-table-update!/default 
         (r6rs:hashtable-wrapped-table hashtable) key proc default))
     *unspecified*)
@@ -123,17 +135,20 @@
   (define* (hashtable-copy hashtable #:optional mutable)
     (make-r6rs-hashtable 
      (hash-table-copy (r6rs:hashtable-wrapped-table hashtable))
+     (r6rs:hashtable-orig-hash-function hashtable)
      (and mutable #t)))
 
   (define* (hashtable-clear! hashtable #:optional k)
-    (if (hashtable-mutable? hashtable)
+    (if (r6rs:hashtable-mutable? hashtable)
        (let* ((ht (r6rs:hashtable-wrapped-table hashtable))
               (equiv (hash-table-equivalence-function ht))
-              (hash-function (hash-table-hash-function ht)))
+              (hash-function (r6rs:hashtable-orig-hash-function hashtable))
+              (wrapped-hash-function (wrap-hash-function hash-function)))
          (r6rs:hashtable-set-wrapped-table!
+          hashtable
           (if k 
-              (make-hash-table equiv hash-function k)
-              (make-hash-table equiv hash-function)))))
+              (make-hash-table equiv wrapped-hash-function k)
+              (make-hash-table equiv wrapped-hash-function)))))
     *unspecified*)
 
   (define (hashtable-keys hashtable)
@@ -156,4 +171,4 @@
     (hash-table-equivalence-function (r6rs:hashtable-wrapped-table hashtable)))
 
   (define (hashtable-hash-function hashtable)
-    (hash-table-hash-function (r6rs:hashtable-wrapped-table hashtable))))
+    (r6rs:hashtable-orig-hash-function hashtable)))
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 21aa2ab..5c2619d 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -72,6 +72,7 @@ SCM_TESTS = tests/alist.test                  \
            tests/r5rs_pitfall.test             \
            tests/r6rs-arithmetic-bitwise.test  \
            tests/r6rs-control.test             \
+           tests/r6rs-hashtables.test          \
            tests/r6rs-ports.test               \
            tests/r6rs-records-inspection.test  \
            tests/r6rs-records-procedural.test  \
diff --git a/test-suite/tests/r6rs-hashtables.test 
b/test-suite/tests/r6rs-hashtables.test
new file mode 100644
index 0000000..9d5c730
--- /dev/null
+++ b/test-suite/tests/r6rs-hashtables.test
@@ -0,0 +1,178 @@
+;;; r6rs-hashtables.test --- Test suite for R6RS (rnrs hashtables)
+
+;;      Copyright (C) 2010 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the Lice6nse, or (at your option) any later version.
+;; 
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; Lesser General Public License for more details.
+;; 
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+
+(define-module (test-suite test-rnrs-hashtable)
+  :use-module (ice-9 receive)
+  :use-module ((rnrs hashtables) :version (6))
+  :use-module (srfi srfi-1)
+  :use-module (test-suite lib))
+
+(with-test-prefix "make-eq-hashtable"
+  (pass-if "eq hashtable compares keys with eq?"
+    (let ((eq-hashtable (make-eq-hashtable)))
+      (hashtable-set! eq-hashtable (list 'foo) #t)
+      (hashtable-set! eq-hashtable 'sym #t)
+      (and (not (hashtable-contains? eq-hashtable (list 'foo)))
+          (hashtable-contains? eq-hashtable 'sym)))))
+
+(with-test-prefix "make-eqv-hashtable"
+  (pass-if "eqv hashtable compares keys with eqv?"
+    (let ((eqv-hashtable (make-eqv-hashtable)))
+      (hashtable-set! eqv-hashtable (list 'foo) #t)
+      (hashtable-set! eqv-hashtable 4 #t)
+      (and (not (hashtable-contains? eqv-hashtable (list 'foo)))
+          (hashtable-contains? eqv-hashtable 4)))))
+
+(with-test-prefix "make-hashtable"
+  (pass-if "hashtable compares keys with custom equality function"
+    (let* ((abs-eqv? (lambda (x y) (eqv? (abs x) (abs y))))
+          (abs-hashtable (make-hashtable abs abs-eqv?)))
+      (hashtable-set! abs-hashtable -4 #t)
+      (and (not (hashtable-contains? abs-hashtable 6))
+          (hashtable-contains? abs-hashtable 4)))))      
+
+(with-test-prefix "hashtable?"
+  (pass-if "hashtable? is #t on hashtables"
+    (let ((hashtable (make-eq-hashtable)))
+      (hashtable? hashtable)))
+  
+  (pass-if "hashtable? is #f on non-hashtables"
+    (let ((not-hashtable (list)))
+      (not (hashtable? not-hashtable)))))
+
+(with-test-prefix "hashtable-size"
+  (pass-if "hashtable-size returns current size"
+    (let ((hashtable (make-eq-hashtable)))
+      (and (eqv? (hashtable-size hashtable) 0)
+          (hashtable-set! hashtable 'foo #t)
+          (eqv? (hashtable-size hashtable) 1)))))
+
+(with-test-prefix "hashtable-ref"
+  (pass-if "hashtable-ref returns value for bound key"
+    (let ((hashtable (make-eq-hashtable)))
+      (hashtable-set! hashtable 'sym 'foo)
+      (eq? (hashtable-ref hashtable 'sym 'bar) 'foo)))
+ 
+  (pass-if "hashtable-ref returns default for unbound key"
+    (let ((hashtable (make-eq-hashtable)))
+      (eq? (hashtable-ref hashtable 'sym 'bar) 'bar))))
+
+(with-test-prefix "hashtable-set!"
+  (pass-if "hashtable-set! returns unspecified"
+    (let ((hashtable (make-eq-hashtable)))
+      (unspecified? (hashtable-set! hashtable 'foo 'bar))))
+
+  (pass-if "hashtable-set! allows storing #f"
+    (let ((hashtable (make-eq-hashtable)))
+      (hashtable-set! hashtable 'foo #f)
+      (not (hashtable-ref hashtable 'foo 'bar)))))
+
+(with-test-prefix "hashtable-delete!"
+  (pass-if "hashtable-delete! removes association"
+    (let ((hashtable (make-eq-hashtable)))
+      (hashtable-set! hashtable 'foo 'bar)
+      (and (unspecified? (hashtable-delete! hashtable 'foo))
+          (not (hashtable-ref hashtable 'foo #f))))))
+
+(with-test-prefix "hashtable-contains?"
+  (pass-if "hashtable-contains? returns #t when association present"
+    (let ((hashtable (make-eq-hashtable)))
+      (hashtable-set! hashtable 'foo 'bar)
+      (let ((contains (hashtable-contains? hashtable 'foo)))
+       (and (boolean? contains) contains))))
+
+  (pass-if "hashtable-contains? returns #f when association not present"
+    (let ((hashtable (make-eq-hashtable)))
+      (not (hashtable-contains? hashtable 'foo)))))
+      
+(with-test-prefix "hashtable-update!"
+  (pass-if "hashtable-update! adds return value of proc on bound key"
+    (let ((hashtable (make-eq-hashtable)))
+      (hashtable-set! hashtable 'foo 0)
+      (hashtable-update! hashtable 'foo (lambda (x) (+ x 1)) 100)
+      (eqv? (hashtable-ref hashtable 'foo #f) 1)))
+
+  (pass-if "hashtable-update! adds default value on unbound key"
+    (let ((hashtable (make-eq-hashtable)))
+      (hashtable-update! hashtable 'foo (lambda (x) (+ x 1)) 100)
+      (eqv? (hashtable-ref hashtable 'foo #f) 101))))
+
+(with-test-prefix "hashtable-copy"
+  (pass-if "hashtable-copy produces copy of hashtable"
+    (let ((hashtable (make-eq-hashtable)))
+      (hashtable-set! hashtable 'foo 1)
+      (hashtable-set! hashtable 'bar 2)
+      (let ((copied-table (hashtable-copy hashtable)))
+       (and (eqv? (hashtable-ref hashtable 'foo #f) 1)
+            (eqv? (hashtable-ref hashtable 'bar #f) 2)))))
+
+  (pass-if "hashtable-copy with mutability #f produces immutable copy"
+    (let ((copied-table (hashtable-copy (make-eq-hashtable) #f)))
+      (hashtable-set! copied-table 'foo 1)
+      (not (hashtable-ref copied-table 'foo #f)))))      
+
+(with-test-prefix "hashtable-clear!"
+  (pass-if "hashtable-clear! removes all values from hashtable"
+    (let ((hashtable (make-eq-hashtable)))
+      (hashtable-set! hashtable 'foo 1)
+      (hashtable-set! hashtable 'bar 2)
+      (and (unspecified? (hashtable-clear! hashtable))
+          (eqv? (hashtable-size hashtable) 0)))))
+
+(with-test-prefix "hashtable-keys"
+  (pass-if "hashtable-keys returns all keys"
+    (let ((hashtable (make-eq-hashtable)))
+      (hashtable-set! hashtable 'foo #t)
+      (hashtable-set! hashtable 'bar #t)
+      (let ((keys (vector->list (hashtable-keys hashtable))))
+       (and (memq 'foo keys) (memq 'bar keys) #t)))))
+
+(with-test-prefix "hashtable-entries"
+  (pass-if "hashtable-entries returns all entries"
+    (let ((hashtable (make-eq-hashtable)))
+      (hashtable-set! hashtable 'foo 1)
+      (hashtable-set! hashtable 'bar 2)
+      (receive 
+        (keys values)
+       (hashtable-entries hashtable)   
+       (let f ((counter 0) (success #t))
+         (if (or (not success) (= counter 2))
+             success
+             (case (vector-ref keys counter)
+               ((foo) (f (+ counter 1) (eqv? (vector-ref values counter) 1)))
+               ((bar) (f (+ counter 1) (eqv? (vector-ref values counter) 2)))
+               (else f 0 #f))))))))
+
+(with-test-prefix "hashtable-equivalence-function"
+  (pass-if "hashtable-equivalence-function returns eqv function"
+    (let* ((abs-eqv? (lambda (x y) (eqv? (abs x) (abs y))))
+          (abs-hashtable (make-hashtable abs abs-eqv?)))
+      (eq? (hashtable-equivalence-function abs-hashtable) abs-eqv?))))
+
+(with-test-prefix "hashtable-hash-function"
+  (pass-if "hashtable-hash-function returns hash function"
+    (let ((abs-hashtable (make-hashtable abs eqv?)))
+      (eq? (hashtable-hash-function abs-hashtable) abs))))
+
+(with-test-prefix "hashtable-mutable?"
+  (pass-if "hashtable-mutable? is #t on mutable hashtables"
+    (hashtable-mutable? (hashtable-copy (make-eq-hashtable) #t)))
+
+  (pass-if "hashtable-mutable? is #f on immutable hashtables"
+    (not (hashtable-mutable? (hashtable-copy (make-eq-hashtable) #f)))))


hooks/post-receive
-- 
GNU Guile




reply via email to

[Prev in Thread] Current Thread [Next in Thread]