← Back to branch summary

~peter-pearse/ubuntu/natty/guile-1.8/prop001

« back to all changes in this revision

Viewing changes to libguile/hash.c

  • Committer: Bazaar Package Importer
  • Author(s): Daniel Schepler
  • Date: 2006-11-09 03:11:16 UTC
  • Revision ID: james.westby@ubuntu.com-20061109031116-hu0q1jxqg12y6yeg
Tags: upstream-1.8.1+1
Import upstream version 1.8.1+1

Show diffs side-by-side

added added

removed removed

Lines of Context:
libguile/hash.c
 
1
/*      Copyright (C) 1995,1996,1997, 2000, 2001, 2003, 2004, 2006 Free Software Foundation, Inc.
 
2
 * 
 
3
 * This library is free software; you can redistribute it and/or
 
4
 * modify it under the terms of the GNU Lesser General Public
 
5
 * License as published by the Free Software Foundation; either
 
6
 * version 2.1 of the License, or (at your option) any later version.
 
7
 *
 
8
 * This library 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 GNU
 
11
 * Lesser General Public License for more details.
 
12
 *
 
13
 * You should have received a copy of the GNU Lesser General Public
 
14
 * License along with this library; if not, write to the Free Software
 
15
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 
16
 */
 
17
 
 
18
 
 
19
 
 
20
 
 
21
#include "libguile/_scm.h"
 
22
#include "libguile/chars.h"
 
23
#include "libguile/ports.h"
 
24
#include "libguile/strings.h"
 
25
#include "libguile/symbols.h"
 
26
#include "libguile/vectors.h"
 
27
 
 
28
#include "libguile/validate.h"
 
29
#include "libguile/hash.h"
 
30
 
 
31
 
 
32
#ifndef floor
 
33
extern double floor();
 
34
#endif
 
35
 
 
36
 
 
37
unsigned long 
 
38
scm_string_hash (const unsigned char *str, size_t len)
 
39
{
 
40
  /* from suggestion at: */
 
41
  /* http://srfi.schemers.org/srfi-13/mail-archive/msg00112.html */
 
42
 
 
43
  unsigned long h = 0;
 
44
  while (len-- > 0)
 
45
    h = *str++ + h*37;
 
46
  return h;
 
47
}
 
48
 
 
49
 
 
50
/* Dirk:FIXME:: why downcase for characters? (2x: scm_hasher, scm_ihashv) */
 
51
/* Dirk:FIXME:: scm_hasher could be made static. */
 
52
 
 
53
 
 
54
unsigned long
 
55
scm_hasher(SCM obj, unsigned long n, size_t d)
 
