Mercurial > hg > xemacs-beta
annotate src/gui.c @ 5561:9a93bc90b3bd
Add a defsetf for get-char-table, necessary for the tests in the last commit.
lisp/ChangeLog addition:
2011-09-04 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (get-char-table): Add a defsetf for this.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Sun, 04 Sep 2011 20:35:31 +0100 |
| parents | 308d34e9f07d |
| children | 56144c8593a8 |
| 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); |
| 853 | 620 while (!UNBOUNDP (Fgethash (make_int (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 } |