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