1 /* Copyright (C) 1995,1996 Free Software Foundation, Inc.
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)
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.
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, 675 Mass Ave, Cambridge, MA 02139, USA.
17 * As a special exception, the Free Software Foundation gives permission
18 * for additional uses of the text contained in its release of GUILE.
20 * The exception is that, if you link the GUILE library with other files
21 * to produce an executable, this does not by itself cause the
22 * resulting executable to be covered by the GNU General Public License.
23 * Your use of that executable is in no way restricted on account of
24 * linking the GUILE library code into it.
26 * This exception does not however invalidate any other reasons why
27 * the executable file might be covered by the GNU General Public License.
29 * This exception applies only to the code released by the
30 * Free Software Foundation under the name GUILE. If you copy
31 * code from other Free Software Foundation releases into a copy of
32 * GUILE, as the General Public License permits, the exception does
33 * not apply to the code that you add in this way. To avoid misleading
34 * anyone as to the status of such modified files, you must delete
35 * this exception notice from them.
37 * If you write modifications of your own for GUILE, it is your choice
38 * whether to permit this exception to apply to your modifications.
39 * If you do not wish that, delete this exception notice.
51 extern double floor();
56 scm_hasher(SCM obj
, unsigned long n
, scm_sizet d
)
65 switch (7 & (int) obj
) {
66 case 2: case 6: /* SCM_INUMP(obj) */
67 return SCM_INUM(obj
) % n
;
70 return (unsigned)(scm_downcase(SCM_ICHR(obj
))) % n
;
73 case (int) SCM_EOL
: d
= 256; break;
75 case (int) SCM_BOOL_T
: d
= 257; break;
76 case (int) SCM_BOOL_F
: d
= 258; break;
77 case (int) SCM_EOF_VAL
: d
= 259; break;
78 default: d
= 263; /* perhaps should be error */
81 default: return 263 % n
; /* perhaps should be error */
83 switch SCM_TYP7(obj
) {
84 default: return 263 % n
;
86 switch SCM_TYP16(obj
) {
88 bighash
: return SCM_INUM(scm_modulo(obj
, SCM_MAKINUM(n
)));
89 default: return 263 % n
;
93 double r
= SCM_REALPART(obj
);
95 obj
= scm_inexact_to_exact (obj
);
96 if SCM_IMP(obj
) return SCM_INUM(obj
) % n
;
100 obj
= scm_number_to_string(obj
, SCM_MAKINUM(10));
103 case scm_tcs_symbols
:
105 case scm_tc7_mb_string
:
106 case scm_tc7_substring
:
107 case scm_tc7_mb_substring
:
108 return scm_strhash(SCM_ROUCHARS(obj
), (scm_sizet
) SCM_ROLENGTH(obj
), n
);
112 scm_sizet len
= SCM_LENGTH(obj
);
113 SCM
*data
= SCM_VELTS(obj
);
118 while (i
--) h
= ((h
<<8) + (scm_hasher(data
[h
% len
], n
, 2))) % n
;
124 unsigned long h
= (n
)-1;
125 while (i
--) h
= ((h
<<8) + (scm_hasher(data
[i
], n
, d
/len
))) % n
;
129 case scm_tcs_cons_imcar
: case scm_tcs_cons_nimcar
:
130 if (d
) return (scm_hasher(SCM_CAR(obj
), n
, d
/2)+scm_hasher(SCM_CDR(obj
), n
, d
/2)) % n
;
133 return ((SCM_RDNG
& SCM_CAR(obj
)) ? 260 : 261) % n
;
134 case scm_tcs_closures
: case scm_tc7_contin
: case scm_tcs_subrs
:
145 scm_ihashq (SCM obj
, unsigned int n
)
153 return (((unsigned int) obj
) >> 1) % n
;
157 SCM_PROC(s_hashq
, "hashq", 2, 0, 0, scm_hashq
);
160 scm_hashq(SCM obj
, SCM n
)
168 SCM_ASSERT(SCM_INUMP(n
) && 0 <= n
, n
, SCM_ARG2
, s_hashq
);
169 return SCM_MAKINUM(scm_ihashq (obj
, SCM_INUM (n
)));
177 scm_ihashv (SCM obj
, unsigned int n
)
186 return ((unsigned int)(scm_downcase(SCM_ICHR(obj
)))) % n
; /* downcase!?!! */
188 if (SCM_NIMP(obj
) && SCM_NUMP(obj
))
189 return (unsigned int) scm_hasher(obj
, n
, 10);
191 return ((unsigned int)obj
) % n
;
195 SCM_PROC(s_hashv
, "hashv", 2, 0, 0, scm_hashv
);
198 scm_hashv(SCM obj
, SCM n
)
206 SCM_ASSERT(SCM_INUMP(n
) && 0 <= n
, n
, SCM_ARG2
, s_hashv
);
207 return SCM_MAKINUM(scm_ihashv (obj
, SCM_INUM (n
)));
215 scm_ihash (SCM obj
, unsigned int n
)
223 return (unsigned int)scm_hasher (obj
, n
, 10);
226 SCM_PROC(s_hash
, "hash", 2, 0, 0, scm_hash
);
229 scm_hash(SCM obj
, SCM n
)
237 SCM_ASSERT(SCM_INUMP(n
) && 0 <= n
, n
, SCM_ARG2
, s_hash
);
238 return SCM_MAKINUM(scm_ihash(obj
, SCM_INUM(n
)));