56
{
 
57
  switch (SCM_ITAG3 (obj)) {
 
58
  case scm_tc3_int_1: 
 
59
  case scm_tc3_int_2:
 
60
    return SCM_I_INUM(obj) % n;   /* SCM_INUMP(obj) */
 
61
  case scm_tc3_imm24:
 
62
    if (SCM_CHARP(obj))
 
63
      return (unsigned)(scm_c_downcase(SCM_CHAR(obj))) % n;
 
64
    switch (SCM_UNPACK (obj)) {
 
65
#ifndef SICP
 
66
    case SCM_UNPACK(SCM_EOL):
 
67
      d = 256; 
 
68
      break;
 
69
#endif
 
70
    case SCM_UNPACK(SCM_BOOL_T):
 
71
      d = 257; 
 
72
      break;
 
73
    case SCM_UNPACK(SCM_BOOL_F):
 
74
      d = 258; 
 
75
      break;
 
76
    case SCM_UNPACK(SCM_EOF_VAL):
 
77
      d = 259; 
 
78
      break;
 
79
    default: 
 
80
      d = 263;          /* perhaps should be error */
 
81
    }
 
82
    return d % n;
 
83
  default: 
 
84
    return 263 % n;     /* perhaps should be error */
 
85
  case scm_tc3_cons:
 
86
    switch SCM_TYP7(obj) {
 
87
    default: 
 
88
      return 263 % n;
 
89
    case scm_tc7_smob:
 
90
      return 263 % n;
 
91
    case scm_tc7_number:
 
92
      switch SCM_TYP16 (obj) {
 
93
      case scm_tc16_big:
 
94
        return scm_to_ulong (scm_modulo (obj, scm_from_ulong (n)));
 
95
      case scm_tc16_real:
 
96
        {
 
97
          double r = SCM_REAL_VALUE (obj);
 
98
          if (floor (r) == r) 
 
99
            {
 
100
              obj = scm_inexact_to_exact (obj);
 
101
              return scm_to_ulong (scm_modulo (obj, scm_from_ulong (n)));
 
102
            }
 
103
        }
 
104
        /* Fall through */
 
105
      case scm_tc16_complex:
 
106
      case scm_tc16_fraction:
 
107
        obj = scm_number_to_string (obj, scm_from_int (10));
 
108
        /* Fall through */
 
109
      }
 
110
      /* Fall through */
 
111
    case scm_tc7_string:
 
112
      {
 
113
        unsigned long hash =
 
114
          scm_string_hash ((const unsigned char *) scm_i_string_chars (obj),
 
115
                           scm_i_string_length (obj)) % n;
 
116
        scm_remember_upto_here_1 (obj);
 
117
        return hash;
 
118
      }
 
119
    case scm_tc7_symbol:
 
120
      return scm_i_symbol_hash (obj) % n;
 
121
    case scm_tc7_wvect:
 
122
    case scm_tc7_vector:
 
123
      {
 
124
        size_t len = SCM_SIMPLE_VECTOR_LENGTH (obj);
 
125
        if (len > 5)
 
126
          {
 
127
            size_t i = d/2;
 
128
            unsigned long h = 1;
 
129
            while (i--)
 
130
              {
 
131
                SCM elt = SCM_SIMPLE_VECTOR_REF (obj, h % len);
 
132
                h = ((h << 8) + (scm_hasher (elt, n, 2))) % n;
 
133
              }
 
134
            return h;
 
135
          }
 
136
        else
 
137
          {
 
138
            size_t i = len;
 
139
            unsigned long h = (n)-1;
 
140
            while (i--)
 
141
              {
 
142
                SCM elt = SCM_SIMPLE_VECTOR_REF (obj, h % len);
 
143
                h = ((h << 8) + (scm_hasher (elt, n, d/len))) % n;
 
144
              }
 
145
            return h;
 
146
          }
 
147
      }
 
148
    case scm_tcs_cons_imcar: 
 
149
    case scm_tcs_cons_nimcar:
 
150
      if (d) return (scm_hasher (SCM_CAR (obj), n, d/2)
 
151
                     + scm_hasher (SCM_CDR (obj), n, d/2)) % n;
 
152
      else return 1;
 
153
    case scm_tc7_port:
 
154
      return ((SCM_RDNG & SCM_CELL_WORD_0 (obj)) ? 260 : 261) % n;
 
155
    case scm_tcs_closures: 
 
156
    case scm_tcs_subrs:
 
157
      return 262 % n;
 
158
    }
 
159
  }
 
160
}
 
161
 
 
162
 
 
163
 
 
164
 
 
165
 
 
166
unsigned long
 
167
scm_ihashq (SCM obj, unsigned long n)
 
168
{
 
169
  return (SCM_UNPACK (obj) >> 1) % n;
 
170
}
 
171
 
 
172
 
 
173
SCM_DEFINE (scm_hashq, "hashq", 2, 0, 0,
 
174
           (SCM key, SCM size),
 
175
            "Determine a hash value for @var{key} that is suitable for\n"
 
176
            "lookups in a hashtable of size @var{size}, where @code{eq?} is\n"
 
177
            "used as the equality predicate.  The function returns an\n"
 
178
            "integer in the range 0 to @var{size} - 1.  Note that\n"
 
179
            "@code{hashq} may use internal addresses.  Thus two calls to\n"
 
180
            "hashq where the keys are @code{eq?} are not guaranteed to\n"
 
181
            "deliver the same value if the key object gets garbage collected\n"
 
182
            "in between.  This can happen, for example with symbols:\n"
 
183
            "@code{(hashq 'foo n) (gc) (hashq 'foo n)} may produce two\n"
 
184
            "different values, since @code{foo} will be garbage collected.")
 
