diff --git a/module/rnrs/6/hashtables.scm b/module/rnrs/6/hashtables.scm index a31497282..1afa91b6e 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 7b5882068..f6322bf5b 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -78,6 +78,7 @@ SCM_TESTS = tests/00-initial-env.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 000000000..9d5c73084 --- /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)))))