Deprecate 'scm_string_hash'.
[bpt/guile.git] / libguile / hash.c
CommitLineData
8ac870de 1/* Copyright (C) 1995, 1996, 1997, 2000, 2001, 2003, 2004, 2006, 2008,
894d0b89 2 * 2009, 2010, 2011, 2012, 2014, 2015 Free Software Foundation, Inc.
8ac870de 3 *
73be1d9e 4 * This library is free software; you can redistribute it and/or
53befeb7
NJ
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.
0f2d19dd 8 *
53befeb7
NJ
9 * This library is distributed in the hope that it will be useful, but
10 * WITHOUT ANY WARRANTY; without even the implied warranty of
73be1d9e
MV
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
0f2d19dd 13 *
73be1d9e
MV
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
53befeb7
NJ
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
17 * 02110-1301 USA
73be1d9e 18 */
1bbd0b84 19
1bbd0b84 20
0f2d19dd 21\f
dbb605f5
LC
22#ifdef HAVE_CONFIG_H
23# include <config.h>
24#endif
0f2d19dd 25
62241538
AW
26#ifdef HAVE_WCHAR_H
27#include <wchar.h>
28#endif
29
10483f9e 30#include <math.h>
62241538
AW
31#include <unistr.h>
32
a0599745
MD
33#include "libguile/_scm.h"
34#include "libguile/chars.h"
35#include "libguile/ports.h"
a002f1a2
DH
36#include "libguile/strings.h"
37#include "libguile/symbols.h"
a0599745 38#include "libguile/vectors.h"
0f2d19dd 39
a0599745
MD
40#include "libguile/validate.h"
41#include "libguile/hash.h"
0f2d19dd
JB
42\f
43
44#ifndef floor
45extern double floor();
46#endif
47
cc1cd04f 48#define SCM_MIN(A, B) ((A) < (B) ? (A) : (B))
1cc91f1b 49
894d0b89
LC
50#if SCM_ENABLE_DEPRECATED == 1
51
52unsigned long
1be6b49c 53scm_string_hash (const unsigned char *str, size_t len)
ba393257 54{
b4d59261
MV
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;
ba393257
DH
62}
63
894d0b89
LC
64#endif
65
e23106d5
MG
66unsigned long
67scm_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
62241538
AW
80unsigned long
81scm_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
108unsigned long
109scm_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
124unsigned long
125scm_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
ba393257 153
dba97178
DH
154/* Dirk:FIXME:: why downcase for characters? (2x: scm_hasher, scm_ihashv) */
155/* Dirk:FIXME:: scm_hasher could be made static. */
156
157
c014a02e
ML
158unsigned long
159scm_hasher(SCM obj, unsigned long n, size_t d)
0f2d19dd 160{
dba97178
DH
161 switch (SCM_ITAG3 (obj)) {
162 case scm_tc3_int_1:
163 case scm_tc3_int_2:
e11e83f3 164 return SCM_I_INUM(obj) % n; /* SCM_INUMP(obj) */
dba97178
DH
165 case scm_tc3_imm24:
166 if (SCM_CHARP(obj))
84fad130 167 return (unsigned)(scm_c_downcase(SCM_CHAR(obj))) % n;
dba97178 168 switch (SCM_UNPACK (obj)) {
210c0325 169 case SCM_EOL_BITS:
94a5efac
GB
170 d = 256;
171 break;
210c0325 172 case SCM_BOOL_T_BITS:
94a5efac
GB
173 d = 257;
174 break;
210c0325 175 case SCM_BOOL_F_BITS:
94a5efac
GB
176 d = 258;
177 break;
210c0325 178 case SCM_EOF_VAL_BITS:
94a5efac
GB
179 d = 259;
180 break;
181 default:
182 d = 263; /* perhaps should be error */
0f2d19dd
JB
183 }
184 return d % n;
94a5efac
GB
185 default:
186 return 263 % n; /* perhaps should be error */
dba97178 187 case scm_tc3_cons:
0f2d19dd 188 switch SCM_TYP7(obj) {
94a5efac
GB
189 default:
190 return 263 % n;
0f2d19dd 191 case scm_tc7_smob:
534c55a9
DH
192 return 263 % n;
193 case scm_tc7_number:
1be6b49c 194 switch SCM_TYP16 (obj) {
950cc72b 195 case scm_tc16_big:
e11e83f3 196 return scm_to_ulong (scm_modulo (obj, scm_from_ulong (n)));
950cc72b
MD
197 case scm_tc16_real:
198 {
1be6b49c 199 double r = SCM_REAL_VALUE (obj);
10483f9e 200 if (floor (r) == r && !isinf (r) && !isnan (r))
e11e83f3
MV
201 {
202 obj = scm_inexact_to_exact (obj);
203 return scm_to_ulong (scm_modulo (obj, scm_from_ulong (n)));
204 }
0f2d19dd 205 }
534c55a9 206 /* Fall through */
950cc72b 207 case scm_tc16_complex:
f92e85f7 208 case scm_tc16_fraction:
e11e83f3 209 obj = scm_number_to_string (obj, scm_from_int (10));
534c55a9 210 /* Fall through */
0f2d19dd 211 }
534c55a9 212 /* Fall through */
0f2d19dd 213 case scm_tc7_string:
8824ac88 214 {
5a6d139b 215 unsigned long hash =
e23106d5 216 scm_i_string_hash (obj) % n;
8824ac88
MV
217 return hash;
218 }
28b06554 219 case scm_tc7_symbol:
cc95e00a 220 return scm_i_symbol_hash (obj) % n;
3854d5fd
LC
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 }
8ac870de
LC
232 case scm_tcs_struct:
233 return scm_i_struct_hash (obj, n, d);
0f2d19dd
JB
234 case scm_tc7_wvect:
235 case scm_tc7_vector:
cc1cd04f
MW
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;
63d869e7 252 d2 = len > 0 ? (d - 1) / len : 0;
cc1cd04f
MW
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;
94a5efac
GB
264 case scm_tcs_cons_imcar:
265 case scm_tcs_cons_nimcar:
1be6b49c
ML
266 if (d) return (scm_hasher (SCM_CAR (obj), n, d/2)
267 + scm_hasher (SCM_CDR (obj), n, d/2)) % n;
0f2d19dd
JB
268 else return 1;
269 case scm_tc7_port:
206d3de3 270 return ((SCM_RDNG & SCM_CELL_WORD_0 (obj)) ? 260 : 261) % n;
cc7005bc 271 case scm_tc7_program:
0f2d19dd
JB
272 return 262 % n;
273 }
274 }
275}
276
277
278\f
279
1cc91f1b 280
c014a02e
ML
281unsigned long
282scm_ihashq (SCM obj, unsigned long n)
0f2d19dd 283{
54778cd3 284 return (SCM_UNPACK (obj) >> 1) % n;
0f2d19dd
JB
285}
286
287
3b3b36dd 288SCM_DEFINE (scm_hashq, "hashq", 2, 0, 0,
94a5efac 289 (SCM key, SCM size),
5352393c
MG
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.")
1bbd0b84 300#define FUNC_NAME s_scm_hashq
0f2d19dd 301{
a55c2b68
MV
302 unsigned long sz = scm_to_unsigned_integer (size, 1, ULONG_MAX);
303 return scm_from_ulong (scm_ihashq (key, sz));
0f2d19dd 304}
1bbd0b84 305#undef FUNC_NAME
0f2d19dd
JB
306
307
308\f
309
1cc91f1b 310
c014a02e
ML
311unsigned long
312scm_ihashv (SCM obj, unsigned long n)
0f2d19dd 313{
7866a09b 314 if (SCM_CHARP(obj))
84fad130 315 return ((unsigned long) (scm_c_downcase (SCM_CHAR (obj)))) % n; /* downcase!?!! */
0f2d19dd 316
0c95b57d 317 if (SCM_NUMP(obj))
c014a02e 318 return (unsigned long) scm_hasher(obj, n, 10);
0f2d19dd 319 else
54778cd3 320 return SCM_UNPACK (obj) % n;
0f2d19dd
JB
321}
322
323
3b3b36dd 324SCM_DEFINE (scm_hashv, "hashv", 2, 0, 0,
94a5efac 325 (SCM key, SCM size),
5352393c
MG
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.")
1bbd0b84 336#define FUNC_NAME s_scm_hashv
0f2d19dd 337{
a55c2b68
MV
338 unsigned long sz = scm_to_unsigned_integer (size, 1, ULONG_MAX);
339 return scm_from_ulong (scm_ihashv (key, sz));
0f2d19dd 340}
1bbd0b84 341#undef FUNC_NAME
0f2d19dd
JB
342
343
344\f
345
1cc91f1b 346
c014a02e
ML
347unsigned long
348scm_ihash (SCM obj, unsigned long n)
0f2d19dd 349{
c014a02e 350 return (unsigned long) scm_hasher (obj, n, 10);
0f2d19dd
JB
351}
352
3b3b36dd 353SCM_DEFINE (scm_hash, "hash", 2, 0, 0,
94a5efac 354 (SCM key, SCM size),
5352393c
MG
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.")
1bbd0b84 359#define FUNC_NAME s_scm_hash
0f2d19dd 360{
a55c2b68
MV
361 unsigned long sz = scm_to_unsigned_integer (size, 1, ULONG_MAX);
362 return scm_from_ulong (scm_ihash (key, sz));
0f2d19dd 363}
1bbd0b84 364#undef FUNC_NAME
0f2d19dd
JB
365
366
367\f
368
1cc91f1b 369
0f2d19dd
JB
370void
371scm_init_hash ()
0f2d19dd 372{
a0599745 373#include "libguile/hash.x"
0f2d19dd
JB
374}
375
89e00824
ML
376
377/*
378 Local Variables:
379 c-file-style: "gnu"
380 End:
381*/