1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
|
; "hash.scm", hashing functions for Scheme.
; Copyright (C) 1992, 1993, 1995, 2003 Aubrey Jaffer
;
;Permission to copy this software, to modify it, to redistribute it,
;to distribute modified versions, and to use it for any purpose is
;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
(define (hash:hash-string-ci str n)
(let ((len (string-length str)))
(if (> len 5)
(let loop ((h (modulo 264 n)) (i 5))
(if (positive? i)
(loop (modulo (+ (* h 256)
(char->integer
(char-downcase
(string-ref str (modulo h len)))))
n)
(- i 1))
h))
(let loop ((h 0) (i (- len 1)))
(if (>= i 0)
(loop (modulo (+ (* h 256)
(char->integer
(char-downcase (string-ref str i))))
n)
(- i 1))
h)))))
(define hash:hash-string hash:hash-string-ci)
(define (hash:hash-symbol sym n)
(hash:hash-string (symbol->string sym) n))
;;; This can overflow on implemenatations where inexacts have a larger
;;; range than exact integers.
(define hash:hash-number
(if (provided? 'inexact)
(lambda (num n)
(if (integer? num)
(modulo (if (exact? num) num (inexact->exact num)) n)
(hash:hash-string-ci
(number->string (if (exact? num) (exact->inexact num) num))
n)))
(lambda (num n)
(if (integer? num)
(modulo num n)
(hash:hash-string-ci (number->string num) n)))))
;@
(define (hash obj n)
(let hs ((d 10) (obj obj))
(cond
((number? obj) (hash:hash-number obj n))
((char? obj) (modulo (char->integer (char-downcase obj)) n))
((symbol? obj) (hash:hash-symbol obj n))
((string? obj) (hash:hash-string obj n))
((vector? obj)
(let ((len (vector-length obj)))
(if (> len 5)
(let lp ((h 1) (i (quotient d 2)))
(if (positive? i)
(lp (modulo (+ (* h 256)
(hs 2 (vector-ref obj (modulo h len))))
n)
(- i 1))
h))
(let loop ((h (- n 1)) (i (- len 1)))
(if (>= i 0)
(loop (modulo (+ (* h 256) (hs (quotient d len)
(vector-ref obj i)))
n)
(- i 1))
h)))))
((pair? obj)
(if (positive? d) (modulo (+ (hs (quotient d 2) (car obj))
(hs (quotient d 2) (cdr obj)))
n)
1))
(else
(modulo
(cond
((null? obj) 256)
((boolean? obj) (if obj 257 258))
((eof-object? obj) 259)
((input-port? obj) 260)
((output-port? obj) 261)
((procedure? obj) 262)
(else 263))
n)))))
(define hash:hash hash)
;;; Object-hash is somewhat expensive on copying GC systems (like
;;; PC-Scheme and MITScheme). We use it only on strings, pairs, and
;;; vectors. This also allows us to use it for both hashq and hashv.
;@
(define hashv
(if (provided? 'object-hash)
(lambda (obj k)
(if (or (string? obj) (pair? obj) (vector? obj))
(modulo (object-hash obj) k)
(hash:hash obj k)))
hash))
(define hashq hashv)
|
