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