Mercurial > hg > xemacs-beta
annotate src/gui.c @ 5636:07256dcc0c8b
Add missing foreback specifier values to the GUI Element face.
They were missing for an unexplicable reason in my initial patch, leading to
nil color instances in the whole hierarchy of widget faces.
-------------------- ChangeLog entries follow: --------------------
src/ChangeLog addition:
2012-01-03 Didier Verna <didier@xemacs.org>
* faces.c (complex_vars_of_faces): Add missing foreback specifier
values to the GUI Element face.
| author | Didier Verna <didier@lrde.epita.fr> |
|---|---|
| date | Tue, 03 Jan 2012 11:25:06 +0100 |
| parents | 56144c8593a8 |
| children | 68f8d295be49 |
| 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 | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5191
diff
changeset
|
9 XEmacs is free software: you can redistribute it and/or modify it |
| 428 | 10 under the terms of the GNU General Public License as published by the |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5191
diff
changeset
|
11 Free Software Foundation, either version 3 of the License, or (at your |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5191
diff
changeset
|
12 option) any later version. |
| 428 | 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 | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5191
diff
changeset
|
20 along with XEmacs. If not, see <http://www.gnu.org/licenses/>. */ |
| 428 | 21 |
| 22 /* Synched up with: Not in FSF. */ | |
| 23 | |
| 793 | 24 /* This file Mule-ized by Ben Wing, 3-24-02. */ |
| 442 | 25 |
| 428 | 26 #include <config.h> |
| 27 #include "lisp.h" | |
| 872 | 28 |
| 442 | 29 #include "buffer.h" |
| 428 | 30 #include "bytecode.h" |
| 872 | 31 #include "elhash.h" |
| 32 #include "gui.h" | |
| 33 #include "menubar.h" | |
| 1318 | 34 #include "redisplay.h" |
| 428 | 35 |
| 442 | 36 Lisp_Object Qmenu_no_selection_hook; |
| 37 Lisp_Object Vmenu_no_selection_hook; | |
| 428 | 38 |
| 39 static Lisp_Object parse_gui_item_tree_list (Lisp_Object list); | |
| 454 | 40 Lisp_Object find_keyword_in_vector (Lisp_Object vector, Lisp_Object keyword); |
| 428 | 41 |
| 563 | 42 Lisp_Object Qgui_error; |
| 43 | |
| 428 | 44 #ifdef HAVE_POPUPS |
| 45 | |
| 46 /* count of menus/dboxes currently up */ | |
| 47 int popup_up_p; | |
| 48 | |
| 49 DEFUN ("popup-up-p", Fpopup_up_p, 0, 0, 0, /* | |
| 50 Return t if a popup menu or dialog box is up, nil otherwise. | |
| 51 See `popup-menu' and `popup-dialog-box'. | |
| 52 */ | |
| 53 ()) | |
| 54 { | |
| 55 return popup_up_p ? Qt : Qnil; | |
| 56 } | |
| 57 #endif /* HAVE_POPUPS */ | |
| 58 | |
| 59 int | |
| 867 | 60 separator_string_p (const Ibyte *s) |
| 428 | 61 { |
| 867 | 62 const Ibyte *p; |
| 63 Ibyte first; | |
| 428 | 64 |
| 65 if (!s || s[0] == '\0') | |
| 66 return 0; | |
| 67 first = s[0]; | |
| 68 if (first != '-' && first != '=') | |
| 69 return 0; | |
| 70 for (p = s; *p == first; p++) | |
| 71 ; | |
| 72 | |
| 73 return (*p == '!' || *p == ':' || *p == '\0'); | |
| 74 } | |
| 75 | |
| 76 /* Massage DATA to find the correct function and argument. Used by | |
| 77 popup_selection_callback() and the msw code. */ | |
| 78 void | |
| 79 get_gui_callback (Lisp_Object data, Lisp_Object *fn, Lisp_Object *arg) | |
| 80 { | |
| 442 | 81 if (EQ (data, Qquit)) |
| 82 { | |
| 83 *fn = Qeval; | |
| 84 *arg = list3 (Qsignal, list2 (Qquote, Qquit), Qnil); | |
| 85 Vquit_flag = Qt; | |
| 86 } | |
| 87 else if (SYMBOLP (data) | |
| 88 || (COMPILED_FUNCTIONP (data) | |
| 89 && XCOMPILED_FUNCTION (data)->flags.interactivep) | |
| 90 || (CONSP (data) && (EQ (XCAR (data), Qlambda)) | |
| 91 && !NILP (Fassq (Qinteractive, Fcdr (Fcdr (data)))))) | |
| 428 | 92 { |
| 93 *fn = Qcall_interactively; | |
| 94 *arg = data; | |
| 95 } | |
| 96 else if (CONSP (data)) | |
| 97 { | |
| 98 *fn = Qeval; | |
| 99 *arg = data; | |
| 100 } | |
| 101 else | |
| 102 { | |
| 103 *fn = Qeval; | |
| 104 *arg = list3 (Qsignal, | |
| 105 list2 (Qquote, Qerror), | |
| 771 | 106 list2 (Qquote, list2 (build_msg_string |
| 428 | 107 ("illegal callback"), |
| 108 data))); | |
| 109 } | |
| 110 } | |
| 111 | |
| 112 /* | |
| 113 * Add a value VAL associated with keyword KEY into PGUI_ITEM | |
| 114 * structure. If KEY is not a keyword, or is an unknown keyword, then | |
| 115 * error is signaled. | |
| 116 */ | |
| 454 | 117 int |
| 428 | 118 gui_item_add_keyval_pair (Lisp_Object gui_item, |
| 440 | 119 Lisp_Object key, Lisp_Object val, |
| 578 | 120 Error_Behavior errb) |
| 428 | 121 { |
| 442 | 122 Lisp_Gui_Item *pgui_item = XGUI_ITEM (gui_item); |
| 454 | 123 int retval = 0; |
| 428 | 124 |
| 125 if (!KEYWORDP (key)) | |
| 563 | 126 sferror_2 ("Non-keyword in gui item", key, pgui_item->name); |
| 428 | 127 |
| 454 | 128 if (EQ (key, Q_descriptor)) |
| 129 { | |
| 130 if (!EQ (pgui_item->name, val)) | |
| 131 { | |
| 132 retval = 1; | |
| 133 pgui_item->name = val; | |
| 134 } | |
| 135 } | |
| 793 | 136 #define FROB(slot) \ |
| 454 | 137 else if (EQ (key, Q_##slot)) \ |
| 138 { \ | |
| 793 | 139 if (!EQ (pgui_item->slot, val)) \ |
| 454 | 140 { \ |
| 141 retval = 1; \ | |
| 793 | 142 pgui_item->slot = val; \ |
| 454 | 143 } \ |
| 144 } | |
| 145 FROB (suffix) | |
| 146 FROB (active) | |
| 147 FROB (included) | |
| 148 FROB (config) | |
| 149 FROB (filter) | |
| 150 FROB (style) | |
| 151 FROB (selected) | |
| 152 FROB (keys) | |
| 153 FROB (callback) | |
| 154 FROB (callback_ex) | |
| 155 FROB (value) | |
| 156 #undef FROB | |
| 440 | 157 else if (EQ (key, Q_key_sequence)) ; /* ignored for FSF compatibility */ |
| 428 | 158 else if (EQ (key, Q_label)) ; /* ignored for 21.0 implement in 21.2 */ |
| 159 else if (EQ (key, Q_accelerator)) | |
| 160 { | |
| 454 | 161 if (!EQ (pgui_item->accelerator, val)) |
| 162 { | |
| 163 retval = 1; | |
| 164 if (SYMBOLP (val) || CHARP (val)) | |
| 165 pgui_item->accelerator = val; | |
| 166 else if (ERRB_EQ (errb, ERROR_ME)) | |
| 563 | 167 invalid_argument ("Bad keyboard accelerator", val); |
| 454 | 168 } |
| 428 | 169 } |
| 170 else if (ERRB_EQ (errb, ERROR_ME)) | |
| 793 | 171 invalid_argument_2 ("Unknown keyword in gui item", key, pgui_item->name); |
| 454 | 172 return retval; |
| 428 | 173 } |
| 174 | |
| 175 void | |
| 176 gui_item_init (Lisp_Object gui_item) | |
| 177 { | |
| 440 | 178 Lisp_Gui_Item *lp = XGUI_ITEM (gui_item); |
| 428 | 179 |
| 180 lp->name = Qnil; | |
| 181 lp->callback = Qnil; | |
| 442 | 182 lp->callback_ex = Qnil; |
| 428 | 183 lp->suffix = Qnil; |
| 184 lp->active = Qt; | |
| 185 lp->included = Qt; | |
| 186 lp->config = Qnil; | |
| 187 lp->filter = Qnil; | |
| 188 lp->style = Qnil; | |
| 189 lp->selected = Qnil; | |
| 190 lp->keys = Qnil; | |
| 191 lp->accelerator = Qnil; | |
| 442 | 192 lp->value = Qnil; |
| 428 | 193 } |
| 194 | |
| 195 Lisp_Object | |
| 196 allocate_gui_item (void) | |
| 197 { | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
198 Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (gui_item); |
| 428 | 199 |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
200 gui_item_init (obj); |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
201 return obj; |
| 428 | 202 } |
| 203 | |
| 204 /* | |
| 205 * ITEM is a lisp vector, describing a menu item or a button. The | |
| 206 * function extracts the description of the item into the PGUI_ITEM | |
| 207 * structure. | |
| 208 */ | |
| 209 static Lisp_Object | |
| 210 make_gui_item_from_keywords_internal (Lisp_Object item, | |
| 578 | 211 Error_Behavior errb) |
| 428 | 212 { |
| 213 int length, plist_p, start; | |
| 214 Lisp_Object *contents; | |
| 215 Lisp_Object gui_item = allocate_gui_item (); | |
| 442 | 216 Lisp_Gui_Item *pgui_item = XGUI_ITEM (gui_item); |
| 428 | 217 |
| 218 CHECK_VECTOR (item); | |
| 219 length = XVECTOR_LENGTH (item); | |
| 220 contents = XVECTOR_DATA (item); | |
| 221 | |
| 222 if (length < 1) | |
| 563 | 223 sferror ("GUI item descriptors must be at least 1 elts long", item); |
| 428 | 224 |
| 225 /* length 1: [ "name" ] | |
| 226 length 2: [ "name" callback ] | |
| 227 length 3: [ "name" callback active-p ] | |
| 228 or [ "name" keyword value ] | |
| 229 length 4: [ "name" callback active-p suffix ] | |
| 230 or [ "name" callback keyword value ] | |
| 231 length 5+: [ "name" callback [ keyword value ]+ ] | |
| 232 or [ "name" [ keyword value ]+ ] | |
| 233 */ | |
| 234 plist_p = (length > 2 && (KEYWORDP (contents [1]) | |
| 235 || KEYWORDP (contents [2]))); | |
| 236 | |
| 237 pgui_item->name = contents [0]; | |
| 238 if (length > 1 && !KEYWORDP (contents [1])) | |
| 239 { | |
| 240 pgui_item->callback = contents [1]; | |
| 241 start = 2; | |
| 242 } | |
| 440 | 243 else |
| 428 | 244 start =1; |
| 245 | |
| 246 if (!plist_p && length > 2) | |
| 247 /* the old way */ | |
| 248 { | |
| 249 pgui_item->active = contents [2]; | |
| 250 if (length == 4) | |
| 251 pgui_item->suffix = contents [3]; | |
| 252 } | |
| 253 else | |
| 254 /* the new way */ | |
| 255 { | |
| 256 int i; | |
| 257 if ((length - start) & 1) | |
| 563 | 258 sferror ( |
| 428 | 259 "GUI item descriptor has an odd number of keywords and values", |
| 793 | 260 item); |
| 428 | 261 |
| 262 for (i = start; i < length;) | |
| 263 { | |
| 264 Lisp_Object key = contents [i++]; | |
| 265 Lisp_Object val = contents [i++]; | |
| 266 gui_item_add_keyval_pair (gui_item, key, val, errb); | |
| 267 } | |
| 268 } | |
| 269 return gui_item; | |
| 270 } | |
| 271 | |
| 454 | 272 /* This will only work with descriptors in the new format. */ |
| 273 Lisp_Object | |
| 274 widget_gui_parse_item_keywords (Lisp_Object item) | |
| 275 { | |
| 276 int i, length; | |
| 277 Lisp_Object *contents; | |
| 278 Lisp_Object gui_item = allocate_gui_item (); | |
| 279 Lisp_Object desc = find_keyword_in_vector (item, Q_descriptor); | |
| 280 | |
| 281 CHECK_VECTOR (item); | |
| 282 length = XVECTOR_LENGTH (item); | |
| 283 contents = XVECTOR_DATA (item); | |
| 284 | |
| 285 if (!NILP (desc) && !STRINGP (desc) && !VECTORP (desc)) | |
| 563 | 286 sferror ("Invalid GUI item descriptor", item); |
| 454 | 287 |
| 288 if (length & 1) | |
| 289 { | |
| 290 if (!SYMBOLP (contents [0])) | |
| 563 | 291 sferror ("Invalid GUI item descriptor", item); |
| 454 | 292 contents++; /* Ignore the leading symbol. */ |
| 293 length--; | |
| 294 } | |
| 295 | |
| 296 for (i = 0; i < length;) | |
| 297 { | |
| 298 Lisp_Object key = contents [i++]; | |
| 299 Lisp_Object val = contents [i++]; | |
| 300 gui_item_add_keyval_pair (gui_item, key, val, ERROR_ME_NOT); | |
| 301 } | |
| 302 | |
| 303 return gui_item; | |
| 304 } | |
| 305 | |
| 306 /* Update a gui item from a partial descriptor. */ | |
| 307 int | |
| 308 update_gui_item_keywords (Lisp_Object gui_item, Lisp_Object item) | |
| 309 { | |
| 310 int i, length, retval = 0; | |
| 311 Lisp_Object *contents; | |
| 312 | |
| 313 CHECK_VECTOR (item); | |
| 314 length = XVECTOR_LENGTH (item); | |
| 315 contents = XVECTOR_DATA (item); | |
| 316 | |
| 317 if (length & 1) | |
| 318 { | |
| 319 if (!SYMBOLP (contents [0])) | |
| 563 | 320 sferror ("Invalid GUI item descriptor", item); |
| 454 | 321 contents++; /* Ignore the leading symbol. */ |
| 322 length--; | |
| 323 } | |
| 324 | |
| 325 for (i = 0; i < length;) | |
| 326 { | |
| 327 Lisp_Object key = contents [i++]; | |
| 328 Lisp_Object val = contents [i++]; | |
| 793 | 329 if (gui_item_add_keyval_pair (gui_item, key, val, ERROR_ME_DEBUG_WARN)) |
| 454 | 330 retval = 1; |
| 331 } | |
| 332 return retval; | |
| 333 } | |
| 334 | |
| 428 | 335 Lisp_Object |
| 336 gui_parse_item_keywords (Lisp_Object item) | |
| 337 { | |
| 338 return make_gui_item_from_keywords_internal (item, ERROR_ME); | |
| 339 } | |
| 340 | |
| 341 Lisp_Object | |
| 342 gui_parse_item_keywords_no_errors (Lisp_Object item) | |
| 343 { | |
| 793 | 344 return make_gui_item_from_keywords_internal (item, ERROR_ME_DEBUG_WARN); |
| 428 | 345 } |
| 346 | |
| 347 /* convert a gui item into plist properties */ | |
| 348 void | |
| 349 gui_add_item_keywords_to_plist (Lisp_Object plist, Lisp_Object gui_item) | |
| 350 { | |
| 442 | 351 Lisp_Gui_Item *pgui_item = XGUI_ITEM (gui_item); |
| 440 | 352 |
| 428 | 353 if (!NILP (pgui_item->callback)) |
| 354 Fplist_put (plist, Q_callback, pgui_item->callback); | |
| 442 | 355 if (!NILP (pgui_item->callback_ex)) |
| 356 Fplist_put (plist, Q_callback_ex, pgui_item->callback_ex); | |
| 428 | 357 if (!NILP (pgui_item->suffix)) |
| 358 Fplist_put (plist, Q_suffix, pgui_item->suffix); | |
| 359 if (!NILP (pgui_item->active)) | |
| 360 Fplist_put (plist, Q_active, pgui_item->active); | |
| 361 if (!NILP (pgui_item->included)) | |
| 362 Fplist_put (plist, Q_included, pgui_item->included); | |
| 363 if (!NILP (pgui_item->config)) | |
| 364 Fplist_put (plist, Q_config, pgui_item->config); | |
| 365 if (!NILP (pgui_item->filter)) | |
| 366 Fplist_put (plist, Q_filter, pgui_item->filter); | |
| 367 if (!NILP (pgui_item->style)) | |
| 368 Fplist_put (plist, Q_style, pgui_item->style); | |
| 369 if (!NILP (pgui_item->selected)) | |
| 370 Fplist_put (plist, Q_selected, pgui_item->selected); | |
| 371 if (!NILP (pgui_item->keys)) | |
| 372 Fplist_put (plist, Q_keys, pgui_item->keys); | |
| 373 if (!NILP (pgui_item->accelerator)) | |
| 374 Fplist_put (plist, Q_accelerator, pgui_item->accelerator); | |
| 442 | 375 if (!NILP (pgui_item->value)) |
| 376 Fplist_put (plist, Q_value, pgui_item->value); | |
| 428 | 377 } |
| 378 | |
| 1318 | 379 static int |
| 1913 | 380 gui_item_value (Lisp_Object form) |
| 1318 | 381 { |
| 382 /* This function can call Lisp. */ | |
| 383 #ifndef ERROR_CHECK_DISPLAY | |
| 384 /* Shortcut to avoid evaluating Qt/Qnil each time; but don't do it when | |
| 385 error-checking so we catch unprotected eval within redisplay quicker */ | |
| 386 if (NILP (form)) | |
| 387 return 0; | |
| 388 if (EQ (form, Qt)) | |
| 389 return 1; | |
| 390 #endif | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
391 return !NILP (in_display ? |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
392 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
|
393 : IGNORE_MULTIPLE_VALUES (Feval (form))); |
| 1318 | 394 } |
| 395 | |
| 428 | 396 /* |
| 397 * Decide whether a GUI item is active by evaluating its :active form | |
| 398 * if any | |
| 399 */ | |
| 400 int | |
| 1913 | 401 gui_item_active_p (Lisp_Object gui_item) |
| 428 | 402 { |
| 1913 | 403 return gui_item_value (XGUI_ITEM (gui_item)->active); |
| 428 | 404 } |
| 405 | |
| 406 /* set menu accelerator key to first underlined character in menu name */ | |
| 407 Lisp_Object | |
| 408 gui_item_accelerator (Lisp_Object gui_item) | |
| 409 { | |
| 442 | 410 Lisp_Gui_Item *pgui = XGUI_ITEM (gui_item); |
| 440 | 411 |
| 428 | 412 if (!NILP (pgui->accelerator)) |
| 413 return pgui->accelerator; | |
| 414 | |
| 415 else | |
| 442 | 416 return gui_name_accelerator (pgui->name); |
| 428 | 417 } |
| 418 | |
| 419 Lisp_Object | |
| 420 gui_name_accelerator (Lisp_Object nm) | |
| 421 { | |
| 867 | 422 Ibyte *name = XSTRING_DATA (nm); |
| 428 | 423 |
| 442 | 424 while (*name) |
| 425 { | |
| 426 if (*name == '%') | |
| 428 | 427 { |
| 442 | 428 ++name; |
| 429 if (!(*name)) | |
| 430 return Qnil; | |
| 431 if (*name == '_' && *(name + 1)) | |
| 432 { | |
| 867 | 433 Ichar accelerator = itext_ichar (name + 1); |
| 771 | 434 return make_char (DOWNCASE (0, accelerator)); |
| 442 | 435 } |
| 428 | 436 } |
| 867 | 437 INC_IBYTEPTR (name); |
| 428 | 438 } |
| 867 | 439 return make_char (DOWNCASE (0, itext_ichar (XSTRING_DATA (nm)))); |
| 428 | 440 } |
| 441 | |
| 442 /* | |
| 443 * Decide whether a GUI item is selected by evaluating its :selected form | |
| 444 * if any | |
| 445 */ | |
| 446 int | |
| 1913 | 447 gui_item_selected_p (Lisp_Object gui_item) |
| 428 | 448 { |
| 1913 | 449 return gui_item_value (XGUI_ITEM (gui_item)->selected); |
| 428 | 450 } |
| 451 | |
| 442 | 452 Lisp_Object |
| 453 gui_item_list_find_selected (Lisp_Object gui_item_list) | |
| 454 { | |
| 1318 | 455 /* This function can call Lisp but cannot GC because it is called within |
| 456 redisplay, and redisplay disables GC. */ | |
| 442 | 457 Lisp_Object rest; |
| 458 LIST_LOOP (rest, gui_item_list) | |
| 459 { | |
| 1913 | 460 if (gui_item_selected_p (XCAR (rest))) |
| 442 | 461 return XCAR (rest); |
| 462 } | |
| 463 return XCAR (gui_item_list); | |
| 464 } | |
| 465 | |
| 428 | 466 /* |
| 467 * Decide whether a GUI item is included by evaluating its :included | |
| 468 * form if given, and testing its :config form against supplied CONFLIST | |
| 469 * configuration variable | |
| 470 */ | |
| 471 int | |
| 472 gui_item_included_p (Lisp_Object gui_item, Lisp_Object conflist) | |
| 473 { | |
| 474 /* This function can call lisp */ | |
| 442 | 475 Lisp_Gui_Item *pgui_item = XGUI_ITEM (gui_item); |
| 428 | 476 |
| 477 /* Evaluate :included first. Shortcut to avoid evaluating Qt each time */ | |
| 1913 | 478 if (!gui_item_value (pgui_item->included)) |
| 428 | 479 return 0; |
| 480 | |
| 481 /* Do :config if conflist is given */ | |
| 482 if (!NILP (conflist) && !NILP (pgui_item->config) | |
| 483 && NILP (Fmemq (pgui_item->config, conflist))) | |
| 484 return 0; | |
| 485 | |
| 486 return 1; | |
| 487 } | |
| 488 | |
| 489 /* | |
| 771 | 490 * Format "left flush" display portion of an item. |
| 428 | 491 */ |
| 771 | 492 Lisp_Object |
| 493 gui_item_display_flush_left (Lisp_Object gui_item) | |
| 428 | 494 { |
| 495 /* This function can call lisp */ | |
| 442 | 496 Lisp_Gui_Item *pgui_item = XGUI_ITEM (gui_item); |
| 771 | 497 Lisp_Object retval; |
| 428 | 498 |
| 499 CHECK_STRING (pgui_item->name); | |
| 771 | 500 retval = pgui_item->name; |
| 428 | 501 |
| 502 if (!NILP (pgui_item->suffix)) | |
| 503 { | |
| 504 Lisp_Object suffix = pgui_item->suffix; | |
| 505 /* Shortcut to avoid evaluating suffix each time */ | |
| 506 if (!STRINGP (suffix)) | |
| 507 { | |
| 508 suffix = Feval (suffix); | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
509 suffix = IGNORE_MULTIPLE_VALUES (suffix); |
| 428 | 510 CHECK_STRING (suffix); |
| 511 } | |
| 512 | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
513 retval = concat3 (pgui_item->name, build_ascstring (" "), suffix); |
| 428 | 514 } |
| 771 | 515 |
| 516 return retval; | |
| 428 | 517 } |
| 518 | |
| 519 /* | |
| 771 | 520 * Format "right flush" display portion of an item into BUF. |
| 428 | 521 */ |
| 771 | 522 Lisp_Object |
| 523 gui_item_display_flush_right (Lisp_Object gui_item) | |
| 428 | 524 { |
| 442 | 525 Lisp_Gui_Item *pgui_item = XGUI_ITEM (gui_item); |
| 428 | 526 |
| 527 #ifdef HAVE_MENUBARS | |
| 528 /* Have keys? */ | |
| 529 if (!menubar_show_keybindings) | |
| 771 | 530 return Qnil; |
| 428 | 531 #endif |
| 532 | |
| 533 /* Try :keys first */ | |
| 534 if (!NILP (pgui_item->keys)) | |
| 535 { | |
| 536 CHECK_STRING (pgui_item->keys); | |
| 771 | 537 return pgui_item->keys; |
| 428 | 538 } |
| 539 | |
| 540 /* See if we can derive keys out of callback symbol */ | |
| 541 if (SYMBOLP (pgui_item->callback)) | |
| 542 { | |
| 793 | 543 DECLARE_EISTRING_MALLOC (buf); |
| 544 Lisp_Object str; | |
| 545 | |
| 546 where_is_to_char (pgui_item->callback, buf); | |
| 547 str = eimake_string (buf); | |
| 548 eifree (buf); | |
| 549 return str; | |
| 428 | 550 } |
| 551 | |
| 552 /* No keys - no right flush display */ | |
| 771 | 553 return Qnil; |
| 428 | 554 } |
| 555 | |
| 1204 | 556 static const struct memory_description gui_item_description [] = { |
| 934 | 557 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, name) }, |
| 558 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, callback) }, | |
| 559 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, callback_ex) }, | |
| 560 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, suffix) }, | |
| 561 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, active) }, | |
| 562 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, included) }, | |
| 563 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, config) }, | |
| 564 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, filter) }, | |
| 565 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, style) }, | |
| 566 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, selected) }, | |
| 567 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, keys) }, | |
| 568 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, accelerator) }, | |
| 569 { XD_LISP_OBJECT, offsetof (struct Lisp_Gui_Item, value) }, | |
| 570 { XD_END } | |
| 571 }; | |
| 572 | |
| 428 | 573 static Lisp_Object |
| 574 mark_gui_item (Lisp_Object obj) | |
| 575 { | |
| 440 | 576 Lisp_Gui_Item *p = XGUI_ITEM (obj); |
| 428 | 577 |
| 578 mark_object (p->name); | |
| 579 mark_object (p->callback); | |
| 442 | 580 mark_object (p->callback_ex); |
| 428 | 581 mark_object (p->config); |
| 582 mark_object (p->suffix); | |
| 583 mark_object (p->active); | |
| 584 mark_object (p->included); | |
| 585 mark_object (p->config); | |
| 586 mark_object (p->filter); | |
| 587 mark_object (p->style); | |
| 588 mark_object (p->selected); | |
| 589 mark_object (p->keys); | |
| 590 mark_object (p->accelerator); | |
| 442 | 591 mark_object (p->value); |
| 428 | 592 |
| 593 return Qnil; | |
| 594 } | |
| 595 | |
| 665 | 596 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
|
597 gui_item_hash (Lisp_Object obj, int depth, Boolint UNUSED (equalp)) |
| 428 | 598 { |
| 440 | 599 Lisp_Gui_Item *p = XGUI_ITEM (obj); |
| 428 | 600 |
|
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
|
601 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
|
602 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
|
603 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
|
604 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
|
605 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
|
606 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
|
607 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
|
608 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
|
609 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
|
610 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
|
611 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
|
612 internal_hash (p->value, depth + 1, 0))); |
| 428 | 613 } |
| 614 | |
| 615 int | |
| 616 gui_item_id_hash (Lisp_Object hashtable, Lisp_Object gitem, int slot) | |
| 617 { | |
|
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
|
618 int hashid = gui_item_hash (gitem, 0, 0); |
| 428 | 619 int id = GUI_ITEM_ID_BITS (hashid, slot); |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
620 while (!UNBOUNDP (Fgethash (make_fixnum (id), hashtable, Qunbound))) |
| 428 | 621 { |
| 622 id = GUI_ITEM_ID_BITS (id + 1, slot); | |
| 623 } | |
| 624 return id; | |
| 625 } | |
| 626 | |
| 1318 | 627 static int |
| 1913 | 628 gui_value_equal (Lisp_Object a, Lisp_Object b, int depth) |
| 1318 | 629 { |
| 1913 | 630 if (in_display) |
| 1318 | 631 return internal_equal_trapping_problems |
| 632 (Qredisplay, "Error calling function within redisplay", 0, 0, | |
| 633 /* say they're not equal in case of error; code calling | |
| 634 gui_item_equal_sans_selected() in redisplay does extra stuff | |
| 635 only when equal */ | |
| 636 0, a, b, depth); | |
| 637 else | |
| 638 return internal_equal (a, b, depth); | |
| 639 } | |
| 640 | |
| 442 | 641 int |
| 1913 | 642 gui_item_equal_sans_selected (Lisp_Object obj1, Lisp_Object obj2, int depth) |
| 428 | 643 { |
| 440 | 644 Lisp_Gui_Item *p1 = XGUI_ITEM (obj1); |
| 645 Lisp_Gui_Item *p2 = XGUI_ITEM (obj2); | |
| 428 | 646 |
| 1913 | 647 if (!(gui_value_equal (p1->name, p2->name, depth + 1) |
| 428 | 648 && |
| 1913 | 649 gui_value_equal (p1->callback, p2->callback, depth + 1) |
| 428 | 650 && |
| 1913 | 651 gui_value_equal (p1->callback_ex, p2->callback_ex, depth + 1) |
| 442 | 652 && |
| 428 | 653 EQ (p1->suffix, p2->suffix) |
| 654 && | |
| 655 EQ (p1->active, p2->active) | |
| 656 && | |
| 657 EQ (p1->included, p2->included) | |
| 658 && | |
| 659 EQ (p1->config, p2->config) | |
| 660 && | |
| 661 EQ (p1->filter, p2->filter) | |
| 662 && | |
| 663 EQ (p1->style, p2->style) | |
| 664 && | |
| 665 EQ (p1->accelerator, p2->accelerator) | |
| 666 && | |
| 442 | 667 EQ (p1->keys, p2->keys) |
| 668 && | |
| 669 EQ (p1->value, p2->value))) | |
| 670 return 0; | |
| 671 return 1; | |
| 672 } | |
| 673 | |
| 674 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
|
675 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
|
676 int UNUSED (foldcase)) |
| 442 | 677 { |
| 678 Lisp_Gui_Item *p1 = XGUI_ITEM (obj1); | |
| 679 Lisp_Gui_Item *p2 = XGUI_ITEM (obj2); | |
| 680 | |
| 1913 | 681 if (!(gui_item_equal_sans_selected (obj1, obj2, depth) && |
| 442 | 682 EQ (p1->selected, p2->selected))) |
| 428 | 683 return 0; |
| 684 return 1; | |
| 685 } | |
| 686 | |
| 454 | 687 Lisp_Object |
| 442 | 688 copy_gui_item (Lisp_Object gui_item) |
| 689 { | |
| 690 Lisp_Object ret = allocate_gui_item (); | |
| 691 Lisp_Gui_Item *lp, *g = XGUI_ITEM (gui_item); | |
| 692 | |
| 693 lp = XGUI_ITEM (ret); | |
| 694 lp->name = g->name; | |
| 695 lp->callback = g->callback; | |
| 696 lp->callback_ex = g->callback_ex; | |
| 697 lp->suffix = g->suffix; | |
| 698 lp->active = g->active; | |
| 699 lp->included = g->included; | |
| 700 lp->config = g->config; | |
| 701 lp->filter = g->filter; | |
| 702 lp->style = g->style; | |
| 703 lp->selected = g->selected; | |
| 704 lp->keys = g->keys; | |
| 705 lp->accelerator = g->accelerator; | |
| 706 lp->value = g->value; | |
| 707 | |
| 708 return ret; | |
| 709 } | |
| 710 | |
| 711 Lisp_Object | |
| 712 copy_gui_item_tree (Lisp_Object arg) | |
| 713 { | |
| 714 if (CONSP (arg)) | |
| 715 { | |
| 716 Lisp_Object rest = arg = Fcopy_sequence (arg); | |
| 717 while (CONSP (rest)) | |
| 718 { | |
| 719 XCAR (rest) = copy_gui_item_tree (XCAR (rest)); | |
| 720 rest = XCDR (rest); | |
| 721 } | |
| 722 return arg; | |
| 723 } | |
| 724 else if (GUI_ITEMP (arg)) | |
| 725 return copy_gui_item (arg); | |
| 726 else | |
| 727 return arg; | |
| 728 } | |
| 729 | |
| 428 | 730 /* parse a glyph descriptor into a tree of gui items. |
| 731 | |
| 732 The gui_item slot of an image instance can be a single item or an | |
| 733 arbitrarily nested hierarchy of item lists. */ | |
| 734 | |
| 442 | 735 static Lisp_Object |
| 736 parse_gui_item_tree_item (Lisp_Object entry) | |
| 428 | 737 { |
| 738 Lisp_Object ret = entry; | |
| 442 | 739 struct gcpro gcpro1; |
| 740 | |
| 741 GCPRO1 (ret); | |
| 742 | |
| 428 | 743 if (VECTORP (entry)) |
| 744 { | |
| 442 | 745 ret = gui_parse_item_keywords_no_errors (entry); |
| 428 | 746 } |
| 747 else if (STRINGP (entry)) | |
| 748 { | |
| 749 CHECK_STRING (entry); | |
| 750 } | |
| 751 else | |
| 563 | 752 sferror ("item must be a vector or a string", entry); |
| 428 | 753 |
| 442 | 754 RETURN_UNGCPRO (ret); |
| 428 | 755 } |
| 756 | |
| 442 | 757 Lisp_Object |
| 758 parse_gui_item_tree_children (Lisp_Object list) | |
| 428 | 759 { |
| 442 | 760 Lisp_Object rest, ret = Qnil, sub = Qnil; |
| 761 struct gcpro gcpro1, gcpro2; | |
| 762 | |
| 763 GCPRO2 (ret, sub); | |
| 428 | 764 CHECK_CONS (list); |
| 765 /* recursively add items to the tree view */ | |
| 766 LIST_LOOP (rest, list) | |
| 767 { | |
| 768 if (CONSP (XCAR (rest))) | |
| 769 sub = parse_gui_item_tree_list (XCAR (rest)); | |
| 770 else | |
| 771 sub = parse_gui_item_tree_item (XCAR (rest)); | |
| 440 | 772 |
| 428 | 773 ret = Fcons (sub, ret); |
| 774 } | |
| 775 /* make the order the same as the items we have parsed */ | |
| 442 | 776 RETURN_UNGCPRO (Fnreverse (ret)); |
| 428 | 777 } |
| 778 | |
| 442 | 779 static Lisp_Object |
| 780 parse_gui_item_tree_list (Lisp_Object list) | |
| 428 | 781 { |
| 782 Lisp_Object ret; | |
| 442 | 783 struct gcpro gcpro1; |
| 428 | 784 CHECK_CONS (list); |
| 785 /* first one can never be a list */ | |
| 786 ret = parse_gui_item_tree_item (XCAR (list)); | |
| 442 | 787 GCPRO1 (ret); |
| 788 ret = Fcons (ret, parse_gui_item_tree_children (XCDR (list))); | |
| 789 RETURN_UNGCPRO (ret); | |
| 790 } | |
| 791 | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
792 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
|
793 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
|
794 0, gui_item_equal, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
795 gui_item_hash, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
796 gui_item_description, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
797 Lisp_Gui_Item); |
| 563 | 798 |
| 799 DOESNT_RETURN | |
| 2367 | 800 gui_error (const Ascbyte *reason, Lisp_Object frob) |
| 563 | 801 { |
| 802 signal_error (Qgui_error, reason, frob); | |
| 803 } | |
| 804 | |
| 569 | 805 DOESNT_RETURN |
| 2367 | 806 gui_error_2 (const Ascbyte *reason, Lisp_Object frob0, Lisp_Object frob1) |
| 569 | 807 { |
| 808 signal_error_2 (Qgui_error, reason, frob0, frob1); | |
| 809 } | |
| 810 | |
| 428 | 811 void |
| 812 syms_of_gui (void) | |
| 813 { | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
814 INIT_LISP_OBJECT (gui_item); |
| 428 | 815 |
| 442 | 816 DEFSYMBOL (Qmenu_no_selection_hook); |
| 428 | 817 |
| 563 | 818 DEFERROR_STANDARD (Qgui_error, Qio_error); |
| 819 | |
| 428 | 820 #ifdef HAVE_POPUPS |
| 821 DEFSUBR (Fpopup_up_p); | |
| 822 #endif | |
| 823 } | |
| 824 | |
| 825 void | |
| 826 vars_of_gui (void) | |
| 827 { | |
| 442 | 828 DEFVAR_LISP ("menu-no-selection-hook", &Vmenu_no_selection_hook /* |
| 829 Function or functions to call when a menu or dialog box is dismissed | |
| 830 without a selection having been made. | |
| 831 */ ); | |
| 832 Vmenu_no_selection_hook = Qnil; | |
| 428 | 833 } |