185
#define FUNC_NAME s_scm_hashq
 
186
{
 
187
  unsigned long sz = scm_to_unsigned_integer (size, 1, ULONG_MAX);
 
188
  return scm_from_ulong (scm_ihashq (key, sz));
 
189
}
 
190
#undef FUNC_NAME
 
191
 
 
192
 
 
193
 
 
194
 
 
195
 
 
196
unsigned long
 
197
scm_ihashv (SCM obj, unsigned long n)
 
198
{
 
199
  if (SCM_CHARP(obj))
 
200
    return ((unsigned long) (scm_c_downcase (SCM_CHAR (obj)))) % n; /* downcase!?!! */
 
201
 
 
202
  if (SCM_NUMP(obj))
 
203
    return (unsigned long) scm_hasher(obj, n, 10);
 
204
  else
 
205
    return SCM_UNPACK (obj) % n;
 
206
}
 
207
 
 
208
 
 
209
SCM_DEFINE (scm_hashv, "hashv", 2, 0, 0,
 
210
           (SCM key, SCM size),
 
211
            "Determine a hash value for @var{key} that is suitable for\n"
 
212
            "lookups in a hashtable of size @var{size}, where @code{eqv?} is\n"
 
213
            "used as the equality predicate.  The function returns an\n"
 
214
            "integer in the range 0 to @var{size} - 1.  Note that\n"
 
215
            "@code{(hashv key)} may use internal addresses.  Thus two calls\n"
 
216
            "to hashv where the keys are @code{eqv?} are not guaranteed to\n"
 
217
            "deliver the same value if the key object gets garbage collected\n"
 
218
            "in between.  This can happen, for example with symbols:\n"
 
219
            "@code{(hashv 'foo n) (gc) (hashv 'foo n)} may produce two\n"
 
220
            "different values, since @code{foo} will be garbage collected.")
 
221
#define FUNC_NAME s_scm_hashv
 
222
{
 
223
  unsigned long sz = scm_to_unsigned_integer (size, 1, ULONG_MAX);
 
224
  return scm_from_ulong (scm_ihashv (key, sz));
 
225
}
 
226
#undef FUNC_NAME
 
227
 
 
228
 
 
229
 
 
230
 
 
231
 
 
232
unsigned long
 
233
scm_ihash (SCM obj, unsigned long n)
 
234
{
 
235
  return (unsigned long) scm_hasher (obj, n, 10);
 
236
}
 
237
 
 
238
SCM_DEFINE (scm_hash, "hash", 2, 0, 0,
 
239
           (SCM key, SCM size),
 
240
            "Determine a hash value for @var{key} that is suitable for\n"
 
241
            "lookups in a hashtable of size @var{size}, where @code{equal?}\n"
 
242
            "is used as the equality predicate.  The function returns an\n"
 
243
            "integer in the range 0 to @var{size} - 1.")
 
244
#define FUNC_NAME s_scm_hash
 
245
{
 
246
  unsigned long sz = scm_to_unsigned_integer (size, 1, ULONG_MAX);
 
247
  return scm_from_ulong (scm_ihash (key, sz));
 
248
}
 
249
#undef FUNC_NAME
 
250
 
 
251
 
 
252
 
 
253
 
 
254
 
 
255
void
 
256
scm_init_hash ()
 
257
{
 
258
#include "libguile/hash.x"
 
259
}
 
260
 
 
261
 
 
262
/*
 
263
  Local Variables:
 
264
  c-file-style: "gnu"
 
265
  End:
 
266
*/