123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451 |
- #ifdef HAVE_CONFIG_H
- # include <config.h>
- #endif
- #ifdef HAVE_WCHAR_H
- #include <wchar.h>
- #endif
- #include <math.h>
- #include <unistr.h>
- #include "libguile/_scm.h"
- #include "libguile/chars.h"
- #include "libguile/ports.h"
- #include "libguile/strings.h"
- #include "libguile/symbols.h"
- #include "libguile/vectors.h"
- #include "libguile/validate.h"
- #include "libguile/hash.h"
- #ifndef floor
- extern double floor();
- #endif
- #define rot(x,k) (((x)<<(k)) | ((x)>>(32-(k))))
- #define mix(a,b,c) \
- { \
- a -= c; a ^= rot(c, 4); c += b; \
- b -= a; b ^= rot(a, 6); a += c; \
- c -= b; c ^= rot(b, 8); b += a; \
- a -= c; a ^= rot(c,16); c += b; \
- b -= a; b ^= rot(a,19); a += c; \
- c -= b; c ^= rot(b, 4); b += a; \
- }
- #define final(a,b,c) \
- { \
- c ^= b; c -= rot(b,14); \
- a ^= c; a -= rot(c,11); \
- b ^= a; b -= rot(a,25); \
- c ^= b; c -= rot(b,16); \
- a ^= c; a -= rot(c,4); \
- b ^= a; b -= rot(a,14); \
- c ^= b; c -= rot(b,24); \
- }
- #define JENKINS_LOOKUP3_HASHWORD2(k, length, ret) \
- do { \
- scm_t_uint32 a, b, c; \
- \
- \
- a = b = c = 0xdeadbeef + ((scm_t_uint32)(length<<2)) + 47; \
- \
- /* Handle most of the key. */ \
- while (length > 3) \
- { \
- a += k[0]; \
- b += k[1]; \
- c += k[2]; \
- mix (a, b, c); \
- length -= 3; \
- k += 3; \
- } \
- \
- \
- switch(length) \
- { \
- case 3 : c += k[2]; \
- case 2 : b += k[1]; \
- case 1 : a += k[0]; \
- final (a, b, c); \
- case 0: \
- break; \
- } \
- \
- if (sizeof (ret) == 8) \
- ret = (((unsigned long) c) << 32) | b; \
- else \
- ret = c; \
- } while (0)
- static unsigned long
- narrow_string_hash (const scm_t_uint8 *str, size_t len)
- {
- unsigned long ret;
- JENKINS_LOOKUP3_HASHWORD2 (str, len, ret);
- ret >>= 2;
- return ret;
- }
- static unsigned long
- wide_string_hash (const scm_t_wchar *str, size_t len)
- {
- unsigned long ret;
- JENKINS_LOOKUP3_HASHWORD2 (str, len, ret);
- ret >>= 2;
- return ret;
- }
- unsigned long
- scm_i_string_hash (SCM str)
- {
- size_t len = scm_i_string_length (str);
- if (scm_i_is_narrow_string (str))
- return narrow_string_hash ((const scm_t_uint8 *) scm_i_string_chars (str),
- len);
- else
- return wide_string_hash (scm_i_string_wide_chars (str), len);
- }
- unsigned long
- scm_i_locale_string_hash (const char *str, size_t len)
- {
- return scm_i_string_hash (scm_from_locale_stringn (str, len));
- }
- unsigned long
- scm_i_latin1_string_hash (const char *str, size_t len)
- {
- if (len == (size_t) -1)
- len = strlen (str);
- return narrow_string_hash ((const scm_t_uint8 *) str, len);
- }
- unsigned long
- scm_i_utf8_string_hash (const char *str, size_t len)
- {
- const scm_t_uint8 *end, *ustr = (const scm_t_uint8 *) str;
- unsigned long ret;
-
- size_t length;
- scm_t_uint32 a, b, c, u32;
- if (len == (size_t) -1)
- len = strlen (str);
- end = ustr + len;
- if (u8_check (ustr, len) != NULL)
-
- return scm_i_string_hash (scm_from_utf8_stringn (str, len));
- length = u8_strnlen (ustr, len);
-
- a = b = c = 0xdeadbeef + ((scm_t_uint32)(length<<2)) + 47;
-
- while (length > 3)
- {
- ustr += u8_mbtouc_unsafe (&u32, ustr, end - ustr);
- a += u32;
- ustr += u8_mbtouc_unsafe (&u32, ustr, end - ustr);
- b += u32;
- ustr += u8_mbtouc_unsafe (&u32, ustr, end - ustr);
- c += u32;
- mix (a, b, c);
- length -= 3;
- }
-
- ustr += u8_mbtouc_unsafe (&u32, ustr, end - ustr);
- a += u32;
- if (--length)
- {
- ustr += u8_mbtouc_unsafe (&u32, ustr, end - ustr);
- b += u32;
- if (--length)
- {
- ustr += u8_mbtouc_unsafe (&u32, ustr, end - ustr);
- c += u32;
- }
- }
- final (a, b, c);
- if (sizeof (unsigned long) == 8)
- ret = (((unsigned long) c) << 32) | b;
- else
- ret = c;
- ret >>= 2;
- return ret;
- }
- static unsigned long scm_raw_ihashq (scm_t_bits key);
- static unsigned long scm_raw_ihash (SCM obj, size_t depth);
- static unsigned long
- scm_i_struct_hash (SCM obj, size_t depth)
- {
- SCM layout;
- scm_t_bits *data;
- size_t struct_size, field_num;
- unsigned long hash;
- layout = SCM_STRUCT_LAYOUT (obj);
- struct_size = scm_i_symbol_length (layout) / 2;
- data = SCM_STRUCT_DATA (obj);
- hash = scm_raw_ihashq (SCM_UNPACK (SCM_STRUCT_VTABLE (obj)));
- if (depth > 0)
- for (field_num = 0; field_num < struct_size; field_num++)
- {
- int protection;
- protection = scm_i_symbol_ref (layout, field_num * 2 + 1);
- if (protection != 'h' && protection != 'o')
- {
- int type;
- type = scm_i_symbol_ref (layout, field_num * 2);
- switch (type)
- {
- case 'p':
- hash ^= scm_raw_ihash (SCM_PACK (data[field_num]),
- depth / 2);
- break;
- case 'u':
- hash ^= scm_raw_ihashq (data[field_num]);
- break;
- default:
- ;
- }
- }
- }
-
- return hash;
- }
- static unsigned long
- scm_raw_ihashq (scm_t_bits key)
- {
- if (sizeof (key) < 8)
- {
- key = (key ^ 61) ^ (key >> 16);
- key = key + (key << 3);
- key = key ^ (key >> 4);
- key = key * 0x27d4eb2d;
- key = key ^ (key >> 15);
- }
- else
- {
- key = (~key) + (key << 21);
- key = key ^ (key >> 24);
- key = (key + (key << 3)) + (key << 8);
- key = key ^ (key >> 14);
- key = (key + (key << 2)) + (key << 4);
- key = key ^ (key >> 28);
- key = key + (key << 31);
- }
- key >>= 2;
- return key;
- }
- static unsigned long
- scm_raw_ihash (SCM obj, size_t depth)
- {
- if (SCM_IMP (obj))
- return scm_raw_ihashq (SCM_UNPACK (obj));
- switch (SCM_TYP7(obj))
- {
-
- case scm_tc7_smob:
- return scm_raw_ihashq (SCM_TYP16 (obj));
- case scm_tc7_number:
- if (scm_is_integer (obj))
- {
- SCM n = SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM);
- if (scm_is_inexact (obj))
- obj = scm_inexact_to_exact (obj);
- return scm_raw_ihashq (scm_to_ulong (scm_modulo (obj, n)));
- }
- else
- return scm_i_string_hash (scm_number_to_string (obj, scm_from_int (10)));
- case scm_tc7_string:
- return scm_i_string_hash (obj);
- case scm_tc7_symbol:
- return scm_i_symbol_hash (obj);
- case scm_tc7_pointer:
- return scm_raw_ihashq ((scm_t_uintptr) SCM_POINTER_VALUE (obj));
- case scm_tc7_wvect:
- case scm_tc7_vector:
- {
- size_t len = SCM_SIMPLE_VECTOR_LENGTH (obj);
- size_t i = depth / 2;
- unsigned long h = scm_raw_ihashq (SCM_CELL_WORD_0 (obj));
- if (len)
- while (i--)
- h ^= scm_raw_ihash (scm_c_vector_ref (obj, h % len), i);
- return h;
- }
- case scm_tcs_cons_imcar:
- case scm_tcs_cons_nimcar:
- if (depth)
- return (scm_raw_ihash (SCM_CAR (obj), depth / 2)
- ^ scm_raw_ihash (SCM_CDR (obj), depth / 2));
- else
- return scm_raw_ihashq (scm_tc3_cons);
- case scm_tcs_struct:
- return scm_i_struct_hash (obj, depth);
- default:
- return scm_raw_ihashq (SCM_CELL_WORD_0 (obj));
- }
- }
- unsigned long
- scm_ihashq (SCM obj, unsigned long n)
- {
- return scm_raw_ihashq (SCM_UNPACK (obj)) % n;
- }
- SCM_DEFINE (scm_hashq, "hashq", 2, 0, 0,
- (SCM key, SCM size),
- "Determine a hash value for @var{key} that is suitable for\n"
- "lookups in a hashtable of size @var{size}, where @code{eq?} is\n"
- "used as the equality predicate. The function returns an\n"
- "integer in the range 0 to @var{size} - 1. Note that\n"
- "@code{hashq} may use internal addresses. Thus two calls to\n"
- "hashq where the keys are @code{eq?} are not guaranteed to\n"
- "deliver the same value if the key object gets garbage collected\n"
- "in between. This can happen, for example with symbols:\n"
- "@code{(hashq 'foo n) (gc) (hashq 'foo n)} may produce two\n"
- "different values, since @code{foo} will be garbage collected.")
- #define FUNC_NAME s_scm_hashq
- {
- unsigned long sz = scm_to_unsigned_integer (size, 1, ULONG_MAX);
- return scm_from_ulong (scm_ihashq (key, sz));
- }
- #undef FUNC_NAME
- unsigned long
- scm_ihashv (SCM obj, unsigned long n)
- {
- if (SCM_NUMP(obj))
- return scm_raw_ihash (obj, 10) % n;
- else
- return scm_raw_ihashq (SCM_UNPACK (obj)) % n;
- }
- SCM_DEFINE (scm_hashv, "hashv", 2, 0, 0,
- (SCM key, SCM size),
- "Determine a hash value for @var{key} that is suitable for\n"
- "lookups in a hashtable of size @var{size}, where @code{eqv?} is\n"
- "used as the equality predicate. The function returns an\n"
- "integer in the range 0 to @var{size} - 1. Note that\n"
- "@code{(hashv key)} may use internal addresses. Thus two calls\n"
- "to hashv where the keys are @code{eqv?} are not guaranteed to\n"
- "deliver the same value if the key object gets garbage collected\n"
- "in between. This can happen, for example with symbols:\n"
- "@code{(hashv 'foo n) (gc) (hashv 'foo n)} may produce two\n"
- "different values, since @code{foo} will be garbage collected.")
- #define FUNC_NAME s_scm_hashv
- {
- unsigned long sz = scm_to_unsigned_integer (size, 1, ULONG_MAX);
- return scm_from_ulong (scm_ihashv (key, sz));
- }
- #undef FUNC_NAME
- unsigned long
- scm_ihash (SCM obj, unsigned long n)
- {
- return (unsigned long) scm_raw_ihash (obj, 10) % n;
- }
- SCM_DEFINE (scm_hash, "hash", 2, 0, 0,
- (SCM key, SCM size),
- "Determine a hash value for @var{key} that is suitable for\n"
- "lookups in a hashtable of size @var{size}, where @code{equal?}\n"
- "is used as the equality predicate. The function returns an\n"
- "integer in the range 0 to @var{size} - 1.")
- #define FUNC_NAME s_scm_hash
- {
- unsigned long sz = scm_to_unsigned_integer (size, 1, ULONG_MAX);
- return scm_from_ulong (scm_ihash (key, sz));
- }
- #undef FUNC_NAME
- void
- scm_init_hash ()
- {
- #include "libguile/hash.x"
- }
|