Mercurial > hg > xemacs-beta
annotate src/gui-x.c @ 5602:c9e5612f5424
Support the MP library on recent FreeBSD, have it pass relevant tests.
src/ChangeLog addition:
2011-11-26 Aidan Kehoe <kehoea@parhasard.net>
* number-mp.c (bignum_to_string):
Don't overwrite the accumulator we've just set up for this
function.
* number-mp.c (BIGNUM_TO_TYPE):
mp_itom() doesn't necessarily do what this code used to think with
negative numbers, it can treat them as unsigned ints. Subtract
numbers from bignum_zero instead of multiplying them by -1 to
convert them to their negative equivalents.
* number-mp.c (bignum_to_int):
* number-mp.c (bignum_to_uint):
* number-mp.c (bignum_to_long):
* number-mp.c (bignum_to_ulong):
* number-mp.c (bignum_to_double):
Use the changed BIGNUM_TO_TYPE() in these functions.
* number-mp.c (bignum_ceil):
* number-mp.c (bignum_floor):
In these functions, be more careful about rounding to positive and
negative infinity, respectively. Don't use the sign of QUOTIENT
when working out out whether to add or subtract one, rather use
the sign QUOTIENT would have if arbitrary-precision division were
done.
* number-mp.h:
* number-mp.h (MP_GCD):
Wrap #include <mp.h> in BEGIN_C_DECLS/END_C_DECLS.
* number.c (Fbigfloat_get_precision):
* number.c (Fbigfloat_set_precision):
Don't attempt to call XBIGFLOAT_GET_PREC if this build doesn't
support big floats.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Sat, 26 Nov 2011 17:59:14 +0000 |
| 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 } |