summaryrefslogtreecommitdiff
path: root/module/rnrs
diff options
context:
space:
mode:
authorJulian Graham <julian.graham@aya.yale.edu>2010-03-20 20:51:37 -0400
committerJulian Graham <julian.graham@aya.yale.edu>2010-05-20 21:18:03 -0400
commit2b95784c8dd29a8bb75e66f2a3c0a77f777fe61a (patch)
treee5af8c0be92a325f0c2f108059beef1d8b036e3f /module/rnrs
parent04ba959921cd8a6a69e367d4f163c45d8b36e199 (diff)
downloadguile-2b95784c8dd29a8bb75e66f2a3c0a77f777fe61a.tar.gz
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.
Diffstat (limited to 'module/rnrs')
-rw-r--r--module/rnrs/6/hashtables.scm53
1 files changed, 34 insertions, 19 deletions
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)))