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