Mercurial > hg > xemacs-beta
annotate src/gui.c @ 5127:a9c41067dd88 ben-lisp-object
more cleanups, terminology clarification, lots of doc work
-------------------- ChangeLog entries follow: --------------------
man/ChangeLog addition:
2010-03-05 Ben Wing <ben@xemacs.org>
* internals/internals.texi (Introduction to Allocation):
* internals/internals.texi (Integers and Characters):
* internals/internals.texi (Allocation from Frob Blocks):
* internals/internals.texi (lrecords):
* internals/internals.texi (Low-level allocation):
Rewrite section on allocation of Lisp objects to reflect the new
reality. Remove references to nonexistent XSETINT and XSETCHAR.
modules/ChangeLog addition:
2010-03-05 Ben Wing <ben@xemacs.org>
* postgresql/postgresql.c (allocate_pgconn):
* postgresql/postgresql.c (allocate_pgresult):
* postgresql/postgresql.h (struct Lisp_PGconn):
* postgresql/postgresql.h (struct Lisp_PGresult):
* ldap/eldap.c (allocate_ldap):
* ldap/eldap.h (struct Lisp_LDAP):
Same changes as in src/ dir. See large log there in ChangeLog,
but basically:
ALLOC_LISP_OBJECT -> ALLOC_NORMAL_LISP_OBJECT
LISP_OBJECT_HEADER -> NORMAL_LISP_OBJECT_HEADER
../hlo/src/ChangeLog addition:
2010-03-05 Ben Wing <ben@xemacs.org>
* alloc.c:
* alloc.c (old_alloc_sized_lcrecord):
* alloc.c (very_old_free_lcrecord):
* alloc.c (copy_lisp_object):
* alloc.c (zero_sized_lisp_object):
* alloc.c (zero_nonsized_lisp_object):
* alloc.c (lisp_object_storage_size):
* alloc.c (free_normal_lisp_object):
* alloc.c (FREE_FIXED_TYPE_WHEN_NOT_IN_GC):
* alloc.c (ALLOC_FROB_BLOCK_LISP_OBJECT):
* alloc.c (Fcons):
* alloc.c (noseeum_cons):
* alloc.c (make_float):
* alloc.c (make_bignum):
* alloc.c (make_bignum_bg):
* alloc.c (make_ratio):
* alloc.c (make_ratio_bg):
* alloc.c (make_ratio_rt):
* alloc.c (make_bigfloat):
* alloc.c (make_bigfloat_bf):
* alloc.c (size_vector):
* alloc.c (make_compiled_function):
* alloc.c (Fmake_symbol):
* alloc.c (allocate_extent):
* alloc.c (allocate_event):
* alloc.c (make_key_data):
* alloc.c (make_button_data):
* alloc.c (make_motion_data):
* alloc.c (make_process_data):
* alloc.c (make_timeout_data):
* alloc.c (make_magic_data):
* alloc.c (make_magic_eval_data):
* alloc.c (make_eval_data):
* alloc.c (make_misc_user_data):
* alloc.c (Fmake_marker):
* alloc.c (noseeum_make_marker):
* alloc.c (size_string_direct_data):
* alloc.c (make_uninit_string):
* alloc.c (make_string_nocopy):
* alloc.c (mark_lcrecord_list):
* alloc.c (alloc_managed_lcrecord):
* alloc.c (free_managed_lcrecord):
* alloc.c (sweep_lcrecords_1):
* alloc.c (malloced_storage_size):
* buffer.c (allocate_buffer):
* buffer.c (compute_buffer_usage):
* buffer.c (DEFVAR_BUFFER_LOCAL_1):
* buffer.c (nuke_all_buffer_slots):
* buffer.c (common_init_complex_vars_of_buffer):
* buffer.h (struct buffer_text):
* buffer.h (struct buffer):
* bytecode.c:
* bytecode.c (make_compiled_function_args):
* bytecode.c (size_compiled_function_args):
* bytecode.h (struct compiled_function_args):
* casetab.c (allocate_case_table):
* casetab.h (struct Lisp_Case_Table):
* charset.h (struct Lisp_Charset):
* chartab.c (fill_char_table):
* chartab.c (Fmake_char_table):
* chartab.c (make_char_table_entry):
* chartab.c (copy_char_table_entry):
* chartab.c (Fcopy_char_table):
* chartab.c (put_char_table):
* chartab.h (struct Lisp_Char_Table_Entry):
* chartab.h (struct Lisp_Char_Table):
* console-gtk-impl.h (struct gtk_device):
* console-gtk-impl.h (struct gtk_frame):
* console-impl.h (struct console):
* console-msw-impl.h (struct Lisp_Devmode):
* console-msw-impl.h (struct mswindows_device):
* console-msw-impl.h (struct msprinter_device):
* console-msw-impl.h (struct mswindows_frame):
* console-msw-impl.h (struct mswindows_dialog_id):
* console-stream-impl.h (struct stream_console):
* console-stream.c (stream_init_console):
* console-tty-impl.h (struct tty_console):
* console-tty-impl.h (struct tty_device):
* console-tty.c (allocate_tty_console_struct):
* console-x-impl.h (struct x_device):
* console-x-impl.h (struct x_frame):
* console.c (allocate_console):
* console.c (nuke_all_console_slots):
* console.c (DEFVAR_CONSOLE_LOCAL_1):
* console.c (common_init_complex_vars_of_console):
* data.c (make_weak_list):
* data.c (make_weak_box):
* data.c (make_ephemeron):
* database.c:
* database.c (struct Lisp_Database):
* database.c (allocate_database):
* database.c (finalize_database):
* device-gtk.c (allocate_gtk_device_struct):
* device-impl.h (struct device):
* device-msw.c:
* device-msw.c (mswindows_init_device):
* device-msw.c (msprinter_init_device):
* device-msw.c (finalize_devmode):
* device-msw.c (allocate_devmode):
* device-tty.c (allocate_tty_device_struct):
* device-x.c (allocate_x_device_struct):
* device.c:
* device.c (nuke_all_device_slots):
* device.c (allocate_device):
* dialog-msw.c (handle_question_dialog_box):
* elhash.c:
* elhash.c (struct Lisp_Hash_Table):
* elhash.c (finalize_hash_table):
* elhash.c (make_general_lisp_hash_table):
* elhash.c (Fcopy_hash_table):
* elhash.h (htentry):
* emacs.c (main_1):
* eval.c:
* eval.c (size_multiple_value):
* event-stream.c (finalize_command_builder):
* event-stream.c (allocate_command_builder):
* event-stream.c (free_command_builder):
* event-stream.c (event_stream_generate_wakeup):
* event-stream.c (event_stream_resignal_wakeup):
* event-stream.c (event_stream_disable_wakeup):
* event-stream.c (event_stream_wakeup_pending_p):
* events.h (struct Lisp_Timeout):
* events.h (struct command_builder):
* extents-impl.h:
* extents-impl.h (struct extent_auxiliary):
* extents-impl.h (struct extent_info):
* extents-impl.h (set_extent_no_chase_aux_field):
* extents-impl.h (set_extent_no_chase_normal_field):
* extents.c:
* extents.c (gap_array_marker):
* extents.c (gap_array):
* extents.c (extent_list_marker):
* extents.c (extent_list):
* extents.c (stack_of_extents):
* extents.c (gap_array_make_marker):
* extents.c (extent_list_make_marker):
* extents.c (allocate_extent_list):
* extents.c (SLOT):
* extents.c (mark_extent_auxiliary):
* extents.c (allocate_extent_auxiliary):
* extents.c (attach_extent_auxiliary):
* extents.c (size_gap_array):
* extents.c (finalize_extent_info):
* extents.c (allocate_extent_info):
* extents.c (uninit_buffer_extents):
* extents.c (allocate_soe):
* extents.c (copy_extent):
* extents.c (vars_of_extents):
* extents.h:
* faces.c (allocate_face):
* faces.h (struct Lisp_Face):
* faces.h (struct face_cachel):
* file-coding.c:
* file-coding.c (finalize_coding_system):
* file-coding.c (sizeof_coding_system):
* file-coding.c (Fcopy_coding_system):
* file-coding.h (struct Lisp_Coding_System):
* file-coding.h (MARKED_SLOT):
* fns.c (size_bit_vector):
* font-mgr.c:
* font-mgr.c (finalize_fc_pattern):
* font-mgr.c (print_fc_pattern):
* font-mgr.c (Ffc_pattern_p):
* font-mgr.c (Ffc_pattern_create):
* font-mgr.c (Ffc_name_parse):
* font-mgr.c (Ffc_name_unparse):
* font-mgr.c (Ffc_pattern_duplicate):
* font-mgr.c (Ffc_pattern_add):
* font-mgr.c (Ffc_pattern_del):
* font-mgr.c (Ffc_pattern_get):
* font-mgr.c (fc_config_create_using):
* font-mgr.c (fc_strlist_to_lisp_using):
* font-mgr.c (fontset_to_list):
* font-mgr.c (Ffc_config_p):
* font-mgr.c (Ffc_config_up_to_date):
* font-mgr.c (Ffc_config_build_fonts):
* font-mgr.c (Ffc_config_get_cache):
* font-mgr.c (Ffc_config_get_fonts):
* font-mgr.c (Ffc_config_set_current):
* font-mgr.c (Ffc_config_get_blanks):
* font-mgr.c (Ffc_config_get_rescan_interval):
* font-mgr.c (Ffc_config_set_rescan_interval):
* font-mgr.c (Ffc_config_app_font_add_file):
* font-mgr.c (Ffc_config_app_font_add_dir):
* font-mgr.c (Ffc_config_app_font_clear):
* font-mgr.c (size):
* font-mgr.c (Ffc_config_substitute):
* font-mgr.c (Ffc_font_render_prepare):
* font-mgr.c (Ffc_font_match):
* font-mgr.c (Ffc_font_sort):
* font-mgr.c (finalize_fc_config):
* font-mgr.c (print_fc_config):
* font-mgr.h:
* font-mgr.h (struct fc_pattern):
* font-mgr.h (XFC_PATTERN):
* font-mgr.h (struct fc_config):
* font-mgr.h (XFC_CONFIG):
* frame-gtk.c (allocate_gtk_frame_struct):
* frame-impl.h (struct frame):
* frame-msw.c (mswindows_init_frame_1):
* frame-x.c (allocate_x_frame_struct):
* frame.c (nuke_all_frame_slots):
* frame.c (allocate_frame_core):
* gc.c:
* gc.c (GC_CHECK_NOT_FREE):
* glyphs.c (finalize_image_instance):
* glyphs.c (allocate_image_instance):
* glyphs.c (Fcolorize_image_instance):
* glyphs.c (allocate_glyph):
* glyphs.c (unmap_subwindow_instance_cache_mapper):
* glyphs.c (register_ignored_expose):
* glyphs.h (struct Lisp_Image_Instance):
* glyphs.h (struct Lisp_Glyph):
* glyphs.h (struct glyph_cachel):
* glyphs.h (struct expose_ignore):
* gui.c (allocate_gui_item):
* gui.h (struct Lisp_Gui_Item):
* keymap.c (struct Lisp_Keymap):
* keymap.c (make_keymap):
* lisp.h:
* lisp.h (struct Lisp_String_Direct_Data):
* lisp.h (struct Lisp_String_Indirect_Data):
* lisp.h (struct Lisp_Vector):
* lisp.h (struct Lisp_Bit_Vector):
* lisp.h (DECLARE_INLINE_LISP_BIT_VECTOR):
* lisp.h (struct weak_box):
* lisp.h (struct ephemeron):
* lisp.h (struct weak_list):
* lrecord.h:
* lrecord.h (struct lrecord_implementation):
* lrecord.h (MC_ALLOC_CALL_FINALIZER):
* lrecord.h (struct lcrecord_list):
* lstream.c (finalize_lstream):
* lstream.c (sizeof_lstream):
* lstream.c (Lstream_new):
* lstream.c (Lstream_delete):
* lstream.h (struct lstream):
* marker.c:
* marker.c (finalize_marker):
* marker.c (compute_buffer_marker_usage):
* mule-charset.c:
* mule-charset.c (make_charset):
* mule-charset.c (compute_charset_usage):
* objects-impl.h (struct Lisp_Color_Instance):
* objects-impl.h (struct Lisp_Font_Instance):
* objects-tty-impl.h (struct tty_color_instance_data):
* objects-tty-impl.h (struct tty_font_instance_data):
* objects-tty.c (tty_initialize_color_instance):
* objects-tty.c (tty_initialize_font_instance):
* objects.c (finalize_color_instance):
* objects.c (Fmake_color_instance):
* objects.c (finalize_font_instance):
* objects.c (Fmake_font_instance):
* objects.c (reinit_vars_of_objects):
* opaque.c:
* opaque.c (sizeof_opaque):
* opaque.c (make_opaque_ptr):
* opaque.c (free_opaque_ptr):
* opaque.h:
* opaque.h (Lisp_Opaque):
* opaque.h (Lisp_Opaque_Ptr):
* print.c (printing_unreadable_lcrecord):
* print.c (external_object_printer):
* print.c (debug_p4):
* process.c (finalize_process):
* process.c (make_process_internal):
* procimpl.h (struct Lisp_Process):
* rangetab.c (Fmake_range_table):
* rangetab.c (Fcopy_range_table):
* rangetab.h (struct Lisp_Range_Table):
* scrollbar.c:
* scrollbar.c (create_scrollbar_instance):
* scrollbar.c (compute_scrollbar_instance_usage):
* scrollbar.h (struct scrollbar_instance):
* specifier.c (finalize_specifier):
* specifier.c (sizeof_specifier):
* specifier.c (set_specifier_caching):
* specifier.h (struct Lisp_Specifier):
* specifier.h (struct specifier_caching):
* symeval.h:
* symeval.h (SYMBOL_VALUE_MAGIC_P):
* symeval.h (DEFVAR_SYMVAL_FWD):
* symsinit.h:
* syntax.c (init_buffer_syntax_cache):
* syntax.h (struct syntax_cache):
* toolbar.c:
* toolbar.c (allocate_toolbar_button):
* toolbar.c (update_toolbar_button):
* toolbar.h (struct toolbar_button):
* tooltalk.c (struct Lisp_Tooltalk_Message):
* tooltalk.c (make_tooltalk_message):
* tooltalk.c (struct Lisp_Tooltalk_Pattern):
* tooltalk.c (make_tooltalk_pattern):
* ui-gtk.c:
* ui-gtk.c (allocate_ffi_data):
* ui-gtk.c (emacs_gtk_object_finalizer):
* ui-gtk.c (allocate_emacs_gtk_object_data):
* ui-gtk.c (allocate_emacs_gtk_boxed_data):
* ui-gtk.h:
* window-impl.h (struct window):
* window-impl.h (struct window_mirror):
* window.c (finalize_window):
* window.c (allocate_window):
* window.c (new_window_mirror):
* window.c (mark_window_as_deleted):
* window.c (make_dummy_parent):
* window.c (compute_window_mirror_usage):
* window.c (compute_window_usage):
Overall point of this change and previous ones in this repository:
(1) Introduce new, clearer terminology: everything other than int
or char is a "record" object, which comes in two types: "normal
objects" and "frob-block objects". Fix up all places that
referred to frob-block objects as "simple", "basic", etc.
(2) Provide an advertised interface for doing operations on Lisp
objects, including creating new types, that is clean and
consistent in its naming, uses the above-referenced terms and
avoids referencing "lrecords", "old lcrecords", etc., which should
hide under the surface.
(3) Make the size_in_bytes and finalizer methods take a
Lisp_Object rather than a void * for consistency with other methods.
(4) Separate finalizer method into finalizer and disksaver, so
that normal finalize methods don't have to worry about disksaving.
Other specifics:
(1) Renaming:
LISP_OBJECT_HEADER -> NORMAL_LISP_OBJECT_HEADER
ALLOC_LISP_OBJECT -> ALLOC_NORMAL_LISP_OBJECT
implementation->basic_p -> implementation->frob_block_p
ALLOCATE_FIXED_TYPE_AND_SET_IMPL -> ALLOC_FROB_BLOCK_LISP_OBJECT
*FCCONFIG*, wrap_fcconfig -> *FC_CONFIG*, wrap_fc_config
*FCPATTERN*, wrap_fcpattern -> *FC_PATTERN*, wrap_fc_pattern
(the last two changes make the naming of these macros consistent
with the naming of all other macros, since the objects are named
fc-config and fc-pattern with a hyphen)
(2) Lots of documentation fixes in lrecord.h.
(3) Eliminate macros for copying, freeing, zeroing objects, getting
their storage size. Instead, new functions:
zero_sized_lisp_object()
zero_nonsized_lisp_object()
lisp_object_storage_size()
free_normal_lisp_object()
(copy_lisp_object() already exists)
LISP_OBJECT_FROB_BLOCK_P() (actually a macro)
Eliminated:
free_lrecord()
zero_lrecord()
copy_lrecord()
copy_sized_lrecord()
old_copy_lcrecord()
old_copy_sized_lcrecord()
old_zero_lcrecord()
old_zero_sized_lcrecord()
LISP_OBJECT_STORAGE_SIZE()
COPY_SIZED_LISP_OBJECT()
COPY_SIZED_LCRECORD()
COPY_LISP_OBJECT()
ZERO_LISP_OBJECT()
FREE_LISP_OBJECT()
(4) Catch the remaining places where lrecord stuff was used directly
and use the advertised interface, e.g. alloc_sized_lrecord() ->
ALLOC_SIZED_LISP_OBJECT().
(5) Make certain statically-declared pseudo-objects
(buffer_local_flags, console_local_flags) have their lheader
initialized correctly, so things like copy_lisp_object() can work
on them. Make extent_auxiliary_defaults a proper heap object
Vextent_auxiliary_defaults, and make extent auxiliaries dumpable
so that this object can be dumped. allocate_extent_auxiliary()
now just creates the object, and attach_extent_auxiliary()
creates an extent auxiliary and attaches to an extent, like the
old allocate_extent_auxiliary().
(6) Create EXTENT_AUXILIARY_SLOTS macro, similar to the foo-slots.h
files but in a macro instead of a file. The purpose is to avoid
duplication when iterating over all the slots in an extent auxiliary.
Use it.
(7) In lstream.c, don't zero out object after allocation because
allocation routines take care of this.
(8) In marker.c, fix a mistake in computing marker overhead.
(9) In print.c, clean up printing_unreadable_lcrecord(),
external_object_printer() to avoid lots of ifdef NEW_GC's.
(10) Separate toolbar-button allocation into a separate
allocate_toolbar_button() function for use in the example code
in lrecord.h.
| author | Ben Wing <ben@xemacs.org> |
|---|---|
| date | Fri, 05 Mar 2010 04:08:17 -0600 |
| parents | b5df3737028a |
| children | f965e31a35f0 |
| 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 { | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
200 Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (gui_item); |
| 428 | 201 |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
202 gui_item_init (obj); |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
203 return obj; |
| 428 | 204 } |
| 205 | |
| 206 /* | |
| 207 * ITEM is a lisp vector, describing a menu item or a button. The | |
| 208 * function extracts the description of the item into the PGUI_ITEM | |
| 209 * structure. | |
| 210 */ | |
| 211 static Lisp_Object | |
| 212 make_gui_item_from_keywords_internal (Lisp_Object item, | |
| 578 | 213 Error_Behavior errb) |
| 428 | 214 { |
| 215 int length, plist_p, start; | |
| 216 Lisp_Object *contents; | |
| 217 Lisp_Object gui_item = allocate_gui_item (); | |
| 442 | 218 Lisp_Gui_Item *pgui_item = XGUI_ITEM (gui_item); |
| 428 | 219 |
| 220 CHECK_VECTOR (item); | |
| 221 length = XVECTOR_LENGTH (item); | |
| 222 contents = XVECTOR_DATA (item); | |
| 223 | |
| 224 if (length < 1) | |
| 563 | 225 sferror ("GUI item descriptors must be at least 1 elts long", item); |
| 428 | 226 |
| 227 /* length 1: [ "name" ] | |
| 228 length 2: [ "name" callback ] | |
| 229 length 3: [ "name" callback active-p ] | |
| 230 or [ "name" keyword value ] | |
| 231 length 4: [ "name" callback active-p suffix ] | |
| 232 or [ "name" callback keyword value ] | |
| 233 length 5+: [ "name" callback [ keyword value ]+ ] | |
| 234 or [ "name" [ keyword value ]+ ] | |
| 235 */ | |
| 236 plist_p = (length > 2 && (KEYWORDP (contents [1]) | |
| 237 || KEYWORDP (contents [2]))); | |
| 238 | |
| 239 pgui_item->name = contents [0]; | |
| 240 if (length > 1 && !KEYWORDP (contents [1])) | |
| 241 { | |
| 242 pgui_item->callback = contents [1]; | |
| 243 start = 2; | |
| 244 } | |
| 440 | 245 else |
| 428 | 246 start =1; |
| 247 | |
| 248 if (!plist_p && length > 2) | |
| 249 /* the old way */ | |
| 250 { | |
| 251 pgui_item->active = contents [2]; | |
| 252 if (length == 4) | |
| 253 pgui_item->suffix = contents [3]; | |
| 254 } | |
| 255 else | |
| 256 /* the new way */ | |
| 257 { | |
| 258 int i; | |
| 259 if ((length - start) & 1) | |
| 563 | 260 sferror ( |
| 428 | 261 "GUI item descriptor has an odd number of keywords and values", |
| 793 | 262 item); |
| 428 | 263 |
| 264 for (i = start; i < length;) | |
| 265 { | |
| 266 Lisp_Object key = contents [i++]; | |
| 267 Lisp_Object val = contents [i++]; | |
| 268 gui_item_add_keyval_pair (gui_item, key, val, errb); | |
| 269 } | |
| 270 } | |
| 271 return gui_item; | |
| 272 } | |
| 273 | |
| 454 | 274 /* This will only work with descriptors in the new format. */ |
| 275 Lisp_Object | |
| 276 widget_gui_parse_item_keywords (Lisp_Object item) | |
| 277 { | |
| 278 int i, length; | |
| 279 Lisp_Object *contents; | |
| 280 Lisp_Object gui_item = allocate_gui_item (); | |
| 281 Lisp_Object desc = find_keyword_in_vector (item, Q_descriptor); | |
| 282 | |
| 283 CHECK_VECTOR (item); | |
| 284 length = XVECTOR_LENGTH (item); | |
| 285 contents = XVECTOR_DATA (item); | |
| 286 | |
| 287 if (!NILP (desc) && !STRINGP (desc) && !VECTORP (desc)) | |
| 563 | 288 sferror ("Invalid GUI item descriptor", item); |
| 454 | 289 |
| 290 if (length & 1) | |
| 291 { | |
| 292 if (!SYMBOLP (contents [0])) | |
| 563 | 293 sferror ("Invalid GUI item descriptor", item); |
| 454 | 294 contents++; /* Ignore the leading symbol. */ |
| 295 length--; | |
| 296 } | |
| 297 | |
| 298 for (i = 0; i < length;) | |
| 299 { | |
| 300 Lisp_Object key = contents [i++]; | |
| 301 Lisp_Object val = contents [i++]; | |
| 302 gui_item_add_keyval_pair (gui_item, key, val, ERROR_ME_NOT); | |
| 303 } | |
| 304 | |
| 305 return gui_item; | |
| 306 } | |
| 307 | |
| 308 /* Update a gui item from a partial descriptor. */ | |
| 309 int | |
| 310 update_gui_item_keywords (Lisp_Object gui_item, Lisp_Object item) | |
| 311 { | |
| 312 int i, length, retval = 0; | |
| 313 Lisp_Object *contents; | |
| 314 | |
| 315 CHECK_VECTOR (item); | |
| 316 length = XVECTOR_LENGTH (item); | |
| 317 contents = XVECTOR_DATA (item); | |
| 318 | |
| 319 if (length & 1) | |
| 320 { | |
| 321 if (!SYMBOLP (contents [0])) | |
| 563 | 322 sferror ("Invalid GUI item descriptor", item); |
| 454 | 323 contents++; /* Ignore the leading symbol. */ |
| 324 length--; | |
| 325 } | |
| 326 | |
| 327 for (i = 0; i < length;) | |
| 328 { | |
| 329 Lisp_Object key = contents [i++]; | |
| 330 Lisp_Object val = contents [i++]; | |
| 793 | 331 if (gui_item_add_keyval_pair (gui_item, key, val, ERROR_ME_DEBUG_WARN)) |
| 454 | 332 retval = 1; |
| 333 } | |
| 334 return retval; | |
| 335 } | |
| 336 | |
| 428 | 337 Lisp_Object |
| 338 gui_parse_item_keywords (Lisp_Object item) | |
| 339 { | |
| 340 return make_gui_item_from_keywords_internal (item, ERROR_ME); | |
| 341 } | |
| 342 | |
| 343 Lisp_Object | |
| 344 gui_parse_item_keywords_no_errors (Lisp_Object item) | |
| 345 { | |
| 793 | 346 return make_gui_item_from_keywords_internal (item, ERROR_ME_DEBUG_WARN); |
| 428 | 347 } |
| 348 | |
| 349 /* convert a gui item into plist properties */ | |
| 350 void | |
| 351 gui_add_item_keywords_to_plist (Lisp_Object plist, Lisp_Object gui_item) | |
| 352 { | |
| 442 | 353 Lisp_Gui_Item *pgui_item = XGUI_ITEM (gui_item); |
| 440 | 354 |
| 428 | 355 if (!NILP (pgui_item->callback)) |
| 356 Fplist_put (plist, Q_callback, pgui_item->callback); | |
| 442 | 357 if (!NILP (pgui_item->callback_ex)) |
| 358 Fplist_put (plist, Q_callback_ex, pgui_item->callback_ex); | |
| 428 | 359 if (!NILP (pgui_item->suffix)) |
| 360 Fplist_put (plist, Q_suffix, pgui_item->suffix); | |
| 361 if (!NILP (pgui_item->active)) | |
| 362 Fplist_put (plist, Q_active, pgui_item->active); | |
| 363 if (!NILP (pgui_item->included)) | |
| 364 Fplist_put (plist, Q_included, pgui_item->included); | |
| 365 if (!NILP (pgui_item->config)) | |
| 366 Fplist_put (plist, Q_config, pgui_item->config); | |
| 367 if (!NILP (pgui_item->filter)) | |
| 368 Fplist_put (plist, Q_filter, pgui_item->filter); | |
| 369 if (!NILP (pgui_item->style)) | |
| 370 Fplist_put (plist, Q_style, pgui_item->style); | |
| 371 if (!NILP (pgui_item->selected)) | |
| 372 Fplist_put (plist, Q_selected, pgui_item->selected); | |
| 373 if (!NILP (pgui_item->keys)) | |
| 374 Fplist_put (plist, Q_keys, pgui_item->keys); | |
| 375 if (!NILP (pgui_item->accelerator)) | |
| 376 Fplist_put (plist, Q_accelerator, pgui_item->accelerator); | |
| 442 | 377 if (!NILP (pgui_item->value)) |
| 378 Fplist_put (plist, Q_value, pgui_item->value); | |
| 428 | 379 } |
| 380 | |
| 1318 | 381 static int |
| 1913 | 382 gui_item_value (Lisp_Object form) |
| 1318 | 383 { |
| 384 /* This function can call Lisp. */ | |
| 385 #ifndef ERROR_CHECK_DISPLAY | |
| 386 /* Shortcut to avoid evaluating Qt/Qnil each time; but don't do it when | |
| 387 error-checking so we catch unprotected eval within redisplay quicker */ | |
| 388 if (NILP (form)) | |
| 389 return 0; | |
| 390 if (EQ (form, Qt)) | |
| 391 return 1; | |
| 392 #endif | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
393 return !NILP (in_display ? |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
394 IGNORE_MULTIPLE_VALUES (eval_within_redisplay (form)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
395 : IGNORE_MULTIPLE_VALUES (Feval (form))); |
| 1318 | 396 } |
| 397 | |
| 428 | 398 /* |
| 399 * Decide whether a GUI item is active by evaluating its :active form | |
| 400 * if any | |
| 401 */ | |
| 402 int | |
| 1913 | 403 gui_item_active_p (Lisp_Object gui_item) |
| 428 | 404 { |
| 1913 | 405 return gui_item_value (XGUI_ITEM (gui_item)->active); |
| 428 | 406 } |
| 407 | |
| 408 /* set menu accelerator key to first underlined character in menu name */ | |
| 409 Lisp_Object | |
| 410 gui_item_accelerator (Lisp_Object gui_item) | |
| 411 { | |
| 442 | 412 Lisp_Gui_Item *pgui = XGUI_ITEM (gui_item); |
| 440 | 413 |
| 428 | 414 if (!NILP (pgui->accelerator)) |
| 415 return pgui->accelerator; | |
| 416 | |
| 417 else | |
| 442 | 418 return gui_name_accelerator (pgui->name); |
| 428 | 419 } |
| 420 | |
| 421 Lisp_Object | |
| 422 gui_name_accelerator (Lisp_Object nm) | |
| 423 { | |
| 867 | 424 Ibyte *name = XSTRING_DATA (nm); |
| 428 | 425 |
| 442 | 426 while (*name) |
| 427 { | |
| 428 if (*name == '%') | |
| 428 | 429 { |
| 442 | 430 ++name; |
| 431 if (!(*name)) | |
| 432 return Qnil; | |
| 433 if (*name == '_' && *(name + 1)) | |
| 434 { | |
| 867 | 435 Ichar accelerator = itext_ichar (name + 1); |
| 771 | 436 return make_char (DOWNCASE (0, accelerator)); |
| 442 | 437 } |
| 428 | 438 } |
| 867 | 439 INC_IBYTEPTR (name); |
| 428 | 440 } |
| 867 | 441 return make_char (DOWNCASE (0, itext_ichar (XSTRING_DATA (nm)))); |
| 428 | 442 } |
| 443 | |
| 444 /* | |
| 445 * Decide whether a GUI item is selected by evaluating its :selected form | |
| 446 * if any | |
| 447 */ | |
| 448 int | |
| 1913 | 449 gui_item_selected_p (Lisp_Object gui_item) |
| 428 | 450 { |
| 1913 | 451 return gui_item_value (XGUI_ITEM (gui_item)->selected); |
| 428 | 452 } |
| 453 | |
| 442 | 454 Lisp_Object |
| 455 gui_item_list_find_selected (Lisp_Object gui_item_list) | |
| 456 { | |
| 1318 | 457 /* This function can call Lisp but cannot GC because it is called within |
| 458 redisplay, and redisplay disables GC. */ | |
| 442 | 459 Lisp_Object rest; |
| 460 LIST_LOOP (rest, gui_item_list) | |
| 461 { | |
| 1913 | 462 if (gui_item_selected_p (XCAR (rest))) |
| 442 | 463 return XCAR (rest); |
| 464 } | |
| 465 return XCAR (gui_item_list); | |
| 466 } | |
| 467 | |
| 428 | 468 /* |
| 469 * Decide whether a GUI item is included by evaluating its :included | |
| 470 * form if given, and testing its :config form against supplied CONFLIST | |
| 471 * configuration variable | |
| 472 */ | |
| 473 int | |
| 474 gui_item_included_p (Lisp_Object gui_item, Lisp_Object conflist) | |
| 475 { | |
| 476 /* This function can call lisp */ | |
| 442 | 477 Lisp_Gui_Item *pgui_item = XGUI_ITEM (gui_item); |
| 428 | 478 |
| 479 /* Evaluate :included first. Shortcut to avoid evaluating Qt each time */ | |
| 1913 | 480 if (!gui_item_value (pgui_item->included)) |
| 428 | 481 return 0; |
| 482 | |
| 483 /* Do :config if conflist is given */ | |
| 484 if (!NILP (conflist) && !NILP (pgui_item->config) | |
| 485 && NILP (Fmemq (pgui_item->config, conflist))) | |
| 486 return 0; | |
| 487 | |
| 488 return 1; | |
| 489 } | |
| 490 | |
| 491 /* | |
| 771 | 492 * Format "left flush" display portion of an item. |
| 428 | 493 */ |
| 771 | 494 Lisp_Object |
| 495 gui_item_display_flush_left (Lisp_Object gui_item) | |
| 428 | 496 { |
| 497 /* This function can call lisp */ | |
| 442 | 498 Lisp_Gui_Item *pgui_item = XGUI_ITEM (gui_item); |
| 771 | 499 Lisp_Object retval; |
| 428 | 500 |
| 501 CHECK_STRING (pgui_item->name); | |
| 771 | 502 retval = pgui_item->name; |
| 428 | 503 |
| 504 if (!NILP (pgui_item->suffix)) | |
| 505 { | |
| 506 Lisp_Object suffix = pgui_item->suffix; | |
| 507 /* Shortcut to avoid evaluating suffix each time */ | |
| 508 if (!STRINGP (suffix)) | |
| 509 { | |
| 510 suffix = Feval (suffix); | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
511 suffix = IGNORE_MULTIPLE_VALUES (suffix); |
| 428 | 512 CHECK_STRING (suffix); |
| 513 } | |
| 514 | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
515 retval = concat3 (pgui_item->name, build_ascstring (" "), suffix); |
| 428 | 516 } |
| 771 | 517 |
| 518 return retval; | |
| 428 | 519 } |
| 520 | |
| 521 /* | |
| 771 | 522 * Format "right flush" display portion of an item into BUF. |
| 428 | 523 */ |
| 771 | 524 Lisp_Object |
| 525 gui_item_display_flush_right (Lisp_Object gui_item) | |
| 428 | 526 { |
| 442 | 527 Lisp_Gui_Item *pgui_item = XGUI_ITEM (gui_item); |
| 428 | 528 |
| 529 #ifdef HAVE_MENUBARS | |
| 530 /* Have keys? */ | |
| 531 if (!menubar_show_keybindings) | |
| 771 | 532 return Qnil; |
| 428 | 533 #endif |
| 534 | |
| 535 /* Try :keys first */ | |
| 536 if (!NILP (pgui_item->keys)) | |
| 537 { | |
| 538 CHECK_STRING (pgui_item->keys); | |
| 771 | 539 return pgui_item->keys; |
| 428 | 540 } |
| 541 | |
| 542 /* See if we can derive keys out of callback symbol */ | |
| 543 if (SYMBOLP (pgui_item->callback)) | |
| 544 { | |
| 793 | 545 DECLARE_EISTRING_MALLOC (buf); |
| 546 Lisp_Object str; | |
| 547 | |
| 548 where_is_to_char (pgui_item->callback, buf); | |
| 549 str = eimake_string (buf); | |
| 550 eifree (buf); | |
| 551 return str; | |
| 428 | 552 } |
| 553 | |
| 554 /* No keys - no right flush display */ | |
| 771 | 555 return Qnil; |
| 428 | 556 } |
| 557 | |
| 1204 | 558 static const struct memory_description gui_item_description [] = { |
| 934 | 559 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, name) }, |
| 560 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, callback) }, | |
| 561 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, callback_ex) }, | |
| 562 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, suffix) }, | |
| 563 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, active) }, | |
| 564 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, included) }, | |
| 565 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, config) }, | |
| 566 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, filter) }, | |
| 567 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, style) }, | |
| 568 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, selected) }, | |
| 569 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, keys) }, | |
| 570 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, accelerator) }, | |
| 571 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, value) }, | |
| 572 { XD_END } | |
| 573 }; | |
| 574 | |
| 428 | 575 static Lisp_Object |
| 576 mark_gui_item (Lisp_Object obj) | |
| 577 { | |
| 440 | 578 Lisp_Gui_Item *p = XGUI_ITEM (obj); |
| 428 | 579 |
| 580 mark_object (p->name); | |
| 581 mark_object (p->callback); | |
| 442 | 582 mark_object (p->callback_ex); |
| 428 | 583 mark_object (p->config); |
| 584 mark_object (p->suffix); | |
| 585 mark_object (p->active); | |
| 586 mark_object (p->included); | |
| 587 mark_object (p->config); | |
| 588 mark_object (p->filter); | |
| 589 mark_object (p->style); | |
| 590 mark_object (p->selected); | |
| 591 mark_object (p->keys); | |
| 592 mark_object (p->accelerator); | |
| 442 | 593 mark_object (p->value); |
| 428 | 594 |
| 595 return Qnil; | |
| 596 } | |
| 597 | |
| 665 | 598 static Hashcode |
| 428 | 599 gui_item_hash (Lisp_Object obj, int depth) |
| 600 { | |
| 440 | 601 Lisp_Gui_Item *p = XGUI_ITEM (obj); |
| 428 | 602 |
| 442 | 603 return HASH2 (HASH6 (internal_hash (p->name, depth + 1), |
| 428 | 604 internal_hash (p->callback, depth + 1), |
| 442 | 605 internal_hash (p->callback_ex, depth + 1), |
| 428 | 606 internal_hash (p->suffix, depth + 1), |
| 607 internal_hash (p->active, depth + 1), | |
| 608 internal_hash (p->included, depth + 1)), | |
| 442 | 609 HASH6 (internal_hash (p->config, depth + 1), |
| 428 | 610 internal_hash (p->filter, depth + 1), |
| 611 internal_hash (p->style, depth + 1), | |
| 612 internal_hash (p->selected, depth + 1), | |
| 442 | 613 internal_hash (p->keys, depth + 1), |
| 614 internal_hash (p->value, depth + 1))); | |
| 428 | 615 } |
| 616 | |
| 617 int | |
| 618 gui_item_id_hash (Lisp_Object hashtable, Lisp_Object gitem, int slot) | |
| 619 { | |
| 620 int hashid = gui_item_hash (gitem, 0); | |
| 621 int id = GUI_ITEM_ID_BITS (hashid, slot); | |
| 853 | 622 while (!UNBOUNDP (Fgethash (make_int (id), hashtable, Qunbound))) |
| 428 | 623 { |
| 624 id = GUI_ITEM_ID_BITS (id + 1, slot); | |
| 625 } | |
| 626 return id; | |
| 627 } | |
| 628 | |
| 1318 | 629 static int |
| 1913 | 630 gui_value_equal (Lisp_Object a, Lisp_Object b, int depth) |
| 1318 | 631 { |
| 1913 | 632 if (in_display) |
| 1318 | 633 return internal_equal_trapping_problems |
| 634 (Qredisplay, "Error calling function within redisplay", 0, 0, | |
| 635 /* say they're not equal in case of error; code calling | |
| 636 gui_item_equal_sans_selected() in redisplay does extra stuff | |
| 637 only when equal */ | |
| 638 0, a, b, depth); | |
| 639 else | |
| 640 return internal_equal (a, b, depth); | |
| 641 } | |
| 642 | |
| 442 | 643 int |
| 1913 | 644 gui_item_equal_sans_selected (Lisp_Object obj1, Lisp_Object obj2, int depth) |
| 428 | 645 { |
| 440 | 646 Lisp_Gui_Item *p1 = XGUI_ITEM (obj1); |
| 647 Lisp_Gui_Item *p2 = XGUI_ITEM (obj2); | |
| 428 | 648 |
| 1913 | 649 if (!(gui_value_equal (p1->name, p2->name, depth + 1) |
| 428 | 650 && |
| 1913 | 651 gui_value_equal (p1->callback, p2->callback, depth + 1) |
| 428 | 652 && |
| 1913 | 653 gui_value_equal (p1->callback_ex, p2->callback_ex, depth + 1) |
| 442 | 654 && |
| 428 | 655 EQ (p1->suffix, p2->suffix) |
| 656 && | |
| 657 EQ (p1->active, p2->active) | |
| 658 && | |
| 659 EQ (p1->included, p2->included) | |
| 660 && | |
| 661 EQ (p1->config, p2->config) | |
| 662 && | |
| 663 EQ (p1->filter, p2->filter) | |
| 664 && | |
| 665 EQ (p1->style, p2->style) | |
| 666 && | |
| 667 EQ (p1->accelerator, p2->accelerator) | |
| 668 && | |
| 442 | 669 EQ (p1->keys, p2->keys) |
| 670 && | |
| 671 EQ (p1->value, p2->value))) | |
| 672 return 0; | |
| 673 return 1; | |
| 674 } | |
| 675 | |
| 676 static int | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
677 gui_item_equal (Lisp_Object obj1, Lisp_Object obj2, int depth, |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
678 int UNUSED (foldcase)) |
| 442 | 679 { |
| 680 Lisp_Gui_Item *p1 = XGUI_ITEM (obj1); | |
| 681 Lisp_Gui_Item *p2 = XGUI_ITEM (obj2); | |
| 682 | |
| 1913 | 683 if (!(gui_item_equal_sans_selected (obj1, obj2, depth) && |
| 442 | 684 EQ (p1->selected, p2->selected))) |
| 428 | 685 return 0; |
| 686 return 1; | |
| 687 } | |
| 688 | |
| 689 static void | |
| 2286 | 690 print_gui_item (Lisp_Object obj, Lisp_Object printcharfun, |
| 691 int UNUSED (escapeflag)) | |
| 428 | 692 { |
| 440 | 693 Lisp_Gui_Item *g = XGUI_ITEM (obj); |
| 428 | 694 |
| 695 if (print_readably) | |
| 4846 | 696 printing_unreadable_lcrecord (obj, 0); |
| 428 | 697 |
| 793 | 698 write_fmt_string (printcharfun, "#<gui-item 0x%x>", g->header.uid); |
| 428 | 699 } |
| 700 | |
| 454 | 701 Lisp_Object |
| 442 | 702 copy_gui_item (Lisp_Object gui_item) |
| 703 { | |
| 704 Lisp_Object ret = allocate_gui_item (); | |
| 705 Lisp_Gui_Item *lp, *g = XGUI_ITEM (gui_item); | |
| 706 | |
| 707 lp = XGUI_ITEM (ret); | |
| 708 lp->name = g->name; | |
| 709 lp->callback = g->callback; | |
| 710 lp->callback_ex = g->callback_ex; | |
| 711 lp->suffix = g->suffix; | |
| 712 lp->active = g->active; | |
| 713 lp->included = g->included; | |
| 714 lp->config = g->config; | |
| 715 lp->filter = g->filter; | |
| 716 lp->style = g->style; | |
| 717 lp->selected = g->selected; | |
| 718 lp->keys = g->keys; | |
| 719 lp->accelerator = g->accelerator; | |
| 720 lp->value = g->value; | |
| 721 | |
| 722 return ret; | |
| 723 } | |
| 724 | |
| 725 Lisp_Object | |
| 726 copy_gui_item_tree (Lisp_Object arg) | |
| 727 { | |
| 728 if (CONSP (arg)) | |
| 729 { | |
| 730 Lisp_Object rest = arg = Fcopy_sequence (arg); | |
| 731 while (CONSP (rest)) | |
| 732 { | |
| 733 XCAR (rest) = copy_gui_item_tree (XCAR (rest)); | |
| 734 rest = XCDR (rest); | |
| 735 } | |
| 736 return arg; | |
| 737 } | |
| 738 else if (GUI_ITEMP (arg)) | |
| 739 return copy_gui_item (arg); | |
| 740 else | |
| 741 return arg; | |
| 742 } | |
| 743 | |
| 428 | 744 /* parse a glyph descriptor into a tree of gui items. |
| 745 | |
| 746 The gui_item slot of an image instance can be a single item or an | |
| 747 arbitrarily nested hierarchy of item lists. */ | |
| 748 | |
| 442 | 749 static Lisp_Object |
| 750 parse_gui_item_tree_item (Lisp_Object entry) | |
| 428 | 751 { |
| 752 Lisp_Object ret = entry; | |
| 442 | 753 struct gcpro gcpro1; |
| 754 | |
| 755 GCPRO1 (ret); | |
| 756 | |
| 428 | 757 if (VECTORP (entry)) |
| 758 { | |
| 442 | 759 ret = gui_parse_item_keywords_no_errors (entry); |
| 428 | 760 } |
| 761 else if (STRINGP (entry)) | |
| 762 { | |
| 763 CHECK_STRING (entry); | |
| 764 } | |
| 765 else | |
| 563 | 766 sferror ("item must be a vector or a string", entry); |
| 428 | 767 |
| 442 | 768 RETURN_UNGCPRO (ret); |
| 428 | 769 } |
| 770 | |
| 442 | 771 Lisp_Object |
| 772 parse_gui_item_tree_children (Lisp_Object list) | |
| 428 | 773 { |
| 442 | 774 Lisp_Object rest, ret = Qnil, sub = Qnil; |
| 775 struct gcpro gcpro1, gcpro2; | |
| 776 | |
| 777 GCPRO2 (ret, sub); | |
| 428 | 778 CHECK_CONS (list); |
| 779 /* recursively add items to the tree view */ | |
| 780 LIST_LOOP (rest, list) | |
| 781 { | |
| 782 if (CONSP (XCAR (rest))) | |
| 783 sub = parse_gui_item_tree_list (XCAR (rest)); | |
| 784 else | |
| 785 sub = parse_gui_item_tree_item (XCAR (rest)); | |
| 440 | 786 |
| 428 | 787 ret = Fcons (sub, ret); |
| 788 } | |
| 789 /* make the order the same as the items we have parsed */ | |
| 442 | 790 RETURN_UNGCPRO (Fnreverse (ret)); |
| 428 | 791 } |
| 792 | |
| 442 | 793 static Lisp_Object |
| 794 parse_gui_item_tree_list (Lisp_Object list) | |
| 428 | 795 { |
| 796 Lisp_Object ret; | |
| 442 | 797 struct gcpro gcpro1; |
| 428 | 798 CHECK_CONS (list); |
| 799 /* first one can never be a list */ | |
| 800 ret = parse_gui_item_tree_item (XCAR (list)); | |
| 442 | 801 GCPRO1 (ret); |
| 802 ret = Fcons (ret, parse_gui_item_tree_children (XCDR (list))); | |
| 803 RETURN_UNGCPRO (ret); | |
| 804 } | |
| 805 | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
806 DEFINE_NODUMP_LISP_OBJECT ("gui-item", gui_item, |
|
5124
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
807 mark_gui_item, print_gui_item, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
808 0, gui_item_equal, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
809 gui_item_hash, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
810 gui_item_description, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
811 Lisp_Gui_Item); |
| 563 | 812 |
| 813 DOESNT_RETURN | |
| 2367 | 814 gui_error (const Ascbyte *reason, Lisp_Object frob) |
| 563 | 815 { |
| 816 signal_error (Qgui_error, reason, frob); | |
| 817 } | |
| 818 | |
| 569 | 819 DOESNT_RETURN |
| 2367 | 820 gui_error_2 (const Ascbyte *reason, Lisp_Object frob0, Lisp_Object frob1) |
| 569 | 821 { |
| 822 signal_error_2 (Qgui_error, reason, frob0, frob1); | |
| 823 } | |
| 824 | |
| 428 | 825 void |
| 826 syms_of_gui (void) | |
| 827 { | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
828 INIT_LISP_OBJECT (gui_item); |
| 428 | 829 |
| 442 | 830 DEFSYMBOL (Qmenu_no_selection_hook); |
| 428 | 831 |
| 563 | 832 DEFERROR_STANDARD (Qgui_error, Qio_error); |
| 833 | |
| 428 | 834 #ifdef HAVE_POPUPS |
| 835 DEFSUBR (Fpopup_up_p); | |
| 836 #endif | |
| 837 } | |
| 838 | |
| 839 void | |
| 840 vars_of_gui (void) | |
| 841 { | |
| 442 | 842 DEFVAR_LISP ("menu-no-selection-hook", &Vmenu_no_selection_hook /* |
| 843 Function or functions to call when a menu or dialog box is dismissed | |
| 844 without a selection having been made. | |
| 845 */ ); | |
| 846 Vmenu_no_selection_hook = Qnil; | |
| 428 | 847 } |