Mercurial > hg > xemacs-beta
annotate src/menubar-x.c @ 5607:1a507c4c6c42
Refactor out sequence-oriented builtins from fns.c to the new sequence.c.
src/ChangeLog addition:
2011-12-04 Aidan Kehoe <kehoea@parhasard.net>
* Makefile.in.in (objs):
* depend:
Add sequence.o to the list of objects and dependencies.
* alloc.c:
* alloc.c (mark_bit_vector):
* alloc.c (print_bit_vector):
* alloc.c (bit_vector_equal):
* alloc.c (internal_bit_vector_equalp_hash):
* alloc.c (bit_vector_hash):
* alloc.c (init_alloc_once_early):
Move the implementation of the bit vector type here from fns.c.
* emacs.c (main_1):
Call syms_of_sequence() here, now sequence.c is included.
* fns.c (Fold_rassq):
Move this together with the rest of the Fold_* functions.
* fns.c:
* fns.c (syms_of_fns):
Move most functions dealing with sequences generally, and
especially those taking key arguments, to a separate file,
sequence.c.
* general-slots.h:
Qyes_or_no_p belong here, not fns.c.
* lisp.h:
Make Flist_length available here, it's used by sequence.c
* sequence.c:
* sequence.c (check_sequence_range):
* sequence.c (Flength):
* sequence.c (check_other_nokey):
* sequence.c (check_other_key):
* sequence.c (check_if_key):
* sequence.c (check_match_eq_key):
* sequence.c (check_match_eql_key):
* sequence.c (check_match_equal_key):
* sequence.c (check_match_equalp_key):
* sequence.c (check_match_other_key):
* sequence.c (check_lss_key):
* sequence.c (check_lss_key_car):
* sequence.c (check_string_lessp_key):
* sequence.c (check_string_lessp_key_car):
* sequence.c (get_check_match_function_1):
* sequence.c (get_merge_predicate):
* sequence.c (count_with_tail):
* sequence.c (list_count_from_end):
* sequence.c (string_count_from_end):
* sequence.c (Fcount):
* sequence.c (Fsubseq):
* sequence.c (list_position_cons_before):
* sequence.c (FmemberX):
* sequence.c (Fadjoin):
* sequence.c (FassocX):
* sequence.c (FrassocX):
* sequence.c (position):
* sequence.c (Fposition):
* sequence.c (Ffind):
* sequence.c (delq_no_quit_and_free_cons):
* sequence.c (FdeleteX):
* sequence.c (FremoveX):
* sequence.c (list_delete_duplicates_from_end):
* sequence.c (Fdelete_duplicates):
* sequence.c (Fremove_duplicates):
* sequence.c (Fnreverse):
* sequence.c (Freverse):
* sequence.c (list_merge):
* sequence.c (array_merge):
* sequence.c (list_array_merge_into_list):
* sequence.c (list_list_merge_into_array):
* sequence.c (list_array_merge_into_array):
* sequence.c (Fmerge):
* sequence.c (list_sort):
* sequence.c (array_sort):
* sequence.c (FsortX):
* sequence.c (Ffill):
* sequence.c (mapcarX):
* sequence.c (shortest_length_among_sequences):
* sequence.c (Fmapconcat):
* sequence.c (FmapcarX):
* sequence.c (Fmapvector):
* sequence.c (Fmapcan):
* sequence.c (Fmap):
* sequence.c (Fmap_into):
* sequence.c (Fsome):
* sequence.c (Fevery):
* sequence.c (Freduce):
* sequence.c (replace_string_range_1):
* sequence.c (Freplace):
* sequence.c (Fnsubstitute):
* sequence.c (Fsubstitute):
* sequence.c (subst):
* sequence.c (sublis):
* sequence.c (Fsublis):
* sequence.c (nsublis):
* sequence.c (Fnsublis):
* sequence.c (Fsubst):
* sequence.c (Fnsubst):
* sequence.c (tree_equal):
* sequence.c (Ftree_equal):
* sequence.c (mismatch_from_end):
* sequence.c (mismatch_list_list):
* sequence.c (mismatch_list_string):
* sequence.c (mismatch_list_array):
* sequence.c (mismatch_string_array):
* sequence.c (mismatch_string_string):
* sequence.c (mismatch_array_array):
* sequence.c (get_mismatch_func):
* sequence.c (Fmismatch):
* sequence.c (Fsearch):
* sequence.c (venn):
* sequence.c (nvenn):
* sequence.c (Funion):
* sequence.c (Fset_exclusive_or):
* sequence.c (Fnset_exclusive_or):
* sequence.c (syms_of_sequence):
Add this file, containing those general functions that dealt with
sequences that were in fns.c.
* symsinit.h:
Make syms_of_sequence() available here.
man/ChangeLog addition:
2011-12-04 Aidan Kehoe <kehoea@parhasard.net>
* internals/internals.texi (Basic Lisp Modules):
Document sequence.c here too.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Sun, 04 Dec 2011 18:42:50 +0000 |
| parents | 308d34e9f07d |
| children | 489e76b85828 |
| rev | line source |
|---|---|
| 428 | 1 /* Implements an elisp-programmable menubar -- X interface. |
| 2 Copyright (C) 1993, 1994 Free Software Foundation, Inc. | |
| 3 Copyright (C) 1995 Tinker Systems and INS Engineering Corp. | |
|
5050
6f2158fa75ed
Fix quick-build, use asserts() in place of ABORT()
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
4 Copyright (C) 2000, 2001, 2002, 2003, 2010 Ben Wing. |
| 428 | 5 |
| 6 This file is part of XEmacs. | |
| 7 | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5050
diff
changeset
|
8 XEmacs is free software: you can redistribute it and/or modify it |
| 428 | 9 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:
5050
diff
changeset
|
10 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:
5050
diff
changeset
|
11 option) any later version. |
| 428 | 12 |
| 13 XEmacs is distributed in the hope that it will be useful, but WITHOUT | |
| 14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
| 15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
| 16 for more details. | |
| 17 | |
| 18 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:
5050
diff
changeset
|
19 along with XEmacs. If not, see <http://www.gnu.org/licenses/>. */ |
| 428 | 20 |
| 21 /* Synched up with: Not in FSF. */ | |
| 22 | |
| 442 | 23 /* This file Mule-ized by Ben Wing, 7-8-00. */ |
| 24 | |
| 25 /* Authorship: | |
| 26 | |
| 27 Created 16-dec-91 by Jamie Zawinski. | |
| 28 Menu filters and many other keywords added by Stig for 19.12. | |
| 29 Original device-abstraction work and GC cleanup work by Ben Wing for 19.13. | |
| 30 Menu accelerators c. 1997? by ??. Moved here from event-stream.c. | |
| 31 Other work post-1996 by ??. | |
| 32 */ | |
| 428 | 33 |
| 34 #include <config.h> | |
| 35 #include "lisp.h" | |
| 36 | |
| 37 #include "buffer.h" | |
| 38 #include "commands.h" /* zmacs_regions */ | |
| 872 | 39 #include "device-impl.h" |
| 428 | 40 #include "events.h" |
| 872 | 41 #include "frame-impl.h" |
| 442 | 42 #include "gui.h" |
| 43 #include "keymap.h" | |
| 44 #include "menubar.h" | |
| 428 | 45 #include "opaque.h" |
| 872 | 46 #include "window-impl.h" |
| 428 | 47 |
| 872 | 48 #include "console-x-impl.h" |
| 800 | 49 |
| 50 #include "EmacsFrame.h" | |
| 51 #include "../lwlib/lwlib.h" | |
| 52 | |
| 428 | 53 static int set_frame_menubar (struct frame *f, |
| 54 int deep_p, | |
| 55 int first_time_p); | |
| 56 | |
| 57 #define MENUBAR_TYPE 0 | |
| 58 #define SUBMENU_TYPE 1 | |
| 59 #define POPUP_TYPE 2 | |
| 60 | |
| 61 | |
| 62 /* Converting Lisp menu tree descriptions to lwlib's `widget_value' form. | |
| 63 | |
| 64 menu_item_descriptor_to_widget_value() converts a lisp description of a | |
| 65 menubar into a tree of widget_value structures. It allocates widget_values | |
| 66 with malloc_widget_value() and allocates other storage only for the `key' | |
| 67 slot. All other slots are filled with pointers to Lisp_String data. We | |
| 68 allocate a widget_value description of the menu or menubar, and hand it to | |
| 69 lwlib, which then makes a copy of it, which it manages internally. We then | |
| 70 immediately free our widget_value tree; it will not be referenced again. | |
| 71 | |
| 72 Incremental menu construction callbacks operate just a bit differently. | |
| 73 They allocate widget_values and call replace_widget_value_tree() to tell | |
| 74 lwlib to destructively modify the incremental stub (subtree) of its | |
| 75 separate widget_value tree. | |
| 76 | |
| 77 This function is highly recursive (it follows the menu trees) and may call | |
| 78 eval. The reason we keep pointers to lisp string data instead of copying | |
| 79 it and freeing it later is to avoid the speed penalty that would entail | |
| 80 (since this needs to be fast, in the simple cases at least). (The reason | |
| 81 we malloc/free the keys slot is because there's not a lisp string around | |
| 82 for us to use in that case.) | |
| 83 | |
| 84 Since we keep pointers to lisp strings, and we call eval, we could lose if | |
| 85 GC relocates (or frees) those strings. It's not easy to gc protect the | |
| 86 strings because of the recursive nature of this function, and the fact that | |
| 87 it returns a data structure that gets freed later. So... we do the | |
| 88 sleaziest thing possible and inhibit GC for the duration. This is probably | |
| 89 not a big deal... | |
| 90 | |
| 91 We do not have to worry about the pointers to Lisp_String data after | |
| 92 this function successfully finishes. lwlib copies all such data with | |
| 93 strdup(). */ | |
| 94 | |
| 95 static widget_value * | |
| 96 menu_item_descriptor_to_widget_value_1 (Lisp_Object desc, | |
| 97 int menu_type, int deep_p, | |
| 98 int filter_p, | |
| 99 int depth) | |
| 100 { | |
| 101 /* This function cannot GC. | |
| 102 It is only called from menu_item_descriptor_to_widget_value, which | |
| 103 prohibits GC. */ | |
| 104 int menubar_root_p = (menu_type == MENUBAR_TYPE && depth == 0); | |
| 105 int count = specpdl_depth (); | |
| 106 int partition_seen = 0; | |
| 438 | 107 widget_value *wv = xmalloc_widget_value (); |
| 108 Lisp_Object wv_closure = make_opaque_ptr (wv); | |
| 428 | 109 |
| 110 record_unwind_protect (widget_value_unwind, wv_closure); | |
| 111 | |
| 112 if (STRINGP (desc)) | |
| 113 { | |
| 867 | 114 Ibyte *string_chars = XSTRING_DATA (desc); |
| 428 | 115 wv->type = (separator_string_p (string_chars) ? SEPARATOR_TYPE : |
| 116 TEXT_TYPE); | |
| 117 if (wv->type == SEPARATOR_TYPE) | |
| 118 { | |
| 442 | 119 wv->value = menu_separator_style_and_to_external (string_chars); |
| 428 | 120 } |
| 121 else | |
| 122 { | |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
123 wv->name = LISP_STRING_TO_EXTERNAL_MALLOC (desc, Qlwlib_encoding); |
| 428 | 124 wv->enabled = 1; |
| 125 /* dverna Dec. 98: command_builder_operate_menu_accelerator will | |
| 126 manipulate the accel as a Lisp_Object if the widget has a name. | |
| 127 Since simple labels have a name, but no accel, we *must* set it | |
| 128 to nil */ | |
| 5013 | 129 wv->accel = STORE_LISP_IN_VOID (Qnil); |
| 428 | 130 } |
| 131 } | |
| 132 else if (VECTORP (desc)) | |
| 133 { | |
| 134 Lisp_Object gui_item = gui_parse_item_keywords (desc); | |
| 442 | 135 if (!button_item_to_widget_value (Qmenubar, |
| 136 gui_item, wv, 1, | |
| 428 | 137 (menu_type == MENUBAR_TYPE |
| 442 | 138 && depth <= 1), 1, 1)) |
| 428 | 139 { |
| 140 /* :included form was nil */ | |
| 141 wv = NULL; | |
| 142 goto menu_item_done; | |
| 143 } | |
| 144 } | |
| 145 else if (CONSP (desc)) | |
| 146 { | |
| 147 Lisp_Object incremental_data = desc; | |
| 148 widget_value *prev = 0; | |
| 149 | |
| 150 if (STRINGP (XCAR (desc))) | |
| 151 { | |
| 152 Lisp_Object key, val; | |
| 153 Lisp_Object include_p = Qnil, hook_fn = Qnil, config_tag = Qnil; | |
| 154 Lisp_Object active_p = Qt; | |
| 155 Lisp_Object accel; | |
| 156 int included_spec = 0; | |
| 157 int active_spec = 0; | |
| 158 wv->type = CASCADE_TYPE; | |
| 159 wv->enabled = 1; | |
| 442 | 160 wv->name = add_accel_and_to_external (XCAR (desc)); |
| 428 | 161 |
| 442 | 162 accel = gui_name_accelerator (XCAR (desc)); |
| 5013 | 163 wv->accel = STORE_LISP_IN_VOID (accel); |
| 428 | 164 |
| 165 desc = Fcdr (desc); | |
| 166 | |
| 167 while (key = Fcar (desc), KEYWORDP (key)) | |
| 168 { | |
| 169 Lisp_Object cascade = desc; | |
| 170 desc = Fcdr (desc); | |
| 171 if (NILP (desc)) | |
| 563 | 172 sferror ("Keyword in menu lacks a value", cascade); |
| 428 | 173 val = Fcar (desc); |
| 174 desc = Fcdr (desc); | |
| 175 if (EQ (key, Q_included)) | |
| 176 include_p = val, included_spec = 1; | |
| 177 else if (EQ (key, Q_config)) | |
| 178 config_tag = val; | |
| 179 else if (EQ (key, Q_filter)) | |
| 180 hook_fn = val; | |
| 181 else if (EQ (key, Q_active)) | |
| 182 active_p = val, active_spec = 1; | |
| 183 else if (EQ (key, Q_accelerator)) | |
| 184 { | |
| 185 if ( SYMBOLP (val) | |
| 186 || CHARP (val)) | |
| 5013 | 187 wv->accel = STORE_LISP_IN_VOID (val); |
| 428 | 188 else |
| 563 | 189 invalid_argument ("bad keyboard accelerator", val); |
| 428 | 190 } |
| 191 else if (EQ (key, Q_label)) | |
| 192 { | |
| 193 /* implement in 21.2 */ | |
| 194 } | |
| 195 else | |
| 563 | 196 invalid_argument ("Unknown menu cascade keyword", cascade); |
| 428 | 197 } |
| 198 | |
| 199 if ((!NILP (config_tag) | |
| 200 && NILP (Fmemq (config_tag, Vmenubar_configuration))) | |
| 201 || (included_spec && NILP (Feval (include_p)))) | |
| 202 { | |
| 203 wv = NULL; | |
| 204 goto menu_item_done; | |
| 205 } | |
| 206 | |
| 207 if (active_spec) | |
| 208 active_p = Feval (active_p); | |
| 209 | |
| 210 if (!NILP (hook_fn) && !NILP (active_p)) | |
| 211 { | |
| 212 #if defined LWLIB_MENUBARS_LUCID || defined LWLIB_MENUBARS_MOTIF | |
| 213 if (filter_p || depth == 0) | |
| 214 { | |
| 215 #endif | |
| 853 | 216 desc = call1 (hook_fn, desc); |
| 428 | 217 if (UNBOUNDP (desc)) |
| 218 desc = Qnil; | |
| 219 #if defined LWLIB_MENUBARS_LUCID || defined LWLIB_MENUBARS_MOTIF | |
| 220 } | |
| 221 else | |
| 222 { | |
| 223 widget_value *incr_wv = xmalloc_widget_value (); | |
| 224 wv->contents = incr_wv; | |
| 225 incr_wv->type = INCREMENTAL_TYPE; | |
| 226 incr_wv->enabled = 1; | |
| 227 incr_wv->name = wv->name; | |
| 436 | 228 incr_wv->name = xstrdup (wv->name); |
| 428 | 229 /* This is automatically GC protected through |
| 230 the call to lw_map_widget_values(); no need | |
| 231 to worry. */ | |
| 5013 | 232 incr_wv->call_data = STORE_LISP_IN_VOID (incremental_data); |
| 428 | 233 goto menu_item_done; |
| 234 } | |
| 235 #endif /* LWLIB_MENUBARS_LUCID || LWLIB_MENUBARS_MOTIF */ | |
| 236 } | |
| 237 if (menu_type == POPUP_TYPE && popup_menu_titles && depth == 0) | |
| 238 { | |
| 239 /* Simply prepend three more widget values to the contents of | |
| 240 the menu: a label, and two separators (to get a double | |
| 241 line). */ | |
| 242 widget_value *title_wv = xmalloc_widget_value (); | |
| 243 widget_value *sep_wv = xmalloc_widget_value (); | |
| 244 title_wv->type = TEXT_TYPE; | |
| 436 | 245 title_wv->name = xstrdup (wv->name); |
| 428 | 246 title_wv->enabled = 1; |
| 247 title_wv->next = sep_wv; | |
| 248 sep_wv->type = SEPARATOR_TYPE; | |
| 867 | 249 sep_wv->value = menu_separator_style_and_to_external ((Ibyte *) "=="); |
| 428 | 250 sep_wv->next = 0; |
| 251 | |
| 252 wv->contents = title_wv; | |
| 253 prev = sep_wv; | |
| 254 } | |
| 255 wv->enabled = ! NILP (active_p); | |
| 256 if (deep_p && !wv->enabled && !NILP (desc)) | |
| 257 { | |
| 258 widget_value *dummy; | |
| 259 /* Add a fake entry so the menus show up */ | |
| 260 wv->contents = dummy = xmalloc_widget_value (); | |
| 436 | 261 dummy->name = xstrdup ("(inactive)"); |
| 5013 | 262 dummy->accel = STORE_LISP_IN_VOID (Qnil); |
| 428 | 263 dummy->enabled = 0; |
| 264 dummy->selected = 0; | |
| 265 dummy->value = NULL; | |
| 266 dummy->type = BUTTON_TYPE; | |
| 267 dummy->call_data = NULL; | |
| 268 dummy->next = NULL; | |
| 269 | |
| 270 goto menu_item_done; | |
| 442 | 271 } |
| 428 | 272 |
| 273 } | |
| 274 else if (menubar_root_p) | |
| 275 { | |
| 436 | 276 wv->name = xstrdup ("menubar"); |
| 428 | 277 wv->type = CASCADE_TYPE; /* Well, nothing else seems to fit and |
| 278 this is ignored anyway... */ | |
| 279 } | |
| 280 else | |
| 281 { | |
| 563 | 282 sferror ("Menu name (first element) must be a string", desc); |
| 428 | 283 } |
| 284 | |
| 285 if (deep_p || menubar_root_p) | |
| 286 { | |
| 287 widget_value *next; | |
| 288 for (; !NILP (desc); desc = Fcdr (desc)) | |
| 289 { | |
| 290 Lisp_Object child = Fcar (desc); | |
| 291 if (menubar_root_p && NILP (child)) /* the partition */ | |
| 292 { | |
| 293 if (partition_seen) | |
| 563 | 294 sferror |
| 442 | 295 ("More than one partition (nil) in menubar description", |
| 296 desc); | |
| 428 | 297 partition_seen = 1; |
| 298 next = xmalloc_widget_value (); | |
| 299 next->type = PUSHRIGHT_TYPE; | |
| 300 } | |
| 301 else | |
| 302 { | |
| 303 next = menu_item_descriptor_to_widget_value_1 | |
| 304 (child, menu_type, deep_p, filter_p, depth + 1); | |
| 305 } | |
| 306 if (! next) | |
| 307 continue; | |
| 308 else if (prev) | |
| 309 prev->next = next; | |
| 310 else | |
| 311 wv->contents = next; | |
| 312 prev = next; | |
| 313 } | |
| 314 } | |
| 315 if (deep_p && !wv->contents) | |
| 316 wv = NULL; | |
| 317 } | |
| 318 else if (NILP (desc)) | |
| 563 | 319 sferror ("nil may not appear in menu descriptions", desc); |
| 428 | 320 else |
| 563 | 321 sferror ("Unrecognized menu descriptor", desc); |
| 428 | 322 |
| 442 | 323 menu_item_done: |
| 428 | 324 |
| 325 if (wv) | |
| 326 { | |
| 327 /* Completed normally. Clear out the object that widget_value_unwind() | |
| 328 will be called with to tell it not to free the wv (as we are | |
| 329 returning it.) */ | |
| 330 set_opaque_ptr (wv_closure, 0); | |
| 331 } | |
| 332 | |
| 771 | 333 unbind_to (count); |
| 428 | 334 return wv; |
| 335 } | |
| 336 | |
| 853 | 337 struct menu_item_descriptor_to_widget_value |
| 338 { | |
| 339 Lisp_Object desc; | |
| 340 int menu_type, deep_p, filter_p; | |
| 341 widget_value *wv; | |
| 342 }; | |
| 428 | 343 |
| 344 static Lisp_Object | |
| 853 | 345 protected_menu_item_descriptor_to_widget_value_1 (void *gack) |
| 428 | 346 { |
| 853 | 347 struct menu_item_descriptor_to_widget_value *midtwv = |
| 348 (struct menu_item_descriptor_to_widget_value *) gack; | |
| 1918 | 349 int count = begin_gc_forbidden (); |
| 350 /* Can't GC! */ | |
| 351 midtwv->wv = menu_item_descriptor_to_widget_value_1 (midtwv->desc, | |
| 352 midtwv->menu_type, | |
| 353 midtwv->deep_p, | |
| 354 midtwv->filter_p, | |
| 355 0); | |
| 356 unbind_to (count); | |
| 442 | 357 return Qnil; |
| 428 | 358 } |
| 853 | 359 |
| 360 /* Inside of the pre_activate_callback, we absolutely need to protect | |
| 361 against errors, esp. but not exclusively in the filter code. (We do | |
| 362 other evalling, too.) We also need to reenable quit checking, which | |
| 363 was disabled by next_event_internal() so as to read C-g as an | |
| 364 event. */ | |
| 428 | 365 |
| 853 | 366 static widget_value * |
| 367 protected_menu_item_descriptor_to_widget_value (Lisp_Object desc, | |
| 368 int menu_type, int deep_p, | |
| 369 int filter_p) | |
| 428 | 370 { |
| 853 | 371 struct menu_item_descriptor_to_widget_value midtwv; |
| 1279 | 372 int depth = internal_bind_int (&in_menu_callback, 1); |
| 373 Lisp_Object retval; | |
| 428 | 374 |
| 853 | 375 midtwv.desc = desc; |
| 376 midtwv.menu_type = menu_type; | |
| 377 midtwv.deep_p = deep_p; | |
| 378 midtwv.filter_p = filter_p; | |
| 428 | 379 |
| 1279 | 380 retval = event_stream_protect_modal_loop |
| 381 ("Error during menu callback", | |
| 382 protected_menu_item_descriptor_to_widget_value_1, &midtwv, | |
| 383 UNINHIBIT_QUIT); | |
| 384 unbind_to (depth); | |
| 385 | |
| 386 if (UNBOUNDP (retval)) | |
| 853 | 387 return 0; |
| 388 | |
| 389 return midtwv.wv; | |
| 428 | 390 } |
| 853 | 391 |
| 1918 | 392 /* The two callers of menu_item_descriptor_to_widget_value may both run while |
| 393 in redisplay. Some descriptor to widget value conversions call Feval, and | |
| 394 at least one calls QUIT. Hence, we have to establish protection here.. */ | |
| 395 | |
| 396 static widget_value * | |
| 397 menu_item_descriptor_to_widget_value (Lisp_Object desc, | |
| 398 int menu_type, /* if this is a menubar, | |
| 399 popup or sub menu */ | |
| 400 int deep_p, /* */ | |
| 401 int filter_p) /* if :filter forms | |
| 402 should run now */ | |
| 403 { | |
| 404 struct menu_item_descriptor_to_widget_value midtwv; | |
| 405 Lisp_Object retval; | |
| 406 | |
| 407 midtwv.desc = desc; | |
| 408 midtwv.menu_type = menu_type; | |
| 409 midtwv.deep_p = deep_p; | |
| 410 midtwv.filter_p = filter_p; | |
| 411 | |
| 412 retval = call_trapping_problems | |
| 413 (Qevent, "Error during menu construction", 0, NULL, | |
| 414 protected_menu_item_descriptor_to_widget_value_1, &midtwv); | |
| 415 | |
| 416 if (UNBOUNDP (retval)) | |
| 417 return NULL; | |
| 418 | |
| 419 return midtwv.wv; | |
| 420 } | |
| 421 | |
| 428 | 422 /* The order in which callbacks are run is funny to say the least. |
| 423 It's sometimes tricky to avoid running a callback twice, and to | |
| 424 avoid returning prematurely. So, this function returns true | |
| 425 if the menu's callbacks are no longer gc protected. So long | |
| 426 as we unprotect them before allowing other callbacks to run, | |
| 427 everything should be ok. | |
| 428 | |
| 429 The pre_activate_callback() *IS* intentionally called multiple times. | |
| 430 If client_data == NULL, then it's being called before the menu is posted. | |
| 431 If client_data != NULL, then client_data is a (widget_value *) and | |
| 432 client_data->data is a Lisp_Object pointing to a lisp submenu description | |
| 433 that must be converted into widget_values. *client_data is destructively | |
| 434 modified. | |
| 435 | |
| 436 #### Stig thinks that there may be a GC problem here due to the | |
| 437 fact that pre_activate_callback() is called multiple times, but I | |
| 438 think he's wrong. | |
| 439 | |
| 440 */ | |
| 441 | |
| 442 static void | |
| 2286 | 443 pre_activate_callback (Widget widget, LWLIB_ID UNUSED (id), |
| 444 XtPointer client_data) | |
| 428 | 445 { |
| 446 /* This function can GC */ | |
| 447 struct device *d = get_device_from_display (XtDisplay (widget)); | |
| 448 struct frame *f = x_any_window_to_frame (d, XtWindow (widget)); | |
| 449 Lisp_Object frame; | |
| 450 | |
| 451 /* set in lwlib to the time stamp associated with the most recent menu | |
| 452 operation */ | |
| 453 extern Time x_focus_timestamp_really_sucks_fix_me_better; | |
| 454 | |
| 455 if (!f) | |
| 456 f = x_any_window_to_frame (d, XtWindow (XtParent (widget))); | |
| 457 if (!f) | |
| 458 return; | |
| 459 | |
| 460 /* make sure f is the selected frame */ | |
| 793 | 461 frame = wrap_frame (f); |
| 428 | 462 Fselect_frame (frame); |
| 463 | |
| 464 if (client_data) | |
| 465 { | |
| 466 /* this is an incremental menu construction callback */ | |
| 467 widget_value *hack_wv = (widget_value *) client_data; | |
| 468 Lisp_Object submenu_desc; | |
| 469 widget_value *wv; | |
| 470 | |
| 471 assert (hack_wv->type == INCREMENTAL_TYPE); | |
| 5013 | 472 submenu_desc = GET_LISP_FROM_VOID (hack_wv->call_data); |
| 428 | 473 |
| 853 | 474 wv = (protected_menu_item_descriptor_to_widget_value |
| 475 (submenu_desc, SUBMENU_TYPE, 1, 0)); | |
| 428 | 476 |
| 477 if (!wv) | |
| 478 { | |
| 479 wv = xmalloc_widget_value (); | |
| 480 wv->type = CASCADE_TYPE; | |
| 481 wv->next = NULL; | |
| 5013 | 482 wv->accel = STORE_LISP_IN_VOID (Qnil); |
| 428 | 483 wv->contents = xmalloc_widget_value (); |
| 484 wv->contents->type = TEXT_TYPE; | |
| 436 | 485 wv->contents->name = xstrdup ("No menu"); |
| 428 | 486 wv->contents->next = NULL; |
| 5013 | 487 wv->contents->accel = STORE_LISP_IN_VOID (Qnil); |
| 428 | 488 } |
| 489 assert (wv && wv->type == CASCADE_TYPE && wv->contents); | |
| 490 replace_widget_value_tree (hack_wv, wv->contents); | |
| 491 free_popup_widget_value_tree (wv); | |
| 1261 | 492 /* Now that we've destructively modified part of the widget value |
| 493 hierarchy, our list of protected callbacks will no longer be | |
| 494 valid, so we need to recompute it. */ | |
| 1346 | 495 gcpro_popup_callbacks (FRAME_X_MENUBAR_ID (f)); |
| 428 | 496 } |
| 1346 | 497 else if (!FRAME_X_MENUBAR_ID (f)) |
| 428 | 498 return; |
| 499 else | |
| 500 { | |
| 501 /* #### - It is necessary to *ALWAYS* call set_frame_menubar() now that | |
| 502 incremental menus are implemented. If a subtree of a menu has been | |
| 503 updated incrementally (a destructive operation), then that subtree | |
| 504 must somehow be wiped. | |
| 505 | |
| 506 It is difficult to undo the destructive operation in lwlib because | |
| 507 a pointer back to lisp data needs to be hidden away somewhere. So | |
| 508 that an INCREMENTAL_TYPE widget_value can be recreated... Hmmmmm. */ | |
| 853 | 509 run_hook_trapping_problems |
| 1333 | 510 (Qmenubar, Qactivate_menubar_hook, |
| 853 | 511 INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION); |
| 428 | 512 set_frame_menubar (f, 1, 0); |
| 513 DEVICE_X_MOUSE_TIMESTAMP (XDEVICE (FRAME_DEVICE (f))) = | |
| 514 DEVICE_X_GLOBAL_MOUSE_TIMESTAMP (XDEVICE (FRAME_DEVICE (f))) = | |
| 515 x_focus_timestamp_really_sucks_fix_me_better; | |
| 516 } | |
| 517 } | |
| 518 | |
| 519 static widget_value * | |
| 520 compute_menubar_data (struct frame *f, Lisp_Object menubar, int deep_p) | |
| 521 { | |
| 522 if (NILP (menubar)) | |
| 438 | 523 return 0; |
| 428 | 524 else |
| 525 { | |
| 438 | 526 widget_value *data; |
| 428 | 527 int count = specpdl_depth (); |
| 528 | |
| 438 | 529 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); |
| 530 Fset_buffer (XWINDOW (FRAME_SELECTED_WINDOW (f))->buffer); | |
| 428 | 531 data = menu_item_descriptor_to_widget_value (menubar, MENUBAR_TYPE, |
| 532 deep_p, 0); | |
| 771 | 533 unbind_to (count); |
| 438 | 534 |
| 535 return data; | |
| 428 | 536 } |
| 537 } | |
| 538 | |
| 539 static int | |
| 540 set_frame_menubar (struct frame *f, int deep_p, int first_time_p) | |
| 541 { | |
| 542 widget_value *data; | |
| 543 Lisp_Object menubar; | |
| 544 int menubar_visible; | |
| 545 long id; | |
| 438 | 546 /* As with the toolbar, the minibuffer does not have its own menubar. */ |
| 428 | 547 struct window *w = XWINDOW (FRAME_LAST_NONMINIBUF_WINDOW (f)); |
| 548 | |
| 549 if (! FRAME_X_P (f)) | |
| 550 return 0; | |
| 551 | |
| 552 /***** first compute the contents of the menubar *****/ | |
| 553 | |
| 554 if (! first_time_p) | |
| 555 { | |
| 556 /* evaluate `current-menubar' in the buffer of the selected window | |
| 557 of the frame in question. */ | |
| 558 menubar = symbol_value_in_buffer (Qcurrent_menubar, w->buffer); | |
| 559 } | |
| 560 else | |
| 561 { | |
| 562 /* That's a little tricky the first time since the frame isn't | |
| 563 fully initialized yet. */ | |
| 564 menubar = Fsymbol_value (Qcurrent_menubar); | |
| 565 } | |
| 566 | |
| 567 if (NILP (menubar)) | |
| 568 { | |
| 569 menubar = Vblank_menubar; | |
| 570 menubar_visible = 0; | |
| 571 } | |
| 572 else | |
| 573 menubar_visible = !NILP (w->menubar_visible_p); | |
| 574 | |
| 575 data = compute_menubar_data (f, menubar, deep_p); | |
|
5050
6f2158fa75ed
Fix quick-build, use asserts() in place of ABORT()
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
576 assert (data && (data->next || data->contents)); |
| 428 | 577 |
| 1346 | 578 if (!FRAME_X_MENUBAR_ID (f)) |
| 579 FRAME_X_MENUBAR_ID (f) = new_lwlib_id (); | |
| 428 | 580 |
| 581 /***** now store into the menubar widget, creating it if necessary *****/ | |
| 582 | |
| 1346 | 583 id = FRAME_X_MENUBAR_ID (f); |
| 428 | 584 if (!FRAME_X_MENUBAR_WIDGET (f)) |
| 585 { | |
| 586 Widget parent = FRAME_X_CONTAINER_WIDGET (f); | |
| 587 | |
| 588 assert (first_time_p); | |
| 589 | |
| 590 /* It's the first time we've mapped the menubar so compute its | |
| 591 contents completely once. This makes sure that the menubar | |
| 592 components are created with the right type. */ | |
| 593 if (!deep_p) | |
| 594 { | |
| 595 free_popup_widget_value_tree (data); | |
| 596 data = compute_menubar_data (f, menubar, 1); | |
| 597 } | |
| 598 | |
| 599 | |
| 600 FRAME_X_MENUBAR_WIDGET (f) = | |
| 601 lw_create_widget ("menubar", "menubar", id, data, parent, | |
| 602 0, pre_activate_callback, | |
| 603 popup_selection_callback, 0); | |
| 604 | |
| 605 } | |
| 606 else | |
| 607 { | |
| 608 lw_modify_all_widgets (id, data, deep_p ? True : False); | |
| 609 } | |
| 610 free_popup_widget_value_tree (data); | |
| 611 | |
| 1261 | 612 /* Buried inside of the lwlib data are pointers to Lisp objects that may |
| 613 have been freshly created. They need to be GC-protected, so snarf them | |
| 614 now and record them into the popup-data object associated with the | |
| 615 frame. */ | |
| 1346 | 616 gcpro_popup_callbacks (id); |
| 1261 | 617 |
| 1346 | 618 FRAME_X_MENUBAR_CONTENTS_UP_TO_DATE (f) = deep_p; |
| 619 FRAME_X_LAST_MENUBAR_BUFFER (f) = | |
| 428 | 620 XWINDOW (FRAME_LAST_NONMINIBUF_WINDOW (f))->buffer; |
| 621 return menubar_visible; | |
| 622 } | |
| 623 | |
| 624 | |
| 625 /* Called from x_create_widgets() to create the initial menubar of a frame | |
| 626 before it is mapped, so that the window is mapped with the menubar already | |
| 627 there instead of us tacking it on later and thrashing the window after it | |
| 628 is visible. */ | |
| 629 int | |
| 630 x_initialize_frame_menubar (struct frame *f) | |
| 631 { | |
| 632 return set_frame_menubar (f, 1, 1); | |
| 633 } | |
| 634 | |
| 635 | |
| 636 static LWLIB_ID last_popup_menu_selection_callback_id; | |
| 637 | |
| 638 static void | |
| 639 popup_menu_selection_callback (Widget widget, LWLIB_ID id, | |
| 640 XtPointer client_data) | |
| 641 { | |
| 642 last_popup_menu_selection_callback_id = id; | |
| 643 popup_selection_callback (widget, id, client_data); | |
| 644 /* lw_destroy_all_widgets() will be called from popup_down_callback() */ | |
| 645 } | |
| 646 | |
| 647 static void | |
| 2286 | 648 popup_menu_down_callback (Widget widget, LWLIB_ID id, |
| 649 XtPointer UNUSED (client_data)) | |
| 428 | 650 { |
| 651 if (popup_handled_p (id)) | |
| 652 return; | |
| 653 assert (popup_up_p != 0); | |
| 654 ungcpro_popup_callbacks (id); | |
| 655 popup_up_p--; | |
| 656 /* if this isn't called immediately after the selection callback, then | |
| 657 there wasn't a menu selection. */ | |
| 658 if (id != last_popup_menu_selection_callback_id) | |
| 659 popup_selection_callback (widget, id, (XtPointer) -1); | |
| 660 lw_destroy_all_widgets (id); | |
| 661 } | |
| 662 | |
| 663 | |
| 664 static void | |
| 440 | 665 make_dummy_xbutton_event (XEvent *dummy, Widget daddy, Lisp_Event *eev) |
| 428 | 666 /* NULL for eev means query pointer */ |
| 667 { | |
| 668 XButtonPressedEvent *btn = (XButtonPressedEvent *) dummy; | |
| 669 | |
| 670 btn->type = ButtonPress; | |
| 671 btn->serial = 0; | |
| 672 btn->send_event = 0; | |
| 673 btn->display = XtDisplay (daddy); | |
| 674 btn->window = XtWindow (daddy); | |
| 675 if (eev) | |
| 676 { | |
| 677 Position shellx, shelly, framex, framey; | |
| 678 Arg al [2]; | |
| 934 | 679 btn->time = EVENT_TIMESTAMP (eev); |
| 1204 | 680 btn->button = EVENT_BUTTON_BUTTON (eev); |
| 934 | 681 btn->root = RootWindowOfScreen (XtScreen (daddy)); |
| 682 btn->subwindow = (Window) NULL; | |
| 1204 | 683 btn->x = EVENT_BUTTON_X (eev); |
| 684 btn->y = EVENT_BUTTON_Y (eev); | |
| 428 | 685 shellx = shelly = 0; |
| 686 #ifndef HAVE_WMCOMMAND | |
| 687 { | |
| 688 Widget shell = XtParent (daddy); | |
| 689 | |
|
4528
726060ee587c
First draft of g++ 4.3 warning removal patch. Builds. *Needs ChangeLogs.*
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4522
diff
changeset
|
690 Xt_SET_ARG (al [0], XtNx, &shellx); |
|
726060ee587c
First draft of g++ 4.3 warning removal patch. Builds. *Needs ChangeLogs.*
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4522
diff
changeset
|
691 Xt_SET_ARG (al [1], XtNy, &shelly); |
| 428 | 692 XtGetValues (shell, al, 2); |
| 693 } | |
| 438 | 694 #endif |
|
4528
726060ee587c
First draft of g++ 4.3 warning removal patch. Builds. *Needs ChangeLogs.*
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4522
diff
changeset
|
695 Xt_SET_ARG (al [0], XtNx, &framex); |
|
726060ee587c
First draft of g++ 4.3 warning removal patch. Builds. *Needs ChangeLogs.*
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4522
diff
changeset
|
696 Xt_SET_ARG (al [1], XtNy, &framey); |
| 428 | 697 XtGetValues (daddy, al, 2); |
| 698 btn->x_root = shellx + framex + btn->x; | |
| 699 btn->y_root = shelly + framey + btn->y; | |
| 700 btn->state = ButtonPressMask; /* all buttons pressed */ | |
| 701 } | |
| 702 else | |
| 703 { | |
| 704 /* CurrentTime is just ZERO, so it's worthless for | |
| 705 determining relative click times. */ | |
| 706 struct device *d = get_device_from_display (XtDisplay (daddy)); | |
| 707 btn->time = DEVICE_X_MOUSE_TIMESTAMP (d); /* event-Xt maintains this */ | |
| 708 btn->button = 0; | |
| 709 XQueryPointer (btn->display, btn->window, &btn->root, | |
| 710 &btn->subwindow, &btn->x_root, &btn->y_root, | |
| 711 &btn->x, &btn->y, &btn->state); | |
| 712 } | |
| 713 } | |
| 714 | |
| 715 | |
| 716 | |
| 717 static void | |
| 718 x_update_frame_menubar_internal (struct frame *f) | |
| 719 { | |
| 720 /* We assume the menubar contents has changed if the global flag is set, | |
| 721 or if the current buffer has changed, or if the menubar has never | |
| 722 been updated before. | |
| 723 */ | |
| 724 int menubar_contents_changed = | |
| 725 (f->menubar_changed | |
| 1346 | 726 || !FRAME_X_MENUBAR_ID (f) |
| 727 || (!EQ (FRAME_X_LAST_MENUBAR_BUFFER (f), | |
| 428 | 728 XWINDOW (FRAME_LAST_NONMINIBUF_WINDOW (f))->buffer))); |
| 729 | |
| 730 Boolean menubar_was_visible = XtIsManaged (FRAME_X_MENUBAR_WIDGET (f)); | |
| 731 Boolean menubar_will_be_visible = menubar_was_visible; | |
| 732 Boolean menubar_visibility_changed; | |
| 733 | |
| 734 if (menubar_contents_changed) | |
| 735 menubar_will_be_visible = set_frame_menubar (f, 0, 0); | |
| 736 | |
| 737 menubar_visibility_changed = menubar_was_visible != menubar_will_be_visible; | |
| 738 | |
| 739 if (!menubar_visibility_changed) | |
| 740 return; | |
| 741 | |
| 742 /* Set menubar visibility */ | |
| 743 (menubar_will_be_visible ? XtManageChild : XtUnmanageChild) | |
| 744 (FRAME_X_MENUBAR_WIDGET (f)); | |
| 745 | |
| 746 MARK_FRAME_SIZE_SLIPPED (f); | |
| 747 } | |
| 748 | |
| 749 static void | |
| 750 x_update_frame_menubars (struct frame *f) | |
| 751 { | |
| 752 assert (FRAME_X_P (f)); | |
| 753 | |
| 754 x_update_frame_menubar_internal (f); | |
| 755 | |
| 756 /* #### This isn't going to work right now that this function works on | |
| 757 a per-frame, not per-device basis. Guess what? I don't care. */ | |
| 758 } | |
| 759 | |
| 760 static void | |
| 761 x_free_frame_menubars (struct frame *f) | |
| 762 { | |
| 763 Widget menubar_widget; | |
| 764 | |
| 765 assert (FRAME_X_P (f)); | |
| 766 | |
| 767 menubar_widget = FRAME_X_MENUBAR_WIDGET (f); | |
| 768 if (menubar_widget) | |
| 769 { | |
| 1346 | 770 LWLIB_ID id = FRAME_X_MENUBAR_ID (f); |
| 428 | 771 lw_destroy_all_widgets (id); |
| 1346 | 772 ungcpro_popup_callbacks (id); |
| 773 FRAME_X_MENUBAR_ID (f) = 0; | |
| 428 | 774 } |
| 775 } | |
| 776 | |
| 777 static void | |
| 778 x_popup_menu (Lisp_Object menu_desc, Lisp_Object event) | |
| 779 { | |
| 780 int menu_id; | |
| 781 struct frame *f = selected_frame (); | |
| 782 widget_value *data; | |
| 783 Widget parent; | |
| 784 Widget menu; | |
| 440 | 785 Lisp_Event *eev = NULL; |
| 428 | 786 XEvent xev; |
| 793 | 787 Lisp_Object frame = wrap_frame (f); |
| 428 | 788 |
| 789 CHECK_X_FRAME (frame); | |
| 790 parent = FRAME_X_SHELL_WIDGET (f); | |
| 791 | |
| 792 if (!NILP (event)) | |
| 793 { | |
| 794 CHECK_LIVE_EVENT (event); | |
| 795 eev= XEVENT (event); | |
| 796 if (eev->event_type != button_press_event | |
| 797 && eev->event_type != button_release_event) | |
| 798 wrong_type_argument (Qmouse_event_p, event); | |
| 799 } | |
| 800 else if (!NILP (Vthis_command_keys)) | |
| 801 { | |
| 802 /* if an event wasn't passed, use the last event of the event sequence | |
| 803 currently being executed, if that event is a mouse event */ | |
| 804 eev = XEVENT (Vthis_command_keys); /* last event first */ | |
| 805 if (eev->event_type != button_press_event | |
| 806 && eev->event_type != button_release_event) | |
| 807 eev = NULL; | |
| 808 } | |
| 809 make_dummy_xbutton_event (&xev, parent, eev); | |
| 810 | |
| 811 if (SYMBOLP (menu_desc)) | |
| 812 menu_desc = Fsymbol_value (menu_desc); | |
| 813 CHECK_CONS (menu_desc); | |
| 814 CHECK_STRING (XCAR (menu_desc)); | |
| 815 data = menu_item_descriptor_to_widget_value (menu_desc, POPUP_TYPE, 1, 1); | |
| 816 | |
| 563 | 817 if (! data) signal_error (Qgui_error, "no menu", Qunbound); |
| 428 | 818 |
| 819 menu_id = new_lwlib_id (); | |
| 820 menu = lw_create_widget ("popup", "popup" /* data->name */, menu_id, data, | |
| 821 parent, 1, 0, | |
| 822 popup_menu_selection_callback, | |
| 823 popup_menu_down_callback); | |
| 824 free_popup_widget_value_tree (data); | |
| 825 | |
| 826 gcpro_popup_callbacks (menu_id); | |
| 827 | |
| 828 /* Setting zmacs-region-stays is necessary here because executing a command | |
| 829 from a menu is really a two-command process: the first command (bound to | |
| 830 the button-click) simply pops up the menu, and returns. This causes a | |
| 831 sequence of magic-events (destined for the popup-menu widget) to begin. | |
| 832 Eventually, a menu item is selected, and a menu-event blip is pushed onto | |
| 833 the end of the input stream, which is then executed by the event loop. | |
| 834 | |
| 835 So there are two command-events, with a bunch of magic-events between | |
| 836 them. We don't want the *first* command event to alter the state of the | |
| 837 region, so that the region can be available as an argument for the second | |
| 838 command. | |
| 442 | 839 */ |
| 428 | 840 if (zmacs_regions) |
| 841 zmacs_region_stays = 1; | |
| 842 | |
| 843 popup_up_p++; | |
| 844 lw_popup_menu (menu, &xev); | |
| 845 /* this speeds up display of pop-up menus */ | |
| 846 XFlush (XtDisplay (parent)); | |
| 847 } | |
| 848 | |
| 849 | |
| 442 | 850 |
| 851 #if defined(LWLIB_MENUBARS_LUCID) | |
| 852 static void | |
| 853 menu_move_up (void) | |
| 854 { | |
| 855 widget_value *current = lw_get_entries (False); | |
| 856 widget_value *entries = lw_get_entries (True); | |
| 857 widget_value *prev = NULL; | |
| 858 | |
| 859 while (entries != current) | |
| 860 { | |
| 861 if (entries->name /*&& entries->enabled*/) prev = entries; | |
| 862 entries = entries->next; | |
| 863 assert (entries); | |
| 864 } | |
| 865 | |
| 866 if (!prev) | |
| 867 /* move to last item */ | |
| 868 { | |
| 869 while (entries->next) | |
| 870 { | |
| 871 if (entries->name /*&& entries->enabled*/) prev = entries; | |
| 872 entries = entries->next; | |
| 873 } | |
| 874 if (prev) | |
| 875 { | |
| 876 if (entries->name /*&& entries->enabled*/) | |
| 877 prev = entries; | |
| 878 } | |
| 879 else | |
| 880 { | |
| 881 /* no selectable items in this menu, pop up to previous level */ | |
| 882 lw_pop_menu (); | |
| 883 return; | |
| 884 } | |
| 885 } | |
| 886 lw_set_item (prev); | |
| 887 } | |
| 888 | |
| 889 static void | |
| 890 menu_move_down (void) | |
| 891 { | |
| 892 widget_value *current = lw_get_entries (False); | |
| 3025 | 893 widget_value *new_ = current; |
| 442 | 894 |
| 3025 | 895 while (new_->next) |
| 442 | 896 { |
| 3025 | 897 new_ = new_->next; |
| 898 if (new_->name /*&& new_->enabled*/) break; | |
| 442 | 899 } |
| 900 | |
| 3025 | 901 if (new_==current||!(new_->name/*||new_->enabled*/)) |
| 442 | 902 { |
| 3025 | 903 new_ = lw_get_entries (True); |
| 904 while (new_!=current) | |
| 442 | 905 { |
| 3025 | 906 if (new_->name /*&& new_->enabled*/) break; |
| 907 new_ = new_->next; | |
| 442 | 908 } |
| 3025 | 909 if (new_==current&&!(new_->name /*|| new_->enabled*/)) |
| 442 | 910 { |
| 911 lw_pop_menu (); | |
| 912 return; | |
| 913 } | |
| 914 } | |
| 915 | |
| 3025 | 916 lw_set_item (new_); |
| 442 | 917 } |
| 918 | |
| 919 static void | |
| 920 menu_move_left (void) | |
| 921 { | |
| 922 int level = lw_menu_level (); | |
| 923 int l = level; | |
| 924 widget_value *current; | |
| 925 | |
| 926 while (level-- >= 3) | |
| 927 lw_pop_menu (); | |
| 928 | |
| 929 menu_move_up (); | |
| 930 current = lw_get_entries (False); | |
| 931 if (l > 2 && current->contents) | |
| 932 lw_push_menu (current->contents); | |
| 933 } | |
| 934 | |
| 935 static void | |
| 936 menu_move_right (void) | |
| 937 { | |
| 938 int level = lw_menu_level (); | |
| 939 int l = level; | |
| 940 widget_value *current; | |
| 941 | |
| 942 while (level-- >= 3) | |
| 943 lw_pop_menu (); | |
| 944 | |
| 945 menu_move_down (); | |
| 946 current = lw_get_entries (False); | |
| 947 if (l > 2 && current->contents) | |
| 948 lw_push_menu (current->contents); | |
| 949 } | |
| 950 | |
| 951 static void | |
| 952 menu_select_item (widget_value *val) | |
| 953 { | |
| 954 if (val == NULL) | |
| 955 val = lw_get_entries (False); | |
| 956 | |
| 957 /* is match a submenu? */ | |
| 958 | |
| 959 if (val->contents) | |
| 960 { | |
| 961 /* enter the submenu */ | |
| 962 | |
| 963 lw_set_item (val); | |
| 964 lw_push_menu (val->contents); | |
| 965 } | |
| 966 else | |
| 967 { | |
| 968 /* Execute the menu entry by calling the menu's `select' | |
| 969 callback function | |
| 970 */ | |
| 971 lw_kill_menus (val); | |
| 972 } | |
| 973 } | |
| 974 | |
| 975 Lisp_Object | |
| 976 command_builder_operate_menu_accelerator (struct command_builder *builder) | |
| 977 { | |
| 978 /* this function can GC */ | |
| 979 | |
| 980 struct console *con = XCONSOLE (Vselected_console); | |
| 981 Lisp_Object evee = builder->most_current_event; | |
| 982 Lisp_Object binding; | |
| 983 widget_value *entries; | |
| 984 | |
| 985 extern int lw_menu_accelerate; /* lwlib.c */ | |
| 986 | |
| 987 #if 0 | |
| 988 { | |
| 989 int i; | |
| 990 Lisp_Object t; | |
| 991 | |
| 992 t = builder->current_events; | |
| 993 i = 0; | |
| 994 while (!NILP (t)) | |
| 995 { | |
| 996 i++; | |
| 800 | 997 write_fmt_string (Qexternal_debugging_output, "OPERATE (%d): ",i); |
| 442 | 998 print_internal (t, Qexternal_debugging_output, 1); |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4528
diff
changeset
|
999 write_ascstring (Qexternal_debugging_output, "\n"); |
| 442 | 1000 t = XEVENT_NEXT (t); |
| 1001 } | |
| 1002 } | |
| 1003 #endif /* 0 */ | |
| 1004 | |
| 1005 /* menu accelerator keys don't go into keyboard macros */ | |
| 1006 if (!NILP (con->defining_kbd_macro) && NILP (Vexecuting_macro)) | |
| 1007 con->kbd_macro_ptr = con->kbd_macro_end; | |
| 1008 | |
| 1009 /* don't echo menu accelerator keys */ | |
| 1010 /*reset_key_echo (builder, 1);*/ | |
| 1011 | |
| 1012 if (!lw_menu_accelerate) | |
| 1013 { | |
| 1014 /* `convert' mouse display to keyboard display | |
| 1015 by entering the open submenu | |
| 1016 */ | |
| 1017 entries = lw_get_entries (False); | |
| 1018 if (entries->contents) | |
| 1019 { | |
| 1020 lw_push_menu (entries->contents); | |
| 1021 lw_display_menu (CurrentTime); | |
| 1022 } | |
| 1023 } | |
| 1024 | |
| 1025 /* compare event to the current menu accelerators */ | |
| 1026 | |
| 1027 entries=lw_get_entries (True); | |
| 1028 | |
| 1029 while (entries) | |
| 1030 { | |
| 1031 Lisp_Object accel; | |
| 5013 | 1032 accel = GET_LISP_FROM_VOID (entries->accel); |
| 442 | 1033 if (entries->name && !NILP (accel)) |
| 1034 { | |
| 1204 | 1035 if (event_matches_key_specifier_p (evee, accel)) |
| 442 | 1036 { |
| 1037 /* a match! */ | |
| 1038 | |
| 1039 menu_select_item (entries); | |
| 1040 | |
| 1041 if (lw_menu_active) lw_display_menu (CurrentTime); | |
| 1042 | |
| 1043 reset_this_command_keys (Vselected_console, 1); | |
| 1044 /*reset_command_builder_event_chain (builder);*/ | |
| 1045 return Vmenu_accelerator_map; | |
| 1046 } | |
| 1047 } | |
| 1048 entries = entries->next; | |
| 1049 } | |
| 1050 | |
| 1051 /* try to look up event in menu-accelerator-map */ | |
| 1052 | |
| 1053 binding = event_binding_in (evee, Vmenu_accelerator_map, 1); | |
| 1054 | |
| 1055 if (NILP (binding)) | |
| 1056 { | |
| 1057 /* beep at user for undefined key */ | |
| 1058 return Qnil; | |
| 1059 } | |
| 1060 else | |
| 1061 { | |
| 1062 if (EQ (binding, Qmenu_quit)) | |
| 1063 { | |
| 1064 /* turn off menus and set quit flag */ | |
| 1065 lw_kill_menus (NULL); | |
| 1066 Vquit_flag = Qt; | |
| 1067 } | |
| 1068 else if (EQ (binding, Qmenu_up)) | |
| 1069 { | |
| 1070 int level = lw_menu_level (); | |
| 1071 if (level > 2) | |
| 1072 menu_move_up (); | |
| 1073 } | |
| 1074 else if (EQ (binding, Qmenu_down)) | |
| 1075 { | |
| 1076 int level = lw_menu_level (); | |
| 1077 if (level > 2) | |
| 1078 menu_move_down (); | |
| 1079 else | |
| 1080 menu_select_item (NULL); | |
| 1081 } | |
| 1082 else if (EQ (binding, Qmenu_left)) | |
| 1083 { | |
| 1084 int level = lw_menu_level (); | |
| 1085 if (level > 3) | |
| 1086 { | |
| 1087 lw_pop_menu (); | |
| 1088 lw_display_menu (CurrentTime); | |
| 1089 } | |
| 1090 else | |
| 1091 menu_move_left (); | |
| 1092 } | |
| 1093 else if (EQ (binding, Qmenu_right)) | |
| 1094 { | |
| 1095 int level = lw_menu_level (); | |
| 1096 if (level > 2 && | |
| 1097 lw_get_entries (False)->contents) | |
| 1098 { | |
| 1099 widget_value *current = lw_get_entries (False); | |
| 1100 if (current->contents) | |
| 1101 menu_select_item (NULL); | |
| 1102 } | |
| 1103 else | |
| 1104 menu_move_right (); | |
| 1105 } | |
| 1106 else if (EQ (binding, Qmenu_select)) | |
| 1107 menu_select_item (NULL); | |
| 1108 else if (EQ (binding, Qmenu_escape)) | |
| 1109 { | |
| 1110 int level = lw_menu_level (); | |
| 1111 | |
| 1112 if (level > 2) | |
| 1113 { | |
| 1114 lw_pop_menu (); | |
| 1115 lw_display_menu (CurrentTime); | |
| 1116 } | |
| 1117 else | |
| 1118 { | |
| 1119 /* turn off menus quietly */ | |
| 1120 lw_kill_menus (NULL); | |
| 1121 } | |
| 1122 } | |
| 1123 else if (KEYMAPP (binding)) | |
| 1124 { | |
| 1125 /* prefix key */ | |
| 1126 reset_this_command_keys (Vselected_console, 1); | |
| 1127 /*reset_command_builder_event_chain (builder);*/ | |
| 1128 return binding; | |
| 1129 } | |
| 1130 else | |
| 1131 { | |
| 1132 /* turn off menus and execute binding */ | |
| 1133 lw_kill_menus (NULL); | |
| 1134 reset_this_command_keys (Vselected_console, 1); | |
| 1135 /*reset_command_builder_event_chain (builder);*/ | |
| 1136 return binding; | |
| 1137 } | |
| 1138 } | |
| 1139 | |
| 1140 if (lw_menu_active) lw_display_menu (CurrentTime); | |
| 1141 | |
| 1142 reset_this_command_keys (Vselected_console, 1); | |
| 1143 /*reset_command_builder_event_chain (builder);*/ | |
| 1144 | |
| 1145 return Vmenu_accelerator_map; | |
| 1146 } | |
| 1147 | |
| 1148 static Lisp_Object | |
| 2286 | 1149 menu_accelerator_junk_on_error (Lisp_Object errordata, |
| 1150 Lisp_Object UNUSED (ignored)) | |
| 442 | 1151 { |
| 1152 Vmenu_accelerator_prefix = Qnil; | |
| 1153 Vmenu_accelerator_modifiers = Qnil; | |
| 1154 Vmenu_accelerator_enabled = Qnil; | |
| 1155 if (!NILP (errordata)) | |
| 1156 { | |
| 1157 /* #### This should call | |
| 1158 (with-output-to-string (display-error errordata)) | |
| 1159 but that stuff is all in Lisp currently. */ | |
| 1160 warn_when_safe_lispobj | |
| 1161 (Qerror, Qwarning, | |
| 771 | 1162 emacs_sprintf_string_lisp |
| 1163 ("%s: %s", Qnil, 2, | |
| 1164 build_msg_string ("Error in menu accelerators (setting to nil)"), | |
| 1165 errordata)); | |
| 442 | 1166 } |
| 1167 | |
| 1168 return Qnil; | |
| 1169 } | |
| 1170 | |
| 1171 static Lisp_Object | |
| 1172 menu_accelerator_safe_compare (Lisp_Object event0) | |
| 1173 { | |
| 1174 if (CONSP (Vmenu_accelerator_prefix)) | |
| 1175 { | |
| 1176 Lisp_Object t; | |
| 1177 t=Vmenu_accelerator_prefix; | |
| 1178 while (!NILP (t) | |
| 1179 && !NILP (event0) | |
| 1204 | 1180 && event_matches_key_specifier_p (event0, Fcar (t))) |
| 442 | 1181 { |
| 1182 t = Fcdr (t); | |
| 1183 event0 = XEVENT_NEXT (event0); | |
| 1184 } | |
| 1185 if (!NILP (t)) | |
| 1186 return Qnil; | |
| 1187 } | |
| 1188 else if (NILP (event0)) | |
| 1189 return Qnil; | |
| 1204 | 1190 else if (event_matches_key_specifier_p (event0, Vmenu_accelerator_prefix)) |
| 442 | 1191 event0 = XEVENT_NEXT (event0); |
| 1192 else | |
| 1193 return Qnil; | |
| 1194 return event0; | |
| 1195 } | |
| 1196 | |
| 1197 static Lisp_Object | |
| 1198 menu_accelerator_safe_mod_compare (Lisp_Object cons) | |
| 1199 { | |
| 1204 | 1200 return (event_matches_key_specifier_p (XCAR (cons), XCDR (cons)) ? Qt |
| 442 | 1201 : Qnil); |
| 1202 } | |
| 1203 | |
| 1204 Lisp_Object | |
| 1205 command_builder_find_menu_accelerator (struct command_builder *builder) | |
| 1206 { | |
| 1207 /* this function can GC */ | |
| 1208 Lisp_Object event0 = builder->current_events; | |
| 1209 struct console *con = XCONSOLE (Vselected_console); | |
| 1210 struct frame *f = XFRAME (CONSOLE_SELECTED_FRAME (con)); | |
| 1211 Widget menubar_widget; | |
| 1212 | |
| 1213 /* compare entries in event0 against the menu prefix */ | |
| 1214 | |
| 1215 if ((!CONSOLE_X_P (XCONSOLE (builder->console))) || NILP (event0) || | |
| 1216 XEVENT (event0)->event_type != key_press_event) | |
| 1217 return Qnil; | |
| 1218 | |
| 1219 if (!NILP (Vmenu_accelerator_prefix)) | |
| 1220 { | |
| 1221 event0 = condition_case_1 (Qerror, | |
| 1222 menu_accelerator_safe_compare, | |
| 1223 event0, | |
| 1224 menu_accelerator_junk_on_error, | |
| 1225 Qnil); | |
| 1226 } | |
| 1227 | |
| 1228 if (NILP (event0)) | |
| 1229 return Qnil; | |
| 1230 | |
| 1231 menubar_widget = FRAME_X_MENUBAR_WIDGET (f); | |
| 1232 if (menubar_widget | |
| 1233 && CONSP (Vmenu_accelerator_modifiers)) | |
| 1234 { | |
| 446 | 1235 Lisp_Object fake = Qnil; |
| 442 | 1236 Lisp_Object last = Qnil; |
| 1237 struct gcpro gcpro1; | |
| 1238 Lisp_Object matchp; | |
| 1239 | |
| 1240 widget_value *val; | |
| 1346 | 1241 LWLIB_ID id = FRAME_X_MENUBAR_ID (f); |
| 442 | 1242 |
| 1243 val = lw_get_all_values (id); | |
| 1244 if (val) | |
| 1245 { | |
| 1246 val = val->contents; | |
| 1247 | |
| 1248 fake = Fcopy_sequence (Vmenu_accelerator_modifiers); | |
| 1249 last = fake; | |
| 1250 | |
| 1251 while (!NILP (Fcdr (last))) | |
| 1252 last = Fcdr (last); | |
| 1253 | |
| 1254 Fsetcdr (last, Fcons (Qnil, Qnil)); | |
| 1255 last = Fcdr (last); | |
| 1256 } | |
| 1257 | |
| 1258 fake = Fcons (Qnil, fake); | |
| 1259 | |
| 1260 GCPRO1 (fake); | |
| 1261 | |
| 1262 while (val) | |
| 1263 { | |
| 1264 Lisp_Object accel; | |
| 5013 | 1265 accel = GET_LISP_FROM_VOID (val->accel); |
| 442 | 1266 if (val->name && !NILP (accel)) |
| 1267 { | |
| 1268 Fsetcar (last, accel); | |
| 1269 Fsetcar (fake, event0); | |
| 1270 matchp = condition_case_1 (Qerror, | |
| 1271 menu_accelerator_safe_mod_compare, | |
| 1272 fake, | |
| 1273 menu_accelerator_junk_on_error, | |
| 1274 Qnil); | |
| 1275 if (!NILP (matchp)) | |
| 1276 { | |
| 1277 /* we found one! */ | |
| 1278 | |
| 1279 lw_set_menu (menubar_widget, val); | |
| 1280 /* yah - yet another hack. | |
| 1281 pretend emacs timestamp is the same as an X timestamp, | |
| 1282 which for the moment it is. (read events.h) | |
| 1283 */ | |
| 1284 lw_map_menu (XEVENT (event0)->timestamp); | |
| 1285 | |
| 1286 if (val->contents) | |
| 1287 lw_push_menu (val->contents); | |
| 1288 | |
| 1289 lw_display_menu (CurrentTime); | |
| 1290 | |
| 1291 /* menu accelerator keys don't go into keyboard macros */ | |
| 1292 if (!NILP (con->defining_kbd_macro) | |
| 1293 && NILP (Vexecuting_macro)) | |
| 1294 con->kbd_macro_ptr = con->kbd_macro_end; | |
| 1295 | |
| 1296 /* don't echo menu accelerator keys */ | |
| 1297 /*reset_key_echo (builder, 1);*/ | |
| 1298 reset_this_command_keys (Vselected_console, 1); | |
| 1299 UNGCPRO; | |
| 1300 | |
| 1301 return Vmenu_accelerator_map; | |
| 1302 } | |
| 1303 } | |
| 1304 | |
| 1305 val = val->next; | |
| 1306 } | |
| 1307 | |
| 1308 UNGCPRO; | |
| 1309 } | |
| 1310 return Qnil; | |
| 1311 } | |
| 1312 | |
| 1313 int | |
| 1314 x_kludge_lw_menu_active (void) | |
| 1315 { | |
| 1316 return lw_menu_active; | |
| 1317 } | |
| 1318 | |
| 1319 DEFUN ("accelerate-menu", Faccelerate_menu, 0, 0, "_", /* | |
| 1320 Make the menubar active. Menu items can be selected using menu accelerators | |
| 1321 or by actions defined in menu-accelerator-map. | |
| 1322 */ | |
| 1323 ()) | |
| 1324 { | |
| 1325 struct console *con = XCONSOLE (Vselected_console); | |
| 1326 struct frame *f = XFRAME (CONSOLE_SELECTED_FRAME (con)); | |
| 1327 LWLIB_ID id; | |
| 1328 widget_value *val; | |
| 1329 | |
| 1346 | 1330 if (!FRAME_X_MENUBAR_ID (f)) |
| 563 | 1331 invalid_argument ("Frame has no menubar", Qunbound); |
| 442 | 1332 |
| 1346 | 1333 id = FRAME_X_MENUBAR_ID (f); |
| 442 | 1334 val = lw_get_all_values (id); |
| 1335 val = val->contents; | |
| 1336 lw_set_menu (FRAME_X_MENUBAR_WIDGET (f), val); | |
| 1337 lw_map_menu (CurrentTime); | |
| 1338 | |
| 1339 lw_display_menu (CurrentTime); | |
| 1340 | |
| 1341 /* menu accelerator keys don't go into keyboard macros */ | |
| 1342 if (!NILP (con->defining_kbd_macro) && NILP (Vexecuting_macro)) | |
| 1343 con->kbd_macro_ptr = con->kbd_macro_end; | |
| 1344 | |
| 1345 return Qnil; | |
| 1346 } | |
| 1347 #endif /* LWLIB_MENUBARS_LUCID */ | |
| 1348 | |
| 1349 | |
| 428 | 1350 void |
| 1351 syms_of_menubar_x (void) | |
| 1352 { | |
| 442 | 1353 #if defined(LWLIB_MENUBARS_LUCID) |
| 1354 DEFSUBR (Faccelerate_menu); | |
| 1355 #endif | |
| 428 | 1356 } |
| 1357 | |
| 1358 void | |
| 1359 console_type_create_menubar_x (void) | |
| 1360 { | |
| 1361 CONSOLE_HAS_METHOD (x, update_frame_menubars); | |
| 1362 CONSOLE_HAS_METHOD (x, free_frame_menubars); | |
| 1363 CONSOLE_HAS_METHOD (x, popup_menu); | |
| 1364 } | |
| 1365 | |
| 1366 void | |
| 1367 reinit_vars_of_menubar_x (void) | |
| 1368 { | |
| 1369 last_popup_menu_selection_callback_id = (LWLIB_ID) -1; | |
| 1370 } | |
| 1371 | |
| 1372 void | |
| 1373 vars_of_menubar_x (void) | |
| 1374 { | |
| 1375 #if defined (LWLIB_MENUBARS_LUCID) | |
| 1376 Fprovide (intern ("lucid-menubars")); | |
| 1377 #elif defined (LWLIB_MENUBARS_MOTIF) | |
| 1378 Fprovide (intern ("motif-menubars")); | |
| 1379 #elif defined (LWLIB_MENUBARS_ATHENA) | |
| 1380 Fprovide (intern ("athena-menubars")); | |
| 1381 #endif | |
| 1382 } |