diff options
Diffstat (limited to 'module/rnrs/hashtables.scm')
-rw-r--r-- | module/rnrs/hashtables.scm | 190 |
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))))) |