libguile/hash.c

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