Mercurial > hg > xemacs-beta
annotate src/elhash.c @ 4976:16112448d484
Rename xfree(FOO, TYPE) -> xfree(FOO)
-------------------- ChangeLog entries follow: --------------------
src/ChangeLog addition:
2010-02-04 Ben Wing <ben@xemacs.org>
* alloc.c (release_breathing_space):
* alloc.c (resize_string):
* alloc.c (sweep_lcrecords_1):
* alloc.c (SWEEP_FIXED_TYPE_BLOCK_1):
* alloc.c (ADDITIONAL_FREE_compiled_function):
* alloc.c (compact_string_chars):
* alloc.c (ADDITIONAL_FREE_string):
* alloc.c (sweep_strings):
* alloca.c (xemacs_c_alloca):
* alsaplay.c (alsa_play_sound_file):
* buffer.c (init_initial_directory):
* buffer.h:
* buffer.h (BUFFER_FREE):
* console-stream.c (stream_delete_console):
* console-tty.c (free_tty_console_struct):
* data.c (Fnumber_to_string):
* device-gtk.c (gtk_init_device):
* device-gtk.c (free_gtk_device_struct):
* device-gtk.c (gtk_delete_device):
* device-msw.c (mswindows_delete_device):
* device-msw.c (msprinter_delete_device):
* device-tty.c (free_tty_device_struct):
* device-tty.c (tty_delete_device):
* device-x.c (x_init_device):
* device-x.c (free_x_device_struct):
* device-x.c (x_delete_device):
* dialog-msw.c (handle_directory_dialog_box):
* dialog-x.c (dbox_descriptor_to_widget_value):
* dired-msw.c (Fmswindows_insert_directory):
* dired.c (free_user_cache):
* dired.c (user_name_completion_unwind):
* doc.c (unparesseuxify_doc_string):
* doc.c (Fsubstitute_command_keys):
* doprnt.c (emacs_doprnt_1):
* dumper.c (pdump_load_finish):
* dumper.c (pdump_file_free):
* dumper.c (pdump_file_unmap):
* dynarr.c:
* dynarr.c (Dynarr_free):
* editfns.c (uncache_home_directory):
* editfns.c (Fset_time_zone_rule):
* elhash.c:
* elhash.c (pdump_reorganize_hash_table):
* elhash.c (maphash_unwind):
* emacs.c (make_arg_list_1):
* emacs.c (free_argc_argv):
* emacs.c (sort_args):
* emacs.c (Frunning_temacs_p):
* emodules.c (attempt_module_delete):
* eval.c (free_pointer):
* event-Xt.c (unselect_filedesc):
* event-Xt.c (emacs_Xt_select_process):
* event-gtk.c (unselect_filedesc):
* event-gtk.c (dragndrop_data_received):
* event-msw.c (winsock_closer):
* event-msw.c (mswindows_dde_callback):
* event-msw.c (mswindows_wnd_proc):
* event-stream.c (finalize_command_builder):
* event-stream.c (free_command_builder):
* extents.c (free_gap_array):
* extents.c (free_extent_list):
* extents.c (free_soe):
* extents.c (extent_fragment_delete):
* extents.c (extent_priority_sort_function):
* file-coding.c (make_coding_system_1):
* file-coding.c (coding_finalizer):
* file-coding.c (set_coding_stream_coding_system):
* file-coding.c (chain_finalize_coding_stream_1):
* file-coding.c (chain_finalize):
* file-coding.c (free_detection_state):
* file-coding.c (coding_category_symbol_to_id):
* fileio.c:
* fileio.c (Ffile_name_directory):
* fileio.c (if):
* fileio.c (Ffile_symlink_p):
* filelock.c (FREE_LOCK_INFO):
* filelock.c (current_lock_owner):
* font-mgr.c (Ffc_name_unparse):
* font-mgr.c (Ffc_pattern_duplicate):
* frame-gtk.c (gtk_delete_frame):
* frame-msw.c (mswindows_delete_frame):
* frame-msw.c (msprinter_delete_frame):
* frame-x.c (x_cde_destroy_callback):
* frame-x.c (Fcde_start_drag_internal):
* frame-x.c (x_cde_transfer_callback):
* frame-x.c (x_delete_frame):
* frame.c (update_frame_title):
* frame.c (Fset_frame_pointer):
* gc.c (register_for_finalization):
* gccache-gtk.c (free_gc_cache):
* gccache-gtk.c (gc_cache_lookup):
* gccache-x.c (free_gc_cache):
* gccache-x.c (gc_cache_lookup):
* glyphs-eimage.c:
* glyphs-eimage.c (jpeg_instantiate_unwind):
* glyphs-eimage.c (gif_instantiate_unwind):
* glyphs-eimage.c (png_instantiate_unwind):
* glyphs-eimage.c (png_instantiate):
* glyphs-eimage.c (tiff_instantiate_unwind):
* glyphs-gtk.c (convert_EImage_to_GDKImage):
* glyphs-gtk.c (gtk_finalize_image_instance):
* glyphs-gtk.c (gtk_init_image_instance_from_eimage):
* glyphs-gtk.c (gtk_xpm_instantiate):
* glyphs-msw.c (convert_EImage_to_DIBitmap):
* glyphs-msw.c (mswindows_init_image_instance_from_eimage):
* glyphs-msw.c (mswindows_initialize_image_instance_mask):
* glyphs-msw.c (xpm_to_eimage):
* glyphs-msw.c (mswindows_xpm_instantiate):
* glyphs-msw.c (xbm_create_bitmap_from_data):
* glyphs-msw.c (mswindows_finalize_image_instance):
* glyphs-x.c (convert_EImage_to_XImage):
* glyphs-x.c (x_finalize_image_instance):
* glyphs-x.c (x_init_image_instance_from_eimage):
* glyphs-x.c (x_xpm_instantiate):
* gui-x.c (free_popup_widget_value_tree):
* hash.c (free_hash_table):
* hash.c (grow_hash_table):
* hash.c (pregrow_hash_table_if_necessary):
* imgproc.c (build_EImage_quantable):
* insdel.c (uninit_buffer_text):
* intl-win32.c (convert_multibyte_to_internal_malloc):
* intl.c:
* intl.c (Fset_current_locale):
* keymap.c:
* keymap.c (where_is_recursive_mapper):
* keymap.c (where_is_internal):
* lisp.h:
* lisp.h (xfree):
* lstream.c (Lstream_close):
* lstream.c (resizing_buffer_closer):
* mule-coding.c:
* mule-coding.c (iso2022_finalize_detection_state):
* nt.c:
* nt.c (mswindows_get_long_filename):
* nt.c (nt_get_resource):
* nt.c (init_mswindows_environment):
* nt.c (get_cached_volume_information):
* nt.c (mswindows_opendir):
* nt.c (mswindows_closedir):
* nt.c (mswindows_readdir):
* nt.c (mswindows_stat):
* nt.c (mswindows_getdcwd):
* nt.c (Fmswindows_long_file_name):
* ntplay.c (nt_play_sound_file):
* ntplay.c (play_sound_data_1):
* number-gmp.c (gmp_free):
* number-gmp.c (init_number_gmp):
* number-mp.c (bignum_to_string):
* number-mp.c (BIGNUM_TO_TYPE):
* number.c (bignum_print):
* number.c (bignum_convfree):
* number.c (ratio_print):
* number.c (bigfloat_print):
* number.c (bigfloat_finalize):
* objects-gtk.c (gtk_finalize_color_instance):
* objects-gtk.c (gtk_finalize_font_instance):
* objects-msw.c (mswindows_finalize_color_instance):
* objects-msw.c (mswindows_finalize_font_instance):
* objects-tty.c (tty_finalize_color_instance):
* objects-tty.c (tty_finalize_font_instance):
* objects-tty.c (tty_font_list):
* objects-x.c (x_finalize_color_instance):
* objects-x.c (x_finalize_font_instance):
* process.c:
* process.c (finalize_process):
* realpath.c:
* redisplay.c (add_propagation_runes):
* regex.c:
* regex.c (xfree):
* regex.c (REGEX_FREE_STACK):
* regex.c (FREE_STACK_RETURN):
* regex.c (regex_compile):
* regex.c (regexec):
* regex.c (regfree):
* scrollbar-gtk.c (gtk_free_scrollbar_instance):
* scrollbar-gtk.c (gtk_release_scrollbar_instance):
* scrollbar-msw.c (mswindows_free_scrollbar_instance):
* scrollbar-msw.c (unshow_that_mofo):
* scrollbar-x.c (x_free_scrollbar_instance):
* scrollbar-x.c (x_release_scrollbar_instance):
* select-gtk.c (emacs_gtk_selection_handle):
* select-msw.c (mswindows_own_selection):
* select-x.c:
* select-x.c (x_handle_selection_request):
* select-x.c (unexpect_property_change):
* select-x.c (x_handle_property_notify):
* select-x.c (receive_incremental_selection):
* select-x.c (x_get_window_property_as_lisp_data):
* select-x.c (Fx_get_cutbuffer_internal):
* specifier.c (finalize_specifier):
* syntax.c (uninit_buffer_syntax_cache):
* sysdep.c (qxe_allocating_getcwd):
* sysdep.c (qxe_lstat):
* sysdep.c (copy_in_passwd):
* sysdep.c (qxe_ctime):
* sysdep.c (closedir):
* sysdep.c (DIRSIZ):
* termcap.c (tgetent):
* termcap.c (tprint):
* tests.c (Ftest_data_format_conversion):
* text.c (new_dfc_convert_copy_data):
* text.h (eifree):
* text.h (eito_alloca):
* text.h (eito_external):
* toolbar-msw.c (mswindows_output_toolbar):
* ui-gtk.c (CONVERT_RETVAL):
* ui-gtk.c (__allocate_object_storage):
* unicode.c (free_from_unicode_table):
* unicode.c (free_to_unicode_table):
* unicode.c (free_charset_unicode_tables):
* win32.c (mswindows_read_link_1):
Rename: xfree(VAL, TYPE)->xfree(VAL)
Command used:
gr 'xfree *\((.*),.*\);' 'xfree (\1);' *.[ch]
Followed by grepping for 'xfree.*,' and fixing anything left.
Rationale: Having to specify the TYPE argument is annoying and
error-prone. It was originally put in to work around warnings
due to strict aliasing but years and years ago I rewrote it
in a way that doesn't use the TYPE argument at all and no one
has complained since then. (And anyway, XEmacs is far from
ever being in compliance with strict aliasing and would require
far-reaching changes to get that way.)
| author | Ben Wing <ben@xemacs.org> |
|---|---|
| date | Thu, 04 Feb 2010 07:28:14 -0600 |
| parents | e813cf16c015 |
| children | 6afe991b8135 b5df3737028a |
| rev | line source |
|---|---|
| 428 | 1 /* Implementation of the hash table lisp object type. |
| 2 Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc. | |
| 2421 | 3 Copyright (C) 1995, 1996, 2002, 2004 Ben Wing. |
| 428 | 4 Copyright (C) 1997 Free Software Foundation, Inc. |
| 5 | |
| 6 This file is part of XEmacs. | |
| 7 | |
| 8 XEmacs is free software; you can redistribute it and/or modify it | |
| 9 under the terms of the GNU General Public License as published by the | |
| 10 Free Software Foundation; either version 2, or (at your option) any | |
| 11 later version. | |
| 12 | |
| 13 XEmacs is distributed in the hope that it will be useful, but WITHOUT | |
| 14 ANY WARRANTY; without even the implied warranty of MERCNTABILITY or | |
| 15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
| 16 for more details. | |
| 17 | |
| 18 You should have received a copy of the GNU General Public License | |
| 19 along with XEmacs; see the file COPYING. If not, write to | |
| 20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
| 21 Boston, MA 02111-1307, USA. */ | |
| 22 | |
| 23 /* Synched up with: Not in FSF. */ | |
| 24 | |
| 1292 | 25 /* Author: Lost in the mists of history. At least back to Lucid 19.3, |
| 26 circa Sep 1992. Early hash table implementation allowed only `eq' as a | |
| 27 test -- other tests possible only when these objects were created from | |
| 28 the C code. | |
| 29 | |
| 30 Expansion to allow general `equal'-test Lisp-creatable tables, and hash | |
| 31 methods for the various Lisp objects in existence at the time, added | |
| 32 during 19.12 I think (early 1995?), by Ben Wing. | |
| 33 | |
| 34 Weak hash tables added by Jamie (maybe?) early on, perhaps around 19.6, | |
| 35 maybe earlier; again, only possible through the C code, and only | |
| 36 supported fully weak hash tables. Expansion to other kinds of weakness, | |
| 37 and exporting of the interface to Lisp, by Ben Wing during 19.12 | |
| 38 (early-mid 1995) or maybe 19.13 cycle (mid 1995). | |
| 39 | |
| 40 Expansion to full Common Lisp spec and interface, redoing of the | |
| 41 implementation, by Martin Buchholz, 1997? (Former hash table | |
| 42 implementation used "double hashing", I'm pretty sure, and was weirdly | |
| 43 tied into the generic hash.c code. Martin completely separated them.) | |
| 44 */ | |
| 45 | |
| 489 | 46 /* This file implements the hash table lisp object type. |
| 47 | |
| 504 | 48 This implementation was mostly written by Martin Buchholz in 1997. |
| 49 | |
| 50 The Lisp-level API (derived from Common Lisp) is almost completely | |
| 51 compatible with GNU Emacs 21, even though the implementations are | |
| 52 totally independent. | |
| 53 | |
| 489 | 54 The hash table technique used is "linear probing". Collisions are |
| 55 resolved by putting the item in the next empty place in the array | |
| 56 following the collision. Finding a hash entry performs a linear | |
| 57 search in the cluster starting at the hash value. | |
| 58 | |
| 59 On deletions from the hash table, the entries immediately following | |
| 60 the deleted entry are re-entered in the hash table. We do not have | |
| 61 a special way to mark deleted entries (known as "tombstones"). | |
| 62 | |
| 63 At the end of the hash entries ("hentries"), we leave room for an | |
| 64 entry that is always empty (the "sentinel"). | |
| 65 | |
| 66 The traditional literature on hash table implementation | |
| 67 (e.g. Knuth) suggests that too much "primary clustering" occurs | |
| 68 with linear probing. However, this literature was written when | |
| 69 locality of reference was not a factor. The discrepancy between | |
| 70 CPU speeds and memory speeds is increasing, and the speed of access | |
| 71 to memory is highly dependent on memory caches which work best when | |
| 72 there is high locality of data reference. Random access to memory | |
| 73 is up to 20 times as expensive as access to the nearest address | |
| 74 (and getting worse). So linear probing makes sense. | |
| 75 | |
| 76 But the representation doesn't actually matter that much with the | |
| 77 current elisp engine. Funcall is sufficiently slow that the choice | |
| 78 of hash table implementation is noise. */ | |
| 79 | |
| 428 | 80 #include <config.h> |
| 81 #include "lisp.h" | |
| 82 #include "bytecode.h" | |
| 83 #include "elhash.h" | |
| 489 | 84 #include "opaque.h" |
| 428 | 85 |
| 86 Lisp_Object Qhash_tablep; | |
| 87 static Lisp_Object Qhashtable, Qhash_table; | |
| 442 | 88 static Lisp_Object Qweakness, Qvalue, Qkey_or_value, Qkey_and_value; |
| 428 | 89 static Lisp_Object Vall_weak_hash_tables; |
| 90 static Lisp_Object Qrehash_size, Qrehash_threshold; | |
| 91 static Lisp_Object Q_size, Q_test, Q_weakness, Q_rehash_size, Q_rehash_threshold; | |
| 92 | |
| 93 /* obsolete as of 19990901 in xemacs-21.2 */ | |
| 442 | 94 static Lisp_Object Qweak, Qkey_weak, Qvalue_weak, Qkey_or_value_weak; |
|
4820
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
95 static Lisp_Object Qnon_weak, Q_type, Q_data; |
| 428 | 96 |
| 97 struct Lisp_Hash_Table | |
| 98 { | |
| 3017 | 99 struct LCRECORD_HEADER header; |
| 665 | 100 Elemcount size; |
| 101 Elemcount count; | |
| 102 Elemcount rehash_count; | |
| 428 | 103 double rehash_size; |
| 104 double rehash_threshold; | |
| 665 | 105 Elemcount golden_ratio; |
| 428 | 106 hash_table_hash_function_t hash_function; |
| 107 hash_table_test_function_t test_function; | |
| 1204 | 108 htentry *hentries; |
| 428 | 109 enum hash_table_weakness weakness; |
| 110 Lisp_Object next_weak; /* Used to chain together all of the weak | |
| 111 hash tables. Don't mark through this. */ | |
| 112 }; | |
| 113 | |
| 1204 | 114 #define CLEAR_HTENTRY(htentry) \ |
| 115 ((*(EMACS_UINT*)(&((htentry)->key))) = 0, \ | |
| 116 (*(EMACS_UINT*)(&((htentry)->value))) = 0) | |
| 428 | 117 |
| 118 #define HASH_TABLE_DEFAULT_SIZE 16 | |
| 119 #define HASH_TABLE_DEFAULT_REHASH_SIZE 1.3 | |
| 120 #define HASH_TABLE_MIN_SIZE 10 | |
|
4778
0081fd36b783
Cast enumerations to int before comparing them for the sake of VC++.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4777
diff
changeset
|
121 #define HASH_TABLE_DEFAULT_REHASH_THRESHOLD(size, test_function) \ |
|
4779
fd98353950a4
Make my last change to elhash.c more kosher, comparing pointers not ints
Aidan Kehoe <kehoea@parhasard.net>
parents:
4778
diff
changeset
|
122 (((size) > 4096 && NULL == (test_function)) ? 0.7 : 0.6) |
| 428 | 123 |
| 665 | 124 #define HASHCODE(key, ht) \ |
| 444 | 125 ((((ht)->hash_function ? (ht)->hash_function (key) : LISP_HASH (key)) \ |
| 126 * (ht)->golden_ratio) \ | |
| 127 % (ht)->size) | |
| 428 | 128 |
| 129 #define KEYS_EQUAL_P(key1, key2, testfun) \ | |
| 434 | 130 (EQ (key1, key2) || ((testfun) && (testfun) (key1, key2))) |
| 428 | 131 |
| 132 #define LINEAR_PROBING_LOOP(probe, entries, size) \ | |
| 133 for (; \ | |
| 1204 | 134 !HTENTRY_CLEAR_P (probe) || \ |
| 428 | 135 (probe == entries + size ? \ |
| 1204 | 136 (probe = entries, !HTENTRY_CLEAR_P (probe)) : 0); \ |
| 428 | 137 probe++) |
| 138 | |
| 800 | 139 #ifdef ERROR_CHECK_STRUCTURES |
| 428 | 140 static void |
| 141 check_hash_table_invariants (Lisp_Hash_Table *ht) | |
| 142 { | |
| 143 assert (ht->count < ht->size); | |
| 144 assert (ht->count <= ht->rehash_count); | |
| 145 assert (ht->rehash_count < ht->size); | |
| 146 assert ((double) ht->count * ht->rehash_threshold - 1 <= (double) ht->rehash_count); | |
| 1204 | 147 assert (HTENTRY_CLEAR_P (ht->hentries + ht->size)); |
| 428 | 148 } |
| 149 #else | |
| 150 #define check_hash_table_invariants(ht) | |
| 151 #endif | |
| 152 | |
| 153 /* Return a suitable size for a hash table, with at least SIZE slots. */ | |
| 665 | 154 static Elemcount |
| 155 hash_table_size (Elemcount requested_size) | |
| 428 | 156 { |
| 157 /* Return some prime near, but greater than or equal to, SIZE. | |
| 158 Decades from the time of writing, someone will have a system large | |
| 159 enough that the list below will be too short... */ | |
| 665 | 160 static const Elemcount primes [] = |
| 428 | 161 { |
| 162 19, 29, 41, 59, 79, 107, 149, 197, 263, 347, 457, 599, 787, 1031, | |
| 163 1361, 1777, 2333, 3037, 3967, 5167, 6719, 8737, 11369, 14783, | |
| 164 19219, 24989, 32491, 42257, 54941, 71429, 92861, 120721, 156941, | |
| 165 204047, 265271, 344857, 448321, 582821, 757693, 985003, 1280519, | |
| 166 1664681, 2164111, 2813353, 3657361, 4754591, 6180989, 8035301, | |
| 167 10445899, 13579681, 17653589, 22949669, 29834603, 38784989, | |
| 168 50420551, 65546729, 85210757, 110774011, 144006217, 187208107, | |
| 169 243370577, 316381771, 411296309, 534685237, 695090819, 903618083, | |
| 647 | 170 1174703521, 1527114613, 1985248999 /* , 2580823717UL, 3355070839UL */ |
| 428 | 171 }; |
| 172 /* We've heard of binary search. */ | |
| 173 int low, high; | |
| 174 for (low = 0, high = countof (primes) - 1; high - low > 1;) | |
| 175 { | |
| 176 /* Loop Invariant: size < primes [high] */ | |
| 177 int mid = (low + high) / 2; | |
| 178 if (primes [mid] < requested_size) | |
| 179 low = mid; | |
| 180 else | |
| 181 high = mid; | |
| 182 } | |
| 183 return primes [high]; | |
| 184 } | |
| 185 | |
| 186 | |
| 187 | |
| 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 |
| 2421 | 398 write_fmt_string (printcharfun, " 0x%x>", ht->header.uid); |
| 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 | |
| 428 | 424 finalize_hash_table (void *header, int for_disksave) |
| 425 { | |
| 426 if (!for_disksave) | |
| 427 { | |
| 428 Lisp_Hash_Table *ht = (Lisp_Hash_Table *) header; | |
| 489 | 429 free_hentries (ht->hentries, ht->size); |
| 428 | 430 ht->hentries = 0; |
| 431 } | |
| 432 } | |
| 3263 | 433 #endif /* not NEW_GC */ |
| 428 | 434 |
| 1204 | 435 static const struct memory_description htentry_description_1[] = { |
| 436 { XD_LISP_OBJECT, offsetof (htentry, key) }, | |
| 437 { XD_LISP_OBJECT, offsetof (htentry, value) }, | |
| 428 | 438 { XD_END } |
| 439 }; | |
| 440 | |
| 1204 | 441 static const struct sized_memory_description htentry_description = { |
| 442 sizeof (htentry), | |
| 443 htentry_description_1 | |
| 428 | 444 }; |
| 445 | |
| 3092 | 446 #ifdef NEW_GC |
| 447 static const struct memory_description htentry_weak_description_1[] = { | |
| 448 { XD_LISP_OBJECT, offsetof (htentry, key), 0, { 0 }, XD_FLAG_NO_KKCC}, | |
| 449 { XD_LISP_OBJECT, offsetof (htentry, value), 0, { 0 }, XD_FLAG_NO_KKCC}, | |
| 450 { XD_END } | |
| 451 }; | |
| 452 | |
| 453 static const struct sized_memory_description htentry_weak_description = { | |
| 454 sizeof (htentry), | |
| 455 htentry_weak_description_1 | |
| 456 }; | |
| 457 | |
| 458 DEFINE_LRECORD_IMPLEMENTATION ("hash-table-entry", hash_table_entry, | |
| 459 1, /*dumpable-flag*/ | |
| 460 0, 0, 0, 0, 0, | |
| 461 htentry_description_1, | |
| 462 Lisp_Hash_Table_Entry); | |
| 463 #endif /* NEW_GC */ | |
| 464 | |
| 1204 | 465 static const struct memory_description htentry_union_description_1[] = { |
| 466 /* Note: XD_INDIRECT in this table refers to the surrounding table, | |
| 467 and so this will work. */ | |
| 3092 | 468 #ifdef NEW_GC |
| 469 { XD_LISP_OBJECT_BLOCK_PTR, HASH_TABLE_NON_WEAK, | |
| 470 XD_INDIRECT (0, 1), { &htentry_description } }, | |
| 471 { XD_LISP_OBJECT_BLOCK_PTR, 0, XD_INDIRECT (0, 1), | |
| 472 { &htentry_weak_description }, XD_FLAG_UNION_DEFAULT_ENTRY }, | |
| 473 #else /* not NEW_GC */ | |
| 2367 | 474 { XD_BLOCK_PTR, HASH_TABLE_NON_WEAK, XD_INDIRECT (0, 1), |
| 2551 | 475 { &htentry_description } }, |
| 476 { XD_BLOCK_PTR, 0, XD_INDIRECT (0, 1), { &htentry_description }, | |
| 1204 | 477 XD_FLAG_UNION_DEFAULT_ENTRY | XD_FLAG_NO_KKCC }, |
| 3092 | 478 #endif /* not NEW_GC */ |
| 1204 | 479 { XD_END } |
| 480 }; | |
| 481 | |
| 482 static const struct sized_memory_description htentry_union_description = { | |
| 483 sizeof (htentry *), | |
| 484 htentry_union_description_1 | |
| 485 }; | |
| 486 | |
| 487 const struct memory_description hash_table_description[] = { | |
| 488 { XD_ELEMCOUNT, offsetof (Lisp_Hash_Table, size) }, | |
| 489 { XD_INT, offsetof (Lisp_Hash_Table, weakness) }, | |
| 490 { XD_UNION, offsetof (Lisp_Hash_Table, hentries), XD_INDIRECT (1, 0), | |
| 2551 | 491 { &htentry_union_description } }, |
| 440 | 492 { XD_LO_LINK, offsetof (Lisp_Hash_Table, next_weak) }, |
| 428 | 493 { XD_END } |
| 494 }; | |
| 495 | |
| 3263 | 496 #ifdef NEW_GC |
| 497 DEFINE_LRECORD_IMPLEMENTATION ("hash-table", hash_table, | |
| 498 1, /*dumpable-flag*/ | |
| 499 mark_hash_table, print_hash_table, | |
| 500 0, hash_table_equal, hash_table_hash, | |
| 501 hash_table_description, | |
| 502 Lisp_Hash_Table); | |
| 503 #else /* not NEW_GC */ | |
| 934 | 504 DEFINE_LRECORD_IMPLEMENTATION ("hash-table", hash_table, |
| 505 1, /*dumpable-flag*/ | |
| 506 mark_hash_table, print_hash_table, | |
| 507 finalize_hash_table, | |
| 508 hash_table_equal, hash_table_hash, | |
| 509 hash_table_description, | |
| 510 Lisp_Hash_Table); | |
| 3263 | 511 #endif /* not NEW_GC */ |
| 428 | 512 |
| 513 static Lisp_Hash_Table * | |
| 514 xhash_table (Lisp_Object hash_table) | |
| 515 { | |
| 1123 | 516 /* #### What's going on here? Why the gc_in_progress check? */ |
| 428 | 517 if (!gc_in_progress) |
| 518 CHECK_HASH_TABLE (hash_table); | |
| 519 check_hash_table_invariants (XHASH_TABLE (hash_table)); | |
| 520 return XHASH_TABLE (hash_table); | |
| 521 } | |
| 522 | |
| 523 | |
| 524 /************************************************************************/ | |
| 525 /* Creation of Hash Tables */ | |
| 526 /************************************************************************/ | |
| 527 | |
| 528 /* Creation of hash tables, without error-checking. */ | |
| 529 static void | |
| 530 compute_hash_table_derived_values (Lisp_Hash_Table *ht) | |
| 531 { | |
| 665 | 532 ht->rehash_count = (Elemcount) |
| 438 | 533 ((double) ht->size * ht->rehash_threshold); |
| 665 | 534 ht->golden_ratio = (Elemcount) |
| 428 | 535 ((double) ht->size * (.6180339887 / (double) sizeof (Lisp_Object))); |
| 536 } | |
| 537 | |
| 538 Lisp_Object | |
| 450 | 539 make_standard_lisp_hash_table (enum hash_table_test test, |
| 665 | 540 Elemcount size, |
| 450 | 541 double rehash_size, |
| 542 double rehash_threshold, | |
| 543 enum hash_table_weakness weakness) | |
| 544 { | |
| 462 | 545 hash_table_hash_function_t hash_function = 0; |
| 450 | 546 hash_table_test_function_t test_function = 0; |
| 547 | |
| 548 switch (test) | |
| 549 { | |
| 550 case HASH_TABLE_EQ: | |
| 551 test_function = 0; | |
| 552 hash_function = 0; | |
| 553 break; | |
| 554 | |
| 555 case HASH_TABLE_EQL: | |
| 556 test_function = lisp_object_eql_equal; | |
| 557 hash_function = lisp_object_eql_hash; | |
| 558 break; | |
| 559 | |
| 560 case HASH_TABLE_EQUAL: | |
| 561 test_function = lisp_object_equal_equal; | |
| 562 hash_function = lisp_object_equal_hash; | |
| 563 break; | |
| 564 | |
| 565 default: | |
| 2500 | 566 ABORT (); |
| 450 | 567 } |
| 568 | |
| 569 return make_general_lisp_hash_table (hash_function, test_function, | |
| 570 size, rehash_size, rehash_threshold, | |
| 571 weakness); | |
| 572 } | |
| 573 | |
| 574 Lisp_Object | |
| 575 make_general_lisp_hash_table (hash_table_hash_function_t hash_function, | |
| 576 hash_table_test_function_t test_function, | |
| 665 | 577 Elemcount size, |
| 428 | 578 double rehash_size, |
| 579 double rehash_threshold, | |
| 580 enum hash_table_weakness weakness) | |
| 581 { | |
| 582 Lisp_Object hash_table; | |
| 3017 | 583 Lisp_Hash_Table *ht = ALLOC_LCRECORD_TYPE (Lisp_Hash_Table, &lrecord_hash_table); |
| 428 | 584 |
| 450 | 585 ht->test_function = test_function; |
| 586 ht->hash_function = hash_function; | |
| 438 | 587 ht->weakness = weakness; |
| 588 | |
| 589 ht->rehash_size = | |
| 590 rehash_size > 1.0 ? rehash_size : HASH_TABLE_DEFAULT_REHASH_SIZE; | |
| 591 | |
| 592 ht->rehash_threshold = | |
| 593 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
|
594 HASH_TABLE_DEFAULT_REHASH_THRESHOLD (size, ht->test_function); |
| 438 | 595 |
| 428 | 596 if (size < HASH_TABLE_MIN_SIZE) |
| 597 size = HASH_TABLE_MIN_SIZE; | |
| 665 | 598 ht->size = hash_table_size ((Elemcount) (((double) size / ht->rehash_threshold) |
| 438 | 599 + 1.0)); |
| 428 | 600 ht->count = 0; |
| 438 | 601 |
| 428 | 602 compute_hash_table_derived_values (ht); |
| 603 | |
| 1204 | 604 /* We leave room for one never-occupied sentinel htentry at the end. */ |
| 3092 | 605 #ifdef NEW_GC |
| 606 ht->hentries = (htentry *) alloc_lrecord_array (sizeof (htentry), | |
| 607 ht->size + 1, | |
| 608 &lrecord_hash_table_entry); | |
| 609 #else /* not NEW_GC */ | |
| 1204 | 610 ht->hentries = xnew_array_and_zero (htentry, ht->size + 1); |
| 3092 | 611 #endif /* not NEW_GC */ |
| 428 | 612 |
| 793 | 613 hash_table = wrap_hash_table (ht); |
| 428 | 614 |
| 615 if (weakness == HASH_TABLE_NON_WEAK) | |
| 616 ht->next_weak = Qunbound; | |
| 617 else | |
| 618 ht->next_weak = Vall_weak_hash_tables, Vall_weak_hash_tables = hash_table; | |
| 619 | |
| 620 return hash_table; | |
| 621 } | |
| 622 | |
| 623 Lisp_Object | |
| 665 | 624 make_lisp_hash_table (Elemcount size, |
| 428 | 625 enum hash_table_weakness weakness, |
| 626 enum hash_table_test test) | |
| 627 { | |
| 450 | 628 return make_standard_lisp_hash_table (test, size, -1.0, -1.0, weakness); |
| 428 | 629 } |
| 630 | |
| 631 /* Pretty reading of hash tables. | |
| 632 | |
| 633 Here we use the existing structures mechanism (which is, | |
| 634 unfortunately, pretty cumbersome) for validating and instantiating | |
| 635 the hash tables. The idea is that the side-effect of reading a | |
| 636 #s(hash-table PLIST) object is creation of a hash table with desired | |
| 637 properties, and that the hash table is returned. */ | |
| 638 | |
| 639 /* Validation functions: each keyword provides its own validation | |
| 640 function. The errors should maybe be continuable, but it is | |
| 641 unclear how this would cope with ERRB. */ | |
| 642 static int | |
| 2286 | 643 hash_table_size_validate (Lisp_Object UNUSED (keyword), Lisp_Object value, |
| 644 Error_Behavior errb) | |
| 428 | 645 { |
| 646 if (NATNUMP (value)) | |
| 647 return 1; | |
| 648 | |
| 563 | 649 maybe_signal_error_1 (Qwrong_type_argument, list2 (Qnatnump, value), |
| 2286 | 650 Qhash_table, errb); |
| 428 | 651 return 0; |
| 652 } | |
| 653 | |
| 665 | 654 static Elemcount |
| 428 | 655 decode_hash_table_size (Lisp_Object obj) |
| 656 { | |
| 657 return NILP (obj) ? HASH_TABLE_DEFAULT_SIZE : XINT (obj); | |
| 658 } | |
| 659 | |
| 660 static int | |
| 2286 | 661 hash_table_weakness_validate (Lisp_Object UNUSED (keyword), Lisp_Object value, |
| 578 | 662 Error_Behavior errb) |
| 428 | 663 { |
| 442 | 664 if (EQ (value, Qnil)) return 1; |
| 665 if (EQ (value, Qt)) return 1; | |
| 666 if (EQ (value, Qkey)) return 1; | |
| 667 if (EQ (value, Qkey_and_value)) return 1; | |
| 668 if (EQ (value, Qkey_or_value)) return 1; | |
| 669 if (EQ (value, Qvalue)) return 1; | |
| 428 | 670 |
| 671 /* Following values are obsolete as of 19990901 in xemacs-21.2 */ | |
| 442 | 672 if (EQ (value, Qnon_weak)) return 1; |
| 673 if (EQ (value, Qweak)) return 1; | |
| 674 if (EQ (value, Qkey_weak)) return 1; | |
| 675 if (EQ (value, Qkey_or_value_weak)) return 1; | |
| 676 if (EQ (value, Qvalue_weak)) return 1; | |
| 428 | 677 |
| 563 | 678 maybe_invalid_constant ("Invalid hash table weakness", |
| 428 | 679 value, Qhash_table, errb); |
| 680 return 0; | |
| 681 } | |
| 682 | |
| 683 static enum hash_table_weakness | |
| 684 decode_hash_table_weakness (Lisp_Object obj) | |
| 685 { | |
| 442 | 686 if (EQ (obj, Qnil)) return HASH_TABLE_NON_WEAK; |
| 687 if (EQ (obj, Qt)) return HASH_TABLE_WEAK; | |
| 688 if (EQ (obj, Qkey_and_value)) return HASH_TABLE_WEAK; | |
| 689 if (EQ (obj, Qkey)) return HASH_TABLE_KEY_WEAK; | |
| 690 if (EQ (obj, Qkey_or_value)) return HASH_TABLE_KEY_VALUE_WEAK; | |
| 691 if (EQ (obj, Qvalue)) return HASH_TABLE_VALUE_WEAK; | |
| 428 | 692 |
| 693 /* Following values are obsolete as of 19990901 in xemacs-21.2 */ | |
| 442 | 694 if (EQ (obj, Qnon_weak)) return HASH_TABLE_NON_WEAK; |
| 695 if (EQ (obj, Qweak)) return HASH_TABLE_WEAK; | |
| 696 if (EQ (obj, Qkey_weak)) return HASH_TABLE_KEY_WEAK; | |
| 697 if (EQ (obj, Qkey_or_value_weak)) return HASH_TABLE_KEY_VALUE_WEAK; | |
| 698 if (EQ (obj, Qvalue_weak)) return HASH_TABLE_VALUE_WEAK; | |
| 428 | 699 |
| 563 | 700 invalid_constant ("Invalid hash table weakness", obj); |
| 1204 | 701 RETURN_NOT_REACHED (HASH_TABLE_NON_WEAK); |
| 428 | 702 } |
| 703 | |
| 704 static int | |
| 2286 | 705 hash_table_test_validate (Lisp_Object UNUSED (keyword), Lisp_Object value, |
| 706 Error_Behavior errb) | |
| 428 | 707 { |
| 708 if (EQ (value, Qnil)) return 1; | |
| 709 if (EQ (value, Qeq)) return 1; | |
| 710 if (EQ (value, Qequal)) return 1; | |
| 711 if (EQ (value, Qeql)) return 1; | |
| 712 | |
| 563 | 713 maybe_invalid_constant ("Invalid hash table test", |
| 2286 | 714 value, Qhash_table, errb); |
| 428 | 715 return 0; |
| 716 } | |
| 717 | |
| 718 static enum hash_table_test | |
| 719 decode_hash_table_test (Lisp_Object obj) | |
| 720 { | |
| 721 if (EQ (obj, Qnil)) return HASH_TABLE_EQL; | |
| 722 if (EQ (obj, Qeq)) return HASH_TABLE_EQ; | |
| 723 if (EQ (obj, Qequal)) return HASH_TABLE_EQUAL; | |
| 724 if (EQ (obj, Qeql)) return HASH_TABLE_EQL; | |
| 725 | |
| 563 | 726 invalid_constant ("Invalid hash table test", obj); |
| 1204 | 727 RETURN_NOT_REACHED (HASH_TABLE_EQ); |
| 428 | 728 } |
| 729 | |
| 730 static int | |
| 2286 | 731 hash_table_rehash_size_validate (Lisp_Object UNUSED (keyword), |
| 732 Lisp_Object value, Error_Behavior errb) | |
| 428 | 733 { |
| 734 if (!FLOATP (value)) | |
| 735 { | |
| 563 | 736 maybe_signal_error_1 (Qwrong_type_argument, list2 (Qfloatp, value), |
| 428 | 737 Qhash_table, errb); |
| 738 return 0; | |
| 739 } | |
| 740 | |
| 741 { | |
| 742 double rehash_size = XFLOAT_DATA (value); | |
| 743 if (rehash_size <= 1.0) | |
| 744 { | |
| 563 | 745 maybe_invalid_argument |
| 428 | 746 ("Hash table rehash size must be greater than 1.0", |
| 747 value, Qhash_table, errb); | |
| 748 return 0; | |
| 749 } | |
| 750 } | |
| 751 | |
| 752 return 1; | |
| 753 } | |
| 754 | |
| 755 static double | |
| 756 decode_hash_table_rehash_size (Lisp_Object rehash_size) | |
| 757 { | |
|
4585
871eb054b34a
Document non-obvious usages.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4410
diff
changeset
|
758 /* -1.0 signals make_general_lisp_hash_table to use the default. */ |
| 428 | 759 return NILP (rehash_size) ? -1.0 : XFLOAT_DATA (rehash_size); |
| 760 } | |
| 761 | |
| 762 static int | |
| 2286 | 763 hash_table_rehash_threshold_validate (Lisp_Object UNUSED (keyword), |
| 764 Lisp_Object value, Error_Behavior errb) | |
| 428 | 765 { |
| 766 if (!FLOATP (value)) | |
| 767 { | |
| 563 | 768 maybe_signal_error_1 (Qwrong_type_argument, list2 (Qfloatp, value), |
| 428 | 769 Qhash_table, errb); |
| 770 return 0; | |
| 771 } | |
| 772 | |
| 773 { | |
| 774 double rehash_threshold = XFLOAT_DATA (value); | |
| 775 if (rehash_threshold <= 0.0 || rehash_threshold >= 1.0) | |
| 776 { | |
| 563 | 777 maybe_invalid_argument |
| 428 | 778 ("Hash table rehash threshold must be between 0.0 and 1.0", |
| 779 value, Qhash_table, errb); | |
| 780 return 0; | |
| 781 } | |
| 782 } | |
| 783 | |
| 784 return 1; | |
| 785 } | |
| 786 | |
| 787 static double | |
| 788 decode_hash_table_rehash_threshold (Lisp_Object rehash_threshold) | |
| 789 { | |
|
4585
871eb054b34a
Document non-obvious usages.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4410
diff
changeset
|
790 /* -1.0 signals make_general_lisp_hash_table to use the default. */ |
| 428 | 791 return NILP (rehash_threshold) ? -1.0 : XFLOAT_DATA (rehash_threshold); |
| 792 } | |
| 793 | |
| 794 static int | |
| 2286 | 795 hash_table_data_validate (Lisp_Object UNUSED (keyword), Lisp_Object value, |
| 796 Error_Behavior errb) | |
| 428 | 797 { |
| 798 int len; | |
| 799 | |
|
4585
871eb054b34a
Document non-obvious usages.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4410
diff
changeset
|
800 /* Check for improper lists while getting length. */ |
| 428 | 801 GET_EXTERNAL_LIST_LENGTH (value, len); |
| 802 | |
| 803 if (len & 1) | |
| 804 { | |
| 563 | 805 maybe_sferror |
| 428 | 806 ("Hash table data must have alternating key/value pairs", |
| 807 value, Qhash_table, errb); | |
| 808 return 0; | |
| 809 } | |
|
4585
871eb054b34a
Document non-obvious usages.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4410
diff
changeset
|
810 |
| 428 | 811 return 1; |
| 812 } | |
| 813 | |
| 814 /* The actual instantiation of a hash table. This does practically no | |
| 815 error checking, because it relies on the fact that the paranoid | |
| 816 functions above have error-checked everything to the last details. | |
| 817 If this assumption is wrong, we will get a crash immediately (with | |
| 818 error-checking compiled in), and we'll know if there is a bug in | |
| 819 the structure mechanism. So there. */ | |
| 820 static Lisp_Object | |
| 821 hash_table_instantiate (Lisp_Object plist) | |
| 822 { | |
| 823 Lisp_Object hash_table; | |
| 824 Lisp_Object test = Qnil; | |
| 825 Lisp_Object size = Qnil; | |
| 826 Lisp_Object rehash_size = Qnil; | |
| 827 Lisp_Object rehash_threshold = Qnil; | |
| 828 Lisp_Object weakness = Qnil; | |
| 829 Lisp_Object data = Qnil; | |
| 830 | |
|
4820
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
831 if (KEYWORDP (Fcar (plist))) |
| 428 | 832 { |
|
4820
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
833 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
|
834 { |
|
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
835 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
|
836 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
|
837 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
|
838 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
|
839 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
|
840 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
|
841 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
|
842 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
|
843 "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
|
844 key); |
|
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
845 else ABORT(); |
|
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
846 } |
|
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 else |
|
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
849 { |
|
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
850 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
|
851 { |
|
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
852 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
|
853 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
|
854 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
|
855 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
|
856 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
|
857 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
|
858 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
|
859 else if (KEYWORDP (key)) |
|
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
860 signal_error (Qinvalid_read_syntax, |
|
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
861 "can't mix keyword and non-keyword hash table syntax", |
|
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
862 key); |
|
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
863 else ABORT(); |
|
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
864 } |
| 428 | 865 } |
| 866 | |
| 867 /* Create the hash table. */ | |
| 450 | 868 hash_table = make_standard_lisp_hash_table |
| 428 | 869 (decode_hash_table_test (test), |
| 870 decode_hash_table_size (size), | |
| 871 decode_hash_table_rehash_size (rehash_size), | |
| 872 decode_hash_table_rehash_threshold (rehash_threshold), | |
| 873 decode_hash_table_weakness (weakness)); | |
| 874 | |
| 875 /* I'm not sure whether this can GC, but better safe than sorry. */ | |
| 876 { | |
| 877 struct gcpro gcpro1; | |
| 878 GCPRO1 (hash_table); | |
| 879 | |
| 880 /* And fill it with data. */ | |
| 881 while (!NILP (data)) | |
| 882 { | |
| 883 Lisp_Object key, value; | |
| 884 key = XCAR (data); data = XCDR (data); | |
| 885 value = XCAR (data); data = XCDR (data); | |
| 886 Fputhash (key, value, hash_table); | |
| 887 } | |
| 888 UNGCPRO; | |
| 889 } | |
| 890 | |
| 891 return hash_table; | |
| 892 } | |
| 893 | |
| 894 static void | |
| 895 structure_type_create_hash_table_structure_name (Lisp_Object structure_name) | |
| 896 { | |
| 897 struct structure_type *st; | |
| 898 | |
| 899 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
|
900 |
|
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
901 /* 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
|
902 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
|
903 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
|
904 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
|
905 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
|
906 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
|
907 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
|
908 |
|
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
909 /* Next the mutually exclusive, older, non-keyword syntax: */ |
| 428 | 910 define_structure_type_keyword (st, Qtest, hash_table_test_validate); |
| 911 define_structure_type_keyword (st, Qsize, hash_table_size_validate); | |
| 912 define_structure_type_keyword (st, Qrehash_size, hash_table_rehash_size_validate); | |
| 913 define_structure_type_keyword (st, Qrehash_threshold, hash_table_rehash_threshold_validate); | |
| 914 define_structure_type_keyword (st, Qweakness, hash_table_weakness_validate); | |
| 915 define_structure_type_keyword (st, Qdata, hash_table_data_validate); | |
| 916 | |
| 917 /* obsolete as of 19990901 in xemacs-21.2 */ | |
| 918 define_structure_type_keyword (st, Qtype, hash_table_weakness_validate); | |
| 919 } | |
| 920 | |
| 921 /* Create a built-in Lisp structure type named `hash-table'. | |
| 922 We make #s(hashtable ...) equivalent to #s(hash-table ...), | |
| 923 for backward compatibility. | |
| 924 This is called from emacs.c. */ | |
| 925 void | |
| 926 structure_type_create_hash_table (void) | |
| 927 { | |
| 928 structure_type_create_hash_table_structure_name (Qhash_table); | |
| 929 structure_type_create_hash_table_structure_name (Qhashtable); /* compat */ | |
| 930 } | |
| 931 | |
| 932 | |
| 933 /************************************************************************/ | |
| 934 /* Definition of Lisp-visible methods */ | |
| 935 /************************************************************************/ | |
| 936 | |
| 937 DEFUN ("hash-table-p", Fhash_table_p, 1, 1, 0, /* | |
| 938 Return t if OBJECT is a hash table, else nil. | |
| 939 */ | |
| 940 (object)) | |
| 941 { | |
| 942 return HASH_TABLEP (object) ? Qt : Qnil; | |
| 943 } | |
| 944 | |
| 945 DEFUN ("make-hash-table", Fmake_hash_table, 0, MANY, 0, /* | |
| 946 Return a new empty hash table object. | |
| 947 Use Common Lisp style keywords to specify hash table properties. | |
| 948 | |
| 949 Keyword :test can be `eq', `eql' (default) or `equal'. | |
| 950 Comparison between keys is done using this function. | |
| 951 If speed is important, consider using `eq'. | |
| 952 When storing strings in the hash table, you will likely need to use `equal'. | |
| 953 | |
| 954 Keyword :size specifies the number of keys likely to be inserted. | |
| 955 This number of entries can be inserted without enlarging the hash table. | |
| 956 | |
| 957 Keyword :rehash-size must be a float greater than 1.0, and specifies | |
| 958 the factor by which to increase the size of the hash table when enlarging. | |
| 959 | |
| 960 Keyword :rehash-threshold must be a float between 0.0 and 1.0, | |
| 961 and specifies the load factor of the hash table which triggers enlarging. | |
| 962 | |
| 442 | 963 Non-standard keyword :weakness can be `nil' (default), `t', `key-and-value', |
| 964 `key', `value' or `key-or-value'. `t' is an alias for `key-and-value'. | |
| 428 | 965 |
| 442 | 966 A key-and-value-weak hash table, also known as a fully-weak or simply |
| 967 as a weak hash table, is one whose pointers do not count as GC | |
| 968 referents: for any key-value pair in the hash table, if the only | |
| 969 remaining pointer to either the key or the value is in a weak hash | |
| 970 table, then the pair will be removed from the hash table, and the key | |
| 971 and value collected. A non-weak hash table (or any other pointer) | |
| 972 would prevent the object from being collected. | |
| 428 | 973 |
| 974 A key-weak hash table is similar to a fully-weak hash table except that | |
| 975 a key-value pair will be removed only if the key remains unmarked | |
| 976 outside of weak hash tables. The pair will remain in the hash table if | |
| 977 the key is pointed to by something other than a weak hash table, even | |
| 978 if the value is not. | |
| 979 | |
| 980 A value-weak hash table is similar to a fully-weak hash table except | |
| 981 that a key-value pair will be removed only if the value remains | |
| 982 unmarked outside of weak hash tables. The pair will remain in the | |
| 983 hash table if the value is pointed to by something other than a weak | |
| 984 hash table, even if the key is not. | |
| 442 | 985 |
| 986 A key-or-value-weak hash table is similar to a fully-weak hash table except | |
| 987 that a key-value pair will be removed only if the value and the key remain | |
| 988 unmarked outside of weak hash tables. The pair will remain in the | |
| 989 hash table if the value or key are pointed to by something other than a weak | |
| 990 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
|
991 |
|
4777
c69aeb86b2a3
Serialise non-default hash table rehash thresholds correctly; use this.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4693
diff
changeset
|
992 arguments: (&key TEST SIZE REHASH-SIZE REHASH-THRESHOLD WEAKNESS) |
| 428 | 993 */ |
| 994 (int nargs, Lisp_Object *args)) | |
| 995 { | |
| 996 int i = 0; | |
| 997 Lisp_Object test = Qnil; | |
| 998 Lisp_Object size = Qnil; | |
| 999 Lisp_Object rehash_size = Qnil; | |
| 1000 Lisp_Object rehash_threshold = Qnil; | |
| 1001 Lisp_Object weakness = Qnil; | |
| 1002 | |
| 1003 while (i + 1 < nargs) | |
| 1004 { | |
| 1005 Lisp_Object keyword = args[i++]; | |
| 1006 Lisp_Object value = args[i++]; | |
| 1007 | |
| 1008 if (EQ (keyword, Q_test)) test = value; | |
| 1009 else if (EQ (keyword, Q_size)) size = value; | |
| 1010 else if (EQ (keyword, Q_rehash_size)) rehash_size = value; | |
| 1011 else if (EQ (keyword, Q_rehash_threshold)) rehash_threshold = value; | |
| 1012 else if (EQ (keyword, Q_weakness)) weakness = value; | |
| 1013 else if (EQ (keyword, Q_type))/*obsolete*/ weakness = value; | |
| 563 | 1014 else invalid_constant ("Invalid hash table property keyword", keyword); |
| 428 | 1015 } |
| 1016 | |
| 1017 if (i < nargs) | |
| 563 | 1018 sferror ("Hash table property requires a value", args[i]); |
| 428 | 1019 |
| 1020 #define VALIDATE_VAR(var) \ | |
| 1021 if (!NILP (var)) hash_table_##var##_validate (Q##var, var, ERROR_ME); | |
| 1022 | |
| 1023 VALIDATE_VAR (test); | |
| 1024 VALIDATE_VAR (size); | |
| 1025 VALIDATE_VAR (rehash_size); | |
| 1026 VALIDATE_VAR (rehash_threshold); | |
| 1027 VALIDATE_VAR (weakness); | |
| 1028 | |
| 450 | 1029 return make_standard_lisp_hash_table |
| 428 | 1030 (decode_hash_table_test (test), |
| 1031 decode_hash_table_size (size), | |
| 1032 decode_hash_table_rehash_size (rehash_size), | |
| 1033 decode_hash_table_rehash_threshold (rehash_threshold), | |
| 1034 decode_hash_table_weakness (weakness)); | |
| 1035 } | |
| 1036 | |
| 1037 DEFUN ("copy-hash-table", Fcopy_hash_table, 1, 1, 0, /* | |
| 1038 Return a new hash table containing the same keys and values as HASH-TABLE. | |
| 1039 The keys and values will not themselves be copied. | |
| 1040 */ | |
| 1041 (hash_table)) | |
| 1042 { | |
| 442 | 1043 const Lisp_Hash_Table *ht_old = xhash_table (hash_table); |
| 3017 | 1044 Lisp_Hash_Table *ht = ALLOC_LCRECORD_TYPE (Lisp_Hash_Table, &lrecord_hash_table); |
| 1045 COPY_LCRECORD (ht, ht_old); | |
| 428 | 1046 |
| 3092 | 1047 #ifdef NEW_GC |
| 1048 ht->hentries = (htentry *) alloc_lrecord_array (sizeof (htentry), | |
| 1049 ht_old->size + 1, | |
| 1050 &lrecord_hash_table_entry); | |
| 1051 #else /* not NEW_GC */ | |
| 1204 | 1052 ht->hentries = xnew_array (htentry, ht_old->size + 1); |
| 3092 | 1053 #endif /* not NEW_GC */ |
| 1204 | 1054 memcpy (ht->hentries, ht_old->hentries, (ht_old->size + 1) * sizeof (htentry)); |
| 428 | 1055 |
| 793 | 1056 hash_table = wrap_hash_table (ht); |
| 428 | 1057 |
| 1058 if (! EQ (ht->next_weak, Qunbound)) | |
| 1059 { | |
| 1060 ht->next_weak = Vall_weak_hash_tables; | |
| 1061 Vall_weak_hash_tables = hash_table; | |
| 1062 } | |
| 1063 | |
| 1064 return hash_table; | |
| 1065 } | |
| 1066 | |
| 1067 static void | |
| 665 | 1068 resize_hash_table (Lisp_Hash_Table *ht, Elemcount new_size) |
| 428 | 1069 { |
| 1204 | 1070 htentry *old_entries, *new_entries, *sentinel, *e; |
| 665 | 1071 Elemcount old_size; |
| 428 | 1072 |
| 1073 old_size = ht->size; | |
| 1074 ht->size = new_size; | |
| 1075 | |
| 1076 old_entries = ht->hentries; | |
| 1077 | |
| 3092 | 1078 #ifdef NEW_GC |
| 1079 ht->hentries = (htentry *) alloc_lrecord_array (sizeof (htentry), | |
| 1080 new_size + 1, | |
| 1081 &lrecord_hash_table_entry); | |
| 1082 #else /* not NEW_GC */ | |
| 1204 | 1083 ht->hentries = xnew_array_and_zero (htentry, new_size + 1); |
| 3092 | 1084 #endif /* not NEW_GC */ |
| 428 | 1085 new_entries = ht->hentries; |
| 1086 | |
| 1087 compute_hash_table_derived_values (ht); | |
| 1088 | |
| 440 | 1089 for (e = old_entries, sentinel = e + old_size; e < sentinel; e++) |
| 1204 | 1090 if (!HTENTRY_CLEAR_P (e)) |
| 428 | 1091 { |
| 1204 | 1092 htentry *probe = new_entries + HASHCODE (e->key, ht); |
| 428 | 1093 LINEAR_PROBING_LOOP (probe, new_entries, new_size) |
| 1094 ; | |
| 1095 *probe = *e; | |
| 1096 } | |
| 1097 | |
| 4117 | 1098 #ifndef NEW_GC |
| 489 | 1099 free_hentries (old_entries, old_size); |
| 4117 | 1100 #endif /* not NEW_GC */ |
| 428 | 1101 } |
| 1102 | |
| 440 | 1103 /* After a hash table has been saved to disk and later restored by the |
| 1104 portable dumper, it contains the same objects, but their addresses | |
| 665 | 1105 and thus their HASHCODEs have changed. */ |
| 428 | 1106 void |
| 440 | 1107 pdump_reorganize_hash_table (Lisp_Object hash_table) |
| 428 | 1108 { |
| 442 | 1109 const Lisp_Hash_Table *ht = xhash_table (hash_table); |
| 3092 | 1110 #ifdef NEW_GC |
| 1111 htentry *new_entries = | |
| 1112 (htentry *) alloc_lrecord_array (sizeof (htentry), ht->size + 1, | |
| 1113 &lrecord_hash_table_entry); | |
| 1114 #else /* not NEW_GC */ | |
| 1204 | 1115 htentry *new_entries = xnew_array_and_zero (htentry, ht->size + 1); |
| 3092 | 1116 #endif /* not NEW_GC */ |
| 1204 | 1117 htentry *e, *sentinel; |
| 440 | 1118 |
| 1119 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++) | |
| 1204 | 1120 if (!HTENTRY_CLEAR_P (e)) |
| 440 | 1121 { |
| 1204 | 1122 htentry *probe = new_entries + HASHCODE (e->key, ht); |
| 440 | 1123 LINEAR_PROBING_LOOP (probe, new_entries, ht->size) |
| 1124 ; | |
| 1125 *probe = *e; | |
| 1126 } | |
| 1127 | |
| 1204 | 1128 memcpy (ht->hentries, new_entries, ht->size * sizeof (htentry)); |
| 440 | 1129 |
| 4117 | 1130 #ifndef NEW_GC |
|
4976
16112448d484
Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
1131 xfree (new_entries); |
| 3092 | 1132 #endif /* not NEW_GC */ |
| 428 | 1133 } |
| 1134 | |
| 1135 static void | |
| 1136 enlarge_hash_table (Lisp_Hash_Table *ht) | |
| 1137 { | |
| 665 | 1138 Elemcount new_size = |
| 1139 hash_table_size ((Elemcount) ((double) ht->size * ht->rehash_size)); | |
| 428 | 1140 resize_hash_table (ht, new_size); |
| 1141 } | |
| 1142 | |
| 4072 | 1143 htentry * |
| 1204 | 1144 find_htentry (Lisp_Object key, const Lisp_Hash_Table *ht) |
| 428 | 1145 { |
| 1146 hash_table_test_function_t test_function = ht->test_function; | |
| 1204 | 1147 htentry *entries = ht->hentries; |
| 1148 htentry *probe = entries + HASHCODE (key, ht); | |
| 428 | 1149 |
| 1150 LINEAR_PROBING_LOOP (probe, entries, ht->size) | |
| 1151 if (KEYS_EQUAL_P (probe->key, key, test_function)) | |
| 1152 break; | |
| 1153 | |
| 1154 return probe; | |
| 1155 } | |
| 1156 | |
| 2421 | 1157 /* A version of Fputhash() that increments the value by the specified |
| 1158 amount and dispenses will all error checks. Assumes that tables does | |
| 1159 comparison using EQ. Used by the profiling routines to avoid | |
| 1160 overhead -- profiling overhead was being recorded at up to 15% of the | |
| 1161 total time. */ | |
| 1162 | |
| 1163 void | |
| 1164 inchash_eq (Lisp_Object key, Lisp_Object table, EMACS_INT offset) | |
| 1165 { | |
| 1166 Lisp_Hash_Table *ht = XHASH_TABLE (table); | |
| 1167 htentry *entries = ht->hentries; | |
| 1168 htentry *probe = entries + HASHCODE (key, ht); | |
| 1169 | |
| 1170 LINEAR_PROBING_LOOP (probe, entries, ht->size) | |
| 1171 if (EQ (probe->key, key)) | |
| 1172 break; | |
| 1173 | |
| 1174 if (!HTENTRY_CLEAR_P (probe)) | |
| 1175 probe->value = make_int (XINT (probe->value) + offset); | |
| 1176 else | |
| 1177 { | |
| 1178 probe->key = key; | |
| 1179 probe->value = make_int (offset); | |
| 1180 | |
| 1181 if (++ht->count >= ht->rehash_count) | |
| 1182 enlarge_hash_table (ht); | |
| 1183 } | |
| 1184 } | |
| 1185 | |
| 428 | 1186 DEFUN ("gethash", Fgethash, 2, 3, 0, /* |
| 1187 Find hash value for KEY in HASH-TABLE. | |
| 1188 If there is no corresponding value, return DEFAULT (which defaults to nil). | |
| 1189 */ | |
| 1190 (key, hash_table, default_)) | |
| 1191 { | |
| 442 | 1192 const Lisp_Hash_Table *ht = xhash_table (hash_table); |
| 1204 | 1193 htentry *e = find_htentry (key, ht); |
| 428 | 1194 |
| 1204 | 1195 return HTENTRY_CLEAR_P (e) ? default_ : e->value; |
| 428 | 1196 } |
| 1197 | |
| 1198 DEFUN ("puthash", Fputhash, 3, 3, 0, /* | |
|
4410
aae1994dfeec
Document return values for #'puthash, #'clrhash.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4398
diff
changeset
|
1199 Hash KEY to VALUE in HASH-TABLE, and return VALUE. |
| 428 | 1200 */ |
| 1201 (key, value, hash_table)) | |
| 1202 { | |
| 1203 Lisp_Hash_Table *ht = xhash_table (hash_table); | |
| 1204 | 1204 htentry *e = find_htentry (key, ht); |
| 428 | 1205 |
| 1204 | 1206 if (!HTENTRY_CLEAR_P (e)) |
| 428 | 1207 return e->value = value; |
| 1208 | |
| 1209 e->key = key; | |
| 1210 e->value = value; | |
| 1211 | |
| 1212 if (++ht->count >= ht->rehash_count) | |
| 1213 enlarge_hash_table (ht); | |
| 1214 | |
| 1215 return value; | |
| 1216 } | |
| 1217 | |
| 1204 | 1218 /* Remove htentry pointed at by PROBE. |
| 428 | 1219 Subsequent entries are removed and reinserted. |
| 1220 We don't use tombstones - too wasteful. */ | |
| 1221 static void | |
| 1204 | 1222 remhash_1 (Lisp_Hash_Table *ht, htentry *entries, htentry *probe) |
| 428 | 1223 { |
| 665 | 1224 Elemcount size = ht->size; |
| 1204 | 1225 CLEAR_HTENTRY (probe); |
| 428 | 1226 probe++; |
| 1227 ht->count--; | |
| 1228 | |
| 1229 LINEAR_PROBING_LOOP (probe, entries, size) | |
| 1230 { | |
| 1231 Lisp_Object key = probe->key; | |
| 1204 | 1232 htentry *probe2 = entries + HASHCODE (key, ht); |
| 428 | 1233 LINEAR_PROBING_LOOP (probe2, entries, size) |
| 1234 if (EQ (probe2->key, key)) | |
| 1204 | 1235 /* htentry at probe doesn't need to move. */ |
| 428 | 1236 goto continue_outer_loop; |
| 1204 | 1237 /* Move htentry from probe to new home at probe2. */ |
| 428 | 1238 *probe2 = *probe; |
| 1204 | 1239 CLEAR_HTENTRY (probe); |
| 428 | 1240 continue_outer_loop: continue; |
| 1241 } | |
| 1242 } | |
| 1243 | |
| 1244 DEFUN ("remhash", Fremhash, 2, 2, 0, /* | |
| 1245 Remove the entry for KEY from HASH-TABLE. | |
| 1246 Do nothing if there is no entry for KEY in HASH-TABLE. | |
| 617 | 1247 Return non-nil if an entry was removed. |
| 428 | 1248 */ |
| 1249 (key, hash_table)) | |
| 1250 { | |
| 1251 Lisp_Hash_Table *ht = xhash_table (hash_table); | |
| 1204 | 1252 htentry *e = find_htentry (key, ht); |
| 428 | 1253 |
| 1204 | 1254 if (HTENTRY_CLEAR_P (e)) |
| 428 | 1255 return Qnil; |
| 1256 | |
| 1257 remhash_1 (ht, ht->hentries, e); | |
| 1258 return Qt; | |
| 1259 } | |
| 1260 | |
| 1261 DEFUN ("clrhash", Fclrhash, 1, 1, 0, /* | |
| 1262 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
|
1263 Return HASH-TABLE. |
| 428 | 1264 */ |
| 1265 (hash_table)) | |
| 1266 { | |
| 1267 Lisp_Hash_Table *ht = xhash_table (hash_table); | |
| 1204 | 1268 htentry *e, *sentinel; |
| 428 | 1269 |
| 1270 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++) | |
| 1204 | 1271 CLEAR_HTENTRY (e); |
| 428 | 1272 ht->count = 0; |
| 1273 | |
| 1274 return hash_table; | |
| 1275 } | |
| 1276 | |
| 1277 /************************************************************************/ | |
| 1278 /* Accessor Functions */ | |
| 1279 /************************************************************************/ | |
| 1280 | |
| 1281 DEFUN ("hash-table-count", Fhash_table_count, 1, 1, 0, /* | |
| 1282 Return the number of entries in HASH-TABLE. | |
| 1283 */ | |
| 1284 (hash_table)) | |
| 1285 { | |
| 1286 return make_int (xhash_table (hash_table)->count); | |
| 1287 } | |
| 1288 | |
| 1289 DEFUN ("hash-table-test", Fhash_table_test, 1, 1, 0, /* | |
| 1290 Return the test function of HASH-TABLE. | |
| 1291 This can be one of `eq', `eql' or `equal'. | |
| 1292 */ | |
| 1293 (hash_table)) | |
| 1294 { | |
| 1295 hash_table_test_function_t fun = xhash_table (hash_table)->test_function; | |
| 1296 | |
| 1297 return (fun == lisp_object_eql_equal ? Qeql : | |
| 1298 fun == lisp_object_equal_equal ? Qequal : | |
| 1299 Qeq); | |
| 1300 } | |
| 1301 | |
| 1302 DEFUN ("hash-table-size", Fhash_table_size, 1, 1, 0, /* | |
| 1303 Return the size of HASH-TABLE. | |
| 1304 This is the current number of slots in HASH-TABLE, whether occupied or not. | |
| 1305 */ | |
| 1306 (hash_table)) | |
| 1307 { | |
| 1308 return make_int (xhash_table (hash_table)->size); | |
| 1309 } | |
| 1310 | |
| 1311 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size, 1, 1, 0, /* | |
| 1312 Return the current rehash size of HASH-TABLE. | |
| 1313 This is a float greater than 1.0; the factor by which HASH-TABLE | |
| 1314 is enlarged when the rehash threshold is exceeded. | |
| 1315 */ | |
| 1316 (hash_table)) | |
| 1317 { | |
| 1318 return make_float (xhash_table (hash_table)->rehash_size); | |
| 1319 } | |
| 1320 | |
| 1321 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold, 1, 1, 0, /* | |
| 1322 Return the current rehash threshold of HASH-TABLE. | |
| 1323 This is a float between 0.0 and 1.0; the maximum `load factor' of HASH-TABLE, | |
| 1324 beyond which the HASH-TABLE is enlarged by rehashing. | |
| 1325 */ | |
| 1326 (hash_table)) | |
| 1327 { | |
| 438 | 1328 return make_float (xhash_table (hash_table)->rehash_threshold); |
| 428 | 1329 } |
| 1330 | |
| 1331 DEFUN ("hash-table-weakness", Fhash_table_weakness, 1, 1, 0, /* | |
| 1332 Return the weakness of HASH-TABLE. | |
| 442 | 1333 This can be one of `nil', `key-and-value', `key-or-value', `key' or `value'. |
| 428 | 1334 */ |
| 1335 (hash_table)) | |
| 1336 { | |
| 1337 switch (xhash_table (hash_table)->weakness) | |
| 1338 { | |
| 442 | 1339 case HASH_TABLE_WEAK: return Qkey_and_value; |
| 1340 case HASH_TABLE_KEY_WEAK: return Qkey; | |
| 1341 case HASH_TABLE_KEY_VALUE_WEAK: return Qkey_or_value; | |
| 1342 case HASH_TABLE_VALUE_WEAK: return Qvalue; | |
| 1343 default: return Qnil; | |
| 428 | 1344 } |
| 1345 } | |
| 1346 | |
| 1347 /* obsolete as of 19990901 in xemacs-21.2 */ | |
| 1348 DEFUN ("hash-table-type", Fhash_table_type, 1, 1, 0, /* | |
| 1349 Return the type of HASH-TABLE. | |
| 1350 This can be one of `non-weak', `weak', `key-weak' or `value-weak'. | |
| 1351 */ | |
| 1352 (hash_table)) | |
| 1353 { | |
| 1354 switch (xhash_table (hash_table)->weakness) | |
| 1355 { | |
| 442 | 1356 case HASH_TABLE_WEAK: return Qweak; |
| 1357 case HASH_TABLE_KEY_WEAK: return Qkey_weak; | |
| 1358 case HASH_TABLE_KEY_VALUE_WEAK: return Qkey_or_value_weak; | |
| 1359 case HASH_TABLE_VALUE_WEAK: return Qvalue_weak; | |
| 1360 default: return Qnon_weak; | |
| 428 | 1361 } |
| 1362 } | |
| 1363 | |
| 1364 /************************************************************************/ | |
| 1365 /* Mapping Functions */ | |
| 1366 /************************************************************************/ | |
| 489 | 1367 |
| 1368 /* We need to be careful when mapping over hash tables because the | |
| 1369 hash table might be modified during the mapping operation: | |
| 1370 - by the mapping function | |
| 1371 - by gc (if the hash table is weak) | |
| 1372 | |
| 1373 So we make a copy of the hentries at the beginning of the mapping | |
| 497 | 1374 operation, and iterate over the copy. Naturally, this is |
| 1375 expensive, but not as expensive as you might think, because no | |
| 1376 actual memory has to be collected by our notoriously inefficient | |
| 1377 GC; we use an unwind-protect instead to free the memory directly. | |
| 1378 | |
| 1379 We could avoid the copying by having the hash table modifiers | |
| 1380 puthash and remhash check for currently active mapping functions. | |
| 1381 Disadvantages: it's hard to get right, and IMO hash mapping | |
| 1382 functions are basically rare, and no extra space in the hash table | |
| 1383 object and no extra cpu in puthash or remhash should be wasted to | |
| 1384 make maphash 3% faster. From a design point of view, the basic | |
| 1385 functions gethash, puthash and remhash should be implementable | |
| 1386 without having to think about maphash. | |
| 1387 | |
| 1388 Note: We don't (yet) have Common Lisp's with-hash-table-iterator. | |
| 1389 If you implement this naively, you cannot have more than one | |
| 1390 concurrently active iterator over the same hash table. The `each' | |
| 1391 function in perl has this limitation. | |
| 1392 | |
| 1393 Note: We GCPRO memory on the heap, not on the stack. There is no | |
| 1394 obvious reason why this is bad, but as of this writing this is the | |
| 1395 only known occurrence of this technique in the code. | |
| 504 | 1396 |
| 1397 -- Martin | |
| 1398 */ | |
| 1399 | |
| 1400 /* Ben disagrees with the "copying hentries" design, and says: | |
| 1401 | |
| 1402 Another solution is the same as I've already proposed -- when | |
| 1403 mapping, mark the table as "change-unsafe", and in this case, use a | |
| 1404 secondary table to maintain changes. this could be basically a | |
| 1405 standard hash table, but with entries only for added or deleted | |
| 1406 entries in the primary table, and a marker like Qunbound to | |
| 1407 indicate a deleted entry. puthash, gethash and remhash need a | |
| 1408 single extra check for this secondary table -- totally | |
| 1409 insignificant speedwise. if you really cared about making | |
| 1410 recursive maphashes completely correct, you'd have to do a bit of | |
| 1411 extra work here -- when maphashing, if the secondary table exists, | |
| 1412 make a copy of it, and use the copy in conjunction with the primary | |
| 1413 table when mapping. the advantages of this are | |
| 1414 | |
| 1415 [a] easy to demonstrate correct, even with weak hashtables. | |
| 1416 | |
| 1417 [b] no extra overhead in the general maphash case -- only when you | |
| 1418 modify the table while maphashing, and even then the overhead is | |
| 1419 very small. | |
| 497 | 1420 */ |
| 1421 | |
| 489 | 1422 static Lisp_Object |
| 1423 maphash_unwind (Lisp_Object unwind_obj) | |
| 1424 { | |
| 1425 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
|
1426 xfree (ptr); |
| 489 | 1427 free_opaque_ptr (unwind_obj); |
| 1428 return Qnil; | |
| 1429 } | |
| 1430 | |
| 1431 /* Return a malloced array of alternating key/value pairs from HT. */ | |
| 1432 static Lisp_Object * | |
| 1433 copy_compress_hentries (const Lisp_Hash_Table *ht) | |
| 1434 { | |
| 1435 Lisp_Object * const objs = | |
| 1436 /* If the hash table is empty, ht->count could be 0. */ | |
| 1437 xnew_array (Lisp_Object, 2 * (ht->count > 0 ? ht->count : 1)); | |
| 1204 | 1438 const htentry *e, *sentinel; |
| 489 | 1439 Lisp_Object *pobj; |
| 1440 | |
| 1441 for (e = ht->hentries, sentinel = e + ht->size, pobj = objs; e < sentinel; e++) | |
| 1204 | 1442 if (!HTENTRY_CLEAR_P (e)) |
| 489 | 1443 { |
| 1444 *(pobj++) = e->key; | |
| 1445 *(pobj++) = e->value; | |
| 1446 } | |
| 1447 | |
| 1448 type_checking_assert (pobj == objs + 2 * ht->count); | |
| 1449 | |
| 1450 return objs; | |
| 1451 } | |
| 1452 | |
| 428 | 1453 DEFUN ("maphash", Fmaphash, 2, 2, 0, /* |
| 1454 Map FUNCTION over entries in HASH-TABLE, calling it with two args, | |
| 1455 each key and value in HASH-TABLE. | |
| 1456 | |
| 489 | 1457 FUNCTION must not modify HASH-TABLE, with the one exception that FUNCTION |
| 428 | 1458 may remhash or puthash the entry currently being processed by FUNCTION. |
| 1459 */ | |
| 1460 (function, hash_table)) | |
| 1461 { | |
| 489 | 1462 const Lisp_Hash_Table * const ht = xhash_table (hash_table); |
| 1463 Lisp_Object * const objs = copy_compress_hentries (ht); | |
| 1464 Lisp_Object args[3]; | |
| 1465 const Lisp_Object *pobj, *end; | |
| 1466 int speccount = specpdl_depth (); | |
| 1467 struct gcpro gcpro1; | |
| 1468 | |
| 1469 record_unwind_protect (maphash_unwind, make_opaque_ptr ((void *)objs)); | |
| 1470 GCPRO1 (objs[0]); | |
| 1471 gcpro1.nvars = 2 * ht->count; | |
| 428 | 1472 |
| 489 | 1473 args[0] = function; |
| 1474 | |
| 1475 for (pobj = objs, end = pobj + 2 * ht->count; pobj < end; pobj += 2) | |
| 1476 { | |
| 1477 args[1] = pobj[0]; | |
| 1478 args[2] = pobj[1]; | |
| 1479 Ffuncall (countof (args), args); | |
| 1480 } | |
| 1481 | |
| 771 | 1482 unbind_to (speccount); |
| 489 | 1483 UNGCPRO; |
| 428 | 1484 |
| 1485 return Qnil; | |
| 1486 } | |
| 1487 | |
| 489 | 1488 /* Map *C* function FUNCTION over the elements of a non-weak lisp hash table. |
| 1489 FUNCTION must not modify HASH-TABLE, with the one exception that FUNCTION | |
| 1490 may puthash the entry currently being processed by FUNCTION. | |
| 1491 Mapping terminates if FUNCTION returns something other than 0. */ | |
| 428 | 1492 void |
| 489 | 1493 elisp_maphash_unsafe (maphash_function_t function, |
| 428 | 1494 Lisp_Object hash_table, void *extra_arg) |
| 1495 { | |
| 442 | 1496 const Lisp_Hash_Table *ht = XHASH_TABLE (hash_table); |
| 1204 | 1497 const htentry *e, *sentinel; |
| 428 | 1498 |
| 1499 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++) | |
| 1204 | 1500 if (!HTENTRY_CLEAR_P (e)) |
| 489 | 1501 if (function (e->key, e->value, extra_arg)) |
| 1502 return; | |
| 428 | 1503 } |
| 1504 | |
| 489 | 1505 /* Map *C* function FUNCTION over the elements of a lisp hash table. |
| 1506 It is safe for FUNCTION to modify HASH-TABLE. | |
| 1507 Mapping terminates if FUNCTION returns something other than 0. */ | |
| 1508 void | |
| 1509 elisp_maphash (maphash_function_t function, | |
| 1510 Lisp_Object hash_table, void *extra_arg) | |
| 1511 { | |
| 1512 const Lisp_Hash_Table * const ht = xhash_table (hash_table); | |
| 1513 Lisp_Object * const objs = copy_compress_hentries (ht); | |
| 1514 const Lisp_Object *pobj, *end; | |
| 1515 int speccount = specpdl_depth (); | |
| 1516 struct gcpro gcpro1; | |
| 1517 | |
| 1518 record_unwind_protect (maphash_unwind, make_opaque_ptr ((void *)objs)); | |
| 1519 GCPRO1 (objs[0]); | |
| 1520 gcpro1.nvars = 2 * ht->count; | |
| 1521 | |
| 1522 for (pobj = objs, end = pobj + 2 * ht->count; pobj < end; pobj += 2) | |
| 1523 if (function (pobj[0], pobj[1], extra_arg)) | |
| 1524 break; | |
| 1525 | |
| 771 | 1526 unbind_to (speccount); |
| 489 | 1527 UNGCPRO; |
| 1528 } | |
| 1529 | |
| 1530 /* Remove all elements of a lisp hash table satisfying *C* predicate PREDICATE. | |
| 1531 PREDICATE must not modify HASH-TABLE. */ | |
| 428 | 1532 void |
| 1533 elisp_map_remhash (maphash_function_t predicate, | |
| 1534 Lisp_Object hash_table, void *extra_arg) | |
| 1535 { | |
| 489 | 1536 const Lisp_Hash_Table * const ht = xhash_table (hash_table); |
| 1537 Lisp_Object * const objs = copy_compress_hentries (ht); | |
| 1538 const Lisp_Object *pobj, *end; | |
| 1539 int speccount = specpdl_depth (); | |
| 1540 struct gcpro gcpro1; | |
| 428 | 1541 |
| 489 | 1542 record_unwind_protect (maphash_unwind, make_opaque_ptr ((void *)objs)); |
| 1543 GCPRO1 (objs[0]); | |
| 1544 gcpro1.nvars = 2 * ht->count; | |
| 1545 | |
| 1546 for (pobj = objs, end = pobj + 2 * ht->count; pobj < end; pobj += 2) | |
| 1547 if (predicate (pobj[0], pobj[1], extra_arg)) | |
| 1548 Fremhash (pobj[0], hash_table); | |
| 1549 | |
| 771 | 1550 unbind_to (speccount); |
| 489 | 1551 UNGCPRO; |
| 428 | 1552 } |
| 1553 | |
| 1554 | |
| 1555 /************************************************************************/ | |
| 1556 /* garbage collecting weak hash tables */ | |
| 1557 /************************************************************************/ | |
| 1598 | 1558 #ifdef USE_KKCC |
| 2645 | 1559 #define MARK_OBJ(obj) do { \ |
| 1560 Lisp_Object mo_obj = (obj); \ | |
| 1561 if (!marked_p (mo_obj)) \ | |
| 1562 { \ | |
| 1563 kkcc_gc_stack_push_lisp_object (mo_obj, 0, -1); \ | |
| 1564 did_mark = 1; \ | |
| 1565 } \ | |
| 1598 | 1566 } while (0) |
| 1567 | |
| 1568 #else /* NO USE_KKCC */ | |
| 1569 | |
| 442 | 1570 #define MARK_OBJ(obj) do { \ |
| 1571 Lisp_Object mo_obj = (obj); \ | |
| 1572 if (!marked_p (mo_obj)) \ | |
| 1573 { \ | |
| 1574 mark_object (mo_obj); \ | |
| 1575 did_mark = 1; \ | |
| 1576 } \ | |
| 1577 } while (0) | |
| 1598 | 1578 #endif /*NO USE_KKCC */ |
| 442 | 1579 |
| 428 | 1580 |
| 1581 /* Complete the marking for semi-weak hash tables. */ | |
| 1582 int | |
| 1583 finish_marking_weak_hash_tables (void) | |
| 1584 { | |
| 1585 Lisp_Object hash_table; | |
| 1586 int did_mark = 0; | |
| 1587 | |
| 1588 for (hash_table = Vall_weak_hash_tables; | |
| 1589 !NILP (hash_table); | |
| 1590 hash_table = XHASH_TABLE (hash_table)->next_weak) | |
| 1591 { | |
| 442 | 1592 const Lisp_Hash_Table *ht = XHASH_TABLE (hash_table); |
| 1204 | 1593 const htentry *e = ht->hentries; |
| 1594 const htentry *sentinel = e + ht->size; | |
| 428 | 1595 |
| 1596 if (! marked_p (hash_table)) | |
| 1597 /* The hash table is probably garbage. Ignore it. */ | |
| 1598 continue; | |
| 1599 | |
| 1600 /* Now, scan over all the pairs. For all pairs that are | |
| 1601 half-marked, we may need to mark the other half if we're | |
| 1602 keeping this pair. */ | |
| 1603 switch (ht->weakness) | |
| 1604 { | |
| 1605 case HASH_TABLE_KEY_WEAK: | |
| 1606 for (; e < sentinel; e++) | |
| 1204 | 1607 if (!HTENTRY_CLEAR_P (e)) |
| 428 | 1608 if (marked_p (e->key)) |
| 1609 MARK_OBJ (e->value); | |
| 1610 break; | |
| 1611 | |
| 1612 case HASH_TABLE_VALUE_WEAK: | |
| 1613 for (; e < sentinel; e++) | |
| 1204 | 1614 if (!HTENTRY_CLEAR_P (e)) |
| 428 | 1615 if (marked_p (e->value)) |
| 1616 MARK_OBJ (e->key); | |
| 1617 break; | |
| 1618 | |
| 442 | 1619 case HASH_TABLE_KEY_VALUE_WEAK: |
| 1620 for (; e < sentinel; e++) | |
| 1204 | 1621 if (!HTENTRY_CLEAR_P (e)) |
| 442 | 1622 { |
| 1623 if (marked_p (e->value)) | |
| 1624 MARK_OBJ (e->key); | |
| 1625 else if (marked_p (e->key)) | |
| 1626 MARK_OBJ (e->value); | |
| 1627 } | |
| 1628 break; | |
| 1629 | |
| 428 | 1630 case HASH_TABLE_KEY_CAR_WEAK: |
| 1631 for (; e < sentinel; e++) | |
| 1204 | 1632 if (!HTENTRY_CLEAR_P (e)) |
| 428 | 1633 if (!CONSP (e->key) || marked_p (XCAR (e->key))) |
| 1634 { | |
| 1635 MARK_OBJ (e->key); | |
| 1636 MARK_OBJ (e->value); | |
| 1637 } | |
| 1638 break; | |
| 1639 | |
| 450 | 1640 /* We seem to be sprouting new weakness types at an alarming |
| 1641 rate. At least this is not externally visible - and in | |
| 1642 fact all of these KEY_CAR_* types are only used by the | |
| 1643 glyph code. */ | |
| 1644 case HASH_TABLE_KEY_CAR_VALUE_WEAK: | |
| 1645 for (; e < sentinel; e++) | |
| 1204 | 1646 if (!HTENTRY_CLEAR_P (e)) |
| 450 | 1647 { |
| 1648 if (!CONSP (e->key) || marked_p (XCAR (e->key))) | |
| 1649 { | |
| 1650 MARK_OBJ (e->key); | |
| 1651 MARK_OBJ (e->value); | |
| 1652 } | |
| 1653 else if (marked_p (e->value)) | |
| 1654 MARK_OBJ (e->key); | |
| 1655 } | |
| 1656 break; | |
| 1657 | |
| 428 | 1658 case HASH_TABLE_VALUE_CAR_WEAK: |
| 1659 for (; e < sentinel; e++) | |
| 1204 | 1660 if (!HTENTRY_CLEAR_P (e)) |
| 428 | 1661 if (!CONSP (e->value) || marked_p (XCAR (e->value))) |
| 1662 { | |
| 1663 MARK_OBJ (e->key); | |
| 1664 MARK_OBJ (e->value); | |
| 1665 } | |
| 1666 break; | |
| 1667 | |
| 1668 default: | |
| 1669 break; | |
| 1670 } | |
| 1671 } | |
| 1672 | |
| 1673 return did_mark; | |
| 1674 } | |
| 1675 | |
| 1676 void | |
| 1677 prune_weak_hash_tables (void) | |
| 1678 { | |
| 1679 Lisp_Object hash_table, prev = Qnil; | |
| 1680 for (hash_table = Vall_weak_hash_tables; | |
| 1681 !NILP (hash_table); | |
| 1682 hash_table = XHASH_TABLE (hash_table)->next_weak) | |
| 1683 { | |
| 1684 if (! marked_p (hash_table)) | |
| 1685 { | |
| 1686 /* This hash table itself is garbage. Remove it from the list. */ | |
| 1687 if (NILP (prev)) | |
| 1688 Vall_weak_hash_tables = XHASH_TABLE (hash_table)->next_weak; | |
| 1689 else | |
| 1690 XHASH_TABLE (prev)->next_weak = XHASH_TABLE (hash_table)->next_weak; | |
| 1691 } | |
| 1692 else | |
| 1693 { | |
| 1694 /* Now, scan over all the pairs. Remove all of the pairs | |
| 1695 in which the key or value, or both, is unmarked | |
| 1696 (depending on the weakness of the hash table). */ | |
| 1697 Lisp_Hash_Table *ht = XHASH_TABLE (hash_table); | |
| 1204 | 1698 htentry *entries = ht->hentries; |
| 1699 htentry *sentinel = entries + ht->size; | |
| 1700 htentry *e; | |
| 428 | 1701 |
| 1702 for (e = entries; e < sentinel; e++) | |
| 1204 | 1703 if (!HTENTRY_CLEAR_P (e)) |
| 428 | 1704 { |
| 1705 again: | |
| 1706 if (!marked_p (e->key) || !marked_p (e->value)) | |
| 1707 { | |
| 1708 remhash_1 (ht, entries, e); | |
| 1204 | 1709 if (!HTENTRY_CLEAR_P (e)) |
| 428 | 1710 goto again; |
| 1711 } | |
| 1712 } | |
| 1713 | |
| 1714 prev = hash_table; | |
| 1715 } | |
| 1716 } | |
| 1717 } | |
| 1718 | |
| 1719 /* Return a hash value for an array of Lisp_Objects of size SIZE. */ | |
| 1720 | |
| 665 | 1721 Hashcode |
| 428 | 1722 internal_array_hash (Lisp_Object *arr, int size, int depth) |
| 1723 { | |
| 1724 int i; | |
| 665 | 1725 Hashcode hash = 0; |
| 442 | 1726 depth++; |
| 428 | 1727 |
| 1728 if (size <= 5) | |
| 1729 { | |
| 1730 for (i = 0; i < size; i++) | |
| 442 | 1731 hash = HASH2 (hash, internal_hash (arr[i], depth)); |
| 428 | 1732 return hash; |
| 1733 } | |
| 1734 | |
| 1735 /* just pick five elements scattered throughout the array. | |
| 1736 A slightly better approach would be to offset by some | |
| 1737 noise factor from the points chosen below. */ | |
| 1738 for (i = 0; i < 5; i++) | |
| 442 | 1739 hash = HASH2 (hash, internal_hash (arr[i*size/5], depth)); |
| 428 | 1740 |
| 1741 return hash; | |
| 1742 } | |
| 1743 | |
| 1744 /* Return a hash value for a Lisp_Object. This is for use when hashing | |
| 1745 objects with the comparison being `equal' (for `eq', you can just | |
| 1746 use the Lisp_Object itself as the hash value). You need to make a | |
| 1747 tradeoff between the speed of the hash function and how good the | |
| 1748 hashing is. In particular, the hash function needs to be FAST, | |
| 1749 so you can't just traipse down the whole tree hashing everything | |
| 1750 together. Most of the time, objects will differ in the first | |
| 1751 few elements you hash. Thus, we only go to a short depth (5) | |
| 1752 and only hash at most 5 elements out of a vector. Theoretically | |
| 1753 we could still take 5^5 time (a big big number) to compute a | |
| 1754 hash, but practically this won't ever happen. */ | |
| 1755 | |
| 665 | 1756 Hashcode |
| 428 | 1757 internal_hash (Lisp_Object obj, int depth) |
| 1758 { | |
| 1759 if (depth > 5) | |
| 1760 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
|
1761 |
|
479443c0f95a
Have list hashes depend on the order of the contents, as is the case for vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4117
diff
changeset
|
1762 if (CONSP(obj)) |
| 428 | 1763 { |
|
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
|
1764 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
|
1765 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
|
1766 |
|
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
|
1767 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
|
1768 |
|
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
|
1769 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
|
1770 { |
|
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
|
1771 /* 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
|
1772 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
|
1773 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
|
1774 } |
|
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
|
1775 |
|
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
|
1776 /* 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
|
1777 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
|
1778 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
|
1779 |
|
479443c0f95a
Have list hashes depend on the order of the contents, as is the case for vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4117
diff
changeset
|
1780 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
|
1781 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
|
1782 { |
|
479443c0f95a
Have list hashes depend on the order of the contents, as is the case for vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4117
diff
changeset
|
1783 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
|
1784 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
|
1785 } |
|
479443c0f95a
Have list hashes depend on the order of the contents, as is the case for vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4117
diff
changeset
|
1786 |
|
479443c0f95a
Have list hashes depend on the order of the contents, as is the case for vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4117
diff
changeset
|
1787 return hash; |
| 428 | 1788 } |
| 1789 if (STRINGP (obj)) | |
| 1790 { | |
| 1791 return hash_string (XSTRING_DATA (obj), XSTRING_LENGTH (obj)); | |
| 1792 } | |
| 1793 if (LRECORDP (obj)) | |
| 1794 { | |
| 442 | 1795 const struct lrecord_implementation |
| 428 | 1796 *imp = XRECORD_LHEADER_IMPLEMENTATION (obj); |
| 1797 if (imp->hash) | |
| 1798 return imp->hash (obj, depth); | |
| 1799 } | |
| 1800 | |
| 1801 return LISP_HASH (obj); | |
| 1802 } | |
| 1803 | |
| 1804 DEFUN ("sxhash", Fsxhash, 1, 1, 0, /* | |
| 1805 Return a hash value for OBJECT. | |
| 444 | 1806 \(equal obj1 obj2) implies (= (sxhash obj1) (sxhash obj2)). |
| 428 | 1807 */ |
| 1808 (object)) | |
| 1809 { | |
| 1810 return make_int (internal_hash (object, 0)); | |
| 1811 } | |
| 1812 | |
| 1813 #if 0 | |
| 826 | 1814 DEFUN ("internal-hash-value", Finternal_hash_value, 1, 1, 0, /* |
| 428 | 1815 Hash value of OBJECT. For debugging. |
| 1816 The value is returned as (HIGH . LOW). | |
| 1817 */ | |
| 1818 (object)) | |
| 1819 { | |
| 1820 /* This function is pretty 32bit-centric. */ | |
| 665 | 1821 Hashcode hash = internal_hash (object, 0); |
| 428 | 1822 return Fcons (hash >> 16, hash & 0xffff); |
| 1823 } | |
| 1824 #endif | |
| 1825 | |
| 1826 | |
| 1827 /************************************************************************/ | |
| 1828 /* initialization */ | |
| 1829 /************************************************************************/ | |
| 1830 | |
| 1831 void | |
| 1832 syms_of_elhash (void) | |
| 1833 { | |
| 1834 DEFSUBR (Fhash_table_p); | |
| 1835 DEFSUBR (Fmake_hash_table); | |
| 1836 DEFSUBR (Fcopy_hash_table); | |
| 1837 DEFSUBR (Fgethash); | |
| 1838 DEFSUBR (Fremhash); | |
| 1839 DEFSUBR (Fputhash); | |
| 1840 DEFSUBR (Fclrhash); | |
| 1841 DEFSUBR (Fmaphash); | |
| 1842 DEFSUBR (Fhash_table_count); | |
| 1843 DEFSUBR (Fhash_table_test); | |
| 1844 DEFSUBR (Fhash_table_size); | |
| 1845 DEFSUBR (Fhash_table_rehash_size); | |
| 1846 DEFSUBR (Fhash_table_rehash_threshold); | |
| 1847 DEFSUBR (Fhash_table_weakness); | |
| 1848 DEFSUBR (Fhash_table_type); /* obsolete */ | |
| 1849 DEFSUBR (Fsxhash); | |
| 1850 #if 0 | |
| 1851 DEFSUBR (Finternal_hash_value); | |
| 1852 #endif | |
| 1853 | |
| 563 | 1854 DEFSYMBOL_MULTIWORD_PREDICATE (Qhash_tablep); |
| 1855 DEFSYMBOL (Qhash_table); | |
| 1856 DEFSYMBOL (Qhashtable); | |
| 1857 DEFSYMBOL (Qweakness); | |
| 1858 DEFSYMBOL (Qvalue); | |
| 1859 DEFSYMBOL (Qkey_or_value); | |
| 1860 DEFSYMBOL (Qkey_and_value); | |
| 1861 DEFSYMBOL (Qrehash_size); | |
| 1862 DEFSYMBOL (Qrehash_threshold); | |
| 428 | 1863 |
| 563 | 1864 DEFSYMBOL (Qweak); /* obsolete */ |
| 1865 DEFSYMBOL (Qkey_weak); /* obsolete */ | |
| 1866 DEFSYMBOL (Qkey_or_value_weak); /* obsolete */ | |
| 1867 DEFSYMBOL (Qvalue_weak); /* obsolete */ | |
| 1868 DEFSYMBOL (Qnon_weak); /* obsolete */ | |
| 428 | 1869 |
|
4820
e6dec75ded0e
Use keywords, not ordinary symbols, in the structure syntax for hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4779
diff
changeset
|
1870 DEFKEYWORD (Q_data); |
| 563 | 1871 DEFKEYWORD (Q_test); |
| 1872 DEFKEYWORD (Q_size); | |
| 1873 DEFKEYWORD (Q_rehash_size); | |
| 1874 DEFKEYWORD (Q_rehash_threshold); | |
| 1875 DEFKEYWORD (Q_weakness); | |
| 1876 DEFKEYWORD (Q_type); /* obsolete */ | |
| 428 | 1877 } |
| 1878 | |
| 1879 void | |
| 771 | 1880 init_elhash_once_early (void) |
| 428 | 1881 { |
| 771 | 1882 INIT_LRECORD_IMPLEMENTATION (hash_table); |
| 3092 | 1883 #ifdef NEW_GC |
| 1884 INIT_LRECORD_IMPLEMENTATION (hash_table_entry); | |
| 1885 #endif /* NEW_GC */ | |
| 771 | 1886 |
| 428 | 1887 /* This must NOT be staticpro'd */ |
| 1888 Vall_weak_hash_tables = Qnil; | |
| 452 | 1889 dump_add_weak_object_chain (&Vall_weak_hash_tables); |
| 428 | 1890 } |