Mercurial > hg > xemacs-beta
annotate src/elhash.c @ 5146:88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
-------------------- ChangeLog entries follow: --------------------
src/ChangeLog addition:
2010-03-15 Ben Wing <ben@xemacs.org>
* alloc.c:
* alloc.c (c_readonly):
* alloc.c (deadbeef_memory):
* alloc.c (make_compiled_function):
* alloc.c (make_button_data):
* alloc.c (make_motion_data):
* alloc.c (make_process_data):
* alloc.c (make_timeout_data):
* alloc.c (make_magic_data):
* alloc.c (make_magic_eval_data):
* alloc.c (make_eval_data):
* alloc.c (make_misc_user_data):
* alloc.c (noseeum_make_marker):
* alloc.c (ADDITIONAL_FREE_string):
* alloc.c (common_init_alloc_early):
* alloc.c (init_alloc_once_early):
* bytecode.c (print_compiled_function):
* bytecode.c (mark_compiled_function):
* casetab.c:
* casetab.c (print_case_table):
* console.c:
* console.c (print_console):
* database.c (print_database):
* database.c (finalize_database):
* device-msw.c (sync_printer_with_devmode):
* device-msw.c (print_devmode):
* device-msw.c (finalize_devmode):
* device.c:
* device.c (print_device):
* elhash.c:
* elhash.c (print_hash_table):
* eval.c (print_multiple_value):
* eval.c (mark_multiple_value):
* events.c (deinitialize_event):
* events.c (print_event):
* events.c (event_equal):
* extents.c:
* extents.c (soe_dump):
* extents.c (soe_insert):
* extents.c (soe_delete):
* extents.c (soe_move):
* extents.c (extent_fragment_update):
* extents.c (print_extent_1):
* extents.c (print_extent):
* extents.c (vars_of_extents):
* frame.c:
* frame.c (print_frame):
* free-hook.c:
* free-hook.c (check_free):
* glyphs.c:
* glyphs.c (print_image_instance):
* glyphs.c (print_glyph):
* gui.c:
* gui.c (copy_gui_item):
* hash.c:
* hash.c (NULL_ENTRY):
* hash.c (KEYS_DIFFER_P):
* keymap.c (print_keymap):
* keymap.c (MARKED_SLOT):
* lisp.h:
* lrecord.h:
* lrecord.h (LISP_OBJECT_UID):
* lrecord.h (set_lheader_implementation):
* lrecord.h (struct old_lcrecord_header):
* lstream.c (print_lstream):
* lstream.c (finalize_lstream):
* marker.c (print_marker):
* marker.c (marker_equal):
* mc-alloc.c (visit_all_used_page_headers):
* mule-charset.c:
* mule-charset.c (print_charset):
* objects.c (print_color_instance):
* objects.c (print_font_instance):
* objects.c (finalize_font_instance):
* opaque.c (print_opaque):
* opaque.c (print_opaque_ptr):
* opaque.c (equal_opaque_ptr):
* print.c (internal_object_printer):
* print.c (enum printing_badness):
* rangetab.c (print_range_table):
* rangetab.c (range_table_equal):
* specifier.c (print_specifier):
* specifier.c (finalize_specifier):
* symbols.c:
* symbols.c (print_symbol_value_magic):
* tooltalk.c:
* tooltalk.c (print_tooltalk_message):
* tooltalk.c (print_tooltalk_pattern):
* window.c (print_window):
* window.c (debug_print_window):
(1) Make lrecord UID's have a separate UID space for each object.
Otherwise, with 20-bit UID's, we rapidly wrap around, especially
when common objects like conses and strings increment the UID value
for every object created. (Originally I tried making two UID spaces,
one for objects that always print readably and hence don't display
the UID, and one for other objects. But certain objects like markers
for which a UID is displayed are still generated rapidly enough that
UID overflow is a serious issue.) This also has the advantage of
making UID values smaller, hence easier to remember -- their main
purpose is to make it easier to keep track of different objects of
the same type when debugging code. Make sure we dump lrecord UID's
so that we don't have problems with pdumped and non-dumped objects
having the same UID.
(2) Display UID's consistently whenever an object (a) doesn't
consistently print readably (objects like cons and string, which
always print readably, can't display a UID), and (b) doesn't
otherwise have a unique property that makes objects of a
particular type distinguishable. (E.g. buffers didn't and still
don't print an ID, but the buffer name uniquely identifies the
buffer.) Some types, such as event, extent, compiled-function,
didn't always (or didn't ever) display an ID; others (such as
marker, extent, lstream, opaque, opaque-ptr, any object using
internal_object_printer()) used to display the actual machine
pointer instead.
(3) Rename NORMAL_LISP_OBJECT_UID to LISP_OBJECT_UID; make it work
over all Lisp objects and take a Lisp object, not a struct pointer.
(4) Some misc cleanups in alloc.c, elhash.c.
(5) Change code in events.c that "deinitializes" an event so that
it doesn't increment the event UID counter in the process. Also
use deadbeef_memory() to overwrite memory instead of doing the same
with custom code. In the process, make deadbeef_memory() in
alloc.c always available, and delete extraneous copy in mc-alloc.c.
Also capitalize all uses of 0xDEADBEEF. Similarly in elhash.c
call deadbeef_memory().
(6) Resurrect "debug SOE" code in extents.c. Make it conditional
on DEBUG_XEMACS and on a `debug-soe' variable, rather than on
SOE_DEBUG. Make it output to stderr, not stdout.
(7) Delete some custom print methods that were identical to
external_object_printer().
| author | Ben Wing <ben@xemacs.org> |
|---|---|
| date | Mon, 15 Mar 2010 16:35:38 -0500 |
| parents | f965e31a35f0 |
| children | 9e0b43d3095c |
| rev | line source |
|---|---|
| 428 | 1 /* Implementation of the hash table lisp object type. |
| 2 Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc. | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
3 Copyright (C) 1995, 1996, 2002, 2004, 2010 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; | |
|
5084
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4976
diff
changeset
|
87 static Lisp_Object Qhashtable, Qhash_table, Qmake_hash_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 { | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
99 NORMAL_LISP_OBJECT_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 | |
| 188 static int | |
| 189 lisp_object_eql_equal (Lisp_Object obj1, Lisp_Object obj2) | |
| 190 { | |
|
4885
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4820
diff
changeset
|
191 return EQ (obj1, obj2) || |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4820
diff
changeset
|
192 (NON_FIXNUM_NUMBER_P (obj1) && internal_equal (obj1, obj2, 0)); |
| 428 | 193 } |
| 194 | |
| 665 | 195 static Hashcode |
| 428 | 196 lisp_object_eql_hash (Lisp_Object obj) |
| 197 { | |
|
4885
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4820
diff
changeset
|
198 return NON_FIXNUM_NUMBER_P (obj) ? internal_hash (obj, 0) : LISP_HASH (obj); |
| 428 | 199 } |
| 200 | |
| 201 static int | |
| 202 lisp_object_equal_equal (Lisp_Object obj1, Lisp_Object obj2) | |
| 203 { | |
| 204 return internal_equal (obj1, obj2, 0); | |
| 205 } | |
| 206 | |
| 665 | 207 static Hashcode |
| 428 | 208 lisp_object_equal_hash (Lisp_Object obj) |
| 209 { | |
| 210 return internal_hash (obj, 0); | |
| 211 } | |
| 212 | |
| 213 | |
| 214 static Lisp_Object | |
| 215 mark_hash_table (Lisp_Object obj) | |
| 216 { | |
| 217 Lisp_Hash_Table *ht = XHASH_TABLE (obj); | |
| 218 | |
| 219 /* If the hash table is weak, we don't want to mark the keys and | |
| 220 values (we scan over them after everything else has been marked, | |
| 221 and mark or remove them as necessary). */ | |
| 222 if (ht->weakness == HASH_TABLE_NON_WEAK) | |
| 223 { | |
| 1204 | 224 htentry *e, *sentinel; |
| 428 | 225 |
| 226 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++) | |
| 1204 | 227 if (!HTENTRY_CLEAR_P (e)) |
| 428 | 228 { |
| 229 mark_object (e->key); | |
| 230 mark_object (e->value); | |
| 231 } | |
| 232 } | |
| 233 return Qnil; | |
| 234 } | |
| 235 | |
| 236 /* Equality of hash tables. Two hash tables are equal when they are of | |
| 237 the same weakness and test function, they have the same number of | |
| 238 elements, and for each key in the hash table, the values are `equal'. | |
| 239 | |
| 240 This is similar to Common Lisp `equalp' of hash tables, with the | |
| 241 difference that CL requires the keys to be compared with the test | |
| 242 function, which we don't do. Doing that would require consing, and | |
| 243 consing is a bad idea in `equal'. Anyway, our method should provide | |
| 244 the same result -- if the keys are not equal according to the test | |
| 245 function, then Fgethash() in hash_table_equal_mapper() will fail. */ | |
| 246 static int | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
247 hash_table_equal (Lisp_Object hash_table1, Lisp_Object hash_table2, int depth, |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
248 int foldcase) |
| 428 | 249 { |
| 250 Lisp_Hash_Table *ht1 = XHASH_TABLE (hash_table1); | |
| 251 Lisp_Hash_Table *ht2 = XHASH_TABLE (hash_table2); | |
| 1204 | 252 htentry *e, *sentinel; |
| 428 | 253 |
| 254 if ((ht1->test_function != ht2->test_function) || | |
| 255 (ht1->weakness != ht2->weakness) || | |
| 256 (ht1->count != ht2->count)) | |
| 257 return 0; | |
| 258 | |
| 259 depth++; | |
| 260 | |
| 261 for (e = ht1->hentries, sentinel = e + ht1->size; e < sentinel; e++) | |
| 1204 | 262 if (!HTENTRY_CLEAR_P (e)) |
| 428 | 263 /* Look up the key in the other hash table, and compare the values. */ |
| 264 { | |
| 265 Lisp_Object value_in_other = Fgethash (e->key, hash_table2, Qunbound); | |
| 266 if (UNBOUNDP (value_in_other) || | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
267 !internal_equal_0 (e->value, value_in_other, depth, foldcase)) |
| 428 | 268 return 0; /* Give up */ |
| 269 } | |
| 270 | |
| 271 return 1; | |
| 272 } | |
| 442 | 273 |
| 274 /* This is not a great hash function, but it _is_ correct and fast. | |
| 275 Examining all entries is too expensive, and examining a random | |
| 276 subset does not yield a correct hash function. */ | |
| 665 | 277 static Hashcode |
| 2286 | 278 hash_table_hash (Lisp_Object hash_table, int UNUSED (depth)) |
| 442 | 279 { |
| 280 return XHASH_TABLE (hash_table)->count; | |
| 281 } | |
| 282 | |
| 428 | 283 |
| 284 /* Printing hash tables. | |
| 285 | |
| 286 This is non-trivial, because we use a readable structure-style | |
| 287 syntax for hash tables. This means that a typical hash table will be | |
| 288 readably printed in the form of: | |
| 289 | |
|
4820
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
290 #s(hash-table :size 2 :data (key1 value1 key2 value2)) |
| 428 | 291 |
| 292 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
|
293 `: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
|
294 `: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
|
295 `: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
|
296 `: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
|
297 `: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
|
298 `:data' (a list) |
| 428 | 299 |
| 430 | 300 If `print-readably' is nil, then a simpler syntax is used, for example |
| 428 | 301 |
| 302 #<hash-table size 2/13 data (key1 value1 key2 value2) 0x874d> | |
| 303 | |
| 304 The data is truncated to four pairs, and the rest is shown with | |
| 305 `...'. This printer does not cons. */ | |
| 306 | |
| 307 | |
| 308 /* Print the data of the hash table. This maps through a Lisp | |
| 309 hash table and prints key/value pairs using PRINTCHARFUN. */ | |
| 310 static void | |
| 311 print_hash_table_data (Lisp_Hash_Table *ht, Lisp_Object printcharfun) | |
| 312 { | |
| 313 int count = 0; | |
| 1204 | 314 htentry *e, *sentinel; |
| 428 | 315 |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4820
diff
changeset
|
316 write_ascstring (printcharfun, " :data ("); |
| 428 | 317 |
| 318 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++) | |
| 1204 | 319 if (!HTENTRY_CLEAR_P (e)) |
| 428 | 320 { |
| 321 if (count > 0) | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4820
diff
changeset
|
322 write_ascstring (printcharfun, " "); |
| 428 | 323 if (!print_readably && count > 3) |
| 324 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4820
diff
changeset
|
325 write_ascstring (printcharfun, "..."); |
| 428 | 326 break; |
| 327 } | |
| 328 print_internal (e->key, printcharfun, 1); | |
| 800 | 329 write_fmt_string_lisp (printcharfun, " %S", 1, e->value); |
| 428 | 330 count++; |
| 331 } | |
| 332 | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4820
diff
changeset
|
333 write_ascstring (printcharfun, ")"); |
| 428 | 334 } |
| 335 | |
| 336 static void | |
| 2286 | 337 print_hash_table (Lisp_Object obj, Lisp_Object printcharfun, |
| 338 int UNUSED (escapeflag)) | |
| 428 | 339 { |
| 340 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
|
341 Ascbyte pigbuf[350]; |
| 428 | 342 |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4820
diff
changeset
|
343 write_ascstring (printcharfun, |
| 826 | 344 print_readably ? "#s(hash-table" : "#<hash-table"); |
| 428 | 345 |
| 346 /* These checks have a kludgy look to them, but they are safe. | |
| 347 Due to nature of hashing, you cannot use arbitrary | |
| 348 test functions anyway. */ | |
| 349 if (!ht->test_function) | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4820
diff
changeset
|
350 write_ascstring (printcharfun, " :test eq"); |
| 428 | 351 else if (ht->test_function == lisp_object_equal_equal) |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4820
diff
changeset
|
352 write_ascstring (printcharfun, " :test equal"); |
| 428 | 353 else if (ht->test_function == lisp_object_eql_equal) |
| 354 DO_NOTHING; | |
| 355 else | |
| 2500 | 356 ABORT (); |
| 428 | 357 |
| 358 if (ht->count || !print_readably) | |
| 359 { | |
| 360 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
|
361 write_fmt_string (printcharfun, " :size %ld", (long) ht->count); |
| 428 | 362 else |
|
4820
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
363 write_fmt_string (printcharfun, " :size %ld/%ld", (long) ht->count, |
| 800 | 364 (long) ht->size); |
| 428 | 365 } |
| 366 | |
| 367 if (ht->weakness != HASH_TABLE_NON_WEAK) | |
| 368 { | |
| 800 | 369 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
|
370 (printcharfun, " :weakness %s", |
| 800 | 371 (ht->weakness == HASH_TABLE_WEAK ? "key-and-value" : |
| 372 ht->weakness == HASH_TABLE_KEY_WEAK ? "key" : | |
| 373 ht->weakness == HASH_TABLE_VALUE_WEAK ? "value" : | |
| 374 ht->weakness == HASH_TABLE_KEY_VALUE_WEAK ? "key-or-value" : | |
| 375 "you-d-better-not-see-this")); | |
| 428 | 376 } |
| 377 | |
|
4777
c69aeb86b2a3
Serialise non-default hash table rehash thresholds correctly; use this.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
378 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
|
379 { |
|
c69aeb86b2a3
Serialise non-default hash table rehash thresholds correctly; use this.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
380 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
|
381 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
|
382 } |
|
c69aeb86b2a3
Serialise non-default hash table rehash thresholds correctly; use this.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
383 |
|
c69aeb86b2a3
Serialise non-default hash table rehash thresholds correctly; use this.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
384 if (ht->rehash_threshold |
|
c69aeb86b2a3
Serialise non-default hash table rehash thresholds correctly; use this.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
385 != 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
|
386 ht->test_function)) |
|
c69aeb86b2a3
Serialise non-default hash table rehash thresholds correctly; use this.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
387 { |
|
c69aeb86b2a3
Serialise non-default hash table rehash thresholds correctly; use this.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
388 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
|
389 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
|
390 } |
|
c69aeb86b2a3
Serialise non-default hash table rehash thresholds correctly; use this.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
391 |
| 428 | 392 if (ht->count) |
| 393 print_hash_table_data (ht, printcharfun); | |
| 394 | |
| 395 if (print_readably) | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4820
diff
changeset
|
396 write_ascstring (printcharfun, ")"); |
| 428 | 397 else |
|
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
398 write_fmt_string (printcharfun, " 0x%x>", LISP_OBJECT_UID (obj)); |
| 428 | 399 } |
| 400 | |
| 4117 | 401 #ifndef NEW_GC |
| 428 | 402 static void |
| 4117 | 403 free_hentries (htentry *hentries, |
| 2333 | 404 #ifdef ERROR_CHECK_STRUCTURES |
|
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
405 Elemcount size |
| 4117 | 406 #else /* not ERROR_CHECK_STRUCTURES) */ |
|
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
407 Elemcount UNUSED (size) |
| 4117 | 408 #endif /* not ERROR_CHECK_STRUCTURES) */ |
| 2333 | 409 ) |
| 489 | 410 { |
| 800 | 411 #ifdef ERROR_CHECK_STRUCTURES |
| 489 | 412 /* Ensure a crash if other code uses the discarded entries afterwards. */ |
|
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
413 deadbeef_memory (hentries, |
|
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
414 (Rawbyte *) (hentries + size) - (Rawbyte *) hentries); |
| 489 | 415 #endif |
| 416 | |
| 417 if (!DUMPEDP (hentries)) | |
|
4976
16112448d484
Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
418 xfree (hentries); |
| 489 | 419 } |
| 420 | |
| 421 static void | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
422 finalize_hash_table (Lisp_Object obj) |
| 428 | 423 { |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
424 Lisp_Hash_Table *ht = XHASH_TABLE (obj); |
|
5124
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5120
diff
changeset
|
425 free_hentries (ht->hentries, ht->size); |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5120
diff
changeset
|
426 ht->hentries = 0; |
| 428 | 427 } |
| 3263 | 428 #endif /* not NEW_GC */ |
| 428 | 429 |
| 1204 | 430 static const struct memory_description htentry_description_1[] = { |
| 431 { XD_LISP_OBJECT, offsetof (htentry, key) }, | |
| 432 { XD_LISP_OBJECT, offsetof (htentry, value) }, | |
| 428 | 433 { XD_END } |
| 434 }; | |
| 435 | |
| 1204 | 436 static const struct sized_memory_description htentry_description = { |
| 437 sizeof (htentry), | |
| 438 htentry_description_1 | |
| 428 | 439 }; |
| 440 | |
| 3092 | 441 #ifdef NEW_GC |
| 442 static const struct memory_description htentry_weak_description_1[] = { | |
| 443 { XD_LISP_OBJECT, offsetof (htentry, key), 0, { 0 }, XD_FLAG_NO_KKCC}, | |
| 444 { XD_LISP_OBJECT, offsetof (htentry, value), 0, { 0 }, XD_FLAG_NO_KKCC}, | |
| 445 { XD_END } | |
| 446 }; | |
| 447 | |
| 448 static const struct sized_memory_description htentry_weak_description = { | |
| 449 sizeof (htentry), | |
| 450 htentry_weak_description_1 | |
| 451 }; | |
| 452 | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
453 DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT ("hash-table-entry", hash_table_entry, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
454 0, htentry_description_1, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
455 Lisp_Hash_Table_Entry); |
| 3092 | 456 #endif /* NEW_GC */ |
| 457 | |
| 1204 | 458 static const struct memory_description htentry_union_description_1[] = { |
| 459 /* Note: XD_INDIRECT in this table refers to the surrounding table, | |
| 460 and so this will work. */ | |
| 3092 | 461 #ifdef NEW_GC |
| 462 { XD_LISP_OBJECT_BLOCK_PTR, HASH_TABLE_NON_WEAK, | |
| 463 XD_INDIRECT (0, 1), { &htentry_description } }, | |
| 464 { XD_LISP_OBJECT_BLOCK_PTR, 0, XD_INDIRECT (0, 1), | |
| 465 { &htentry_weak_description }, XD_FLAG_UNION_DEFAULT_ENTRY }, | |
| 466 #else /* not NEW_GC */ | |
| 2367 | 467 { XD_BLOCK_PTR, HASH_TABLE_NON_WEAK, XD_INDIRECT (0, 1), |
| 2551 | 468 { &htentry_description } }, |
| 469 { XD_BLOCK_PTR, 0, XD_INDIRECT (0, 1), { &htentry_description }, | |
| 1204 | 470 XD_FLAG_UNION_DEFAULT_ENTRY | XD_FLAG_NO_KKCC }, |
| 3092 | 471 #endif /* not NEW_GC */ |
| 1204 | 472 { XD_END } |
| 473 }; | |
| 474 | |
| 475 static const struct sized_memory_description htentry_union_description = { | |
| 476 sizeof (htentry *), | |
| 477 htentry_union_description_1 | |
| 478 }; | |
| 479 | |
| 480 const struct memory_description hash_table_description[] = { | |
| 481 { XD_ELEMCOUNT, offsetof (Lisp_Hash_Table, size) }, | |
| 482 { XD_INT, offsetof (Lisp_Hash_Table, weakness) }, | |
| 483 { XD_UNION, offsetof (Lisp_Hash_Table, hentries), XD_INDIRECT (1, 0), | |
| 2551 | 484 { &htentry_union_description } }, |
| 440 | 485 { XD_LO_LINK, offsetof (Lisp_Hash_Table, next_weak) }, |
| 428 | 486 { XD_END } |
| 487 }; | |
| 488 | |
| 3263 | 489 #ifdef NEW_GC |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
490 DEFINE_DUMPABLE_LISP_OBJECT ("hash-table", hash_table, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
491 mark_hash_table, print_hash_table, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
492 0, hash_table_equal, hash_table_hash, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
493 hash_table_description, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
494 Lisp_Hash_Table); |
| 3263 | 495 #else /* not NEW_GC */ |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
496 DEFINE_DUMPABLE_LISP_OBJECT ("hash-table", hash_table, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
497 mark_hash_table, print_hash_table, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
498 finalize_hash_table, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
499 hash_table_equal, hash_table_hash, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
500 hash_table_description, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
501 Lisp_Hash_Table); |
| 3263 | 502 #endif /* not NEW_GC */ |
| 428 | 503 |
| 504 static Lisp_Hash_Table * | |
| 505 xhash_table (Lisp_Object hash_table) | |
| 506 { | |
| 1123 | 507 /* #### What's going on here? Why the gc_in_progress check? */ |
| 428 | 508 if (!gc_in_progress) |
| 509 CHECK_HASH_TABLE (hash_table); | |
| 510 check_hash_table_invariants (XHASH_TABLE (hash_table)); | |
| 511 return XHASH_TABLE (hash_table); | |
| 512 } | |
| 513 | |
| 514 | |
| 515 /************************************************************************/ | |
| 516 /* Creation of Hash Tables */ | |
| 517 /************************************************************************/ | |
| 518 | |
| 519 /* Creation of hash tables, without error-checking. */ | |
| 520 static void | |
| 521 compute_hash_table_derived_values (Lisp_Hash_Table *ht) | |
| 522 { | |
| 665 | 523 ht->rehash_count = (Elemcount) |
| 438 | 524 ((double) ht->size * ht->rehash_threshold); |
| 665 | 525 ht->golden_ratio = (Elemcount) |
| 428 | 526 ((double) ht->size * (.6180339887 / (double) sizeof (Lisp_Object))); |
| 527 } | |
| 528 | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
529 static htentry * |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
530 allocate_hash_table_entries (Elemcount size) |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
531 { |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
532 #ifdef NEW_GC |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
533 return XHASH_TABLE_ENTRY (alloc_lrecord_array |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
534 (size, &lrecord_hash_table_entry)); |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
535 #else /* not NEW_GC */ |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
536 return xnew_array_and_zero (htentry, size); |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
537 #endif /* not NEW_GC */ |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
538 } |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
539 |
| 428 | 540 Lisp_Object |
| 450 | 541 make_standard_lisp_hash_table (enum hash_table_test test, |
| 665 | 542 Elemcount size, |
| 450 | 543 double rehash_size, |
| 544 double rehash_threshold, | |
| 545 enum hash_table_weakness weakness) | |
| 546 { | |
| 462 | 547 hash_table_hash_function_t hash_function = 0; |
| 450 | 548 hash_table_test_function_t test_function = 0; |
| 549 | |
| 550 switch (test) | |
| 551 { | |
| 552 case HASH_TABLE_EQ: | |
| 553 test_function = 0; | |
| 554 hash_function = 0; | |
| 555 break; | |
| 556 | |
| 557 case HASH_TABLE_EQL: | |
| 558 test_function = lisp_object_eql_equal; | |
| 559 hash_function = lisp_object_eql_hash; | |
| 560 break; | |
| 561 | |
| 562 case HASH_TABLE_EQUAL: | |
| 563 test_function = lisp_object_equal_equal; | |
| 564 hash_function = lisp_object_equal_hash; | |
| 565 break; | |
| 566 | |
| 567 default: | |
| 2500 | 568 ABORT (); |
| 450 | 569 } |
| 570 | |
| 571 return make_general_lisp_hash_table (hash_function, test_function, | |
| 572 size, rehash_size, rehash_threshold, | |
| 573 weakness); | |
| 574 } | |
| 575 | |
| 576 Lisp_Object | |
| 577 make_general_lisp_hash_table (hash_table_hash_function_t hash_function, | |
| 578 hash_table_test_function_t test_function, | |
| 665 | 579 Elemcount size, |
| 428 | 580 double rehash_size, |
| 581 double rehash_threshold, | |
| 582 enum hash_table_weakness weakness) | |
| 583 { | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
584 Lisp_Object hash_table = ALLOC_NORMAL_LISP_OBJECT (hash_table); |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
585 Lisp_Hash_Table *ht = XHASH_TABLE (hash_table); |
| 428 | 586 |
| 450 | 587 ht->test_function = test_function; |
| 588 ht->hash_function = hash_function; | |
| 438 | 589 ht->weakness = weakness; |
| 590 | |
| 591 ht->rehash_size = | |
| 592 rehash_size > 1.0 ? rehash_size : HASH_TABLE_DEFAULT_REHASH_SIZE; | |
| 593 | |
| 594 ht->rehash_threshold = | |
| 595 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
|
596 HASH_TABLE_DEFAULT_REHASH_THRESHOLD (size, ht->test_function); |
| 438 | 597 |
| 428 | 598 if (size < HASH_TABLE_MIN_SIZE) |
| 599 size = HASH_TABLE_MIN_SIZE; | |
| 665 | 600 ht->size = hash_table_size ((Elemcount) (((double) size / ht->rehash_threshold) |
| 438 | 601 + 1.0)); |
| 428 | 602 ht->count = 0; |
| 438 | 603 |
| 428 | 604 compute_hash_table_derived_values (ht); |
| 605 | |
| 1204 | 606 /* We leave room for one never-occupied sentinel htentry at the end. */ |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
607 ht->hentries = allocate_hash_table_entries (ht->size + 1); |
| 428 | 608 |
| 609 if (weakness == HASH_TABLE_NON_WEAK) | |
| 610 ht->next_weak = Qunbound; | |
| 611 else | |
| 612 ht->next_weak = Vall_weak_hash_tables, Vall_weak_hash_tables = hash_table; | |
| 613 | |
| 614 return hash_table; | |
| 615 } | |
| 616 | |
| 617 Lisp_Object | |
| 665 | 618 make_lisp_hash_table (Elemcount size, |
| 428 | 619 enum hash_table_weakness weakness, |
| 620 enum hash_table_test test) | |
| 621 { | |
| 450 | 622 return make_standard_lisp_hash_table (test, size, -1.0, -1.0, weakness); |
| 428 | 623 } |
| 624 | |
| 625 /* Pretty reading of hash tables. | |
| 626 | |
| 627 Here we use the existing structures mechanism (which is, | |
| 628 unfortunately, pretty cumbersome) for validating and instantiating | |
| 629 the hash tables. The idea is that the side-effect of reading a | |
| 630 #s(hash-table PLIST) object is creation of a hash table with desired | |
| 631 properties, and that the hash table is returned. */ | |
| 632 | |
| 633 /* Validation functions: each keyword provides its own validation | |
| 634 function. The errors should maybe be continuable, but it is | |
| 635 unclear how this would cope with ERRB. */ | |
| 636 static int | |
| 2286 | 637 hash_table_size_validate (Lisp_Object UNUSED (keyword), Lisp_Object value, |
| 638 Error_Behavior errb) | |
| 428 | 639 { |
| 640 if (NATNUMP (value)) | |
| 641 return 1; | |
| 642 | |
| 563 | 643 maybe_signal_error_1 (Qwrong_type_argument, list2 (Qnatnump, value), |
| 2286 | 644 Qhash_table, errb); |
| 428 | 645 return 0; |
| 646 } | |
| 647 | |
| 665 | 648 static Elemcount |
| 428 | 649 decode_hash_table_size (Lisp_Object obj) |
| 650 { | |
| 651 return NILP (obj) ? HASH_TABLE_DEFAULT_SIZE : XINT (obj); | |
| 652 } | |
| 653 | |
| 654 static int | |
| 2286 | 655 hash_table_weakness_validate (Lisp_Object UNUSED (keyword), Lisp_Object value, |
| 578 | 656 Error_Behavior errb) |
| 428 | 657 { |
| 442 | 658 if (EQ (value, Qnil)) return 1; |
| 659 if (EQ (value, Qt)) return 1; | |
| 660 if (EQ (value, Qkey)) return 1; | |
| 661 if (EQ (value, Qkey_and_value)) return 1; | |
| 662 if (EQ (value, Qkey_or_value)) return 1; | |
| 663 if (EQ (value, Qvalue)) return 1; | |
| 428 | 664 |
| 665 /* Following values are obsolete as of 19990901 in xemacs-21.2 */ | |
| 442 | 666 if (EQ (value, Qnon_weak)) return 1; |
| 667 if (EQ (value, Qweak)) return 1; | |
| 668 if (EQ (value, Qkey_weak)) return 1; | |
| 669 if (EQ (value, Qkey_or_value_weak)) return 1; | |
| 670 if (EQ (value, Qvalue_weak)) return 1; | |
| 428 | 671 |
| 563 | 672 maybe_invalid_constant ("Invalid hash table weakness", |
| 428 | 673 value, Qhash_table, errb); |
| 674 return 0; | |
| 675 } | |
| 676 | |
| 677 static enum hash_table_weakness | |
| 678 decode_hash_table_weakness (Lisp_Object obj) | |
| 679 { | |
| 442 | 680 if (EQ (obj, Qnil)) return HASH_TABLE_NON_WEAK; |
| 681 if (EQ (obj, Qt)) return HASH_TABLE_WEAK; | |
| 682 if (EQ (obj, Qkey_and_value)) return HASH_TABLE_WEAK; | |
| 683 if (EQ (obj, Qkey)) return HASH_TABLE_KEY_WEAK; | |
| 684 if (EQ (obj, Qkey_or_value)) return HASH_TABLE_KEY_VALUE_WEAK; | |
| 685 if (EQ (obj, Qvalue)) return HASH_TABLE_VALUE_WEAK; | |
| 428 | 686 |
| 687 /* Following values are obsolete as of 19990901 in xemacs-21.2 */ | |
| 442 | 688 if (EQ (obj, Qnon_weak)) return HASH_TABLE_NON_WEAK; |
| 689 if (EQ (obj, Qweak)) return HASH_TABLE_WEAK; | |
| 690 if (EQ (obj, Qkey_weak)) return HASH_TABLE_KEY_WEAK; | |
| 691 if (EQ (obj, Qkey_or_value_weak)) return HASH_TABLE_KEY_VALUE_WEAK; | |
| 692 if (EQ (obj, Qvalue_weak)) return HASH_TABLE_VALUE_WEAK; | |
| 428 | 693 |
| 563 | 694 invalid_constant ("Invalid hash table weakness", obj); |
| 1204 | 695 RETURN_NOT_REACHED (HASH_TABLE_NON_WEAK); |
| 428 | 696 } |
| 697 | |
| 698 static int | |
| 2286 | 699 hash_table_test_validate (Lisp_Object UNUSED (keyword), Lisp_Object value, |
| 700 Error_Behavior errb) | |
| 428 | 701 { |
| 702 if (EQ (value, Qnil)) return 1; | |
| 703 if (EQ (value, Qeq)) return 1; | |
| 704 if (EQ (value, Qequal)) return 1; | |
| 705 if (EQ (value, Qeql)) return 1; | |
| 706 | |
| 563 | 707 maybe_invalid_constant ("Invalid hash table test", |
| 2286 | 708 value, Qhash_table, errb); |
| 428 | 709 return 0; |
| 710 } | |
| 711 | |
| 712 static enum hash_table_test | |
| 713 decode_hash_table_test (Lisp_Object obj) | |
| 714 { | |
| 715 if (EQ (obj, Qnil)) return HASH_TABLE_EQL; | |
| 716 if (EQ (obj, Qeq)) return HASH_TABLE_EQ; | |
| 717 if (EQ (obj, Qequal)) return HASH_TABLE_EQUAL; | |
| 718 if (EQ (obj, Qeql)) return HASH_TABLE_EQL; | |
| 719 | |
| 563 | 720 invalid_constant ("Invalid hash table test", obj); |
| 1204 | 721 RETURN_NOT_REACHED (HASH_TABLE_EQ); |
| 428 | 722 } |
| 723 | |
| 724 static int | |
| 2286 | 725 hash_table_rehash_size_validate (Lisp_Object UNUSED (keyword), |
| 726 Lisp_Object value, Error_Behavior errb) | |
| 428 | 727 { |
| 728 if (!FLOATP (value)) | |
| 729 { | |
| 563 | 730 maybe_signal_error_1 (Qwrong_type_argument, list2 (Qfloatp, value), |
| 428 | 731 Qhash_table, errb); |
| 732 return 0; | |
| 733 } | |
| 734 | |
| 735 { | |
| 736 double rehash_size = XFLOAT_DATA (value); | |
| 737 if (rehash_size <= 1.0) | |
| 738 { | |
| 563 | 739 maybe_invalid_argument |
| 428 | 740 ("Hash table rehash size must be greater than 1.0", |
| 741 value, Qhash_table, errb); | |
| 742 return 0; | |
| 743 } | |
| 744 } | |
| 745 | |
| 746 return 1; | |
| 747 } | |
| 748 | |
| 749 static double | |
| 750 decode_hash_table_rehash_size (Lisp_Object rehash_size) | |
| 751 { | |
|
4585
871eb054b34a
Document non-obvious usages.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4410
diff
changeset
|
752 /* -1.0 signals make_general_lisp_hash_table to use the default. */ |
| 428 | 753 return NILP (rehash_size) ? -1.0 : XFLOAT_DATA (rehash_size); |
| 754 } | |
| 755 | |
| 756 static int | |
| 2286 | 757 hash_table_rehash_threshold_validate (Lisp_Object UNUSED (keyword), |
| 758 Lisp_Object value, Error_Behavior errb) | |
| 428 | 759 { |
| 760 if (!FLOATP (value)) | |
| 761 { | |
| 563 | 762 maybe_signal_error_1 (Qwrong_type_argument, list2 (Qfloatp, value), |
| 428 | 763 Qhash_table, errb); |
| 764 return 0; | |
| 765 } | |
| 766 | |
| 767 { | |
| 768 double rehash_threshold = XFLOAT_DATA (value); | |
| 769 if (rehash_threshold <= 0.0 || rehash_threshold >= 1.0) | |
| 770 { | |
| 563 | 771 maybe_invalid_argument |
| 428 | 772 ("Hash table rehash threshold must be between 0.0 and 1.0", |
| 773 value, Qhash_table, errb); | |
| 774 return 0; | |
| 775 } | |
| 776 } | |
| 777 | |
| 778 return 1; | |
| 779 } | |
| 780 | |
| 781 static double | |
| 782 decode_hash_table_rehash_threshold (Lisp_Object rehash_threshold) | |
| 783 { | |
|
4585
871eb054b34a
Document non-obvious usages.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4410
diff
changeset
|
784 /* -1.0 signals make_general_lisp_hash_table to use the default. */ |
| 428 | 785 return NILP (rehash_threshold) ? -1.0 : XFLOAT_DATA (rehash_threshold); |
| 786 } | |
| 787 | |
| 788 static int | |
| 2286 | 789 hash_table_data_validate (Lisp_Object UNUSED (keyword), Lisp_Object value, |
| 790 Error_Behavior errb) | |
| 428 | 791 { |
| 792 int len; | |
| 793 | |
|
4585
871eb054b34a
Document non-obvious usages.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4410
diff
changeset
|
794 /* Check for improper lists while getting length. */ |
| 428 | 795 GET_EXTERNAL_LIST_LENGTH (value, len); |
| 796 | |
| 797 if (len & 1) | |
| 798 { | |
| 563 | 799 maybe_sferror |
| 428 | 800 ("Hash table data must have alternating key/value pairs", |
| 801 value, Qhash_table, errb); | |
| 802 return 0; | |
| 803 } | |
|
4585
871eb054b34a
Document non-obvious usages.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4410
diff
changeset
|
804 |
| 428 | 805 return 1; |
| 806 } | |
| 807 | |
| 808 /* The actual instantiation of a hash table. This does practically no | |
| 809 error checking, because it relies on the fact that the paranoid | |
| 810 functions above have error-checked everything to the last details. | |
| 811 If this assumption is wrong, we will get a crash immediately (with | |
| 812 error-checking compiled in), and we'll know if there is a bug in | |
| 813 the structure mechanism. So there. */ | |
| 814 static Lisp_Object | |
| 815 hash_table_instantiate (Lisp_Object plist) | |
| 816 { | |
| 817 Lisp_Object hash_table; | |
| 818 Lisp_Object test = Qnil; | |
| 819 Lisp_Object size = Qnil; | |
| 820 Lisp_Object rehash_size = Qnil; | |
| 821 Lisp_Object rehash_threshold = Qnil; | |
| 822 Lisp_Object weakness = Qnil; | |
| 823 Lisp_Object data = Qnil; | |
| 824 | |
|
4820
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
825 if (KEYWORDP (Fcar (plist))) |
| 428 | 826 { |
|
4820
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
827 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
|
828 { |
|
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
829 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
|
830 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
|
831 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
|
832 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
|
833 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
|
834 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
|
835 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
|
836 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
|
837 "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
|
838 key); |
|
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
839 else ABORT(); |
|
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
840 } |
|
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
841 } |
|
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
842 else |
|
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
843 { |
|
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
844 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
|
845 { |
|
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
846 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
|
847 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
|
848 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
|
849 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
|
850 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
|
851 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
|
852 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
|
853 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
|
854 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
|
855 "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
|
856 key); |
|
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
857 else ABORT(); |
|
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
858 } |
| 428 | 859 } |
| 860 | |
| 861 /* Create the hash table. */ | |
| 450 | 862 hash_table = make_standard_lisp_hash_table |
| 428 | 863 (decode_hash_table_test (test), |
| 864 decode_hash_table_size (size), | |
| 865 decode_hash_table_rehash_size (rehash_size), | |
| 866 decode_hash_table_rehash_threshold (rehash_threshold), | |
| 867 decode_hash_table_weakness (weakness)); | |
| 868 | |
| 869 /* I'm not sure whether this can GC, but better safe than sorry. */ | |
| 870 { | |
| 871 struct gcpro gcpro1; | |
| 872 GCPRO1 (hash_table); | |
| 873 | |
| 874 /* And fill it with data. */ | |
| 875 while (!NILP (data)) | |
| 876 { | |
| 877 Lisp_Object key, value; | |
| 878 key = XCAR (data); data = XCDR (data); | |
| 879 value = XCAR (data); data = XCDR (data); | |
| 880 Fputhash (key, value, hash_table); | |
| 881 } | |
| 882 UNGCPRO; | |
| 883 } | |
| 884 | |
| 885 return hash_table; | |
| 886 } | |
| 887 | |
| 888 static void | |
| 889 structure_type_create_hash_table_structure_name (Lisp_Object structure_name) | |
| 890 { | |
| 891 struct structure_type *st; | |
| 892 | |
| 893 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
|
894 |
|
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
895 /* 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
|
896 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
|
897 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
|
898 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
|
899 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
|
900 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
|
901 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
|
902 |
|
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
903 /* Next the mutually exclusive, older, non-keyword syntax: */ |
| 428 | 904 define_structure_type_keyword (st, Qtest, hash_table_test_validate); |
| 905 define_structure_type_keyword (st, Qsize, hash_table_size_validate); | |
| 906 define_structure_type_keyword (st, Qrehash_size, hash_table_rehash_size_validate); | |
| 907 define_structure_type_keyword (st, Qrehash_threshold, hash_table_rehash_threshold_validate); | |
| 908 define_structure_type_keyword (st, Qweakness, hash_table_weakness_validate); | |
| 909 define_structure_type_keyword (st, Qdata, hash_table_data_validate); | |
| 910 | |
| 911 /* obsolete as of 19990901 in xemacs-21.2 */ | |
| 912 define_structure_type_keyword (st, Qtype, hash_table_weakness_validate); | |
| 913 } | |
| 914 | |
| 915 /* Create a built-in Lisp structure type named `hash-table'. | |
| 916 We make #s(hashtable ...) equivalent to #s(hash-table ...), | |
| 917 for backward compatibility. | |
| 918 This is called from emacs.c. */ | |
| 919 void | |
| 920 structure_type_create_hash_table (void) | |
| 921 { | |
| 922 structure_type_create_hash_table_structure_name (Qhash_table); | |
| 923 structure_type_create_hash_table_structure_name (Qhashtable); /* compat */ | |
| 924 } | |
| 925 | |
| 926 | |
| 927 /************************************************************************/ | |
| 928 /* Definition of Lisp-visible methods */ | |
| 929 /************************************************************************/ | |
| 930 | |
| 931 DEFUN ("hash-table-p", Fhash_table_p, 1, 1, 0, /* | |
| 932 Return t if OBJECT is a hash table, else nil. | |
| 933 */ | |
| 934 (object)) | |
| 935 { | |
| 936 return HASH_TABLEP (object) ? Qt : Qnil; | |
| 937 } | |
| 938 | |
| 939 DEFUN ("make-hash-table", Fmake_hash_table, 0, MANY, 0, /* | |
| 940 Return a new empty hash table object. | |
| 941 Use Common Lisp style keywords to specify hash table properties. | |
| 942 | |
| 943 Keyword :test can be `eq', `eql' (default) or `equal'. | |
| 944 Comparison between keys is done using this function. | |
| 945 If speed is important, consider using `eq'. | |
| 946 When storing strings in the hash table, you will likely need to use `equal'. | |
| 947 | |
| 948 Keyword :size specifies the number of keys likely to be inserted. | |
| 949 This number of entries can be inserted without enlarging the hash table. | |
| 950 | |
| 951 Keyword :rehash-size must be a float greater than 1.0, and specifies | |
| 952 the factor by which to increase the size of the hash table when enlarging. | |
| 953 | |
| 954 Keyword :rehash-threshold must be a float between 0.0 and 1.0, | |
| 955 and specifies the load factor of the hash table which triggers enlarging. | |
| 956 | |
| 442 | 957 Non-standard keyword :weakness can be `nil' (default), `t', `key-and-value', |
| 958 `key', `value' or `key-or-value'. `t' is an alias for `key-and-value'. | |
| 428 | 959 |
| 442 | 960 A key-and-value-weak hash table, also known as a fully-weak or simply |
| 961 as a weak hash table, is one whose pointers do not count as GC | |
| 962 referents: for any key-value pair in the hash table, if the only | |
| 963 remaining pointer to either the key or the value is in a weak hash | |
| 964 table, then the pair will be removed from the hash table, and the key | |
| 965 and value collected. A non-weak hash table (or any other pointer) | |
| 966 would prevent the object from being collected. | |
| 428 | 967 |
| 968 A key-weak hash table is similar to a fully-weak hash table except that | |
| 969 a key-value pair will be removed only if the key remains unmarked | |
| 970 outside of weak hash tables. The pair will remain in the hash table if | |
| 971 the key is pointed to by something other than a weak hash table, even | |
| 972 if the value is not. | |
| 973 | |
| 974 A value-weak hash table is similar to a fully-weak hash table except | |
| 975 that a key-value pair will be removed only if the value remains | |
| 976 unmarked outside of weak hash tables. The pair will remain in the | |
| 977 hash table if the value is pointed to by something other than a weak | |
| 978 hash table, even if the key is not. | |
| 442 | 979 |
| 980 A key-or-value-weak hash table is similar to a fully-weak hash table except | |
| 981 that a key-value pair will be removed only if the value and the key remain | |
| 982 unmarked outside of weak hash tables. The pair will remain in the | |
| 983 hash table if the value or key are pointed to by something other than a weak | |
| 984 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
|
985 |
|
4777
c69aeb86b2a3
Serialise non-default hash table rehash thresholds correctly; use this.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
986 arguments: (&key TEST SIZE REHASH-SIZE REHASH-THRESHOLD WEAKNESS) |
| 428 | 987 */ |
| 988 (int nargs, Lisp_Object *args)) | |
| 989 { | |
|
5084
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4976
diff
changeset
|
990 #ifdef NO_NEED_TO_HANDLE_21_4_CODE |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4976
diff
changeset
|
991 PARSE_KEYWORDS (Qmake_hash_table, nargs, args, 0, 5, |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4976
diff
changeset
|
992 (test, size, rehash_size, rehash_threshold, weakness), |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4976
diff
changeset
|
993 NULL, weakness = Qunbound), 0); |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4976
diff
changeset
|
994 #else |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4976
diff
changeset
|
995 PARSE_KEYWORDS (Qmake_hash_table, nargs, args, 0, 6, |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4976
diff
changeset
|
996 (test, size, rehash_size, rehash_threshold, weakness, |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4976
diff
changeset
|
997 type), (type = Qunbound, weakness = Qunbound), 0); |
| 428 | 998 |
|
5084
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4976
diff
changeset
|
999 if (EQ (weakness, Qunbound)) |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4976
diff
changeset
|
1000 { |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4976
diff
changeset
|
1001 if (EQ (weakness, Qunbound) && !EQ (type, Qunbound)) |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4976
diff
changeset
|
1002 { |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4976
diff
changeset
|
1003 weakness = type; |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4976
diff
changeset
|
1004 } |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4976
diff
changeset
|
1005 else |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4976
diff
changeset
|
1006 { |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4976
diff
changeset
|
1007 weakness = Qnil; |
|
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4976
diff
changeset
|
1008 } |
| 428 | 1009 } |
|
5084
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4976
diff
changeset
|
1010 #endif |
| 428 | 1011 |
| 1012 #define VALIDATE_VAR(var) \ | |
| 1013 if (!NILP (var)) hash_table_##var##_validate (Q##var, var, ERROR_ME); | |
| 1014 | |
| 1015 VALIDATE_VAR (test); | |
| 1016 VALIDATE_VAR (size); | |
| 1017 VALIDATE_VAR (rehash_size); | |
| 1018 VALIDATE_VAR (rehash_threshold); | |
| 1019 VALIDATE_VAR (weakness); | |
| 1020 | |
| 450 | 1021 return make_standard_lisp_hash_table |
| 428 | 1022 (decode_hash_table_test (test), |
| 1023 decode_hash_table_size (size), | |
| 1024 decode_hash_table_rehash_size (rehash_size), | |
| 1025 decode_hash_table_rehash_threshold (rehash_threshold), | |
| 1026 decode_hash_table_weakness (weakness)); | |
| 1027 } | |
| 1028 | |
| 1029 DEFUN ("copy-hash-table", Fcopy_hash_table, 1, 1, 0, /* | |
| 1030 Return a new hash table containing the same keys and values as HASH-TABLE. | |
| 1031 The keys and values will not themselves be copied. | |
| 1032 */ | |
| 1033 (hash_table)) | |
| 1034 { | |
| 442 | 1035 const Lisp_Hash_Table *ht_old = xhash_table (hash_table); |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
1036 Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (hash_table); |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
1037 Lisp_Hash_Table *ht = XHASH_TABLE (obj); |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
1038 copy_lisp_object (obj, hash_table); |
| 428 | 1039 |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1040 /* We leave room for one never-occupied sentinel htentry at the end. */ |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1041 ht->hentries = allocate_hash_table_entries (ht_old->size + 1); |
| 1204 | 1042 memcpy (ht->hentries, ht_old->hentries, (ht_old->size + 1) * sizeof (htentry)); |
| 428 | 1043 |
| 1044 if (! EQ (ht->next_weak, Qunbound)) | |
| 1045 { | |
| 1046 ht->next_weak = Vall_weak_hash_tables; | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
1047 Vall_weak_hash_tables = obj; |
| 428 | 1048 } |
| 1049 | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
1050 return obj; |
| 428 | 1051 } |
| 1052 | |
| 1053 static void | |
| 665 | 1054 resize_hash_table (Lisp_Hash_Table *ht, Elemcount new_size) |
| 428 | 1055 { |
| 1204 | 1056 htentry *old_entries, *new_entries, *sentinel, *e; |
| 665 | 1057 Elemcount old_size; |
| 428 | 1058 |
| 1059 old_size = ht->size; | |
| 1060 ht->size = new_size; | |
| 1061 | |
| 1062 old_entries = ht->hentries; | |
| 1063 | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1064 /* We leave room for one never-occupied sentinel htentry at the end. */ |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1065 ht->hentries = allocate_hash_table_entries (new_size + 1); |
| 428 | 1066 new_entries = ht->hentries; |
| 1067 | |
| 1068 compute_hash_table_derived_values (ht); | |
| 1069 | |
| 440 | 1070 for (e = old_entries, sentinel = e + old_size; e < sentinel; e++) |
| 1204 | 1071 if (!HTENTRY_CLEAR_P (e)) |
| 428 | 1072 { |
| 1204 | 1073 htentry *probe = new_entries + HASHCODE (e->key, ht); |
| 428 | 1074 LINEAR_PROBING_LOOP (probe, new_entries, new_size) |
| 1075 ; | |
| 1076 *probe = *e; | |
| 1077 } | |
| 1078 | |
| 4117 | 1079 #ifndef NEW_GC |
| 489 | 1080 free_hentries (old_entries, old_size); |
| 4117 | 1081 #endif /* not NEW_GC */ |
| 428 | 1082 } |
| 1083 | |
| 440 | 1084 /* After a hash table has been saved to disk and later restored by the |
| 1085 portable dumper, it contains the same objects, but their addresses | |
| 665 | 1086 and thus their HASHCODEs have changed. */ |
| 428 | 1087 void |
| 440 | 1088 pdump_reorganize_hash_table (Lisp_Object hash_table) |
| 428 | 1089 { |
| 442 | 1090 const Lisp_Hash_Table *ht = xhash_table (hash_table); |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1091 /* We leave room for one never-occupied sentinel htentry at the end. */ |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1092 htentry *new_entries = allocate_hash_table_entries (ht->size + 1); |
| 1204 | 1093 htentry *e, *sentinel; |
| 440 | 1094 |
| 1095 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++) | |
| 1204 | 1096 if (!HTENTRY_CLEAR_P (e)) |
| 440 | 1097 { |
| 1204 | 1098 htentry *probe = new_entries + HASHCODE (e->key, ht); |
| 440 | 1099 LINEAR_PROBING_LOOP (probe, new_entries, ht->size) |
| 1100 ; | |
| 1101 *probe = *e; | |
| 1102 } | |
| 1103 | |
| 1204 | 1104 memcpy (ht->hentries, new_entries, ht->size * sizeof (htentry)); |
| 440 | 1105 |
| 4117 | 1106 #ifndef NEW_GC |
|
4976
16112448d484
Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
1107 xfree (new_entries); |
| 3092 | 1108 #endif /* not NEW_GC */ |
| 428 | 1109 } |
| 1110 | |
| 1111 static void | |
| 1112 enlarge_hash_table (Lisp_Hash_Table *ht) | |
| 1113 { | |
| 665 | 1114 Elemcount new_size = |
| 1115 hash_table_size ((Elemcount) ((double) ht->size * ht->rehash_size)); | |
| 428 | 1116 resize_hash_table (ht, new_size); |
| 1117 } | |
| 1118 | |
| 4072 | 1119 htentry * |
| 1204 | 1120 find_htentry (Lisp_Object key, const Lisp_Hash_Table *ht) |
| 428 | 1121 { |
| 1122 hash_table_test_function_t test_function = ht->test_function; | |
| 1204 | 1123 htentry *entries = ht->hentries; |
| 1124 htentry *probe = entries + HASHCODE (key, ht); | |
| 428 | 1125 |
| 1126 LINEAR_PROBING_LOOP (probe, entries, ht->size) | |
| 1127 if (KEYS_EQUAL_P (probe->key, key, test_function)) | |
| 1128 break; | |
| 1129 | |
| 1130 return probe; | |
| 1131 } | |
| 1132 | |
| 2421 | 1133 /* A version of Fputhash() that increments the value by the specified |
| 1134 amount and dispenses will all error checks. Assumes that tables does | |
| 1135 comparison using EQ. Used by the profiling routines to avoid | |
| 1136 overhead -- profiling overhead was being recorded at up to 15% of the | |
| 1137 total time. */ | |
| 1138 | |
| 1139 void | |
| 1140 inchash_eq (Lisp_Object key, Lisp_Object table, EMACS_INT offset) | |
| 1141 { | |
| 1142 Lisp_Hash_Table *ht = XHASH_TABLE (table); | |
| 1143 htentry *entries = ht->hentries; | |
| 1144 htentry *probe = entries + HASHCODE (key, ht); | |
| 1145 | |
| 1146 LINEAR_PROBING_LOOP (probe, entries, ht->size) | |
| 1147 if (EQ (probe->key, key)) | |
| 1148 break; | |
| 1149 | |
| 1150 if (!HTENTRY_CLEAR_P (probe)) | |
| 1151 probe->value = make_int (XINT (probe->value) + offset); | |
| 1152 else | |
| 1153 { | |
| 1154 probe->key = key; | |
| 1155 probe->value = make_int (offset); | |
| 1156 | |
| 1157 if (++ht->count >= ht->rehash_count) | |
| 1158 enlarge_hash_table (ht); | |
| 1159 } | |
| 1160 } | |
| 1161 | |
| 428 | 1162 DEFUN ("gethash", Fgethash, 2, 3, 0, /* |
| 1163 Find hash value for KEY in HASH-TABLE. | |
| 1164 If there is no corresponding value, return DEFAULT (which defaults to nil). | |
| 1165 */ | |
| 1166 (key, hash_table, default_)) | |
| 1167 { | |
| 442 | 1168 const Lisp_Hash_Table *ht = xhash_table (hash_table); |
| 1204 | 1169 htentry *e = find_htentry (key, ht); |
| 428 | 1170 |
| 1204 | 1171 return HTENTRY_CLEAR_P (e) ? default_ : e->value; |
| 428 | 1172 } |
| 1173 | |
| 1174 DEFUN ("puthash", Fputhash, 3, 3, 0, /* | |
|
4410
aae1994dfeec
Document return values for #'puthash, #'clrhash.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4398
diff
changeset
|
1175 Hash KEY to VALUE in HASH-TABLE, and return VALUE. |
| 428 | 1176 */ |
| 1177 (key, value, hash_table)) | |
| 1178 { | |
| 1179 Lisp_Hash_Table *ht = xhash_table (hash_table); | |
| 1204 | 1180 htentry *e = find_htentry (key, ht); |
| 428 | 1181 |
| 1204 | 1182 if (!HTENTRY_CLEAR_P (e)) |
| 428 | 1183 return e->value = value; |
| 1184 | |
| 1185 e->key = key; | |
| 1186 e->value = value; | |
| 1187 | |
| 1188 if (++ht->count >= ht->rehash_count) | |
| 1189 enlarge_hash_table (ht); | |
| 1190 | |
| 1191 return value; | |
| 1192 } | |
| 1193 | |
| 1204 | 1194 /* Remove htentry pointed at by PROBE. |
| 428 | 1195 Subsequent entries are removed and reinserted. |
| 1196 We don't use tombstones - too wasteful. */ | |
| 1197 static void | |
| 1204 | 1198 remhash_1 (Lisp_Hash_Table *ht, htentry *entries, htentry *probe) |
| 428 | 1199 { |
| 665 | 1200 Elemcount size = ht->size; |
| 1204 | 1201 CLEAR_HTENTRY (probe); |
| 428 | 1202 probe++; |
| 1203 ht->count--; | |
| 1204 | |
| 1205 LINEAR_PROBING_LOOP (probe, entries, size) | |
| 1206 { | |
| 1207 Lisp_Object key = probe->key; | |
| 1204 | 1208 htentry *probe2 = entries + HASHCODE (key, ht); |
| 428 | 1209 LINEAR_PROBING_LOOP (probe2, entries, size) |
| 1210 if (EQ (probe2->key, key)) | |
| 1204 | 1211 /* htentry at probe doesn't need to move. */ |
| 428 | 1212 goto continue_outer_loop; |
| 1204 | 1213 /* Move htentry from probe to new home at probe2. */ |
| 428 | 1214 *probe2 = *probe; |
| 1204 | 1215 CLEAR_HTENTRY (probe); |
| 428 | 1216 continue_outer_loop: continue; |
| 1217 } | |
| 1218 } | |
| 1219 | |
| 1220 DEFUN ("remhash", Fremhash, 2, 2, 0, /* | |
| 1221 Remove the entry for KEY from HASH-TABLE. | |
| 1222 Do nothing if there is no entry for KEY in HASH-TABLE. | |
| 617 | 1223 Return non-nil if an entry was removed. |
| 428 | 1224 */ |
| 1225 (key, hash_table)) | |
| 1226 { | |
| 1227 Lisp_Hash_Table *ht = xhash_table (hash_table); | |
| 1204 | 1228 htentry *e = find_htentry (key, ht); |
| 428 | 1229 |
| 1204 | 1230 if (HTENTRY_CLEAR_P (e)) |
| 428 | 1231 return Qnil; |
| 1232 | |
| 1233 remhash_1 (ht, ht->hentries, e); | |
| 1234 return Qt; | |
| 1235 } | |
| 1236 | |
| 1237 DEFUN ("clrhash", Fclrhash, 1, 1, 0, /* | |
| 1238 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
|
1239 Return HASH-TABLE. |
| 428 | 1240 */ |
| 1241 (hash_table)) | |
| 1242 { | |
| 1243 Lisp_Hash_Table *ht = xhash_table (hash_table); | |
| 1204 | 1244 htentry *e, *sentinel; |
| 428 | 1245 |
| 1246 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++) | |
| 1204 | 1247 CLEAR_HTENTRY (e); |
| 428 | 1248 ht->count = 0; |
| 1249 | |
| 1250 return hash_table; | |
| 1251 } | |
| 1252 | |
| 1253 /************************************************************************/ | |
| 1254 /* Accessor Functions */ | |
| 1255 /************************************************************************/ | |
| 1256 | |
| 1257 DEFUN ("hash-table-count", Fhash_table_count, 1, 1, 0, /* | |
| 1258 Return the number of entries in HASH-TABLE. | |
| 1259 */ | |
| 1260 (hash_table)) | |
| 1261 { | |
| 1262 return make_int (xhash_table (hash_table)->count); | |
| 1263 } | |
| 1264 | |
| 1265 DEFUN ("hash-table-test", Fhash_table_test, 1, 1, 0, /* | |
| 1266 Return the test function of HASH-TABLE. | |
| 1267 This can be one of `eq', `eql' or `equal'. | |
| 1268 */ | |
| 1269 (hash_table)) | |
| 1270 { | |
| 1271 hash_table_test_function_t fun = xhash_table (hash_table)->test_function; | |
| 1272 | |
| 1273 return (fun == lisp_object_eql_equal ? Qeql : | |
| 1274 fun == lisp_object_equal_equal ? Qequal : | |
| 1275 Qeq); | |
| 1276 } | |
| 1277 | |
| 1278 DEFUN ("hash-table-size", Fhash_table_size, 1, 1, 0, /* | |
| 1279 Return the size of HASH-TABLE. | |
| 1280 This is the current number of slots in HASH-TABLE, whether occupied or not. | |
| 1281 */ | |
| 1282 (hash_table)) | |
| 1283 { | |
| 1284 return make_int (xhash_table (hash_table)->size); | |
| 1285 } | |
| 1286 | |
| 1287 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size, 1, 1, 0, /* | |
| 1288 Return the current rehash size of HASH-TABLE. | |
| 1289 This is a float greater than 1.0; the factor by which HASH-TABLE | |
| 1290 is enlarged when the rehash threshold is exceeded. | |
| 1291 */ | |
| 1292 (hash_table)) | |
| 1293 { | |
| 1294 return make_float (xhash_table (hash_table)->rehash_size); | |
| 1295 } | |
| 1296 | |
| 1297 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold, 1, 1, 0, /* | |
| 1298 Return the current rehash threshold of HASH-TABLE. | |
| 1299 This is a float between 0.0 and 1.0; the maximum `load factor' of HASH-TABLE, | |
| 1300 beyond which the HASH-TABLE is enlarged by rehashing. | |
| 1301 */ | |
| 1302 (hash_table)) | |
| 1303 { | |
| 438 | 1304 return make_float (xhash_table (hash_table)->rehash_threshold); |
| 428 | 1305 } |
| 1306 | |
| 1307 DEFUN ("hash-table-weakness", Fhash_table_weakness, 1, 1, 0, /* | |
| 1308 Return the weakness of HASH-TABLE. | |
| 442 | 1309 This can be one of `nil', `key-and-value', `key-or-value', `key' or `value'. |
| 428 | 1310 */ |
| 1311 (hash_table)) | |
| 1312 { | |
| 1313 switch (xhash_table (hash_table)->weakness) | |
| 1314 { | |
| 442 | 1315 case HASH_TABLE_WEAK: return Qkey_and_value; |
| 1316 case HASH_TABLE_KEY_WEAK: return Qkey; | |
| 1317 case HASH_TABLE_KEY_VALUE_WEAK: return Qkey_or_value; | |
| 1318 case HASH_TABLE_VALUE_WEAK: return Qvalue; | |
| 1319 default: return Qnil; | |
| 428 | 1320 } |
| 1321 } | |
| 1322 | |
| 1323 /* obsolete as of 19990901 in xemacs-21.2 */ | |
| 1324 DEFUN ("hash-table-type", Fhash_table_type, 1, 1, 0, /* | |
| 1325 Return the type of HASH-TABLE. | |
| 1326 This can be one of `non-weak', `weak', `key-weak' or `value-weak'. | |
| 1327 */ | |
| 1328 (hash_table)) | |
| 1329 { | |
| 1330 switch (xhash_table (hash_table)->weakness) | |
| 1331 { | |
| 442 | 1332 case HASH_TABLE_WEAK: return Qweak; |
| 1333 case HASH_TABLE_KEY_WEAK: return Qkey_weak; | |
| 1334 case HASH_TABLE_KEY_VALUE_WEAK: return Qkey_or_value_weak; | |
| 1335 case HASH_TABLE_VALUE_WEAK: return Qvalue_weak; | |
| 1336 default: return Qnon_weak; | |
| 428 | 1337 } |
| 1338 } | |
| 1339 | |
| 1340 /************************************************************************/ | |
| 1341 /* Mapping Functions */ | |
| 1342 /************************************************************************/ | |
| 489 | 1343 |
| 1344 /* We need to be careful when mapping over hash tables because the | |
| 1345 hash table might be modified during the mapping operation: | |
| 1346 - by the mapping function | |
| 1347 - by gc (if the hash table is weak) | |
| 1348 | |
| 1349 So we make a copy of the hentries at the beginning of the mapping | |
| 497 | 1350 operation, and iterate over the copy. Naturally, this is |
| 1351 expensive, but not as expensive as you might think, because no | |
| 1352 actual memory has to be collected by our notoriously inefficient | |
| 1353 GC; we use an unwind-protect instead to free the memory directly. | |
| 1354 | |
| 1355 We could avoid the copying by having the hash table modifiers | |
| 1356 puthash and remhash check for currently active mapping functions. | |
| 1357 Disadvantages: it's hard to get right, and IMO hash mapping | |
| 1358 functions are basically rare, and no extra space in the hash table | |
| 1359 object and no extra cpu in puthash or remhash should be wasted to | |
| 1360 make maphash 3% faster. From a design point of view, the basic | |
| 1361 functions gethash, puthash and remhash should be implementable | |
| 1362 without having to think about maphash. | |
| 1363 | |
| 1364 Note: We don't (yet) have Common Lisp's with-hash-table-iterator. | |
| 1365 If you implement this naively, you cannot have more than one | |
| 1366 concurrently active iterator over the same hash table. The `each' | |
| 1367 function in perl has this limitation. | |
| 1368 | |
| 1369 Note: We GCPRO memory on the heap, not on the stack. There is no | |
| 1370 obvious reason why this is bad, but as of this writing this is the | |
| 1371 only known occurrence of this technique in the code. | |
| 504 | 1372 |
| 1373 -- Martin | |
| 1374 */ | |
| 1375 | |
| 1376 /* Ben disagrees with the "copying hentries" design, and says: | |
| 1377 | |
| 1378 Another solution is the same as I've already proposed -- when | |
| 1379 mapping, mark the table as "change-unsafe", and in this case, use a | |
| 1380 secondary table to maintain changes. this could be basically a | |
| 1381 standard hash table, but with entries only for added or deleted | |
| 1382 entries in the primary table, and a marker like Qunbound to | |
| 1383 indicate a deleted entry. puthash, gethash and remhash need a | |
| 1384 single extra check for this secondary table -- totally | |
| 1385 insignificant speedwise. if you really cared about making | |
| 1386 recursive maphashes completely correct, you'd have to do a bit of | |
| 1387 extra work here -- when maphashing, if the secondary table exists, | |
| 1388 make a copy of it, and use the copy in conjunction with the primary | |
| 1389 table when mapping. the advantages of this are | |
| 1390 | |
| 1391 [a] easy to demonstrate correct, even with weak hashtables. | |
| 1392 | |
| 1393 [b] no extra overhead in the general maphash case -- only when you | |
| 1394 modify the table while maphashing, and even then the overhead is | |
| 1395 very small. | |
| 497 | 1396 */ |
| 1397 | |
| 489 | 1398 static Lisp_Object |
| 1399 maphash_unwind (Lisp_Object unwind_obj) | |
| 1400 { | |
| 1401 void *ptr = (void *) get_opaque_ptr (unwind_obj); | |
|
4976
16112448d484
Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
1402 xfree (ptr); |
| 489 | 1403 free_opaque_ptr (unwind_obj); |
| 1404 return Qnil; | |
| 1405 } | |
| 1406 | |
| 1407 /* Return a malloced array of alternating key/value pairs from HT. */ | |
| 1408 static Lisp_Object * | |
| 1409 copy_compress_hentries (const Lisp_Hash_Table *ht) | |
| 1410 { | |
| 1411 Lisp_Object * const objs = | |
| 1412 /* If the hash table is empty, ht->count could be 0. */ | |
| 1413 xnew_array (Lisp_Object, 2 * (ht->count > 0 ? ht->count : 1)); | |
| 1204 | 1414 const htentry *e, *sentinel; |
| 489 | 1415 Lisp_Object *pobj; |
| 1416 | |
| 1417 for (e = ht->hentries, sentinel = e + ht->size, pobj = objs; e < sentinel; e++) | |
| 1204 | 1418 if (!HTENTRY_CLEAR_P (e)) |
| 489 | 1419 { |
| 1420 *(pobj++) = e->key; | |
| 1421 *(pobj++) = e->value; | |
| 1422 } | |
| 1423 | |
| 1424 type_checking_assert (pobj == objs + 2 * ht->count); | |
| 1425 | |
| 1426 return objs; | |
| 1427 } | |
| 1428 | |
| 428 | 1429 DEFUN ("maphash", Fmaphash, 2, 2, 0, /* |
| 1430 Map FUNCTION over entries in HASH-TABLE, calling it with two args, | |
| 1431 each key and value in HASH-TABLE. | |
| 1432 | |
| 489 | 1433 FUNCTION must not modify HASH-TABLE, with the one exception that FUNCTION |
| 428 | 1434 may remhash or puthash the entry currently being processed by FUNCTION. |
| 1435 */ | |
| 1436 (function, hash_table)) | |
| 1437 { | |
| 489 | 1438 const Lisp_Hash_Table * const ht = xhash_table (hash_table); |
| 1439 Lisp_Object * const objs = copy_compress_hentries (ht); | |
| 1440 Lisp_Object args[3]; | |
| 1441 const Lisp_Object *pobj, *end; | |
| 1442 int speccount = specpdl_depth (); | |
| 1443 struct gcpro gcpro1; | |
| 1444 | |
| 1445 record_unwind_protect (maphash_unwind, make_opaque_ptr ((void *)objs)); | |
| 1446 GCPRO1 (objs[0]); | |
| 1447 gcpro1.nvars = 2 * ht->count; | |
| 428 | 1448 |
| 489 | 1449 args[0] = function; |
| 1450 | |
| 1451 for (pobj = objs, end = pobj + 2 * ht->count; pobj < end; pobj += 2) | |
| 1452 { | |
| 1453 args[1] = pobj[0]; | |
| 1454 args[2] = pobj[1]; | |
| 1455 Ffuncall (countof (args), args); | |
| 1456 } | |
| 1457 | |
| 771 | 1458 unbind_to (speccount); |
| 489 | 1459 UNGCPRO; |
| 428 | 1460 |
| 1461 return Qnil; | |
| 1462 } | |
| 1463 | |
| 489 | 1464 /* Map *C* function FUNCTION over the elements of a non-weak lisp hash table. |
| 1465 FUNCTION must not modify HASH-TABLE, with the one exception that FUNCTION | |
| 1466 may puthash the entry currently being processed by FUNCTION. | |
| 1467 Mapping terminates if FUNCTION returns something other than 0. */ | |
| 428 | 1468 void |
| 489 | 1469 elisp_maphash_unsafe (maphash_function_t function, |
| 428 | 1470 Lisp_Object hash_table, void *extra_arg) |
| 1471 { | |
| 442 | 1472 const Lisp_Hash_Table *ht = XHASH_TABLE (hash_table); |
| 1204 | 1473 const htentry *e, *sentinel; |
| 428 | 1474 |
| 1475 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++) | |
| 1204 | 1476 if (!HTENTRY_CLEAR_P (e)) |
| 489 | 1477 if (function (e->key, e->value, extra_arg)) |
| 1478 return; | |
| 428 | 1479 } |
| 1480 | |
| 489 | 1481 /* Map *C* function FUNCTION over the elements of a lisp hash table. |
| 1482 It is safe for FUNCTION to modify HASH-TABLE. | |
| 1483 Mapping terminates if FUNCTION returns something other than 0. */ | |
| 1484 void | |
| 1485 elisp_maphash (maphash_function_t function, | |
| 1486 Lisp_Object hash_table, void *extra_arg) | |
| 1487 { | |
| 1488 const Lisp_Hash_Table * const ht = xhash_table (hash_table); | |
| 1489 Lisp_Object * const objs = copy_compress_hentries (ht); | |
| 1490 const Lisp_Object *pobj, *end; | |
| 1491 int speccount = specpdl_depth (); | |
| 1492 struct gcpro gcpro1; | |
| 1493 | |
| 1494 record_unwind_protect (maphash_unwind, make_opaque_ptr ((void *)objs)); | |
| 1495 GCPRO1 (objs[0]); | |
| 1496 gcpro1.nvars = 2 * ht->count; | |
| 1497 | |
| 1498 for (pobj = objs, end = pobj + 2 * ht->count; pobj < end; pobj += 2) | |
| 1499 if (function (pobj[0], pobj[1], extra_arg)) | |
| 1500 break; | |
| 1501 | |
| 771 | 1502 unbind_to (speccount); |
| 489 | 1503 UNGCPRO; |
| 1504 } | |
| 1505 | |
| 1506 /* Remove all elements of a lisp hash table satisfying *C* predicate PREDICATE. | |
| 1507 PREDICATE must not modify HASH-TABLE. */ | |
| 428 | 1508 void |
| 1509 elisp_map_remhash (maphash_function_t predicate, | |
| 1510 Lisp_Object hash_table, void *extra_arg) | |
| 1511 { | |
| 489 | 1512 const Lisp_Hash_Table * const ht = xhash_table (hash_table); |
| 1513 Lisp_Object * const objs = copy_compress_hentries (ht); | |
| 1514 const Lisp_Object *pobj, *end; | |
| 1515 int speccount = specpdl_depth (); | |
| 1516 struct gcpro gcpro1; | |
| 428 | 1517 |
| 489 | 1518 record_unwind_protect (maphash_unwind, make_opaque_ptr ((void *)objs)); |
| 1519 GCPRO1 (objs[0]); | |
| 1520 gcpro1.nvars = 2 * ht->count; | |
| 1521 | |
| 1522 for (pobj = objs, end = pobj + 2 * ht->count; pobj < end; pobj += 2) | |
| 1523 if (predicate (pobj[0], pobj[1], extra_arg)) | |
| 1524 Fremhash (pobj[0], hash_table); | |
| 1525 | |
| 771 | 1526 unbind_to (speccount); |
| 489 | 1527 UNGCPRO; |
| 428 | 1528 } |
| 1529 | |
| 1530 | |
| 1531 /************************************************************************/ | |
| 1532 /* garbage collecting weak hash tables */ | |
| 1533 /************************************************************************/ | |
| 1598 | 1534 #ifdef USE_KKCC |
| 2645 | 1535 #define MARK_OBJ(obj) do { \ |
| 1536 Lisp_Object mo_obj = (obj); \ | |
| 1537 if (!marked_p (mo_obj)) \ | |
| 1538 { \ | |
| 1539 kkcc_gc_stack_push_lisp_object (mo_obj, 0, -1); \ | |
| 1540 did_mark = 1; \ | |
| 1541 } \ | |
| 1598 | 1542 } while (0) |
| 1543 | |
| 1544 #else /* NO USE_KKCC */ | |
| 1545 | |
| 442 | 1546 #define MARK_OBJ(obj) do { \ |
| 1547 Lisp_Object mo_obj = (obj); \ | |
| 1548 if (!marked_p (mo_obj)) \ | |
| 1549 { \ | |
| 1550 mark_object (mo_obj); \ | |
| 1551 did_mark = 1; \ | |
| 1552 } \ | |
| 1553 } while (0) | |
| 1598 | 1554 #endif /*NO USE_KKCC */ |
| 442 | 1555 |
| 428 | 1556 |
| 1557 /* Complete the marking for semi-weak hash tables. */ | |
| 1558 int | |
| 1559 finish_marking_weak_hash_tables (void) | |
| 1560 { | |
| 1561 Lisp_Object hash_table; | |
| 1562 int did_mark = 0; | |
| 1563 | |
| 1564 for (hash_table = Vall_weak_hash_tables; | |
| 1565 !NILP (hash_table); | |
| 1566 hash_table = XHASH_TABLE (hash_table)->next_weak) | |
| 1567 { | |
| 442 | 1568 const Lisp_Hash_Table *ht = XHASH_TABLE (hash_table); |
| 1204 | 1569 const htentry *e = ht->hentries; |
| 1570 const htentry *sentinel = e + ht->size; | |
| 428 | 1571 |
| 1572 if (! marked_p (hash_table)) | |
| 1573 /* The hash table is probably garbage. Ignore it. */ | |
| 1574 continue; | |
| 1575 | |
| 1576 /* Now, scan over all the pairs. For all pairs that are | |
| 1577 half-marked, we may need to mark the other half if we're | |
| 1578 keeping this pair. */ | |
| 1579 switch (ht->weakness) | |
| 1580 { | |
| 1581 case HASH_TABLE_KEY_WEAK: | |
| 1582 for (; e < sentinel; e++) | |
| 1204 | 1583 if (!HTENTRY_CLEAR_P (e)) |
| 428 | 1584 if (marked_p (e->key)) |
| 1585 MARK_OBJ (e->value); | |
| 1586 break; | |
| 1587 | |
| 1588 case HASH_TABLE_VALUE_WEAK: | |
| 1589 for (; e < sentinel; e++) | |
| 1204 | 1590 if (!HTENTRY_CLEAR_P (e)) |
| 428 | 1591 if (marked_p (e->value)) |
| 1592 MARK_OBJ (e->key); | |
| 1593 break; | |
| 1594 | |
| 442 | 1595 case HASH_TABLE_KEY_VALUE_WEAK: |
| 1596 for (; e < sentinel; e++) | |
| 1204 | 1597 if (!HTENTRY_CLEAR_P (e)) |
| 442 | 1598 { |
| 1599 if (marked_p (e->value)) | |
| 1600 MARK_OBJ (e->key); | |
| 1601 else if (marked_p (e->key)) | |
| 1602 MARK_OBJ (e->value); | |
| 1603 } | |
| 1604 break; | |
| 1605 | |
| 428 | 1606 case HASH_TABLE_KEY_CAR_WEAK: |
| 1607 for (; e < sentinel; e++) | |
| 1204 | 1608 if (!HTENTRY_CLEAR_P (e)) |
| 428 | 1609 if (!CONSP (e->key) || marked_p (XCAR (e->key))) |
| 1610 { | |
| 1611 MARK_OBJ (e->key); | |
| 1612 MARK_OBJ (e->value); | |
| 1613 } | |
| 1614 break; | |
| 1615 | |
| 450 | 1616 /* We seem to be sprouting new weakness types at an alarming |
| 1617 rate. At least this is not externally visible - and in | |
| 1618 fact all of these KEY_CAR_* types are only used by the | |
| 1619 glyph code. */ | |
| 1620 case HASH_TABLE_KEY_CAR_VALUE_WEAK: | |
| 1621 for (; e < sentinel; e++) | |
| 1204 | 1622 if (!HTENTRY_CLEAR_P (e)) |
| 450 | 1623 { |
| 1624 if (!CONSP (e->key) || marked_p (XCAR (e->key))) | |
| 1625 { | |
| 1626 MARK_OBJ (e->key); | |
| 1627 MARK_OBJ (e->value); | |
| 1628 } | |
| 1629 else if (marked_p (e->value)) | |
| 1630 MARK_OBJ (e->key); | |
| 1631 } | |
| 1632 break; | |
| 1633 | |
| 428 | 1634 case HASH_TABLE_VALUE_CAR_WEAK: |
| 1635 for (; e < sentinel; e++) | |
| 1204 | 1636 if (!HTENTRY_CLEAR_P (e)) |
| 428 | 1637 if (!CONSP (e->value) || marked_p (XCAR (e->value))) |
| 1638 { | |
| 1639 MARK_OBJ (e->key); | |
| 1640 MARK_OBJ (e->value); | |
| 1641 } | |
| 1642 break; | |
| 1643 | |
| 1644 default: | |
| 1645 break; | |
| 1646 } | |
| 1647 } | |
| 1648 | |
| 1649 return did_mark; | |
| 1650 } | |
| 1651 | |
| 1652 void | |
| 1653 prune_weak_hash_tables (void) | |
| 1654 { | |
| 1655 Lisp_Object hash_table, prev = Qnil; | |
| 1656 for (hash_table = Vall_weak_hash_tables; | |
| 1657 !NILP (hash_table); | |
| 1658 hash_table = XHASH_TABLE (hash_table)->next_weak) | |
| 1659 { | |
| 1660 if (! marked_p (hash_table)) | |
| 1661 { | |
| 1662 /* This hash table itself is garbage. Remove it from the list. */ | |
| 1663 if (NILP (prev)) | |
| 1664 Vall_weak_hash_tables = XHASH_TABLE (hash_table)->next_weak; | |
| 1665 else | |
| 1666 XHASH_TABLE (prev)->next_weak = XHASH_TABLE (hash_table)->next_weak; | |
| 1667 } | |
| 1668 else | |
| 1669 { | |
| 1670 /* Now, scan over all the pairs. Remove all of the pairs | |
| 1671 in which the key or value, or both, is unmarked | |
| 1672 (depending on the weakness of the hash table). */ | |
| 1673 Lisp_Hash_Table *ht = XHASH_TABLE (hash_table); | |
| 1204 | 1674 htentry *entries = ht->hentries; |
| 1675 htentry *sentinel = entries + ht->size; | |
| 1676 htentry *e; | |
| 428 | 1677 |
| 1678 for (e = entries; e < sentinel; e++) | |
| 1204 | 1679 if (!HTENTRY_CLEAR_P (e)) |
| 428 | 1680 { |
| 1681 again: | |
| 1682 if (!marked_p (e->key) || !marked_p (e->value)) | |
| 1683 { | |
| 1684 remhash_1 (ht, entries, e); | |
| 1204 | 1685 if (!HTENTRY_CLEAR_P (e)) |
| 428 | 1686 goto again; |
| 1687 } | |
| 1688 } | |
| 1689 | |
| 1690 prev = hash_table; | |
| 1691 } | |
| 1692 } | |
| 1693 } | |
| 1694 | |
| 1695 /* Return a hash value for an array of Lisp_Objects of size SIZE. */ | |
| 1696 | |
| 665 | 1697 Hashcode |
| 428 | 1698 internal_array_hash (Lisp_Object *arr, int size, int depth) |
| 1699 { | |
| 1700 int i; | |
| 665 | 1701 Hashcode hash = 0; |
| 442 | 1702 depth++; |
| 428 | 1703 |
| 1704 if (size <= 5) | |
| 1705 { | |
| 1706 for (i = 0; i < size; i++) | |
| 442 | 1707 hash = HASH2 (hash, internal_hash (arr[i], depth)); |
| 428 | 1708 return hash; |
| 1709 } | |
| 1710 | |
| 1711 /* just pick five elements scattered throughout the array. | |
| 1712 A slightly better approach would be to offset by some | |
| 1713 noise factor from the points chosen below. */ | |
| 1714 for (i = 0; i < 5; i++) | |
| 442 | 1715 hash = HASH2 (hash, internal_hash (arr[i*size/5], depth)); |
| 428 | 1716 |
| 1717 return hash; | |
| 1718 } | |
| 1719 | |
| 1720 /* Return a hash value for a Lisp_Object. This is for use when hashing | |
| 1721 objects with the comparison being `equal' (for `eq', you can just | |
| 1722 use the Lisp_Object itself as the hash value). You need to make a | |
| 1723 tradeoff between the speed of the hash function and how good the | |
| 1724 hashing is. In particular, the hash function needs to be FAST, | |
| 1725 so you can't just traipse down the whole tree hashing everything | |
| 1726 together. Most of the time, objects will differ in the first | |
| 1727 few elements you hash. Thus, we only go to a short depth (5) | |
| 1728 and only hash at most 5 elements out of a vector. Theoretically | |
| 1729 we could still take 5^5 time (a big big number) to compute a | |
| 1730 hash, but practically this won't ever happen. */ | |
| 1731 | |
| 665 | 1732 Hashcode |
| 428 | 1733 internal_hash (Lisp_Object obj, int depth) |
| 1734 { | |
| 1735 if (depth > 5) | |
| 1736 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
|
1737 |
|
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
|
1738 if (CONSP(obj)) |
| 428 | 1739 { |
|
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
|
1740 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
|
1741 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
|
1742 |
|
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
|
1743 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
|
1744 |
|
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
|
1745 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
|
1746 { |
|
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
|
1747 /* 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
|
1748 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
|
1749 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
|
1750 } |
|
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
|
1751 |
|
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
|
1752 /* 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
|
1753 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
|
1754 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
|
1755 |
|
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
|
1756 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
|
1757 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
|
1758 { |
|
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
|
1759 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
|
1760 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
|
1761 } |
|
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
|
1762 |
|
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
|
1763 return hash; |
| 428 | 1764 } |
| 1765 if (STRINGP (obj)) | |
| 1766 { | |
| 1767 return hash_string (XSTRING_DATA (obj), XSTRING_LENGTH (obj)); | |
| 1768 } | |
| 1769 if (LRECORDP (obj)) | |
| 1770 { | |
| 442 | 1771 const struct lrecord_implementation |
| 428 | 1772 *imp = XRECORD_LHEADER_IMPLEMENTATION (obj); |
| 1773 if (imp->hash) | |
| 1774 return imp->hash (obj, depth); | |
| 1775 } | |
| 1776 | |
| 1777 return LISP_HASH (obj); | |
| 1778 } | |
| 1779 | |
| 1780 DEFUN ("sxhash", Fsxhash, 1, 1, 0, /* | |
| 1781 Return a hash value for OBJECT. | |
| 444 | 1782 \(equal obj1 obj2) implies (= (sxhash obj1) (sxhash obj2)). |
| 428 | 1783 */ |
| 1784 (object)) | |
| 1785 { | |
| 1786 return make_int (internal_hash (object, 0)); | |
| 1787 } | |
| 1788 | |
| 1789 #if 0 | |
| 826 | 1790 DEFUN ("internal-hash-value", Finternal_hash_value, 1, 1, 0, /* |
| 428 | 1791 Hash value of OBJECT. For debugging. |
| 1792 The value is returned as (HIGH . LOW). | |
| 1793 */ | |
| 1794 (object)) | |
| 1795 { | |
| 1796 /* This function is pretty 32bit-centric. */ | |
| 665 | 1797 Hashcode hash = internal_hash (object, 0); |
| 428 | 1798 return Fcons (hash >> 16, hash & 0xffff); |
| 1799 } | |
| 1800 #endif | |
| 1801 | |
| 1802 | |
| 1803 /************************************************************************/ | |
| 1804 /* initialization */ | |
| 1805 /************************************************************************/ | |
| 1806 | |
| 1807 void | |
| 1808 syms_of_elhash (void) | |
| 1809 { | |
| 1810 DEFSUBR (Fhash_table_p); | |
| 1811 DEFSUBR (Fmake_hash_table); | |
| 1812 DEFSUBR (Fcopy_hash_table); | |
| 1813 DEFSUBR (Fgethash); | |
| 1814 DEFSUBR (Fremhash); | |
| 1815 DEFSUBR (Fputhash); | |
| 1816 DEFSUBR (Fclrhash); | |
| 1817 DEFSUBR (Fmaphash); | |
| 1818 DEFSUBR (Fhash_table_count); | |
| 1819 DEFSUBR (Fhash_table_test); | |
| 1820 DEFSUBR (Fhash_table_size); | |
| 1821 DEFSUBR (Fhash_table_rehash_size); | |
| 1822 DEFSUBR (Fhash_table_rehash_threshold); | |
| 1823 DEFSUBR (Fhash_table_weakness); | |
| 1824 DEFSUBR (Fhash_table_type); /* obsolete */ | |
| 1825 DEFSUBR (Fsxhash); | |
| 1826 #if 0 | |
| 1827 DEFSUBR (Finternal_hash_value); | |
| 1828 #endif | |
| 1829 | |
| 563 | 1830 DEFSYMBOL_MULTIWORD_PREDICATE (Qhash_tablep); |
| 1831 DEFSYMBOL (Qhash_table); | |
| 1832 DEFSYMBOL (Qhashtable); | |
|
5084
6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4976
diff
changeset
|
1833 DEFSYMBOL (Qmake_hash_table); |
| 563 | 1834 DEFSYMBOL (Qweakness); |
| 1835 DEFSYMBOL (Qvalue); | |
| 1836 DEFSYMBOL (Qkey_or_value); | |
| 1837 DEFSYMBOL (Qkey_and_value); | |
| 1838 DEFSYMBOL (Qrehash_size); | |
| 1839 DEFSYMBOL (Qrehash_threshold); | |
| 428 | 1840 |
| 563 | 1841 DEFSYMBOL (Qweak); /* obsolete */ |
| 1842 DEFSYMBOL (Qkey_weak); /* obsolete */ | |
| 1843 DEFSYMBOL (Qkey_or_value_weak); /* obsolete */ | |
| 1844 DEFSYMBOL (Qvalue_weak); /* obsolete */ | |
| 1845 DEFSYMBOL (Qnon_weak); /* obsolete */ | |
| 428 | 1846 |
|
4820
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
1847 DEFKEYWORD (Q_data); |
| 563 | 1848 DEFKEYWORD (Q_test); |
| 1849 DEFKEYWORD (Q_size); | |
| 1850 DEFKEYWORD (Q_rehash_size); | |
| 1851 DEFKEYWORD (Q_rehash_threshold); | |
| 1852 DEFKEYWORD (Q_weakness); | |
| 1853 DEFKEYWORD (Q_type); /* obsolete */ | |
| 428 | 1854 } |
| 1855 | |
| 1856 void | |
| 771 | 1857 init_elhash_once_early (void) |
| 428 | 1858 { |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
1859 INIT_LISP_OBJECT (hash_table); |
| 3092 | 1860 #ifdef NEW_GC |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1861 INIT_LISP_OBJECT (hash_table_entry); |
| 3092 | 1862 #endif /* NEW_GC */ |
| 771 | 1863 |
| 428 | 1864 /* This must NOT be staticpro'd */ |
| 1865 Vall_weak_hash_tables = Qnil; | |
| 452 | 1866 dump_add_weak_object_chain (&Vall_weak_hash_tables); |
| 428 | 1867 } |