source: project/release/3/hashes/tags/2.2/hash-utils.scm @ 8297

Last change on this file since 8297 was 8297, checked in by Kon Lovett, 13 years ago

Added rabin-karp, TW user mix hash.

File size: 7.0 KB
Line 
1;;;; hash-utils.scm
2;;;; Kon Lovett, Jan '06
3
4;; Issues
5;;
6;; - Assumes string-length is the string-byte-length. The use of
7;; standard-bindings should ensure this invariant.
8;;
9;; - unsigned-integer32-ref & -set! assume all object data aligned
10;; on 32-bit boundary!
11
12(use message-digest miscmacros mathh-int misc-extn-control)
13(use hashes-support)
14
15(declare
16  (usual-integrations)
17  (number-type generic) ; "core" - fixnum & flonum only
18  (inline)
19  (no-procedure-checks)
20  (no-bound-checks)
21  (bound-to-procedure
22    ##sys#check-exact
23    ##sys#check-number
24    ##sys#check-closure )
25  (export
26    current-hash-seed
27    make-range-restriction
28    make-fixnum-range-restriction
29    make-seeded-hash
30    make-mask-hash
31    make-range-hash
32    make-bounded-hash
33    make-fixnum-bounded-hash
34    make-real-hash
35    make-hash-procedure
36    make-hash-message-digest-procedures ) )
37
38#>
39#include "hashes.h"
40
41#undef bitsizeof
42<#
43
44(include "hashes-macros")
45
46;;;
47
48(define-inline (check-number loc obj)
49  (##sys#check-number obj loc) )
50
51(define-inline (check-fixnum loc obj)
52  (##sys#check-exact obj loc) )
53
54(define-inline (check-procedure loc obj)
55  (##sys#check-closure obj loc) )
56
57(define-inline (check-unsigned-integer32 loc obj)
58        (unless (and (integer? obj)
59                     (<= 0 obj maximum-unsigned-integer32))
60                (error loc "not an integer in [0 maximum-unsigned-integer32)" obj) ) )
61
62;;
63
64(define-inline (force-exact num)
65  (if (flonum? num)
66      (##core#inline "C_quickflonumtruncate" num)
67      num) )
68
69(define-inline (number->exact n)
70        (if (inexact? n)
71      (let ([i (if (integer? n) n (round n))])
72        (inexact->exact
73          (cond [(< i most-negative-fixnum) (modulo i most-negative-fixnum)]
74                [(< most-positive-fixnum i) (modulo i most-positive-fixnum)]
75                [else                       i])) )
76      n ) )
77
78(define-inline (number->fixnum n)
79  (force-exact (number->exact n)) )
80
81;; Common hash seed
82
83(define-parameter current-hash-seed
84  DEFAULT-HASH-SEED
85        (lambda (v)
86          (set! hs$hash-seed
87          (cond [(fixnum? v)  (if (fx< v 0) (fxneg v) v)]
88                [(flonum? v)  (if (fp< v 0.0) (fpneg v) v)]
89                [(not v)      0]
90                [else
91                  (warning 'current-hash-seed "invalid hash-seed" v)
92                  hs$hash-seed]))
93    hs$hash-seed))
94
95;;; Range restrictions
96
97(define (make-range-restriction upper . args)
98        (let-optionals args ([lower 0])
99                (check-number 'make-range-restriction lower)
100                (check-number 'make-range-restriction upper)
101                (unless (<= lower upper) (swap-set! upper lower))
102                (if (zero? lower)
103        (lambda (num) (modulo num upper))
104        (let ([diff (- upper lower -1)])
105          (lambda (num) (+ lower (modulo num diff))) ) ) ) )
106
107(define (make-fixnum-range-restriction upper . args)
108        (let-optionals args ([lower 0])
109                (check-fixnum 'make-fixnum-range-restriction lower)
110                (check-fixnum 'make-fixnum-range-restriction upper)
111                (unless (<= lower upper) (swap-set! upper lower))
112                (if (fx= 0 lower)
113        (lambda (num) (fxmod (number->fixnum num) upper))
114        (let ([diff (fx+ (fx- upper lower) 1)])
115          (lambda (num) (fx+ lower (fxmod (number->fixnum num) diff))) ) ) ) )
116
117;;; SRFI-69 hash function signatures
118
119(define (make-fixnum-bounded-hash hash-proc . args)
120  (let-optionals args ([getlen string-length] [initr #f])
121    (check-procedure 'make-fixnum-bounded-hash hash-proc)
122    (check-procedure 'make-fixnum-bounded-hash getlen)
123    (when initr (check-procedure 'make-fixnum-bounded-hash initr))
124    (lambda (obj . args)
125      (let-optionals args ([bound most-positive-fixnum])
126        (fxmod (fxand (force-exact (hash-proc obj (getlen obj) (if initr (initr) 0)))
127                      most-positive-fixnum)
128               bound) ) ) ) )
129
130;;; HASH function signatures
131
132(define (make-bounded-hash hash-proc . args)
133  (let-optionals args ([getlen string-length] [initr #f])
134    (check-procedure 'make-bounded-hash hash-proc)
135    (check-procedure 'make-bounded-hash getlen)
136    (when initr (check-procedure 'make-bounded-hash initr))
137    (lambda (obj . args)
138      (let-optionals args ([bound most-positive-fixnum])
139        (abs (modulo (hash-proc obj (getlen obj) (if initr (initr) 0)) bound)) ) ) ) )
140
141(define (make-seeded-hash hash-proc . args)
142        (check-procedure 'make-seeded-hash hash-proc)
143        (let-optionals args ([seed (current-hash-seed)])
144                (check-unsigned-integer32 'make-seeded-hash seed)
145                (lambda (str . args)
146                        (hash-proc str (optional args (string-length str)) seed)) ) )
147
148(define (make-range-hash hash-proc upper . args)
149        (check-procedure 'make-range-hash hash-proc)
150        (let-optionals args ([lower 0])
151                (check-unsigned-integer32 'make-range-hash lower)
152                (check-unsigned-integer32 'make-range-hash upper)
153                (unless (<= lower upper) (swap-set! upper lower))
154                (if (zero? lower)
155        (lambda (str . args) (modulo (apply hash-proc str args) upper))
156        (let ([diff (- upper lower -1)])
157          (lambda (str . args) (+ lower (modulo (apply hash-proc str args) diff))) ) ) ) )
158
159(define (make-mask-hash hash-proc mask)
160        (check-procedure 'make-mask-hash hash-proc)
161  (check-unsigned-integer32 'make-mask-hash mask)
162        (lambda (str . args)
163                (bitwise-and (apply hash-proc str args) mask)) )
164
165(define (make-real-hash hash-proc)
166        (check-procedure 'make-real-hash hash-proc)
167        (lambda (str . args)
168                (let ([h (apply hash-proc str args)])
169                        (if (zero? h) 0.0 (/ 1.0 h)) ) ) )
170
171;;;
172
173;; Takes 1 argument:
174;; hash-primitive-procedure
175;;
176;; Returns 1 value:
177;; hash-update-procedure
178;; ((c-pointer "ctx") scheme-object unsigned-integer32 -> void)
179
180(define (%make-hash-update-procedure prim-proc)
181  (lambda (ctx data length)
182    (hashes:ctx-hash-set! ctx (prim-proc data length (hashes:ctx-hash-ref ctx))) ) )
183
184;; Takes 2 arguments - 1 required & 1 optional:
185;; hash-primitive-procedure
186;; length-procedure
187;;
188;; Returns 1 value:
189;; hash-procedure
190
191(define (make-hash-procedure prim-proc #!optional [byte-length string-length])
192  (check-procedure 'make-hash-procedure prim-proc)
193  (lambda (data . args)
194    (let-optionals args ([length (byte-length data)] [initval 0])
195      (prim-proc data length initval)) ) )
196
197;; Takes 1 argument:
198;; hash-primitive-procedure
199;;
200;; Returns a 3 element list:
201;; binary-message-digest
202;; message-digest
203;; message-digest-primitive
204
205(define (make-hash-message-digest-procedures prim-proc)
206  (check-procedure 'make-hash-message-digest-procedures prim-proc)
207  (let ([updt-proc (%make-hash-update-procedure prim-proc)])
208    (list
209      (lambda (obj)
210        (make-binary-message-digest obj
211          hashes:hash-context-size unsigned-integer32-size
212          hashes:generic-init updt-proc hashes:generic-final
213          (gensym "hash:binary-digest-")))
214      (lambda (obj)
215        (make-message-digest obj
216          hashes:hash-context-size unsigned-integer32-size
217          hashes:generic-init updt-proc hashes:generic-final
218          (gensym "hash:digest")))
219      (lambda (obj)
220        (make-message-digest-primitive
221          hashes:hash-context-size unsigned-integer32-size
222          hashes:generic-init updt-proc hashes:generic-final
223          (gensym "hash:primitive-")))) ) )
Note: See TracBrowser for help on using the repository browser.