Changeset 8297 in project


Ignore:
Timestamp:
02/09/08 02:11:46 (13 years ago)
Author:
Kon Lovett
Message:

Added rabin-karp, TW user mix hash.

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  
    66;; - CRC hash accumulation technique is questionable.
    77
    8 (use message-digest box crc hash-utils mathh-int)
     8(use message-digest box crc hash-utils mathh-int hashes-support)
    99
    1010(declare

  • release/3/hashes/tags/2.2/TWUserMixHash-support.scm

    r8148 r8297  
    77  (disable-interrupts)
    88  (no-procedure-checks)
     9  (no-argc-checks)
    910  (no-bound-checks)
    1011  (export
    1112    foreign-TWUserMixHash ) )
    1213
     14;;;
     15
    1316#>
    1417#include "hashes.h"
    1518
     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
    1629#ifdef C_BIG_ENDIAN
    1730static uint32_t
    18 TWUserMixHash (uint8_t *data, uint32_t length, uint32_t initval, uint32_t (*mix) (uint32_t))
     31TWUserMixHash (uint8_t *data, uint32_t length, uint32_t key, void * mixer_data)
    1932{
    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  }
    2341
    2442  if (data == NULL) return 0;
    2543
    26    while (len >= 4) {
    27       key += (k[0] + (((uint32_t) k[1]) << 8) + (((uint32_t) k[2]) << 16) + (((uint32_t) k[3]) << 24));
    28       mix (key);
    29       k += 4;
    30       len -= 4;
    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  }
    3250
    33    switch (len) {
    34      /* all the case statements fall through */
    35    case 3 : key += (((uint32_t) k[2]) << 16);
    36    case 2 : key += (((uint32_t) k[1]) << 8);
    37    case 1 : key += k[0];
    38      /* case 0: nothing left to add */
    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);
    4159
    42    return key;
     60  return key;
    4361}
    4462#else
    4563static uint32_t
    46 TWUserMixHash (uint8_t *data, uint32_t length, uint32_t initval, uint32_t (*mix) (uint32_t))
     64TWUserMixHash (uint8_t *data, uint32_t length, uint32_t key, void * mixer_data)
    4765{
    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  }
    5174
    5275  if (data == NULL) return 0;
    5376
    54    if (((uint32_t) k) & 3) {
    55       while (len >= 4) {  /* unaligned */
    56         key += (k[0] + (((uint32_t) k[1]) << 8) + (((uint32_t) k[2]) << 16) + (((uint32_t) k[3]) << 24));
    57         mix (key);
    58         k += 4;
    59         len -= 4;
    60       }
    61    } else {
    62       while (len >= 4) {  /* aligned */
    63         key += *((uint32_t *) (k + 0));
    64         mix (key);
    65         k += 4;
    66         len -= 4;
    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  }
    6992
    70    switch (len) {
    71      /* all the case statements fall through */
    72    case 3 : key += (((uint32_t) k[2]) << 16);
    73    case 2 : key += (((uint32_t) k[1]) << 8);
    74    case 1 : key += k[0];
    75      /* case 0: nothing left to add */
    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);
    78101
    79    return key;
     102  return key;
    80103}
    81104#endif
    … …  
    87110
    88111(define foreign-TWUserMixHash
    89   (foreign-lambda unsigned-integer32 "TWUserMixHash"
    90                                      scheme-pointer unsigned-integer32
    91                                      unsigned-integer32
    92                                      (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  
    33
    44(use srfi-12)
    5 (use TWUserMixHash-support hashes-support)
    6 (use mathh-int message-digest)
     5(use TWUserMixHash-support hash-utils)
    76
    87(declare
    … …  
    1312  (export
    1413    make-TWUserMixHash-primitive-procedure
    15     make-TWUserMixHash-procedure
    16     make-TWUserMixHash-message-digest-procedures
    1714    make-TWUserMixHash ) )
    1815
    … …  
    2118(define-inline (check-procedure loc obj)
    2219  (##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-procedure
    30 ;;
    31 ;; Returns 1 value:
    32 ;; foreign-mix-procedure
    33 
    34 (define *last-exception* #f)
    35 
    36 (define (run-safe thunk errdef)
    37   (set! *last-exception* #f)
    38   (handle-exceptions ex
    39       (begin (set! *last-exception* ex) errdef)
    40     (thunk) ) )
    41 
    42 (define-macro (make-foreign-callback-mix-procedure ?mix-proc)
    43   `(##core#foreign-callback-wrapper
    44     ',(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-procedure
    53 ;;
    54 ;; Returns 1 value:
    55 ;; hash-update-procedure
    56 ;; ((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))) ) )
    6220
    6321;;;
    … …  
    8038;; hash-primitive-procedure
    8139
    82 (define (make-TWUserMixHash-primitive-procedure mix-proc)
     40(define (make-TWUserMixHash-primitive-procedure mix-proc #!optional unsafe?)
    8341  (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 ) ) ) ) ) )
    13155
    13256;; Takes 1 argument:
    … …  
    14064;; message-digest-primitive
    14165
    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?)])
    14469      (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  
    1010;; on 32-bit boundary!
    1111
    12 (use lolevel)
    1312(use message-digest miscmacros mathh-int misc-extn-control)
     13(use hashes-support)
    1414
    1515(declare
    … …  
    2424    ##sys#check-closure )
    2525  (export
    26     ;; Deprecated
    27     string-binary-unsigned-int32-set!
    28     string-binary->unsigned-int32
    29     ;;
    3026    current-hash-seed
    3127    make-range-restriction
    … …  
    3733    make-fixnum-bounded-hash
    3834    make-real-hash
    39     unsigned-integer32-ref
    40     unsigned-integer32-set!) )
     35    make-hash-procedure
     36    make-hash-message-digest-procedures ) )
    4137
    4238#>
    … …  
    4541#undef bitsizeof
    4642<#
     43
     44(include "hashes-macros")
    4745
    4846;;;
    … …  
    8482
    8583(define-parameter current-hash-seed
    86   0
     84  DEFAULT-HASH-SEED
    8785        (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))
    12294
    12395;;; Range restrictions
    … …  
    199171;;;
    200172
    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  
    162162                        )
    163163
    164       #; ;TWUserMixHash DOESN'T WORK
    165164                        (subsection "TWUserMixHash Procedures"
    166165
    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
    170170          (p "Returns a hash primitive procedure, "
    171171          (code "(scheme-object unsigned-integer32 unsigned-integer32 -> unsigned-integer32)") ", "
    172172          "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])"
    185178          (p "Returns 5 values: " (tt "HASH-PRIM") ", " (tt "HASH") ", "
    186179          (code ":binary-digest") ", " (code ":digest") ", and " (code ":primitive") ".") )
    … …  
    244237                                        "restricted to the interval, [0.0 1.0]. The signature is that "
    245238                                        "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") ".") )
    246248                        )
    247249
    … …  
    271273                                        (p "Sets the first 32-bits of " (tt "STRING") " to " (tt "NUMBER") "."))
    272274                        )
     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                        )
    273292                )
    274293
    275294  (history
     295    (version "2.2" "Added Rabin-Karp string hash search, TWUserMixHash.")
    276296    (version "2.105" "Added TWSHMXHash, TWSHMLMXHash, TWMGMXHash.")
    277297    (version "2.104" "Added make-fixnum-bounded-hash.")

  • release/3/hashes/tags/2.2/hashes-macros.scm

    r8148 r8297  
    5151           hashes:generic-init ,UN hashes:generic-final
    5252           ',PN)) ) ) )
     53
     54(define-constant DEFAULT-HASH-SEED 0)

  • release/3/hashes/tags/2.2/hashes-support.scm

    r8148 r8297  
    1919;; - Better initval handling, what ever that means.
    2020
    21 (use hash-utils)
    22 
    2321(declare
     22  (uses lolevel)
    2423  (usual-integrations)
    2524  (inline)
     25  (generic)
    2626  (disable-interrupts)
    2727  (no-procedure-checks)
    … …  
    2929  (no-bound-checks)
    3030  (export
     31    hs$hash-seed
     32    unsigned-integer32-set!
     33    unsigned-integer32-ref
    3134    hashes:hash-context-size
    3235    hashes:ctx-hash-ref
    … …  
    4144<#
    4245
     46(include "hashes-macros")
     47
    4348;;;
     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) )
    4482
    4583(define hashes:hash-context-size (foreign-value "sizeof (hashctx)" int))
    … …  
    6098
    6199(define (hashes:generic-init ctx)
    62         (hashes:ctx-hash-set! ctx (current-hash-seed)) )
     100        (hashes:ctx-hash-set! ctx hs$hash-seed) )
    63101
    64102;;

  • release/3/hashes/tags/2.2/hashes.html

    r8148 r8297  
    274274<p>The ISpell hash function.</p></td></tr></table></div>
    275275<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 -&gt; unsigned-integer32)</code>, for the procedure <tt>MIX</tt>, <code>(unsigned-integer32 -&gt; 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">
    276286<h4>Digest Procedures</h4>
    277287<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>
    … …  
    308318<dt class="definition"><strong>procedure:</strong> (make-real-hash {HASH})</dt>
    309319<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 -&gt; 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>
    311327<div class="subsection">
    312328<h4>Range Procedures</h4>
    … …  
    327343<dt class="definition"><strong>procedure:</strong> (unsigned-integer32-set! OBJECT NUMBER)</dt>
    328344<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>
    330354<div class="section">
    331355<h3>Version</h3>
    332356<ul>
     357<li>2.106 Added Rabin-Karp string hash search, TWUserMixHash.</li>
    333358<li>2.105 Added TWSHMXHash, TWSHMLMXHash, TWMGMXHash.</li>
    334359<li>2.104 Added make-fixnum-bounded-hash.</li>

  • release/3/hashes/tags/2.2/hashes.meta

    r8148 r8297  
    55 (license "BSD")
    66 (category crypt)
    7  (needs misc-extn miscmacros mathh message-digest box crc)
     7 (needs misc-extn miscmacros mathh message-digest box crc iset)
    88 (author "Kon Lovett")
    99 (egg "hashes.egg")
    … …  
    3636        "CRCHash.scm"
    3737        "hashes.scm"
     38        "rabin-karp.scm"
    3839        "hashes.h"
    3940        "hash-utils.scm"

  • release/3/hashes/tags/2.2/hashes.scm

    r8148 r8297  
    66        RJMXHash
    77        TWMXHash TWSHMXHash TWSHMLMXHash TWMGMXHash
    8         #; ;TWUserMixHash DOESN'T WORK
    98        TWUserMixHash
    109        FNVHash FNVAHash

  • release/3/hashes/tags/2.2/hashes.setup

    r8148 r8297  
    22
    33(required-extension-version
     4  'iset                   "1.4"
    45  'crc                    "1.1"
     6  'box                    "1.8"
    57  'mathh                  "1.9"
    68  'misc-extn              "3.002"
    … …  
    810  'miscmacros             "2.4")
    911
    10 (install-dynld hash-utils *version*)
    11 
    1212(install-dynld hashes-support *version* -O3 -d0)
    1313
    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"))
    1815
    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"))
    4242
    4343(install-dynld+docu hashes *version*)
    4444
     45(install-dynld rabin-karp *version* (documentation "hashes.html"))
     46
    4547(install-test "hashes-test.scm")

  • release/3/hashes/tags/2.2/tests/hashes-test.scm

    r8148 r8297  
    33(use testbase testbase-output-human)
    44(use hashes)
     5(use rabin-karp)
    56
    67;;;
    … …  
    165166)
    166167
    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
    168180(define-test hashes-utils-test "TWUserMixHash"
    169181  (initial
    170     (define (mix key)
    171       key)
     182    (define (mix key) key)
    172183    (define usrmixhsh)
    173184    (define hash-prim)
    … …  
    177188                (define prim:digest) )
    178189
    179     (expect-set! "TWUserMixHash Make" usrmixhsh (receive (make-TWUserMixHash mix)))
     190    (expect-set! "TWUserMixHash Make" usrmixhsh (receive (make-TWUserMixHash mix #t)))
    180191    (side-effect
    181192      (set! hash-prim (car usrmixhsh))

  • release/3/hashes/trunk/CRCHash.scm

    r8148 r8297  
    66;; - CRC hash accumulation technique is questionable.
    77
    8 (use message-digest box crc hash-utils mathh-int)
     8(use message-digest box crc hash-utils mathh-int hashes-support)
    99
    1010(declare

  • release/3/hashes/trunk/TWUserMixHash-support.scm

    r8148 r8297  
    77  (disable-interrupts)
    88  (no-procedure-checks)
     9  (no-argc-checks)
    910  (no-bound-checks)
    1011  (export
    1112    foreign-TWUserMixHash ) )
    1213
     14;;;
     15
    1316#>
    1417#include "hashes.h"
    1518
     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
    1629#ifdef C_BIG_ENDIAN
    1730static uint32_t
    18 TWUserMixHash (uint8_t *data, uint32_t length, uint32_t initval, uint32_t (*mix) (uint32_t))
     31TWUserMixHash (uint8_t *data, uint32_t length, uint32_t key, void * mixer_data)
    1932{
    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  }
    2341
    2442  if (data == NULL) return 0;
    2543
    26    while (len >= 4) {
    27       key += (k[0] + (((uint32_t) k[1]) << 8) + (((uint32_t) k[2]) << 16) + (((uint32_t) k[3]) << 24));
    28       mix (key);
    29       k += 4;
    30       len -= 4;
    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  }
    3250
    33    switch (len) {
    34      /* all the case statements fall through */
    35    case 3 : key += (((uint32_t) k[2]) << 16);
    36    case 2 : key += (((uint32_t) k[1]) << 8);
    37    case 1 : key += k[0];
    38      /* case 0: nothing left to add */
    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);
    4159
    42    return key;
     60  return key;
    4361}
    4462#else
    4563static uint32_t
    46 TWUserMixHash (uint8_t *data, uint32_t length, uint32_t initval, uint32_t (*mix) (uint32_t))
     64TWUserMixHash (uint8_t *data, uint32_t length, uint32_t key, void * mixer_data)
    4765{
    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  }
    5174
    5275  if (data == NULL) return 0;
    5376
    54    if (((uint32_t) k) & 3) {
    55       while (len >= 4) {  /* unaligned */
    56         key += (k[0] + (((uint32_t) k[1]) << 8) + (((uint32_t) k[2]) << 16) + (((uint32_t) k[3]) << 24));
    57         mix (key);
    58         k += 4;
    59         len -= 4;
    60       }
    61    } else {
    62       while (len >= 4) {  /* aligned */
    63         key += *((uint32_t *) (k + 0));
    64         mix (key);
    65         k += 4;
    66         len -= 4;
    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  }
    6992
    70    switch (len) {
    71      /* all the case statements fall through */
    72    case 3 : key += (((uint32_t) k[2]) << 16);
    73    case 2 : key += (((uint32_t) k[1]) << 8);
    74    case 1 : key += k[0];
    75      /* case 0: nothing left to add */
    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);
    78101
    79    return key;
     102  return key;
    80103}
    81104#endif
    … …  
    87110
    88111(define foreign-TWUserMixHash
    89   (foreign-lambda unsigned-integer32 "TWUserMixHash"
    90                                      scheme-pointer unsigned-integer32
    91                                      unsigned-integer32
    92                                      (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  
    33
    44(use srfi-12)
    5 (use TWUserMixHash-support hashes-support)
    6 (use mathh-int message-digest)
     5(use TWUserMixHash-support hash-utils)
    76
    87(declare
    … …  
    1312  (export
    1413    make-TWUserMixHash-primitive-procedure
    15     make-TWUserMixHash-procedure
    16     make-TWUserMixHash-message-digest-procedures
    1714    make-TWUserMixHash ) )
    1815
    … …  
    2118(define-inline (check-procedure loc obj)
    2219  (##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-procedure
    30 ;;
    31 ;; Returns 1 value:
    32 ;; foreign-mix-procedure
    33 
    34 (define *last-exception* #f)
    35 
    36 (define (run-safe thunk errdef)
    37   (set! *last-exception* #f)
    38   (handle-exceptions ex
    39       (begin (set! *last-exception* ex) errdef)
    40     (thunk) ) )
    41 
    42 (define-macro (make-foreign-callback-mix-procedure ?mix-proc)
    43   `(##core#foreign-callback-wrapper
    44     ',(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-procedure
    53 ;;
    54 ;; Returns 1 value:
    55 ;; hash-update-procedure
    56 ;; ((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))) ) )
    6220
    6321;;;
    … …  
    8038;; hash-primitive-procedure
    8139
    82 (define (make-TWUserMixHash-primitive-procedure mix-proc)
     40(define (make-TWUserMixHash-primitive-procedure mix-proc #!optional unsafe?)
    8341  (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 ) ) ) ) ) )
    13155
    13256;; Takes 1 argument:
    … …  
    14064;; message-digest-primitive
    14165
    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?)])
    14469      (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  
    1010;; on 32-bit boundary!
    1111
    12 (use lolevel)
    1312(use message-digest miscmacros mathh-int misc-extn-control)
     13(use hashes-support)
    1414
    1515(declare
    … …  
    2424    ##sys#check-closure )
    2525  (export
    26     ;; Deprecated
    27     string-binary-unsigned-int32-set!
    28     string-binary->unsigned-int32
    29     ;;
    3026    current-hash-seed
    3127    make-range-restriction
    … …  
    3733    make-fixnum-bounded-hash
    3834    make-real-hash
    39     unsigned-integer32-ref
    40     unsigned-integer32-set!) )
     35    make-hash-procedure
     36    make-hash-message-digest-procedures ) )
    4137
    4238#>
    … …  
    4541#undef bitsizeof
    4642<#
     43
     44(include "hashes-macros")
    4745
    4846;;;
    … …  
    8482
    8583(define-parameter current-hash-seed
    86   0
     84  DEFAULT-HASH-SEED
    8785        (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))
    12294
    12395;;; Range restrictions
    … …  
    199171;;;
    200172
    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  
    162162                        )
    163163
    164       #; ;TWUserMixHash DOESN'T WORK
    165164                        (subsection "TWUserMixHash Procedures"
    166165
    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
    170170          (p "Returns a hash primitive procedure, "
    171171          (code "(scheme-object unsigned-integer32 unsigned-integer32 -> unsigned-integer32)") ", "
    172172          "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])"
    185178          (p "Returns 5 values: " (tt "HASH-PRIM") ", " (tt "HASH") ", "
    186179          (code ":binary-digest") ", " (code ":digest") ", and " (code ":primitive") ".") )
    … …  
    244237                                        "restricted to the interval, [0.0 1.0]. The signature is that "
    245238                                        "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") ".") )
    246248                        )
    247249
    … …  
    271273                                        (p "Sets the first 32-bits of " (tt "STRING") " to " (tt "NUMBER") "."))
    272274                        )
     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                        )
    273292                )
    274293
    275294  (history
     295    (version "2.2" "Added Rabin-Karp string hash search, TWUserMixHash.")
    276296    (version "2.105" "Added TWSHMXHash, TWSHMLMXHash, TWMGMXHash.")
    277297    (version "2.104" "Added make-fixnum-bounded-hash.")

  • release/3/hashes/trunk/hashes-macros.scm

    r8148 r8297  
    5151           hashes:generic-init ,UN hashes:generic-final
    5252           ',PN)) ) ) )
     53
     54(define-constant DEFAULT-HASH-SEED 0)

  • release/3/hashes/trunk/hashes-support.scm

    r8148 r8297  
    1919;; - Better initval handling, what ever that means.
    2020
    21 (use hash-utils)
    22 
    2321(declare
     22  (uses lolevel)
    2423  (usual-integrations)
    2524  (inline)
     25  (generic)
    2626  (disable-interrupts)
    2727  (no-procedure-checks)
    … …  
    2929  (no-bound-checks)
    3030  (export
     31    hs$hash-seed
     32    unsigned-integer32-set!
     33    unsigned-integer32-ref
    3134    hashes:hash-context-size
    3235    hashes:ctx-hash-ref
    … …  
    4144<#
    4245
     46(include "hashes-macros")
     47
    4348;;;
     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) )
    4482
    4583(define hashes:hash-context-size (foreign-value "sizeof (hashctx)" int))
    … …  
    6098
    6199(define (hashes:generic-init ctx)
    62         (hashes:ctx-hash-set! ctx (current-hash-seed)) )
     100        (hashes:ctx-hash-set! ctx hs$hash-seed) )
    63101
    64102;;

  • release/3/hashes/trunk/hashes.html

    r8148 r8297  
    274274<p>The ISpell hash function.</p></td></tr></table></div>
    275275<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 -&gt; unsigned-integer32)</code>, for the procedure <tt>MIX</tt>, <code>(unsigned-integer32 -&gt; 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">
    276286<h4>Digest Procedures</h4>
    277287<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>
    … …  
    308318<dt class="definition"><strong>procedure:</strong> (make-real-hash {HASH})</dt>
    309319<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 -&gt; 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>
    311327<div class="subsection">
    312328<h4>Range Procedures</h4>
    … …  
    327343<dt class="definition"><strong>procedure:</strong> (unsigned-integer32-set! OBJECT NUMBER)</dt>
    328344<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>
    330354<div class="section">
    331355<h3>Version</h3>
    332356<ul>
     357<li>2.106 Added Rabin-Karp string hash search, TWUserMixHash.</li>
    333358<li>2.105 Added TWSHMXHash, TWSHMLMXHash, TWMGMXHash.</li>
    334359<li>2.104 Added make-fixnum-bounded-hash.</li>

  • release/3/hashes/trunk/hashes.meta

    r8148 r8297  
    55 (license "BSD")
    66 (category crypt)
    7  (needs misc-extn miscmacros mathh message-digest box crc)
     7 (needs misc-extn miscmacros mathh message-digest box crc iset)
    88 (author "Kon Lovett")
    99 (egg "hashes.egg")
    … …  
    3636        "CRCHash.scm"
    3737        "hashes.scm"
     38        "rabin-karp.scm"
    3839        "hashes.h"
    3940        "hash-utils.scm"

  • release/3/hashes/trunk/hashes.scm

    r8148 r8297  
    66        RJMXHash
    77        TWMXHash TWSHMXHash TWSHMLMXHash TWMGMXHash
    8         #; ;TWUserMixHash DOESN'T WORK
    98        TWUserMixHash
    109        FNVHash FNVAHash

  • release/3/hashes/trunk/hashes.setup

    r8148 r8297  
    22
    33(required-extension-version
     4  'iset                   "1.4"
    45  'crc                    "1.1"
     6  'box                    "1.8"
    57  'mathh                  "1.9"
    68  'misc-extn              "3.002"
    … …  
    810  'miscmacros             "2.4")
    911
    10 (install-dynld hash-utils *version*)
    11 
    1212(install-dynld hashes-support *version* -O3 -d0)
    1313
    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"))
    1815
    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"))
    4242
    4343(install-dynld+docu hashes *version*)
    4444
     45(install-dynld rabin-karp *version* (documentation "hashes.html"))
     46
    4547(install-test "hashes-test.scm")

  • release/3/hashes/trunk/tests/hashes-test.scm

    r8148 r8297  
    33(use testbase testbase-output-human)
    44(use hashes)
     5(use rabin-karp)
    56
    67;;;
    … …  
    165166)
    166167
    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
    168180(define-test hashes-utils-test "TWUserMixHash"
    169181  (initial
    170     (define (mix key)
    171       key)
     182    (define (mix key) key)
    172183    (define usrmixhsh)
    173184    (define hash-prim)
    … …  
    177188                (define prim:digest) )
    178189
    179     (expect-set! "TWUserMixHash Make" usrmixhsh (receive (make-TWUserMixHash mix)))
     190    (expect-set! "TWUserMixHash Make" usrmixhsh (receive (make-TWUserMixHash mix #t)))
    180191    (side-effect
    181192      (set! hash-prim (car usrmixhsh))
Note: See TracChangeset for help on using the changeset viewer.