Mercurial > hg > xemacs-beta
annotate src/elhash.c @ 4885:6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
lisp/ChangeLog addition:
2010-01-24 Aidan Kehoe <kehoea@parhasard.net>
Correct the semantics of #'member*, #'eql, #'assoc* in the
presence of bignums; change the integerp byte code to fixnump
semantics.
* bytecomp.el (fixnump, integerp, byte-compile-integerp):
Change the integerp byte code to fixnump; add a byte-compile
method to integerp using fixnump and numberp and avoiding a
funcall most of the time, since in the non-core contexts where
integerp is used, it's mostly distinguishing between fixnums and
things that are not numbers at all.
* byte-optimize.el (side-effect-free-fns, byte-after-unbind-ops)
(byte-compile-side-effect-and-error-free-ops):
Replace the integerp bytecode with fixnump; add fixnump to the
side-effect-free-fns. Add the other extended number type
predicates to the list in passing.
* obsolete.el (floatp-safe): Mark this as obsolete.
* cl.el (eql): Go into more detail in the docstring here. Don't
bother checking whether both arguments are numbers; one is enough,
#'equal will fail correctly if they have distinct types.
(subst): Replace a call to #'integerp (deciding whether to use
#'memq or not) with one to #'fixnump.
Delete most-positive-fixnum, most-negative-fixnum from this file;
they're now always in C, so they can't be modified from Lisp.
* cl-seq.el (member*, assoc*, rassoc*):
Correct these functions in the presence of bignums.
* cl-macs.el (cl-make-type-test): The type test for a fixnum is
now fixnump. Ditch floatp-safe, use floatp instead.
(eql): Correct this compiler macro in the presence of bignums.
(assoc*): Correct this compiler macro in the presence of bignums.
* simple.el (undo):
Change #'integerp to #'fixnump here, since we use #'delq with the
same value as ELT a few lines down.
src/ChangeLog addition:
2010-01-24 Aidan Kehoe <kehoea@parhasard.net>
Fix problems with #'eql, extended number types, and the hash table
implementation; change the Bintegerp bytecode to fixnump semantics
even on bignum builds, since #'integerp can have a fast
implementation in terms of #'fixnump for most of its extant uses,
but not vice-versa.
* lisp.h: Always #include number.h; we want the macros provided in
it, even if the various number types are not available.
* number.h (NON_FIXNUM_NUMBER_P): New macro, giving 1 when its
argument is of non-immediate number type. Equivalent to FLOATP if
WITH_NUMBER_TYPES is not defined.
* elhash.c (lisp_object_eql_equal, lisp_object_eql_hash):
Use NON_FIXNUM_NUMBER_P in these functions, instead of FLOATP,
giving more correct behaviour in the presence of the extended
number types.
* bytecode.c (Bfixnump, execute_optimized_program):
Rename Bintegerp to Bfixnump; change its semantics to reflect the
new name on builds with bignum support.
* data.c (Ffixnump, Fintegerp, syms_of_data, vars_of_data):
Always make #'fixnump available, even on non-BIGNUM builds;
always implement #'integerp in this file, even on BIGNUM builds.
Move most-positive-fixnum, most-negative-fixnum here from
number.c, so they are Lisp constants even on builds without number
types, and attempts to change or bind them error.
Use the NUMBERP and INTEGERP macros even on builds without
extended number types.
* data.c (fixnum_char_or_marker_to_int):
Rename this function from integer_char_or_marker_to_int, to better
reflect the arguments it accepts.
* number.c (Fevenp, Foddp, syms_of_number):
Never provide #'integerp in this file. Remove #'oddp,
#'evenp; their implementations are overridden by those in cl.el.
* number.c (vars_of_number):
most-positive-fixnum, most-negative-fixnum are no longer here.
man/ChangeLog addition:
2010-01-23 Aidan Kehoe <kehoea@parhasard.net>
Generally: be careful to say fixnum, not integer, when talking
about fixed-precision integral types. I'm sure I've missed
instances, both here and in the docstrings, but this is a decent
start.
* lispref/text.texi (Columns):
Document where only fixnums, not integers generally, are accepted.
(Registers):
Remove some ancient char-int confoundance here.
* lispref/strings.texi (Creating Strings, Creating Strings):
Be more exact in describing where fixnums but not integers in
general are accepted.
(Creating Strings): Use a more contemporary example to illustrate
how concat deals with lists including integers about #xFF. Delete
some obsolete documentation on same.
(Char Table Types): Document that only fixnums are accepted as
values in syntax tables.
* lispref/searching.texi (String Search, Search and Replace):
Be exact in describing where fixnums but not integers in general
are accepted.
* lispref/range-tables.texi (Range Tables): Be exact in describing
them; only fixnums are accepted to describe ranges.
* lispref/os.texi (Killing XEmacs, User Identification)
(Time of Day, Time Conversion):
Be more exact about using fixnum where only fixed-precision
integers are accepted.
* lispref/objects.texi (Integer Type): Be more exact (and
up-to-date) about the possible values for
integers. Cross-reference to documentation of the bignum extension.
(Equality Predicates):
(Range Table Type):
(Array Type): Use fixnum, not integer, to describe a
fixed-precision integer.
(Syntax Table Type): Correct some English syntax here.
* lispref/numbers.texi (Numbers): Change the phrasing here to use
fixnum to mean the fixed-precision integers normal in emacs.
Document that our terminology deviates from that of Common Lisp,
and that we're working on it.
(Compatibility Issues): Reiterate the Common Lisp versus Emacs
Lisp compatibility issues.
(Comparison of Numbers, Arithmetic Operations):
* lispref/commands.texi (Command Loop Info, Working With Events):
* lispref/buffers.texi (Modification Time):
Be more exact in describing where fixnums but not integers in
general are accepted.
author | Aidan Kehoe <kehoea@parhasard.net> |
---|---|
date | Sun, 24 Jan 2010 15:21:27 +0000 |
parents | e6dec75ded0e |
children | 6ef8256a020a db2db229ee82 |
rev | line source |
---|---|
428 | 1 /* Implementation of the hash table lisp object type. |
2 Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc. | |
2421 | 3 Copyright (C) 1995, 1996, 2002, 2004 Ben Wing. |
428 | 4 Copyright (C) 1997 Free Software Foundation, Inc. |
5 | |
6 This file is part of XEmacs. | |
7 | |
8 XEmacs is free software; you can redistribute it and/or modify it | |
9 under the terms of the GNU General Public License as published by the | |
10 Free Software Foundation; either version 2, or (at your option) any | |
11 later version. | |
12 | |
13 XEmacs is distributed in the hope that it will be useful, but WITHOUT | |
14 ANY WARRANTY; without even the implied warranty of MERCNTABILITY or | |
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
16 for more details. | |
17 | |
18 You should have received a copy of the GNU General Public License | |
19 along with XEmacs; see the file COPYING. If not, write to | |
20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
21 Boston, MA 02111-1307, USA. */ | |
22 | |
23 /* Synched up with: Not in FSF. */ | |
24 | |
1292 | 25 /* Author: Lost in the mists of history. At least back to Lucid 19.3, |
26 circa Sep 1992. Early hash table implementation allowed only `eq' as a | |
27 test -- other tests possible only when these objects were created from | |
28 the C code. | |
29 | |
30 Expansion to allow general `equal'-test Lisp-creatable tables, and hash | |
31 methods for the various Lisp objects in existence at the time, added | |
32 during 19.12 I think (early 1995?), by Ben Wing. | |
33 | |
34 Weak hash tables added by Jamie (maybe?) early on, perhaps around 19.6, | |
35 maybe earlier; again, only possible through the C code, and only | |
36 supported fully weak hash tables. Expansion to other kinds of weakness, | |
37 and exporting of the interface to Lisp, by Ben Wing during 19.12 | |
38 (early-mid 1995) or maybe 19.13 cycle (mid 1995). | |
39 | |
40 Expansion to full Common Lisp spec and interface, redoing of the | |
41 implementation, by Martin Buchholz, 1997? (Former hash table | |
42 implementation used "double hashing", I'm pretty sure, and was weirdly | |
43 tied into the generic hash.c code. Martin completely separated them.) | |
44 */ | |
45 | |
489 | 46 /* This file implements the hash table lisp object type. |
47 | |
504 | 48 This implementation was mostly written by Martin Buchholz in 1997. |
49 | |
50 The Lisp-level API (derived from Common Lisp) is almost completely | |
51 compatible with GNU Emacs 21, even though the implementations are | |
52 totally independent. | |
53 | |
489 | 54 The hash table technique used is "linear probing". Collisions are |
55 resolved by putting the item in the next empty place in the array | |
56 following the collision. Finding a hash entry performs a linear | |
57 search in the cluster starting at the hash value. | |
58 | |
59 On deletions from the hash table, the entries immediately following | |
60 the deleted entry are re-entered in the hash table. We do not have | |
61 a special way to mark deleted entries (known as "tombstones"). | |
62 | |
63 At the end of the hash entries ("hentries"), we leave room for an | |
64 entry that is always empty (the "sentinel"). | |
65 | |
66 The traditional literature on hash table implementation | |
67 (e.g. Knuth) suggests that too much "primary clustering" occurs | |
68 with linear probing. However, this literature was written when | |
69 locality of reference was not a factor. The discrepancy between | |
70 CPU speeds and memory speeds is increasing, and the speed of access | |
71 to memory is highly dependent on memory caches which work best when | |
72 there is high locality of data reference. Random access to memory | |
73 is up to 20 times as expensive as access to the nearest address | |
74 (and getting worse). So linear probing makes sense. | |
75 | |
76 But the representation doesn't actually matter that much with the | |
77 current elisp engine. Funcall is sufficiently slow that the choice | |
78 of hash table implementation is noise. */ | |
79 | |
428 | 80 #include <config.h> |
81 #include "lisp.h" | |
82 #include "bytecode.h" | |
83 #include "elhash.h" | |
489 | 84 #include "opaque.h" |
428 | 85 |
86 Lisp_Object Qhash_tablep; | |
87 static Lisp_Object Qhashtable, Qhash_table; | |
442 | 88 static Lisp_Object Qweakness, Qvalue, Qkey_or_value, Qkey_and_value; |
428 | 89 static Lisp_Object Vall_weak_hash_tables; |
90 static Lisp_Object Qrehash_size, Qrehash_threshold; | |
91 static Lisp_Object Q_size, Q_test, Q_weakness, Q_rehash_size, Q_rehash_threshold; | |
92 | |
93 /* obsolete as of 19990901 in xemacs-21.2 */ | |
442 | 94 static Lisp_Object Qweak, Qkey_weak, Qvalue_weak, Qkey_or_value_weak; |
4820
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
95 static Lisp_Object Qnon_weak, Q_type, Q_data; |
428 | 96 |
97 struct Lisp_Hash_Table | |
98 { | |
3017 | 99 struct LCRECORD_HEADER header; |
665 | 100 Elemcount size; |
101 Elemcount count; | |
102 Elemcount rehash_count; | |
428 | 103 double rehash_size; |
104 double rehash_threshold; | |
665 | 105 Elemcount golden_ratio; |
428 | 106 hash_table_hash_function_t hash_function; |
107 hash_table_test_function_t test_function; | |
1204 | 108 htentry *hentries; |
428 | 109 enum hash_table_weakness weakness; |
110 Lisp_Object next_weak; /* Used to chain together all of the weak | |
111 hash tables. Don't mark through this. */ | |
112 }; | |
113 | |
1204 | 114 #define CLEAR_HTENTRY(htentry) \ |
115 ((*(EMACS_UINT*)(&((htentry)->key))) = 0, \ | |
116 (*(EMACS_UINT*)(&((htentry)->value))) = 0) | |
428 | 117 |
118 #define HASH_TABLE_DEFAULT_SIZE 16 | |
119 #define HASH_TABLE_DEFAULT_REHASH_SIZE 1.3 | |
120 #define HASH_TABLE_MIN_SIZE 10 | |
4778
0081fd36b783
Cast enumerations to int before comparing them for the sake of VC++.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4777
diff
changeset
|
121 #define HASH_TABLE_DEFAULT_REHASH_THRESHOLD(size, test_function) \ |
4779
fd98353950a4
Make my last change to elhash.c more kosher, comparing pointers not ints
Aidan Kehoe <kehoea@parhasard.net>
parents:
4778
diff
changeset
|
122 (((size) > 4096 && NULL == (test_function)) ? 0.7 : 0.6) |
428 | 123 |
665 | 124 #define HASHCODE(key, ht) \ |
444 | 125 ((((ht)->hash_function ? (ht)->hash_function (key) : LISP_HASH (key)) \ |
126 * (ht)->golden_ratio) \ | |
127 % (ht)->size) | |
428 | 128 |
129 #define KEYS_EQUAL_P(key1, key2, testfun) \ | |
434 | 130 (EQ (key1, key2) || ((testfun) && (testfun) (key1, key2))) |
428 | 131 |
132 #define LINEAR_PROBING_LOOP(probe, entries, size) \ | |
133 for (; \ | |
1204 | 134 !HTENTRY_CLEAR_P (probe) || \ |
428 | 135 (probe == entries + size ? \ |
1204 | 136 (probe = entries, !HTENTRY_CLEAR_P (probe)) : 0); \ |
428 | 137 probe++) |
138 | |
800 | 139 #ifdef ERROR_CHECK_STRUCTURES |
428 | 140 static void |
141 check_hash_table_invariants (Lisp_Hash_Table *ht) | |
142 { | |
143 assert (ht->count < ht->size); | |
144 assert (ht->count <= ht->rehash_count); | |
145 assert (ht->rehash_count < ht->size); | |
146 assert ((double) ht->count * ht->rehash_threshold - 1 <= (double) ht->rehash_count); | |
1204 | 147 assert (HTENTRY_CLEAR_P (ht->hentries + ht->size)); |
428 | 148 } |
149 #else | |
150 #define check_hash_table_invariants(ht) | |
151 #endif | |
152 | |
153 /* Return a suitable size for a hash table, with at least SIZE slots. */ | |
665 | 154 static Elemcount |
155 hash_table_size (Elemcount requested_size) | |
428 | 156 { |
157 /* Return some prime near, but greater than or equal to, SIZE. | |
158 Decades from the time of writing, someone will have a system large | |
159 enough that the list below will be too short... */ | |
665 | 160 static const Elemcount primes [] = |
428 | 161 { |
162 19, 29, 41, 59, 79, 107, 149, 197, 263, 347, 457, 599, 787, 1031, | |
163 1361, 1777, 2333, 3037, 3967, 5167, 6719, 8737, 11369, 14783, | |
164 19219, 24989, 32491, 42257, 54941, 71429, 92861, 120721, 156941, | |
165 204047, 265271, 344857, 448321, 582821, 757693, 985003, 1280519, | |
166 1664681, 2164111, 2813353, 3657361, 4754591, 6180989, 8035301, | |
167 10445899, 13579681, 17653589, 22949669, 29834603, 38784989, | |
168 50420551, 65546729, 85210757, 110774011, 144006217, 187208107, | |
169 243370577, 316381771, 411296309, 534685237, 695090819, 903618083, | |
647 | 170 1174703521, 1527114613, 1985248999 /* , 2580823717UL, 3355070839UL */ |
428 | 171 }; |
172 /* We've heard of binary search. */ | |
173 int low, high; | |
174 for (low = 0, high = countof (primes) - 1; high - low > 1;) | |
175 { | |
176 /* Loop Invariant: size < primes [high] */ | |
177 int mid = (low + high) / 2; | |
178 if (primes [mid] < requested_size) | |
179 low = mid; | |
180 else | |
181 high = mid; | |
182 } | |
183 return primes [high]; | |
184 } | |
185 | |
186 | |
187 #if 0 /* I don't think these are needed any more. | |
188 If using the general lisp_object_equal_*() functions | |
189 causes efficiency problems, these can be resurrected. --ben */ | |
190 /* equality and hash functions for Lisp strings */ | |
191 int | |
192 lisp_string_equal (Lisp_Object str1, Lisp_Object str2) | |
193 { | |
194 /* This is wrong anyway. You can't use strcmp() on Lisp strings, | |
195 because they can contain zero characters. */ | |
196 return !strcmp ((char *) XSTRING_DATA (str1), (char *) XSTRING_DATA (str2)); | |
197 } | |
198 | |
665 | 199 static Hashcode |
428 | 200 lisp_string_hash (Lisp_Object obj) |
201 { | |
202 return hash_string (XSTRING_DATA (str), XSTRING_LENGTH (str)); | |
203 } | |
204 | |
205 #endif /* 0 */ | |
206 | |
207 static int | |
208 lisp_object_eql_equal (Lisp_Object obj1, Lisp_Object obj2) | |
209 { | |
4885
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4820
diff
changeset
|
210 return EQ (obj1, obj2) || |
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4820
diff
changeset
|
211 (NON_FIXNUM_NUMBER_P (obj1) && internal_equal (obj1, obj2, 0)); |
428 | 212 } |
213 | |
665 | 214 static Hashcode |
428 | 215 lisp_object_eql_hash (Lisp_Object obj) |
216 { | |
4885
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4820
diff
changeset
|
217 return NON_FIXNUM_NUMBER_P (obj) ? internal_hash (obj, 0) : LISP_HASH (obj); |
428 | 218 } |
219 | |
220 static int | |
221 lisp_object_equal_equal (Lisp_Object obj1, Lisp_Object obj2) | |
222 { | |
223 return internal_equal (obj1, obj2, 0); | |
224 } | |
225 | |
665 | 226 static Hashcode |
428 | 227 lisp_object_equal_hash (Lisp_Object obj) |
228 { | |
229 return internal_hash (obj, 0); | |
230 } | |
231 | |
232 | |
233 static Lisp_Object | |
234 mark_hash_table (Lisp_Object obj) | |
235 { | |
236 Lisp_Hash_Table *ht = XHASH_TABLE (obj); | |
237 | |
238 /* If the hash table is weak, we don't want to mark the keys and | |
239 values (we scan over them after everything else has been marked, | |
240 and mark or remove them as necessary). */ | |
241 if (ht->weakness == HASH_TABLE_NON_WEAK) | |
242 { | |
1204 | 243 htentry *e, *sentinel; |
428 | 244 |
245 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++) | |
1204 | 246 if (!HTENTRY_CLEAR_P (e)) |
428 | 247 { |
248 mark_object (e->key); | |
249 mark_object (e->value); | |
250 } | |
251 } | |
252 return Qnil; | |
253 } | |
254 | |
255 /* Equality of hash tables. Two hash tables are equal when they are of | |
256 the same weakness and test function, they have the same number of | |
257 elements, and for each key in the hash table, the values are `equal'. | |
258 | |
259 This is similar to Common Lisp `equalp' of hash tables, with the | |
260 difference that CL requires the keys to be compared with the test | |
261 function, which we don't do. Doing that would require consing, and | |
262 consing is a bad idea in `equal'. Anyway, our method should provide | |
263 the same result -- if the keys are not equal according to the test | |
264 function, then Fgethash() in hash_table_equal_mapper() will fail. */ | |
265 static int | |
266 hash_table_equal (Lisp_Object hash_table1, Lisp_Object hash_table2, int depth) | |
267 { | |
268 Lisp_Hash_Table *ht1 = XHASH_TABLE (hash_table1); | |
269 Lisp_Hash_Table *ht2 = XHASH_TABLE (hash_table2); | |
1204 | 270 htentry *e, *sentinel; |
428 | 271 |
272 if ((ht1->test_function != ht2->test_function) || | |
273 (ht1->weakness != ht2->weakness) || | |
274 (ht1->count != ht2->count)) | |
275 return 0; | |
276 | |
277 depth++; | |
278 | |
279 for (e = ht1->hentries, sentinel = e + ht1->size; e < sentinel; e++) | |
1204 | 280 if (!HTENTRY_CLEAR_P (e)) |
428 | 281 /* Look up the key in the other hash table, and compare the values. */ |
282 { | |
283 Lisp_Object value_in_other = Fgethash (e->key, hash_table2, Qunbound); | |
284 if (UNBOUNDP (value_in_other) || | |
285 !internal_equal (e->value, value_in_other, depth)) | |
286 return 0; /* Give up */ | |
287 } | |
288 | |
289 return 1; | |
290 } | |
442 | 291 |
292 /* This is not a great hash function, but it _is_ correct and fast. | |
293 Examining all entries is too expensive, and examining a random | |
294 subset does not yield a correct hash function. */ | |
665 | 295 static Hashcode |
2286 | 296 hash_table_hash (Lisp_Object hash_table, int UNUSED (depth)) |
442 | 297 { |
298 return XHASH_TABLE (hash_table)->count; | |
299 } | |
300 | |
428 | 301 |
302 /* Printing hash tables. | |
303 | |
304 This is non-trivial, because we use a readable structure-style | |
305 syntax for hash tables. This means that a typical hash table will be | |
306 readably printed in the form of: | |
307 | |
4820
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
308 #s(hash-table :size 2 :data (key1 value1 key2 value2)) |
428 | 309 |
310 The supported hash table structure keywords and their values are: | |
4820
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
311 `:test' (eql (or nil), eq or equal) |
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
312 `:size' (a natnum or nil) |
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
313 `:rehash-size' (a float) |
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
314 `:rehash-threshold' (a float) |
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
315 `:weakness' (nil, key, value, key-and-value, or key-or-value) |
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
316 `:data' (a list) |
428 | 317 |
430 | 318 If `print-readably' is nil, then a simpler syntax is used, for example |
428 | 319 |
320 #<hash-table size 2/13 data (key1 value1 key2 value2) 0x874d> | |
321 | |
322 The data is truncated to four pairs, and the rest is shown with | |
323 `...'. This printer does not cons. */ | |
324 | |
325 | |
326 /* Print the data of the hash table. This maps through a Lisp | |
327 hash table and prints key/value pairs using PRINTCHARFUN. */ | |
328 static void | |
329 print_hash_table_data (Lisp_Hash_Table *ht, Lisp_Object printcharfun) | |
330 { | |
331 int count = 0; | |
1204 | 332 htentry *e, *sentinel; |
428 | 333 |
4820
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
334 write_c_string (printcharfun, " :data ("); |
428 | 335 |
336 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++) | |
1204 | 337 if (!HTENTRY_CLEAR_P (e)) |
428 | 338 { |
339 if (count > 0) | |
826 | 340 write_c_string (printcharfun, " "); |
428 | 341 if (!print_readably && count > 3) |
342 { | |
826 | 343 write_c_string (printcharfun, "..."); |
428 | 344 break; |
345 } | |
346 print_internal (e->key, printcharfun, 1); | |
800 | 347 write_fmt_string_lisp (printcharfun, " %S", 1, e->value); |
428 | 348 count++; |
349 } | |
350 | |
826 | 351 write_c_string (printcharfun, ")"); |
428 | 352 } |
353 | |
354 static void | |
2286 | 355 print_hash_table (Lisp_Object obj, Lisp_Object printcharfun, |
356 int UNUSED (escapeflag)) | |
428 | 357 { |
358 Lisp_Hash_Table *ht = XHASH_TABLE (obj); | |
4777
c69aeb86b2a3
Serialise non-default hash table rehash thresholds correctly; use this.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
359 Ascbyte pigbuf[350]; |
428 | 360 |
826 | 361 write_c_string (printcharfun, |
362 print_readably ? "#s(hash-table" : "#<hash-table"); | |
428 | 363 |
364 /* These checks have a kludgy look to them, but they are safe. | |
365 Due to nature of hashing, you cannot use arbitrary | |
366 test functions anyway. */ | |
367 if (!ht->test_function) | |
4820
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
368 write_c_string (printcharfun, " :test eq"); |
428 | 369 else if (ht->test_function == lisp_object_equal_equal) |
4820
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
370 write_c_string (printcharfun, " :test equal"); |
428 | 371 else if (ht->test_function == lisp_object_eql_equal) |
372 DO_NOTHING; | |
373 else | |
2500 | 374 ABORT (); |
428 | 375 |
376 if (ht->count || !print_readably) | |
377 { | |
378 if (print_readably) | |
4820
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
379 write_fmt_string (printcharfun, " :size %ld", (long) ht->count); |
428 | 380 else |
4820
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
381 write_fmt_string (printcharfun, " :size %ld/%ld", (long) ht->count, |
800 | 382 (long) ht->size); |
428 | 383 } |
384 | |
385 if (ht->weakness != HASH_TABLE_NON_WEAK) | |
386 { | |
800 | 387 write_fmt_string |
4820
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
388 (printcharfun, " :weakness %s", |
800 | 389 (ht->weakness == HASH_TABLE_WEAK ? "key-and-value" : |
390 ht->weakness == HASH_TABLE_KEY_WEAK ? "key" : | |
391 ht->weakness == HASH_TABLE_VALUE_WEAK ? "value" : | |
392 ht->weakness == HASH_TABLE_KEY_VALUE_WEAK ? "key-or-value" : | |
393 "you-d-better-not-see-this")); | |
428 | 394 } |
395 | |
4777
c69aeb86b2a3
Serialise non-default hash table rehash thresholds correctly; use this.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
396 if (ht->rehash_size != HASH_TABLE_DEFAULT_REHASH_SIZE) |
c69aeb86b2a3
Serialise non-default hash table rehash thresholds correctly; use this.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
397 { |
c69aeb86b2a3
Serialise non-default hash table rehash thresholds correctly; use this.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
398 float_to_string (pigbuf, ht->rehash_size); |
4820
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
399 write_fmt_string (printcharfun, " :rehash-size %s", pigbuf); |
4777
c69aeb86b2a3
Serialise non-default hash table rehash thresholds correctly; use this.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
400 } |
c69aeb86b2a3
Serialise non-default hash table rehash thresholds correctly; use this.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
401 |
c69aeb86b2a3
Serialise non-default hash table rehash thresholds correctly; use this.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
402 if (ht->rehash_threshold |
c69aeb86b2a3
Serialise non-default hash table rehash thresholds correctly; use this.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
403 != HASH_TABLE_DEFAULT_REHASH_THRESHOLD (ht->size, |
c69aeb86b2a3
Serialise non-default hash table rehash thresholds correctly; use this.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
404 ht->test_function)) |
c69aeb86b2a3
Serialise non-default hash table rehash thresholds correctly; use this.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
405 { |
c69aeb86b2a3
Serialise non-default hash table rehash thresholds correctly; use this.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
406 float_to_string (pigbuf, ht->rehash_threshold); |
4820
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
407 write_fmt_string (printcharfun, " :rehash-threshold %s", pigbuf); |
4777
c69aeb86b2a3
Serialise non-default hash table rehash thresholds correctly; use this.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
408 } |
c69aeb86b2a3
Serialise non-default hash table rehash thresholds correctly; use this.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
409 |
428 | 410 if (ht->count) |
411 print_hash_table_data (ht, printcharfun); | |
412 | |
413 if (print_readably) | |
826 | 414 write_c_string (printcharfun, ")"); |
428 | 415 else |
2421 | 416 write_fmt_string (printcharfun, " 0x%x>", ht->header.uid); |
428 | 417 } |
418 | |
4117 | 419 #ifndef NEW_GC |
428 | 420 static void |
4117 | 421 free_hentries (htentry *hentries, |
2333 | 422 #ifdef ERROR_CHECK_STRUCTURES |
423 size_t size | |
4117 | 424 #else /* not ERROR_CHECK_STRUCTURES) */ |
2333 | 425 size_t UNUSED (size) |
4117 | 426 #endif /* not ERROR_CHECK_STRUCTURES) */ |
2333 | 427 ) |
489 | 428 { |
800 | 429 #ifdef ERROR_CHECK_STRUCTURES |
489 | 430 /* Ensure a crash if other code uses the discarded entries afterwards. */ |
1204 | 431 htentry *e, *sentinel; |
489 | 432 |
433 for (e = hentries, sentinel = e + size; e < sentinel; e++) | |
1204 | 434 * (unsigned long *) e = 0xdeadbeef; /* -559038737 base 10 */ |
489 | 435 #endif |
436 | |
437 if (!DUMPEDP (hentries)) | |
1726 | 438 xfree (hentries, htentry *); |
489 | 439 } |
440 | |
441 static void | |
428 | 442 finalize_hash_table (void *header, int for_disksave) |
443 { | |
444 if (!for_disksave) | |
445 { | |
446 Lisp_Hash_Table *ht = (Lisp_Hash_Table *) header; | |
489 | 447 free_hentries (ht->hentries, ht->size); |
428 | 448 ht->hentries = 0; |
449 } | |
450 } | |
3263 | 451 #endif /* not NEW_GC */ |
428 | 452 |
1204 | 453 static const struct memory_description htentry_description_1[] = { |
454 { XD_LISP_OBJECT, offsetof (htentry, key) }, | |
455 { XD_LISP_OBJECT, offsetof (htentry, value) }, | |
428 | 456 { XD_END } |
457 }; | |
458 | |
1204 | 459 static const struct sized_memory_description htentry_description = { |
460 sizeof (htentry), | |
461 htentry_description_1 | |
428 | 462 }; |
463 | |
3092 | 464 #ifdef NEW_GC |
465 static const struct memory_description htentry_weak_description_1[] = { | |
466 { XD_LISP_OBJECT, offsetof (htentry, key), 0, { 0 }, XD_FLAG_NO_KKCC}, | |
467 { XD_LISP_OBJECT, offsetof (htentry, value), 0, { 0 }, XD_FLAG_NO_KKCC}, | |
468 { XD_END } | |
469 }; | |
470 | |
471 static const struct sized_memory_description htentry_weak_description = { | |
472 sizeof (htentry), | |
473 htentry_weak_description_1 | |
474 }; | |
475 | |
476 DEFINE_LRECORD_IMPLEMENTATION ("hash-table-entry", hash_table_entry, | |
477 1, /*dumpable-flag*/ | |
478 0, 0, 0, 0, 0, | |
479 htentry_description_1, | |
480 Lisp_Hash_Table_Entry); | |
481 #endif /* NEW_GC */ | |
482 | |
1204 | 483 static const struct memory_description htentry_union_description_1[] = { |
484 /* Note: XD_INDIRECT in this table refers to the surrounding table, | |
485 and so this will work. */ | |
3092 | 486 #ifdef NEW_GC |
487 { XD_LISP_OBJECT_BLOCK_PTR, HASH_TABLE_NON_WEAK, | |
488 XD_INDIRECT (0, 1), { &htentry_description } }, | |
489 { XD_LISP_OBJECT_BLOCK_PTR, 0, XD_INDIRECT (0, 1), | |
490 { &htentry_weak_description }, XD_FLAG_UNION_DEFAULT_ENTRY }, | |
491 #else /* not NEW_GC */ | |
2367 | 492 { XD_BLOCK_PTR, HASH_TABLE_NON_WEAK, XD_INDIRECT (0, 1), |
2551 | 493 { &htentry_description } }, |
494 { XD_BLOCK_PTR, 0, XD_INDIRECT (0, 1), { &htentry_description }, | |
1204 | 495 XD_FLAG_UNION_DEFAULT_ENTRY | XD_FLAG_NO_KKCC }, |
3092 | 496 #endif /* not NEW_GC */ |
1204 | 497 { XD_END } |
498 }; | |
499 | |
500 static const struct sized_memory_description htentry_union_description = { | |
501 sizeof (htentry *), | |
502 htentry_union_description_1 | |
503 }; | |
504 | |
505 const struct memory_description hash_table_description[] = { | |
506 { XD_ELEMCOUNT, offsetof (Lisp_Hash_Table, size) }, | |
507 { XD_INT, offsetof (Lisp_Hash_Table, weakness) }, | |
508 { XD_UNION, offsetof (Lisp_Hash_Table, hentries), XD_INDIRECT (1, 0), | |
2551 | 509 { &htentry_union_description } }, |
440 | 510 { XD_LO_LINK, offsetof (Lisp_Hash_Table, next_weak) }, |
428 | 511 { XD_END } |
512 }; | |
513 | |
3263 | 514 #ifdef NEW_GC |
515 DEFINE_LRECORD_IMPLEMENTATION ("hash-table", hash_table, | |
516 1, /*dumpable-flag*/ | |
517 mark_hash_table, print_hash_table, | |
518 0, hash_table_equal, hash_table_hash, | |
519 hash_table_description, | |
520 Lisp_Hash_Table); | |
521 #else /* not NEW_GC */ | |
934 | 522 DEFINE_LRECORD_IMPLEMENTATION ("hash-table", hash_table, |
523 1, /*dumpable-flag*/ | |
524 mark_hash_table, print_hash_table, | |
525 finalize_hash_table, | |
526 hash_table_equal, hash_table_hash, | |
527 hash_table_description, | |
528 Lisp_Hash_Table); | |
3263 | 529 #endif /* not NEW_GC */ |
428 | 530 |
531 static Lisp_Hash_Table * | |
532 xhash_table (Lisp_Object hash_table) | |
533 { | |
1123 | 534 /* #### What's going on here? Why the gc_in_progress check? */ |
428 | 535 if (!gc_in_progress) |
536 CHECK_HASH_TABLE (hash_table); | |
537 check_hash_table_invariants (XHASH_TABLE (hash_table)); | |
538 return XHASH_TABLE (hash_table); | |
539 } | |
540 | |
541 | |
542 /************************************************************************/ | |
543 /* Creation of Hash Tables */ | |
544 /************************************************************************/ | |
545 | |
546 /* Creation of hash tables, without error-checking. */ | |
547 static void | |
548 compute_hash_table_derived_values (Lisp_Hash_Table *ht) | |
549 { | |
665 | 550 ht->rehash_count = (Elemcount) |
438 | 551 ((double) ht->size * ht->rehash_threshold); |
665 | 552 ht->golden_ratio = (Elemcount) |
428 | 553 ((double) ht->size * (.6180339887 / (double) sizeof (Lisp_Object))); |
554 } | |
555 | |
556 Lisp_Object | |
450 | 557 make_standard_lisp_hash_table (enum hash_table_test test, |
665 | 558 Elemcount size, |
450 | 559 double rehash_size, |
560 double rehash_threshold, | |
561 enum hash_table_weakness weakness) | |
562 { | |
462 | 563 hash_table_hash_function_t hash_function = 0; |
450 | 564 hash_table_test_function_t test_function = 0; |
565 | |
566 switch (test) | |
567 { | |
568 case HASH_TABLE_EQ: | |
569 test_function = 0; | |
570 hash_function = 0; | |
571 break; | |
572 | |
573 case HASH_TABLE_EQL: | |
574 test_function = lisp_object_eql_equal; | |
575 hash_function = lisp_object_eql_hash; | |
576 break; | |
577 | |
578 case HASH_TABLE_EQUAL: | |
579 test_function = lisp_object_equal_equal; | |
580 hash_function = lisp_object_equal_hash; | |
581 break; | |
582 | |
583 default: | |
2500 | 584 ABORT (); |
450 | 585 } |
586 | |
587 return make_general_lisp_hash_table (hash_function, test_function, | |
588 size, rehash_size, rehash_threshold, | |
589 weakness); | |
590 } | |
591 | |
592 Lisp_Object | |
593 make_general_lisp_hash_table (hash_table_hash_function_t hash_function, | |
594 hash_table_test_function_t test_function, | |
665 | 595 Elemcount size, |
428 | 596 double rehash_size, |
597 double rehash_threshold, | |
598 enum hash_table_weakness weakness) | |
599 { | |
600 Lisp_Object hash_table; | |
3017 | 601 Lisp_Hash_Table *ht = ALLOC_LCRECORD_TYPE (Lisp_Hash_Table, &lrecord_hash_table); |
428 | 602 |
450 | 603 ht->test_function = test_function; |
604 ht->hash_function = hash_function; | |
438 | 605 ht->weakness = weakness; |
606 | |
607 ht->rehash_size = | |
608 rehash_size > 1.0 ? rehash_size : HASH_TABLE_DEFAULT_REHASH_SIZE; | |
609 | |
610 ht->rehash_threshold = | |
611 rehash_threshold > 0.0 ? rehash_threshold : | |
4777
c69aeb86b2a3
Serialise non-default hash table rehash thresholds correctly; use this.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
612 HASH_TABLE_DEFAULT_REHASH_THRESHOLD (size, ht->test_function); |
438 | 613 |
428 | 614 if (size < HASH_TABLE_MIN_SIZE) |
615 size = HASH_TABLE_MIN_SIZE; | |
665 | 616 ht->size = hash_table_size ((Elemcount) (((double) size / ht->rehash_threshold) |
438 | 617 + 1.0)); |
428 | 618 ht->count = 0; |
438 | 619 |
428 | 620 compute_hash_table_derived_values (ht); |
621 | |
1204 | 622 /* We leave room for one never-occupied sentinel htentry at the end. */ |
3092 | 623 #ifdef NEW_GC |
624 ht->hentries = (htentry *) alloc_lrecord_array (sizeof (htentry), | |
625 ht->size + 1, | |
626 &lrecord_hash_table_entry); | |
627 #else /* not NEW_GC */ | |
1204 | 628 ht->hentries = xnew_array_and_zero (htentry, ht->size + 1); |
3092 | 629 #endif /* not NEW_GC */ |
428 | 630 |
793 | 631 hash_table = wrap_hash_table (ht); |
428 | 632 |
633 if (weakness == HASH_TABLE_NON_WEAK) | |
634 ht->next_weak = Qunbound; | |
635 else | |
636 ht->next_weak = Vall_weak_hash_tables, Vall_weak_hash_tables = hash_table; | |
637 | |
638 return hash_table; | |
639 } | |
640 | |
641 Lisp_Object | |
665 | 642 make_lisp_hash_table (Elemcount size, |
428 | 643 enum hash_table_weakness weakness, |
644 enum hash_table_test test) | |
645 { | |
450 | 646 return make_standard_lisp_hash_table (test, size, -1.0, -1.0, weakness); |
428 | 647 } |
648 | |
649 /* Pretty reading of hash tables. | |
650 | |
651 Here we use the existing structures mechanism (which is, | |
652 unfortunately, pretty cumbersome) for validating and instantiating | |
653 the hash tables. The idea is that the side-effect of reading a | |
654 #s(hash-table PLIST) object is creation of a hash table with desired | |
655 properties, and that the hash table is returned. */ | |
656 | |
657 /* Validation functions: each keyword provides its own validation | |
658 function. The errors should maybe be continuable, but it is | |
659 unclear how this would cope with ERRB. */ | |
660 static int | |
2286 | 661 hash_table_size_validate (Lisp_Object UNUSED (keyword), Lisp_Object value, |
662 Error_Behavior errb) | |
428 | 663 { |
664 if (NATNUMP (value)) | |
665 return 1; | |
666 | |
563 | 667 maybe_signal_error_1 (Qwrong_type_argument, list2 (Qnatnump, value), |
2286 | 668 Qhash_table, errb); |
428 | 669 return 0; |
670 } | |
671 | |
665 | 672 static Elemcount |
428 | 673 decode_hash_table_size (Lisp_Object obj) |
674 { | |
675 return NILP (obj) ? HASH_TABLE_DEFAULT_SIZE : XINT (obj); | |
676 } | |
677 | |
678 static int | |
2286 | 679 hash_table_weakness_validate (Lisp_Object UNUSED (keyword), Lisp_Object value, |
578 | 680 Error_Behavior errb) |
428 | 681 { |
442 | 682 if (EQ (value, Qnil)) return 1; |
683 if (EQ (value, Qt)) return 1; | |
684 if (EQ (value, Qkey)) return 1; | |
685 if (EQ (value, Qkey_and_value)) return 1; | |
686 if (EQ (value, Qkey_or_value)) return 1; | |
687 if (EQ (value, Qvalue)) return 1; | |
428 | 688 |
689 /* Following values are obsolete as of 19990901 in xemacs-21.2 */ | |
442 | 690 if (EQ (value, Qnon_weak)) return 1; |
691 if (EQ (value, Qweak)) return 1; | |
692 if (EQ (value, Qkey_weak)) return 1; | |
693 if (EQ (value, Qkey_or_value_weak)) return 1; | |
694 if (EQ (value, Qvalue_weak)) return 1; | |
428 | 695 |
563 | 696 maybe_invalid_constant ("Invalid hash table weakness", |
428 | 697 value, Qhash_table, errb); |
698 return 0; | |
699 } | |
700 | |
701 static enum hash_table_weakness | |
702 decode_hash_table_weakness (Lisp_Object obj) | |
703 { | |
442 | 704 if (EQ (obj, Qnil)) return HASH_TABLE_NON_WEAK; |
705 if (EQ (obj, Qt)) return HASH_TABLE_WEAK; | |
706 if (EQ (obj, Qkey_and_value)) return HASH_TABLE_WEAK; | |
707 if (EQ (obj, Qkey)) return HASH_TABLE_KEY_WEAK; | |
708 if (EQ (obj, Qkey_or_value)) return HASH_TABLE_KEY_VALUE_WEAK; | |
709 if (EQ (obj, Qvalue)) return HASH_TABLE_VALUE_WEAK; | |
428 | 710 |
711 /* Following values are obsolete as of 19990901 in xemacs-21.2 */ | |
442 | 712 if (EQ (obj, Qnon_weak)) return HASH_TABLE_NON_WEAK; |
713 if (EQ (obj, Qweak)) return HASH_TABLE_WEAK; | |
714 if (EQ (obj, Qkey_weak)) return HASH_TABLE_KEY_WEAK; | |
715 if (EQ (obj, Qkey_or_value_weak)) return HASH_TABLE_KEY_VALUE_WEAK; | |
716 if (EQ (obj, Qvalue_weak)) return HASH_TABLE_VALUE_WEAK; | |
428 | 717 |
563 | 718 invalid_constant ("Invalid hash table weakness", obj); |
1204 | 719 RETURN_NOT_REACHED (HASH_TABLE_NON_WEAK); |
428 | 720 } |
721 | |
722 static int | |
2286 | 723 hash_table_test_validate (Lisp_Object UNUSED (keyword), Lisp_Object value, |
724 Error_Behavior errb) | |
428 | 725 { |
726 if (EQ (value, Qnil)) return 1; | |
727 if (EQ (value, Qeq)) return 1; | |
728 if (EQ (value, Qequal)) return 1; | |
729 if (EQ (value, Qeql)) return 1; | |
730 | |
563 | 731 maybe_invalid_constant ("Invalid hash table test", |
2286 | 732 value, Qhash_table, errb); |
428 | 733 return 0; |
734 } | |
735 | |
736 static enum hash_table_test | |
737 decode_hash_table_test (Lisp_Object obj) | |
738 { | |
739 if (EQ (obj, Qnil)) return HASH_TABLE_EQL; | |
740 if (EQ (obj, Qeq)) return HASH_TABLE_EQ; | |
741 if (EQ (obj, Qequal)) return HASH_TABLE_EQUAL; | |
742 if (EQ (obj, Qeql)) return HASH_TABLE_EQL; | |
743 | |
563 | 744 invalid_constant ("Invalid hash table test", obj); |
1204 | 745 RETURN_NOT_REACHED (HASH_TABLE_EQ); |
428 | 746 } |
747 | |
748 static int | |
2286 | 749 hash_table_rehash_size_validate (Lisp_Object UNUSED (keyword), |
750 Lisp_Object value, Error_Behavior errb) | |
428 | 751 { |
752 if (!FLOATP (value)) | |
753 { | |
563 | 754 maybe_signal_error_1 (Qwrong_type_argument, list2 (Qfloatp, value), |
428 | 755 Qhash_table, errb); |
756 return 0; | |
757 } | |
758 | |
759 { | |
760 double rehash_size = XFLOAT_DATA (value); | |
761 if (rehash_size <= 1.0) | |
762 { | |
563 | 763 maybe_invalid_argument |
428 | 764 ("Hash table rehash size must be greater than 1.0", |
765 value, Qhash_table, errb); | |
766 return 0; | |
767 } | |
768 } | |
769 | |
770 return 1; | |
771 } | |
772 | |
773 static double | |
774 decode_hash_table_rehash_size (Lisp_Object rehash_size) | |
775 { | |
4585
871eb054b34a
Document non-obvious usages.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4410
diff
changeset
|
776 /* -1.0 signals make_general_lisp_hash_table to use the default. */ |
428 | 777 return NILP (rehash_size) ? -1.0 : XFLOAT_DATA (rehash_size); |
778 } | |
779 | |
780 static int | |
2286 | 781 hash_table_rehash_threshold_validate (Lisp_Object UNUSED (keyword), |
782 Lisp_Object value, Error_Behavior errb) | |
428 | 783 { |
784 if (!FLOATP (value)) | |
785 { | |
563 | 786 maybe_signal_error_1 (Qwrong_type_argument, list2 (Qfloatp, value), |
428 | 787 Qhash_table, errb); |
788 return 0; | |
789 } | |
790 | |
791 { | |
792 double rehash_threshold = XFLOAT_DATA (value); | |
793 if (rehash_threshold <= 0.0 || rehash_threshold >= 1.0) | |
794 { | |
563 | 795 maybe_invalid_argument |
428 | 796 ("Hash table rehash threshold must be between 0.0 and 1.0", |
797 value, Qhash_table, errb); | |
798 return 0; | |
799 } | |
800 } | |
801 | |
802 return 1; | |
803 } | |
804 | |
805 static double | |
806 decode_hash_table_rehash_threshold (Lisp_Object rehash_threshold) | |
807 { | |
4585
871eb054b34a
Document non-obvious usages.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4410
diff
changeset
|
808 /* -1.0 signals make_general_lisp_hash_table to use the default. */ |
428 | 809 return NILP (rehash_threshold) ? -1.0 : XFLOAT_DATA (rehash_threshold); |
810 } | |
811 | |
812 static int | |
2286 | 813 hash_table_data_validate (Lisp_Object UNUSED (keyword), Lisp_Object value, |
814 Error_Behavior errb) | |
428 | 815 { |
816 int len; | |
817 | |
4585
871eb054b34a
Document non-obvious usages.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4410
diff
changeset
|
818 /* Check for improper lists while getting length. */ |
428 | 819 GET_EXTERNAL_LIST_LENGTH (value, len); |
820 | |
821 if (len & 1) | |
822 { | |
563 | 823 maybe_sferror |
428 | 824 ("Hash table data must have alternating key/value pairs", |
825 value, Qhash_table, errb); | |
826 return 0; | |
827 } | |
4585
871eb054b34a
Document non-obvious usages.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4410
diff
changeset
|
828 |
428 | 829 return 1; |
830 } | |
831 | |
832 /* The actual instantiation of a hash table. This does practically no | |
833 error checking, because it relies on the fact that the paranoid | |
834 functions above have error-checked everything to the last details. | |
835 If this assumption is wrong, we will get a crash immediately (with | |
836 error-checking compiled in), and we'll know if there is a bug in | |
837 the structure mechanism. So there. */ | |
838 static Lisp_Object | |
839 hash_table_instantiate (Lisp_Object plist) | |
840 { | |
841 Lisp_Object hash_table; | |
842 Lisp_Object test = Qnil; | |
843 Lisp_Object size = Qnil; | |
844 Lisp_Object rehash_size = Qnil; | |
845 Lisp_Object rehash_threshold = Qnil; | |
846 Lisp_Object weakness = Qnil; | |
847 Lisp_Object data = Qnil; | |
848 | |
4820
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
849 if (KEYWORDP (Fcar (plist))) |
428 | 850 { |
4820
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
851 PROPERTY_LIST_LOOP_3 (key, value, plist) |
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
852 { |
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
853 if (EQ (key, Q_test)) test = value; |
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
854 else if (EQ (key, Q_size)) size = value; |
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
855 else if (EQ (key, Q_rehash_size)) rehash_size = value; |
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
856 else if (EQ (key, Q_rehash_threshold)) rehash_threshold = value; |
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
857 else if (EQ (key, Q_weakness)) weakness = value; |
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
858 else if (EQ (key, Q_data)) data = value; |
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
859 else if (!KEYWORDP (key)) |
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
860 signal_error (Qinvalid_read_syntax, |
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
861 "can't mix keyword and non-keyword hash table syntax", |
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
862 key); |
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
863 else ABORT(); |
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
864 } |
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
865 } |
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
866 else |
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
867 { |
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
868 PROPERTY_LIST_LOOP_3 (key, value, plist) |
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
869 { |
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
870 if (EQ (key, Qtest)) test = value; |
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
871 else if (EQ (key, Qsize)) size = value; |
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
872 else if (EQ (key, Qrehash_size)) rehash_size = value; |
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
873 else if (EQ (key, Qrehash_threshold)) rehash_threshold = value; |
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
874 else if (EQ (key, Qweakness)) weakness = value; |
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
875 else if (EQ (key, Qdata)) data = value; |
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
876 else if (EQ (key, Qtype))/*obsolete*/ weakness = value; |
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
877 else if (KEYWORDP (key)) |
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
878 signal_error (Qinvalid_read_syntax, |
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
879 "can't mix keyword and non-keyword hash table syntax", |
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
880 key); |
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
881 else ABORT(); |
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
882 } |
428 | 883 } |
884 | |
885 /* Create the hash table. */ | |
450 | 886 hash_table = make_standard_lisp_hash_table |
428 | 887 (decode_hash_table_test (test), |
888 decode_hash_table_size (size), | |
889 decode_hash_table_rehash_size (rehash_size), | |
890 decode_hash_table_rehash_threshold (rehash_threshold), | |
891 decode_hash_table_weakness (weakness)); | |
892 | |
893 /* I'm not sure whether this can GC, but better safe than sorry. */ | |
894 { | |
895 struct gcpro gcpro1; | |
896 GCPRO1 (hash_table); | |
897 | |
898 /* And fill it with data. */ | |
899 while (!NILP (data)) | |
900 { | |
901 Lisp_Object key, value; | |
902 key = XCAR (data); data = XCDR (data); | |
903 value = XCAR (data); data = XCDR (data); | |
904 Fputhash (key, value, hash_table); | |
905 } | |
906 UNGCPRO; | |
907 } | |
908 | |
909 return hash_table; | |
910 } | |
911 | |
912 static void | |
913 structure_type_create_hash_table_structure_name (Lisp_Object structure_name) | |
914 { | |
915 struct structure_type *st; | |
916 | |
917 st = define_structure_type (structure_name, 0, hash_table_instantiate); | |
4820
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
918 |
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
919 /* First the keyword syntax: */ |
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
920 define_structure_type_keyword (st, Q_test, hash_table_test_validate); |
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
921 define_structure_type_keyword (st, Q_size, hash_table_size_validate); |
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
922 define_structure_type_keyword (st, Q_rehash_size, hash_table_rehash_size_validate); |
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
923 define_structure_type_keyword (st, Q_rehash_threshold, hash_table_rehash_threshold_validate); |
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
924 define_structure_type_keyword (st, Q_weakness, hash_table_weakness_validate); |
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
925 define_structure_type_keyword (st, Q_data, hash_table_data_validate); |
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
926 |
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
927 /* Next the mutually exclusive, older, non-keyword syntax: */ |
428 | 928 define_structure_type_keyword (st, Qtest, hash_table_test_validate); |
929 define_structure_type_keyword (st, Qsize, hash_table_size_validate); | |
930 define_structure_type_keyword (st, Qrehash_size, hash_table_rehash_size_validate); | |
931 define_structure_type_keyword (st, Qrehash_threshold, hash_table_rehash_threshold_validate); | |
932 define_structure_type_keyword (st, Qweakness, hash_table_weakness_validate); | |
933 define_structure_type_keyword (st, Qdata, hash_table_data_validate); | |
934 | |
935 /* obsolete as of 19990901 in xemacs-21.2 */ | |
936 define_structure_type_keyword (st, Qtype, hash_table_weakness_validate); | |
937 } | |
938 | |
939 /* Create a built-in Lisp structure type named `hash-table'. | |
940 We make #s(hashtable ...) equivalent to #s(hash-table ...), | |
941 for backward compatibility. | |
942 This is called from emacs.c. */ | |
943 void | |
944 structure_type_create_hash_table (void) | |
945 { | |
946 structure_type_create_hash_table_structure_name (Qhash_table); | |
947 structure_type_create_hash_table_structure_name (Qhashtable); /* compat */ | |
948 } | |
949 | |
950 | |
951 /************************************************************************/ | |
952 /* Definition of Lisp-visible methods */ | |
953 /************************************************************************/ | |
954 | |
955 DEFUN ("hash-table-p", Fhash_table_p, 1, 1, 0, /* | |
956 Return t if OBJECT is a hash table, else nil. | |
957 */ | |
958 (object)) | |
959 { | |
960 return HASH_TABLEP (object) ? Qt : Qnil; | |
961 } | |
962 | |
963 DEFUN ("make-hash-table", Fmake_hash_table, 0, MANY, 0, /* | |
964 Return a new empty hash table object. | |
965 Use Common Lisp style keywords to specify hash table properties. | |
966 | |
967 Keyword :test can be `eq', `eql' (default) or `equal'. | |
968 Comparison between keys is done using this function. | |
969 If speed is important, consider using `eq'. | |
970 When storing strings in the hash table, you will likely need to use `equal'. | |
971 | |
972 Keyword :size specifies the number of keys likely to be inserted. | |
973 This number of entries can be inserted without enlarging the hash table. | |
974 | |
975 Keyword :rehash-size must be a float greater than 1.0, and specifies | |
976 the factor by which to increase the size of the hash table when enlarging. | |
977 | |
978 Keyword :rehash-threshold must be a float between 0.0 and 1.0, | |
979 and specifies the load factor of the hash table which triggers enlarging. | |
980 | |
442 | 981 Non-standard keyword :weakness can be `nil' (default), `t', `key-and-value', |
982 `key', `value' or `key-or-value'. `t' is an alias for `key-and-value'. | |
428 | 983 |
442 | 984 A key-and-value-weak hash table, also known as a fully-weak or simply |
985 as a weak hash table, is one whose pointers do not count as GC | |
986 referents: for any key-value pair in the hash table, if the only | |
987 remaining pointer to either the key or the value is in a weak hash | |
988 table, then the pair will be removed from the hash table, and the key | |
989 and value collected. A non-weak hash table (or any other pointer) | |
990 would prevent the object from being collected. | |
428 | 991 |
992 A key-weak hash table is similar to a fully-weak hash table except that | |
993 a key-value pair will be removed only if the key remains unmarked | |
994 outside of weak hash tables. The pair will remain in the hash table if | |
995 the key is pointed to by something other than a weak hash table, even | |
996 if the value is not. | |
997 | |
998 A value-weak hash table is similar to a fully-weak hash table except | |
999 that a key-value pair will be removed only if the value remains | |
1000 unmarked outside of weak hash tables. The pair will remain in the | |
1001 hash table if the value is pointed to by something other than a weak | |
1002 hash table, even if the key is not. | |
442 | 1003 |
1004 A key-or-value-weak hash table is similar to a fully-weak hash table except | |
1005 that a key-value pair will be removed only if the value and the key remain | |
1006 unmarked outside of weak hash tables. The pair will remain in the | |
1007 hash table if the value or key are pointed to by something other than a weak | |
1008 hash table, even if the other is not. | |
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4585
diff
changeset
|
1009 |
4777
c69aeb86b2a3
Serialise non-default hash table rehash thresholds correctly; use this.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
1010 arguments: (&key TEST SIZE REHASH-SIZE REHASH-THRESHOLD WEAKNESS) |
428 | 1011 */ |
1012 (int nargs, Lisp_Object *args)) | |
1013 { | |
1014 int i = 0; | |
1015 Lisp_Object test = Qnil; | |
1016 Lisp_Object size = Qnil; | |
1017 Lisp_Object rehash_size = Qnil; | |
1018 Lisp_Object rehash_threshold = Qnil; | |
1019 Lisp_Object weakness = Qnil; | |
1020 | |
1021 while (i + 1 < nargs) | |
1022 { | |
1023 Lisp_Object keyword = args[i++]; | |
1024 Lisp_Object value = args[i++]; | |
1025 | |
1026 if (EQ (keyword, Q_test)) test = value; | |
1027 else if (EQ (keyword, Q_size)) size = value; | |
1028 else if (EQ (keyword, Q_rehash_size)) rehash_size = value; | |
1029 else if (EQ (keyword, Q_rehash_threshold)) rehash_threshold = value; | |
1030 else if (EQ (keyword, Q_weakness)) weakness = value; | |
1031 else if (EQ (keyword, Q_type))/*obsolete*/ weakness = value; | |
563 | 1032 else invalid_constant ("Invalid hash table property keyword", keyword); |
428 | 1033 } |
1034 | |
1035 if (i < nargs) | |
563 | 1036 sferror ("Hash table property requires a value", args[i]); |
428 | 1037 |
1038 #define VALIDATE_VAR(var) \ | |
1039 if (!NILP (var)) hash_table_##var##_validate (Q##var, var, ERROR_ME); | |
1040 | |
1041 VALIDATE_VAR (test); | |
1042 VALIDATE_VAR (size); | |
1043 VALIDATE_VAR (rehash_size); | |
1044 VALIDATE_VAR (rehash_threshold); | |
1045 VALIDATE_VAR (weakness); | |
1046 | |
450 | 1047 return make_standard_lisp_hash_table |
428 | 1048 (decode_hash_table_test (test), |
1049 decode_hash_table_size (size), | |
1050 decode_hash_table_rehash_size (rehash_size), | |
1051 decode_hash_table_rehash_threshold (rehash_threshold), | |
1052 decode_hash_table_weakness (weakness)); | |
1053 } | |
1054 | |
1055 DEFUN ("copy-hash-table", Fcopy_hash_table, 1, 1, 0, /* | |
1056 Return a new hash table containing the same keys and values as HASH-TABLE. | |
1057 The keys and values will not themselves be copied. | |
1058 */ | |
1059 (hash_table)) | |
1060 { | |
442 | 1061 const Lisp_Hash_Table *ht_old = xhash_table (hash_table); |
3017 | 1062 Lisp_Hash_Table *ht = ALLOC_LCRECORD_TYPE (Lisp_Hash_Table, &lrecord_hash_table); |
1063 COPY_LCRECORD (ht, ht_old); | |
428 | 1064 |
3092 | 1065 #ifdef NEW_GC |
1066 ht->hentries = (htentry *) alloc_lrecord_array (sizeof (htentry), | |
1067 ht_old->size + 1, | |
1068 &lrecord_hash_table_entry); | |
1069 #else /* not NEW_GC */ | |
1204 | 1070 ht->hentries = xnew_array (htentry, ht_old->size + 1); |
3092 | 1071 #endif /* not NEW_GC */ |
1204 | 1072 memcpy (ht->hentries, ht_old->hentries, (ht_old->size + 1) * sizeof (htentry)); |
428 | 1073 |
793 | 1074 hash_table = wrap_hash_table (ht); |
428 | 1075 |
1076 if (! EQ (ht->next_weak, Qunbound)) | |
1077 { | |
1078 ht->next_weak = Vall_weak_hash_tables; | |
1079 Vall_weak_hash_tables = hash_table; | |
1080 } | |
1081 | |
1082 return hash_table; | |
1083 } | |
1084 | |
1085 static void | |
665 | 1086 resize_hash_table (Lisp_Hash_Table *ht, Elemcount new_size) |
428 | 1087 { |
1204 | 1088 htentry *old_entries, *new_entries, *sentinel, *e; |
665 | 1089 Elemcount old_size; |
428 | 1090 |
1091 old_size = ht->size; | |
1092 ht->size = new_size; | |
1093 | |
1094 old_entries = ht->hentries; | |
1095 | |
3092 | 1096 #ifdef NEW_GC |
1097 ht->hentries = (htentry *) alloc_lrecord_array (sizeof (htentry), | |
1098 new_size + 1, | |
1099 &lrecord_hash_table_entry); | |
1100 #else /* not NEW_GC */ | |
1204 | 1101 ht->hentries = xnew_array_and_zero (htentry, new_size + 1); |
3092 | 1102 #endif /* not NEW_GC */ |
428 | 1103 new_entries = ht->hentries; |
1104 | |
1105 compute_hash_table_derived_values (ht); | |
1106 | |
440 | 1107 for (e = old_entries, sentinel = e + old_size; e < sentinel; e++) |
1204 | 1108 if (!HTENTRY_CLEAR_P (e)) |
428 | 1109 { |
1204 | 1110 htentry *probe = new_entries + HASHCODE (e->key, ht); |
428 | 1111 LINEAR_PROBING_LOOP (probe, new_entries, new_size) |
1112 ; | |
1113 *probe = *e; | |
1114 } | |
1115 | |
4117 | 1116 #ifndef NEW_GC |
489 | 1117 free_hentries (old_entries, old_size); |
4117 | 1118 #endif /* not NEW_GC */ |
428 | 1119 } |
1120 | |
440 | 1121 /* After a hash table has been saved to disk and later restored by the |
1122 portable dumper, it contains the same objects, but their addresses | |
665 | 1123 and thus their HASHCODEs have changed. */ |
428 | 1124 void |
440 | 1125 pdump_reorganize_hash_table (Lisp_Object hash_table) |
428 | 1126 { |
442 | 1127 const Lisp_Hash_Table *ht = xhash_table (hash_table); |
3092 | 1128 #ifdef NEW_GC |
1129 htentry *new_entries = | |
1130 (htentry *) alloc_lrecord_array (sizeof (htentry), ht->size + 1, | |
1131 &lrecord_hash_table_entry); | |
1132 #else /* not NEW_GC */ | |
1204 | 1133 htentry *new_entries = xnew_array_and_zero (htentry, ht->size + 1); |
3092 | 1134 #endif /* not NEW_GC */ |
1204 | 1135 htentry *e, *sentinel; |
440 | 1136 |
1137 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++) | |
1204 | 1138 if (!HTENTRY_CLEAR_P (e)) |
440 | 1139 { |
1204 | 1140 htentry *probe = new_entries + HASHCODE (e->key, ht); |
440 | 1141 LINEAR_PROBING_LOOP (probe, new_entries, ht->size) |
1142 ; | |
1143 *probe = *e; | |
1144 } | |
1145 | |
1204 | 1146 memcpy (ht->hentries, new_entries, ht->size * sizeof (htentry)); |
440 | 1147 |
4117 | 1148 #ifndef NEW_GC |
1726 | 1149 xfree (new_entries, htentry *); |
3092 | 1150 #endif /* not NEW_GC */ |
428 | 1151 } |
1152 | |
1153 static void | |
1154 enlarge_hash_table (Lisp_Hash_Table *ht) | |
1155 { | |
665 | 1156 Elemcount new_size = |
1157 hash_table_size ((Elemcount) ((double) ht->size * ht->rehash_size)); | |
428 | 1158 resize_hash_table (ht, new_size); |
1159 } | |
1160 | |
4072 | 1161 htentry * |
1204 | 1162 find_htentry (Lisp_Object key, const Lisp_Hash_Table *ht) |
428 | 1163 { |
1164 hash_table_test_function_t test_function = ht->test_function; | |
1204 | 1165 htentry *entries = ht->hentries; |
1166 htentry *probe = entries + HASHCODE (key, ht); | |
428 | 1167 |
1168 LINEAR_PROBING_LOOP (probe, entries, ht->size) | |
1169 if (KEYS_EQUAL_P (probe->key, key, test_function)) | |
1170 break; | |
1171 | |
1172 return probe; | |
1173 } | |
1174 | |
2421 | 1175 /* A version of Fputhash() that increments the value by the specified |
1176 amount and dispenses will all error checks. Assumes that tables does | |
1177 comparison using EQ. Used by the profiling routines to avoid | |
1178 overhead -- profiling overhead was being recorded at up to 15% of the | |
1179 total time. */ | |
1180 | |
1181 void | |
1182 inchash_eq (Lisp_Object key, Lisp_Object table, EMACS_INT offset) | |
1183 { | |
1184 Lisp_Hash_Table *ht = XHASH_TABLE (table); | |
1185 htentry *entries = ht->hentries; | |
1186 htentry *probe = entries + HASHCODE (key, ht); | |
1187 | |
1188 LINEAR_PROBING_LOOP (probe, entries, ht->size) | |
1189 if (EQ (probe->key, key)) | |
1190 break; | |
1191 | |
1192 if (!HTENTRY_CLEAR_P (probe)) | |
1193 probe->value = make_int (XINT (probe->value) + offset); | |
1194 else | |
1195 { | |
1196 probe->key = key; | |
1197 probe->value = make_int (offset); | |
1198 | |
1199 if (++ht->count >= ht->rehash_count) | |
1200 enlarge_hash_table (ht); | |
1201 } | |
1202 } | |
1203 | |
428 | 1204 DEFUN ("gethash", Fgethash, 2, 3, 0, /* |
1205 Find hash value for KEY in HASH-TABLE. | |
1206 If there is no corresponding value, return DEFAULT (which defaults to nil). | |
1207 */ | |
1208 (key, hash_table, default_)) | |
1209 { | |
442 | 1210 const Lisp_Hash_Table *ht = xhash_table (hash_table); |
1204 | 1211 htentry *e = find_htentry (key, ht); |
428 | 1212 |
1204 | 1213 return HTENTRY_CLEAR_P (e) ? default_ : e->value; |
428 | 1214 } |
1215 | |
1216 DEFUN ("puthash", Fputhash, 3, 3, 0, /* | |
4410
aae1994dfeec
Document return values for #'puthash, #'clrhash.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4398
diff
changeset
|
1217 Hash KEY to VALUE in HASH-TABLE, and return VALUE. |
428 | 1218 */ |
1219 (key, value, hash_table)) | |
1220 { | |
1221 Lisp_Hash_Table *ht = xhash_table (hash_table); | |
1204 | 1222 htentry *e = find_htentry (key, ht); |
428 | 1223 |
1204 | 1224 if (!HTENTRY_CLEAR_P (e)) |
428 | 1225 return e->value = value; |
1226 | |
1227 e->key = key; | |
1228 e->value = value; | |
1229 | |
1230 if (++ht->count >= ht->rehash_count) | |
1231 enlarge_hash_table (ht); | |
1232 | |
1233 return value; | |
1234 } | |
1235 | |
1204 | 1236 /* Remove htentry pointed at by PROBE. |
428 | 1237 Subsequent entries are removed and reinserted. |
1238 We don't use tombstones - too wasteful. */ | |
1239 static void | |
1204 | 1240 remhash_1 (Lisp_Hash_Table *ht, htentry *entries, htentry *probe) |
428 | 1241 { |
665 | 1242 Elemcount size = ht->size; |
1204 | 1243 CLEAR_HTENTRY (probe); |
428 | 1244 probe++; |
1245 ht->count--; | |
1246 | |
1247 LINEAR_PROBING_LOOP (probe, entries, size) | |
1248 { | |
1249 Lisp_Object key = probe->key; | |
1204 | 1250 htentry *probe2 = entries + HASHCODE (key, ht); |
428 | 1251 LINEAR_PROBING_LOOP (probe2, entries, size) |
1252 if (EQ (probe2->key, key)) | |
1204 | 1253 /* htentry at probe doesn't need to move. */ |
428 | 1254 goto continue_outer_loop; |
1204 | 1255 /* Move htentry from probe to new home at probe2. */ |
428 | 1256 *probe2 = *probe; |
1204 | 1257 CLEAR_HTENTRY (probe); |
428 | 1258 continue_outer_loop: continue; |
1259 } | |
1260 } | |
1261 | |
1262 DEFUN ("remhash", Fremhash, 2, 2, 0, /* | |
1263 Remove the entry for KEY from HASH-TABLE. | |
1264 Do nothing if there is no entry for KEY in HASH-TABLE. | |
617 | 1265 Return non-nil if an entry was removed. |
428 | 1266 */ |
1267 (key, hash_table)) | |
1268 { | |
1269 Lisp_Hash_Table *ht = xhash_table (hash_table); | |
1204 | 1270 htentry *e = find_htentry (key, ht); |
428 | 1271 |
1204 | 1272 if (HTENTRY_CLEAR_P (e)) |
428 | 1273 return Qnil; |
1274 | |
1275 remhash_1 (ht, ht->hentries, e); | |
1276 return Qt; | |
1277 } | |
1278 | |
1279 DEFUN ("clrhash", Fclrhash, 1, 1, 0, /* | |
1280 Remove all entries from HASH-TABLE, leaving it empty. | |
4410
aae1994dfeec
Document return values for #'puthash, #'clrhash.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4398
diff
changeset
|
1281 Return HASH-TABLE. |
428 | 1282 */ |
1283 (hash_table)) | |
1284 { | |
1285 Lisp_Hash_Table *ht = xhash_table (hash_table); | |
1204 | 1286 htentry *e, *sentinel; |
428 | 1287 |
1288 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++) | |
1204 | 1289 CLEAR_HTENTRY (e); |
428 | 1290 ht->count = 0; |
1291 | |
1292 return hash_table; | |
1293 } | |
1294 | |
1295 /************************************************************************/ | |
1296 /* Accessor Functions */ | |
1297 /************************************************************************/ | |
1298 | |
1299 DEFUN ("hash-table-count", Fhash_table_count, 1, 1, 0, /* | |
1300 Return the number of entries in HASH-TABLE. | |
1301 */ | |
1302 (hash_table)) | |
1303 { | |
1304 return make_int (xhash_table (hash_table)->count); | |
1305 } | |
1306 | |
1307 DEFUN ("hash-table-test", Fhash_table_test, 1, 1, 0, /* | |
1308 Return the test function of HASH-TABLE. | |
1309 This can be one of `eq', `eql' or `equal'. | |
1310 */ | |
1311 (hash_table)) | |
1312 { | |
1313 hash_table_test_function_t fun = xhash_table (hash_table)->test_function; | |
1314 | |
1315 return (fun == lisp_object_eql_equal ? Qeql : | |
1316 fun == lisp_object_equal_equal ? Qequal : | |
1317 Qeq); | |
1318 } | |
1319 | |
1320 DEFUN ("hash-table-size", Fhash_table_size, 1, 1, 0, /* | |
1321 Return the size of HASH-TABLE. | |
1322 This is the current number of slots in HASH-TABLE, whether occupied or not. | |
1323 */ | |
1324 (hash_table)) | |
1325 { | |
1326 return make_int (xhash_table (hash_table)->size); | |
1327 } | |
1328 | |
1329 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size, 1, 1, 0, /* | |
1330 Return the current rehash size of HASH-TABLE. | |
1331 This is a float greater than 1.0; the factor by which HASH-TABLE | |
1332 is enlarged when the rehash threshold is exceeded. | |
1333 */ | |
1334 (hash_table)) | |
1335 { | |
1336 return make_float (xhash_table (hash_table)->rehash_size); | |
1337 } | |
1338 | |
1339 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold, 1, 1, 0, /* | |
1340 Return the current rehash threshold of HASH-TABLE. | |
1341 This is a float between 0.0 and 1.0; the maximum `load factor' of HASH-TABLE, | |
1342 beyond which the HASH-TABLE is enlarged by rehashing. | |
1343 */ | |
1344 (hash_table)) | |
1345 { | |
438 | 1346 return make_float (xhash_table (hash_table)->rehash_threshold); |
428 | 1347 } |
1348 | |
1349 DEFUN ("hash-table-weakness", Fhash_table_weakness, 1, 1, 0, /* | |
1350 Return the weakness of HASH-TABLE. | |
442 | 1351 This can be one of `nil', `key-and-value', `key-or-value', `key' or `value'. |
428 | 1352 */ |
1353 (hash_table)) | |
1354 { | |
1355 switch (xhash_table (hash_table)->weakness) | |
1356 { | |
442 | 1357 case HASH_TABLE_WEAK: return Qkey_and_value; |
1358 case HASH_TABLE_KEY_WEAK: return Qkey; | |
1359 case HASH_TABLE_KEY_VALUE_WEAK: return Qkey_or_value; | |
1360 case HASH_TABLE_VALUE_WEAK: return Qvalue; | |
1361 default: return Qnil; | |
428 | 1362 } |
1363 } | |
1364 | |
1365 /* obsolete as of 19990901 in xemacs-21.2 */ | |
1366 DEFUN ("hash-table-type", Fhash_table_type, 1, 1, 0, /* | |
1367 Return the type of HASH-TABLE. | |
1368 This can be one of `non-weak', `weak', `key-weak' or `value-weak'. | |
1369 */ | |
1370 (hash_table)) | |
1371 { | |
1372 switch (xhash_table (hash_table)->weakness) | |
1373 { | |
442 | 1374 case HASH_TABLE_WEAK: return Qweak; |
1375 case HASH_TABLE_KEY_WEAK: return Qkey_weak; | |
1376 case HASH_TABLE_KEY_VALUE_WEAK: return Qkey_or_value_weak; | |
1377 case HASH_TABLE_VALUE_WEAK: return Qvalue_weak; | |
1378 default: return Qnon_weak; | |
428 | 1379 } |
1380 } | |
1381 | |
1382 /************************************************************************/ | |
1383 /* Mapping Functions */ | |
1384 /************************************************************************/ | |
489 | 1385 |
1386 /* We need to be careful when mapping over hash tables because the | |
1387 hash table might be modified during the mapping operation: | |
1388 - by the mapping function | |
1389 - by gc (if the hash table is weak) | |
1390 | |
1391 So we make a copy of the hentries at the beginning of the mapping | |
497 | 1392 operation, and iterate over the copy. Naturally, this is |
1393 expensive, but not as expensive as you might think, because no | |
1394 actual memory has to be collected by our notoriously inefficient | |
1395 GC; we use an unwind-protect instead to free the memory directly. | |
1396 | |
1397 We could avoid the copying by having the hash table modifiers | |
1398 puthash and remhash check for currently active mapping functions. | |
1399 Disadvantages: it's hard to get right, and IMO hash mapping | |
1400 functions are basically rare, and no extra space in the hash table | |
1401 object and no extra cpu in puthash or remhash should be wasted to | |
1402 make maphash 3% faster. From a design point of view, the basic | |
1403 functions gethash, puthash and remhash should be implementable | |
1404 without having to think about maphash. | |
1405 | |
1406 Note: We don't (yet) have Common Lisp's with-hash-table-iterator. | |
1407 If you implement this naively, you cannot have more than one | |
1408 concurrently active iterator over the same hash table. The `each' | |
1409 function in perl has this limitation. | |
1410 | |
1411 Note: We GCPRO memory on the heap, not on the stack. There is no | |
1412 obvious reason why this is bad, but as of this writing this is the | |
1413 only known occurrence of this technique in the code. | |
504 | 1414 |
1415 -- Martin | |
1416 */ | |
1417 | |
1418 /* Ben disagrees with the "copying hentries" design, and says: | |
1419 | |
1420 Another solution is the same as I've already proposed -- when | |
1421 mapping, mark the table as "change-unsafe", and in this case, use a | |
1422 secondary table to maintain changes. this could be basically a | |
1423 standard hash table, but with entries only for added or deleted | |
1424 entries in the primary table, and a marker like Qunbound to | |
1425 indicate a deleted entry. puthash, gethash and remhash need a | |
1426 single extra check for this secondary table -- totally | |
1427 insignificant speedwise. if you really cared about making | |
1428 recursive maphashes completely correct, you'd have to do a bit of | |
1429 extra work here -- when maphashing, if the secondary table exists, | |
1430 make a copy of it, and use the copy in conjunction with the primary | |
1431 table when mapping. the advantages of this are | |
1432 | |
1433 [a] easy to demonstrate correct, even with weak hashtables. | |
1434 | |
1435 [b] no extra overhead in the general maphash case -- only when you | |
1436 modify the table while maphashing, and even then the overhead is | |
1437 very small. | |
497 | 1438 */ |
1439 | |
489 | 1440 static Lisp_Object |
1441 maphash_unwind (Lisp_Object unwind_obj) | |
1442 { | |
1443 void *ptr = (void *) get_opaque_ptr (unwind_obj); | |
1726 | 1444 xfree (ptr, void *); |
489 | 1445 free_opaque_ptr (unwind_obj); |
1446 return Qnil; | |
1447 } | |
1448 | |
1449 /* Return a malloced array of alternating key/value pairs from HT. */ | |
1450 static Lisp_Object * | |
1451 copy_compress_hentries (const Lisp_Hash_Table *ht) | |
1452 { | |
1453 Lisp_Object * const objs = | |
1454 /* If the hash table is empty, ht->count could be 0. */ | |
1455 xnew_array (Lisp_Object, 2 * (ht->count > 0 ? ht->count : 1)); | |
1204 | 1456 const htentry *e, *sentinel; |
489 | 1457 Lisp_Object *pobj; |
1458 | |
1459 for (e = ht->hentries, sentinel = e + ht->size, pobj = objs; e < sentinel; e++) | |
1204 | 1460 if (!HTENTRY_CLEAR_P (e)) |
489 | 1461 { |
1462 *(pobj++) = e->key; | |
1463 *(pobj++) = e->value; | |
1464 } | |
1465 | |
1466 type_checking_assert (pobj == objs + 2 * ht->count); | |
1467 | |
1468 return objs; | |
1469 } | |
1470 | |
428 | 1471 DEFUN ("maphash", Fmaphash, 2, 2, 0, /* |
1472 Map FUNCTION over entries in HASH-TABLE, calling it with two args, | |
1473 each key and value in HASH-TABLE. | |
1474 | |
489 | 1475 FUNCTION must not modify HASH-TABLE, with the one exception that FUNCTION |
428 | 1476 may remhash or puthash the entry currently being processed by FUNCTION. |
1477 */ | |
1478 (function, hash_table)) | |
1479 { | |
489 | 1480 const Lisp_Hash_Table * const ht = xhash_table (hash_table); |
1481 Lisp_Object * const objs = copy_compress_hentries (ht); | |
1482 Lisp_Object args[3]; | |
1483 const Lisp_Object *pobj, *end; | |
1484 int speccount = specpdl_depth (); | |
1485 struct gcpro gcpro1; | |
1486 | |
1487 record_unwind_protect (maphash_unwind, make_opaque_ptr ((void *)objs)); | |
1488 GCPRO1 (objs[0]); | |
1489 gcpro1.nvars = 2 * ht->count; | |
428 | 1490 |
489 | 1491 args[0] = function; |
1492 | |
1493 for (pobj = objs, end = pobj + 2 * ht->count; pobj < end; pobj += 2) | |
1494 { | |
1495 args[1] = pobj[0]; | |
1496 args[2] = pobj[1]; | |
1497 Ffuncall (countof (args), args); | |
1498 } | |
1499 | |
771 | 1500 unbind_to (speccount); |
489 | 1501 UNGCPRO; |
428 | 1502 |
1503 return Qnil; | |
1504 } | |
1505 | |
489 | 1506 /* Map *C* function FUNCTION over the elements of a non-weak lisp hash table. |
1507 FUNCTION must not modify HASH-TABLE, with the one exception that FUNCTION | |
1508 may puthash the entry currently being processed by FUNCTION. | |
1509 Mapping terminates if FUNCTION returns something other than 0. */ | |
428 | 1510 void |
489 | 1511 elisp_maphash_unsafe (maphash_function_t function, |
428 | 1512 Lisp_Object hash_table, void *extra_arg) |
1513 { | |
442 | 1514 const Lisp_Hash_Table *ht = XHASH_TABLE (hash_table); |
1204 | 1515 const htentry *e, *sentinel; |
428 | 1516 |
1517 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++) | |
1204 | 1518 if (!HTENTRY_CLEAR_P (e)) |
489 | 1519 if (function (e->key, e->value, extra_arg)) |
1520 return; | |
428 | 1521 } |
1522 | |
489 | 1523 /* Map *C* function FUNCTION over the elements of a lisp hash table. |
1524 It is safe for FUNCTION to modify HASH-TABLE. | |
1525 Mapping terminates if FUNCTION returns something other than 0. */ | |
1526 void | |
1527 elisp_maphash (maphash_function_t function, | |
1528 Lisp_Object hash_table, void *extra_arg) | |
1529 { | |
1530 const Lisp_Hash_Table * const ht = xhash_table (hash_table); | |
1531 Lisp_Object * const objs = copy_compress_hentries (ht); | |
1532 const Lisp_Object *pobj, *end; | |
1533 int speccount = specpdl_depth (); | |
1534 struct gcpro gcpro1; | |
1535 | |
1536 record_unwind_protect (maphash_unwind, make_opaque_ptr ((void *)objs)); | |
1537 GCPRO1 (objs[0]); | |
1538 gcpro1.nvars = 2 * ht->count; | |
1539 | |
1540 for (pobj = objs, end = pobj + 2 * ht->count; pobj < end; pobj += 2) | |
1541 if (function (pobj[0], pobj[1], extra_arg)) | |
1542 break; | |
1543 | |
771 | 1544 unbind_to (speccount); |
489 | 1545 UNGCPRO; |
1546 } | |
1547 | |
1548 /* Remove all elements of a lisp hash table satisfying *C* predicate PREDICATE. | |
1549 PREDICATE must not modify HASH-TABLE. */ | |
428 | 1550 void |
1551 elisp_map_remhash (maphash_function_t predicate, | |
1552 Lisp_Object hash_table, void *extra_arg) | |
1553 { | |
489 | 1554 const Lisp_Hash_Table * const ht = xhash_table (hash_table); |
1555 Lisp_Object * const objs = copy_compress_hentries (ht); | |
1556 const Lisp_Object *pobj, *end; | |
1557 int speccount = specpdl_depth (); | |
1558 struct gcpro gcpro1; | |
428 | 1559 |
489 | 1560 record_unwind_protect (maphash_unwind, make_opaque_ptr ((void *)objs)); |
1561 GCPRO1 (objs[0]); | |
1562 gcpro1.nvars = 2 * ht->count; | |
1563 | |
1564 for (pobj = objs, end = pobj + 2 * ht->count; pobj < end; pobj += 2) | |
1565 if (predicate (pobj[0], pobj[1], extra_arg)) | |
1566 Fremhash (pobj[0], hash_table); | |
1567 | |
771 | 1568 unbind_to (speccount); |
489 | 1569 UNGCPRO; |
428 | 1570 } |
1571 | |
1572 | |
1573 /************************************************************************/ | |
1574 /* garbage collecting weak hash tables */ | |
1575 /************************************************************************/ | |
1598 | 1576 #ifdef USE_KKCC |
2645 | 1577 #define MARK_OBJ(obj) do { \ |
1578 Lisp_Object mo_obj = (obj); \ | |
1579 if (!marked_p (mo_obj)) \ | |
1580 { \ | |
1581 kkcc_gc_stack_push_lisp_object (mo_obj, 0, -1); \ | |
1582 did_mark = 1; \ | |
1583 } \ | |
1598 | 1584 } while (0) |
1585 | |
1586 #else /* NO USE_KKCC */ | |
1587 | |
442 | 1588 #define MARK_OBJ(obj) do { \ |
1589 Lisp_Object mo_obj = (obj); \ | |
1590 if (!marked_p (mo_obj)) \ | |
1591 { \ | |
1592 mark_object (mo_obj); \ | |
1593 did_mark = 1; \ | |
1594 } \ | |
1595 } while (0) | |
1598 | 1596 #endif /*NO USE_KKCC */ |
442 | 1597 |
428 | 1598 |
1599 /* Complete the marking for semi-weak hash tables. */ | |
1600 int | |
1601 finish_marking_weak_hash_tables (void) | |
1602 { | |
1603 Lisp_Object hash_table; | |
1604 int did_mark = 0; | |
1605 | |
1606 for (hash_table = Vall_weak_hash_tables; | |
1607 !NILP (hash_table); | |
1608 hash_table = XHASH_TABLE (hash_table)->next_weak) | |
1609 { | |
442 | 1610 const Lisp_Hash_Table *ht = XHASH_TABLE (hash_table); |
1204 | 1611 const htentry *e = ht->hentries; |
1612 const htentry *sentinel = e + ht->size; | |
428 | 1613 |
1614 if (! marked_p (hash_table)) | |
1615 /* The hash table is probably garbage. Ignore it. */ | |
1616 continue; | |
1617 | |
1618 /* Now, scan over all the pairs. For all pairs that are | |
1619 half-marked, we may need to mark the other half if we're | |
1620 keeping this pair. */ | |
1621 switch (ht->weakness) | |
1622 { | |
1623 case HASH_TABLE_KEY_WEAK: | |
1624 for (; e < sentinel; e++) | |
1204 | 1625 if (!HTENTRY_CLEAR_P (e)) |
428 | 1626 if (marked_p (e->key)) |
1627 MARK_OBJ (e->value); | |
1628 break; | |
1629 | |
1630 case HASH_TABLE_VALUE_WEAK: | |
1631 for (; e < sentinel; e++) | |
1204 | 1632 if (!HTENTRY_CLEAR_P (e)) |
428 | 1633 if (marked_p (e->value)) |
1634 MARK_OBJ (e->key); | |
1635 break; | |
1636 | |
442 | 1637 case HASH_TABLE_KEY_VALUE_WEAK: |
1638 for (; e < sentinel; e++) | |
1204 | 1639 if (!HTENTRY_CLEAR_P (e)) |
442 | 1640 { |
1641 if (marked_p (e->value)) | |
1642 MARK_OBJ (e->key); | |
1643 else if (marked_p (e->key)) | |
1644 MARK_OBJ (e->value); | |
1645 } | |
1646 break; | |
1647 | |
428 | 1648 case HASH_TABLE_KEY_CAR_WEAK: |
1649 for (; e < sentinel; e++) | |
1204 | 1650 if (!HTENTRY_CLEAR_P (e)) |
428 | 1651 if (!CONSP (e->key) || marked_p (XCAR (e->key))) |
1652 { | |
1653 MARK_OBJ (e->key); | |
1654 MARK_OBJ (e->value); | |
1655 } | |
1656 break; | |
1657 | |
450 | 1658 /* We seem to be sprouting new weakness types at an alarming |
1659 rate. At least this is not externally visible - and in | |
1660 fact all of these KEY_CAR_* types are only used by the | |
1661 glyph code. */ | |
1662 case HASH_TABLE_KEY_CAR_VALUE_WEAK: | |
1663 for (; e < sentinel; e++) | |
1204 | 1664 if (!HTENTRY_CLEAR_P (e)) |
450 | 1665 { |
1666 if (!CONSP (e->key) || marked_p (XCAR (e->key))) | |
1667 { | |
1668 MARK_OBJ (e->key); | |
1669 MARK_OBJ (e->value); | |
1670 } | |
1671 else if (marked_p (e->value)) | |
1672 MARK_OBJ (e->key); | |
1673 } | |
1674 break; | |
1675 | |
428 | 1676 case HASH_TABLE_VALUE_CAR_WEAK: |
1677 for (; e < sentinel; e++) | |
1204 | 1678 if (!HTENTRY_CLEAR_P (e)) |
428 | 1679 if (!CONSP (e->value) || marked_p (XCAR (e->value))) |
1680 { | |
1681 MARK_OBJ (e->key); | |
1682 MARK_OBJ (e->value); | |
1683 } | |
1684 break; | |
1685 | |
1686 default: | |
1687 break; | |
1688 } | |
1689 } | |
1690 | |
1691 return did_mark; | |
1692 } | |
1693 | |
1694 void | |
1695 prune_weak_hash_tables (void) | |
1696 { | |
1697 Lisp_Object hash_table, prev = Qnil; | |
1698 for (hash_table = Vall_weak_hash_tables; | |
1699 !NILP (hash_table); | |
1700 hash_table = XHASH_TABLE (hash_table)->next_weak) | |
1701 { | |
1702 if (! marked_p (hash_table)) | |
1703 { | |
1704 /* This hash table itself is garbage. Remove it from the list. */ | |
1705 if (NILP (prev)) | |
1706 Vall_weak_hash_tables = XHASH_TABLE (hash_table)->next_weak; | |
1707 else | |
1708 XHASH_TABLE (prev)->next_weak = XHASH_TABLE (hash_table)->next_weak; | |
1709 } | |
1710 else | |
1711 { | |
1712 /* Now, scan over all the pairs. Remove all of the pairs | |
1713 in which the key or value, or both, is unmarked | |
1714 (depending on the weakness of the hash table). */ | |
1715 Lisp_Hash_Table *ht = XHASH_TABLE (hash_table); | |
1204 | 1716 htentry *entries = ht->hentries; |
1717 htentry *sentinel = entries + ht->size; | |
1718 htentry *e; | |
428 | 1719 |
1720 for (e = entries; e < sentinel; e++) | |
1204 | 1721 if (!HTENTRY_CLEAR_P (e)) |
428 | 1722 { |
1723 again: | |
1724 if (!marked_p (e->key) || !marked_p (e->value)) | |
1725 { | |
1726 remhash_1 (ht, entries, e); | |
1204 | 1727 if (!HTENTRY_CLEAR_P (e)) |
428 | 1728 goto again; |
1729 } | |
1730 } | |
1731 | |
1732 prev = hash_table; | |
1733 } | |
1734 } | |
1735 } | |
1736 | |
1737 /* Return a hash value for an array of Lisp_Objects of size SIZE. */ | |
1738 | |
665 | 1739 Hashcode |
428 | 1740 internal_array_hash (Lisp_Object *arr, int size, int depth) |
1741 { | |
1742 int i; | |
665 | 1743 Hashcode hash = 0; |
442 | 1744 depth++; |
428 | 1745 |
1746 if (size <= 5) | |
1747 { | |
1748 for (i = 0; i < size; i++) | |
442 | 1749 hash = HASH2 (hash, internal_hash (arr[i], depth)); |
428 | 1750 return hash; |
1751 } | |
1752 | |
1753 /* just pick five elements scattered throughout the array. | |
1754 A slightly better approach would be to offset by some | |
1755 noise factor from the points chosen below. */ | |
1756 for (i = 0; i < 5; i++) | |
442 | 1757 hash = HASH2 (hash, internal_hash (arr[i*size/5], depth)); |
428 | 1758 |
1759 return hash; | |
1760 } | |
1761 | |
1762 /* Return a hash value for a Lisp_Object. This is for use when hashing | |
1763 objects with the comparison being `equal' (for `eq', you can just | |
1764 use the Lisp_Object itself as the hash value). You need to make a | |
1765 tradeoff between the speed of the hash function and how good the | |
1766 hashing is. In particular, the hash function needs to be FAST, | |
1767 so you can't just traipse down the whole tree hashing everything | |
1768 together. Most of the time, objects will differ in the first | |
1769 few elements you hash. Thus, we only go to a short depth (5) | |
1770 and only hash at most 5 elements out of a vector. Theoretically | |
1771 we could still take 5^5 time (a big big number) to compute a | |
1772 hash, but practically this won't ever happen. */ | |
1773 | |
665 | 1774 Hashcode |
428 | 1775 internal_hash (Lisp_Object obj, int depth) |
1776 { | |
1777 if (depth > 5) | |
1778 return 0; | |
4398
479443c0f95a
Have list hashes depend on the order of the contents, as is the case for vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4117
diff
changeset
|
1779 |
479443c0f95a
Have list hashes depend on the order of the contents, as is the case for vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4117
diff
changeset
|
1780 if (CONSP(obj)) |
428 | 1781 { |
4398
479443c0f95a
Have list hashes depend on the order of the contents, as is the case for vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4117
diff
changeset
|
1782 Hashcode hash, h; |
479443c0f95a
Have list hashes depend on the order of the contents, as is the case for vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4117
diff
changeset
|
1783 int s; |
479443c0f95a
Have list hashes depend on the order of the contents, as is the case for vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4117
diff
changeset
|
1784 |
479443c0f95a
Have list hashes depend on the order of the contents, as is the case for vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4117
diff
changeset
|
1785 depth += 1; |
479443c0f95a
Have list hashes depend on the order of the contents, as is the case for vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4117
diff
changeset
|
1786 |
479443c0f95a
Have list hashes depend on the order of the contents, as is the case for vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4117
diff
changeset
|
1787 if (!CONSP(XCDR(obj))) |
479443c0f95a
Have list hashes depend on the order of the contents, as is the case for vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4117
diff
changeset
|
1788 { |
479443c0f95a
Have list hashes depend on the order of the contents, as is the case for vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4117
diff
changeset
|
1789 /* special case for '(a . b) conses */ |
479443c0f95a
Have list hashes depend on the order of the contents, as is the case for vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4117
diff
changeset
|
1790 return HASH2(internal_hash(XCAR(obj), depth), |
479443c0f95a
Have list hashes depend on the order of the contents, as is the case for vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4117
diff
changeset
|
1791 internal_hash(XCDR(obj), depth)); |
479443c0f95a
Have list hashes depend on the order of the contents, as is the case for vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4117
diff
changeset
|
1792 } |
479443c0f95a
Have list hashes depend on the order of the contents, as is the case for vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4117
diff
changeset
|
1793 |
479443c0f95a
Have list hashes depend on the order of the contents, as is the case for vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4117
diff
changeset
|
1794 /* Don't simply tail recurse; we want to hash lists with the |
479443c0f95a
Have list hashes depend on the order of the contents, as is the case for vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4117
diff
changeset
|
1795 same contents in distinct orders differently. */ |
479443c0f95a
Have list hashes depend on the order of the contents, as is the case for vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4117
diff
changeset
|
1796 hash = internal_hash(XCAR(obj), depth); |
479443c0f95a
Have list hashes depend on the order of the contents, as is the case for vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4117
diff
changeset
|
1797 |
479443c0f95a
Have list hashes depend on the order of the contents, as is the case for vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4117
diff
changeset
|
1798 obj = XCDR(obj); |
479443c0f95a
Have list hashes depend on the order of the contents, as is the case for vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4117
diff
changeset
|
1799 for (s = 1; s < 6 && CONSP(obj); obj = XCDR(obj), s++) |
479443c0f95a
Have list hashes depend on the order of the contents, as is the case for vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4117
diff
changeset
|
1800 { |
479443c0f95a
Have list hashes depend on the order of the contents, as is the case for vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4117
diff
changeset
|
1801 h = internal_hash(XCAR(obj), depth); |
479443c0f95a
Have list hashes depend on the order of the contents, as is the case for vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4117
diff
changeset
|
1802 hash = HASH3(hash, h, s); |
479443c0f95a
Have list hashes depend on the order of the contents, as is the case for vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4117
diff
changeset
|
1803 } |
479443c0f95a
Have list hashes depend on the order of the contents, as is the case for vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4117
diff
changeset
|
1804 |
479443c0f95a
Have list hashes depend on the order of the contents, as is the case for vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4117
diff
changeset
|
1805 return hash; |
428 | 1806 } |
1807 if (STRINGP (obj)) | |
1808 { | |
1809 return hash_string (XSTRING_DATA (obj), XSTRING_LENGTH (obj)); | |
1810 } | |
1811 if (LRECORDP (obj)) | |
1812 { | |
442 | 1813 const struct lrecord_implementation |
428 | 1814 *imp = XRECORD_LHEADER_IMPLEMENTATION (obj); |
1815 if (imp->hash) | |
1816 return imp->hash (obj, depth); | |
1817 } | |
1818 | |
1819 return LISP_HASH (obj); | |
1820 } | |
1821 | |
1822 DEFUN ("sxhash", Fsxhash, 1, 1, 0, /* | |
1823 Return a hash value for OBJECT. | |
444 | 1824 \(equal obj1 obj2) implies (= (sxhash obj1) (sxhash obj2)). |
428 | 1825 */ |
1826 (object)) | |
1827 { | |
1828 return make_int (internal_hash (object, 0)); | |
1829 } | |
1830 | |
1831 #if 0 | |
826 | 1832 DEFUN ("internal-hash-value", Finternal_hash_value, 1, 1, 0, /* |
428 | 1833 Hash value of OBJECT. For debugging. |
1834 The value is returned as (HIGH . LOW). | |
1835 */ | |
1836 (object)) | |
1837 { | |
1838 /* This function is pretty 32bit-centric. */ | |
665 | 1839 Hashcode hash = internal_hash (object, 0); |
428 | 1840 return Fcons (hash >> 16, hash & 0xffff); |
1841 } | |
1842 #endif | |
1843 | |
1844 | |
1845 /************************************************************************/ | |
1846 /* initialization */ | |
1847 /************************************************************************/ | |
1848 | |
1849 void | |
1850 syms_of_elhash (void) | |
1851 { | |
1852 DEFSUBR (Fhash_table_p); | |
1853 DEFSUBR (Fmake_hash_table); | |
1854 DEFSUBR (Fcopy_hash_table); | |
1855 DEFSUBR (Fgethash); | |
1856 DEFSUBR (Fremhash); | |
1857 DEFSUBR (Fputhash); | |
1858 DEFSUBR (Fclrhash); | |
1859 DEFSUBR (Fmaphash); | |
1860 DEFSUBR (Fhash_table_count); | |
1861 DEFSUBR (Fhash_table_test); | |
1862 DEFSUBR (Fhash_table_size); | |
1863 DEFSUBR (Fhash_table_rehash_size); | |
1864 DEFSUBR (Fhash_table_rehash_threshold); | |
1865 DEFSUBR (Fhash_table_weakness); | |
1866 DEFSUBR (Fhash_table_type); /* obsolete */ | |
1867 DEFSUBR (Fsxhash); | |
1868 #if 0 | |
1869 DEFSUBR (Finternal_hash_value); | |
1870 #endif | |
1871 | |
563 | 1872 DEFSYMBOL_MULTIWORD_PREDICATE (Qhash_tablep); |
1873 DEFSYMBOL (Qhash_table); | |
1874 DEFSYMBOL (Qhashtable); | |
1875 DEFSYMBOL (Qweakness); | |
1876 DEFSYMBOL (Qvalue); | |
1877 DEFSYMBOL (Qkey_or_value); | |
1878 DEFSYMBOL (Qkey_and_value); | |
1879 DEFSYMBOL (Qrehash_size); | |
1880 DEFSYMBOL (Qrehash_threshold); | |
428 | 1881 |
563 | 1882 DEFSYMBOL (Qweak); /* obsolete */ |
1883 DEFSYMBOL (Qkey_weak); /* obsolete */ | |
1884 DEFSYMBOL (Qkey_or_value_weak); /* obsolete */ | |
1885 DEFSYMBOL (Qvalue_weak); /* obsolete */ | |
1886 DEFSYMBOL (Qnon_weak); /* obsolete */ | |
428 | 1887 |
4820
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
1888 DEFKEYWORD (Q_data); |
563 | 1889 DEFKEYWORD (Q_test); |
1890 DEFKEYWORD (Q_size); | |
1891 DEFKEYWORD (Q_rehash_size); | |
1892 DEFKEYWORD (Q_rehash_threshold); | |
1893 DEFKEYWORD (Q_weakness); | |
1894 DEFKEYWORD (Q_type); /* obsolete */ | |
428 | 1895 } |
1896 | |
1897 void | |
771 | 1898 init_elhash_once_early (void) |
428 | 1899 { |
771 | 1900 INIT_LRECORD_IMPLEMENTATION (hash_table); |
3092 | 1901 #ifdef NEW_GC |
1902 INIT_LRECORD_IMPLEMENTATION (hash_table_entry); | |
1903 #endif /* NEW_GC */ | |
771 | 1904 |
428 | 1905 /* This must NOT be staticpro'd */ |
1906 Vall_weak_hash_tables = Qnil; | |
452 | 1907 dump_add_weak_object_chain (&Vall_weak_hash_tables); |
428 | 1908 } |