libguile/hash.c

   1 /*      Copyright (C) 1995,1996,1997, 2000 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 <stdio.h>
  48 #include "libguile/_scm.h"
  49 #include "libguile/chars.h"
  50 #include "libguile/ports.h"
  51 #include "libguile/strings.h"
  52 #include "libguile/symbols.h"
  53 #include "libguile/vectors.h"
  54
  55 #include "libguile/validate.h"
  56 #include "libguile/hash.h"
  57 \f
  58
  59 #ifndef floor
  60 extern double floor();
  61 #endif
  62
  63
  64 unsigned long
  65 scm_string_hash (const unsigned char *str, scm_sizet len)
  66 {
  67   if (len > 5)
  68     {
  69       scm_sizet i = 5;
  70       unsigned long h = 264;
  71       while (i--)
  72         h = (h << 8) + ((unsigned) (scm_downcase (str[h % len])));
  73       return h;
  74     }
  75   else
  76     {
  77       scm_sizet i = len;
  78       unsigned long h = 0;
  79       while (i)
  80         h = (h << 8) + ((unsigned) (scm_downcase (str[--i])));
  81       return h;
  82     }
  83 }
  84
  85
  86 /* Dirk:FIXME:: why downcase for characters? (2x: scm_hasher, scm_ihashv) */
  87 /* Dirk:FIXME:: scm_hasher could be made static. */
  88
  89
  90 unsigned long
  91 scm_hasher(SCM obj, unsigned long n, scm_sizet d)
  92 {
  93   switch (SCM_ITAG3 (obj)) {
  94   case scm_tc3_int_1:
  95   case scm_tc3_int_2:
  96     return SCM_INUM(obj) % n;   /* SCM_INUMP(obj) */
  97   case scm_tc3_imm24:
  98     if (SCM_CHARP(obj))
  99       return (unsigned)(scm_downcase(SCM_CHAR(obj))) % n;
 100     switch (SCM_UNPACK (obj)) {
 101 #ifndef SICP
 102     case SCM_EOL:
 103       d = 256;
 104       break;
 105 #endif
 106     case SCM_BOOL_T:
 107       d = 257;
 108       break;
 109     case SCM_BOOL_F:
 110       d = 258;
 111       break;
 112     case SCM_EOF_VAL:
 113       d = 259;
 114       break;
 115     default:
 116       d = 263;          /* perhaps should be error */
 117     }
 118     return d % n;
 119   default:
 120     return 263 % n;     /* perhaps should be error */
 121   case scm_tc3_cons:
 122     switch SCM_TYP7(obj) {
 123     default:
 124       return 263 % n;
 125     case scm_tc7_smob:
 126       switch SCM_TYP16(obj) {
 127       case scm_tc16_big:
 128         return SCM_INUM(scm_modulo(obj, SCM_MAKINUM(n)));
 129       default:
 130         return 263 % n;
 131       case scm_tc16_real:
 132         {
 133           double r = SCM_REAL_VALUE(obj);
 134           if (floor(r)==r) {
 135             obj = scm_inexact_to_exact (obj);
 136             if SCM_IMP(obj) return SCM_INUM(obj) % n;
 137             return SCM_INUM(scm_modulo(obj, SCM_MAKINUM(n)));
 138           }
 139         }
 140       case scm_tc16_complex:
 141         obj = scm_number_to_string(obj, SCM_MAKINUM(10));
 142       }
 143     case scm_tc7_string:
 144     case scm_tc7_substring:
 145       return scm_string_hash (SCM_STRING_UCHARS (obj), SCM_STRING_LENGTH (obj)) % n;
 146     case scm_tc7_symbol:
 147       return SCM_SYMBOL_HASH (obj) % n;
 148     case scm_tc7_wvect:
 149     case scm_tc7_vector:
 150       {
 151         scm_sizet len = SCM_VECTOR_LENGTH(obj);
 152         SCM *data = SCM_VELTS(obj);
 153         if (len>5)
 154           {
 155             scm_sizet i = d/2;
 156             unsigned long h = 1;
 157             while (i--) h = ((h<<8) + (scm_hasher(data[h % len], n, 2))) % n;
 158             return h;
 159           }
 160         else
 161           {
 162             scm_sizet i = len;
 163             unsigned long h = (n)-1;
 164             while (i--) h = ((h<<8) + (scm_hasher(data[i], n, d/len))) % n;
 165             return h;
 166           }
 167       }
 168     case scm_tcs_cons_imcar:
 169     case scm_tcs_cons_nimcar:
 170       if (d) return (scm_hasher(SCM_CAR(obj), n, d/2)+scm_hasher(SCM_CDR(obj), n, d/2)) % n;
 171       else return 1;
 172     case scm_tc7_port:
 173       return ((SCM_RDNG & SCM_CELL_WORD_0 (obj)) ? 260 : 261) % n;
 174     case scm_tcs_closures:
 175     case scm_tcs_subrs:
 176       return 262 % n;
 177     }
 178   }
 179 }
 180
 181
 182 \f
 183
 184
 185 unsigned int
 186 scm_ihashq (SCM obj, unsigned int n)
 187 {
 188   return (SCM_UNPACK (obj) >> 1) % n;
 189 }
 190
 191
 192 SCM_DEFINE (scm_hashq, "hashq", 2, 0, 0,
 193            (SCM key, SCM size),
 194             "Determine a hash value for KEY that is suitable for lookups in\n"
 195             "a hashtable of size SIZE, where eq? is used as the equality\n"
 196             "predicate.  The function returns an integer in the range 0 to\n"
 197             "SIZE - 1.  NOTE that `hashq' may use internal addresses.\n"
 198             "Thus two calls to hashq where the keys are eq? are not\n"
 199             "guaranteed to deliver the same value if the key object gets\n"
 200             "garbage collected in between.  This can happen, for example\n"
 201             "with symbols:  (hashq 'foo n) (gc) (hashq 'foo n) may produce two\n"
 202             "different values, since 'foo will be garbage collected.")
 203 #define FUNC_NAME s_scm_hashq
 204 {
 205   SCM_VALIDATE_INUM_MIN (2, size, 0);
 206   return SCM_MAKINUM (scm_ihashq (key, SCM_INUM (size)));
 207 }
 208 #undef FUNC_NAME
 209
 210
 211 \f
 212
 213
 214 unsigned int
 215 scm_ihashv (SCM obj, unsigned int n)
 216 {
 217   if (SCM_CHARP(obj))
 218     return ((unsigned int)(scm_downcase(SCM_CHAR(obj)))) % n; /* downcase!?!! */
 219
 220   if (SCM_NUMP(obj))
 221     return (unsigned int) scm_hasher(obj, n, 10);
 222   else
 223     return SCM_UNPACK (obj) % n;
 224 }
 225
 226
 227 SCM_DEFINE (scm_hashv, "hashv", 2, 0, 0,
 228            (SCM key, SCM size),
 229             "Determine a hash value for KEY that is suitable for lookups in\n"
 230             "a hashtable of size SIZE, where eqv? is used as the equality\n"
 231             "predicate.  The function returns an integer in the range 0 to\n"
 232             "SIZE - 1.  NOTE that (hashv key) may use internal addresses.\n"
 233             "Thus two calls to hashv where the keys are eqv? are not\n"
 234             "guaranteed to deliver the same value if the key object gets\n"
 235             "garbage collected in between.  This can happen, for example\n"
 236             "with symbols:  (hashv 'foo n) (gc) (hashv 'foo n) may produce two\n"
 237             "different values, since 'foo will be garbage collected.")
 238 #define FUNC_NAME s_scm_hashv
 239 {
 240   SCM_VALIDATE_INUM_MIN (2, size, 0);
 241   return SCM_MAKINUM (scm_ihashv (key, SCM_INUM (size)));
 242 }
 243 #undef FUNC_NAME
 244
 245
 246 \f
 247
 248
 249 unsigned int
 250 scm_ihash (SCM obj, unsigned int n)
 251 {
 252   return (unsigned int)scm_hasher (obj, n, 10);
 253 }
 254
 255 SCM_DEFINE (scm_hash, "hash", 2, 0, 0,
 256            (SCM key, SCM size),
 257             "Determine a hash value for KEY that is suitable for lookups in\n"
 258             "a hashtable of size SIZE, where equal? is used as the equality\n"
 259             "predicate.  The function returns an integer in the range 0 to\n"
 260             "SIZE - 1.")
 261 #define FUNC_NAME s_scm_hash
 262 {
 263   SCM_VALIDATE_INUM_MIN (2, size, 0);
 264   return SCM_MAKINUM (scm_ihash (key, SCM_INUM (size)));
 265 }
 266 #undef FUNC_NAME
 267
 268
 269 \f
 270
 271
 272 void
 273 scm_init_hash ()
 274 {
 275 #ifndef SCM_MAGIC_SNARFER
 276 #include "libguile/hash.x"
 277 #endif
 278 }
 279
 280
 281 /*
 282   Local Variables:
 283   c-file-style: "gnu"
 284   End:
 285 */