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