Mercurial > hg > xemacs-beta
annotate src/gui-x.c @ 5754:b09e3b1b7424
Use #'call-with-condition-handler, #'normal-top-level, instead of resignalling
lisp/ChangeLog addition:
2013-08-21 Aidan Kehoe <kehoea@parhasard.net>
* startup.el (normal-top-level):
Use #'call-with-condition-handler here when calling
#'command-line, giving better backtraces on error.
Be careful about the current buffer in HANDLER.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Wed, 21 Aug 2013 20:16:55 +0100 |
| parents | 56144c8593a8 |
| children |
| rev | line source |
|---|---|
| 428 | 1 /* General GUI code -- X-specific. (menubars, scrollbars, toolbars, dialogs) |
| 2 Copyright (C) 1995 Board of Trustees, University of Illinois. | |
| 1261 | 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 | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5013
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:
5013
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:
5013
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:
5013
diff
changeset
|
20 along with XEmacs. If not, see <http://www.gnu.org/licenses/>. */ |
| 428 | 21 |
| 22 /* Synched up with: Not in FSF. */ | |
| 23 | |
| 442 | 24 /* This file Mule-ized by Ben Wing, 7-8-00. */ |
| 25 | |
| 428 | 26 #include <config.h> |
| 27 #include "lisp.h" | |
| 28 | |
| 872 | 29 #include "buffer.h" |
| 30 #include "device-impl.h" | |
| 31 #include "events.h" | |
| 32 #include "frame.h" | |
| 33 #include "glyphs.h" | |
| 34 #include "gui.h" | |
| 35 #include "menubar.h" | |
| 36 #include "opaque.h" | |
| 37 #include "redisplay.h" | |
| 38 | |
| 39 #include "console-x-impl.h" | |
| 40 | |
| 428 | 41 #ifdef LWLIB_USES_MOTIF |
| 1315 | 42 #include "xmotif.h" /* for XmVersion */ |
| 428 | 43 #endif |
| 44 | |
| 45 /* we need a unique id for each popup menu, dialog box, and scrollbar */ | |
| 647 | 46 static LWLIB_ID lwlib_id_tick; |
| 428 | 47 |
| 48 LWLIB_ID | |
| 49 new_lwlib_id (void) | |
| 50 { | |
| 1346 | 51 lwlib_id_tick++; |
| 52 if (!lwlib_id_tick) | |
| 53 lwlib_id_tick++; | |
| 54 return lwlib_id_tick; | |
| 428 | 55 } |
| 56 | |
| 57 widget_value * | |
| 58 xmalloc_widget_value (void) | |
| 59 { | |
| 60 widget_value *tmp = malloc_widget_value (); | |
| 61 if (!tmp) memory_full (); | |
| 62 return tmp; | |
| 63 } | |
| 64 | |
| 65 | |
| 1346 | 66 |
| 67 /* This contains an alist of (id . protect-me) for GCPRO'ing the callbacks | |
| 68 of the popup menus and dialog boxes. */ | |
| 69 static Lisp_Object Vpopup_callbacks; | |
| 428 | 70 |
| 1346 | 71 struct widget_value_mapper |
| 72 { | |
| 73 Lisp_Object protect_me; | |
| 1204 | 74 }; |
| 75 | |
| 76 static int | |
| 77 snarf_widget_value_mapper (widget_value *val, void *closure) | |
| 78 { | |
| 1346 | 79 struct widget_value_mapper *z = (struct widget_value_mapper *) closure; |
| 1204 | 80 |
| 81 if (val->call_data) | |
| 5013 | 82 z->protect_me = Fcons (GET_LISP_FROM_VOID (val->call_data), z->protect_me); |
| 1204 | 83 if (val->accel) |
| 5013 | 84 z->protect_me = Fcons (GET_LISP_FROM_VOID (val->accel), z->protect_me); |
| 1204 | 85 |
| 86 return 0; | |
| 87 } | |
| 88 | |
| 1261 | 89 /* Snarf the callbacks and other Lisp data that are hidden in the lwlib |
| 1346 | 90 call-data and accel associated with id ID and return them for |
| 91 proper marking. */ | |
| 1261 | 92 |
| 1346 | 93 static Lisp_Object |
| 94 snarf_widget_values_for_gcpro (LWLIB_ID id) | |
| 1261 | 95 { |
| 1346 | 96 struct widget_value_mapper z; |
| 1261 | 97 |
| 1346 | 98 z.protect_me = Qnil; |
| 99 lw_map_widget_values (id, snarf_widget_value_mapper, &z); | |
| 100 return z.protect_me; | |
| 101 } | |
| 1261 | 102 |
| 1346 | 103 /* Given an lwlib id ID associated with a widget tree, make sure that all |
| 104 Lisp callbacks in the tree are GC-protected. This can be called | |
| 105 multiple times on the same widget tree -- this should be done at | |
| 106 creation time and each time the tree is modified. */ | |
| 1261 | 107 |
| 428 | 108 void |
| 109 gcpro_popup_callbacks (LWLIB_ID id) | |
| 110 { | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
111 Lisp_Object lid = make_fixnum (id); |
| 2552 | 112 Lisp_Object this_callback = assq_no_quit (lid, Vpopup_callbacks); |
| 428 | 113 |
| 2552 | 114 if (!NILP (this_callback)) |
| 1346 | 115 { |
| 2552 | 116 free_list (XCDR (this_callback)); |
| 117 XCDR (this_callback) = snarf_widget_values_for_gcpro (id); | |
| 1346 | 118 } |
| 119 else | |
| 120 Vpopup_callbacks = Fcons (Fcons (lid, snarf_widget_values_for_gcpro (id)), | |
| 121 Vpopup_callbacks); | |
| 122 } | |
| 1204 | 123 |
| 1346 | 124 /* Remove GC-protection from the just-destroyed widget tree associated |
| 125 with lwlib id ID. */ | |
| 428 | 126 |
| 127 void | |
| 128 ungcpro_popup_callbacks (LWLIB_ID id) | |
| 129 { | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
130 Lisp_Object lid = make_fixnum (id); |
| 2552 | 131 Lisp_Object this_callback = assq_no_quit (lid, Vpopup_callbacks); |
| 1346 | 132 |
| 2552 | 133 assert (!NILP (this_callback)); |
| 134 free_list (XCDR (this_callback)); | |
| 135 Vpopup_callbacks = delq_no_quit (this_callback, Vpopup_callbacks); | |
| 428 | 136 } |
| 137 | |
| 138 int | |
| 139 popup_handled_p (LWLIB_ID id) | |
| 140 { | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
141 return NILP (assq_no_quit (make_fixnum (id), Vpopup_callbacks)); |
| 428 | 142 } |
| 143 | |
| 144 /* menu_item_descriptor_to_widget_value() et al. mallocs a | |
| 145 widget_value, but then may signal lisp errors. If an error does | |
| 146 not occur, the opaque ptr we have here has had its pointer set to 0 | |
| 147 to tell us not to do anything. Otherwise we free the widget value. | |
| 148 (This has nothing to do with GC, it's just about not dropping | |
| 149 pointers to malloc'd data when errors happen.) */ | |
| 150 | |
| 151 Lisp_Object | |
| 152 widget_value_unwind (Lisp_Object closure) | |
| 153 { | |
| 154 widget_value *wv = (widget_value *) get_opaque_ptr (closure); | |
| 155 free_opaque_ptr (closure); | |
| 156 if (wv) | |
| 436 | 157 free_widget_value_tree (wv); |
| 428 | 158 return Qnil; |
| 159 } | |
| 160 | |
| 161 #if 0 | |
| 162 static void | |
| 163 print_widget_value (widget_value *wv, int depth) | |
| 164 { | |
| 442 | 165 /* strings in wv are in external format; use printf not stdout_out |
| 166 because the latter takes internal-format strings */ | |
| 167 Extbyte d [200]; | |
| 428 | 168 int i; |
| 169 for (i = 0; i < depth; i++) d[i] = ' '; | |
| 170 d[depth]=0; | |
| 171 /* #### - print type field */ | |
| 172 printf ("%sname: %s\n", d, (wv->name ? wv->name : "(null)")); | |
| 173 if (wv->value) printf ("%svalue: %s\n", d, wv->value); | |
| 174 if (wv->key) printf ("%skey: %s\n", d, wv->key); | |
| 175 printf ("%senabled: %d\n", d, wv->enabled); | |
| 176 if (wv->contents) | |
| 177 { | |
| 178 printf ("\n%scontents: \n", d); | |
| 179 print_widget_value (wv->contents, depth + 5); | |
| 180 } | |
| 181 if (wv->next) | |
| 182 { | |
| 183 printf ("\n"); | |
| 184 print_widget_value (wv->next, depth); | |
| 185 } | |
| 186 } | |
| 187 #endif | |
| 188 | |
| 189 /* This recursively calls free_widget_value() on the tree of widgets. | |
| 190 It must free all data that was malloc'ed for these widget_values. | |
| 191 | |
| 192 It used to be that emacs only allocated new storage for the `key' slot. | |
| 193 All other slots are pointers into the data of Lisp_Strings, and must be | |
| 194 left alone. */ | |
| 195 void | |
| 196 free_popup_widget_value_tree (widget_value *wv) | |
| 197 { | |
| 198 if (! wv) return; | |
|
4976
16112448d484
Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents:
4677
diff
changeset
|
199 if (wv->key) xfree (wv->key); |
|
16112448d484
Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents:
4677
diff
changeset
|
200 if (wv->value) xfree (wv->value); |
|
16112448d484
Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents:
4677
diff
changeset
|
201 if (wv->name) xfree (wv->name); |
| 428 | 202 |
| 1204 | 203 wv->name = wv->value = wv->key = (char *) 0xDEADBEEF; /* -559038737 base 10*/ |
| 428 | 204 |
| 205 if (wv->contents && (wv->contents != (widget_value*)1)) | |
| 206 { | |
| 207 free_popup_widget_value_tree (wv->contents); | |
| 208 wv->contents = (widget_value *) 0xDEADBEEF; | |
| 209 } | |
| 210 if (wv->next) | |
| 211 { | |
| 212 free_popup_widget_value_tree (wv->next); | |
| 213 wv->next = (widget_value *) 0xDEADBEEF; | |
| 214 } | |
| 215 free_widget_value (wv); | |
| 216 } | |
| 217 | |
| 218 /* The following is actually called from somewhere within XtDispatchEvent(), | |
| 2168 | 219 called from XtAppProcessEvent() in event-Xt.c. |
| 220 | |
| 221 Callback function for widgets and menus. | |
| 222 */ | |
| 428 | 223 |
| 224 void | |
| 2286 | 225 popup_selection_callback (Widget widget, LWLIB_ID UNUSED (id), |
| 428 | 226 XtPointer client_data) |
| 227 { | |
| 442 | 228 Lisp_Object data, image_instance, callback, callback_ex; |
| 229 Lisp_Object frame, event; | |
| 230 int update_subwindows_p = 0; | |
| 428 | 231 struct device *d = get_device_from_display (XtDisplay (widget)); |
| 232 struct frame *f = x_any_widget_or_parent_to_frame (d, widget); | |
| 233 | |
| 872 | 234 #ifdef HAVE_MENUBARS |
| 428 | 235 /* set in lwlib to the time stamp associated with the most recent menu |
| 236 operation */ | |
| 237 extern Time x_focus_timestamp_really_sucks_fix_me_better; | |
| 872 | 238 #endif |
| 428 | 239 |
| 240 if (!f) | |
| 241 return; | |
| 242 if (((EMACS_INT) client_data) == 0) | |
| 243 return; | |
| 5013 | 244 data = GET_LISP_FROM_VOID (client_data); |
| 793 | 245 frame = wrap_frame (f); |
| 428 | 246 |
| 247 #if 0 | |
| 248 /* #### What the hell? I can't understand why this call is here, | |
| 249 and doing it is really courting disaster in the new event | |
| 250 model, since popup_selection_callback is called from | |
| 251 within next_event_internal() and Faccept_process_output() | |
| 252 itself calls next_event_internal(). --Ben */ | |
| 253 | |
| 254 /* Flush the X and process input */ | |
| 255 Faccept_process_output (Qnil, Qnil, Qnil); | |
| 256 #endif | |
| 257 | |
| 258 if (((EMACS_INT) client_data) == -1) | |
| 259 { | |
| 442 | 260 event = Fmake_event (Qnil, Qnil); |
| 261 | |
| 934 | 262 XSET_EVENT_TYPE (event, misc_user_event); |
| 263 XSET_EVENT_CHANNEL (event, frame); | |
| 1204 | 264 XSET_EVENT_MISC_USER_FUNCTION (event, Qrun_hooks); |
| 265 XSET_EVENT_MISC_USER_OBJECT (event, Qmenu_no_selection_hook); | |
| 428 | 266 } |
| 267 else | |
| 268 { | |
| 442 | 269 image_instance = XCAR (data); |
| 270 callback = XCAR (XCDR (data)); | |
| 271 callback_ex = XCDR (XCDR (data)); | |
| 272 update_subwindows_p = 1; | |
| 273 /* It is possible for a widget action to cause it to get out of | |
| 274 sync with its instantiator. Thus it is necessary to signal | |
| 275 this possibility. */ | |
| 276 if (IMAGE_INSTANCEP (image_instance)) | |
| 277 XIMAGE_INSTANCE_WIDGET_ACTION_OCCURRED (image_instance) = 1; | |
| 278 | |
| 279 if (!NILP (callback_ex) && !UNBOUNDP (callback_ex)) | |
| 280 { | |
| 281 event = Fmake_event (Qnil, Qnil); | |
| 282 | |
| 934 | 283 XSET_EVENT_TYPE (event, misc_user_event); |
| 284 XSET_EVENT_CHANNEL (event, frame); | |
| 1204 | 285 XSET_EVENT_MISC_USER_FUNCTION (event, Qeval); |
| 286 XSET_EVENT_MISC_USER_OBJECT (event, list4 (Qfuncall, callback_ex, image_instance, event)); | |
| 442 | 287 } |
| 288 else if (NILP (callback) || UNBOUNDP (callback)) | |
| 289 event = Qnil; | |
| 290 else | |
| 291 { | |
| 292 Lisp_Object fn, arg; | |
| 293 | |
| 294 event = Fmake_event (Qnil, Qnil); | |
| 295 | |
| 296 get_gui_callback (callback, &fn, &arg); | |
| 934 | 297 XSET_EVENT_TYPE (event, misc_user_event); |
| 298 XSET_EVENT_CHANNEL (event, frame); | |
| 1204 | 299 XSET_EVENT_MISC_USER_FUNCTION (event, fn); |
| 300 XSET_EVENT_MISC_USER_OBJECT (event, arg); | |
| 442 | 301 } |
| 428 | 302 } |
| 303 | |
| 304 /* This is the timestamp used for asserting focus so we need to get an | |
| 444 | 305 up-to-date value event if no events have been dispatched to emacs |
| 428 | 306 */ |
| 872 | 307 #ifdef HAVE_MENUBARS |
| 428 | 308 DEVICE_X_MOUSE_TIMESTAMP (d) = x_focus_timestamp_really_sucks_fix_me_better; |
| 309 #else | |
| 310 DEVICE_X_MOUSE_TIMESTAMP (d) = DEVICE_X_GLOBAL_MOUSE_TIMESTAMP (d); | |
| 311 #endif | |
| 442 | 312 if (!NILP (event)) |
| 1204 | 313 enqueue_dispatch_event (event); |
| 442 | 314 /* The result of this evaluation could cause other instances to change so |
| 315 enqueue an update callback to check this. */ | |
| 316 if (update_subwindows_p && !NILP (event)) | |
| 317 enqueue_magic_eval_event (update_widget_instances, frame); | |
| 428 | 318 } |
| 319 | |
| 320 #if 1 | |
| 321 /* Eval the activep slot of the menu item */ | |
| 1914 | 322 # define wv_set_evalable_slot(slot,form) do { \ |
| 323 Lisp_Object wses_form = (form); \ | |
| 324 (slot) = (NILP (wses_form) ? 0 : \ | |
| 325 EQ (wses_form, Qt) ? 1 : \ | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2552
diff
changeset
|
326 !NILP (in_display ? \ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2552
diff
changeset
|
327 IGNORE_MULTIPLE_VALUES (eval_within_redisplay (wses_form)) \ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2552
diff
changeset
|
328 : IGNORE_MULTIPLE_VALUES (Feval (wses_form)))); \ |
| 428 | 329 } while (0) |
| 330 #else | |
| 331 /* Treat the activep slot of the menu item as a boolean */ | |
| 332 # define wv_set_evalable_slot(slot,form) \ | |
| 333 ((void) (slot = (!NILP (form)))) | |
| 334 #endif | |
| 335 | |
| 442 | 336 Extbyte * |
| 867 | 337 menu_separator_style_and_to_external (const Ibyte *s) |
| 428 | 338 { |
| 867 | 339 const Ibyte *p; |
| 340 Ibyte first; | |
| 428 | 341 |
| 342 if (!s || s[0] == '\0') | |
| 343 return NULL; | |
| 344 first = s[0]; | |
| 345 if (first != '-' && first != '=') | |
| 346 return NULL; | |
| 347 for (p = s; *p == first; p++) | |
| 348 DO_NOTHING; | |
| 349 | |
| 350 /* #### - cannot currently specify a separator tag "--!tag" and a | |
| 351 separator style "--:style" at the same time. */ | |
| 352 /* #### - Also, the motif menubar code doesn't deal with the | |
| 353 double etched style yet, so it's not good to get into the habit of | |
| 354 using "===" in menubars to get double-etched lines */ | |
| 355 if (*p == '!' || *p == '\0') | |
| 356 return ((first == '-') | |
| 357 ? NULL /* single etched is the default */ | |
| 358 : xstrdup ("shadowDoubleEtchedIn")); | |
| 359 else if (*p == ':') | |
| 442 | 360 { |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4677
diff
changeset
|
361 return ITEXT_TO_EXTERNAL_MALLOC (p + 1, Qlwlib_encoding); |
| 442 | 362 } |
| 428 | 363 |
| 364 return NULL; | |
| 365 } | |
| 366 | |
| 442 | 367 Extbyte * |
| 368 add_accel_and_to_external (Lisp_Object string) | |
| 369 { | |
| 370 int i; | |
| 371 int found_accel = 0; | |
| 372 Extbyte *retval; | |
| 867 | 373 Ibyte *name = XSTRING_DATA (string); |
| 442 | 374 |
| 375 for (i = 0; name[i]; ++i) | |
| 376 if (name[i] == '%' && name[i+1] == '_') | |
| 377 { | |
| 378 found_accel = 1; | |
| 379 break; | |
| 380 } | |
| 381 | |
| 382 if (found_accel) | |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4677
diff
changeset
|
383 retval = LISP_STRING_TO_EXTERNAL_MALLOC (string, Qlwlib_encoding); |
| 442 | 384 else |
| 385 { | |
| 647 | 386 Bytecount namelen = XSTRING_LENGTH (string); |
| 2367 | 387 Ibyte *chars = alloca_ibytes (namelen + 3); |
| 442 | 388 chars[0] = '%'; |
| 389 chars[1] = '_'; | |
| 390 memcpy (chars + 2, name, namelen + 1); | |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4677
diff
changeset
|
391 retval = ITEXT_TO_EXTERNAL_MALLOC (chars, Qlwlib_encoding); |
| 442 | 392 } |
| 393 | |
| 394 return retval; | |
| 395 } | |
| 428 | 396 |
| 853 | 397 /* This does the dirty work. GC is inhibited when this is called. |
| 398 */ | |
| 428 | 399 int |
| 442 | 400 button_item_to_widget_value (Lisp_Object gui_object_instance, |
| 401 Lisp_Object gui_item, widget_value *wv, | |
| 402 int allow_text_field_p, int no_keys_p, | |
| 403 int menu_entry_p, int accel_p) | |
| 428 | 404 { |
| 853 | 405 /* This function cannot GC because GC is inhibited when it's called */ |
| 440 | 406 Lisp_Gui_Item* pgui = 0; |
| 428 | 407 |
| 408 /* degenerate case */ | |
| 409 if (STRINGP (gui_item)) | |
| 410 { | |
| 411 wv->type = TEXT_TYPE; | |
| 442 | 412 if (accel_p) |
| 413 wv->name = add_accel_and_to_external (gui_item); | |
| 414 else | |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4677
diff
changeset
|
415 wv->name = LISP_STRING_TO_EXTERNAL_MALLOC (gui_item, Qlwlib_encoding); |
| 428 | 416 return 1; |
| 417 } | |
| 418 else if (!GUI_ITEMP (gui_item)) | |
| 563 | 419 invalid_argument ("need a string or a gui_item here", gui_item); |
| 428 | 420 |
| 421 pgui = XGUI_ITEM (gui_item); | |
| 422 | |
| 423 if (!NILP (pgui->filter)) | |
| 563 | 424 sferror (":filter keyword not permitted on leaf nodes", gui_item); |
| 428 | 425 |
| 426 #ifdef HAVE_MENUBARS | |
| 442 | 427 if (menu_entry_p && !gui_item_included_p (gui_item, Vmenubar_configuration)) |
| 428 | 428 { |
| 429 /* the include specification says to ignore this item. */ | |
| 430 return 0; | |
| 431 } | |
| 432 #endif /* HAVE_MENUBARS */ | |
| 433 | |
| 442 | 434 if (!STRINGP (pgui->name)) |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2552
diff
changeset
|
435 pgui->name = IGNORE_MULTIPLE_VALUES (Feval (pgui->name)); |
| 442 | 436 |
| 428 | 437 CHECK_STRING (pgui->name); |
| 442 | 438 if (accel_p) |
| 439 { | |
| 440 wv->name = add_accel_and_to_external (pgui->name); | |
| 5013 | 441 wv->accel = STORE_LISP_IN_VOID (gui_item_accelerator (gui_item)); |
| 442 | 442 } |
| 443 else | |
| 444 { | |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4677
diff
changeset
|
445 wv->name = LISP_STRING_TO_EXTERNAL_MALLOC (pgui->name, Qlwlib_encoding); |
| 5013 | 446 wv->accel = STORE_LISP_IN_VOID (Qnil); |
| 442 | 447 } |
| 428 | 448 |
| 449 if (!NILP (pgui->suffix)) | |
| 450 { | |
| 451 Lisp_Object suffix2; | |
| 452 | |
| 453 /* Shortcut to avoid evaluating suffix each time */ | |
| 454 if (STRINGP (pgui->suffix)) | |
| 455 suffix2 = pgui->suffix; | |
| 456 else | |
| 457 { | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2552
diff
changeset
|
458 suffix2 = IGNORE_MULTIPLE_VALUES (Feval (pgui->suffix)); |
| 428 | 459 CHECK_STRING (suffix2); |
| 460 } | |
| 461 | |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4677
diff
changeset
|
462 wv->value = LISP_STRING_TO_EXTERNAL_MALLOC (suffix2, Qlwlib_encoding); |
| 428 | 463 } |
| 464 | |
| 465 wv_set_evalable_slot (wv->enabled, pgui->active); | |
| 466 wv_set_evalable_slot (wv->selected, pgui->selected); | |
| 467 | |
| 442 | 468 if (!NILP (pgui->callback) || !NILP (pgui->callback_ex)) |
| 5013 | 469 wv->call_data = STORE_LISP_IN_VOID (cons3 (gui_object_instance, |
| 442 | 470 pgui->callback, |
| 471 pgui->callback_ex)); | |
| 428 | 472 |
| 473 if (no_keys_p | |
| 474 #ifdef HAVE_MENUBARS | |
| 442 | 475 || (menu_entry_p && !menubar_show_keybindings) |
| 428 | 476 #endif |
| 477 ) | |
| 478 wv->key = 0; | |
| 479 else if (!NILP (pgui->keys)) /* Use this string to generate key bindings */ | |
| 480 { | |
| 481 CHECK_STRING (pgui->keys); | |
| 482 pgui->keys = Fsubstitute_command_keys (pgui->keys); | |
| 483 if (XSTRING_LENGTH (pgui->keys) > 0) | |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4677
diff
changeset
|
484 wv->key = LISP_STRING_TO_EXTERNAL_MALLOC (pgui->keys, Qlwlib_encoding); |
| 428 | 485 else |
| 486 wv->key = 0; | |
| 487 } | |
| 488 else if (SYMBOLP (pgui->callback)) /* Show the binding of this command. */ | |
| 489 { | |
| 793 | 490 DECLARE_EISTRING_MALLOC (buf); |
| 428 | 491 /* #### Warning, dependency here on current_buffer and point */ |
| 492 where_is_to_char (pgui->callback, buf); | |
| 793 | 493 if (eilen (buf) > 0) |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4677
diff
changeset
|
494 wv->key = ITEXT_TO_EXTERNAL_MALLOC (eidata (buf), Qlwlib_encoding); |
| 428 | 495 else |
| 496 wv->key = 0; | |
| 793 | 497 eifree (buf); |
| 428 | 498 } |
| 499 | |
| 500 CHECK_SYMBOL (pgui->style); | |
| 501 if (NILP (pgui->style)) | |
| 502 { | |
| 867 | 503 Ibyte *intname; |
| 2286 | 504 Bytecount unused_intlen; |
| 428 | 505 /* If the callback is nil, treat this item like unselectable text. |
| 506 This way, dashes will show up as a separator. */ | |
| 507 if (!wv->enabled) | |
| 508 wv->type = BUTTON_TYPE; | |
| 444 | 509 TO_INTERNAL_FORMAT (C_STRING, wv->name, |
| 2286 | 510 ALLOCA, (intname, unused_intlen), |
| 444 | 511 Qlwlib_encoding); |
| 442 | 512 if (separator_string_p (intname)) |
| 428 | 513 { |
| 514 wv->type = SEPARATOR_TYPE; | |
| 442 | 515 wv->value = menu_separator_style_and_to_external (intname); |
| 428 | 516 } |
| 517 else | |
| 518 { | |
| 519 #if 0 | |
| 520 /* #### - this is generally desirable for menubars, but it breaks | |
| 521 a package that uses dialog boxes and next_command_event magic | |
| 522 to use the callback slot in dialog buttons for data instead of | |
| 523 a real callback. | |
| 524 | |
| 525 Code is data, right? The beauty of LISP abuse. --Stig */ | |
| 526 if (NILP (callback)) | |
| 527 wv->type = TEXT_TYPE; | |
| 528 else | |
| 529 #endif | |
| 530 wv->type = BUTTON_TYPE; | |
| 531 } | |
| 532 } | |
| 533 else if (EQ (pgui->style, Qbutton)) | |
| 534 wv->type = BUTTON_TYPE; | |
| 535 else if (EQ (pgui->style, Qtoggle)) | |
| 536 wv->type = TOGGLE_TYPE; | |
| 537 else if (EQ (pgui->style, Qradio)) | |
| 538 wv->type = RADIO_TYPE; | |
| 539 else if (EQ (pgui->style, Qtext)) | |
| 540 { | |
| 541 wv->type = TEXT_TYPE; | |
| 542 #if 0 | |
| 543 wv->value = wv->name; | |
| 544 wv->name = "value"; | |
| 545 #endif | |
| 546 } | |
| 547 else | |
| 563 | 548 invalid_constant_2 ("Unknown style", pgui->style, gui_item); |
| 428 | 549 |
| 550 if (!allow_text_field_p && (wv->type == TEXT_TYPE)) | |
| 563 | 551 sferror ("Text field not allowed in this context", gui_item); |
| 428 | 552 |
| 553 if (!NILP (pgui->selected) && EQ (pgui->style, Qtext)) | |
| 563 | 554 sferror |
| 442 | 555 (":selected only makes sense with :style toggle, radio or button", |
| 556 gui_item); | |
| 428 | 557 return 1; |
| 558 } | |
| 559 | |
| 560 /* parse tree's of gui items into widget_value hierarchies */ | |
| 442 | 561 static void gui_item_children_to_widget_values (Lisp_Object |
| 562 gui_object_instance, | |
| 563 Lisp_Object items, | |
| 564 widget_value* parent, | |
| 565 int accel_p); | |
| 428 | 566 |
| 567 static widget_value * | |
| 442 | 568 gui_items_to_widget_values_1 (Lisp_Object gui_object_instance, |
| 569 Lisp_Object items, widget_value* parent, | |
| 570 widget_value* prev, int accel_p) | |
| 428 | 571 { |
| 572 widget_value* wv = 0; | |
| 573 | |
| 574 assert ((parent || prev) && !(parent && prev)); | |
| 575 /* now walk the tree creating widget_values as appropriate */ | |
| 576 if (!CONSP (items)) | |
| 577 { | |
| 442 | 578 wv = xmalloc_widget_value (); |
| 428 | 579 if (parent) |
| 580 parent->contents = wv; | |
| 440 | 581 else |
| 428 | 582 prev->next = wv; |
| 442 | 583 if (!button_item_to_widget_value (gui_object_instance, |
| 584 items, wv, 0, 1, 0, accel_p)) | |
| 428 | 585 { |
| 436 | 586 free_widget_value_tree (wv); |
| 428 | 587 if (parent) |
| 588 parent->contents = 0; | |
| 440 | 589 else |
| 428 | 590 prev->next = 0; |
| 591 } | |
| 440 | 592 else |
| 442 | 593 wv->value = xstrdup (wv->name); /* what a mess... */ |
| 428 | 594 } |
| 595 else | |
| 596 { | |
| 597 /* first one is the parent */ | |
| 598 if (CONSP (XCAR (items))) | |
| 563 | 599 sferror ("parent item must not be a list", XCAR (items)); |
| 428 | 600 |
| 601 if (parent) | |
| 442 | 602 wv = gui_items_to_widget_values_1 (gui_object_instance, |
| 603 XCAR (items), parent, 0, accel_p); | |
| 428 | 604 else |
| 442 | 605 wv = gui_items_to_widget_values_1 (gui_object_instance, |
| 606 XCAR (items), 0, prev, accel_p); | |
| 428 | 607 /* the rest are the children */ |
| 442 | 608 gui_item_children_to_widget_values (gui_object_instance, |
| 609 XCDR (items), wv, accel_p); | |
| 428 | 610 } |
| 611 return wv; | |
| 612 } | |
| 613 | |
| 614 static void | |
| 442 | 615 gui_item_children_to_widget_values (Lisp_Object gui_object_instance, |
| 616 Lisp_Object items, widget_value* parent, | |
| 617 int accel_p) | |
| 428 | 618 { |
| 619 widget_value* wv = 0, *prev = 0; | |
| 620 Lisp_Object rest; | |
| 621 CHECK_CONS (items); | |
| 622 | |
| 623 /* first one is master */ | |
| 442 | 624 prev = gui_items_to_widget_values_1 (gui_object_instance, XCAR (items), |
| 625 parent, 0, accel_p); | |
| 428 | 626 /* the rest are the children */ |
| 627 LIST_LOOP (rest, XCDR (items)) | |
| 628 { | |
| 629 Lisp_Object tab = XCAR (rest); | |
| 442 | 630 wv = gui_items_to_widget_values_1 (gui_object_instance, tab, 0, prev, |
| 631 accel_p); | |
| 428 | 632 prev = wv; |
| 633 } | |
| 634 } | |
| 635 | |
| 636 widget_value * | |
| 442 | 637 gui_items_to_widget_values (Lisp_Object gui_object_instance, Lisp_Object items, |
| 638 int accel_p) | |
| 428 | 639 { |
| 640 /* This function can GC */ | |
| 641 widget_value *control = 0, *tmp = 0; | |
| 771 | 642 int count; |
| 428 | 643 Lisp_Object wv_closure; |
| 644 | |
| 645 if (NILP (items)) | |
| 563 | 646 sferror ("must have some items", items); |
| 428 | 647 |
| 648 /* Inhibit GC during this conversion. The reasons for this are | |
| 649 the same as in menu_item_descriptor_to_widget_value(); see | |
| 650 the large comment above that function. */ | |
| 771 | 651 count = begin_gc_forbidden (); |
| 428 | 652 |
| 653 /* Also make sure that we free the partially-created widget_value | |
| 654 tree on Lisp error. */ | |
| 442 | 655 control = xmalloc_widget_value (); |
| 428 | 656 wv_closure = make_opaque_ptr (control); |
| 657 record_unwind_protect (widget_value_unwind, wv_closure); | |
| 658 | |
| 442 | 659 gui_items_to_widget_values_1 (gui_object_instance, items, control, 0, |
| 660 accel_p); | |
| 428 | 661 |
| 662 /* mess about getting the data we really want */ | |
| 663 tmp = control; | |
| 664 control = control->contents; | |
| 665 tmp->next = 0; | |
| 666 tmp->contents = 0; | |
| 436 | 667 free_widget_value_tree (tmp); |
| 428 | 668 |
| 669 /* No more need to free the half-filled-in structures. */ | |
| 670 set_opaque_ptr (wv_closure, 0); | |
| 771 | 671 unbind_to (count); |
| 428 | 672 |
| 673 return control; | |
| 674 } | |
| 675 | |
| 676 void | |
| 677 syms_of_gui_x (void) | |
| 678 { | |
| 679 } | |
| 680 | |
| 681 void | |
| 682 reinit_vars_of_gui_x (void) | |
| 683 { | |
| 684 lwlib_id_tick = (1<<16); /* start big, to not conflict with Energize */ | |
| 685 #ifdef HAVE_POPUPS | |
| 686 popup_up_p = 0; | |
| 687 #endif | |
| 688 } | |
| 689 | |
| 690 void | |
| 691 vars_of_gui_x (void) | |
| 692 { | |
| 693 Vpopup_callbacks = Qnil; | |
| 694 staticpro (&Vpopup_callbacks); | |
| 695 } |