hashtables.scm 6.3 KB

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