Mercurial > hg > xemacs-beta
annotate src/gui.c @ 5269:90a0084b3541
Rephrase the #'the docstring, make it nicer while byte-compiling.
lisp/ChangeLog addition:
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* bytecomp.el (byte-compile-initial-macro-environment):
* cl-macs.el (the):
Rephrase the docstring, make its implementation when compiling
files a little nicer.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Thu, 16 Sep 2010 15:34:35 +0100 |
| parents | 71ee43b8a74d |
| children | 308d34e9f07d |
| 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 |
|
5191
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
599 gui_item_hash (Lisp_Object obj, int depth, Boolint UNUSED (equalp)) |
| 428 | 600 { |
| 440 | 601 Lisp_Gui_Item *p = XGUI_ITEM (obj); |
| 428 | 602 |
|
5191
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
603 return HASH2 (HASH6 (internal_hash (p->name, depth + 1, 0), |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
604 internal_hash (p->callback, depth + 1, 0), |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
605 internal_hash (p->callback_ex, depth + 1, 0), |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
606 internal_hash (p->suffix, depth + 1, 0), |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
607 internal_hash (p->active, depth + 1, 0), |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
608 internal_hash (p->included, depth + 1, 0)), |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
609 HASH6 (internal_hash (p->config, depth + 1, 0), |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
610 internal_hash (p->filter, depth + 1, 0), |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
611 internal_hash (p->style, depth + 1, 0), |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
612 internal_hash (p->selected, depth + 1, 0), |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
613 internal_hash (p->keys, depth + 1, 0), |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
614 internal_hash (p->value, depth + 1, 0))); |
| 428 | 615 } |
| 616 | |
| 617 int | |
| 618 gui_item_id_hash (Lisp_Object hashtable, Lisp_Object gitem, int slot) | |
| 619 { | |
|
5191
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5146
diff
changeset
|
620 int hashid = gui_item_hash (gitem, 0, 0); |
| 428 | 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 } |