Mercurial > hg > xemacs-beta
annotate src/gui.c @ 2720:6fa9919a9a0b
[xemacs-hg @ 2005-04-08 23:10:01 by crestani]
ChangeLog addition:
2005-04-01 Marcus Crestani <crestani@xemacs.org>
The new allocator.
New configure flag: `MC_ALLOC':
* configure.ac (XE_COMPLEX_ARG_ENABLE): Add `--enable-mc-alloc' as
a new configure flag.
* configure.in (AC_INIT_PARSE_ARGS): Add `--mc-alloc' as a new
configure flag.
* configure.usage: Add description for `mc-alloc'.
DUMP_IN_EXEC:
* Makefile.in.in: Condition the installation of a separate dump
file on !DUMP_ON_EXEC.
* configure.ac (XE_COMPLEX_ARG_ENABLE): Add
`--enable-dump-in-exec' as a new configure flag.
* configure.ac: DUMP_IN_EXEC is define as default for PDUMP but
not default for MC_ALLOC.
* configure.in (AC_INIT_PARSE_ARGS): Add `--dump-in-exec' as a
new configure flag.
* configure.in: DUMP_IN_EXEC is define as default for PDUMP but
not default for MC_ALLOC.
* configure.usage: Add description for `dump-in-exec'.
lib-src/ChangeLog addition:
2005-04-01 Marcus Crestani <crestani@xemacs.org>
The new allocator.
DUMP_IN_EXEC:
* Makefile.in.in: Only compile insert-data-in-exec if
DUMP_IN_EXEC is defined.
lisp/ChangeLog addition:
2005-04-01 Marcus Crestani <crestani@xemacs.org>
The new allocator.
MEMORY_USAGE_STATS
* diagnose.el: Add new lisp function to pretty print statistics
about the new allocator.
* diagnose.el (show-mc-alloc-memory-usage): New.
modules/ChangeLog addition:
2005-04-01 Marcus Crestani <crestani@xemacs.org>
The new allocator.
Remove Lcrecords:
* postgresql/postgresql.c (allocate_pgconn): Allocate with new
allocator.
* postgresql/postgresql.c (allocate_pgresult): Allocate PGresult
with new allocator.
* postgresql/postgresql.h (struct Lisp_PGconn): Add
lrecord_header.
* postgresql/postgresql.h (struct Lisp_PGresult): Add
lrecord_header.
* ldap/eldap.c (allocate_ldap): Allocate with new allocator.
* ldap/eldap.h (struct Lisp_LDAP): Add lrecord_header.
nt/ChangeLog addition:
2005-04-01 Marcus Crestani <crestani@xemacs.org>
The new allocator.
New configure flag: `MC_ALLOC':
* config.inc.samp: Add new flag `MC_ALLOC'.
* xemacs.mak: Add flag and configuration output for `MC_ALLOC'.
New files:
* xemacs.dsp: Add source files mc-alloc.c and mc-alloc.h.
* xemacs.mak: Add new object file mc-alloc.obj to dependencies.
src/ChangeLog addition:
2005-04-01 Marcus Crestani <crestani@xemacs.org>
The new allocator.
New configure flag: `MC_ALLOC':
* config.h.in: Add new flag `MC_ALLOC'.
New files:
* Makefile.in.in: Add new object file mc-alloc.o.
* depend: Add new files to dependencies.
* mc-alloc.c: New.
* mc-alloc.h: New.
Running the new allocator from XEmacs:
* alloc.c (deadbeef_memory): Moved to mc-alloc.c.
* emacs.c (main_1): Initialize the new allocator and add
syms_of_mc_alloc.
* symsinit.h: Add syms_of_mc_alloc.
New lrecord allocation and free functions:
* alloc.c (alloc_lrecord): New. Allocates an lrecord, includes
type checking and initializing of the lrecord_header.
* alloc.c (noseeum_alloc_lrecord): Same as above, but increments
the NOSEEUM cons counter.
* alloc.c (free_lrecord): New. Calls the finalizer and frees the
lrecord.
* lrecord.h: Add lrecord allocation prototypes and comments.
Remove old lrecord FROB block allocation:
* alloc.c (allocate_lisp_storage): Former function to expand
heap. Not needed anymore, remove.
* alloc.c: Completely remove `Fixed-size type macros'
* alloc.c (release_breathing_space): Remove.
* alloc.c (memory_full): Remove release_breathing_space.
* alloc.c (refill_memory_reserve): Remove.
* alloc.c (TYPE_ALLOC_SIZE): Remove.
* alloc.c (DECLARE_FIXED_TYPE_ALLOC): Remove.
* alloc.c (ALLOCATE_FIXED_TYPE_FROM_BLOCK): Remove.
* alloc.c (ALLOCATE_FIXED_TYPE_1): Remove.
* alloc.c (ALLOCATE_FIXED_TYPE): Remove.
* alloc.c (NOSEEUM_ALLOCATE_FIXED_TYPE): Remove.
* alloc.c (struct Lisp_Free): Remove.
* alloc.c (LRECORD_FREE_P): Remove.
* alloc.c (MARK_LRECORD_AS_FREE): Remove.
* alloc.c (MARK_LRECORD_AS_NOT_FREE): Remove.
* alloc.c (PUT_FIXED_TYPE_ON_FREE_LIST): Remove.
* alloc.c (FREE_FIXED_TYPE): Remove.
* alloc.c (FREE_FIXED_TYPE_WHEN_NOT_IN_GC): Remove.
Allocate old lrecords with new allocator:
* alloc.c: DECLARE_FIXED_TYPE_ALLOC removed for all lrecords
defined in alloc.c.
* alloc.c (Fcons): Allocate with new allocator.
* alloc.c (noseeum_cons): Allocate with new allocator.
* alloc.c (make_float): Allocate with new allocator.
* alloc.c (make_bignum): Allocate with new allocator.
* alloc.c (make_bignum_bg): Allocate with new allocator.
* alloc.c (make_ratio): Allocate with new allocator.
* alloc.c (make_ratio_bg): Allocate with new allocator.
* alloc.c (make_ratio_rt): Allocate with new allocator.
* alloc.c (make_bigfloat): Allocate with new allocator.
* alloc.c (make_bigfloat_bf): Allocate with new allocator.
* alloc.c (make_compiled_function): Allocate with new allocator.
* alloc.c (Fmake_symbol): Allocate with new allocator.
* alloc.c (allocate_extent): Allocate with new allocator.
* alloc.c (allocate_event): Allocate with new allocator.
* alloc.c (make_key_data): Allocate with new allocator.
* alloc.c (make_button_data): Allocate with new allocator.
* alloc.c (make_motion_data): Allocate with new allocator.
* alloc.c (make_process_data): Allocate with new allocator.
* alloc.c (make_timeout_data): Allocate with new allocator.
* alloc.c (make_magic_data): Allocate with new allocator.
* alloc.c (make_magic_eval_data): Allocate with new allocator.
* alloc.c (make_eval_data): Allocate with new allocator.
* alloc.c (make_misc_user_data): Allocate with new allocator.
* alloc.c (Fmake_marker): Allocate with new allocator.
* alloc.c (noseeum_make_marker): Allocate with new allocator.
* alloc.c (make_uninit_string): Allocate with new allocator.
* alloc.c (resize_string): Allocate with new allocator.
* alloc.c (make_string_nocopy): Allocate with new allocator.
Garbage Collection:
* alloc.c (GC_CHECK_NOT_FREE): Remove obsolete assertions.
* alloc.c (SWEEP_FIXED_TYPE_BLOCK): Remove.
* alloc.c (SWEEP_FIXED_TYPE_BLOCK_1): Remove.
* alloc.c (sweep_conses): Remove.
* alloc.c (free_cons): Use new allocator to free.
* alloc.c (sweep_compiled_functions): Remove.
* alloc.c (sweep_floats): Remove.
* alloc.c (sweep_bignums): Remove.
* alloc.c (sweep_ratios): Remove.
* alloc.c (sweep_bigfloats): Remove.
* alloc.c (sweep_symbols): Remove.
* alloc.c (sweep_extents): Remove.
* alloc.c (sweep_events): Remove.
* alloc.c (sweep_key_data): Remove.
* alloc.c (free_key_data): Use new allocator to free.
* alloc.c (sweep_button_data): Remove.
* alloc.c (free_button_data): Use new allocator to free.
* alloc.c (sweep_motion_data): Remove.
* alloc.c (free_motion_data): Use new allocator to free.
* alloc.c (sweep_process_data): Remove.
* alloc.c (free_process_data): Use new allocator to free.
* alloc.c (sweep_timeout_data): Remove.
* alloc.c (free_timeout_data): Use new allocator to free.
* alloc.c (sweep_magic_data): Remove.
* alloc.c (free_magic_data): Use new allocator to free.
* alloc.c (sweep_magic_eval_data): Remove.
* alloc.c (free_magic_eval_data): Use new allocator to free.
* alloc.c (sweep_eval_data): Remove.
* alloc.c (free_eval_data): Use new allocator to free.
* alloc.c (sweep_misc_user_data): Remove.
* alloc.c (free_misc_user_data): Use new allocator to free.
* alloc.c (sweep_markers): Remove.
* alloc.c (free_marker): Use new allocator to free.
* alloc.c (garbage_collect_1): Remove release_breathing_space.
* alloc.c (gc_sweep): Remove all the old lcrecord and lrecord
related stuff. Sweeping now works like this: compact string
chars, finalize, sweep.
* alloc.c (common_init_alloc_early): Remove old lrecord
initializations, remove breathing_space.
* emacs.c (Fdump_emacs): Remove release_breathing_space.
* lisp.h: Remove prototype for release_breathing_space.
* lisp.h: Adjust the special cons mark makros.
Lrecord Finalizer:
* alloc.c: Add finalizer to lrecord definition.
* alloc.c (finalize_string): Add finalizer for string.
* bytecode.c: Add finalizer to lrecord definition.
* bytecode.c (finalize_compiled_function): Add finalizer for
compiled function.
* marker.c: Add finalizer to lrecord definition.
* marker.c (finalize_marker): Add finalizer for marker.
These changes build the interface to mc-alloc:
* lrecord.h (MC_ALLOC_CALL_FINALIZER): Tell mc-alloc how to
finalize lrecords.
* lrecord.h (MC_ALLOC_CALL_FINALIZER_FOR_DISKSAVE): Tell
mc-alloc how to finalize for disksave.
Unify lrecords and lcrecords:
* lisp.h (struct Lisp_String): Adjust string union hack to
new lrecord header.
* lrecord.h: Adjust comments.
* lrecord.h (struct lrecord_header): The new lrecord header
includes type, lisp-readonly, free, and uid.
* lrecord.h (set_lheader_implementation): Adjust to new
lrecord_header.
* lrecord.h (struct lrecord_implementation): The field basic_p
for indication of an old lrecord is not needed anymore, remove.
* lrecord.h (MAKE_LRECORD_IMPLEMENTATION): Remove basic_p.
* lrecord.h (MAKE_EXTERNAL_LRECORD_IMPLEMENTATION): Remove
basic_p.
* lrecord.h (copy_sized_lrecord): Remove distinction between
old lrecords and lcrecords.
* lrecord.h (copy_lrecord): Remove distinction between old
lrecords and lcrecords.
* lrecord.h (zero_sized_lrecord): Remove distinction between
old lrecords and lcrecords.
* lrecord.h (zero_lrecord): Remove distinction between old
lrecords and lcrecords.
Remove lcrecords and lcrecord lists:
* alloc.c (basic_alloc_lcrecord): Not needed anymore, remove.
* alloc.c (very_old_free_lcrecord): Not needed anymore, remove.
* alloc.c (copy_lisp_object): No more distinction between
lrecords and lcrecords.
* alloc.c (all_lcrecords): Not needed anymore, remove.
* alloc.c (make_vector_internal): Allocate as lrecord.
* alloc.c (make_bit_vector_internal): Allocate as lrecord.
* alloc.c: Completely remove `lcrecord lists'.
* alloc.c (free_description): Remove.
* alloc.c (lcrecord_list_description): Remove.
* alloc.c (mark_lcrecord_list): Remove.
* alloc.c (make_lcrecord_list): Remove.
* alloc.c (alloc_managed_lcrecord): Remove.
* alloc.c (free_managed_lcrecord): Remove.
* alloc.c (alloc_automanaged_lcrecord): Remove.
* alloc.c (free_lcrecord): Remove.
* alloc.c (lcrecord_stats): Remove.
* alloc.c (tick_lcrecord_stats): Remove.
* alloc.c (disksave_object_finalization_1): Add call to
mc_finalize_for_disksave. Remove the lcrecord way to visit all
objects.
* alloc.c (kkcc_marking): Remove XD_FLAG_FREE_LISP_OBJECT
* alloc.c (sweep_lcrecords_1): Remove.
* alloc.c (common_init_alloc_early): Remove everything related
to lcrecords, remove old lrecord initializations,
* alloc.c (init_lcrecord_lists): Not needed anymore, remove.
* alloc.c (reinit_alloc_early): Remove everything related to
lcrecords.
* alloc.c (init_alloc_once_early): Remove everything related to
lcrecords.
* buffer.c (allocate_buffer): Allocate as lrecord.
* buffer.c (nuke_all_buffer_slots): Use lrecord functions.
* buffer.c (common_init_complex_vars_of_buffer): Allocate as
lrecord.
* buffer.h (struct buffer): Add lrecord_header.
* casetab.c (allocate_case_table): Allocate as lrecord.
* casetab.h (struct Lisp_Case_Table): Add lrecord_header.
* charset.h (struct Lisp_Charset): Add lrecord_header.
* chartab.c (fill_char_table): Use lrecord functions.
* chartab.c (Fmake_char_table): Allocate as lrecord.
* chartab.c (make_char_table_entry): Allocate as lrecord.
* chartab.c (copy_char_table_entry): Allocate as lrecord.
* chartab.c (Fcopy_char_table): Allocate as lrecord.
* chartab.c (put_char_table): Use lrecord functions.
* chartab.h (struct Lisp_Char_Table_Entry): Add lrecord_header.
* chartab.h (struct Lisp_Char_Table): Add lrecord_header.
* console-impl.h (struct console): Add lrecord_header.
* console-msw-impl.h (struct Lisp_Devmode): Add lrecord_header.
* console-msw-impl.h (struct mswindows_dialog_id): Add
lrecord_header.
* console.c (allocate_console): Allocate as lrecord.
* console.c (nuke_all_console_slots): Use lrecord functions.
* console.c (common_init_complex_vars_of_console): Allocate as
lrecord.
* data.c (make_weak_list): Allocate as lrecord.
* data.c (make_weak_box): Allocate as lrecord.
* data.c (make_ephemeron): Allocate as lrecord.
* database.c (struct Lisp_Database): Add lrecord_header.
* database.c (allocate_database): Allocate as lrecord.
* device-impl.h (struct device): Add lrecord_header.
* device-msw.c (allocate_devmode): Allocate as lrecord.
* device.c (nuke_all_device_slots): Use lrecord functions.
* device.c (allocate_device): Allocate as lrecord.
* dialog-msw.c (handle_question_dialog_box): Allocate as lrecord.
* elhash.c (struct Lisp_Hash_Table): Add lrecord_header.
* elhash.c (make_general_lisp_hash_table): Allocate as lrecord.
* elhash.c (Fcopy_hash_table): Allocate as lrecord.
* event-stream.c: Lcrecord lists Vcommand_builder_free_list and
Vtimeout_free_list are no longer needed. Remove.
* event-stream.c (allocate_command_builder): Allocate as lrecord.
* event-stream.c (free_command_builder): Use lrecord functions.
* event-stream.c (event_stream_generate_wakeup): Allocate as
lrecord.
* event-stream.c (event_stream_resignal_wakeup): Use lrecord
functions.
* event-stream.c (event_stream_disable_wakeup): Use lrecord
functions.
* event-stream.c (reinit_vars_of_event_stream): Lcrecord lists
remove.
* events.h (struct Lisp_Timeout): Add lrecord_header.
* events.h (struct command_builder): Add lrecord_header.
* extents-impl.h (struct extent_auxiliary): Add lrecord_header.
* extents-impl.h (struct extent_info): Add lrecord_header.
* extents.c (allocate_extent_auxiliary): Allocate as lrecord.
* extents.c (allocate_extent_info): Allocate as lrecord.
* extents.c (copy_extent): Allocate as lrecord.
* faces.c (allocate_face): Allocate as lrecord.
* faces.h (struct Lisp_Face): Add lrecord_header.
* file-coding.c (allocate_coding_system): Allocate as lrecord.
* file-coding.c (Fcopy_coding_system): Allocate as lrecord.
* file-coding.h (struct Lisp_Coding_System): Add lrecord_header.
* fns.c (Ffillarray): Allocate as lrecord.
* frame-impl.h (struct frame): Add lrecord_header.
* frame.c (nuke_all_frame_slots): Use lrecord functions.
* frame.c (allocate_frame_core): Allocate as lrecord.
* glyphs.c (allocate_image_instance): Allocate as lrecord.
* glyphs.c (Fcolorize_image_instance): Allocate as lrecord.
* glyphs.c (allocate_glyph): Allocate as lrecord.
* glyphs.h (struct Lisp_Image_Instance): Add lrecord_header.
* glyphs.h (struct Lisp_Glyph): Add lrecord_header.
* gui.c (allocate_gui_item): Allocate as lrecord.
* gui.h (struct Lisp_Gui_Item): Add lrecord_header.
* keymap.c (struct Lisp_Keymap): Add lrecord_header.
* keymap.c (make_keymap): Allocate as lrecord.
* lisp.h (struct Lisp_Vector): Add lrecord_header.
* lisp.h (struct Lisp_Bit_Vector): Add lrecord_header.
* lisp.h (struct weak_box): Add lrecord_header.
* lisp.h (struct ephemeron): Add lrecord_header.
* lisp.h (struct weak_list): Add lrecord_header.
* lrecord.h (struct lcrecord_header): Not used, remove.
* lrecord.h (struct free_lcrecord_header): Not used, remove.
* lrecord.h (struct lcrecord_list): Not needed anymore, remove.
* lrecord.h (lcrecord_list): Not needed anymore, remove.
* lrecord.h: (enum data_description_entry_flags): Remove
XD_FLAG_FREE_LISP_OBJECT.
* lstream.c: Lrecord list Vlstream_free_list remove.
* lstream.c (Lstream_new): Allocate as lrecord.
* lstream.c (Lstream_delete): Use lrecod functions.
* lstream.c (reinit_vars_of_lstream): Vlstream_free_list
initialization remove.
* lstream.h (struct lstream): Add lrecord_header.
* emacs.c (main_1): Remove lstream initialization.
* mule-charset.c (make_charset): Allocate as lrecord.
* objects-impl.h (struct Lisp_Color_Instance): Add
lrecord_header.
* objects-impl.h (struct Lisp_Font_Instance): Add lrecord_header.
* objects.c (Fmake_color_instance): Allocate as lrecord.
* objects.c (Fmake_font_instance): Allocate as lrecord.
* objects.c (reinit_vars_of_objects): Allocate as lrecord.
* opaque.c: Lcreord list Vopaque_ptr_list remove.
* opaque.c (make_opaque): Allocate as lrecord.
* opaque.c (make_opaque_ptr): Allocate as lrecord.
* opaque.c (free_opaque_ptr): Use lrecord functions.
* opaque.c (reinit_opaque_early):
* opaque.c (init_opaque_once_early): Vopaque_ptr_list
initialization remove.
* opaque.h (Lisp_Opaque): Add lrecord_header.
* opaque.h (Lisp_Opaque_Ptr): Add lrecord_header.
* emacs.c (main_1): Remove opaque variable initialization.
* print.c (default_object_printer): Use new lrecord_header.
* print.c (print_internal): Use new lrecord_header.
* print.c (debug_p4): Use new lrecord_header.
* process.c (make_process_internal): Allocate as lrecord.
* procimpl.h (struct Lisp_Process): Add lrecord_header.
* rangetab.c (Fmake_range_table): Allocate as lrecord.
* rangetab.c (Fcopy_range_table): Allocate as lrecord.
* rangetab.h (struct Lisp_Range_Table): Add lrecord_header.
* scrollbar.c (create_scrollbar_instance): Allocate as lrecord.
* scrollbar.h (struct scrollbar_instance): Add lrecord_header.
* specifier.c (make_specifier_internal): Allocate as lrecord.
* specifier.h (struct Lisp_Specifier): Add lrecord_header.
* symbols.c:
* symbols.c (Fmake_variable_buffer_local): Allocate as lrecord.
* symbols.c (Fdontusethis_set_symbol_value_handler): Allocate
as lrecord.
* symbols.c (Fdefvaralias): Allocate as lrecord.
* symeval.h (struct symbol_value_magic): Add lrecord_header.
* toolbar.c (update_toolbar_button): Allocate as lrecord.
* toolbar.h (struct toolbar_button): Add lrecord_header.
* tooltalk.c (struct Lisp_Tooltalk_Message): Add lrecord_header.
* tooltalk.c (make_tooltalk_message): Allocate as lrecord.
* tooltalk.c (struct Lisp_Tooltalk_Pattern): Add lrecord_header.
* tooltalk.c (make_tooltalk_pattern): Allocate as lrecord.
* ui-gtk.c (allocate_ffi_data): Allocate as lrecord.
* ui-gtk.c (allocate_emacs_gtk_object_data): Allocate as lrecord.
* ui-gtk.c (allocate_emacs_gtk_boxed_data): Allocate as lrecord.
* ui-gtk.h (structs): Add lrecord_header.
* window-impl.h (struct window): Add lrecord_header.
* window-impl.h (struct window_mirror): Add lrecord_header.
* window.c (allocate_window): Allocate as lrecord.
* window.c (new_window_mirror): Allocate as lrecord.
* window.c (make_dummy_parent): Allocate as lrecord.
MEMORY_USAGE_STATS
* alloc.c (fixed_type_block_overhead): Not used anymore, remove.
* buffer.c (compute_buffer_usage): Get storage size from new
allocator.
* marker.c (compute_buffer_marker_usage): Get storage size from
new allocator.
* mule-charset.c (compute_charset_usage): Get storage size from
new allocator.
* scrollbar-gtk.c (gtk_compute_scrollbar_instance_usage): Get
storage size from new allocator.
* scrollbar-msw.c (mswindows_compute_scrollbar_instance_usage):
Get storage size from new allocator.
* scrollbar-x.c (x_compute_scrollbar_instance_usage): Get
storage size from new allocator.
* scrollbar.c (compute_scrollbar_instance_usage): Get storage
size from new allocator.
* unicode.c (compute_from_unicode_table_size_1): Get storage
size from new allocator.
* unicode.c (compute_to_unicode_table_size_1): Get storage size
from new allocator.
* window.c (compute_window_mirror_usage): Get storage size from
new allocator.
* window.c (compute_window_usage): Get storage size from new
allocator.
MC_ALLOC_TYPE_STATS:
* alloc.c (alloc_lrecord): Bump lrecord count.
* alloc.c (noseeum_alloc_lrecord): Bump lrecord count.
* alloc.c (struct lrecord_stats): Storage for counts.
* alloc.c (init_lrecord_stats): Zero statistics.
* alloc.c (inc_lrecord_stats): Increase the statistic.
* alloc.c (dec_lrecord_stats): Decrease the statistic.
* alloc.c (gc_plist_hack): Used to print the information.
* alloc.c (Fgarbage_collect): Return the collected information.
* mc-alloc.c (remove_cell): Decrease lrecord count.
* mc-alloc.h: Set flag MC_ALLOC_TYPE_STATS.
* emacs.c (main_1): Init lrecord statistics.
* lrecord.h: Add prototypes for *_lrecord_stats.
Strings:
* alloc.c (Fmake_string): Initialize ascii_begin to zero.
* alloc.c (gc_count_num_short_string_in_use): Remove.
* alloc.c (gc_count_string_total_size): Remove.
* alloc.c (gc_count_short_string_total_size): Remove.
* alloc.c (debug_string_purity): Remove.
* alloc.c (debug_string_purity_print): Remove.
* alloc.c (sweep_strings): Remove.
Remove static C-readonly Lisp objects:
* alloc.c (c_readonly): Not needed anymore, remove.
* alloc.c (GC_CHECK_LHEADER_INVARIANTS): Remove some obsolete
lheader invariants assertions.
* buffer.c (DEFVAR_BUFFER_LOCAL_1): Allocate dynamically.
* console.c (DEFVAR_CONSOLE_LOCAL_1): Allocate dynamically.
* gpmevent.c: Indirection via MC_ALLOC_Freceive_gpm_event.
* gpmevent.c (Fgpm_enable): Allocate dynamically.
* gpmevent.c (syms_of_gpmevent): Allocate dynamically.
* lisp.h (C_READONLY): Not needed anymore, remove.
* lisp.h (DEFUN): Allocate dynamically.
* lrecord.h (C_READONLY_RECORD_HEADER_P): Not needed anymore,
remove.
* lrecord.h (SET_C_READONLY_RECORD_HEADER): Not needed anymore,
remove.
* symbols.c (guts_of_unbound_marker):
* symeval.h (defsubr): Allocate dynamically.
* symeval.h (DEFSUBR_MACRO): Allocate dynamically.
* symeval.h (DEFVAR_ SYMVAL_FWD): Allocate dynamically.
* tests.c (TESTS_DEFSUBR): Allocate dynamically.
Definition of mcpro:
* lisp.h: Add mcpro prototypes.
* alloc.c (common_init_alloc_early): Add initialization for
mcpros.
* alloc.c (mcpro_description_1): New.
* alloc.c (mcpro_description): New.
* alloc.c (mcpros_description_1): New.
* alloc.c (mcpros_description): New.
* alloc.c (mcpro_one_name_description_1): New.
* alloc.c (mcpro_one_name_description): New.
* alloc.c (mcpro_names_description_1): New.
* alloc.c (mcpro_names_description): New.
* alloc.c (mcpros): New.
* alloc.c (mcpro_names): New.
* alloc.c (mcpro_1): New.
* alloc.c (mc_pro): New.
* alloc.c (garbage_collect_1): Add mcpros to root set.
Usage of mcpro:
* alloc.c (make_string_nocopy): Add string to root set.
* symbols.c (init_symbols_once_early): Add Qunbound to root set.
Changes to the Portable Dumper:
* alloc.c (FREE_OR_REALLOC_BEGIN): Since dumped objects can be
freed with the new allocator, remove assertion for !DUMPEDP.
* dumper.c: Adjust comments, increase PDUMP_HASHSIZE.
* dumper.c (pdump_make_hash): Shift address only 2 bytes, to
avoid collisions.
* dumper.c (pdump_objects_unmark): No more mark bits within
the object, remove.
* dumper.c (mc_addr_elt): New. Element data structure for mc
hash table.
* dumper.c (pdump_mc_hash): New hash table: `lookup table'.
* dumper.c (pdump_get_mc_addr): New. Lookup for hash table.
* dumper.c (pdump_get_indirect_mc_addr): New. Lookup for
convertibles.
* dumper.c (pdump_put_mc_addr): New. Putter for hash table.
* dumper.c (pdump_dump_mc_data): New. Writes the table for
relocation at load time to the dump file.
* dumper.c (pdump_scan_lisp_objects_by_alignment): New.
Visits all dumped Lisp objects.
* dumper.c (pdump_scan_non_lisp_objects_by_alignment): New.
Visits all other dumped objects.
* dumper.c (pdump_reloc_one_mc): New. Updates all pointers
of an object by using the hash table pdump_mc_hash.
* dumper.c (pdump_reloc_one): Replaced by pdump_reloc_one_mc.
* dumper.c (pdump): Change the structure of the dump file, add
the mc post dump relocation table to dump file.
* dumper.c (pdump_load_finish): Hand all dumped objects to the
new allocator and use the mc post dump relocation table for
relocating the dumped objects at dump file load time, free not
longer used data structures.
* dumper.c (pdump_load): Free the dump file.
* dumper.h: Remove pdump_objects_unmark.
* lrecord.h (DUMPEDP): Dumped objects can be freed, remove.
DUMP_IN_EXEC:
* Makefile.in.in: Linking for and with dump in executable only if
DUMP_IN_EXEC is defined.
* config.h.in: Add new flag `DUMP_IN_EXEC'
* emacs.c: Condition dump-data.h on DUMP_IN_EXEC.
* emacs.c (main_1): Flag `-si' only works if dump image is
written into executable.
Miscellanious
* lrecord.h (enum lrecord_type): Added numbers to all types,
very handy for debugging.
* xemacs.def.in.in: Add mc-alloc functions to make them visible
to the modules.
| author | crestani |
|---|---|
| date | Fri, 08 Apr 2005 23:11:35 +0000 |
| parents | ecf1ebac70d8 |
| children | 1e7cc382eb16 |
| rev | line source |
|---|---|
| 428 | 1 /* Generic GUI code. (menubars, scrollbars, toolbars, dialogs) |
| 2 Copyright (C) 1995 Board of Trustees, University of Illinois. | |
| 1318 | 3 Copyright (C) 1995, 1996, 2000, 2001, 2002, 2003 Ben Wing. |
| 428 | 4 Copyright (C) 1995 Sun Microsystems, Inc. |
| 5 Copyright (C) 1998 Free Software Foundation, Inc. | |
| 6 | |
| 7 This file is part of XEmacs. | |
| 8 | |
| 9 XEmacs is free software; you can redistribute it and/or modify it | |
| 10 under the terms of the GNU General Public License as published by the | |
| 11 Free Software Foundation; either version 2, or (at your option) any | |
| 12 later version. | |
| 13 | |
| 14 XEmacs is distributed in the hope that it will be useful, but WITHOUT | |
| 15 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
| 16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
| 17 for more details. | |
| 18 | |
| 19 You should have received a copy of the GNU General Public License | |
| 20 along with XEmacs; see the file COPYING. If not, write to | |
| 21 the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
| 22 Boston, MA 02111-1307, USA. */ | |
| 23 | |
| 24 /* Synched up with: Not in FSF. */ | |
| 25 | |
| 793 | 26 /* This file Mule-ized by Ben Wing, 3-24-02. */ |
| 442 | 27 |
| 428 | 28 #include <config.h> |
| 29 #include "lisp.h" | |
| 872 | 30 |
| 442 | 31 #include "buffer.h" |
| 428 | 32 #include "bytecode.h" |
| 872 | 33 #include "elhash.h" |
| 34 #include "gui.h" | |
| 35 #include "menubar.h" | |
| 1318 | 36 #include "redisplay.h" |
| 428 | 37 |
| 442 | 38 Lisp_Object Qmenu_no_selection_hook; |
| 39 Lisp_Object Vmenu_no_selection_hook; | |
| 428 | 40 |
| 41 static Lisp_Object parse_gui_item_tree_list (Lisp_Object list); | |
| 454 | 42 Lisp_Object find_keyword_in_vector (Lisp_Object vector, Lisp_Object keyword); |
| 428 | 43 |
| 563 | 44 Lisp_Object Qgui_error; |
| 45 | |
| 428 | 46 #ifdef HAVE_POPUPS |
| 47 | |
| 48 /* count of menus/dboxes currently up */ | |
| 49 int popup_up_p; | |
| 50 | |
| 51 DEFUN ("popup-up-p", Fpopup_up_p, 0, 0, 0, /* | |
| 52 Return t if a popup menu or dialog box is up, nil otherwise. | |
| 53 See `popup-menu' and `popup-dialog-box'. | |
| 54 */ | |
| 55 ()) | |
| 56 { | |
| 57 return popup_up_p ? Qt : Qnil; | |
| 58 } | |
| 59 #endif /* HAVE_POPUPS */ | |
| 60 | |
| 61 int | |
| 867 | 62 separator_string_p (const Ibyte *s) |
| 428 | 63 { |
| 867 | 64 const Ibyte *p; |
| 65 Ibyte first; | |
| 428 | 66 |
| 67 if (!s || s[0] == '\0') | |
| 68 return 0; | |
| 69 first = s[0]; | |
| 70 if (first != '-' && first != '=') | |
| 71 return 0; | |
| 72 for (p = s; *p == first; p++) | |
| 73 ; | |
| 74 | |
| 75 return (*p == '!' || *p == ':' || *p == '\0'); | |
| 76 } | |
| 77 | |
| 78 /* Massage DATA to find the correct function and argument. Used by | |
| 79 popup_selection_callback() and the msw code. */ | |
| 80 void | |
| 81 get_gui_callback (Lisp_Object data, Lisp_Object *fn, Lisp_Object *arg) | |
| 82 { | |
| 442 | 83 if (EQ (data, Qquit)) |
| 84 { | |
| 85 *fn = Qeval; | |
| 86 *arg = list3 (Qsignal, list2 (Qquote, Qquit), Qnil); | |
| 87 Vquit_flag = Qt; | |
| 88 } | |
| 89 else if (SYMBOLP (data) | |
| 90 || (COMPILED_FUNCTIONP (data) | |
| 91 && XCOMPILED_FUNCTION (data)->flags.interactivep) | |
| 92 || (CONSP (data) && (EQ (XCAR (data), Qlambda)) | |
| 93 && !NILP (Fassq (Qinteractive, Fcdr (Fcdr (data)))))) | |
| 428 | 94 { |
| 95 *fn = Qcall_interactively; | |
| 96 *arg = data; | |
| 97 } | |
| 98 else if (CONSP (data)) | |
| 99 { | |
| 100 *fn = Qeval; | |
| 101 *arg = data; | |
| 102 } | |
| 103 else | |
| 104 { | |
| 105 *fn = Qeval; | |
| 106 *arg = list3 (Qsignal, | |
| 107 list2 (Qquote, Qerror), | |
| 771 | 108 list2 (Qquote, list2 (build_msg_string |
| 428 | 109 ("illegal callback"), |
| 110 data))); | |
| 111 } | |
| 112 } | |
| 113 | |
| 114 /* | |
| 115 * Add a value VAL associated with keyword KEY into PGUI_ITEM | |
| 116 * structure. If KEY is not a keyword, or is an unknown keyword, then | |
| 117 * error is signaled. | |
| 118 */ | |
| 454 | 119 int |
| 428 | 120 gui_item_add_keyval_pair (Lisp_Object gui_item, |
| 440 | 121 Lisp_Object key, Lisp_Object val, |
| 578 | 122 Error_Behavior errb) |
| 428 | 123 { |
| 442 | 124 Lisp_Gui_Item *pgui_item = XGUI_ITEM (gui_item); |
| 454 | 125 int retval = 0; |
| 428 | 126 |
| 127 if (!KEYWORDP (key)) | |
| 563 | 128 sferror_2 ("Non-keyword in gui item", key, pgui_item->name); |
| 428 | 129 |
| 454 | 130 if (EQ (key, Q_descriptor)) |
| 131 { | |
| 132 if (!EQ (pgui_item->name, val)) | |
| 133 { | |
| 134 retval = 1; | |
| 135 pgui_item->name = val; | |
| 136 } | |
| 137 } | |
| 793 | 138 #define FROB(slot) \ |
| 454 | 139 else if (EQ (key, Q_##slot)) \ |
| 140 { \ | |
| 793 | 141 if (!EQ (pgui_item->slot, val)) \ |
| 454 | 142 { \ |
| 143 retval = 1; \ | |
| 793 | 144 pgui_item->slot = val; \ |
| 454 | 145 } \ |
| 146 } | |
| 147 FROB (suffix) | |
| 148 FROB (active) | |
| 149 FROB (included) | |
| 150 FROB (config) | |
| 151 FROB (filter) | |
| 152 FROB (style) | |
| 153 FROB (selected) | |
| 154 FROB (keys) | |
| 155 FROB (callback) | |
| 156 FROB (callback_ex) | |
| 157 FROB (value) | |
| 158 #undef FROB | |
| 440 | 159 else if (EQ (key, Q_key_sequence)) ; /* ignored for FSF compatibility */ |
| 428 | 160 else if (EQ (key, Q_label)) ; /* ignored for 21.0 implement in 21.2 */ |
| 161 else if (EQ (key, Q_accelerator)) | |
| 162 { | |
| 454 | 163 if (!EQ (pgui_item->accelerator, val)) |
| 164 { | |
| 165 retval = 1; | |
| 166 if (SYMBOLP (val) || CHARP (val)) | |
| 167 pgui_item->accelerator = val; | |
| 168 else if (ERRB_EQ (errb, ERROR_ME)) | |
| 563 | 169 invalid_argument ("Bad keyboard accelerator", val); |
| 454 | 170 } |
| 428 | 171 } |
| 172 else if (ERRB_EQ (errb, ERROR_ME)) | |
| 793 | 173 invalid_argument_2 ("Unknown keyword in gui item", key, pgui_item->name); |
| 454 | 174 return retval; |
| 428 | 175 } |
| 176 | |
| 177 void | |
| 178 gui_item_init (Lisp_Object gui_item) | |
| 179 { | |
| 440 | 180 Lisp_Gui_Item *lp = XGUI_ITEM (gui_item); |
| 428 | 181 |
| 182 lp->name = Qnil; | |
| 183 lp->callback = Qnil; | |
| 442 | 184 lp->callback_ex = Qnil; |
| 428 | 185 lp->suffix = Qnil; |
| 186 lp->active = Qt; | |
| 187 lp->included = Qt; | |
| 188 lp->config = Qnil; | |
| 189 lp->filter = Qnil; | |
| 190 lp->style = Qnil; | |
| 191 lp->selected = Qnil; | |
| 192 lp->keys = Qnil; | |
| 193 lp->accelerator = Qnil; | |
| 442 | 194 lp->value = Qnil; |
| 428 | 195 } |
| 196 | |
| 197 Lisp_Object | |
| 198 allocate_gui_item (void) | |
| 199 { | |
| 2720 | 200 #ifdef MC_ALLOC |
| 201 Lisp_Gui_Item *lp = alloc_lrecord_type (Lisp_Gui_Item, &lrecord_gui_item); | |
| 202 #else /* not MC_ALLOC */ | |
| 440 | 203 Lisp_Gui_Item *lp = alloc_lcrecord_type (Lisp_Gui_Item, &lrecord_gui_item); |
| 2720 | 204 #endif /* not MC_ALLOC */ |
| 428 | 205 Lisp_Object val; |
| 206 | |
| 793 | 207 val = wrap_gui_item (lp); |
| 428 | 208 |
| 209 gui_item_init (val); | |
| 210 | |
| 211 return val; | |
| 212 } | |
| 213 | |
| 214 /* | |
| 215 * ITEM is a lisp vector, describing a menu item or a button. The | |
| 216 * function extracts the description of the item into the PGUI_ITEM | |
| 217 * structure. | |
| 218 */ | |
| 219 static Lisp_Object | |
| 220 make_gui_item_from_keywords_internal (Lisp_Object item, | |
| 578 | 221 Error_Behavior errb) |
| 428 | 222 { |
| 223 int length, plist_p, start; | |
| 224 Lisp_Object *contents; | |
| 225 Lisp_Object gui_item = allocate_gui_item (); | |
| 442 | 226 Lisp_Gui_Item *pgui_item = XGUI_ITEM (gui_item); |
| 428 | 227 |
| 228 CHECK_VECTOR (item); | |
| 229 length = XVECTOR_LENGTH (item); | |
| 230 contents = XVECTOR_DATA (item); | |
| 231 | |
| 232 if (length < 1) | |
| 563 | 233 sferror ("GUI item descriptors must be at least 1 elts long", item); |
| 428 | 234 |
| 235 /* length 1: [ "name" ] | |
| 236 length 2: [ "name" callback ] | |
| 237 length 3: [ "name" callback active-p ] | |
| 238 or [ "name" keyword value ] | |
| 239 length 4: [ "name" callback active-p suffix ] | |
| 240 or [ "name" callback keyword value ] | |
| 241 length 5+: [ "name" callback [ keyword value ]+ ] | |
| 242 or [ "name" [ keyword value ]+ ] | |
| 243 */ | |
| 244 plist_p = (length > 2 && (KEYWORDP (contents [1]) | |
| 245 || KEYWORDP (contents [2]))); | |
| 246 | |
| 247 pgui_item->name = contents [0]; | |
| 248 if (length > 1 && !KEYWORDP (contents [1])) | |
| 249 { | |
| 250 pgui_item->callback = contents [1]; | |
| 251 start = 2; | |
| 252 } | |
| 440 | 253 else |
| 428 | 254 start =1; |
| 255 | |
| 256 if (!plist_p && length > 2) | |
| 257 /* the old way */ | |
| 258 { | |
| 259 pgui_item->active = contents [2]; | |
| 260 if (length == 4) | |
| 261 pgui_item->suffix = contents [3]; | |
| 262 } | |
| 263 else | |
| 264 /* the new way */ | |
| 265 { | |
| 266 int i; | |
| 267 if ((length - start) & 1) | |
| 563 | 268 sferror ( |
| 428 | 269 "GUI item descriptor has an odd number of keywords and values", |
| 793 | 270 item); |
| 428 | 271 |
| 272 for (i = start; i < length;) | |
| 273 { | |
| 274 Lisp_Object key = contents [i++]; | |
| 275 Lisp_Object val = contents [i++]; | |
| 276 gui_item_add_keyval_pair (gui_item, key, val, errb); | |
| 277 } | |
| 278 } | |
| 279 return gui_item; | |
| 280 } | |
| 281 | |
| 454 | 282 /* This will only work with descriptors in the new format. */ |
| 283 Lisp_Object | |
| 284 widget_gui_parse_item_keywords (Lisp_Object item) | |
| 285 { | |
| 286 int i, length; | |
| 287 Lisp_Object *contents; | |
| 288 Lisp_Object gui_item = allocate_gui_item (); | |
| 289 Lisp_Object desc = find_keyword_in_vector (item, Q_descriptor); | |
| 290 | |
| 291 CHECK_VECTOR (item); | |
| 292 length = XVECTOR_LENGTH (item); | |
| 293 contents = XVECTOR_DATA (item); | |
| 294 | |
| 295 if (!NILP (desc) && !STRINGP (desc) && !VECTORP (desc)) | |
| 563 | 296 sferror ("Invalid GUI item descriptor", item); |
| 454 | 297 |
| 298 if (length & 1) | |
| 299 { | |
| 300 if (!SYMBOLP (contents [0])) | |
| 563 | 301 sferror ("Invalid GUI item descriptor", item); |
| 454 | 302 contents++; /* Ignore the leading symbol. */ |
| 303 length--; | |
| 304 } | |
| 305 | |
| 306 for (i = 0; i < length;) | |
| 307 { | |
| 308 Lisp_Object key = contents [i++]; | |
| 309 Lisp_Object val = contents [i++]; | |
| 310 gui_item_add_keyval_pair (gui_item, key, val, ERROR_ME_NOT); | |
| 311 } | |
| 312 | |
| 313 return gui_item; | |
| 314 } | |
| 315 | |
| 316 /* Update a gui item from a partial descriptor. */ | |
| 317 int | |
| 318 update_gui_item_keywords (Lisp_Object gui_item, Lisp_Object item) | |
| 319 { | |
| 320 int i, length, retval = 0; | |
| 321 Lisp_Object *contents; | |
| 322 | |
| 323 CHECK_VECTOR (item); | |
| 324 length = XVECTOR_LENGTH (item); | |
| 325 contents = XVECTOR_DATA (item); | |
| 326 | |
| 327 if (length & 1) | |
| 328 { | |
| 329 if (!SYMBOLP (contents [0])) | |
| 563 | 330 sferror ("Invalid GUI item descriptor", item); |
| 454 | 331 contents++; /* Ignore the leading symbol. */ |
| 332 length--; | |
| 333 } | |
| 334 | |
| 335 for (i = 0; i < length;) | |
| 336 { | |
| 337 Lisp_Object key = contents [i++]; | |
| 338 Lisp_Object val = contents [i++]; | |
| 793 | 339 if (gui_item_add_keyval_pair (gui_item, key, val, ERROR_ME_DEBUG_WARN)) |
| 454 | 340 retval = 1; |
| 341 } | |
| 342 return retval; | |
| 343 } | |
| 344 | |
| 428 | 345 Lisp_Object |
| 346 gui_parse_item_keywords (Lisp_Object item) | |
| 347 { | |
| 348 return make_gui_item_from_keywords_internal (item, ERROR_ME); | |
| 349 } | |
| 350 | |
| 351 Lisp_Object | |
| 352 gui_parse_item_keywords_no_errors (Lisp_Object item) | |
| 353 { | |
| 793 | 354 return make_gui_item_from_keywords_internal (item, ERROR_ME_DEBUG_WARN); |
| 428 | 355 } |
| 356 | |
| 357 /* convert a gui item into plist properties */ | |
| 358 void | |
| 359 gui_add_item_keywords_to_plist (Lisp_Object plist, Lisp_Object gui_item) | |
| 360 { | |
| 442 | 361 Lisp_Gui_Item *pgui_item = XGUI_ITEM (gui_item); |
| 440 | 362 |
| 428 | 363 if (!NILP (pgui_item->callback)) |
| 364 Fplist_put (plist, Q_callback, pgui_item->callback); | |
| 442 | 365 if (!NILP (pgui_item->callback_ex)) |
| 366 Fplist_put (plist, Q_callback_ex, pgui_item->callback_ex); | |
| 428 | 367 if (!NILP (pgui_item->suffix)) |
| 368 Fplist_put (plist, Q_suffix, pgui_item->suffix); | |
| 369 if (!NILP (pgui_item->active)) | |
| 370 Fplist_put (plist, Q_active, pgui_item->active); | |
| 371 if (!NILP (pgui_item->included)) | |
| 372 Fplist_put (plist, Q_included, pgui_item->included); | |
| 373 if (!NILP (pgui_item->config)) | |
| 374 Fplist_put (plist, Q_config, pgui_item->config); | |
| 375 if (!NILP (pgui_item->filter)) | |
| 376 Fplist_put (plist, Q_filter, pgui_item->filter); | |
| 377 if (!NILP (pgui_item->style)) | |
| 378 Fplist_put (plist, Q_style, pgui_item->style); | |
| 379 if (!NILP (pgui_item->selected)) | |
| 380 Fplist_put (plist, Q_selected, pgui_item->selected); | |
| 381 if (!NILP (pgui_item->keys)) | |
| 382 Fplist_put (plist, Q_keys, pgui_item->keys); | |
| 383 if (!NILP (pgui_item->accelerator)) | |
| 384 Fplist_put (plist, Q_accelerator, pgui_item->accelerator); | |
| 442 | 385 if (!NILP (pgui_item->value)) |
| 386 Fplist_put (plist, Q_value, pgui_item->value); | |
| 428 | 387 } |
| 388 | |
| 1318 | 389 static int |
| 1913 | 390 gui_item_value (Lisp_Object form) |
| 1318 | 391 { |
| 392 /* This function can call Lisp. */ | |
| 393 | |
| 394 #ifndef ERROR_CHECK_DISPLAY | |
| 395 /* Shortcut to avoid evaluating Qt/Qnil each time; but don't do it when | |
| 396 error-checking so we catch unprotected eval within redisplay quicker */ | |
| 397 if (NILP (form)) | |
| 398 return 0; | |
| 399 if (EQ (form, Qt)) | |
| 400 return 1; | |
| 401 #endif | |
| 1913 | 402 return !NILP (in_display ? eval_within_redisplay (form) : Feval (form)); |
| 1318 | 403 } |
| 404 | |
| 428 | 405 /* |
| 406 * Decide whether a GUI item is active by evaluating its :active form | |
| 407 * if any | |
| 408 */ | |
| 409 int | |
| 1913 | 410 gui_item_active_p (Lisp_Object gui_item) |
| 428 | 411 { |
| 1913 | 412 return gui_item_value (XGUI_ITEM (gui_item)->active); |
| 428 | 413 } |
| 414 | |
| 415 /* set menu accelerator key to first underlined character in menu name */ | |
| 416 Lisp_Object | |
| 417 gui_item_accelerator (Lisp_Object gui_item) | |
| 418 { | |
| 442 | 419 Lisp_Gui_Item *pgui = XGUI_ITEM (gui_item); |
| 440 | 420 |
| 428 | 421 if (!NILP (pgui->accelerator)) |
| 422 return pgui->accelerator; | |
| 423 | |
| 424 else | |
| 442 | 425 return gui_name_accelerator (pgui->name); |
| 428 | 426 } |
| 427 | |
| 428 Lisp_Object | |
| 429 gui_name_accelerator (Lisp_Object nm) | |
| 430 { | |
| 867 | 431 Ibyte *name = XSTRING_DATA (nm); |
| 428 | 432 |
| 442 | 433 while (*name) |
| 434 { | |
| 435 if (*name == '%') | |
| 428 | 436 { |
| 442 | 437 ++name; |
| 438 if (!(*name)) | |
| 439 return Qnil; | |
| 440 if (*name == '_' && *(name + 1)) | |
| 441 { | |
| 867 | 442 Ichar accelerator = itext_ichar (name + 1); |
| 771 | 443 return make_char (DOWNCASE (0, accelerator)); |
| 442 | 444 } |
| 428 | 445 } |
| 867 | 446 INC_IBYTEPTR (name); |
| 428 | 447 } |
| 867 | 448 return make_char (DOWNCASE (0, itext_ichar (XSTRING_DATA (nm)))); |
| 428 | 449 } |
| 450 | |
| 451 /* | |
| 452 * Decide whether a GUI item is selected by evaluating its :selected form | |
| 453 * if any | |
| 454 */ | |
| 455 int | |
| 1913 | 456 gui_item_selected_p (Lisp_Object gui_item) |
| 428 | 457 { |
| 1913 | 458 return gui_item_value (XGUI_ITEM (gui_item)->selected); |
| 428 | 459 } |
| 460 | |
| 442 | 461 Lisp_Object |
| 462 gui_item_list_find_selected (Lisp_Object gui_item_list) | |
| 463 { | |
| 1318 | 464 /* This function can call Lisp but cannot GC because it is called within |
| 465 redisplay, and redisplay disables GC. */ | |
| 442 | 466 Lisp_Object rest; |
| 467 LIST_LOOP (rest, gui_item_list) | |
| 468 { | |
| 1913 | 469 if (gui_item_selected_p (XCAR (rest))) |
| 442 | 470 return XCAR (rest); |
| 471 } | |
| 472 return XCAR (gui_item_list); | |
| 473 } | |
| 474 | |
| 428 | 475 /* |
| 476 * Decide whether a GUI item is included by evaluating its :included | |
| 477 * form if given, and testing its :config form against supplied CONFLIST | |
| 478 * configuration variable | |
| 479 */ | |
| 480 int | |
| 481 gui_item_included_p (Lisp_Object gui_item, Lisp_Object conflist) | |
| 482 { | |
| 483 /* This function can call lisp */ | |
| 442 | 484 Lisp_Gui_Item *pgui_item = XGUI_ITEM (gui_item); |
| 428 | 485 |
| 486 /* Evaluate :included first. Shortcut to avoid evaluating Qt each time */ | |
| 1913 | 487 if (!gui_item_value (pgui_item->included)) |
| 428 | 488 return 0; |
| 489 | |
| 490 /* Do :config if conflist is given */ | |
| 491 if (!NILP (conflist) && !NILP (pgui_item->config) | |
| 492 && NILP (Fmemq (pgui_item->config, conflist))) | |
| 493 return 0; | |
| 494 | |
| 495 return 1; | |
| 496 } | |
| 497 | |
| 498 /* | |
| 771 | 499 * Format "left flush" display portion of an item. |
| 428 | 500 */ |
| 771 | 501 Lisp_Object |
| 502 gui_item_display_flush_left (Lisp_Object gui_item) | |
| 428 | 503 { |
| 504 /* This function can call lisp */ | |
| 442 | 505 Lisp_Gui_Item *pgui_item = XGUI_ITEM (gui_item); |
| 771 | 506 Lisp_Object retval; |
| 428 | 507 |
| 508 CHECK_STRING (pgui_item->name); | |
| 771 | 509 retval = pgui_item->name; |
| 428 | 510 |
| 511 if (!NILP (pgui_item->suffix)) | |
| 512 { | |
| 513 Lisp_Object suffix = pgui_item->suffix; | |
| 514 /* Shortcut to avoid evaluating suffix each time */ | |
| 515 if (!STRINGP (suffix)) | |
| 516 { | |
| 517 suffix = Feval (suffix); | |
| 518 CHECK_STRING (suffix); | |
| 519 } | |
| 520 | |
| 771 | 521 retval = concat3 (pgui_item->name, build_string (" "), suffix); |
| 428 | 522 } |
| 771 | 523 |
| 524 return retval; | |
| 428 | 525 } |
| 526 | |
| 527 /* | |
| 771 | 528 * Format "right flush" display portion of an item into BUF. |
| 428 | 529 */ |
| 771 | 530 Lisp_Object |
| 531 gui_item_display_flush_right (Lisp_Object gui_item) | |
| 428 | 532 { |
| 442 | 533 Lisp_Gui_Item *pgui_item = XGUI_ITEM (gui_item); |
| 428 | 534 |
| 535 #ifdef HAVE_MENUBARS | |
| 536 /* Have keys? */ | |
| 537 if (!menubar_show_keybindings) | |
| 771 | 538 return Qnil; |
| 428 | 539 #endif |
| 540 | |
| 541 /* Try :keys first */ | |
| 542 if (!NILP (pgui_item->keys)) | |
| 543 { | |
| 544 CHECK_STRING (pgui_item->keys); | |
| 771 | 545 return pgui_item->keys; |
| 428 | 546 } |
| 547 | |
| 548 /* See if we can derive keys out of callback symbol */ | |
| 549 if (SYMBOLP (pgui_item->callback)) | |
| 550 { | |
| 793 | 551 DECLARE_EISTRING_MALLOC (buf); |
| 552 Lisp_Object str; | |
| 553 | |
| 554 where_is_to_char (pgui_item->callback, buf); | |
| 555 str = eimake_string (buf); | |
| 556 eifree (buf); | |
| 557 return str; | |
| 428 | 558 } |
| 559 | |
| 560 /* No keys - no right flush display */ | |
| 771 | 561 return Qnil; |
| 428 | 562 } |
| 563 | |
| 1204 | 564 static const struct memory_description gui_item_description [] = { |
| 934 | 565 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, name) }, |
| 566 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, callback) }, | |
| 567 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, callback_ex) }, | |
| 568 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, suffix) }, | |
| 569 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, active) }, | |
| 570 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, included) }, | |
| 571 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, config) }, | |
| 572 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, filter) }, | |
| 573 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, style) }, | |
| 574 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, selected) }, | |
| 575 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, keys) }, | |
| 576 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, accelerator) }, | |
| 577 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, value) }, | |
| 578 { XD_END } | |
| 579 }; | |
| 580 | |
| 428 | 581 static Lisp_Object |
| 582 mark_gui_item (Lisp_Object obj) | |
| 583 { | |
| 440 | 584 Lisp_Gui_Item *p = XGUI_ITEM (obj); |
| 428 | 585 |
| 586 mark_object (p->name); | |
| 587 mark_object (p->callback); | |
| 442 | 588 mark_object (p->callback_ex); |
| 428 | 589 mark_object (p->config); |
| 590 mark_object (p->suffix); | |
| 591 mark_object (p->active); | |
| 592 mark_object (p->included); | |
| 593 mark_object (p->config); | |
| 594 mark_object (p->filter); | |
| 595 mark_object (p->style); | |
| 596 mark_object (p->selected); | |
| 597 mark_object (p->keys); | |
| 598 mark_object (p->accelerator); | |
| 442 | 599 mark_object (p->value); |
| 428 | 600 |
| 601 return Qnil; | |
| 602 } | |
| 603 | |
| 665 | 604 static Hashcode |
| 428 | 605 gui_item_hash (Lisp_Object obj, int depth) |
| 606 { | |
| 440 | 607 Lisp_Gui_Item *p = XGUI_ITEM (obj); |
| 428 | 608 |
| 442 | 609 return HASH2 (HASH6 (internal_hash (p->name, depth + 1), |
| 428 | 610 internal_hash (p->callback, depth + 1), |
| 442 | 611 internal_hash (p->callback_ex, depth + 1), |
| 428 | 612 internal_hash (p->suffix, depth + 1), |
| 613 internal_hash (p->active, depth + 1), | |
| 614 internal_hash (p->included, depth + 1)), | |
| 442 | 615 HASH6 (internal_hash (p->config, depth + 1), |
| 428 | 616 internal_hash (p->filter, depth + 1), |
| 617 internal_hash (p->style, depth + 1), | |
| 618 internal_hash (p->selected, depth + 1), | |
| 442 | 619 internal_hash (p->keys, depth + 1), |
| 620 internal_hash (p->value, depth + 1))); | |
| 428 | 621 } |
| 622 | |
| 623 int | |
| 624 gui_item_id_hash (Lisp_Object hashtable, Lisp_Object gitem, int slot) | |
| 625 { | |
| 626 int hashid = gui_item_hash (gitem, 0); | |
| 627 int id = GUI_ITEM_ID_BITS (hashid, slot); | |
| 853 | 628 while (!UNBOUNDP (Fgethash (make_int (id), hashtable, Qunbound))) |
| 428 | 629 { |
| 630 id = GUI_ITEM_ID_BITS (id + 1, slot); | |
| 631 } | |
| 632 return id; | |
| 633 } | |
| 634 | |
| 1318 | 635 static int |
| 1913 | 636 gui_value_equal (Lisp_Object a, Lisp_Object b, int depth) |
| 1318 | 637 { |
| 1913 | 638 if (in_display) |
| 1318 | 639 return internal_equal_trapping_problems |
| 640 (Qredisplay, "Error calling function within redisplay", 0, 0, | |
| 641 /* say they're not equal in case of error; code calling | |
| 642 gui_item_equal_sans_selected() in redisplay does extra stuff | |
| 643 only when equal */ | |
| 644 0, a, b, depth); | |
| 645 else | |
| 646 return internal_equal (a, b, depth); | |
| 647 } | |
| 648 | |
| 442 | 649 int |
| 1913 | 650 gui_item_equal_sans_selected (Lisp_Object obj1, Lisp_Object obj2, int depth) |
| 428 | 651 { |
| 440 | 652 Lisp_Gui_Item *p1 = XGUI_ITEM (obj1); |
| 653 Lisp_Gui_Item *p2 = XGUI_ITEM (obj2); | |
| 428 | 654 |
| 1913 | 655 if (!(gui_value_equal (p1->name, p2->name, depth + 1) |
| 428 | 656 && |
| 1913 | 657 gui_value_equal (p1->callback, p2->callback, depth + 1) |
| 428 | 658 && |
| 1913 | 659 gui_value_equal (p1->callback_ex, p2->callback_ex, depth + 1) |
| 442 | 660 && |
| 428 | 661 EQ (p1->suffix, p2->suffix) |
| 662 && | |
| 663 EQ (p1->active, p2->active) | |
| 664 && | |
| 665 EQ (p1->included, p2->included) | |
| 666 && | |
| 667 EQ (p1->config, p2->config) | |
| 668 && | |
| 669 EQ (p1->filter, p2->filter) | |
| 670 && | |
| 671 EQ (p1->style, p2->style) | |
| 672 && | |
| 673 EQ (p1->accelerator, p2->accelerator) | |
| 674 && | |
| 442 | 675 EQ (p1->keys, p2->keys) |
| 676 && | |
| 677 EQ (p1->value, p2->value))) | |
| 678 return 0; | |
| 679 return 1; | |
| 680 } | |
| 681 | |
| 682 static int | |
| 683 gui_item_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) | |
| 684 { | |
| 685 Lisp_Gui_Item *p1 = XGUI_ITEM (obj1); | |
| 686 Lisp_Gui_Item *p2 = XGUI_ITEM (obj2); | |
| 687 | |
| 1913 | 688 if (!(gui_item_equal_sans_selected (obj1, obj2, depth) && |
| 442 | 689 EQ (p1->selected, p2->selected))) |
| 428 | 690 return 0; |
| 691 return 1; | |
| 692 } | |
| 693 | |
| 694 static void | |
| 2286 | 695 print_gui_item (Lisp_Object obj, Lisp_Object printcharfun, |
| 696 int UNUSED (escapeflag)) | |
| 428 | 697 { |
| 440 | 698 Lisp_Gui_Item *g = XGUI_ITEM (obj); |
| 428 | 699 |
| 700 if (print_readably) | |
| 563 | 701 printing_unreadable_object ("#<gui-item 0x%x>", g->header.uid); |
| 428 | 702 |
| 793 | 703 write_fmt_string (printcharfun, "#<gui-item 0x%x>", g->header.uid); |
| 428 | 704 } |
| 705 | |
| 454 | 706 Lisp_Object |
| 442 | 707 copy_gui_item (Lisp_Object gui_item) |
| 708 { | |
| 709 Lisp_Object ret = allocate_gui_item (); | |
| 710 Lisp_Gui_Item *lp, *g = XGUI_ITEM (gui_item); | |
| 711 | |
| 712 lp = XGUI_ITEM (ret); | |
| 713 lp->name = g->name; | |
| 714 lp->callback = g->callback; | |
| 715 lp->callback_ex = g->callback_ex; | |
| 716 lp->suffix = g->suffix; | |
| 717 lp->active = g->active; | |
| 718 lp->included = g->included; | |
| 719 lp->config = g->config; | |
| 720 lp->filter = g->filter; | |
| 721 lp->style = g->style; | |
| 722 lp->selected = g->selected; | |
| 723 lp->keys = g->keys; | |
| 724 lp->accelerator = g->accelerator; | |
| 725 lp->value = g->value; | |
| 726 | |
| 727 return ret; | |
| 728 } | |
| 729 | |
| 730 Lisp_Object | |
| 731 copy_gui_item_tree (Lisp_Object arg) | |
| 732 { | |
| 733 if (CONSP (arg)) | |
| 734 { | |
| 735 Lisp_Object rest = arg = Fcopy_sequence (arg); | |
| 736 while (CONSP (rest)) | |
| 737 { | |
| 738 XCAR (rest) = copy_gui_item_tree (XCAR (rest)); | |
| 739 rest = XCDR (rest); | |
| 740 } | |
| 741 return arg; | |
| 742 } | |
| 743 else if (GUI_ITEMP (arg)) | |
| 744 return copy_gui_item (arg); | |
| 745 else | |
| 746 return arg; | |
| 747 } | |
| 748 | |
| 428 | 749 /* parse a glyph descriptor into a tree of gui items. |
| 750 | |
| 751 The gui_item slot of an image instance can be a single item or an | |
| 752 arbitrarily nested hierarchy of item lists. */ | |
| 753 | |
| 442 | 754 static Lisp_Object |
| 755 parse_gui_item_tree_item (Lisp_Object entry) | |
| 428 | 756 { |
| 757 Lisp_Object ret = entry; | |
| 442 | 758 struct gcpro gcpro1; |
| 759 | |
| 760 GCPRO1 (ret); | |
| 761 | |
| 428 | 762 if (VECTORP (entry)) |
| 763 { | |
| 442 | 764 ret = gui_parse_item_keywords_no_errors (entry); |
| 428 | 765 } |
| 766 else if (STRINGP (entry)) | |
| 767 { | |
| 768 CHECK_STRING (entry); | |
| 769 } | |
| 770 else | |
| 563 | 771 sferror ("item must be a vector or a string", entry); |
| 428 | 772 |
| 442 | 773 RETURN_UNGCPRO (ret); |
| 428 | 774 } |
| 775 | |
| 442 | 776 Lisp_Object |
| 777 parse_gui_item_tree_children (Lisp_Object list) | |
| 428 | 778 { |
| 442 | 779 Lisp_Object rest, ret = Qnil, sub = Qnil; |
| 780 struct gcpro gcpro1, gcpro2; | |
| 781 | |
| 782 GCPRO2 (ret, sub); | |
| 428 | 783 CHECK_CONS (list); |
| 784 /* recursively add items to the tree view */ | |
| 785 LIST_LOOP (rest, list) | |
| 786 { | |
| 787 if (CONSP (XCAR (rest))) | |
| 788 sub = parse_gui_item_tree_list (XCAR (rest)); | |
| 789 else | |
| 790 sub = parse_gui_item_tree_item (XCAR (rest)); | |
| 440 | 791 |
| 428 | 792 ret = Fcons (sub, ret); |
| 793 } | |
| 794 /* make the order the same as the items we have parsed */ | |
| 442 | 795 RETURN_UNGCPRO (Fnreverse (ret)); |
| 428 | 796 } |
| 797 | |
| 442 | 798 static Lisp_Object |
| 799 parse_gui_item_tree_list (Lisp_Object list) | |
| 428 | 800 { |
| 801 Lisp_Object ret; | |
| 442 | 802 struct gcpro gcpro1; |
| 428 | 803 CHECK_CONS (list); |
| 804 /* first one can never be a list */ | |
| 805 ret = parse_gui_item_tree_item (XCAR (list)); | |
| 442 | 806 GCPRO1 (ret); |
| 807 ret = Fcons (ret, parse_gui_item_tree_children (XCDR (list))); | |
| 808 RETURN_UNGCPRO (ret); | |
| 809 } | |
| 810 | |
| 811 static void | |
| 2286 | 812 finalize_gui_item (void *UNUSED (header), int UNUSED (for_disksave)) |
| 442 | 813 { |
| 428 | 814 } |
| 815 | |
| 934 | 816 DEFINE_LRECORD_IMPLEMENTATION ("gui-item", gui_item, |
| 817 0, /*dumpable-flag*/ | |
| 818 mark_gui_item, print_gui_item, | |
| 819 finalize_gui_item, gui_item_equal, | |
| 820 gui_item_hash, | |
| 821 gui_item_description, | |
| 822 Lisp_Gui_Item); | |
| 563 | 823 |
| 824 DOESNT_RETURN | |
| 2367 | 825 gui_error (const Ascbyte *reason, Lisp_Object frob) |
| 563 | 826 { |
| 827 signal_error (Qgui_error, reason, frob); | |
| 828 } | |
| 829 | |
| 569 | 830 DOESNT_RETURN |
| 2367 | 831 gui_error_2 (const Ascbyte *reason, Lisp_Object frob0, Lisp_Object frob1) |
| 569 | 832 { |
| 833 signal_error_2 (Qgui_error, reason, frob0, frob1); | |
| 834 } | |
| 835 | |
| 428 | 836 void |
| 837 syms_of_gui (void) | |
| 838 { | |
| 442 | 839 INIT_LRECORD_IMPLEMENTATION (gui_item); |
| 428 | 840 |
| 442 | 841 DEFSYMBOL (Qmenu_no_selection_hook); |
| 428 | 842 |
| 563 | 843 DEFERROR_STANDARD (Qgui_error, Qio_error); |
| 844 | |
| 428 | 845 #ifdef HAVE_POPUPS |
| 846 DEFSUBR (Fpopup_up_p); | |
| 847 #endif | |
| 848 } | |
| 849 | |
| 850 void | |
| 851 vars_of_gui (void) | |
| 852 { | |
| 442 | 853 DEFVAR_LISP ("menu-no-selection-hook", &Vmenu_no_selection_hook /* |
| 854 Function or functions to call when a menu or dialog box is dismissed | |
| 855 without a selection having been made. | |
| 856 */ ); | |
| 857 Vmenu_no_selection_hook = Qnil; | |
| 428 | 858 } |