Mercurial > hg > xemacs-beta
annotate src/gui.c @ 5146:88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
-------------------- ChangeLog entries follow: --------------------
src/ChangeLog addition:
2010-03-15 Ben Wing <ben@xemacs.org>
* alloc.c:
* alloc.c (c_readonly):
* alloc.c (deadbeef_memory):
* alloc.c (make_compiled_function):
* 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 (noseeum_make_marker):
* alloc.c (ADDITIONAL_FREE_string):
* alloc.c (common_init_alloc_early):
* alloc.c (init_alloc_once_early):
* bytecode.c (print_compiled_function):
* bytecode.c (mark_compiled_function):
* casetab.c:
* casetab.c (print_case_table):
* console.c:
* console.c (print_console):
* database.c (print_database):
* database.c (finalize_database):
* device-msw.c (sync_printer_with_devmode):
* device-msw.c (print_devmode):
* device-msw.c (finalize_devmode):
* device.c:
* device.c (print_device):
* elhash.c:
* elhash.c (print_hash_table):
* eval.c (print_multiple_value):
* eval.c (mark_multiple_value):
* events.c (deinitialize_event):
* events.c (print_event):
* events.c (event_equal):
* extents.c:
* extents.c (soe_dump):
* extents.c (soe_insert):
* extents.c (soe_delete):
* extents.c (soe_move):
* extents.c (extent_fragment_update):
* extents.c (print_extent_1):
* extents.c (print_extent):
* extents.c (vars_of_extents):
* frame.c:
* frame.c (print_frame):
* free-hook.c:
* free-hook.c (check_free):
* glyphs.c:
* glyphs.c (print_image_instance):
* glyphs.c (print_glyph):
* gui.c:
* gui.c (copy_gui_item):
* hash.c:
* hash.c (NULL_ENTRY):
* hash.c (KEYS_DIFFER_P):
* keymap.c (print_keymap):
* keymap.c (MARKED_SLOT):
* lisp.h:
* lrecord.h:
* lrecord.h (LISP_OBJECT_UID):
* lrecord.h (set_lheader_implementation):
* lrecord.h (struct old_lcrecord_header):
* lstream.c (print_lstream):
* lstream.c (finalize_lstream):
* marker.c (print_marker):
* marker.c (marker_equal):
* mc-alloc.c (visit_all_used_page_headers):
* mule-charset.c:
* mule-charset.c (print_charset):
* objects.c (print_color_instance):
* objects.c (print_font_instance):
* objects.c (finalize_font_instance):
* opaque.c (print_opaque):
* opaque.c (print_opaque_ptr):
* opaque.c (equal_opaque_ptr):
* print.c (internal_object_printer):
* print.c (enum printing_badness):
* rangetab.c (print_range_table):
* rangetab.c (range_table_equal):
* specifier.c (print_specifier):
* specifier.c (finalize_specifier):
* symbols.c:
* symbols.c (print_symbol_value_magic):
* tooltalk.c:
* tooltalk.c (print_tooltalk_message):
* tooltalk.c (print_tooltalk_pattern):
* window.c (print_window):
* window.c (debug_print_window):
(1) Make lrecord UID's have a separate UID space for each object.
Otherwise, with 20-bit UID's, we rapidly wrap around, especially
when common objects like conses and strings increment the UID value
for every object created. (Originally I tried making two UID spaces,
one for objects that always print readably and hence don't display
the UID, and one for other objects. But certain objects like markers
for which a UID is displayed are still generated rapidly enough that
UID overflow is a serious issue.) This also has the advantage of
making UID values smaller, hence easier to remember -- their main
purpose is to make it easier to keep track of different objects of
the same type when debugging code. Make sure we dump lrecord UID's
so that we don't have problems with pdumped and non-dumped objects
having the same UID.
(2) Display UID's consistently whenever an object (a) doesn't
consistently print readably (objects like cons and string, which
always print readably, can't display a UID), and (b) doesn't
otherwise have a unique property that makes objects of a
particular type distinguishable. (E.g. buffers didn't and still
don't print an ID, but the buffer name uniquely identifies the
buffer.) Some types, such as event, extent, compiled-function,
didn't always (or didn't ever) display an ID; others (such as
marker, extent, lstream, opaque, opaque-ptr, any object using
internal_object_printer()) used to display the actual machine
pointer instead.
(3) Rename NORMAL_LISP_OBJECT_UID to LISP_OBJECT_UID; make it work
over all Lisp objects and take a Lisp object, not a struct pointer.
(4) Some misc cleanups in alloc.c, elhash.c.
(5) Change code in events.c that "deinitializes" an event so that
it doesn't increment the event UID counter in the process. Also
use deadbeef_memory() to overwrite memory instead of doing the same
with custom code. In the process, make deadbeef_memory() in
alloc.c always available, and delete extraneous copy in mc-alloc.c.
Also capitalize all uses of 0xDEADBEEF. Similarly in elhash.c
call deadbeef_memory().
(6) Resurrect "debug SOE" code in extents.c. Make it conditional
on DEBUG_XEMACS and on a `debug-soe' variable, rather than on
SOE_DEBUG. Make it output to stderr, not stdout.
(7) Delete some custom print methods that were identical to
external_object_printer().
| author | Ben Wing <ben@xemacs.org> |
|---|---|
| date | Mon, 15 Mar 2010 16:35:38 -0500 |
| parents | f965e31a35f0 |
| children | 71ee43b8a74d |
| rev | line source |
|---|---|
| 428 | 1 /* Generic GUI code. (menubars, scrollbars, toolbars, dialogs) |
| 2 Copyright (C) 1995 Board of Trustees, University of Illinois. | |
|
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
3 Copyright (C) 1995, 1996, 2000, 2001, 2002, 2003, 2010 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 | |
| 454 | 689 Lisp_Object |
| 442 | 690 copy_gui_item (Lisp_Object gui_item) |
| 691 { | |
| 692 Lisp_Object ret = allocate_gui_item (); | |
| 693 Lisp_Gui_Item *lp, *g = XGUI_ITEM (gui_item); | |
| 694 | |
| 695 lp = XGUI_ITEM (ret); | |
| 696 lp->name = g->name; | |
| 697 lp->callback = g->callback; | |
| 698 lp->callback_ex = g->callback_ex; | |
| 699 lp->suffix = g->suffix; | |
| 700 lp->active = g->active; | |
| 701 lp->included = g->included; | |
| 702 lp->config = g->config; | |
| 703 lp->filter = g->filter; | |
| 704 lp->style = g->style; | |
| 705 lp->selected = g->selected; | |
| 706 lp->keys = g->keys; | |
| 707 lp->accelerator = g->accelerator; | |
| 708 lp->value = g->value; | |
| 709 | |
| 710 return ret; | |
| 711 } | |
| 712 | |
| 713 Lisp_Object | |
| 714 copy_gui_item_tree (Lisp_Object arg) | |
| 715 { | |
| 716 if (CONSP (arg)) | |
| 717 { | |
| 718 Lisp_Object rest = arg = Fcopy_sequence (arg); | |
| 719 while (CONSP (rest)) | |
| 720 { | |
| 721 XCAR (rest) = copy_gui_item_tree (XCAR (rest)); | |
| 722 rest = XCDR (rest); | |
| 723 } | |
| 724 return arg; | |
| 725 } | |
| 726 else if (GUI_ITEMP (arg)) | |
| 727 return copy_gui_item (arg); | |
| 728 else | |
| 729 return arg; | |
| 730 } | |
| 731 | |
| 428 | 732 /* parse a glyph descriptor into a tree of gui items. |
| 733 | |
| 734 The gui_item slot of an image instance can be a single item or an | |
| 735 arbitrarily nested hierarchy of item lists. */ | |
| 736 | |
| 442 | 737 static Lisp_Object |
| 738 parse_gui_item_tree_item (Lisp_Object entry) | |
| 428 | 739 { |
| 740 Lisp_Object ret = entry; | |
| 442 | 741 struct gcpro gcpro1; |
| 742 | |
| 743 GCPRO1 (ret); | |
| 744 | |
| 428 | 745 if (VECTORP (entry)) |
| 746 { | |
| 442 | 747 ret = gui_parse_item_keywords_no_errors (entry); |
| 428 | 748 } |
| 749 else if (STRINGP (entry)) | |
| 750 { | |
| 751 CHECK_STRING (entry); | |
| 752 } | |
| 753 else | |
| 563 | 754 sferror ("item must be a vector or a string", entry); |
| 428 | 755 |
| 442 | 756 RETURN_UNGCPRO (ret); |
| 428 | 757 } |
| 758 | |
| 442 | 759 Lisp_Object |
| 760 parse_gui_item_tree_children (Lisp_Object list) | |
| 428 | 761 { |
| 442 | 762 Lisp_Object rest, ret = Qnil, sub = Qnil; |
| 763 struct gcpro gcpro1, gcpro2; | |
| 764 | |
| 765 GCPRO2 (ret, sub); | |
| 428 | 766 CHECK_CONS (list); |
| 767 /* recursively add items to the tree view */ | |
| 768 LIST_LOOP (rest, list) | |
| 769 { | |
| 770 if (CONSP (XCAR (rest))) | |
| 771 sub = parse_gui_item_tree_list (XCAR (rest)); | |
| 772 else | |
| 773 sub = parse_gui_item_tree_item (XCAR (rest)); | |
| 440 | 774 |
| 428 | 775 ret = Fcons (sub, ret); |
| 776 } | |
| 777 /* make the order the same as the items we have parsed */ | |
| 442 | 778 RETURN_UNGCPRO (Fnreverse (ret)); |
| 428 | 779 } |
| 780 | |
| 442 | 781 static Lisp_Object |
| 782 parse_gui_item_tree_list (Lisp_Object list) | |
| 428 | 783 { |
| 784 Lisp_Object ret; | |
| 442 | 785 struct gcpro gcpro1; |
| 428 | 786 CHECK_CONS (list); |
| 787 /* first one can never be a list */ | |
| 788 ret = parse_gui_item_tree_item (XCAR (list)); | |
| 442 | 789 GCPRO1 (ret); |
| 790 ret = Fcons (ret, parse_gui_item_tree_children (XCDR (list))); | |
| 791 RETURN_UNGCPRO (ret); | |
| 792 } | |
| 793 | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
794 DEFINE_NODUMP_LISP_OBJECT ("gui-item", gui_item, |
|
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
795 mark_gui_item, external_object_printer, |
|
5124
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
796 0, gui_item_equal, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
797 gui_item_hash, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
798 gui_item_description, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
799 Lisp_Gui_Item); |
| 563 | 800 |
| 801 DOESNT_RETURN | |
| 2367 | 802 gui_error (const Ascbyte *reason, Lisp_Object frob) |
| 563 | 803 { |
| 804 signal_error (Qgui_error, reason, frob); | |
| 805 } | |
| 806 | |
| 569 | 807 DOESNT_RETURN |
| 2367 | 808 gui_error_2 (const Ascbyte *reason, Lisp_Object frob0, Lisp_Object frob1) |
| 569 | 809 { |
| 810 signal_error_2 (Qgui_error, reason, frob0, frob1); | |
| 811 } | |
| 812 | |
| 428 | 813 void |
| 814 syms_of_gui (void) | |
| 815 { | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
816 INIT_LISP_OBJECT (gui_item); |
| 428 | 817 |
| 442 | 818 DEFSYMBOL (Qmenu_no_selection_hook); |
| 428 | 819 |
| 563 | 820 DEFERROR_STANDARD (Qgui_error, Qio_error); |
| 821 | |
| 428 | 822 #ifdef HAVE_POPUPS |
| 823 DEFSUBR (Fpopup_up_p); | |
| 824 #endif | |
| 825 } | |
| 826 | |
| 827 void | |
| 828 vars_of_gui (void) | |
| 829 { | |
| 442 | 830 DEFVAR_LISP ("menu-no-selection-hook", &Vmenu_no_selection_hook /* |
| 831 Function or functions to call when a menu or dialog box is dismissed | |
| 832 without a selection having been made. | |
| 833 */ ); | |
| 834 Vmenu_no_selection_hook = Qnil; | |
| 428 | 835 } |