libguile/hash.c

   1 /*      Copyright (C) 1995,1996,1997, 2000, 2001 Free Software Foundation, Inc.
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.  */
  41
  42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
  43    gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
  44
  45 \f
  46
  47 #include "libguile/_scm.h"
  48 #include "libguile/chars.h"
  49 #include "libguile/ports.h"
  50 #include "libguile/strings.h"
  51 #include "libguile/symbols.h"
  52 #include "libguile/vectors.h"
  53
  54 #include "libguile/validate.h"
  55 #include "libguile/hash.h"
  56 \f
  57
  58 #ifndef floor
  59 extern double floor();
  60 #endif
  61
  62
  63 unsigned long
  64 scm_string_hash (const unsigned char *str, scm_sizet len)
  65 {
  66   if (len > 5)
  67     {
  68       scm_sizet i = 5;
  69       unsigned long h = 264;
  70       while (i--)
  71         h = (h << 8) + (unsigned) str[h % len];
  72       return h;
  73     }
  74   else
  75     {
  76       scm_sizet i = len;
  77       unsigned long h = 0;
  78       while (i)
  79         h = (h << 8) + (unsigned) str[--i];
  80       return h;
  81     }
  82 }
  83
  84
  85 /* Dirk:FIXME:: why downcase for characters? (2x: scm_hasher, scm_ihashv) */
  86 /* Dirk:FIXME:: scm_hasher could be made static. */
  87
  88
  89 unsigned long
  90 scm_hasher(SCM obj, unsigned long n, scm_sizet d)
  91 {
  92   switch (SCM_ITAG3 (obj)) {
  93   case scm_tc3_int_1:
  94   case scm_tc3_int_2:
  95     return SCM_INUM(obj) % n;   /* SCM_INUMP(obj) */
  96   case scm_tc3_imm24:
  97     if (SCM_CHARP(obj))
  98       return (unsigned)(scm_downcase(SCM_CHAR(obj))) % n;
  99     switch (SCM_UNPACK (obj)) {
 100 #ifndef SICP
 101     case SCM_EOL:
 102       d = 256;
 103       break;
 104 #endif
 105     case SCM_BOOL_T:
 106       d = 257;
 107       break;
 108     case SCM_BOOL_F:
 109       d = 258;
 110       break;
 111     case SCM_EOF_VAL:
 112       d = 259;
 113       break;
 114     default:
 115       d = 263;          /* perhaps should be error */
 116     }
 117     return d % n;
 118   default:
 119     return 263 % n;     /* perhaps should be error */
 120   case scm_tc3_cons:
 121     switch SCM_TYP7(obj) {
 122     default:
 123       return 263 % n;
 124     case scm_tc7_smob:
 125       switch SCM_TYP16(obj) {
 126       case scm_tc16_big:
 127         return SCM_INUM(scm_modulo(obj, SCM_MAKINUM(n)));
 128       default:
 129         return 263 % n;
 130       case scm_tc16_real:
 131         {
 132           double r = SCM_REAL_VALUE(obj);
 133           if (floor(r)==r) {
 134             obj = scm_inexact_to_exact (obj);
 135             if SCM_IMP(obj) return SCM_INUM(obj) % n;
 136             return SCM_INUM(scm_modulo(obj, SCM_MAKINUM(n)));
 137           }
 138         }
 139       case scm_tc16_complex:
 140         obj = scm_number_to_string(obj, SCM_MAKINUM(10));
 141       }
 142     case scm_tc7_string:
 143     case scm_tc7_substring:
 144       return scm_string_hash (SCM_STRING_UCHARS (obj), SCM_STRING_LENGTH (obj)) % n;
 145     case scm_tc7_symbol:
 146       return SCM_SYMBOL_HASH (obj) % n;
 147     case scm_tc7_wvect:
 148     case scm_tc7_vector:
 149       {
 150         scm_sizet len = SCM_VECTOR_LENGTH(obj);
 151         SCM *data = SCM_VELTS(obj);
 152         if (len>5)
 153           {
 154             scm_sizet i = d/2;
 155             unsigned long h = 1;
 156             while (i--) h = ((h<<8) + (scm_hasher(data[h % len], n, 2))) % n;
 157             return h;
 158           }
 159         else
 160           {
 161             scm_sizet i = len;
 162             unsigned long h = (n)-1;
 163             while (i--) h = ((h<<8) + (scm_hasher(data[i], n, d/len))) % n;
 164             return h;
 165           }
 166       }
 167     case scm_tcs_cons_imcar:
 168     case scm_tcs_cons_nimcar:
 169       if (d) return (scm_hasher(SCM_CAR(obj), n, d/2)+scm_hasher(SCM_CDR(obj), n, d/2)) % n;
 170       else return 1;
 171     case scm_tc7_port:
 172       return ((SCM_RDNG & SCM_CELL_WORD_0 (obj)) ? 260 : 261) % n;
 173     case scm_tcs_closures:
 174     case scm_tcs_subrs:
 175       return 262 % n;
 176     }
 177   }
 178 }
 179
 180
 181 \f
 182
 183
 184 unsigned int
 185 scm_ihashq (SCM obj, unsigned int n)
 186 {
 187   return (SCM_UNPACK (obj) >> 1) % n;
 188 }
 189
 190
 191 SCM_DEFINE (scm_hashq, "hashq", 2, 0, 0,
 192            (SCM key, SCM size),
 193             "Determine a hash value for KEY that is suitable for lookups in\n"
 194             "a hashtable of size SIZE, where eq? is used as the equality\n"
 195             "predicate.  The function returns an integer in the range 0 to\n"
 196             "SIZE - 1.  NOTE that `hashq' may use internal addresses.\n"
 197             "Thus two calls to hashq where the keys are eq? are not\n"
 198             "guaranteed to deliver the same value if the key object gets\n"
 199             "garbage collected in between.  This can happen, for example\n"
 200             "with symbols:  (hashq 'foo n) (gc) (hashq 'foo n) may produce two\n"
 201             "different values, since 'foo will be garbage collected.")
 202 #define FUNC_NAME s_scm_hashq
 203 {
 204   SCM_VALIDATE_INUM_MIN (2, size, 0);
 205   return SCM_MAKINUM (scm_ihashq (key, SCM_INUM (size)));
 206 }
 207 #undef FUNC_NAME
 208
 209
 210 \f
 211
 212
 213 unsigned int
 214 scm_ihashv (SCM obj, unsigned int n)
 215 {
 216   if (SCM_CHARP(obj))
 217     return ((unsigned int)(scm_downcase(SCM_CHAR(obj)))) % n; /* downcase!?!! */
 218
 219   if (SCM_NUMP(obj))
 220     return (unsigned int) scm_hasher(obj, n, 10);
 221   else
 222     return SCM_UNPACK (obj) % n;
 223 }
 224
 225
 226 SCM_DEFINE (scm_hashv, "hashv", 2, 0, 0,
 227            (SCM key, SCM size),
 228             "Determine a hash value for KEY that is suitable for lookups in\n"
 229             "a hashtable of size SIZE, where eqv? is used as the equality\n"
 230             "predicate.  The function returns an integer in the range 0 to\n"
 231             "SIZE - 1.  NOTE that (hashv key) may use internal addresses.\n"
 232             "Thus two calls to hashv where the keys are eqv? are not\n"
 233             "guaranteed to deliver the same value if the key object gets\n"
 234             "garbage collected in between.  This can happen, for example\n"
 235             "with symbols:  (hashv 'foo n) (gc) (hashv 'foo n) may produce two\n"
 236             "different values, since 'foo will be garbage collected.")
 237 #define FUNC_NAME s_scm_hashv
 238 {
 239   SCM_VALIDATE_INUM_MIN (2, size, 0);
 240   return SCM_MAKINUM (scm_ihashv (key, SCM_INUM (size)));
 241 }
 242 #undef FUNC_NAME
 243
 244
 245 \f
 246
 247
 248 unsigned int
 249 scm_ihash (SCM obj, unsigned int n)
 250 {
 251   return (unsigned int)scm_hasher (obj, n, 10);
 252 }
 253
 254 SCM_DEFINE (scm_hash, "hash", 2, 0, 0,
 255            (SCM key, SCM size),
 256             "Determine a hash value for KEY that is suitable for lookups in\n"
 257             "a hashtable of size SIZE, where equal? is used as the equality\n"
 258             "predicate.  The function returns an integer in the range 0 to\n"
 259             "SIZE - 1.")
 260 #define FUNC_NAME s_scm_hash
 261 {
 262   SCM_VALIDATE_INUM_MIN (2, size, 0);
 263   return SCM_MAKINUM (scm_ihash (key, SCM_INUM (size)));
 264 }
 265 #undef FUNC_NAME
 266
 267
 268 \f
 269
 270
 271 void
 272 scm_init_hash ()
 273 {
 274 #ifndef SCM_MAGIC_SNARFER
 275 #include "libguile/hash.x"
 276 #endif
 277 }
 278
 279
 280 /*
 281   Local Variables:
 282   c-file-style: "gnu"
 283   End:
 284 */