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