libguile/hash.c

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