Changeset 8297 in project
- Timestamp:
- 02/09/08 02:11:46 (12 years ago)
- Location:
- release/3/hashes
- Files:
-
- 2 added
- 24 edited
- 1 copied
Legend:
- Unmodified
- Added
- Removed
-
release/3/hashes/tags/2.2/CRCHash.scm
r8148 r8297 6 6 ;; - CRC hash accumulation technique is questionable. 7 7 8 (use message-digest box crc hash-utils mathh-int )8 (use message-digest box crc hash-utils mathh-int hashes-support) 9 9 10 10 (declare -
release/3/hashes/tags/2.2/TWUserMixHash-support.scm
r8148 r8297 7 7 (disable-interrupts) 8 8 (no-procedure-checks) 9 (no-argc-checks) 9 10 (no-bound-checks) 10 11 (export 11 12 foreign-TWUserMixHash ) ) 12 13 14 ;;; 15 13 16 #> 14 17 #include "hashes.h" 15 18 19 #define MIXER(key) {\ 20 char numbuf[C_SIZEOF_FLONUM];\ 21 C_word *ptr = (C_word *) &numbuf;\ 22 C_word num = C_unsigned_int_to_num (&ptr, key);\ 23 C_word res;\ 24 C_save (num);\ 25 res = C_callback (mixer, 1);\ 26 key = (uint32_t) C_num_to_unsigned_int (res);\ 27 } 28 16 29 #ifdef C_BIG_ENDIAN 17 30 static uint32_t 18 TWUserMixHash (uint8_t *data, uint32_t length, uint32_t initval, uint32_t (*mix) (uint32_t))31 TWUserMixHash (uint8_t *data, uint32_t length, uint32_t key, void * mixer_data) 19 32 { 20 uint8_t *k = data; 21 uint32_t len = length; 22 uint32_t key = initval; 33 uint8_t *k = data; 34 uint32_t len = length; 35 C_word mixer = (C_word) ((C_SCHEME_BLOCK *) (((char *) mixer_data) - sizeof (C_header))); 36 37 if (C_header_bits (mixer) != C_CLOSURE_TYPE) { 38 C_printf ("Error: (TWUserMixHash) invalid mix procedure: not a closure"); 39 return 0; 40 } 23 41 24 42 if (data == NULL) return 0; 25 43 26 27 28 mix(key);29 30 31 44 while (len >= 4) { 45 key += (k[0] + (((uint32_t) k[1]) << 8) + (((uint32_t) k[2]) << 16) + (((uint32_t) k[3]) << 24)); 46 MIXER (key); 47 k += 4; 48 len -= 4; 49 } 32 50 33 34 35 36 37 38 39 40 mix(key);51 switch (len) { 52 /* all the case statements fall through */ 53 case 3 : key += (((uint32_t) k[2]) << 16); 54 case 2 : key += (((uint32_t) k[1]) << 8); 55 case 1 : key += k[0]; 56 /* case 0: nothing left to add */ 57 } 58 MIXER (key); 41 59 42 60 return key; 43 61 } 44 62 #else 45 63 static uint32_t 46 TWUserMixHash (uint8_t *data, uint32_t length, uint32_t initval, uint32_t (*mix) (uint32_t))64 TWUserMixHash (uint8_t *data, uint32_t length, uint32_t key, void * mixer_data) 47 65 { 48 uint8_t *k = data; 49 uint32_t len = length; 50 uint32_t key = initval; 66 uint8_t *k = data; 67 uint32_t len = length; 68 C_word mixer = (C_word) ((C_SCHEME_BLOCK *) (((char *) mixer_data) - sizeof (C_header))); 69 70 if (C_header_bits (mixer) != C_CLOSURE_TYPE) { 71 C_printf ("Error: (TWUserMixHash) invalid mix procedure: not a closure"); 72 return 0; 73 } 51 74 52 75 if (data == NULL) return 0; 53 76 54 55 56 57 mix(key);58 59 60 61 62 63 64 mix(key);65 66 67 68 77 if (((uint32_t) k) & 3) { 78 while (len >= 4) { /* unaligned */ 79 key += (k[0] + (((uint32_t) k[1]) << 8) + (((uint32_t) k[2]) << 16) + (((uint32_t) k[3]) << 24)); 80 MIXER (key); 81 k += 4; 82 len -= 4; 83 } 84 } else { 85 while (len >= 4) { /* aligned */ 86 key += *((uint32_t *) (k + 0)); 87 MIXER (key); 88 k += 4; 89 len -= 4; 90 } 91 } 69 92 70 71 72 73 74 75 76 77 mix(key);93 switch (len) { 94 /* all the case statements fall through */ 95 case 3 : key += (((uint32_t) k[2]) << 16); 96 case 2 : key += (((uint32_t) k[1]) << 8); 97 case 1 : key += k[0]; 98 /* case 0: nothing left to add */ 99 } 100 MIXER (key); 78 101 79 102 return key; 80 103 } 81 104 #endif … … 87 110 88 111 (define foreign-TWUserMixHash 89 (foreign- lambda unsigned-integer32 "TWUserMixHash"90 91 unsigned-integer3292 (function unsigned-integer32 (unsigned-integer32) "")))112 (foreign-safe-lambda unsigned-integer32 113 "TWUserMixHash" scheme-pointer unsigned-integer32 114 unsigned-integer32 115 nonnull-scheme-pointer)) -
release/3/hashes/tags/2.2/TWUserMixHash.scm
r8148 r8297 3 3 4 4 (use srfi-12) 5 (use TWUserMixHash-support hashes-support) 6 (use mathh-int message-digest) 5 (use TWUserMixHash-support hash-utils) 7 6 8 7 (declare … … 13 12 (export 14 13 make-TWUserMixHash-primitive-procedure 15 make-TWUserMixHash-procedure16 make-TWUserMixHash-message-digest-procedures17 14 make-TWUserMixHash ) ) 18 15 … … 21 18 (define-inline (check-procedure loc obj) 22 19 (##sys#check-closure obj loc) ) 23 24 ;;;25 26 ;; (define-external (mix_callback (unsigned-integer32 key)) unsigned-integer32 ... mix key ...)27 28 ;; Takes 1 argument:29 ;; mix-procedure30 ;;31 ;; Returns 1 value:32 ;; foreign-mix-procedure33 34 (define *last-exception* #f)35 36 (define (run-safe thunk errdef)37 (set! *last-exception* #f)38 (handle-exceptions ex39 (begin (set! *last-exception* ex) errdef)40 (thunk) ) )41 42 (define-macro (make-foreign-callback-mix-procedure ?mix-proc)43 `(##core#foreign-callback-wrapper44 ',(symbol->string (gensym 'foreign_callback_mix_))45 '""46 'unsigned-integer32 '(unsigned-integer32)47 (lambda (key)48 #;(,?mix-proc key)49 (run-safe (lambda () (,?mix-proc key)) 0))) )50 51 ;; Takes 1 argument:52 ;; hash-primitive-procedure53 ;;54 ;; Returns 1 value:55 ;; hash-update-procedure56 ;; ((c-pointer "ctx") scheme-object unsigned-integer32 -> void)57 58 (define (make-TWUserMixHash-update-procedure prim-proc)59 (check-procedure 'make-TWUserMixHash-update-procedure prim-proc)60 (lambda (ctx data length)61 (hashes:ctx-hash-set! ctx (prim-proc data length (hashes:ctx-hash-ref ctx))) ) )62 20 63 21 ;;; … … 80 38 ;; hash-primitive-procedure 81 39 82 (define (make-TWUserMixHash-primitive-procedure mix-proc )40 (define (make-TWUserMixHash-primitive-procedure mix-proc #!optional unsafe?) 83 41 (check-procedure 'make-TWUserMixHash-primitive-procedure mix-proc) 84 (let ([foreign-callback-mix (make-foreign-callback-mix-procedure mix-proc)]) 85 (lambda (data length initval) 86 (let ([key (foreign-TWUserMixHash data length initval foreign-callback-mix)]) 87 (if *last-exception* 88 (abort *last-exception*) 89 key ) ) ) ) ) 90 91 ;; Takes 2 arguments - 1 required & 1 optional: 92 ;; hash-primitive-procedure 93 ;; length-procedure 94 ;; 95 ;; Returns 1 value: 96 ;; hash-procedure 97 98 (define (make-TWUserMixHash-procedure prim-proc #!optional [byte-length string-length]) 99 (check-procedure 'make-TWUserMixHash-procedure prim-proc) 100 (lambda (data . args) 101 (let-optionals args ([length (byte-length data)] [initval 0]) 102 (prim-proc data length initval)) ) ) 103 104 ;; Takes 1 argument: 105 ;; hash-primitive-procedure 106 ;; 107 ;; Returns a 3 element list: 108 ;; binary-message-digest 109 ;; message-digest 110 ;; message-digest-primitive 111 112 (define (make-TWUserMixHash-message-digest-procedures prim-proc) 113 (check-procedure 'make-TWUserMixHash-message-digest-procedures prim-proc) 114 (let ([updt-proc (make-TWUserMixHash-update-procedure prim-proc)]) 115 (list 116 (lambda (obj) 117 (make-binary-message-digest obj 118 hashes:hash-context-size unsigned-integer32-size 119 hashes:generic-init updt-proc hashes:generic-final 120 (gensym 'TWUserMixHash:binary-digest_))) 121 (lambda (obj) 122 (make-message-digest obj 123 hashes:hash-context-size unsigned-integer32-size 124 hashes:generic-init updt-proc hashes:generic-final 125 (gensym 'TWUserMixHash:digest_))) 126 (lambda (obj) 127 (make-message-digest-primitive 128 hashes:hash-context-size unsigned-integer32-size 129 hashes:generic-init updt-proc hashes:generic-final 130 (gensym 'TWUserMixHash:primitive_)))) ) ) 42 (if unsafe? 43 (cut foreign-TWUserMixHash <> <> <> mix-proc) 44 (let* ([*last-exception* #f] 45 [mixer (lambda (key) 46 (handle-exceptions ex 47 (begin (set! *last-exception* ex) 0) 48 (set! *last-exception* #f) 49 (mix-proc key) ) ) ] ) 50 (lambda (data length initval) 51 (let ([key (foreign-TWUserMixHash data length initval mixer)]) 52 (if *last-exception* 53 (abort *last-exception*) 54 key ) ) ) ) ) ) 131 55 132 56 ;; Takes 1 argument: … … 140 64 ;; message-digest-primitive 141 65 142 (define (make-TWUserMixHash mixer) 143 (let ([prim-proc (make-TWUserMixHash-primitive-procedure mixer)]) 66 (define (make-TWUserMixHash mix-proc #!optional unsafe?) 67 (check-procedure 'make-TWUserMixHash mix-proc) 68 (let ([prim-proc (make-TWUserMixHash-primitive-procedure mix-proc unsafe?)]) 144 69 (apply values prim-proc 145 (make- TWUserMixHash-procedure prim-proc)146 (make- TWUserMixHash-message-digest-procedures prim-proc)) ) )70 (make-hash-procedure prim-proc) 71 (make-hash-message-digest-procedures prim-proc)) ) ) -
release/3/hashes/tags/2.2/hash-utils.scm
r8148 r8297 10 10 ;; on 32-bit boundary! 11 11 12 (use lolevel)13 12 (use message-digest miscmacros mathh-int misc-extn-control) 13 (use hashes-support) 14 14 15 15 (declare … … 24 24 ##sys#check-closure ) 25 25 (export 26 ;; Deprecated27 string-binary-unsigned-int32-set!28 string-binary->unsigned-int3229 ;;30 26 current-hash-seed 31 27 make-range-restriction … … 37 33 make-fixnum-bounded-hash 38 34 make-real-hash 39 unsigned-integer32-ref40 unsigned-integer32-set!) )35 make-hash-procedure 36 make-hash-message-digest-procedures ) ) 41 37 42 38 #> … … 45 41 #undef bitsizeof 46 42 <# 43 44 (include "hashes-macros") 47 45 48 46 ;;; … … 84 82 85 83 (define-parameter current-hash-seed 86 084 DEFAULT-HASH-SEED 87 85 (lambda (v) 88 (cond [(number? v) (abs v)] 89 [(not v) 0] 90 [else 91 (warning "invalid hash-seed" v) 92 (current-hash-seed)] ) ) ) 93 94 ;;; Utilities 95 96 (define uint32-cptr-ref 97 (foreign-lambda* unsigned-integer32 ((c-pointer dat)) 98 "return (*((uint32_t *) dat));")) 99 100 (define uint32-cptr-set! 101 (foreign-lambda* void ((c-pointer dat) (unsigned-integer32 w32)) 102 "*((uint32_t *) dat) = (uint32_t) w32;")) 103 104 (define uint32-sptr-ref 105 (foreign-lambda* unsigned-integer32 ((scheme-pointer dat)) 106 "return (*((uint32_t *) dat));")) 107 108 (define uint32-sptr-set! 109 (foreign-lambda* void ((scheme-pointer dat) (unsigned-integer32 w32)) 110 "*((uint32_t *) dat) = (uint32_t) w32;")) 111 112 (define-inline (ptr-prc-for-obj obj cptr-proc sptr-proc) 113 (if (or (pointer? obj) (locative? obj)) 114 cptr-proc 115 sptr-proc ) ) 116 117 (define (unsigned-integer32-set! obj num) 118 ((ptr-prc-for-obj obj uint32-cptr-set! uint32-sptr-set!) obj num) ) 119 120 (define (unsigned-integer32-ref obj) 121 ((ptr-prc-for-obj obj uint32-cptr-ref uint32-sptr-ref) obj) ) 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)) 122 94 123 95 ;;; Range restrictions … … 199 171 ;;; 200 172 201 (define string-binary-unsigned-int32-set! unsigned-integer32-ref) 202 (define string-binary->unsigned-int32 unsigned-integer32-set!) 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-")))) ) ) -
release/3/hashes/tags/2.2/hashes-eggdoc.scm
r8148 r8297 162 162 ) 163 163 164 #; ;TWUserMixHash DOESN'T WORK165 164 (subsection "TWUserMixHash Procedures" 166 165 167 (p "Thomas Wang's hash function with a user supplied MIX.") 168 169 (procedure "(make-TWUserMixHash-primitive-procedure MIXER)" 166 (p "Thomas Wang's hash function with a user supplied MIX procedure.") 167 168 (procedure "(make-TWUserMixHash-primitive-procedure MIXER [UNSAFE #f])" 169 170 170 (p "Returns a hash primitive procedure, " 171 171 (code "(scheme-object unsigned-integer32 unsigned-integer32 -> unsigned-integer32)") ", " 172 172 "for the procedure " (tt "MIX") ", " 173 (code "(unsigned-integer32 -> unsigned-integer32)") ".") ) 174 175 (procedure "(make-TWUserMixHash-procedure HASH-PRIM [BYTE-LENGTH string-length])" 176 (p "Returns a hash procedure, " 177 (code "(scheme-object #!optional unsigned-integer32 unsigned-integer32 -> unsigned-integer32)") ", " 178 "for the hash primitive procedure " (tt "HASH-PRIM") ".") ) 179 180 (procedure "(make-TWUserMixHash-message-digest-procedures HASH-PRIM)" 181 (p "Returns a list of " (code ":binary-digest") ", " (code ":digest") ", and " 182 (code ":primitive") "for the hash primitive procedure " (tt "HASH-PRIM") ".") ) 183 184 (procedure "(make-TWUserMixHash MIXER)" 173 (code "(unsigned-integer32 -> unsigned-integer32)") ".") 174 175 (p "When " (tt "UNSAFE") " no exception checking is performed.") ) 176 177 (procedure "(make-TWUserMixHash MIXER [UNSAFE #f])" 185 178 (p "Returns 5 values: " (tt "HASH-PRIM") ", " (tt "HASH") ", " 186 179 (code ":binary-digest") ", " (code ":digest") ", and " (code ":primitive") ".") ) … … 244 237 "restricted to the interval, [0.0 1.0]. The signature is that " 245 238 "of the " (tt "{HASH}") ".")) 239 240 (procedure "(make-hash-procedure HASH-PRIM [BYTE-LENGTH string-length])" 241 (p "Returns a hash procedure, " 242 (code "(scheme-object #!optional unsigned-integer32 unsigned-integer32 -> unsigned-integer32)") ", " 243 "for the hash primitive procedure " (tt "HASH-PRIM") ".") ) 244 245 (procedure "(make-hash-message-digest-procedures HASH-PRIM)" 246 (p "Returns a list of " (code ":binary-digest") ", " (code ":digest") ", and " 247 (code ":primitive") "for the hash primitive procedure " (tt "HASH-PRIM") ".") ) 246 248 ) 247 249 … … 271 273 (p "Sets the first 32-bits of " (tt "STRING") " to " (tt "NUMBER") ".")) 272 274 ) 275 276 (subsection "Hash Search" 277 278 (usage "rabin-karp") 279 280 (procedure "(make-rabin-karp-string-search SUBSTRINGS [TEST [HASH]])" 281 (p "Returns a procedure of one argument, the search string, and two " 282 "optional arguments, the start and end positions within the string. " 283 "The search procedure returns a list of the matched substring and a list of the " 284 "start and end positions of the match in the search string. Returns " 285 (code "#f") " when no match found. Similar to the " (tt "regex unit") " " 286 (code "string-match") " procedure.") 287 288 (p (tt "SUBSTRINGS") " is a list of strings. " (tt "TEST") " is an " 289 "equivalence procedure. " (tt "HASH") " is a SRFI-69 compliant hash " 290 "procedure.") ) 291 ) 273 292 ) 274 293 275 294 (history 295 (version "2.2" "Added Rabin-Karp string hash search, TWUserMixHash.") 276 296 (version "2.105" "Added TWSHMXHash, TWSHMLMXHash, TWMGMXHash.") 277 297 (version "2.104" "Added make-fixnum-bounded-hash.") -
release/3/hashes/tags/2.2/hashes-macros.scm
r8148 r8297 51 51 hashes:generic-init ,UN hashes:generic-final 52 52 ',PN)) ) ) ) 53 54 (define-constant DEFAULT-HASH-SEED 0) -
release/3/hashes/tags/2.2/hashes-support.scm
r8148 r8297 19 19 ;; - Better initval handling, what ever that means. 20 20 21 (use hash-utils)22 23 21 (declare 22 (uses lolevel) 24 23 (usual-integrations) 25 24 (inline) 25 (generic) 26 26 (disable-interrupts) 27 27 (no-procedure-checks) … … 29 29 (no-bound-checks) 30 30 (export 31 hs$hash-seed 32 unsigned-integer32-set! 33 unsigned-integer32-ref 31 34 hashes:hash-context-size 32 35 hashes:ctx-hash-ref … … 41 44 <# 42 45 46 (include "hashes-macros") 47 43 48 ;;; 49 50 (define uint32-cptr-ref 51 (foreign-lambda* unsigned-integer32 ((c-pointer dat)) 52 "return (*((uint32_t *) dat));")) 53 54 (define uint32-cptr-set! 55 (foreign-lambda* void ((c-pointer dat) (unsigned-integer32 w32)) 56 "*((uint32_t *) dat) = (uint32_t) w32;")) 57 58 (define uint32-sptr-ref 59 (foreign-lambda* unsigned-integer32 ((scheme-pointer dat)) 60 "return (*((uint32_t *) dat));")) 61 62 (define uint32-sptr-set! 63 (foreign-lambda* void ((scheme-pointer dat) (unsigned-integer32 w32)) 64 "*((uint32_t *) dat) = (uint32_t) w32;")) 65 66 (define-inline (ptr-prc-for-obj obj cptr-proc sptr-proc) 67 (if (or (pointer? obj) (locative? obj)) 68 cptr-proc 69 sptr-proc ) ) 70 71 ;;; 72 73 (define hs$hash-seed DEFAULT-HASH-SEED) 74 75 ;;; 76 77 (define (unsigned-integer32-set! obj num) 78 ((ptr-prc-for-obj obj uint32-cptr-set! uint32-sptr-set!) obj num) ) 79 80 (define (unsigned-integer32-ref obj) 81 ((ptr-prc-for-obj obj uint32-cptr-ref uint32-sptr-ref) obj) ) 44 82 45 83 (define hashes:hash-context-size (foreign-value "sizeof (hashctx)" int)) … … 60 98 61 99 (define (hashes:generic-init ctx) 62 (hashes:ctx-hash-set! ctx (current-hash-seed)) )100 (hashes:ctx-hash-set! ctx hs$hash-seed) ) 63 101 64 102 ;; -
release/3/hashes/tags/2.2/hashes.html
r8148 r8297 274 274 <p>The ISpell hash function.</p></td></tr></table></div> 275 275 <div class="subsection"> 276 <h4>TWUserMixHash Procedures</h4> 277 <p>Thomas Wang's hash function with a user supplied MIX procedure.</p> 278 <dt class="definition"><strong>procedure:</strong> (make-TWUserMixHash-primitive-procedure MIXER [UNSAFE #f])</dt> 279 <dd> 280 <p>Returns a hash primitive procedure, <code>(scheme-object unsigned-integer32 unsigned-integer32 -> unsigned-integer32)</code>, for the procedure <tt>MIX</tt>, <code>(unsigned-integer32 -> unsigned-integer32)</code>.</p> 281 <p>When <tt>UNSAFE</tt> no exception checking is performed.</p></dd> 282 <dt class="definition"><strong>procedure:</strong> (make-TWUserMixHash MIXER [UNSAFE #f])</dt> 283 <dd> 284 <p>Returns 5 values: <tt>HASH-PRIM</tt>, <tt>HASH</tt>, <code>:binary-digest</code>, <code>:digest</code>, and <code>:primitive</code>.</p></dd></div> 285 <div class="subsection"> 276 286 <h4>Digest Procedures</h4> 277 287 <p>An acceptable input object for the digest procedures is a string, input-port, blob, vector, list, or homogeneous-vector. See <a href="http://www.call-with-current-continuation.org/eggs/message-digest.html">message-digest</a> for more information.</p> … … 308 318 <dt class="definition"><strong>procedure:</strong> (make-real-hash {HASH})</dt> 309 319 <dd> 310 <p>Returns a <tt>{HASH}</tt> with the hash value restricted to the interval, [0.0 1.0]. The signature is that of the <tt>{HASH}</tt>.</p></dd></div> 320 <p>Returns a <tt>{HASH}</tt> with the hash value restricted to the interval, [0.0 1.0]. The signature is that of the <tt>{HASH}</tt>.</p></dd> 321 <dt class="definition"><strong>procedure:</strong> (make-hash-procedure HASH-PRIM [BYTE-LENGTH string-length])</dt> 322 <dd> 323 <p>Returns a hash procedure, <code>(scheme-object #!optional unsigned-integer32 unsigned-integer32 -> unsigned-integer32)</code>, for the hash primitive procedure <tt>HASH-PRIM</tt>.</p></dd> 324 <dt class="definition"><strong>procedure:</strong> (make-hash-message-digest-procedures HASH-PRIM)</dt> 325 <dd> 326 <p>Returns a list of <code>:binary-digest</code>, <code>:digest</code>, and <code>:primitive</code>for the hash primitive procedure <tt>HASH-PRIM</tt>.</p></dd></div> 311 327 <div class="subsection"> 312 328 <h4>Range Procedures</h4> … … 327 343 <dt class="definition"><strong>procedure:</strong> (unsigned-integer32-set! OBJECT NUMBER)</dt> 328 344 <dd> 329 <p>Sets the first 32-bits of <tt>STRING</tt> to <tt>NUMBER</tt>.</p></dd></div></div> 345 <p>Sets the first 32-bits of <tt>STRING</tt> to <tt>NUMBER</tt>.</p></dd></div> 346 <div class="subsection"> 347 <h4>Hash Search</h4> 348 <div class="section"> 349 <h3>Usage</h3>rabin-karp</div> 350 <dt class="definition"><strong>procedure:</strong> (make-rabin-karp-string-search SUBSTRINGS [TEST [HASH]])</dt> 351 <dd> 352 <p>Returns a procedure of one argument, the search string, and two optional arguments, the start and end positions within the string. The search procedure returns a list of the matched substring and a list of the start and end positions of the match in the search string. Returns <code>#f</code> when no match found. Similar to the <tt>regex unit</tt> <code>string-match</code> procedure.</p> 353 <p><tt>SUBSTRINGS</tt> is a list of strings. <tt>TEST</tt> is an equivalence procedure. <tt>HASH</tt> is a SRFI-69 compliant hash procedure.</p></dd></div></div> 330 354 <div class="section"> 331 355 <h3>Version</h3> 332 356 <ul> 357 <li>2.106 Added Rabin-Karp string hash search, TWUserMixHash.</li> 333 358 <li>2.105 Added TWSHMXHash, TWSHMLMXHash, TWMGMXHash.</li> 334 359 <li>2.104 Added make-fixnum-bounded-hash.</li> -
release/3/hashes/tags/2.2/hashes.meta
r8148 r8297 5 5 (license "BSD") 6 6 (category crypt) 7 (needs misc-extn miscmacros mathh message-digest box crc )7 (needs misc-extn miscmacros mathh message-digest box crc iset) 8 8 (author "Kon Lovett") 9 9 (egg "hashes.egg") … … 36 36 "CRCHash.scm" 37 37 "hashes.scm" 38 "rabin-karp.scm" 38 39 "hashes.h" 39 40 "hash-utils.scm" -
release/3/hashes/tags/2.2/hashes.scm
r8148 r8297 6 6 RJMXHash 7 7 TWMXHash TWSHMXHash TWSHMLMXHash TWMGMXHash 8 #; ;TWUserMixHash DOESN'T WORK9 8 TWUserMixHash 10 9 FNVHash FNVAHash -
release/3/hashes/tags/2.2/hashes.setup
r8148 r8297 2 2 3 3 (required-extension-version 4 'iset "1.4" 4 5 'crc "1.1" 6 'box "1.8" 5 7 'mathh "1.9" 6 8 'misc-extn "3.002" … … 8 10 'miscmacros "2.4") 9 11 10 (install-dynld hash-utils *version*)11 12 12 (install-dynld hashes-support *version* -O3 -d0) 13 13 14 #| TWUserMixHash DOESN'T WORK 15 (install-dynld TWUserMixHash-support *version*) 16 (install-dynld TWUserMixHash *version*) 17 |# 14 (install-dynld hash-utils *version* (documentation "hashes.html")) 18 15 19 (install-dynld RJMXHash *version*) 20 (install-dynld TWMXHash *version*) 21 (install-dynld TWMGMXHash *version*) 22 (install-dynld TWSHMXHash *version*) 23 (install-dynld TWSHMLMXHash *version*) 24 (install-dynld FNVHash *version*) 25 (install-dynld FNVAHash *version*) 26 (install-dynld PHSFHash *version*) 27 (install-dynld RSHash *version*) 28 (install-dynld JSHash *version*) 29 (install-dynld PJWHash *version*) 30 (install-dynld ELFHash *version*) 31 (install-dynld BKDRHash *version*) 32 (install-dynld SDBMHash *version*) 33 (install-dynld DJBHash *version*) 34 (install-dynld NDJBHash *version*) 35 (install-dynld DEKHash *version*) 36 (install-dynld APHash *version*) 37 (install-dynld BRPHash *version*) 38 (install-dynld PYHash *version*) 39 (install-dynld RJL3Hash *version*) 40 (install-dynld ISPLHash *version*) 41 (install-dynld CRCHash *version*) 16 (install-dynld RJMXHash *version* (documentation "hashes.html")) 17 (install-dynld TWMXHash *version* (documentation "hashes.html")) 18 (install-dynld TWMGMXHash *version* (documentation "hashes.html")) 19 (install-dynld TWSHMXHash *version* (documentation "hashes.html")) 20 (install-dynld TWSHMLMXHash *version* (documentation "hashes.html")) 21 (install-dynld FNVHash *version* (documentation "hashes.html")) 22 (install-dynld FNVAHash *version* (documentation "hashes.html")) 23 (install-dynld PHSFHash *version* (documentation "hashes.html")) 24 (install-dynld RSHash *version* (documentation "hashes.html")) 25 (install-dynld JSHash *version* (documentation "hashes.html")) 26 (install-dynld PJWHash *version* (documentation "hashes.html")) 27 (install-dynld ELFHash *version* (documentation "hashes.html")) 28 (install-dynld BKDRHash *version* (documentation "hashes.html")) 29 (install-dynld SDBMHash *version* (documentation "hashes.html")) 30 (install-dynld DJBHash *version* (documentation "hashes.html")) 31 (install-dynld NDJBHash *version* (documentation "hashes.html")) 32 (install-dynld DEKHash *version* (documentation "hashes.html")) 33 (install-dynld APHash *version* (documentation "hashes.html")) 34 (install-dynld BRPHash *version* (documentation "hashes.html")) 35 (install-dynld PYHash *version* (documentation "hashes.html")) 36 (install-dynld RJL3Hash *version* (documentation "hashes.html")) 37 (install-dynld ISPLHash *version* (documentation "hashes.html")) 38 (install-dynld CRCHash *version* (documentation "hashes.html")) 39 40 (install-dynld TWUserMixHash-support *version* -O3 -d0) 41 (install-dynld TWUserMixHash *version* (documentation "hashes.html")) 42 42 43 43 (install-dynld+docu hashes *version*) 44 44 45 (install-dynld rabin-karp *version* (documentation "hashes.html")) 46 45 47 (install-test "hashes-test.scm") -
release/3/hashes/tags/2.2/tests/hashes-test.scm
r8148 r8297 3 3 (use testbase testbase-output-human) 4 4 (use hashes) 5 (use rabin-karp) 5 6 6 7 ;;; … … 165 166 ) 166 167 167 #; ;TWUserMixHash DOESN'T WORK 168 (define-test rabin-karp-test "Rabin-Karp Search" 169 (initial 170 (define substrs '("quick" "foo" "brown" "dog" "skasfdskjsalksafnsalsfsdsdjkldsajlfsalsk")) 171 (define hashp) 172 (define rksp) ) 173 174 (expect-set! hashp (make-fixnum-bounded-hash RJL3Hash-prim)) 175 (expect-set! rksp (make-rabin-karp-string-search substrs string=? hashp)) 176 (expect-success "Without start & end" (rksp TSTSTR)) 177 (expect-success "With start & end" (rksp TSTSTR 41 TSTSTR-LEN)) 178 ) 179 168 180 (define-test hashes-utils-test "TWUserMixHash" 169 181 (initial 170 (define (mix key) 171 key) 182 (define (mix key) key) 172 183 (define usrmixhsh) 173 184 (define hash-prim) … … 177 188 (define prim:digest) ) 178 189 179 (expect-set! "TWUserMixHash Make" usrmixhsh (receive (make-TWUserMixHash mix )))190 (expect-set! "TWUserMixHash Make" usrmixhsh (receive (make-TWUserMixHash mix #t))) 180 191 (side-effect 181 192 (set! hash-prim (car usrmixhsh)) -
release/3/hashes/trunk/CRCHash.scm
r8148 r8297 6 6 ;; - CRC hash accumulation technique is questionable. 7 7 8 (use message-digest box crc hash-utils mathh-int )8 (use message-digest box crc hash-utils mathh-int hashes-support) 9 9 10 10 (declare -
release/3/hashes/trunk/TWUserMixHash-support.scm
r8148 r8297 7 7 (disable-interrupts) 8 8 (no-procedure-checks) 9 (no-argc-checks) 9 10 (no-bound-checks) 10 11 (export 11 12 foreign-TWUserMixHash ) ) 12 13 14 ;;; 15 13 16 #> 14 17 #include "hashes.h" 15 18 19 #define MIXER(key) {\ 20 char numbuf[C_SIZEOF_FLONUM];\ 21 C_word *ptr = (C_word *) &numbuf;\ 22 C_word num = C_unsigned_int_to_num (&ptr, key);\ 23 C_word res;\ 24 C_save (num);\ 25 res = C_callback (mixer, 1);\ 26 key = (uint32_t) C_num_to_unsigned_int (res);\ 27 } 28 16 29 #ifdef C_BIG_ENDIAN 17 30 static uint32_t 18 TWUserMixHash (uint8_t *data, uint32_t length, uint32_t initval, uint32_t (*mix) (uint32_t))31 TWUserMixHash (uint8_t *data, uint32_t length, uint32_t key, void * mixer_data) 19 32 { 20 uint8_t *k = data; 21 uint32_t len = length; 22 uint32_t key = initval; 33 uint8_t *k = data; 34 uint32_t len = length; 35 C_word mixer = (C_word) ((C_SCHEME_BLOCK *) (((char *) mixer_data) - sizeof (C_header))); 36 37 if (C_header_bits (mixer) != C_CLOSURE_TYPE) { 38 C_printf ("Error: (TWUserMixHash) invalid mix procedure: not a closure"); 39 return 0; 40 } 23 41 24 42 if (data == NULL) return 0; 25 43 26 27 28 mix(key);29 30 31 44 while (len >= 4) { 45 key += (k[0] + (((uint32_t) k[1]) << 8) + (((uint32_t) k[2]) << 16) + (((uint32_t) k[3]) << 24)); 46 MIXER (key); 47 k += 4; 48 len -= 4; 49 } 32 50 33 34 35 36 37 38 39 40 mix(key);51 switch (len) { 52 /* all the case statements fall through */ 53 case 3 : key += (((uint32_t) k[2]) << 16); 54 case 2 : key += (((uint32_t) k[1]) << 8); 55 case 1 : key += k[0]; 56 /* case 0: nothing left to add */ 57 } 58 MIXER (key); 41 59 42 60 return key; 43 61 } 44 62 #else 45 63 static uint32_t 46 TWUserMixHash (uint8_t *data, uint32_t length, uint32_t initval, uint32_t (*mix) (uint32_t))64 TWUserMixHash (uint8_t *data, uint32_t length, uint32_t key, void * mixer_data) 47 65 { 48 uint8_t *k = data; 49 uint32_t len = length; 50 uint32_t key = initval; 66 uint8_t *k = data; 67 uint32_t len = length; 68 C_word mixer = (C_word) ((C_SCHEME_BLOCK *) (((char *) mixer_data) - sizeof (C_header))); 69 70 if (C_header_bits (mixer) != C_CLOSURE_TYPE) { 71 C_printf ("Error: (TWUserMixHash) invalid mix procedure: not a closure"); 72 return 0; 73 } 51 74 52 75 if (data == NULL) return 0; 53 76 54 55 56 57 mix(key);58 59 60 61 62 63 64 mix(key);65 66 67 68 77 if (((uint32_t) k) & 3) { 78 while (len >= 4) { /* unaligned */ 79 key += (k[0] + (((uint32_t) k[1]) << 8) + (((uint32_t) k[2]) << 16) + (((uint32_t) k[3]) << 24)); 80 MIXER (key); 81 k += 4; 82 len -= 4; 83 } 84 } else { 85 while (len >= 4) { /* aligned */ 86 key += *((uint32_t *) (k + 0)); 87 MIXER (key); 88 k += 4; 89 len -= 4; 90 } 91 } 69 92 70 71 72 73 74 75 76 77 mix(key);93 switch (len) { 94 /* all the case statements fall through */ 95 case 3 : key += (((uint32_t) k[2]) << 16); 96 case 2 : key += (((uint32_t) k[1]) << 8); 97 case 1 : key += k[0]; 98 /* case 0: nothing left to add */ 99 } 100 MIXER (key); 78 101 79 102 return key; 80 103 } 81 104 #endif … … 87 110 88 111 (define foreign-TWUserMixHash 89 (foreign- lambda unsigned-integer32 "TWUserMixHash"90 91 unsigned-integer3292 (function unsigned-integer32 (unsigned-integer32) "")))112 (foreign-safe-lambda unsigned-integer32 113 "TWUserMixHash" scheme-pointer unsigned-integer32 114 unsigned-integer32 115 nonnull-scheme-pointer)) -
release/3/hashes/trunk/TWUserMixHash.scm
r8148 r8297 3 3 4 4 (use srfi-12) 5 (use TWUserMixHash-support hashes-support) 6 (use mathh-int message-digest) 5 (use TWUserMixHash-support hash-utils) 7 6 8 7 (declare … … 13 12 (export 14 13 make-TWUserMixHash-primitive-procedure 15 make-TWUserMixHash-procedure16 make-TWUserMixHash-message-digest-procedures17 14 make-TWUserMixHash ) ) 18 15 … … 21 18 (define-inline (check-procedure loc obj) 22 19 (##sys#check-closure obj loc) ) 23 24 ;;;25 26 ;; (define-external (mix_callback (unsigned-integer32 key)) unsigned-integer32 ... mix key ...)27 28 ;; Takes 1 argument:29 ;; mix-procedure30 ;;31 ;; Returns 1 value:32 ;; foreign-mix-procedure33 34 (define *last-exception* #f)35 36 (define (run-safe thunk errdef)37 (set! *last-exception* #f)38 (handle-exceptions ex39 (begin (set! *last-exception* ex) errdef)40 (thunk) ) )41 42 (define-macro (make-foreign-callback-mix-procedure ?mix-proc)43 `(##core#foreign-callback-wrapper44 ',(symbol->string (gensym 'foreign_callback_mix_))45 '""46 'unsigned-integer32 '(unsigned-integer32)47 (lambda (key)48 #;(,?mix-proc key)49 (run-safe (lambda () (,?mix-proc key)) 0))) )50 51 ;; Takes 1 argument:52 ;; hash-primitive-procedure53 ;;54 ;; Returns 1 value:55 ;; hash-update-procedure56 ;; ((c-pointer "ctx") scheme-object unsigned-integer32 -> void)57 58 (define (make-TWUserMixHash-update-procedure prim-proc)59 (check-procedure 'make-TWUserMixHash-update-procedure prim-proc)60 (lambda (ctx data length)61 (hashes:ctx-hash-set! ctx (prim-proc data length (hashes:ctx-hash-ref ctx))) ) )62 20 63 21 ;;; … … 80 38 ;; hash-primitive-procedure 81 39 82 (define (make-TWUserMixHash-primitive-procedure mix-proc )40 (define (make-TWUserMixHash-primitive-procedure mix-proc #!optional unsafe?) 83 41 (check-procedure 'make-TWUserMixHash-primitive-procedure mix-proc) 84 (let ([foreign-callback-mix (make-foreign-callback-mix-procedure mix-proc)]) 85 (lambda (data length initval) 86 (let ([key (foreign-TWUserMixHash data length initval foreign-callback-mix)]) 87 (if *last-exception* 88 (abort *last-exception*) 89 key ) ) ) ) ) 90 91 ;; Takes 2 arguments - 1 required & 1 optional: 92 ;; hash-primitive-procedure 93 ;; length-procedure 94 ;; 95 ;; Returns 1 value: 96 ;; hash-procedure 97 98 (define (make-TWUserMixHash-procedure prim-proc #!optional [byte-length string-length]) 99 (check-procedure 'make-TWUserMixHash-procedure prim-proc) 100 (lambda (data . args) 101 (let-optionals args ([length (byte-length data)] [initval 0]) 102 (prim-proc data length initval)) ) ) 103 104 ;; Takes 1 argument: 105 ;; hash-primitive-procedure 106 ;; 107 ;; Returns a 3 element list: 108 ;; binary-message-digest 109 ;; message-digest 110 ;; message-digest-primitive 111 112 (define (make-TWUserMixHash-message-digest-procedures prim-proc) 113 (check-procedure 'make-TWUserMixHash-message-digest-procedures prim-proc) 114 (let ([updt-proc (make-TWUserMixHash-update-procedure prim-proc)]) 115 (list 116 (lambda (obj) 117 (make-binary-message-digest obj 118 hashes:hash-context-size unsigned-integer32-size 119 hashes:generic-init updt-proc hashes:generic-final 120 (gensym 'TWUserMixHash:binary-digest_))) 121 (lambda (obj) 122 (make-message-digest obj 123 hashes:hash-context-size unsigned-integer32-size 124 hashes:generic-init updt-proc hashes:generic-final 125 (gensym 'TWUserMixHash:digest_))) 126 (lambda (obj) 127 (make-message-digest-primitive 128 hashes:hash-context-size unsigned-integer32-size 129 hashes:generic-init updt-proc hashes:generic-final 130 (gensym 'TWUserMixHash:primitive_)))) ) ) 42 (if unsafe? 43 (cut foreign-TWUserMixHash <> <> <> mix-proc) 44 (let* ([*last-exception* #f] 45 [mixer (lambda (key) 46 (handle-exceptions ex 47 (begin (set! *last-exception* ex) 0) 48 (set! *last-exception* #f) 49 (mix-proc key) ) ) ] ) 50 (lambda (data length initval) 51 (let ([key (foreign-TWUserMixHash data length initval mixer)]) 52 (if *last-exception* 53 (abort *last-exception*) 54 key ) ) ) ) ) ) 131 55 132 56 ;; Takes 1 argument: … … 140 64 ;; message-digest-primitive 141 65 142 (define (make-TWUserMixHash mixer) 143 (let ([prim-proc (make-TWUserMixHash-primitive-procedure mixer)]) 66 (define (make-TWUserMixHash mix-proc #!optional unsafe?) 67 (check-procedure 'make-TWUserMixHash mix-proc) 68 (let ([prim-proc (make-TWUserMixHash-primitive-procedure mix-proc unsafe?)]) 144 69 (apply values prim-proc 145 (make- TWUserMixHash-procedure prim-proc)146 (make- TWUserMixHash-message-digest-procedures prim-proc)) ) )70 (make-hash-procedure prim-proc) 71 (make-hash-message-digest-procedures prim-proc)) ) ) -
release/3/hashes/trunk/hash-utils.scm
r8148 r8297 10 10 ;; on 32-bit boundary! 11 11 12 (use lolevel)13 12 (use message-digest miscmacros mathh-int misc-extn-control) 13 (use hashes-support) 14 14 15 15 (declare … … 24 24 ##sys#check-closure ) 25 25 (export 26 ;; Deprecated27 string-binary-unsigned-int32-set!28 string-binary->unsigned-int3229 ;;30 26 current-hash-seed 31 27 make-range-restriction … … 37 33 make-fixnum-bounded-hash 38 34 make-real-hash 39 unsigned-integer32-ref40 unsigned-integer32-set!) )35 make-hash-procedure 36 make-hash-message-digest-procedures ) ) 41 37 42 38 #> … … 45 41 #undef bitsizeof 46 42 <# 43 44 (include "hashes-macros") 47 45 48 46 ;;; … … 84 82 85 83 (define-parameter current-hash-seed 86 084 DEFAULT-HASH-SEED 87 85 (lambda (v) 88 (cond [(number? v) (abs v)] 89 [(not v) 0] 90 [else 91 (warning "invalid hash-seed" v) 92 (current-hash-seed)] ) ) ) 93 94 ;;; Utilities 95 96 (define uint32-cptr-ref 97 (foreign-lambda* unsigned-integer32 ((c-pointer dat)) 98 "return (*((uint32_t *) dat));")) 99 100 (define uint32-cptr-set! 101 (foreign-lambda* void ((c-pointer dat) (unsigned-integer32 w32)) 102 "*((uint32_t *) dat) = (uint32_t) w32;")) 103 104 (define uint32-sptr-ref 105 (foreign-lambda* unsigned-integer32 ((scheme-pointer dat)) 106 "return (*((uint32_t *) dat));")) 107 108 (define uint32-sptr-set! 109 (foreign-lambda* void ((scheme-pointer dat) (unsigned-integer32 w32)) 110 "*((uint32_t *) dat) = (uint32_t) w32;")) 111 112 (define-inline (ptr-prc-for-obj obj cptr-proc sptr-proc) 113 (if (or (pointer? obj) (locative? obj)) 114 cptr-proc 115 sptr-proc ) ) 116 117 (define (unsigned-integer32-set! obj num) 118 ((ptr-prc-for-obj obj uint32-cptr-set! uint32-sptr-set!) obj num) ) 119 120 (define (unsigned-integer32-ref obj) 121 ((ptr-prc-for-obj obj uint32-cptr-ref uint32-sptr-ref) obj) ) 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)) 122 94 123 95 ;;; Range restrictions … … 199 171 ;;; 200 172 201 (define string-binary-unsigned-int32-set! unsigned-integer32-ref) 202 (define string-binary->unsigned-int32 unsigned-integer32-set!) 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-")))) ) ) -
release/3/hashes/trunk/hashes-eggdoc.scm
r8148 r8297 162 162 ) 163 163 164 #; ;TWUserMixHash DOESN'T WORK165 164 (subsection "TWUserMixHash Procedures" 166 165 167 (p "Thomas Wang's hash function with a user supplied MIX.") 168 169 (procedure "(make-TWUserMixHash-primitive-procedure MIXER)" 166 (p "Thomas Wang's hash function with a user supplied MIX procedure.") 167 168 (procedure "(make-TWUserMixHash-primitive-procedure MIXER [UNSAFE #f])" 169 170 170 (p "Returns a hash primitive procedure, " 171 171 (code "(scheme-object unsigned-integer32 unsigned-integer32 -> unsigned-integer32)") ", " 172 172 "for the procedure " (tt "MIX") ", " 173 (code "(unsigned-integer32 -> unsigned-integer32)") ".") ) 174 175 (procedure "(make-TWUserMixHash-procedure HASH-PRIM [BYTE-LENGTH string-length])" 176 (p "Returns a hash procedure, " 177 (code "(scheme-object #!optional unsigned-integer32 unsigned-integer32 -> unsigned-integer32)") ", " 178 "for the hash primitive procedure " (tt "HASH-PRIM") ".") ) 179 180 (procedure "(make-TWUserMixHash-message-digest-procedures HASH-PRIM)" 181 (p "Returns a list of " (code ":binary-digest") ", " (code ":digest") ", and " 182 (code ":primitive") "for the hash primitive procedure " (tt "HASH-PRIM") ".") ) 183 184 (procedure "(make-TWUserMixHash MIXER)" 173 (code "(unsigned-integer32 -> unsigned-integer32)") ".") 174 175 (p "When " (tt "UNSAFE") " no exception checking is performed.") ) 176 177 (procedure "(make-TWUserMixHash MIXER [UNSAFE #f])" 185 178 (p "Returns 5 values: " (tt "HASH-PRIM") ", " (tt "HASH") ", " 186 179 (code ":binary-digest") ", " (code ":digest") ", and " (code ":primitive") ".") ) … … 244 237 "restricted to the interval, [0.0 1.0]. The signature is that " 245 238 "of the " (tt "{HASH}") ".")) 239 240 (procedure "(make-hash-procedure HASH-PRIM [BYTE-LENGTH string-length])" 241 (p "Returns a hash procedure, " 242 (code "(scheme-object #!optional unsigned-integer32 unsigned-integer32 -> unsigned-integer32)") ", " 243 "for the hash primitive procedure " (tt "HASH-PRIM") ".") ) 244 245 (procedure "(make-hash-message-digest-procedures HASH-PRIM)" 246 (p "Returns a list of " (code ":binary-digest") ", " (code ":digest") ", and " 247 (code ":primitive") "for the hash primitive procedure " (tt "HASH-PRIM") ".") ) 246 248 ) 247 249 … … 271 273 (p "Sets the first 32-bits of " (tt "STRING") " to " (tt "NUMBER") ".")) 272 274 ) 275 276 (subsection "Hash Search" 277 278 (usage "rabin-karp") 279 280 (procedure "(make-rabin-karp-string-search SUBSTRINGS [TEST [HASH]])" 281 (p "Returns a procedure of one argument, the search string, and two " 282 "optional arguments, the start and end positions within the string. " 283 "The search procedure returns a list of the matched substring and a list of the " 284 "start and end positions of the match in the search string. Returns " 285 (code "#f") " when no match found. Similar to the " (tt "regex unit") " " 286 (code "string-match") " procedure.") 287 288 (p (tt "SUBSTRINGS") " is a list of strings. " (tt "TEST") " is an " 289 "equivalence procedure. " (tt "HASH") " is a SRFI-69 compliant hash " 290 "procedure.") ) 291 ) 273 292 ) 274 293 275 294 (history 295 (version "2.2" "Added Rabin-Karp string hash search, TWUserMixHash.") 276 296 (version "2.105" "Added TWSHMXHash, TWSHMLMXHash, TWMGMXHash.") 277 297 (version "2.104" "Added make-fixnum-bounded-hash.") -
release/3/hashes/trunk/hashes-macros.scm
r8148 r8297 51 51 hashes:generic-init ,UN hashes:generic-final 52 52 ',PN)) ) ) ) 53 54 (define-constant DEFAULT-HASH-SEED 0) -
release/3/hashes/trunk/hashes-support.scm
r8148 r8297 19 19 ;; - Better initval handling, what ever that means. 20 20 21 (use hash-utils)22 23 21 (declare 22 (uses lolevel) 24 23 (usual-integrations) 25 24 (inline) 25 (generic) 26 26 (disable-interrupts) 27 27 (no-procedure-checks) … … 29 29 (no-bound-checks) 30 30 (export 31 hs$hash-seed 32 unsigned-integer32-set! 33 unsigned-integer32-ref 31 34 hashes:hash-context-size 32 35 hashes:ctx-hash-ref … … 41 44 <# 42 45 46 (include "hashes-macros") 47 43 48 ;;; 49 50 (define uint32-cptr-ref 51 (foreign-lambda* unsigned-integer32 ((c-pointer dat)) 52 "return (*((uint32_t *) dat));")) 53 54 (define uint32-cptr-set! 55 (foreign-lambda* void ((c-pointer dat) (unsigned-integer32 w32)) 56 "*((uint32_t *) dat) = (uint32_t) w32;")) 57 58 (define uint32-sptr-ref 59 (foreign-lambda* unsigned-integer32 ((scheme-pointer dat)) 60 "return (*((uint32_t *) dat));")) 61 62 (define uint32-sptr-set! 63 (foreign-lambda* void ((scheme-pointer dat) (unsigned-integer32 w32)) 64 "*((uint32_t *) dat) = (uint32_t) w32;")) 65 66 (define-inline (ptr-prc-for-obj obj cptr-proc sptr-proc) 67 (if (or (pointer? obj) (locative? obj)) 68 cptr-proc 69 sptr-proc ) ) 70 71 ;;; 72 73 (define hs$hash-seed DEFAULT-HASH-SEED) 74 75 ;;; 76 77 (define (unsigned-integer32-set! obj num) 78 ((ptr-prc-for-obj obj uint32-cptr-set! uint32-sptr-set!) obj num) ) 79 80 (define (unsigned-integer32-ref obj) 81 ((ptr-prc-for-obj obj uint32-cptr-ref uint32-sptr-ref) obj) ) 44 82 45 83 (define hashes:hash-context-size (foreign-value "sizeof (hashctx)" int)) … … 60 98 61 99 (define (hashes:generic-init ctx) 62 (hashes:ctx-hash-set! ctx (current-hash-seed)) )100 (hashes:ctx-hash-set! ctx hs$hash-seed) ) 63 101 64 102 ;; -
release/3/hashes/trunk/hashes.html
r8148 r8297 274 274 <p>The ISpell hash function.</p></td></tr></table></div> 275 275 <div class="subsection"> 276 <h4>TWUserMixHash Procedures</h4> 277 <p>Thomas Wang's hash function with a user supplied MIX procedure.</p> 278 <dt class="definition"><strong>procedure:</strong> (make-TWUserMixHash-primitive-procedure MIXER [UNSAFE #f])</dt> 279 <dd> 280 <p>Returns a hash primitive procedure, <code>(scheme-object unsigned-integer32 unsigned-integer32 -> unsigned-integer32)</code>, for the procedure <tt>MIX</tt>, <code>(unsigned-integer32 -> unsigned-integer32)</code>.</p> 281 <p>When <tt>UNSAFE</tt> no exception checking is performed.</p></dd> 282 <dt class="definition"><strong>procedure:</strong> (make-TWUserMixHash MIXER [UNSAFE #f])</dt> 283 <dd> 284 <p>Returns 5 values: <tt>HASH-PRIM</tt>, <tt>HASH</tt>, <code>:binary-digest</code>, <code>:digest</code>, and <code>:primitive</code>.</p></dd></div> 285 <div class="subsection"> 276 286 <h4>Digest Procedures</h4> 277 287 <p>An acceptable input object for the digest procedures is a string, input-port, blob, vector, list, or homogeneous-vector. See <a href="http://www.call-with-current-continuation.org/eggs/message-digest.html">message-digest</a> for more information.</p> … … 308 318 <dt class="definition"><strong>procedure:</strong> (make-real-hash {HASH})</dt> 309 319 <dd> 310 <p>Returns a <tt>{HASH}</tt> with the hash value restricted to the interval, [0.0 1.0]. The signature is that of the <tt>{HASH}</tt>.</p></dd></div> 320 <p>Returns a <tt>{HASH}</tt> with the hash value restricted to the interval, [0.0 1.0]. The signature is that of the <tt>{HASH}</tt>.</p></dd> 321 <dt class="definition"><strong>procedure:</strong> (make-hash-procedure HASH-PRIM [BYTE-LENGTH string-length])</dt> 322 <dd> 323 <p>Returns a hash procedure, <code>(scheme-object #!optional unsigned-integer32 unsigned-integer32 -> unsigned-integer32)</code>, for the hash primitive procedure <tt>HASH-PRIM</tt>.</p></dd> 324 <dt class="definition"><strong>procedure:</strong> (make-hash-message-digest-procedures HASH-PRIM)</dt> 325 <dd> 326 <p>Returns a list of <code>:binary-digest</code>, <code>:digest</code>, and <code>:primitive</code>for the hash primitive procedure <tt>HASH-PRIM</tt>.</p></dd></div> 311 327 <div class="subsection"> 312 328 <h4>Range Procedures</h4> … … 327 343 <dt class="definition"><strong>procedure:</strong> (unsigned-integer32-set! OBJECT NUMBER)</dt> 328 344 <dd> 329 <p>Sets the first 32-bits of <tt>STRING</tt> to <tt>NUMBER</tt>.</p></dd></div></div> 345 <p>Sets the first 32-bits of <tt>STRING</tt> to <tt>NUMBER</tt>.</p></dd></div> 346 <div class="subsection"> 347 <h4>Hash Search</h4> 348 <div class="section"> 349 <h3>Usage</h3>rabin-karp</div> 350 <dt class="definition"><strong>procedure:</strong> (make-rabin-karp-string-search SUBSTRINGS [TEST [HASH]])</dt> 351 <dd> 352 <p>Returns a procedure of one argument, the search string, and two optional arguments, the start and end positions within the string. The search procedure returns a list of the matched substring and a list of the start and end positions of the match in the search string. Returns <code>#f</code> when no match found. Similar to the <tt>regex unit</tt> <code>string-match</code> procedure.</p> 353 <p><tt>SUBSTRINGS</tt> is a list of strings. <tt>TEST</tt> is an equivalence procedure. <tt>HASH</tt> is a SRFI-69 compliant hash procedure.</p></dd></div></div> 330 354 <div class="section"> 331 355 <h3>Version</h3> 332 356 <ul> 357 <li>2.106 Added Rabin-Karp string hash search, TWUserMixHash.</li> 333 358 <li>2.105 Added TWSHMXHash, TWSHMLMXHash, TWMGMXHash.</li> 334 359 <li>2.104 Added make-fixnum-bounded-hash.</li> -
release/3/hashes/trunk/hashes.meta
r8148 r8297 5 5 (license "BSD") 6 6 (category crypt) 7 (needs misc-extn miscmacros mathh message-digest box crc )7 (needs misc-extn miscmacros mathh message-digest box crc iset) 8 8 (author "Kon Lovett") 9 9 (egg "hashes.egg") … … 36 36 "CRCHash.scm" 37 37 "hashes.scm" 38 "rabin-karp.scm" 38 39 "hashes.h" 39 40 "hash-utils.scm" -
release/3/hashes/trunk/hashes.scm
r8148 r8297 6 6 RJMXHash 7 7 TWMXHash TWSHMXHash TWSHMLMXHash TWMGMXHash 8 #; ;TWUserMixHash DOESN'T WORK9 8 TWUserMixHash 10 9 FNVHash FNVAHash -
release/3/hashes/trunk/hashes.setup
r8148 r8297 2 2 3 3 (required-extension-version 4 'iset "1.4" 4 5 'crc "1.1" 6 'box "1.8" 5 7 'mathh "1.9" 6 8 'misc-extn "3.002" … … 8 10 'miscmacros "2.4") 9 11 10 (install-dynld hash-utils *version*)11 12 12 (install-dynld hashes-support *version* -O3 -d0) 13 13 14 #| TWUserMixHash DOESN'T WORK 15 (install-dynld TWUserMixHash-support *version*) 16 (install-dynld TWUserMixHash *version*) 17 |# 14 (install-dynld hash-utils *version* (documentation "hashes.html")) 18 15 19 (install-dynld RJMXHash *version*) 20 (install-dynld TWMXHash *version*) 21 (install-dynld TWMGMXHash *version*) 22 (install-dynld TWSHMXHash *version*) 23 (install-dynld TWSHMLMXHash *version*) 24 (install-dynld FNVHash *version*) 25 (install-dynld FNVAHash *version*) 26 (install-dynld PHSFHash *version*) 27 (install-dynld RSHash *version*) 28 (install-dynld JSHash *version*) 29 (install-dynld PJWHash *version*) 30 (install-dynld ELFHash *version*) 31 (install-dynld BKDRHash *version*) 32 (install-dynld SDBMHash *version*) 33 (install-dynld DJBHash *version*) 34 (install-dynld NDJBHash *version*) 35 (install-dynld DEKHash *version*) 36 (install-dynld APHash *version*) 37 (install-dynld BRPHash *version*) 38 (install-dynld PYHash *version*) 39 (install-dynld RJL3Hash *version*) 40 (install-dynld ISPLHash *version*) 41 (install-dynld CRCHash *version*) 16 (install-dynld RJMXHash *version* (documentation "hashes.html")) 17 (install-dynld TWMXHash *version* (documentation "hashes.html")) 18 (install-dynld TWMGMXHash *version* (documentation "hashes.html")) 19 (install-dynld TWSHMXHash *version* (documentation "hashes.html")) 20 (install-dynld TWSHMLMXHash *version* (documentation "hashes.html")) 21 (install-dynld FNVHash *version* (documentation "hashes.html")) 22 (install-dynld FNVAHash *version* (documentation "hashes.html")) 23 (install-dynld PHSFHash *version* (documentation "hashes.html")) 24 (install-dynld RSHash *version* (documentation "hashes.html")) 25 (install-dynld JSHash *version* (documentation "hashes.html")) 26 (install-dynld PJWHash *version* (documentation "hashes.html")) 27 (install-dynld ELFHash *version* (documentation "hashes.html")) 28 (install-dynld BKDRHash *version* (documentation "hashes.html")) 29 (install-dynld SDBMHash *version* (documentation "hashes.html")) 30 (install-dynld DJBHash *version* (documentation "hashes.html")) 31 (install-dynld NDJBHash *version* (documentation "hashes.html")) 32 (install-dynld DEKHash *version* (documentation "hashes.html")) 33 (install-dynld APHash *version* (documentation "hashes.html")) 34 (install-dynld BRPHash *version* (documentation "hashes.html")) 35 (install-dynld PYHash *version* (documentation "hashes.html")) 36 (install-dynld RJL3Hash *version* (documentation "hashes.html")) 37 (install-dynld ISPLHash *version* (documentation "hashes.html")) 38 (install-dynld CRCHash *version* (documentation "hashes.html")) 39 40 (install-dynld TWUserMixHash-support *version* -O3 -d0) 41 (install-dynld TWUserMixHash *version* (documentation "hashes.html")) 42 42 43 43 (install-dynld+docu hashes *version*) 44 44 45 (install-dynld rabin-karp *version* (documentation "hashes.html")) 46 45 47 (install-test "hashes-test.scm") -
release/3/hashes/trunk/tests/hashes-test.scm
r8148 r8297 3 3 (use testbase testbase-output-human) 4 4 (use hashes) 5 (use rabin-karp) 5 6 6 7 ;;; … … 165 166 ) 166 167 167 #; ;TWUserMixHash DOESN'T WORK 168 (define-test rabin-karp-test "Rabin-Karp Search" 169 (initial 170 (define substrs '("quick" "foo" "brown" "dog" "skasfdskjsalksafnsalsfsdsdjkldsajlfsalsk")) 171 (define hashp) 172 (define rksp) ) 173 174 (expect-set! hashp (make-fixnum-bounded-hash RJL3Hash-prim)) 175 (expect-set! rksp (make-rabin-karp-string-search substrs string=? hashp)) 176 (expect-success "Without start & end" (rksp TSTSTR)) 177 (expect-success "With start & end" (rksp TSTSTR 41 TSTSTR-LEN)) 178 ) 179 168 180 (define-test hashes-utils-test "TWUserMixHash" 169 181 (initial 170 (define (mix key) 171 key) 182 (define (mix key) key) 172 183 (define usrmixhsh) 173 184 (define hash-prim) … … 177 188 (define prim:digest) ) 178 189 179 (expect-set! "TWUserMixHash Make" usrmixhsh (receive (make-TWUserMixHash mix )))190 (expect-set! "TWUserMixHash Make" usrmixhsh (receive (make-TWUserMixHash mix #t))) 180 191 (side-effect 181 192 (set! hash-prim (car usrmixhsh))
Note: See TracChangeset
for help on using the changeset viewer.