1;; Copyright (C) Panu Kalliokoski (2005). All Rights Reserved. 2;; 3;; Permission is hereby granted, free of charge, to any person obtaining a 4;; copy of this software and associated documentation files (the 5;; "Software"), to deal in the Software without restriction, including 6;; without limitation the rights to use, copy, modify, merge, publish, 7;; distribute, sublicense, and/or sell copies of the Software, and to 8;; permit persons to whom the Software is furnished to do so, subject to 9;; the following conditions: 10;; 11;; The above copyright notice and this permission notice shall be included 12;; in all copies or substantial portions of the Software. 13;; 14;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS 15;; OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 22;; Latest sources: 23;; 24;; http://members.sange.fi/~atehwa/vc/r+d/guse/srfi/hash-srfi.ss 25;; http://members.sange.fi/~atehwa/vc/r+d/guse/srfi/test-hash.ss 26 27 28;; ChangeLog 29;; 30;; 2007-07-23 yamaken - Imported from 31;; http://srfi.schemers.org/srfi-69/srfi-69.html 32;; and adapted to SigScheme 33 34 35;; 36;; SigScheme adaptation 37;; 38 39(require-extension (srfi 9 23)) 40 41(define inexact? (lambda (x) #f)) 42(define real? inexact?) 43 44(define expt 45 (lambda (x y) 46 (let rec ((res 1) 47 (cnt y)) 48 (if (zero? cnt) 49 res 50 (rec (* res x) (- cnt 1)))))) 51 52;; 53;; Main implementation 54;; 55 56;; This implementation relies on SRFI-9 for distinctness of the hash table 57;; type, and on SRFI-23 for error reporting. Otherwise, the implementation 58;; is pure R5RS. 59 60(define *default-bound* (- (expt 2 29) 3)) 61 62(define (%string-hash s ch-conv bound) 63 (let ((hash 31) 64 (len (string-length s))) 65 (do ((index 0 (+ index 1))) 66 ((>= index len) (modulo hash bound)) 67 (set! hash (modulo (+ (* 37 hash) 68 (char->integer (ch-conv (string-ref s index)))) 69 *default-bound*))))) 70 71(define (string-hash s . maybe-bound) 72 (let ((bound (if (null? maybe-bound) *default-bound* (car maybe-bound)))) 73 (%string-hash s (lambda (x) x) bound))) 74 75(define (string-ci-hash s . maybe-bound) 76 (let ((bound (if (null? maybe-bound) *default-bound* (car maybe-bound)))) 77 (%string-hash s char-downcase bound))) 78 79(define (symbol-hash s . maybe-bound) 80 (let ((bound (if (null? maybe-bound) *default-bound* (car maybe-bound)))) 81 (%string-hash (symbol->string s) (lambda (x) x) bound))) 82 83(define (hash obj . maybe-bound) 84 (let ((bound (if (null? maybe-bound) *default-bound* (car maybe-bound)))) 85 (cond ((integer? obj) (modulo obj bound)) 86 ((string? obj) (string-hash obj bound)) 87 ((symbol? obj) (symbol-hash obj bound)) 88 ((real? obj) (modulo (+ (numerator obj) (denominator obj)) bound)) 89 ((number? obj) 90 (modulo (+ (hash (real-part obj)) (* 3 (hash (imag-part obj)))) 91 bound)) 92 ((char? obj) (modulo (char->integer obj) bound)) 93 ((vector? obj) (vector-hash obj bound)) 94 ((pair? obj) (modulo (+ (hash (car obj)) (* 3 (hash (cdr obj)))) 95 bound)) 96 ((null? obj) 0) 97 ((not obj) 0) 98 ((procedure? obj) (error "hash: procedures cannot be hashed" obj)) 99 (else 1)))) 100 101(define hash-by-identity hash) 102 103(define (vector-hash v bound) 104 (let ((hashvalue 571) 105 (len (vector-length v))) 106 (do ((index 0 (+ index 1))) 107 ((>= index len) (modulo hashvalue bound)) 108 (set! hashvalue (modulo (+ (* 257 hashvalue) (hash (vector-ref v index))) 109 *default-bound*))))) 110 111(define %make-hash-node cons) 112(define %hash-node-set-value! set-cdr!) 113(define %hash-node-key car) 114(define %hash-node-value cdr) 115 116(define-record-type <srfi-hash-table> 117 (%make-hash-table size hash compare associate entries) 118 hash-table? 119 (size hash-table-size hash-table-set-size!) 120 (hash hash-table-hash-function) 121 (compare hash-table-equivalence-function) 122 (associate hash-table-association-function) 123 (entries hash-table-entries hash-table-set-entries!)) 124 125(define *default-table-size* 64) 126 127(define (appropriate-hash-function-for comparison) 128 (or (and (eq? comparison eq?) hash-by-identity) 129 (and (eq? comparison string=?) string-hash) 130 (and (eq? comparison string-ci=?) string-ci-hash) 131 hash)) 132 133(define (make-hash-table . args) 134 (let* ((comparison (if (null? args) equal? (car args))) 135 (hash 136 (if (or (null? args) (null? (cdr args))) 137 (appropriate-hash-function-for comparison) (cadr args))) 138 (size 139 (if (or (null? args) (null? (cdr args)) (null? (cddr args))) 140 *default-table-size* (caddr args))) 141 (association 142 (or (and (eq? comparison eq?) assq) 143 (and (eq? comparison eqv?) assv) 144 (and (eq? comparison equal?) assoc) 145 (letrec 146 ((associate 147 (lambda (val alist) 148 (cond ((null? alist) #f) 149 ((comparison val (caar alist)) (car alist)) 150 (else (associate val (cdr alist))))))) 151 associate)))) 152 (%make-hash-table 0 hash comparison association (make-vector size '())))) 153 154(define (make-hash-table-maker comp hash) 155 (lambda args (apply make-hash-table (cons comp (cons hash args))))) 156(define make-symbol-hash-table 157 (make-hash-table-maker eq? symbol-hash)) 158(define make-string-hash-table 159 (make-hash-table-maker string=? string-hash)) 160(define make-string-ci-hash-table 161 (make-hash-table-maker string-ci=? string-ci-hash)) 162(define make-integer-hash-table 163 (make-hash-table-maker = modulo)) 164 165(define (%hash-table-hash hash-table key) 166 ((hash-table-hash-function hash-table) 167 key (vector-length (hash-table-entries hash-table)))) 168 169(define (%hash-table-find entries associate hash key) 170 (associate key (vector-ref entries hash))) 171 172(define (%hash-table-add! entries hash key value) 173 (vector-set! entries hash 174 (cons (%make-hash-node key value) 175 (vector-ref entries hash)))) 176 177(define (%hash-table-delete! entries compare hash key) 178 (let ((entrylist (vector-ref entries hash))) 179 (cond ((null? entrylist) #f) 180 ((compare key (caar entrylist)) 181 (vector-set! entries hash (cdr entrylist)) #t) 182 (else 183 (let loop ((current (cdr entrylist)) (previous entrylist)) 184 (cond ((null? current) #f) 185 ((compare key (caar current)) 186 (set-cdr! previous (cdr current)) #t) 187 (else (loop (cdr current) current)))))))) 188 189(define (%hash-table-walk proc entries) 190 (do ((index (- (vector-length entries) 1) (- index 1))) 191 ((< index 0)) (for-each proc (vector-ref entries index)))) 192 193(define (%hash-table-maybe-resize! hash-table) 194 (let* ((old-entries (hash-table-entries hash-table)) 195 (hash-length (vector-length old-entries))) 196 (if (> (hash-table-size hash-table) hash-length) 197 (let* ((new-length (* 2 hash-length)) 198 (new-entries (make-vector new-length '())) 199 (hash (hash-table-hash-function hash-table))) 200 (%hash-table-walk 201 (lambda (node) 202 (%hash-table-add! new-entries 203 (hash (%hash-node-key node) new-length) 204 (%hash-node-key node) (%hash-node-value node))) 205 old-entries) 206 (hash-table-set-entries! hash-table new-entries))))) 207 208(define (hash-table-ref hash-table key . maybe-default) 209 (cond ((%hash-table-find (hash-table-entries hash-table) 210 (hash-table-association-function hash-table) 211 (%hash-table-hash hash-table key) key) 212 => %hash-node-value) 213 ((null? maybe-default) 214 (error "hash-table-ref: no value associated with" key)) 215 (else ((car maybe-default))))) 216 217(define (hash-table-ref/default hash-table key default) 218 (hash-table-ref hash-table key (lambda () default))) 219 220(define (hash-table-set! hash-table key value) 221 (let ((hash (%hash-table-hash hash-table key)) 222 (entries (hash-table-entries hash-table))) 223 (cond ((%hash-table-find entries 224 (hash-table-association-function hash-table) 225 hash key) 226 => (lambda (node) (%hash-node-set-value! node value))) 227 (else (%hash-table-add! entries hash key value) 228 (hash-table-set-size! hash-table 229 (+ 1 (hash-table-size hash-table))) 230 (%hash-table-maybe-resize! hash-table))))) 231 232(define (hash-table-update! hash-table key function . maybe-default) 233 (let ((hash (%hash-table-hash hash-table key)) 234 (entries (hash-table-entries hash-table))) 235 (cond ((%hash-table-find entries 236 (hash-table-association-function hash-table) 237 hash key) 238 => (lambda (node) 239 (%hash-node-set-value! 240 node (function (%hash-node-value node))))) 241 ((null? maybe-default) 242 (error "hash-table-update!: no value exists for key" key)) 243 (else (%hash-table-add! entries hash key 244 (function ((car maybe-default)))) 245 (hash-table-set-size! hash-table 246 (+ 1 (hash-table-size hash-table))) 247 (%hash-table-maybe-resize! hash-table))))) 248 249(define (hash-table-update!/default hash-table key function default) 250 (hash-table-update! hash-table key function (lambda () default))) 251 252(define (hash-table-delete! hash-table key) 253 (if (%hash-table-delete! (hash-table-entries hash-table) 254 (hash-table-equivalence-function hash-table) 255 (%hash-table-hash hash-table key) key) 256 (hash-table-set-size! hash-table (- (hash-table-size hash-table) 1)))) 257 258(define (hash-table-exists? hash-table key) 259 (and (%hash-table-find (hash-table-entries hash-table) 260 (hash-table-association-function hash-table) 261 (%hash-table-hash hash-table key) key) #t)) 262 263(define (hash-table-walk hash-table proc) 264 (%hash-table-walk 265 (lambda (node) (proc (%hash-node-key node) (%hash-node-value node))) 266 (hash-table-entries hash-table))) 267 268(define (hash-table-fold hash-table f acc) 269 (hash-table-walk hash-table 270 (lambda (key value) (set! acc (f key value acc)))) 271 acc) 272 273(define (alist->hash-table alist . args) 274 (let* ((comparison (if (null? args) equal? (car args))) 275 (hash 276 (if (or (null? args) (null? (cdr args))) 277 (appropriate-hash-function-for comparison) (cadr args))) 278 (size 279 (if (or (null? args) (null? (cdr args)) (null? (cddr args))) 280 (max *default-table-size* (* 2 (length alist))) (caddr args))) 281 (hash-table (make-hash-table comparison hash size))) 282 (for-each 283 (lambda (elem) 284 (hash-table-update!/default 285 hash-table (car elem) (lambda (x) x) (cdr elem))) 286 alist) 287 hash-table)) 288 289(define (hash-table->alist hash-table) 290 (hash-table-fold hash-table 291 (lambda (key val acc) (cons (cons key val) acc)) '())) 292 293(define (hash-table-copy hash-table) 294 (let ((new (make-hash-table (hash-table-equivalence-function hash-table) 295 (hash-table-hash-function hash-table) 296 (max *default-table-size* 297 (* 2 (hash-table-size hash-table)))))) 298 (hash-table-walk hash-table 299 (lambda (key value) (hash-table-set! new key value))) 300 new)) 301 302(define (hash-table-merge! hash-table1 hash-table2) 303 (hash-table-walk 304 hash-table2 305 (lambda (key value) (hash-table-set! hash-table1 key value))) 306 hash-table1) 307 308(define (hash-table-keys hash-table) 309 (hash-table-fold hash-table (lambda (key val acc) (cons key acc)) '())) 310 311(define (hash-table-values hash-table) 312 (hash-table-fold hash-table (lambda (key val acc) (cons val acc)) '())) 313