Mercurial > hg > xemacs-beta
annotate src/gui.c @ 4899:aa8197436fdb
Make #'find-function behave better with dumped functions, installed XEmacs
2010-01-30 Aidan Kehoe <kehoea@parhasard.net>
* loadup.el:
If any filename in load-history starts with the value of
source-lisp, delete that part of the string, so that
#'find-function works better with dumped functions in an installed
XEmacs (it will look in lisp-directory instead, where it will
probably succeed).
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Sat, 30 Jan 2010 15:47:37 +0000 |
| parents | a98ca4640147 |
| children | 6ef8256a020a 19a72041c5ed |
| 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 { | |
| 3017 | 200 Lisp_Gui_Item *lp = ALLOC_LCRECORD_TYPE (Lisp_Gui_Item, &lrecord_gui_item); |
| 428 | 201 Lisp_Object val; |
| 202 | |
| 793 | 203 val = wrap_gui_item (lp); |
| 428 | 204 |
| 205 gui_item_init (val); | |
| 206 | |
| 207 return val; | |
| 208 } | |
| 209 | |
| 210 /* | |
| 211 * ITEM is a lisp vector, describing a menu item or a button. The | |
| 212 * function extracts the description of the item into the PGUI_ITEM | |
| 213 * structure. | |
| 214 */ | |
| 215 static Lisp_Object | |
| 216 make_gui_item_from_keywords_internal (Lisp_Object item, | |
| 578 | 217 Error_Behavior errb) |
| 428 | 218 { |
| 219 int length, plist_p, start; | |
| 220 Lisp_Object *contents; | |
| 221 Lisp_Object gui_item = allocate_gui_item (); | |
| 442 | 222 Lisp_Gui_Item *pgui_item = XGUI_ITEM (gui_item); |
| 428 | 223 |
| 224 CHECK_VECTOR (item); | |
| 225 length = XVECTOR_LENGTH (item); | |
| 226 contents = XVECTOR_DATA (item); | |
| 227 | |
| 228 if (length < 1) | |
| 563 | 229 sferror ("GUI item descriptors must be at least 1 elts long", item); |
| 428 | 230 |
| 231 /* length 1: [ "name" ] | |
| 232 length 2: [ "name" callback ] | |
| 233 length 3: [ "name" callback active-p ] | |
| 234 or [ "name" keyword value ] | |
| 235 length 4: [ "name" callback active-p suffix ] | |
| 236 or [ "name" callback keyword value ] | |
| 237 length 5+: [ "name" callback [ keyword value ]+ ] | |
| 238 or [ "name" [ keyword value ]+ ] | |
| 239 */ | |
| 240 plist_p = (length > 2 && (KEYWORDP (contents [1]) | |
| 241 || KEYWORDP (contents [2]))); | |
| 242 | |
| 243 pgui_item->name = contents [0]; | |
| 244 if (length > 1 && !KEYWORDP (contents [1])) | |
| 245 { | |
| 246 pgui_item->callback = contents [1]; | |
| 247 start = 2; | |
| 248 } | |
| 440 | 249 else |
| 428 | 250 start =1; |
| 251 | |
| 252 if (!plist_p && length > 2) | |
| 253 /* the old way */ | |
| 254 { | |
| 255 pgui_item->active = contents [2]; | |
| 256 if (length == 4) | |
| 257 pgui_item->suffix = contents [3]; | |
| 258 } | |
| 259 else | |
| 260 /* the new way */ | |
| 261 { | |
| 262 int i; | |
| 263 if ((length - start) & 1) | |
| 563 | 264 sferror ( |
| 428 | 265 "GUI item descriptor has an odd number of keywords and values", |
| 793 | 266 item); |
| 428 | 267 |
| 268 for (i = start; i < length;) | |
| 269 { | |
| 270 Lisp_Object key = contents [i++]; | |
| 271 Lisp_Object val = contents [i++]; | |
| 272 gui_item_add_keyval_pair (gui_item, key, val, errb); | |
| 273 } | |
| 274 } | |
| 275 return gui_item; | |
| 276 } | |
| 277 | |
| 454 | 278 /* This will only work with descriptors in the new format. */ |
| 279 Lisp_Object | |
| 280 widget_gui_parse_item_keywords (Lisp_Object item) | |
| 281 { | |
| 282 int i, length; | |
| 283 Lisp_Object *contents; | |
| 284 Lisp_Object gui_item = allocate_gui_item (); | |
| 285 Lisp_Object desc = find_keyword_in_vector (item, Q_descriptor); | |
| 286 | |
| 287 CHECK_VECTOR (item); | |
| 288 length = XVECTOR_LENGTH (item); | |
| 289 contents = XVECTOR_DATA (item); | |
| 290 | |
| 291 if (!NILP (desc) && !STRINGP (desc) && !VECTORP (desc)) | |
| 563 | 292 sferror ("Invalid GUI item descriptor", item); |
| 454 | 293 |
| 294 if (length & 1) | |
| 295 { | |
| 296 if (!SYMBOLP (contents [0])) | |
| 563 | 297 sferror ("Invalid GUI item descriptor", item); |
| 454 | 298 contents++; /* Ignore the leading symbol. */ |
| 299 length--; | |
| 300 } | |
| 301 | |
| 302 for (i = 0; i < length;) | |
| 303 { | |
| 304 Lisp_Object key = contents [i++]; | |
| 305 Lisp_Object val = contents [i++]; | |
| 306 gui_item_add_keyval_pair (gui_item, key, val, ERROR_ME_NOT); | |
| 307 } | |
| 308 | |
| 309 return gui_item; | |
| 310 } | |
| 311 | |
| 312 /* Update a gui item from a partial descriptor. */ | |
| 313 int | |
| 314 update_gui_item_keywords (Lisp_Object gui_item, Lisp_Object item) | |
| 315 { | |
| 316 int i, length, retval = 0; | |
| 317 Lisp_Object *contents; | |
| 318 | |
| 319 CHECK_VECTOR (item); | |
| 320 length = XVECTOR_LENGTH (item); | |
| 321 contents = XVECTOR_DATA (item); | |
| 322 | |
| 323 if (length & 1) | |
| 324 { | |
| 325 if (!SYMBOLP (contents [0])) | |
| 563 | 326 sferror ("Invalid GUI item descriptor", item); |
| 454 | 327 contents++; /* Ignore the leading symbol. */ |
| 328 length--; | |
| 329 } | |
| 330 | |
| 331 for (i = 0; i < length;) | |
| 332 { | |
| 333 Lisp_Object key = contents [i++]; | |
| 334 Lisp_Object val = contents [i++]; | |
| 793 | 335 if (gui_item_add_keyval_pair (gui_item, key, val, ERROR_ME_DEBUG_WARN)) |
| 454 | 336 retval = 1; |
| 337 } | |
| 338 return retval; | |
| 339 } | |
| 340 | |
| 428 | 341 Lisp_Object |
| 342 gui_parse_item_keywords (Lisp_Object item) | |
| 343 { | |
| 344 return make_gui_item_from_keywords_internal (item, ERROR_ME); | |
| 345 } | |
| 346 | |
| 347 Lisp_Object | |
| 348 gui_parse_item_keywords_no_errors (Lisp_Object item) | |
| 349 { | |
| 793 | 350 return make_gui_item_from_keywords_internal (item, ERROR_ME_DEBUG_WARN); |
| 428 | 351 } |
| 352 | |
| 353 /* convert a gui item into plist properties */ | |
| 354 void | |
| 355 gui_add_item_keywords_to_plist (Lisp_Object plist, Lisp_Object gui_item) | |
| 356 { | |
| 442 | 357 Lisp_Gui_Item *pgui_item = XGUI_ITEM (gui_item); |
| 440 | 358 |
| 428 | 359 if (!NILP (pgui_item->callback)) |
| 360 Fplist_put (plist, Q_callback, pgui_item->callback); | |
| 442 | 361 if (!NILP (pgui_item->callback_ex)) |
| 362 Fplist_put (plist, Q_callback_ex, pgui_item->callback_ex); | |
| 428 | 363 if (!NILP (pgui_item->suffix)) |
| 364 Fplist_put (plist, Q_suffix, pgui_item->suffix); | |
| 365 if (!NILP (pgui_item->active)) | |
| 366 Fplist_put (plist, Q_active, pgui_item->active); | |
| 367 if (!NILP (pgui_item->included)) | |
| 368 Fplist_put (plist, Q_included, pgui_item->included); | |
| 369 if (!NILP (pgui_item->config)) | |
| 370 Fplist_put (plist, Q_config, pgui_item->config); | |
| 371 if (!NILP (pgui_item->filter)) | |
| 372 Fplist_put (plist, Q_filter, pgui_item->filter); | |
| 373 if (!NILP (pgui_item->style)) | |
| 374 Fplist_put (plist, Q_style, pgui_item->style); | |
| 375 if (!NILP (pgui_item->selected)) | |
| 376 Fplist_put (plist, Q_selected, pgui_item->selected); | |
| 377 if (!NILP (pgui_item->keys)) | |
| 378 Fplist_put (plist, Q_keys, pgui_item->keys); | |
| 379 if (!NILP (pgui_item->accelerator)) | |
| 380 Fplist_put (plist, Q_accelerator, pgui_item->accelerator); | |
| 442 | 381 if (!NILP (pgui_item->value)) |
| 382 Fplist_put (plist, Q_value, pgui_item->value); | |
| 428 | 383 } |
| 384 | |
| 1318 | 385 static int |
| 1913 | 386 gui_item_value (Lisp_Object form) |
| 1318 | 387 { |
| 388 /* This function can call Lisp. */ | |
| 389 #ifndef ERROR_CHECK_DISPLAY | |
| 390 /* Shortcut to avoid evaluating Qt/Qnil each time; but don't do it when | |
| 391 error-checking so we catch unprotected eval within redisplay quicker */ | |
| 392 if (NILP (form)) | |
| 393 return 0; | |
| 394 if (EQ (form, Qt)) | |
| 395 return 1; | |
| 396 #endif | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
397 return !NILP (in_display ? |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
398 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
|
399 : IGNORE_MULTIPLE_VALUES (Feval (form))); |
| 1318 | 400 } |
| 401 | |
| 428 | 402 /* |
| 403 * Decide whether a GUI item is active by evaluating its :active form | |
| 404 * if any | |
| 405 */ | |
| 406 int | |
| 1913 | 407 gui_item_active_p (Lisp_Object gui_item) |
| 428 | 408 { |
| 1913 | 409 return gui_item_value (XGUI_ITEM (gui_item)->active); |
| 428 | 410 } |
| 411 | |
| 412 /* set menu accelerator key to first underlined character in menu name */ | |
| 413 Lisp_Object | |
| 414 gui_item_accelerator (Lisp_Object gui_item) | |
| 415 { | |
| 442 | 416 Lisp_Gui_Item *pgui = XGUI_ITEM (gui_item); |
| 440 | 417 |
| 428 | 418 if (!NILP (pgui->accelerator)) |
| 419 return pgui->accelerator; | |
| 420 | |
| 421 else | |
| 442 | 422 return gui_name_accelerator (pgui->name); |
| 428 | 423 } |
| 424 | |
| 425 Lisp_Object | |
| 426 gui_name_accelerator (Lisp_Object nm) | |
| 427 { | |
| 867 | 428 Ibyte *name = XSTRING_DATA (nm); |
| 428 | 429 |
| 442 | 430 while (*name) |
| 431 { | |
| 432 if (*name == '%') | |
| 428 | 433 { |
| 442 | 434 ++name; |
| 435 if (!(*name)) | |
| 436 return Qnil; | |
| 437 if (*name == '_' && *(name + 1)) | |
| 438 { | |
| 867 | 439 Ichar accelerator = itext_ichar (name + 1); |
| 771 | 440 return make_char (DOWNCASE (0, accelerator)); |
| 442 | 441 } |
| 428 | 442 } |
| 867 | 443 INC_IBYTEPTR (name); |
| 428 | 444 } |
| 867 | 445 return make_char (DOWNCASE (0, itext_ichar (XSTRING_DATA (nm)))); |
| 428 | 446 } |
| 447 | |
| 448 /* | |
| 449 * Decide whether a GUI item is selected by evaluating its :selected form | |
| 450 * if any | |
| 451 */ | |
| 452 int | |
| 1913 | 453 gui_item_selected_p (Lisp_Object gui_item) |
| 428 | 454 { |
| 1913 | 455 return gui_item_value (XGUI_ITEM (gui_item)->selected); |
| 428 | 456 } |
| 457 | |
| 442 | 458 Lisp_Object |
| 459 gui_item_list_find_selected (Lisp_Object gui_item_list) | |
| 460 { | |
| 1318 | 461 /* This function can call Lisp but cannot GC because it is called within |
| 462 redisplay, and redisplay disables GC. */ | |
| 442 | 463 Lisp_Object rest; |
| 464 LIST_LOOP (rest, gui_item_list) | |
| 465 { | |
| 1913 | 466 if (gui_item_selected_p (XCAR (rest))) |
| 442 | 467 return XCAR (rest); |
| 468 } | |
| 469 return XCAR (gui_item_list); | |
| 470 } | |
| 471 | |
| 428 | 472 /* |
| 473 * Decide whether a GUI item is included by evaluating its :included | |
| 474 * form if given, and testing its :config form against supplied CONFLIST | |
| 475 * configuration variable | |
| 476 */ | |
| 477 int | |
| 478 gui_item_included_p (Lisp_Object gui_item, Lisp_Object conflist) | |
| 479 { | |
| 480 /* This function can call lisp */ | |
| 442 | 481 Lisp_Gui_Item *pgui_item = XGUI_ITEM (gui_item); |
| 428 | 482 |
| 483 /* Evaluate :included first. Shortcut to avoid evaluating Qt each time */ | |
| 1913 | 484 if (!gui_item_value (pgui_item->included)) |
| 428 | 485 return 0; |
| 486 | |
| 487 /* Do :config if conflist is given */ | |
| 488 if (!NILP (conflist) && !NILP (pgui_item->config) | |
| 489 && NILP (Fmemq (pgui_item->config, conflist))) | |
| 490 return 0; | |
| 491 | |
| 492 return 1; | |
| 493 } | |
| 494 | |
| 495 /* | |
| 771 | 496 * Format "left flush" display portion of an item. |
| 428 | 497 */ |
| 771 | 498 Lisp_Object |
| 499 gui_item_display_flush_left (Lisp_Object gui_item) | |
| 428 | 500 { |
| 501 /* This function can call lisp */ | |
| 442 | 502 Lisp_Gui_Item *pgui_item = XGUI_ITEM (gui_item); |
| 771 | 503 Lisp_Object retval; |
| 428 | 504 |
| 505 CHECK_STRING (pgui_item->name); | |
| 771 | 506 retval = pgui_item->name; |
| 428 | 507 |
| 508 if (!NILP (pgui_item->suffix)) | |
| 509 { | |
| 510 Lisp_Object suffix = pgui_item->suffix; | |
| 511 /* Shortcut to avoid evaluating suffix each time */ | |
| 512 if (!STRINGP (suffix)) | |
| 513 { | |
| 514 suffix = Feval (suffix); | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
515 suffix = IGNORE_MULTIPLE_VALUES (suffix); |
| 428 | 516 CHECK_STRING (suffix); |
| 517 } | |
| 518 | |
| 771 | 519 retval = concat3 (pgui_item->name, build_string (" "), suffix); |
| 428 | 520 } |
| 771 | 521 |
| 522 return retval; | |
| 428 | 523 } |
| 524 | |
| 525 /* | |
| 771 | 526 * Format "right flush" display portion of an item into BUF. |
| 428 | 527 */ |
| 771 | 528 Lisp_Object |
| 529 gui_item_display_flush_right (Lisp_Object gui_item) | |
| 428 | 530 { |
| 442 | 531 Lisp_Gui_Item *pgui_item = XGUI_ITEM (gui_item); |
| 428 | 532 |
| 533 #ifdef HAVE_MENUBARS | |
| 534 /* Have keys? */ | |
| 535 if (!menubar_show_keybindings) | |
| 771 | 536 return Qnil; |
| 428 | 537 #endif |
| 538 | |
| 539 /* Try :keys first */ | |
| 540 if (!NILP (pgui_item->keys)) | |
| 541 { | |
| 542 CHECK_STRING (pgui_item->keys); | |
| 771 | 543 return pgui_item->keys; |
| 428 | 544 } |
| 545 | |
| 546 /* See if we can derive keys out of callback symbol */ | |
| 547 if (SYMBOLP (pgui_item->callback)) | |
| 548 { | |
| 793 | 549 DECLARE_EISTRING_MALLOC (buf); |
| 550 Lisp_Object str; | |
| 551 | |
| 552 where_is_to_char (pgui_item->callback, buf); | |
| 553 str = eimake_string (buf); | |
| 554 eifree (buf); | |
| 555 return str; | |
| 428 | 556 } |
| 557 | |
| 558 /* No keys - no right flush display */ | |
| 771 | 559 return Qnil; |
| 428 | 560 } |
| 561 | |
| 1204 | 562 static const struct memory_description gui_item_description [] = { |
| 934 | 563 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, name) }, |
| 564 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, callback) }, | |
| 565 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, callback_ex) }, | |
| 566 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, suffix) }, | |
| 567 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, active) }, | |
| 568 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, included) }, | |
| 569 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, config) }, | |
| 570 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, filter) }, | |
| 571 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, style) }, | |
| 572 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, selected) }, | |
| 573 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, keys) }, | |
| 574 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, accelerator) }, | |
| 575 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, value) }, | |
| 576 { XD_END } | |
| 577 }; | |
| 578 | |
| 428 | 579 static Lisp_Object |
| 580 mark_gui_item (Lisp_Object obj) | |
| 581 { | |
| 440 | 582 Lisp_Gui_Item *p = XGUI_ITEM (obj); |
| 428 | 583 |
| 584 mark_object (p->name); | |
| 585 mark_object (p->callback); | |
| 442 | 586 mark_object (p->callback_ex); |
| 428 | 587 mark_object (p->config); |
| 588 mark_object (p->suffix); | |
| 589 mark_object (p->active); | |
| 590 mark_object (p->included); | |
| 591 mark_object (p->config); | |
| 592 mark_object (p->filter); | |
| 593 mark_object (p->style); | |
| 594 mark_object (p->selected); | |
| 595 mark_object (p->keys); | |
| 596 mark_object (p->accelerator); | |
| 442 | 597 mark_object (p->value); |
| 428 | 598 |
| 599 return Qnil; | |
| 600 } | |
| 601 | |
| 665 | 602 static Hashcode |
| 428 | 603 gui_item_hash (Lisp_Object obj, int depth) |
| 604 { | |
| 440 | 605 Lisp_Gui_Item *p = XGUI_ITEM (obj); |
| 428 | 606 |
| 442 | 607 return HASH2 (HASH6 (internal_hash (p->name, depth + 1), |
| 428 | 608 internal_hash (p->callback, depth + 1), |
| 442 | 609 internal_hash (p->callback_ex, depth + 1), |
| 428 | 610 internal_hash (p->suffix, depth + 1), |
| 611 internal_hash (p->active, depth + 1), | |
| 612 internal_hash (p->included, depth + 1)), | |
| 442 | 613 HASH6 (internal_hash (p->config, depth + 1), |
| 428 | 614 internal_hash (p->filter, depth + 1), |
| 615 internal_hash (p->style, depth + 1), | |
| 616 internal_hash (p->selected, depth + 1), | |
| 442 | 617 internal_hash (p->keys, depth + 1), |
| 618 internal_hash (p->value, depth + 1))); | |
| 428 | 619 } |
| 620 | |
| 621 int | |
| 622 gui_item_id_hash (Lisp_Object hashtable, Lisp_Object gitem, int slot) | |
| 623 { | |
| 624 int hashid = gui_item_hash (gitem, 0); | |
| 625 int id = GUI_ITEM_ID_BITS (hashid, slot); | |
| 853 | 626 while (!UNBOUNDP (Fgethash (make_int (id), hashtable, Qunbound))) |
| 428 | 627 { |
| 628 id = GUI_ITEM_ID_BITS (id + 1, slot); | |
| 629 } | |
| 630 return id; | |
| 631 } | |
| 632 | |
| 1318 | 633 static int |
| 1913 | 634 gui_value_equal (Lisp_Object a, Lisp_Object b, int depth) |
| 1318 | 635 { |
| 1913 | 636 if (in_display) |
| 1318 | 637 return internal_equal_trapping_problems |
| 638 (Qredisplay, "Error calling function within redisplay", 0, 0, | |
| 639 /* say they're not equal in case of error; code calling | |
| 640 gui_item_equal_sans_selected() in redisplay does extra stuff | |
| 641 only when equal */ | |
| 642 0, a, b, depth); | |
| 643 else | |
| 644 return internal_equal (a, b, depth); | |
| 645 } | |
| 646 | |
| 442 | 647 int |
| 1913 | 648 gui_item_equal_sans_selected (Lisp_Object obj1, Lisp_Object obj2, int depth) |
| 428 | 649 { |
| 440 | 650 Lisp_Gui_Item *p1 = XGUI_ITEM (obj1); |
| 651 Lisp_Gui_Item *p2 = XGUI_ITEM (obj2); | |
| 428 | 652 |
| 1913 | 653 if (!(gui_value_equal (p1->name, p2->name, depth + 1) |
| 428 | 654 && |
| 1913 | 655 gui_value_equal (p1->callback, p2->callback, depth + 1) |
| 428 | 656 && |
| 1913 | 657 gui_value_equal (p1->callback_ex, p2->callback_ex, depth + 1) |
| 442 | 658 && |
| 428 | 659 EQ (p1->suffix, p2->suffix) |
| 660 && | |
| 661 EQ (p1->active, p2->active) | |
| 662 && | |
| 663 EQ (p1->included, p2->included) | |
| 664 && | |
| 665 EQ (p1->config, p2->config) | |
| 666 && | |
| 667 EQ (p1->filter, p2->filter) | |
| 668 && | |
| 669 EQ (p1->style, p2->style) | |
| 670 && | |
| 671 EQ (p1->accelerator, p2->accelerator) | |
| 672 && | |
| 442 | 673 EQ (p1->keys, p2->keys) |
| 674 && | |
| 675 EQ (p1->value, p2->value))) | |
| 676 return 0; | |
| 677 return 1; | |
| 678 } | |
| 679 | |
| 680 static int | |
| 681 gui_item_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) | |
| 682 { | |
| 683 Lisp_Gui_Item *p1 = XGUI_ITEM (obj1); | |
| 684 Lisp_Gui_Item *p2 = XGUI_ITEM (obj2); | |
| 685 | |
| 1913 | 686 if (!(gui_item_equal_sans_selected (obj1, obj2, depth) && |
| 442 | 687 EQ (p1->selected, p2->selected))) |
| 428 | 688 return 0; |
| 689 return 1; | |
| 690 } | |
| 691 | |
| 692 static void | |
| 2286 | 693 print_gui_item (Lisp_Object obj, Lisp_Object printcharfun, |
| 694 int UNUSED (escapeflag)) | |
| 428 | 695 { |
| 440 | 696 Lisp_Gui_Item *g = XGUI_ITEM (obj); |
| 428 | 697 |
| 698 if (print_readably) | |
| 4846 | 699 printing_unreadable_lcrecord (obj, 0); |
| 428 | 700 |
| 793 | 701 write_fmt_string (printcharfun, "#<gui-item 0x%x>", g->header.uid); |
| 428 | 702 } |
| 703 | |
| 454 | 704 Lisp_Object |
| 442 | 705 copy_gui_item (Lisp_Object gui_item) |
| 706 { | |
| 707 Lisp_Object ret = allocate_gui_item (); | |
| 708 Lisp_Gui_Item *lp, *g = XGUI_ITEM (gui_item); | |
| 709 | |
| 710 lp = XGUI_ITEM (ret); | |
| 711 lp->name = g->name; | |
| 712 lp->callback = g->callback; | |
| 713 lp->callback_ex = g->callback_ex; | |
| 714 lp->suffix = g->suffix; | |
| 715 lp->active = g->active; | |
| 716 lp->included = g->included; | |
| 717 lp->config = g->config; | |
| 718 lp->filter = g->filter; | |
| 719 lp->style = g->style; | |
| 720 lp->selected = g->selected; | |
| 721 lp->keys = g->keys; | |
| 722 lp->accelerator = g->accelerator; | |
| 723 lp->value = g->value; | |
| 724 | |
| 725 return ret; | |
| 726 } | |
| 727 | |
| 728 Lisp_Object | |
| 729 copy_gui_item_tree (Lisp_Object arg) | |
| 730 { | |
| 731 if (CONSP (arg)) | |
| 732 { | |
| 733 Lisp_Object rest = arg = Fcopy_sequence (arg); | |
| 734 while (CONSP (rest)) | |
| 735 { | |
| 736 XCAR (rest) = copy_gui_item_tree (XCAR (rest)); | |
| 737 rest = XCDR (rest); | |
| 738 } | |
| 739 return arg; | |
| 740 } | |
| 741 else if (GUI_ITEMP (arg)) | |
| 742 return copy_gui_item (arg); | |
| 743 else | |
| 744 return arg; | |
| 745 } | |
| 746 | |
| 428 | 747 /* parse a glyph descriptor into a tree of gui items. |
| 748 | |
| 749 The gui_item slot of an image instance can be a single item or an | |
| 750 arbitrarily nested hierarchy of item lists. */ | |
| 751 | |
| 442 | 752 static Lisp_Object |
| 753 parse_gui_item_tree_item (Lisp_Object entry) | |
| 428 | 754 { |
| 755 Lisp_Object ret = entry; | |
| 442 | 756 struct gcpro gcpro1; |
| 757 | |
| 758 GCPRO1 (ret); | |
| 759 | |
| 428 | 760 if (VECTORP (entry)) |
| 761 { | |
| 442 | 762 ret = gui_parse_item_keywords_no_errors (entry); |
| 428 | 763 } |
| 764 else if (STRINGP (entry)) | |
| 765 { | |
| 766 CHECK_STRING (entry); | |
| 767 } | |
| 768 else | |
| 563 | 769 sferror ("item must be a vector or a string", entry); |
| 428 | 770 |
| 442 | 771 RETURN_UNGCPRO (ret); |
| 428 | 772 } |
| 773 | |
| 442 | 774 Lisp_Object |
| 775 parse_gui_item_tree_children (Lisp_Object list) | |
| 428 | 776 { |
| 442 | 777 Lisp_Object rest, ret = Qnil, sub = Qnil; |
| 778 struct gcpro gcpro1, gcpro2; | |
| 779 | |
| 780 GCPRO2 (ret, sub); | |
| 428 | 781 CHECK_CONS (list); |
| 782 /* recursively add items to the tree view */ | |
| 783 LIST_LOOP (rest, list) | |
| 784 { | |
| 785 if (CONSP (XCAR (rest))) | |
| 786 sub = parse_gui_item_tree_list (XCAR (rest)); | |
| 787 else | |
| 788 sub = parse_gui_item_tree_item (XCAR (rest)); | |
| 440 | 789 |
| 428 | 790 ret = Fcons (sub, ret); |
| 791 } | |
| 792 /* make the order the same as the items we have parsed */ | |
| 442 | 793 RETURN_UNGCPRO (Fnreverse (ret)); |
| 428 | 794 } |
| 795 | |
| 442 | 796 static Lisp_Object |
| 797 parse_gui_item_tree_list (Lisp_Object list) | |
| 428 | 798 { |
| 799 Lisp_Object ret; | |
| 442 | 800 struct gcpro gcpro1; |
| 428 | 801 CHECK_CONS (list); |
| 802 /* first one can never be a list */ | |
| 803 ret = parse_gui_item_tree_item (XCAR (list)); | |
| 442 | 804 GCPRO1 (ret); |
| 805 ret = Fcons (ret, parse_gui_item_tree_children (XCDR (list))); | |
| 806 RETURN_UNGCPRO (ret); | |
| 807 } | |
| 808 | |
| 934 | 809 DEFINE_LRECORD_IMPLEMENTATION ("gui-item", gui_item, |
| 810 0, /*dumpable-flag*/ | |
| 811 mark_gui_item, print_gui_item, | |
| 3263 | 812 0, gui_item_equal, |
| 934 | 813 gui_item_hash, |
| 814 gui_item_description, | |
| 815 Lisp_Gui_Item); | |
| 563 | 816 |
| 817 DOESNT_RETURN | |
| 2367 | 818 gui_error (const Ascbyte *reason, Lisp_Object frob) |
| 563 | 819 { |
| 820 signal_error (Qgui_error, reason, frob); | |
| 821 } | |
| 822 | |
| 569 | 823 DOESNT_RETURN |
| 2367 | 824 gui_error_2 (const Ascbyte *reason, Lisp_Object frob0, Lisp_Object frob1) |
| 569 | 825 { |
| 826 signal_error_2 (Qgui_error, reason, frob0, frob1); | |
| 827 } | |
| 828 | |
| 428 | 829 void |
| 830 syms_of_gui (void) | |
| 831 { | |
| 442 | 832 INIT_LRECORD_IMPLEMENTATION (gui_item); |
| 428 | 833 |
| 442 | 834 DEFSYMBOL (Qmenu_no_selection_hook); |
| 428 | 835 |
| 563 | 836 DEFERROR_STANDARD (Qgui_error, Qio_error); |
| 837 | |
| 428 | 838 #ifdef HAVE_POPUPS |
| 839 DEFSUBR (Fpopup_up_p); | |
| 840 #endif | |
| 841 } | |
| 842 | |
| 843 void | |
| 844 vars_of_gui (void) | |
| 845 { | |
| 442 | 846 DEFVAR_LISP ("menu-no-selection-hook", &Vmenu_no_selection_hook /* |
| 847 Function or functions to call when a menu or dialog box is dismissed | |
| 848 without a selection having been made. | |
| 849 */ ); | |
| 850 Vmenu_no_selection_hook = Qnil; | |
| 428 | 851 } |