Mercurial > hg > xemacs-beta
annotate src/gui.c @ 5925:08cfc8f77fb6 cygwin
make space for long ptr, and store as such, for frame in WINDOW data,
add a bit more debugging to debug-mswindow,
Vin Shelton patch to fix M-x shell
| author | Henry Thompson <ht@markup.co.uk> |
|---|---|
| date | Fri, 27 Feb 2015 17:41:20 +0000 |
| 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 } |