summaryrefslogtreecommitdiff
path: root/module/rnrs/hashtables.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/rnrs/hashtables.scm')
-rw-r--r--module/rnrs/hashtables.scm190
1 files changed, 190 insertions, 0 deletions
diff --git a/module/rnrs/hashtables.scm b/module/rnrs/hashtables.scm
new file mode 100644
index 000000000..22bae7f09
--- /dev/null
+++ b/module/rnrs/hashtables.scm
@@ -0,0 +1,190 @@
+;;; hashtables.scm --- The R6RS hashtables library
+
+;; 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 License, 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
+
+
+(library (rnrs hashtables (6))
+ (export make-eq-hashtable
+ make-eqv-hashtable
+ make-hashtable
+
+ hashtable?
+ hashtable-size
+ hashtable-ref
+ hashtable-set!
+ hashtable-delete!
+ hashtable-contains?
+ hashtable-update!
+ hashtable-copy
+ hashtable-clear!
+ hashtable-keys
+ hashtable-entries
+
+ hashtable-equivalence-function
+ hashtable-hash-function
+ hashtable-mutable?
+
+ equal-hash
+ string-hash
+ string-ci-hash
+ symbol-hash)
+ (import (rename (only (guile) string-hash-ci
+ string-hash
+ hashq
+ hashv
+ modulo
+ *unspecified*
+ @@)
+ (string-hash-ci string-ci-hash))
+ (only (ice-9 optargs) define*)
+ (rename (only (srfi :69) make-hash-table
+ hash
+ hash-by-identity
+ hash-table-size
+ hash-table-ref/default
+ hash-table-set!
+ hash-table-delete!
+ hash-table-exists?
+ hash-table-update!/default
+ hash-table-copy
+ hash-table-equivalence-function
+ hash-table-hash-function
+ hash-table-keys
+ hash-table-fold)
+ (hash equal-hash)
+ (hash-by-identity symbol-hash))
+ (rnrs base (6))
+ (rnrs records procedural (6)))
+
+ (define r6rs:hashtable
+ (make-record-type-descriptor
+ 'r6rs:hashtable #f #f #t #t
+ '#((mutable wrapped-table)
+ (immutable orig-hash-function)
+ (immutable mutable)
+ (immutable type))))
+
+ (define hashtable? (record-predicate r6rs:hashtable))
+ (define make-r6rs-hashtable
+ (record-constructor (make-record-constructor-descriptor
+ 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 r6rs:hashtable-orig-hash-function (record-accessor r6rs:hashtable 1))
+ (define r6rs:hashtable-mutable? (record-accessor r6rs:hashtable 2))
+ (define r6rs:hashtable-type (record-accessor r6rs:hashtable 3))
+
+ (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 capacity) (modulo (proc key) capacity)))
+
+ (define* (make-eq-hashtable #:optional k)
+ (make-r6rs-hashtable
+ (if k (make-hash-table eq? hashq k) (make-hash-table eq? symbol-hash))
+ symbol-hash
+ #t
+ 'eq))
+
+ (define* (make-eqv-hashtable #:optional k)
+ (make-r6rs-hashtable
+ (if k (make-hash-table eqv? hashv k) (make-hash-table eqv? hash-by-value))
+ hash-by-value
+ #t
+ 'eqv))
+
+ (define* (make-hashtable hash-function equiv #:optional k)
+ (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
+ 'custom)))
+
+ (define (hashtable-size hashtable)
+ (hash-table-size (r6rs:hashtable-wrapped-table hashtable)))
+
+ (define (hashtable-ref hashtable key default)
+ (hash-table-ref/default
+ (r6rs:hashtable-wrapped-table hashtable) key default))
+
+ (define (hashtable-set! hashtable key obj)
+ (if (r6rs:hashtable-mutable? hashtable)
+ (hash-table-set! (r6rs:hashtable-wrapped-table hashtable) key obj)
+ (assertion-violation
+ 'hashtable-set! "Hashtable is immutable." hashtable)))
+
+ (define (hashtable-delete! hashtable key)
+ (if (r6rs:hashtable-mutable? hashtable)
+ (hash-table-delete! (r6rs:hashtable-wrapped-table hashtable) key))
+ *unspecified*)
+
+ (define (hashtable-contains? hashtable key)
+ (hash-table-exists? (r6rs:hashtable-wrapped-table hashtable) key))
+
+ (define (hashtable-update! hashtable key proc default)
+ (if (r6rs:hashtable-mutable? hashtable)
+ (hash-table-update!/default
+ (r6rs:hashtable-wrapped-table hashtable) key proc default))
+ *unspecified*)
+
+ (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)
+ (r6rs:hashtable-type hashtable)))
+
+ (define* (hashtable-clear! hashtable #:optional k)
+ (if (r6rs:hashtable-mutable? hashtable)
+ (let* ((ht (r6rs:hashtable-wrapped-table hashtable))
+ (equiv (hash-table-equivalence-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 wrapped-hash-function k)
+ (make-hash-table equiv wrapped-hash-function)))))
+ *unspecified*)
+
+ (define (hashtable-keys hashtable)
+ (list->vector (hash-table-keys (r6rs:hashtable-wrapped-table hashtable))))
+
+ (define (hashtable-entries hashtable)
+ (let* ((ht (r6rs:hashtable-wrapped-table hashtable))
+ (size (hash-table-size ht))
+ (keys (make-vector size))
+ (vals (make-vector size)))
+ (hash-table-fold (r6rs:hashtable-wrapped-table hashtable)
+ (lambda (k v i)
+ (vector-set! keys i k)
+ (vector-set! vals i v)
+ (+ i 1))
+ 0)
+ (values keys vals)))
+
+ (define (hashtable-equivalence-function hashtable)
+ (hash-table-equivalence-function (r6rs:hashtable-wrapped-table hashtable)))
+
+ (define (hashtable-hash-function hashtable)
+ (case (r6rs:hashtable-type hashtable)
+ ((eq eqv) #f)
+ (else (r6rs:hashtable-orig-hash-function hashtable)))))