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