module/rnrs/6/hashtables.scm

   1 ;;; hashtables.scm --- The R6RS hashtables library
   2
   3 ;;      Copyright (C) 2010 Free Software Foundation, Inc.
   4 ;;
   5 ;; This library is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the GNU Lesser General Public
   7 ;; License as published by the Free Software Foundation; either
   8 ;; version 3 of the License, or (at your option) any later version.
   9 ;;
  10 ;; This library is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;; Lesser General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU Lesser General Public
  16 ;; License along with this library; if not, write to the Free Software
  17 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18 \f
  19
  20 (library (rnrs hashtables (6))
  21   (export make-eq-hashtable
  22           make-eqv-hashtable
  23           make-hashtable
  24
  25           hashtable?
  26           hashtable-size
  27           hashtable-ref
  28           hashtable-set!
  29           hashtable-delete!
  30           hashtable-contains?
  31           hashtable-update!
  32           hashtable-copy
  33           hashtable-clear!
  34           hashtable-keys
  35           hashtable-entries
  36
  37           hashtable-equivalence-function
  38           hashtable-hash-function
  39           hashtable-mutable?
  40
  41           equal-hash
  42           string-hash
  43           string-ci-hash
  44           symbol-hash)
  45   (import (rename (only (guile) string-hash-ci string-hash hashq hashv @@)
  46                   (string-hash-ci string-ci-hash))
  47           (only (ice-9 optargs) define*)
  48           (rename (only (srfi :69) make-hash-table
  49                                    hash
  50                                    hash-by-identity
  51                                    hash-table-size
  52                                    hash-table-ref/default
  53                                    hash-table-set!
  54                                    hash-table-delete!
  55                                    hash-table-exists?
  56                                    hash-table-update!/default
  57                                    hash-table-copy
  58                                    hash-table-equivalence-function
  59                                    hash-table-hash-function
  60                                    hash-table-keys
  61                                    hash-table-fold)
  62                   (hash equal-hash)
  63                   (hash-by-identity symbol-hash))
  64           (rnrs base (6))
  65           (rnrs records procedural (6)))
  66
  67   (define r6rs:hashtable
  68     (make-record-type-descriptor
  69      'r6rs:hashtable #f #f #t #t
  70      '#((mutable wrapped-table)
  71         (immutable orig-hash-function)
  72         (immutable mutable))))
  73
  74   (define hashtable? (record-predicate r6rs:hashtable))
  75   (define make-r6rs-hashtable
  76     (record-constructor (make-record-constructor-descriptor
  77                          r6rs:hashtable #f #f)))
  78   (define r6rs:hashtable-wrapped-table (record-accessor r6rs:hashtable 0))
  79   (define r6rs:hashtable-set-wrapped-table! (record-mutator r6rs:hashtable 0))
  80   (define r6rs:hashtable-orig-hash-function (record-accessor r6rs:hashtable 1))
  81   (define r6rs:hashtable-mutable? (record-accessor r6rs:hashtable 2))
  82
  83   (define hashtable-mutable? r6rs:hashtable-mutable?)
  84
  85   (define hash-by-value ((@@ (srfi srfi-69) caller-with-default-size) hashv))
  86   (define (wrap-hash-function proc) (lambda (key obj) (proc key)))
  87
  88   (define* (make-eq-hashtable #:optional k)
  89     (make-r6rs-hashtable
  90      (if k (make-hash-table eq? hashq k) (make-hash-table eq? symbol-hash))
  91      symbol-hash
  92      #t))
  93
  94   (define* (make-eqv-hashtable #:optional k)
  95     (make-r6rs-hashtable
  96      (if k (make-hash-table eqv? hashv k) (make-hash-table eqv? hash-by-value))
  97      hash-by-value
  98      #t))
  99
 100   (define* (make-hashtable hash-function equiv #:optional k)
 101     (let ((wrapped-hash-function (wrap-hash-function hash-function)))
 102       (make-r6rs-hashtable
 103        (if k
 104            (make-hash-table equiv wrapped-hash-function k)
 105            (make-hash-table equiv wrapped-hash-function))
 106        hash-function
 107        #t)))
 108
 109   (define (hashtable-size hashtable)
 110     (hash-table-size (r6rs:hashtable-wrapped-table hashtable)))
 111
 112   (define (hashtable-ref hashtable key default)
 113     (hash-table-ref/default
 114      (r6rs:hashtable-wrapped-table hashtable) key default))
 115
 116   (define (hashtable-set! hashtable key obj)
 117     (if (r6rs:hashtable-mutable? hashtable)
 118         (hash-table-set! (r6rs:hashtable-wrapped-table hashtable) key obj))
 119     *unspecified*)
 120
 121   (define (hashtable-delete! hashtable key)
 122     (if (r6rs:hashtable-mutable? hashtable)
 123         (hash-table-delete! (r6rs:hashtable-wrapped-table hashtable) key))
 124     *unspecified*)
 125
 126   (define (hashtable-contains? hashtable key)
 127     (hash-table-exists? (r6rs:hashtable-wrapped-table hashtable) key))
 128
 129   (define (hashtable-update! hashtable key proc default)
 130     (if (r6rs:hashtable-mutable? hashtable)
 131         (hash-table-update!/default
 132          (r6rs:hashtable-wrapped-table hashtable) key proc default))
 133     *unspecified*)
 134
 135   (define* (hashtable-copy hashtable #:optional mutable)
 136     (make-r6rs-hashtable
 137      (hash-table-copy (r6rs:hashtable-wrapped-table hashtable))
 138      (r6rs:hashtable-orig-hash-function hashtable)
 139      (and mutable #t)))
 140
 141   (define* (hashtable-clear! hashtable #:optional k)
 142     (if (r6rs:hashtable-mutable? hashtable)
 143         (let* ((ht (r6rs:hashtable-wrapped-table hashtable))
 144                (equiv (hash-table-equivalence-function ht))
 145                (hash-function (r6rs:hashtable-orig-hash-function hashtable))
 146                (wrapped-hash-function (wrap-hash-function hash-function)))
 147           (r6rs:hashtable-set-wrapped-table!
 148            hashtable
 149            (if k
 150                (make-hash-table equiv wrapped-hash-function k)
 151                (make-hash-table equiv wrapped-hash-function)))))
 152     *unspecified*)
 153
 154   (define (hashtable-keys hashtable)
 155     (list->vector (hash-table-keys (r6rs:hashtable-wrapped-table hashtable))))
 156
 157   (define (hashtable-entries hashtable)
 158     (let* ((ht (r6rs:hashtable-wrapped-table hashtable))
 159            (size (hash-table-size ht))
 160            (keys (make-vector size))
 161            (vals (make-vector size)))
 162       (hash-table-fold (r6rs:hashtable-wrapped-table hashtable)
 163                        (lambda (k v i)
 164                          (vector-set! keys i k)
 165                          (vector-set! vals i v)
 166                          (+ i 1))
 167                        0)
 168       (values keys vals)))
 169
 170   (define (hashtable-equivalence-function hashtable)
 171     (hash-table-equivalence-function (r6rs:hashtable-wrapped-table hashtable)))
 172
 173   (define (hashtable-hash-function hashtable)
 174     (r6rs:hashtable-orig-hash-function hashtable)))