Mercurial > hg > xemacs-beta
annotate src/gui.c @ 5124:623d57b7fbe8 ben-lisp-object
separate regular and disksave finalization, print method fixes.
Create separate disksave method and make the finalize method only be for
actual object finalization, not disksave finalization.
Fix places where 0 was given in place of a printer -- print methods are
mandatory, and internal objects formerly without a print method now must
explicitly specify internal_object_printer().
Change the defn of CONSOLE_LIVE_P to avoid problems in some weird situations.
-------------------- ChangeLog entries follow: --------------------
src/ChangeLog addition:
2010-01-20 Ben Wing <ben@xemacs.org>
* alloc.c:
* alloc.c (very_old_free_lcrecord):
* alloc.c (disksave_object_finalization_1):
* alloc.c (make_lcrecord_list):
* alloc.c (alloc_managed_lcrecord):
* alloc.c (free_managed_lcrecord):
* alloc.c (sweep_lcrecords_1):
* buffer.c:
* bytecode.c:
* bytecode.c (Fcompiled_function_p):
* chartab.c:
* console-impl.h:
* console-impl.h (CONSOLE_TYPE_P):
* console.c:
* console.c (set_quit_events):
* data.c:
* data.c (Fmake_ephemeron):
* database.c:
* database.c (finalize_database):
* database.c (Fclose_database):
* device-msw.c:
* device-msw.c (finalize_devmode):
* device-msw.c (allocate_devmode):
* device.c:
* elhash.c:
* elhash.c (finalize_hash_table):
* eval.c:
* eval.c (bind_multiple_value_limits):
* event-stream.c:
* event-stream.c (finalize_command_builder):
* events.c:
* events.c (mark_event):
* extents.c:
* extents.c (finalize_extent_info):
* extents.c (uninit_buffer_extents):
* faces.c:
* file-coding.c:
* file-coding.c (finalize_coding_system):
* file-coding.h:
* file-coding.h (struct coding_system_methods):
* file-coding.h (struct detector):
* floatfns.c:
* floatfns.c (extract_float):
* fns.c:
* fns.c (Fidentity):
* font-mgr.c (finalize_fc_pattern):
* font-mgr.c (finalize_fc_config):
* frame.c:
* glyphs.c:
* glyphs.c (finalize_image_instance):
* glyphs.c (unmap_subwindow_instance_cache_mapper):
* gui.c:
* gui.c (gui_error):
* keymap.c:
* lisp.h (struct Lisp_Symbol):
* lrecord.h:
* lrecord.h (struct lrecord_implementation):
* lrecord.h (MC_ALLOC_CALL_FINALIZER):
* lrecord.h (MC_ALLOC_CALL_FINALIZER_FOR_DISKSAVE):
* lrecord.h (DEFINE_DUMPABLE_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_GENERAL_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_SIZABLE_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_SIZABLE_GENERAL_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_FROB_BLOCK_GENERAL_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_FROB_BLOCK_SIZABLE_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_SIZABLE_INTERNAL_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_GENERAL_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_SIZABLE_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_SIZABLE_GENERAL_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_FROB_BLOCK_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_FROB_BLOCK_GENERAL_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_FROB_BLOCK_SIZABLE_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_INTERNAL_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_SIZABLE_INTERNAL_LISP_OBJECT):
* lrecord.h (MAKE_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_MODULE_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_MODULE_GENERAL_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_MODULE_SIZABLE_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_MODULE_SIZABLE_GENERAL_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_MODULE_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_MODULE_GENERAL_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_MODULE_SIZABLE_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_MODULE_SIZABLE_GENERAL_LISP_OBJECT):
* lrecord.h (MAKE_MODULE_LISP_OBJECT):
* lstream.c:
* lstream.c (finalize_lstream):
* lstream.c (disksave_lstream):
* marker.c:
* marker.c (finalize_marker):
* mule-charset.c (make_charset):
* number.c:
* objects.c:
* objects.c (finalize_color_instance):
* objects.c (finalize_font_instance):
* opaque.c:
* opaque.c (make_opaque_ptr):
* process-nt.c:
* process-nt.c (nt_finalize_process_data):
* process-nt.c (nt_deactivate_process):
* process.c:
* process.c (finalize_process):
* procimpl.h (struct process_methods):
* scrollbar.c:
* scrollbar.c (free_scrollbar_instance):
* specifier.c (finalize_specifier):
* symbols.c:
* toolbar.c:
* toolbar.c (Ftoolbar_button_p):
* tooltalk.c:
* ui-gtk.c:
* ui-gtk.c (emacs_gtk_object_finalizer):
* ui-gtk.c (allocate_emacs_gtk_boxed_data):
* window.c:
* window.c (finalize_window):
* window.c (mark_window_as_deleted):
Separate out regular and disksave finalization. Instead of a
FOR_DISKSAVE argument to the finalizer, create a separate object
method `disksaver'. Make `finalizer' have only one argument.
Go through and separate out all finalize methods into finalize
and disksave. Delete lots of thereby redundant disksave checking.
Delete places that signal an error if we attempt to disksave --
all of these objects are non-dumpable and we will get an error
from pdump anyway if we attempt to dump them. After this is done,
only one object remains that has a disksave method -- lstream.
Change DEFINE_*_LISP_OBJECT_WITH_PROPS to DEFINE_*_GENERAL_LISP_OBJECT,
which is used for specifying either property methods or disksave
methods (or in the future, any other less-used methods).
Remove the for_disksave argument to finalize_process_data. Don't
provide a disksaver for processes because no one currently needs
it.
Clean up various places where objects didn't provide a print method.
It was made mandatory in previous changes, and all methods now
either provide their own print method or use internal_object_printer
or external_object_printer.
Change the definition of CONSOLE_LIVE_P to use the contype enum
rather than looking into the conmeths structure -- in some weird
situations with dead objects, the conmeths structure is NULL,
and printing such objects from debug_print() will crash if we try
to look into the conmeths structure.
| author | Ben Wing <ben@xemacs.org> |
|---|---|
| date | Wed, 20 Jan 2010 07:05:57 -0600 |
| parents | e0db3c197671 |
| children | b5df3737028a |
| 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 { | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
200 Lisp_Object obj = ALLOC_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 | |
| 771 | 515 retval = concat3 (pgui_item->name, build_string (" "), 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 | |
| 677 gui_item_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) | |
| 678 { | |
| 679 Lisp_Gui_Item *p1 = XGUI_ITEM (obj1); | |
| 680 Lisp_Gui_Item *p2 = XGUI_ITEM (obj2); | |
| 681 | |
| 1913 | 682 if (!(gui_item_equal_sans_selected (obj1, obj2, depth) && |
| 442 | 683 EQ (p1->selected, p2->selected))) |
| 428 | 684 return 0; |
| 685 return 1; | |
| 686 } | |
| 687 | |
| 688 static void | |
| 2286 | 689 print_gui_item (Lisp_Object obj, Lisp_Object printcharfun, |
| 690 int UNUSED (escapeflag)) | |
| 428 | 691 { |
| 440 | 692 Lisp_Gui_Item *g = XGUI_ITEM (obj); |
| 428 | 693 |
| 694 if (print_readably) | |
| 563 | 695 printing_unreadable_object ("#<gui-item 0x%x>", g->header.uid); |
| 428 | 696 |
| 793 | 697 write_fmt_string (printcharfun, "#<gui-item 0x%x>", g->header.uid); |
| 428 | 698 } |
| 699 | |
| 454 | 700 Lisp_Object |
| 442 | 701 copy_gui_item (Lisp_Object gui_item) |
| 702 { | |
| 703 Lisp_Object ret = allocate_gui_item (); | |
| 704 Lisp_Gui_Item *lp, *g = XGUI_ITEM (gui_item); | |
| 705 | |
| 706 lp = XGUI_ITEM (ret); | |
| 707 lp->name = g->name; | |
| 708 lp->callback = g->callback; | |
| 709 lp->callback_ex = g->callback_ex; | |
| 710 lp->suffix = g->suffix; | |
| 711 lp->active = g->active; | |
| 712 lp->included = g->included; | |
| 713 lp->config = g->config; | |
| 714 lp->filter = g->filter; | |
| 715 lp->style = g->style; | |
| 716 lp->selected = g->selected; | |
| 717 lp->keys = g->keys; | |
| 718 lp->accelerator = g->accelerator; | |
| 719 lp->value = g->value; | |
| 720 | |
| 721 return ret; | |
| 722 } | |
| 723 | |
| 724 Lisp_Object | |
| 725 copy_gui_item_tree (Lisp_Object arg) | |
| 726 { | |
| 727 if (CONSP (arg)) | |
| 728 { | |
| 729 Lisp_Object rest = arg = Fcopy_sequence (arg); | |
| 730 while (CONSP (rest)) | |
| 731 { | |
| 732 XCAR (rest) = copy_gui_item_tree (XCAR (rest)); | |
| 733 rest = XCDR (rest); | |
| 734 } | |
| 735 return arg; | |
| 736 } | |
| 737 else if (GUI_ITEMP (arg)) | |
| 738 return copy_gui_item (arg); | |
| 739 else | |
| 740 return arg; | |
| 741 } | |
| 742 | |
| 428 | 743 /* parse a glyph descriptor into a tree of gui items. |
| 744 | |
| 745 The gui_item slot of an image instance can be a single item or an | |
| 746 arbitrarily nested hierarchy of item lists. */ | |
| 747 | |
| 442 | 748 static Lisp_Object |
| 749 parse_gui_item_tree_item (Lisp_Object entry) | |
| 428 | 750 { |
| 751 Lisp_Object ret = entry; | |
| 442 | 752 struct gcpro gcpro1; |
| 753 | |
| 754 GCPRO1 (ret); | |
| 755 | |
| 428 | 756 if (VECTORP (entry)) |
| 757 { | |
| 442 | 758 ret = gui_parse_item_keywords_no_errors (entry); |
| 428 | 759 } |
| 760 else if (STRINGP (entry)) | |
| 761 { | |
| 762 CHECK_STRING (entry); | |
| 763 } | |
| 764 else | |
| 563 | 765 sferror ("item must be a vector or a string", entry); |
| 428 | 766 |
| 442 | 767 RETURN_UNGCPRO (ret); |
| 428 | 768 } |
| 769 | |
| 442 | 770 Lisp_Object |
| 771 parse_gui_item_tree_children (Lisp_Object list) | |
| 428 | 772 { |
| 442 | 773 Lisp_Object rest, ret = Qnil, sub = Qnil; |
| 774 struct gcpro gcpro1, gcpro2; | |
| 775 | |
| 776 GCPRO2 (ret, sub); | |
| 428 | 777 CHECK_CONS (list); |
| 778 /* recursively add items to the tree view */ | |
| 779 LIST_LOOP (rest, list) | |
| 780 { | |
| 781 if (CONSP (XCAR (rest))) | |
| 782 sub = parse_gui_item_tree_list (XCAR (rest)); | |
| 783 else | |
| 784 sub = parse_gui_item_tree_item (XCAR (rest)); | |
| 440 | 785 |
| 428 | 786 ret = Fcons (sub, ret); |
| 787 } | |
| 788 /* make the order the same as the items we have parsed */ | |
| 442 | 789 RETURN_UNGCPRO (Fnreverse (ret)); |
| 428 | 790 } |
| 791 | |
| 442 | 792 static Lisp_Object |
| 793 parse_gui_item_tree_list (Lisp_Object list) | |
| 428 | 794 { |
| 795 Lisp_Object ret; | |
| 442 | 796 struct gcpro gcpro1; |
| 428 | 797 CHECK_CONS (list); |
| 798 /* first one can never be a list */ | |
| 799 ret = parse_gui_item_tree_item (XCAR (list)); | |
| 442 | 800 GCPRO1 (ret); |
| 801 ret = Fcons (ret, parse_gui_item_tree_children (XCDR (list))); | |
| 802 RETURN_UNGCPRO (ret); | |
| 803 } | |
| 804 | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
805 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
|
806 mark_gui_item, print_gui_item, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
807 0, gui_item_equal, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
808 gui_item_hash, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
809 gui_item_description, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
810 Lisp_Gui_Item); |
| 563 | 811 |
| 812 DOESNT_RETURN | |
| 2367 | 813 gui_error (const Ascbyte *reason, Lisp_Object frob) |
| 563 | 814 { |
| 815 signal_error (Qgui_error, reason, frob); | |
| 816 } | |
| 817 | |
| 569 | 818 DOESNT_RETURN |
| 2367 | 819 gui_error_2 (const Ascbyte *reason, Lisp_Object frob0, Lisp_Object frob1) |
| 569 | 820 { |
| 821 signal_error_2 (Qgui_error, reason, frob0, frob1); | |
| 822 } | |
| 823 | |
| 428 | 824 void |
| 825 syms_of_gui (void) | |
| 826 { | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
827 INIT_LISP_OBJECT (gui_item); |
| 428 | 828 |
| 442 | 829 DEFSYMBOL (Qmenu_no_selection_hook); |
| 428 | 830 |
| 563 | 831 DEFERROR_STANDARD (Qgui_error, Qio_error); |
| 832 | |
| 428 | 833 #ifdef HAVE_POPUPS |
| 834 DEFSUBR (Fpopup_up_p); | |
| 835 #endif | |
| 836 } | |
| 837 | |
| 838 void | |
| 839 vars_of_gui (void) | |
| 840 { | |
| 442 | 841 DEFVAR_LISP ("menu-no-selection-hook", &Vmenu_no_selection_hook /* |
| 842 Function or functions to call when a menu or dialog box is dismissed | |
| 843 without a selection having been made. | |
| 844 */ ); | |
| 845 Vmenu_no_selection_hook = Qnil; | |
| 428 | 846 } |