libguile/hash.c

   1 /* Copyright (C) 1995, 1996, 1997, 2000, 2001, 2003, 2004, 2006, 2008,
   2  *   2009, 2010, 2011, 2012, 2014 Free Software Foundation, Inc.
   3  *
   4  * This library is free software; you can redistribute it and/or
   5  * modify it under the terms of the GNU Lesser General Public License
   6  * as published by the Free Software Foundation; either version 3 of
   7  * the License, or (at your option) any later version.
   8  *
   9  * This library is distributed in the hope that it will be useful, but
  10  * WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12  * Lesser General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU Lesser General Public
  15  * License along with this library; if not, write to the Free Software
  16  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  17  * 02110-1301 USA
  18  */
  19
  20
  21 \f
  22 #ifdef HAVE_CONFIG_H
  23 # include <config.h>
  24 #endif
  25
  26 #ifdef HAVE_WCHAR_H
  27 #include <wchar.h>
  28 #endif
  29
  30 #include <math.h>
  31 #include <unistr.h>
  32
  33 #include "libguile/_scm.h"
  34 #include "libguile/chars.h"
  35 #include "libguile/ports.h"
  36 #include "libguile/strings.h"
  37 #include "libguile/symbols.h"
  38 #include "libguile/vectors.h"
  39
  40 #include "libguile/validate.h"
  41 #include "libguile/hash.h"
  42 \f
  43
  44 #ifndef floor
  45 extern double floor();
  46 #endif
  47
  48 #define SCM_MIN(A, B) ((A) < (B) ? (A) : (B))
  49
  50 unsigned long
  51 scm_string_hash (const unsigned char *str, size_t len)
  52 {
  53   /* from suggestion at: */
  54   /* http://srfi.schemers.org/srfi-13/mail-archive/msg00112.html */
  55
  56   unsigned long h = 0;
  57   while (len-- > 0)
  58     h = *str++ + h*37;
  59   return h;
  60 }
  61
  62 unsigned long
  63 scm_i_string_hash (SCM str)
  64 {
  65   size_t len = scm_i_string_length (str);
  66   size_t i = 0;
  67
  68   unsigned long h = 0;
  69   while (len-- > 0)
  70     h = (unsigned long) scm_i_string_ref (str, i++) + h * 37;
  71
  72   scm_remember_upto_here_1 (str);
  73   return h;
  74 }
  75
  76 unsigned long
  77 scm_i_locale_string_hash (const char *str, size_t len)
  78 {
  79 #ifdef HAVE_WCHAR_H
  80   mbstate_t state;
  81   wchar_t c;
  82   size_t byte_idx = 0, nbytes;
  83   unsigned long h = 0;
  84
  85   if (len == (size_t) -1)
  86     len = strlen (str);
  87
  88   while ((nbytes = mbrtowc (&c, str + byte_idx, len - byte_idx, &state)) > 0)
  89     {
  90       if (nbytes >= (size_t) -2)
  91         /* Invalid input string; punt.  */
  92         return scm_i_string_hash (scm_from_locale_stringn (str, len));
  93
  94       h = (unsigned long) c + h * 37;
  95       byte_idx += nbytes;
  96     }
  97
  98   return h;
  99 #else
 100   return scm_i_string_hash (scm_from_locale_stringn (str, len));
 101 #endif
 102 }
 103
 104 unsigned long
 105 scm_i_latin1_string_hash (const char *str, size_t len)
 106 {
 107   const scm_t_uint8 *ustr = (const scm_t_uint8 *) str;
 108   size_t i = 0;
 109   unsigned long h = 0;
 110
 111   if (len == (size_t) -1)
 112     len = strlen (str);
 113
 114   for (; i < len; i++)
 115     h = (unsigned long) ustr[i] + h * 37;
 116
 117   return h;
 118 }
 119
 120 unsigned long
 121 scm_i_utf8_string_hash (const char *str, size_t len)
 122 {
 123   const scm_t_uint8 *ustr = (const scm_t_uint8 *) str;
 124   size_t byte_idx = 0;
 125   unsigned long h = 0;
 126
 127   if (len == (size_t) -1)
 128     len = strlen (str);
 129
 130   while (byte_idx < len)
 131     {
 132       ucs4_t c;
 133       int nbytes;
 134
 135       nbytes = u8_mbtouc (&c, ustr + byte_idx, len - byte_idx);
 136       if (nbytes == 0)
 137         break;
 138       else if (nbytes < 0)
 139         /* Bad UTF-8; punt.  */
 140         return scm_i_string_hash (scm_from_utf8_stringn (str, len));
 141
 142       h = (unsigned long) c + h * 37;
 143       byte_idx += nbytes;
 144     }
 145
 146   return h;
 147 }
 148
 149
 150 /* Dirk:FIXME:: why downcase for characters? (2x: scm_hasher, scm_ihashv) */
 151 /* Dirk:FIXME:: scm_hasher could be made static. */
 152
 153
 154 unsigned long
 155 scm_hasher(SCM obj, unsigned long n, size_t d)
 156 {
 157   switch (SCM_ITAG3 (obj)) {
 158   case scm_tc3_int_1:
 159   case scm_tc3_int_2:
 160     return SCM_I_INUM(obj) % n;   /* SCM_INUMP(obj) */
 161   case scm_tc3_imm24:
 162     if (SCM_CHARP(obj))
 163       return (unsigned)(scm_c_downcase(SCM_CHAR(obj))) % n;
 164     switch (SCM_UNPACK (obj)) {
 165     case SCM_EOL_BITS:
 166       d = 256;
 167       break;
 168     case SCM_BOOL_T_BITS:
 169       d = 257;
 170       break;
 171     case SCM_BOOL_F_BITS:
 172       d = 258;
 173       break;
 174     case SCM_EOF_VAL_BITS:
 175       d = 259;
 176       break;
 177     default:
 178       d = 263;          /* perhaps should be error */
 179     }
 180     return d % n;
 181   default:
 182     return 263 % n;     /* perhaps should be error */
 183   case scm_tc3_cons:
 184     switch SCM_TYP7(obj) {
 185     default:
 186       return 263 % n;
 187     case scm_tc7_smob:
 188       return 263 % n;
 189     case scm_tc7_number:
 190       switch SCM_TYP16 (obj) {
 191       case scm_tc16_big:
 192         return scm_to_ulong (scm_modulo (obj, scm_from_ulong (n)));
 193       case scm_tc16_real:
 194         {
 195           double r = SCM_REAL_VALUE (obj);
 196           if (floor (r) == r && !isinf (r) && !isnan (r))
 197             {
 198               obj = scm_inexact_to_exact (obj);
 199               return scm_to_ulong (scm_modulo (obj, scm_from_ulong (n)));
 200             }
 201         }
 202         /* Fall through */
 203       case scm_tc16_complex:
 204       case scm_tc16_fraction:
 205         obj = scm_number_to_string (obj, scm_from_int (10));
 206         /* Fall through */
 207       }
 208       /* Fall through */
 209     case scm_tc7_string:
 210       {
 211         unsigned long hash =
 212           scm_i_string_hash (obj) % n;
 213         return hash;
 214       }
 215     case scm_tc7_symbol:
 216       return scm_i_symbol_hash (obj) % n;
 217     case scm_tc7_pointer:
 218       {
 219         /* Pointer objects are typically used to store addresses of heap
 220            objects.  On most platforms, these are at least 3-byte
 221            aligned (on x86_64-*-gnu, `malloc' returns 4-byte aligned
 222            addresses), so get rid of the least significant bits.  */
 223         scm_t_uintptr significant_bits;
 224
 225         significant_bits = (scm_t_uintptr) SCM_POINTER_VALUE (obj) >> 4UL;
 226         return (size_t) significant_bits  % n;
 227       }
 228     case scm_tcs_struct:
 229       return scm_i_struct_hash (obj, n, d);
 230     case scm_tc7_wvect:
 231     case scm_tc7_vector:
 232       if (d > 0)
 233         {
 234           size_t len, i, d2;
 235           unsigned long h;
 236
 237           len = SCM_SIMPLE_VECTOR_LENGTH (obj);
 238           if (len > 5)
 239             {
 240               i = d / 2;
 241               h = 1;
 242               d2 = SCM_MIN (2, d - 1);
 243             }
 244           else
 245             {
 246               i = len;
 247               h = n - 1;
 248               d2 = len > 0 ? (d - 1) / len : 0;
 249             }
 250
 251           while (i--)
 252             {
 253               SCM elt = SCM_SIMPLE_VECTOR_REF (obj, h % len);
 254               h = ((h << 8) + (scm_hasher (elt, n, d2))) % n;
 255             }
 256           return h;
 257         }
 258       else
 259         return 1;
 260     case scm_tcs_cons_imcar:
 261     case scm_tcs_cons_nimcar:
 262       if (d) return (scm_hasher (SCM_CAR (obj), n, d/2)
 263                      + scm_hasher (SCM_CDR (obj), n, d/2)) % n;
 264       else return 1;
 265     case scm_tc7_port:
 266       return ((SCM_RDNG & SCM_CELL_WORD_0 (obj)) ? 260 : 261) % n;
 267     case scm_tc7_program:
 268       return 262 % n;
 269     }
 270   }
 271 }
 272
 273
 274 \f
 275
 276
 277 unsigned long
 278 scm_ihashq (SCM obj, unsigned long n)
 279 {
 280   return (SCM_UNPACK (obj) >> 1) % n;
 281 }
 282
 283
 284 SCM_DEFINE (scm_hashq, "hashq", 2, 0, 0,
 285            (SCM key, SCM size),
 286             "Determine a hash value for @var{key} that is suitable for\n"
 287             "lookups in a hashtable of size @var{size}, where @code{eq?} is\n"
 288             "used as the equality predicate.  The function returns an\n"
 289             "integer in the range 0 to @var{size} - 1.  Note that\n"
 290             "@code{hashq} may use internal addresses.  Thus two calls to\n"
 291             "hashq where the keys are @code{eq?} are not guaranteed to\n"
 292             "deliver the same value if the key object gets garbage collected\n"
 293             "in between.  This can happen, for example with symbols:\n"
 294             "@code{(hashq 'foo n) (gc) (hashq 'foo n)} may produce two\n"
 295             "different values, since @code{foo} will be garbage collected.")
 296 #define FUNC_NAME s_scm_hashq
 297 {
 298   unsigned long sz = scm_to_unsigned_integer (size, 1, ULONG_MAX);
 299   return scm_from_ulong (scm_ihashq (key, sz));
 300 }
 301 #undef FUNC_NAME
 302
 303
 304 \f
 305
 306
 307 unsigned long
 308 scm_ihashv (SCM obj, unsigned long n)
 309 {
 310   if (SCM_CHARP(obj))
 311     return ((unsigned long) (scm_c_downcase (SCM_CHAR (obj)))) % n; /* downcase!?!! */
 312
 313   if (SCM_NUMP(obj))
 314     return (unsigned long) scm_hasher(obj, n, 10);
 315   else
 316     return SCM_UNPACK (obj) % n;
 317 }
 318
 319
 320 SCM_DEFINE (scm_hashv, "hashv", 2, 0, 0,
 321            (SCM key, SCM size),
 322             "Determine a hash value for @var{key} that is suitable for\n"
 323             "lookups in a hashtable of size @var{size}, where @code{eqv?} is\n"
 324             "used as the equality predicate.  The function returns an\n"
 325             "integer in the range 0 to @var{size} - 1.  Note that\n"
 326             "@code{(hashv key)} may use internal addresses.  Thus two calls\n"
 327             "to hashv where the keys are @code{eqv?} are not guaranteed to\n"
 328             "deliver the same value if the key object gets garbage collected\n"
 329             "in between.  This can happen, for example with symbols:\n"
 330             "@code{(hashv 'foo n) (gc) (hashv 'foo n)} may produce two\n"
 331             "different values, since @code{foo} will be garbage collected.")
 332 #define FUNC_NAME s_scm_hashv
 333 {
 334   unsigned long sz = scm_to_unsigned_integer (size, 1, ULONG_MAX);
 335   return scm_from_ulong (scm_ihashv (key, sz));
 336 }
 337 #undef FUNC_NAME
 338
 339
 340 \f
 341
 342
 343 unsigned long
 344 scm_ihash (SCM obj, unsigned long n)
 345 {
 346   return (unsigned long) scm_hasher (obj, n, 10);
 347 }
 348
 349 SCM_DEFINE (scm_hash, "hash", 2, 0, 0,
 350            (SCM key, SCM size),
 351             "Determine a hash value for @var{key} that is suitable for\n"
 352             "lookups in a hashtable of size @var{size}, where @code{equal?}\n"
 353             "is used as the equality predicate.  The function returns an\n"
 354             "integer in the range 0 to @var{size} - 1.")
 355 #define FUNC_NAME s_scm_hash
 356 {
 357   unsigned long sz = scm_to_unsigned_integer (size, 1, ULONG_MAX);
 358   return scm_from_ulong (scm_ihash (key, sz));
 359 }
 360 #undef FUNC_NAME
 361
 362
 363 \f
 364
 365
 366 void
 367 scm_init_hash ()
 368 {
 369 #include "libguile/hash.x"
 370 }
 371
 372
 373 /*
 374   Local Variables:
 375   c-file-style: "gnu"
 376   End:
 377 */