Mercurial > hg > xemacs-beta
annotate src/event-stream.c @ 5127:a9c41067dd88 ben-lisp-object
more cleanups, terminology clarification, lots of doc work
-------------------- ChangeLog entries follow: --------------------
man/ChangeLog addition:
2010-03-05 Ben Wing <ben@xemacs.org>
* internals/internals.texi (Introduction to Allocation):
* internals/internals.texi (Integers and Characters):
* internals/internals.texi (Allocation from Frob Blocks):
* internals/internals.texi (lrecords):
* internals/internals.texi (Low-level allocation):
Rewrite section on allocation of Lisp objects to reflect the new
reality. Remove references to nonexistent XSETINT and XSETCHAR.
modules/ChangeLog addition:
2010-03-05 Ben Wing <ben@xemacs.org>
* postgresql/postgresql.c (allocate_pgconn):
* postgresql/postgresql.c (allocate_pgresult):
* postgresql/postgresql.h (struct Lisp_PGconn):
* postgresql/postgresql.h (struct Lisp_PGresult):
* ldap/eldap.c (allocate_ldap):
* ldap/eldap.h (struct Lisp_LDAP):
Same changes as in src/ dir. See large log there in ChangeLog,
but basically:
ALLOC_LISP_OBJECT -> ALLOC_NORMAL_LISP_OBJECT
LISP_OBJECT_HEADER -> NORMAL_LISP_OBJECT_HEADER
../hlo/src/ChangeLog addition:
2010-03-05 Ben Wing <ben@xemacs.org>
* alloc.c:
* alloc.c (old_alloc_sized_lcrecord):
* alloc.c (very_old_free_lcrecord):
* alloc.c (copy_lisp_object):
* alloc.c (zero_sized_lisp_object):
* alloc.c (zero_nonsized_lisp_object):
* alloc.c (lisp_object_storage_size):
* alloc.c (free_normal_lisp_object):
* alloc.c (FREE_FIXED_TYPE_WHEN_NOT_IN_GC):
* alloc.c (ALLOC_FROB_BLOCK_LISP_OBJECT):
* alloc.c (Fcons):
* alloc.c (noseeum_cons):
* alloc.c (make_float):
* alloc.c (make_bignum):
* alloc.c (make_bignum_bg):
* alloc.c (make_ratio):
* alloc.c (make_ratio_bg):
* alloc.c (make_ratio_rt):
* alloc.c (make_bigfloat):
* alloc.c (make_bigfloat_bf):
* alloc.c (size_vector):
* alloc.c (make_compiled_function):
* alloc.c (Fmake_symbol):
* alloc.c (allocate_extent):
* alloc.c (allocate_event):
* alloc.c (make_key_data):
* alloc.c (make_button_data):
* alloc.c (make_motion_data):
* alloc.c (make_process_data):
* alloc.c (make_timeout_data):
* alloc.c (make_magic_data):
* alloc.c (make_magic_eval_data):
* alloc.c (make_eval_data):
* alloc.c (make_misc_user_data):
* alloc.c (Fmake_marker):
* alloc.c (noseeum_make_marker):
* alloc.c (size_string_direct_data):
* alloc.c (make_uninit_string):
* alloc.c (make_string_nocopy):
* alloc.c (mark_lcrecord_list):
* alloc.c (alloc_managed_lcrecord):
* alloc.c (free_managed_lcrecord):
* alloc.c (sweep_lcrecords_1):
* alloc.c (malloced_storage_size):
* buffer.c (allocate_buffer):
* buffer.c (compute_buffer_usage):
* buffer.c (DEFVAR_BUFFER_LOCAL_1):
* buffer.c (nuke_all_buffer_slots):
* buffer.c (common_init_complex_vars_of_buffer):
* buffer.h (struct buffer_text):
* buffer.h (struct buffer):
* bytecode.c:
* bytecode.c (make_compiled_function_args):
* bytecode.c (size_compiled_function_args):
* bytecode.h (struct compiled_function_args):
* casetab.c (allocate_case_table):
* casetab.h (struct Lisp_Case_Table):
* charset.h (struct Lisp_Charset):
* chartab.c (fill_char_table):
* chartab.c (Fmake_char_table):
* chartab.c (make_char_table_entry):
* chartab.c (copy_char_table_entry):
* chartab.c (Fcopy_char_table):
* chartab.c (put_char_table):
* chartab.h (struct Lisp_Char_Table_Entry):
* chartab.h (struct Lisp_Char_Table):
* console-gtk-impl.h (struct gtk_device):
* console-gtk-impl.h (struct gtk_frame):
* console-impl.h (struct console):
* console-msw-impl.h (struct Lisp_Devmode):
* console-msw-impl.h (struct mswindows_device):
* console-msw-impl.h (struct msprinter_device):
* console-msw-impl.h (struct mswindows_frame):
* console-msw-impl.h (struct mswindows_dialog_id):
* console-stream-impl.h (struct stream_console):
* console-stream.c (stream_init_console):
* console-tty-impl.h (struct tty_console):
* console-tty-impl.h (struct tty_device):
* console-tty.c (allocate_tty_console_struct):
* console-x-impl.h (struct x_device):
* console-x-impl.h (struct x_frame):
* console.c (allocate_console):
* console.c (nuke_all_console_slots):
* console.c (DEFVAR_CONSOLE_LOCAL_1):
* console.c (common_init_complex_vars_of_console):
* data.c (make_weak_list):
* data.c (make_weak_box):
* data.c (make_ephemeron):
* database.c:
* database.c (struct Lisp_Database):
* database.c (allocate_database):
* database.c (finalize_database):
* device-gtk.c (allocate_gtk_device_struct):
* device-impl.h (struct device):
* device-msw.c:
* device-msw.c (mswindows_init_device):
* device-msw.c (msprinter_init_device):
* device-msw.c (finalize_devmode):
* device-msw.c (allocate_devmode):
* device-tty.c (allocate_tty_device_struct):
* device-x.c (allocate_x_device_struct):
* device.c:
* device.c (nuke_all_device_slots):
* device.c (allocate_device):
* dialog-msw.c (handle_question_dialog_box):
* elhash.c:
* elhash.c (struct Lisp_Hash_Table):
* elhash.c (finalize_hash_table):
* elhash.c (make_general_lisp_hash_table):
* elhash.c (Fcopy_hash_table):
* elhash.h (htentry):
* emacs.c (main_1):
* eval.c:
* eval.c (size_multiple_value):
* event-stream.c (finalize_command_builder):
* event-stream.c (allocate_command_builder):
* event-stream.c (free_command_builder):
* event-stream.c (event_stream_generate_wakeup):
* event-stream.c (event_stream_resignal_wakeup):
* event-stream.c (event_stream_disable_wakeup):
* event-stream.c (event_stream_wakeup_pending_p):
* events.h (struct Lisp_Timeout):
* events.h (struct command_builder):
* extents-impl.h:
* extents-impl.h (struct extent_auxiliary):
* extents-impl.h (struct extent_info):
* extents-impl.h (set_extent_no_chase_aux_field):
* extents-impl.h (set_extent_no_chase_normal_field):
* extents.c:
* extents.c (gap_array_marker):
* extents.c (gap_array):
* extents.c (extent_list_marker):
* extents.c (extent_list):
* extents.c (stack_of_extents):
* extents.c (gap_array_make_marker):
* extents.c (extent_list_make_marker):
* extents.c (allocate_extent_list):
* extents.c (SLOT):
* extents.c (mark_extent_auxiliary):
* extents.c (allocate_extent_auxiliary):
* extents.c (attach_extent_auxiliary):
* extents.c (size_gap_array):
* extents.c (finalize_extent_info):
* extents.c (allocate_extent_info):
* extents.c (uninit_buffer_extents):
* extents.c (allocate_soe):
* extents.c (copy_extent):
* extents.c (vars_of_extents):
* extents.h:
* faces.c (allocate_face):
* faces.h (struct Lisp_Face):
* faces.h (struct face_cachel):
* file-coding.c:
* file-coding.c (finalize_coding_system):
* file-coding.c (sizeof_coding_system):
* file-coding.c (Fcopy_coding_system):
* file-coding.h (struct Lisp_Coding_System):
* file-coding.h (MARKED_SLOT):
* fns.c (size_bit_vector):
* font-mgr.c:
* font-mgr.c (finalize_fc_pattern):
* font-mgr.c (print_fc_pattern):
* font-mgr.c (Ffc_pattern_p):
* font-mgr.c (Ffc_pattern_create):
* font-mgr.c (Ffc_name_parse):
* font-mgr.c (Ffc_name_unparse):
* font-mgr.c (Ffc_pattern_duplicate):
* font-mgr.c (Ffc_pattern_add):
* font-mgr.c (Ffc_pattern_del):
* font-mgr.c (Ffc_pattern_get):
* font-mgr.c (fc_config_create_using):
* font-mgr.c (fc_strlist_to_lisp_using):
* font-mgr.c (fontset_to_list):
* font-mgr.c (Ffc_config_p):
* font-mgr.c (Ffc_config_up_to_date):
* font-mgr.c (Ffc_config_build_fonts):
* font-mgr.c (Ffc_config_get_cache):
* font-mgr.c (Ffc_config_get_fonts):
* font-mgr.c (Ffc_config_set_current):
* font-mgr.c (Ffc_config_get_blanks):
* font-mgr.c (Ffc_config_get_rescan_interval):
* font-mgr.c (Ffc_config_set_rescan_interval):
* font-mgr.c (Ffc_config_app_font_add_file):
* font-mgr.c (Ffc_config_app_font_add_dir):
* font-mgr.c (Ffc_config_app_font_clear):
* font-mgr.c (size):
* font-mgr.c (Ffc_config_substitute):
* font-mgr.c (Ffc_font_render_prepare):
* font-mgr.c (Ffc_font_match):
* font-mgr.c (Ffc_font_sort):
* font-mgr.c (finalize_fc_config):
* font-mgr.c (print_fc_config):
* font-mgr.h:
* font-mgr.h (struct fc_pattern):
* font-mgr.h (XFC_PATTERN):
* font-mgr.h (struct fc_config):
* font-mgr.h (XFC_CONFIG):
* frame-gtk.c (allocate_gtk_frame_struct):
* frame-impl.h (struct frame):
* frame-msw.c (mswindows_init_frame_1):
* frame-x.c (allocate_x_frame_struct):
* frame.c (nuke_all_frame_slots):
* frame.c (allocate_frame_core):
* gc.c:
* gc.c (GC_CHECK_NOT_FREE):
* glyphs.c (finalize_image_instance):
* glyphs.c (allocate_image_instance):
* glyphs.c (Fcolorize_image_instance):
* glyphs.c (allocate_glyph):
* glyphs.c (unmap_subwindow_instance_cache_mapper):
* glyphs.c (register_ignored_expose):
* glyphs.h (struct Lisp_Image_Instance):
* glyphs.h (struct Lisp_Glyph):
* glyphs.h (struct glyph_cachel):
* glyphs.h (struct expose_ignore):
* gui.c (allocate_gui_item):
* gui.h (struct Lisp_Gui_Item):
* keymap.c (struct Lisp_Keymap):
* keymap.c (make_keymap):
* lisp.h:
* lisp.h (struct Lisp_String_Direct_Data):
* lisp.h (struct Lisp_String_Indirect_Data):
* lisp.h (struct Lisp_Vector):
* lisp.h (struct Lisp_Bit_Vector):
* lisp.h (DECLARE_INLINE_LISP_BIT_VECTOR):
* lisp.h (struct weak_box):
* lisp.h (struct ephemeron):
* lisp.h (struct weak_list):
* lrecord.h:
* lrecord.h (struct lrecord_implementation):
* lrecord.h (MC_ALLOC_CALL_FINALIZER):
* lrecord.h (struct lcrecord_list):
* lstream.c (finalize_lstream):
* lstream.c (sizeof_lstream):
* lstream.c (Lstream_new):
* lstream.c (Lstream_delete):
* lstream.h (struct lstream):
* marker.c:
* marker.c (finalize_marker):
* marker.c (compute_buffer_marker_usage):
* mule-charset.c:
* mule-charset.c (make_charset):
* mule-charset.c (compute_charset_usage):
* objects-impl.h (struct Lisp_Color_Instance):
* objects-impl.h (struct Lisp_Font_Instance):
* objects-tty-impl.h (struct tty_color_instance_data):
* objects-tty-impl.h (struct tty_font_instance_data):
* objects-tty.c (tty_initialize_color_instance):
* objects-tty.c (tty_initialize_font_instance):
* objects.c (finalize_color_instance):
* objects.c (Fmake_color_instance):
* objects.c (finalize_font_instance):
* objects.c (Fmake_font_instance):
* objects.c (reinit_vars_of_objects):
* opaque.c:
* opaque.c (sizeof_opaque):
* opaque.c (make_opaque_ptr):
* opaque.c (free_opaque_ptr):
* opaque.h:
* opaque.h (Lisp_Opaque):
* opaque.h (Lisp_Opaque_Ptr):
* print.c (printing_unreadable_lcrecord):
* print.c (external_object_printer):
* print.c (debug_p4):
* process.c (finalize_process):
* process.c (make_process_internal):
* procimpl.h (struct Lisp_Process):
* rangetab.c (Fmake_range_table):
* rangetab.c (Fcopy_range_table):
* rangetab.h (struct Lisp_Range_Table):
* scrollbar.c:
* scrollbar.c (create_scrollbar_instance):
* scrollbar.c (compute_scrollbar_instance_usage):
* scrollbar.h (struct scrollbar_instance):
* specifier.c (finalize_specifier):
* specifier.c (sizeof_specifier):
* specifier.c (set_specifier_caching):
* specifier.h (struct Lisp_Specifier):
* specifier.h (struct specifier_caching):
* symeval.h:
* symeval.h (SYMBOL_VALUE_MAGIC_P):
* symeval.h (DEFVAR_SYMVAL_FWD):
* symsinit.h:
* syntax.c (init_buffer_syntax_cache):
* syntax.h (struct syntax_cache):
* toolbar.c:
* toolbar.c (allocate_toolbar_button):
* toolbar.c (update_toolbar_button):
* toolbar.h (struct toolbar_button):
* tooltalk.c (struct Lisp_Tooltalk_Message):
* tooltalk.c (make_tooltalk_message):
* tooltalk.c (struct Lisp_Tooltalk_Pattern):
* tooltalk.c (make_tooltalk_pattern):
* ui-gtk.c:
* ui-gtk.c (allocate_ffi_data):
* ui-gtk.c (emacs_gtk_object_finalizer):
* ui-gtk.c (allocate_emacs_gtk_object_data):
* ui-gtk.c (allocate_emacs_gtk_boxed_data):
* ui-gtk.h:
* window-impl.h (struct window):
* window-impl.h (struct window_mirror):
* window.c (finalize_window):
* window.c (allocate_window):
* window.c (new_window_mirror):
* window.c (mark_window_as_deleted):
* window.c (make_dummy_parent):
* window.c (compute_window_mirror_usage):
* window.c (compute_window_usage):
Overall point of this change and previous ones in this repository:
(1) Introduce new, clearer terminology: everything other than int
or char is a "record" object, which comes in two types: "normal
objects" and "frob-block objects". Fix up all places that
referred to frob-block objects as "simple", "basic", etc.
(2) Provide an advertised interface for doing operations on Lisp
objects, including creating new types, that is clean and
consistent in its naming, uses the above-referenced terms and
avoids referencing "lrecords", "old lcrecords", etc., which should
hide under the surface.
(3) Make the size_in_bytes and finalizer methods take a
Lisp_Object rather than a void * for consistency with other methods.
(4) Separate finalizer method into finalizer and disksaver, so
that normal finalize methods don't have to worry about disksaving.
Other specifics:
(1) Renaming:
LISP_OBJECT_HEADER -> NORMAL_LISP_OBJECT_HEADER
ALLOC_LISP_OBJECT -> ALLOC_NORMAL_LISP_OBJECT
implementation->basic_p -> implementation->frob_block_p
ALLOCATE_FIXED_TYPE_AND_SET_IMPL -> ALLOC_FROB_BLOCK_LISP_OBJECT
*FCCONFIG*, wrap_fcconfig -> *FC_CONFIG*, wrap_fc_config
*FCPATTERN*, wrap_fcpattern -> *FC_PATTERN*, wrap_fc_pattern
(the last two changes make the naming of these macros consistent
with the naming of all other macros, since the objects are named
fc-config and fc-pattern with a hyphen)
(2) Lots of documentation fixes in lrecord.h.
(3) Eliminate macros for copying, freeing, zeroing objects, getting
their storage size. Instead, new functions:
zero_sized_lisp_object()
zero_nonsized_lisp_object()
lisp_object_storage_size()
free_normal_lisp_object()
(copy_lisp_object() already exists)
LISP_OBJECT_FROB_BLOCK_P() (actually a macro)
Eliminated:
free_lrecord()
zero_lrecord()
copy_lrecord()
copy_sized_lrecord()
old_copy_lcrecord()
old_copy_sized_lcrecord()
old_zero_lcrecord()
old_zero_sized_lcrecord()
LISP_OBJECT_STORAGE_SIZE()
COPY_SIZED_LISP_OBJECT()
COPY_SIZED_LCRECORD()
COPY_LISP_OBJECT()
ZERO_LISP_OBJECT()
FREE_LISP_OBJECT()
(4) Catch the remaining places where lrecord stuff was used directly
and use the advertised interface, e.g. alloc_sized_lrecord() ->
ALLOC_SIZED_LISP_OBJECT().
(5) Make certain statically-declared pseudo-objects
(buffer_local_flags, console_local_flags) have their lheader
initialized correctly, so things like copy_lisp_object() can work
on them. Make extent_auxiliary_defaults a proper heap object
Vextent_auxiliary_defaults, and make extent auxiliaries dumpable
so that this object can be dumped. allocate_extent_auxiliary()
now just creates the object, and attach_extent_auxiliary()
creates an extent auxiliary and attaches to an extent, like the
old allocate_extent_auxiliary().
(6) Create EXTENT_AUXILIARY_SLOTS macro, similar to the foo-slots.h
files but in a macro instead of a file. The purpose is to avoid
duplication when iterating over all the slots in an extent auxiliary.
Use it.
(7) In lstream.c, don't zero out object after allocation because
allocation routines take care of this.
(8) In marker.c, fix a mistake in computing marker overhead.
(9) In print.c, clean up printing_unreadable_lcrecord(),
external_object_printer() to avoid lots of ifdef NEW_GC's.
(10) Separate toolbar-button allocation into a separate
allocate_toolbar_button() function for use in the example code
in lrecord.h.
| author | Ben Wing <ben@xemacs.org> |
|---|---|
| date | Fri, 05 Mar 2010 04:08:17 -0600 |
| parents | 2a462149bd6a |
| children | e5380fdaf8f1 f965e31a35f0 |
| rev | line source |
|---|---|
| 428 | 1 /* The portable interface to event streams. |
| 2 Copyright (C) 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. | |
| 3 Copyright (C) 1995 Board of Trustees, University of Illinois. | |
| 4 Copyright (C) 1995 Sun Microsystems, Inc. | |
| 5125 | 5 Copyright (C) 1995, 1996, 2001, 2002, 2003, 2005, 2010 Ben Wing. |
| 428 | 6 |
| 7 This file is part of XEmacs. | |
| 8 | |
| 9 XEmacs is free software; you can redistribute it and/or modify it | |
| 10 under the terms of the GNU General Public License as published by the | |
| 11 Free Software Foundation; either version 2, or (at your option) any | |
| 12 later version. | |
| 13 | |
| 14 XEmacs is distributed in the hope that it will be useful, but WITHOUT | |
| 15 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
| 16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
| 17 for more details. | |
| 18 | |
| 19 You should have received a copy of the GNU General Public License | |
| 20 along with XEmacs; see the file COPYING. If not, write to | |
| 21 the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
| 22 Boston, MA 02111-1307, USA. */ | |
| 23 | |
| 24 /* Synched up with: Not in FSF. */ | |
| 25 | |
| 442 | 26 /* Authorship: |
| 27 | |
| 28 Created 1991 by Jamie Zawinski. | |
| 29 A great deal of work over the ages by Ben Wing (Mule-ization for 19.12, | |
| 30 device abstraction for 19.12/19.13, async timers for 19.14, | |
| 31 rewriting of focus code for 19.12, pre-idle hook for 19.12, | |
| 32 redoing of signal and quit handling for 19.9 and 19.12, | |
| 33 misc-user events to clean up menu/scrollbar handling for 19.11, | |
| 34 function-key-map/key-translation-map/keyboard-translate-table for | |
| 35 19.13/19.14, open-dribble-file for 19.13, much other cleanup). | |
| 36 focus-follows-mouse from Chuck Thompson, 1995. | |
| 37 XIM stuff by Martin Buchholz, c. 1996?. | |
| 38 */ | |
| 39 | |
| 428 | 40 /* This file has been Mule-ized. */ |
| 41 | |
| 42 /* | |
| 43 * DANGER!! | |
| 44 * | |
| 45 * If you ever change ANYTHING in this file, you MUST run the | |
| 46 * testcases at the end to make sure that you haven't changed | |
| 47 * the semantics of recent-keys, last-input-char, or keyboard | |
| 48 * macros. You'd be surprised how easy it is to break this. | |
| 49 * | |
| 50 */ | |
| 51 | |
| 52 /* TODO: | |
| 1204 | 53 [This stuff is way too hard to maintain - needs rework.] |
| 54 I don't think it's that bad in the main. I've done a fair amount of | |
| 55 cleanup work over the ages; the only stuff that's probably still somewhat | |
| 56 messy is the command-builder handling, which is that way because it's | |
| 57 trying to be "compatible" with pseudo-standards established by Emacs | |
| 58 v18. | |
| 428 | 59 |
| 60 The command builder should deal only with key and button events. | |
| 61 Other command events should be able to come in the MIDDLE of a key | |
| 62 sequence, without disturbing the key sequence composition, or the | |
| 63 command builder structure representing it. | |
| 64 | |
| 65 Someone should rethink universal-argument and figure out how an | |
| 66 arbitrary command can influence the next command (universal-argument | |
| 67 or universal-coding-system-argument) or the next key (hyperify). | |
| 68 | |
| 69 Both C-h and Help in the middle of a key sequence should trigger | |
| 70 prefix-help-command. help-char is stupid. Maybe we need | |
| 71 keymap-of-last-resort? | |
| 72 | |
| 73 After prefix-help is run, one should be able to CONTINUE TYPING, | |
| 74 instead of RETYPING, the key sequence. | |
| 75 */ | |
| 76 | |
| 77 #include <config.h> | |
| 78 #include "lisp.h" | |
| 79 | |
| 80 #include "blocktype.h" | |
| 81 #include "buffer.h" | |
| 82 #include "commands.h" | |
| 872 | 83 #include "device-impl.h" |
| 428 | 84 #include "elhash.h" |
| 85 #include "events.h" | |
| 872 | 86 #include "frame-impl.h" |
| 428 | 87 #include "insdel.h" /* for buffer_reset_changes */ |
| 88 #include "keymap.h" | |
| 89 #include "lstream.h" | |
| 90 #include "macros.h" /* for defining_keyboard_macro */ | |
| 442 | 91 #include "menubar.h" /* #### for evil kludges. */ |
| 428 | 92 #include "process.h" |
| 1292 | 93 #include "profile.h" |
| 872 | 94 #include "window-impl.h" |
| 428 | 95 |
| 96 #include "sysdep.h" /* init_poll_for_quit() */ | |
| 97 #include "syssignal.h" /* SIGCHLD, etc. */ | |
| 98 #include "sysfile.h" | |
| 99 #include "systime.h" /* to set Vlast_input_time */ | |
| 100 | |
| 101 #include "file-coding.h" | |
| 102 | |
| 103 #include <errno.h> | |
| 104 | |
| 105 /* The number of keystrokes between auto-saves. */ | |
| 458 | 106 static Fixnum auto_save_interval; |
| 428 | 107 |
| 108 Lisp_Object Qundefined_keystroke_sequence; | |
| 563 | 109 Lisp_Object Qinvalid_key_binding; |
| 428 | 110 |
| 111 Lisp_Object Qcommand_event_p; | |
| 112 | |
| 113 /* Hooks to run before and after each command. */ | |
| 114 Lisp_Object Vpre_command_hook, Vpost_command_hook; | |
| 115 Lisp_Object Qpre_command_hook, Qpost_command_hook; | |
| 116 | |
| 442 | 117 /* See simple.el */ |
| 118 Lisp_Object Qhandle_pre_motion_command, Qhandle_post_motion_command; | |
| 119 | |
| 428 | 120 /* Hook run when XEmacs is about to be idle. */ |
| 121 Lisp_Object Qpre_idle_hook, Vpre_idle_hook; | |
| 122 | |
| 123 /* Control gratuitous keyboard focus throwing. */ | |
| 124 int focus_follows_mouse; | |
| 125 | |
| 444 | 126 /* When true, modifier keys are sticky. */ |
| 442 | 127 int modifier_keys_are_sticky; |
| 444 | 128 /* Modifier keys are sticky for this many milliseconds. */ |
| 129 Lisp_Object Vmodifier_keys_sticky_time; | |
| 130 | |
| 2828 | 131 /* If true, "Russian C-x processing" is enabled. */ |
| 132 int try_alternate_layouts_for_commands; | |
| 133 | |
| 444 | 134 /* Here FSF Emacs 20.7 defines Vpost_command_idle_hook, |
| 135 post_command_idle_delay, Vdeferred_action_list, and | |
| 136 Vdeferred_action_function, but we don't because that stuff is crap, | |
| 1315 | 137 and we're smarter than them, and their mommas are fat. */ |
| 444 | 138 |
| 139 /* FSF Emacs 20.7 also defines Vinput_method_function, | |
| 140 Qinput_method_exit_on_first_char and Qinput_method_use_echo_area. | |
| 1315 | 141 I don't know whether this should be imported or not. */ |
| 428 | 142 |
| 143 /* Non-nil disable property on a command means | |
| 144 do not execute it; call disabled-command-hook's value instead. */ | |
| 733 | 145 Lisp_Object Qdisabled; |
| 428 | 146 |
| 147 /* Last keyboard or mouse input event read as a command. */ | |
| 148 Lisp_Object Vlast_command_event; | |
| 149 | |
| 150 /* The nearest ASCII equivalent of the above. */ | |
| 151 Lisp_Object Vlast_command_char; | |
| 152 | |
| 153 /* Last keyboard or mouse event read for any purpose. */ | |
| 154 Lisp_Object Vlast_input_event; | |
| 155 | |
| 156 /* The nearest ASCII equivalent of the above. */ | |
| 157 Lisp_Object Vlast_input_char; | |
| 158 | |
| 159 Lisp_Object Vcurrent_mouse_event; | |
| 160 | |
| 161 /* This is fbound in cmdloop.el, see the commentary there */ | |
| 162 Lisp_Object Qcancel_mode_internal; | |
| 163 | |
| 164 /* If not Qnil, event objects to be read as the next command input */ | |
| 165 Lisp_Object Vunread_command_events; | |
| 166 Lisp_Object Vunread_command_event; /* obsoleteness support */ | |
| 167 | |
| 168 static Lisp_Object Qunread_command_events, Qunread_command_event; | |
| 169 | |
| 170 /* Previous command, represented by a Lisp object. | |
| 442 | 171 Does not include prefix commands and arg setting commands. */ |
| 428 | 172 Lisp_Object Vlast_command; |
| 173 | |
| 442 | 174 /* Contents of this-command-properties for the last command. */ |
| 175 Lisp_Object Vlast_command_properties; | |
| 176 | |
| 428 | 177 /* If a command sets this, the value goes into |
| 442 | 178 last-command for the next command. */ |
| 428 | 179 Lisp_Object Vthis_command; |
| 180 | |
| 442 | 181 /* If a command sets this, the value goes into |
| 182 last-command-properties for the next command. */ | |
| 183 Lisp_Object Vthis_command_properties; | |
| 184 | |
| 428 | 185 /* The value of point when the last command was executed. */ |
| 665 | 186 Charbpos last_point_position; |
| 428 | 187 |
| 188 /* The frame that was current when the last command was started. */ | |
| 189 Lisp_Object Vlast_selected_frame; | |
| 190 | |
| 191 /* The buffer that was current when the last command was started. */ | |
| 192 Lisp_Object last_point_position_buffer; | |
| 193 | |
| 194 /* A (16bit . 16bit) representation of the time of the last-command-event. */ | |
| 195 Lisp_Object Vlast_input_time; | |
| 196 | |
| 197 /* A (16bit 16bit usec) representation of the time | |
| 198 of the last-command-event. */ | |
| 199 Lisp_Object Vlast_command_event_time; | |
| 200 | |
| 201 /* Character to recognize as the help char. */ | |
| 202 Lisp_Object Vhelp_char; | |
| 203 | |
| 204 /* Form to execute when help char is typed. */ | |
| 205 Lisp_Object Vhelp_form; | |
| 206 | |
| 207 /* Command to run when the help character follows a prefix key. */ | |
| 208 Lisp_Object Vprefix_help_command; | |
| 209 | |
| 210 /* Flag to tell QUIT that some interesting occurrence (e.g. a keypress) | |
| 211 may have happened. */ | |
| 212 volatile int something_happened; | |
| 213 | |
| 214 /* Hash table to translate keysyms through */ | |
| 215 Lisp_Object Vkeyboard_translate_table; | |
| 216 | |
| 217 /* If control-meta-super-shift-X is undefined, try control-meta-super-x */ | |
| 218 Lisp_Object Vretry_undefined_key_binding_unshifted; | |
| 219 Lisp_Object Qretry_undefined_key_binding_unshifted; | |
| 220 | |
| 221 /* Console that corresponds to our controlling terminal */ | |
| 222 Lisp_Object Vcontrolling_terminal; | |
| 223 | |
| 224 /* An event (actually an event chain linked through event_next) or Qnil. | |
| 225 */ | |
| 226 Lisp_Object Vthis_command_keys; | |
| 227 Lisp_Object Vthis_command_keys_tail; | |
| 228 | |
| 229 /* #### kludge! */ | |
| 230 Lisp_Object Qauto_show_make_point_visible; | |
| 231 | |
| 232 /* File in which we write all commands we read; an lstream */ | |
| 233 static Lisp_Object Vdribble_file; | |
| 234 | |
| 235 /* Recent keys ring location; a vector of events or nil-s */ | |
| 236 Lisp_Object Vrecent_keys_ring; | |
| 237 int recent_keys_ring_size; | |
| 238 int recent_keys_ring_index; | |
| 239 | |
| 240 /* Boolean specifying whether keystrokes should be added to | |
| 241 recent-keys. */ | |
| 242 int inhibit_input_event_recording; | |
| 243 | |
| 430 | 244 Lisp_Object Qself_insert_defer_undo; |
| 245 | |
| 1268 | 246 int in_modal_loop; |
| 247 | |
| 248 /* the number of keyboard characters read. callint.c wants this. */ | |
| 249 Charcount num_input_chars; | |
| 428 | 250 |
| 1292 | 251 static Lisp_Object Qnext_event, Qdispatch_event, QSnext_event_internal; |
| 252 static Lisp_Object QSexecute_internal_event; | |
| 253 | |
| 428 | 254 #ifdef DEBUG_XEMACS |
| 458 | 255 Fixnum debug_emacs_events; |
| 428 | 256 |
| 257 static void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4932
diff
changeset
|
258 external_debugging_print_event (const Ascbyte *event_description, |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4932
diff
changeset
|
259 Lisp_Object event) |
| 428 | 260 { |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4932
diff
changeset
|
261 write_ascstring (Qexternal_debugging_output, "("); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4932
diff
changeset
|
262 write_ascstring (Qexternal_debugging_output, event_description); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4932
diff
changeset
|
263 write_ascstring (Qexternal_debugging_output, ") "); |
| 428 | 264 print_internal (event, Qexternal_debugging_output, 1); |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4932
diff
changeset
|
265 write_ascstring (Qexternal_debugging_output, "\n"); |
| 428 | 266 } |
| 267 #define DEBUG_PRINT_EMACS_EVENT(event_description, event) do { \ | |
| 268 if (debug_emacs_events) \ | |
| 269 external_debugging_print_event (event_description, event); \ | |
| 270 } while (0) | |
| 271 #else | |
| 272 #define DEBUG_PRINT_EMACS_EVENT(string, event) | |
| 273 #endif | |
| 274 | |
| 275 | |
| 276 /* The callback routines for the window system or terminal driver */ | |
| 277 struct event_stream *event_stream; | |
| 278 | |
| 2367 | 279 |
| 280 /* | |
| 281 | |
| 282 See also | |
| 283 | |
| 284 (Info-goto-node "(internals)Event Stream Callback Routines") | |
| 285 */ | |
| 1204 | 286 |
| 428 | 287 static Lisp_Object command_event_queue; |
| 288 static Lisp_Object command_event_queue_tail; | |
| 289 | |
| 1204 | 290 Lisp_Object dispatch_event_queue; |
| 291 static Lisp_Object dispatch_event_queue_tail; | |
| 292 | |
| 428 | 293 /* Nonzero means echo unfinished commands after this many seconds of pause. */ |
| 294 static Lisp_Object Vecho_keystrokes; | |
| 295 | |
| 296 /* The number of keystrokes since the last auto-save. */ | |
| 297 static int keystrokes_since_auto_save; | |
| 298 | |
| 299 /* Used by the C-g signal handler so that it will never "hard quit" | |
| 300 when waiting for an event. Otherwise holding down C-g could | |
| 301 cause a suspension back to the shell, which is generally | |
| 302 undesirable. (#### This doesn't fully work.) */ | |
| 303 | |
| 304 int emacs_is_blocking; | |
| 305 | |
| 306 /* Handlers which run during sit-for, sleep-for and accept-process-output | |
| 307 are not allowed to recursively call these routines. We record here | |
| 308 if we are in that situation. */ | |
| 309 | |
| 1268 | 310 static int recursive_sit_for; |
| 311 | |
| 312 static void pre_command_hook (void); | |
| 313 static void post_command_hook (void); | |
| 314 static void maybe_kbd_translate (Lisp_Object event); | |
| 315 static void push_this_command_keys (Lisp_Object event); | |
| 316 static void push_recent_keys (Lisp_Object event); | |
| 317 static void dribble_out_event (Lisp_Object event); | |
| 318 static void execute_internal_event (Lisp_Object event); | |
| 319 static int is_scrollbar_event (Lisp_Object event); | |
| 428 | 320 |
| 321 | |
| 322 /**********************************************************************/ | |
| 323 /* Command-builder object */ | |
| 324 /**********************************************************************/ | |
| 325 | |
| 326 #define XCOMMAND_BUILDER(x) \ | |
| 327 XRECORD (x, command_builder, struct command_builder) | |
| 771 | 328 #define wrap_command_builder(p) wrap_record (p, command_builder) |
| 428 | 329 #define COMMAND_BUILDERP(x) RECORDP (x, command_builder) |
| 330 #define CHECK_COMMAND_BUILDER(x) CHECK_RECORD (x, command_builder) | |
| 771 | 331 #define CONCHECK_COMMAND_BUILDER(x) CONCHECK_RECORD (x, command_builder) |
| 332 | |
| 1204 | 333 static const struct memory_description command_builder_description [] = { |
| 934 | 334 { XD_LISP_OBJECT, offsetof (struct command_builder, current_events) }, |
| 335 { XD_LISP_OBJECT, offsetof (struct command_builder, most_current_event) }, | |
| 336 { XD_LISP_OBJECT, offsetof (struct command_builder, last_non_munged_event) }, | |
| 337 { XD_LISP_OBJECT, offsetof (struct command_builder, console) }, | |
| 1204 | 338 { XD_LISP_OBJECT_ARRAY, offsetof (struct command_builder, first_mungeable_event), 2 }, |
| 934 | 339 { XD_END } |
| 340 }; | |
| 341 | |
| 428 | 342 static Lisp_Object |
| 343 mark_command_builder (Lisp_Object obj) | |
| 344 { | |
| 345 struct command_builder *builder = XCOMMAND_BUILDER (obj); | |
| 346 mark_object (builder->current_events); | |
| 347 mark_object (builder->most_current_event); | |
| 348 mark_object (builder->last_non_munged_event); | |
| 1204 | 349 mark_object (builder->first_mungeable_event[0]); |
| 350 mark_object (builder->first_mungeable_event[1]); | |
| 428 | 351 return builder->console; |
| 352 } | |
| 353 | |
| 354 static void | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
355 finalize_command_builder (Lisp_Object obj) |
| 428 | 356 { |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
357 struct command_builder *b = XCOMMAND_BUILDER (obj); |
|
5124
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5120
diff
changeset
|
358 if (b->echo_buf) |
| 428 | 359 { |
| 5125 | 360 xfree (b->echo_buf); |
|
5124
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5120
diff
changeset
|
361 b->echo_buf = 0; |
| 428 | 362 } |
| 363 } | |
| 364 | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
365 DEFINE_NODUMP_LISP_OBJECT ("command-builder", command_builder, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
366 mark_command_builder, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
367 internal_object_printer, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
368 finalize_command_builder, 0, 0, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
369 command_builder_description, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
370 struct command_builder); |
| 771 | 371 |
| 428 | 372 static void |
| 373 reset_command_builder_event_chain (struct command_builder *builder) | |
| 374 { | |
| 375 builder->current_events = Qnil; | |
| 376 builder->most_current_event = Qnil; | |
| 377 builder->last_non_munged_event = Qnil; | |
| 1204 | 378 builder->first_mungeable_event[0] = Qnil; |
| 379 builder->first_mungeable_event[1] = Qnil; | |
| 428 | 380 } |
| 381 | |
| 382 Lisp_Object | |
| 771 | 383 allocate_command_builder (Lisp_Object console, int with_echo_buf) |
| 428 | 384 { |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
385 Lisp_Object builder_obj = ALLOC_NORMAL_LISP_OBJECT (command_builder); |
| 771 | 386 struct command_builder *builder = XCOMMAND_BUILDER (builder_obj); |
| 428 | 387 |
| 388 builder->console = console; | |
| 389 reset_command_builder_event_chain (builder); | |
| 771 | 390 if (with_echo_buf) |
| 391 { | |
| 392 /* #### This badly needs to be turned into a Dynarr */ | |
| 393 builder->echo_buf_length = 300; /* #### Kludge */ | |
| 867 | 394 builder->echo_buf = xnew_array (Ibyte, builder->echo_buf_length); |
| 771 | 395 builder->echo_buf[0] = 0; |
| 396 } | |
| 397 else | |
| 398 { | |
| 399 builder->echo_buf_length = 0; | |
| 400 builder->echo_buf = NULL; | |
| 401 } | |
| 428 | 402 builder->echo_buf_index = -1; |
| 403 builder->self_insert_countdown = 0; | |
| 404 | |
| 405 return builder_obj; | |
| 406 } | |
| 407 | |
| 771 | 408 /* Copy or clone COLLAPSING (copy to NEW_BUILDINGS if non-zero, |
| 409 otherwise clone); but don't copy the echo-buf stuff. (The calling | |
| 410 routines don't need it and will reset it, and we would rather avoid | |
| 411 malloc.) */ | |
| 412 | |
| 413 static Lisp_Object | |
| 414 copy_command_builder (struct command_builder *collapsing, | |
| 415 struct command_builder *new_buildings) | |
| 416 { | |
| 417 if (!new_buildings) | |
| 418 new_buildings = XCOMMAND_BUILDER (allocate_command_builder (Qnil, 0)); | |
| 419 | |
| 3358 | 420 new_buildings->console = collapsing->console; |
| 421 | |
| 771 | 422 new_buildings->self_insert_countdown = collapsing->self_insert_countdown; |
| 423 | |
| 424 deallocate_event_chain (new_buildings->current_events); | |
| 425 new_buildings->current_events = | |
| 426 copy_event_chain (collapsing->current_events); | |
| 427 | |
| 428 new_buildings->most_current_event = | |
| 429 transfer_event_chain_pointer (collapsing->most_current_event, | |
| 430 collapsing->current_events, | |
| 431 new_buildings->current_events); | |
| 432 new_buildings->last_non_munged_event = | |
| 433 transfer_event_chain_pointer (collapsing->last_non_munged_event, | |
| 434 collapsing->current_events, | |
| 435 new_buildings->current_events); | |
| 1204 | 436 new_buildings->first_mungeable_event[0] = |
| 437 transfer_event_chain_pointer (collapsing->first_mungeable_event[0], | |
| 771 | 438 collapsing->current_events, |
| 439 new_buildings->current_events); | |
| 1204 | 440 new_buildings->first_mungeable_event[1] = |
| 441 transfer_event_chain_pointer (collapsing->first_mungeable_event[1], | |
| 771 | 442 collapsing->current_events, |
| 443 new_buildings->current_events); | |
| 444 | |
| 445 return wrap_command_builder (new_buildings); | |
| 446 } | |
| 447 | |
| 448 static void | |
| 449 free_command_builder (struct command_builder *builder) | |
| 450 { | |
| 451 if (builder->echo_buf) | |
| 452 { | |
|
4976
16112448d484
Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
453 xfree (builder->echo_buf); |
| 771 | 454 builder->echo_buf = NULL; |
| 455 } | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
456 free_normal_lisp_object (wrap_command_builder (builder)); |
| 771 | 457 } |
| 458 | |
| 428 | 459 static void |
| 460 command_builder_append_event (struct command_builder *builder, | |
| 461 Lisp_Object event) | |
| 462 { | |
| 463 assert (EVENTP (event)); | |
| 464 | |
| 771 | 465 event = Fcopy_event (event, Qnil); |
| 428 | 466 if (EVENTP (builder->most_current_event)) |
| 467 XSET_EVENT_NEXT (builder->most_current_event, event); | |
| 468 else | |
| 469 builder->current_events = event; | |
| 470 | |
| 471 builder->most_current_event = event; | |
| 1204 | 472 if (NILP (builder->first_mungeable_event[0])) |
| 473 builder->first_mungeable_event[0] = event; | |
| 474 if (NILP (builder->first_mungeable_event[1])) | |
| 475 builder->first_mungeable_event[1] = event; | |
| 428 | 476 } |
| 477 | |
| 478 | |
| 479 /**********************************************************************/ | |
| 480 /* Low-level interfaces onto event methods */ | |
| 481 /**********************************************************************/ | |
| 482 | |
| 483 static void | |
| 1268 | 484 check_event_stream_ok (void) |
| 428 | 485 { |
| 486 if (!event_stream && noninteractive) | |
| 814 | 487 /* See comment in init_event_stream() */ |
| 488 init_event_stream (); | |
| 489 else assert (event_stream); | |
| 428 | 490 } |
| 491 | |
| 492 void | |
| 440 | 493 event_stream_handle_magic_event (Lisp_Event *event) |
| 428 | 494 { |
| 1268 | 495 check_event_stream_ok (); |
| 428 | 496 event_stream->handle_magic_event_cb (event); |
| 497 } | |
| 498 | |
| 788 | 499 void |
| 500 event_stream_format_magic_event (Lisp_Event *event, Lisp_Object pstream) | |
| 501 { | |
| 1268 | 502 check_event_stream_ok (); |
| 788 | 503 event_stream->format_magic_event_cb (event, pstream); |
| 504 } | |
| 505 | |
| 506 int | |
| 507 event_stream_compare_magic_event (Lisp_Event *e1, Lisp_Event *e2) | |
| 508 { | |
| 1268 | 509 check_event_stream_ok (); |
| 788 | 510 return event_stream->compare_magic_event_cb (e1, e2); |
| 511 } | |
| 512 | |
| 513 Hashcode | |
| 514 event_stream_hash_magic_event (Lisp_Event *e) | |
| 515 { | |
| 1268 | 516 check_event_stream_ok (); |
| 788 | 517 return event_stream->hash_magic_event_cb (e); |
| 518 } | |
| 519 | |
| 428 | 520 static int |
| 521 event_stream_add_timeout (EMACS_TIME timeout) | |
| 522 { | |
| 1268 | 523 check_event_stream_ok (); |
| 428 | 524 return event_stream->add_timeout_cb (timeout); |
| 525 } | |
| 526 | |
| 527 static void | |
| 528 event_stream_remove_timeout (int id) | |
| 529 { | |
| 1268 | 530 check_event_stream_ok (); |
| 428 | 531 event_stream->remove_timeout_cb (id); |
| 532 } | |
| 533 | |
| 534 void | |
| 535 event_stream_select_console (struct console *con) | |
| 536 { | |
| 1268 | 537 check_event_stream_ok (); |
| 428 | 538 if (!con->input_enabled) |
| 539 { | |
| 540 event_stream->select_console_cb (con); | |
| 541 con->input_enabled = 1; | |
| 542 } | |
| 543 } | |
| 544 | |
| 545 void | |
| 546 event_stream_unselect_console (struct console *con) | |
| 547 { | |
| 1268 | 548 check_event_stream_ok (); |
| 428 | 549 if (con->input_enabled) |
| 550 { | |
| 551 event_stream->unselect_console_cb (con); | |
| 552 con->input_enabled = 0; | |
| 553 } | |
| 554 } | |
| 555 | |
| 556 void | |
| 853 | 557 event_stream_select_process (Lisp_Process *proc, int doin, int doerr) |
| 428 | 558 { |
| 853 | 559 int cur_in, cur_err; |
| 560 | |
| 1268 | 561 check_event_stream_ok (); |
| 853 | 562 |
| 563 cur_in = get_process_selected_p (proc, 0); | |
| 564 if (cur_in) | |
| 565 doin = 0; | |
| 566 | |
| 567 if (!process_has_separate_stderr (wrap_process (proc))) | |
| 428 | 568 { |
| 853 | 569 doerr = 0; |
| 570 cur_err = 0; | |
| 571 } | |
| 572 else | |
| 573 { | |
| 574 cur_err = get_process_selected_p (proc, 1); | |
| 575 if (cur_err) | |
| 576 doerr = 0; | |
| 577 } | |
| 578 | |
| 579 if (doin || doerr) | |
| 580 { | |
| 581 event_stream->select_process_cb (proc, doin, doerr); | |
| 582 set_process_selected_p (proc, cur_in || doin, cur_err || doerr); | |
| 428 | 583 } |
| 584 } | |
| 585 | |
| 586 void | |
| 853 | 587 event_stream_unselect_process (Lisp_Process *proc, int doin, int doerr) |
| 428 | 588 { |
| 853 | 589 int cur_in, cur_err; |
| 590 | |
| 1268 | 591 check_event_stream_ok (); |
| 853 | 592 |
| 593 cur_in = get_process_selected_p (proc, 0); | |
| 594 if (!cur_in) | |
| 595 doin = 0; | |
| 596 | |
| 597 if (!process_has_separate_stderr (wrap_process (proc))) | |
| 428 | 598 { |
| 853 | 599 doerr = 0; |
| 600 cur_err = 0; | |
| 601 } | |
| 602 else | |
| 603 { | |
| 604 cur_err = get_process_selected_p (proc, 1); | |
| 605 if (!cur_err) | |
| 606 doerr = 0; | |
| 607 } | |
| 608 | |
| 609 if (doin || doerr) | |
| 610 { | |
| 611 event_stream->unselect_process_cb (proc, doin, doerr); | |
| 612 set_process_selected_p (proc, cur_in && !doin, cur_err && !doerr); | |
| 428 | 613 } |
| 614 } | |
| 615 | |
| 853 | 616 void |
| 617 event_stream_create_io_streams (void *inhandle, void *outhandle, | |
| 618 void *errhandle, Lisp_Object *instream, | |
| 619 Lisp_Object *outstream, | |
| 620 Lisp_Object *errstream, | |
| 621 USID *in_usid, | |
| 622 USID *err_usid, | |
| 623 int flags) | |
| 428 | 624 { |
| 1268 | 625 check_event_stream_ok (); |
| 853 | 626 event_stream->create_io_streams_cb |
| 627 (inhandle, outhandle, errhandle, instream, outstream, errstream, | |
| 628 in_usid, err_usid, flags); | |
| 428 | 629 } |
| 630 | |
| 853 | 631 void |
| 632 event_stream_delete_io_streams (Lisp_Object instream, | |
| 633 Lisp_Object outstream, | |
| 634 Lisp_Object errstream, | |
| 635 USID *in_usid, | |
| 636 USID *err_usid) | |
| 428 | 637 { |
| 1268 | 638 check_event_stream_ok (); |
| 853 | 639 event_stream->delete_io_streams_cb (instream, outstream, errstream, |
| 640 in_usid, err_usid); | |
| 428 | 641 } |
| 642 | |
| 442 | 643 static int |
| 644 event_stream_current_event_timestamp (struct console *c) | |
| 645 { | |
| 646 if (event_stream && event_stream->current_event_timestamp_cb) | |
| 647 return event_stream->current_event_timestamp_cb (c); | |
| 648 else | |
| 649 return 0; | |
| 650 } | |
| 428 | 651 |
| 652 | |
| 653 /**********************************************************************/ | |
| 654 /* Character prompting */ | |
| 655 /**********************************************************************/ | |
| 656 | |
| 657 static void | |
| 658 echo_key_event (struct command_builder *command_builder, | |
| 659 Lisp_Object event) | |
| 660 { | |
| 661 /* This function can GC */ | |
| 793 | 662 DECLARE_EISTRING_MALLOC (buf); |
| 428 | 663 Bytecount buf_index = command_builder->echo_buf_index; |
| 867 | 664 Ibyte *e; |
| 428 | 665 Bytecount len; |
| 666 | |
| 667 if (buf_index < 0) | |
| 668 { | |
| 669 buf_index = 0; /* We're echoing now */ | |
| 670 clear_echo_area (selected_frame (), Qnil, 0); | |
| 671 } | |
| 672 | |
| 934 | 673 format_event_object (buf, event, 1); |
| 793 | 674 len = eilen (buf); |
| 428 | 675 |
| 676 if (len + buf_index + 4 > command_builder->echo_buf_length) | |
| 793 | 677 { |
| 678 eifree (buf); | |
| 679 return; | |
| 680 } | |
| 428 | 681 e = command_builder->echo_buf + buf_index; |
| 793 | 682 memcpy (e, eidata (buf), len); |
| 428 | 683 e += len; |
| 793 | 684 eifree (buf); |
| 428 | 685 |
| 686 e[0] = ' '; | |
| 687 e[1] = '-'; | |
| 688 e[2] = ' '; | |
| 689 e[3] = 0; | |
| 690 | |
| 691 command_builder->echo_buf_index = buf_index + len + 1; | |
| 692 } | |
| 693 | |
| 694 static void | |
| 695 regenerate_echo_keys_from_this_command_keys (struct command_builder * | |
| 696 builder) | |
| 697 { | |
| 698 Lisp_Object event; | |
| 699 | |
| 700 builder->echo_buf_index = 0; | |
| 701 | |
| 702 EVENT_CHAIN_LOOP (event, Vthis_command_keys) | |
| 703 echo_key_event (builder, event); | |
| 704 } | |
| 705 | |
| 706 static void | |
| 707 maybe_echo_keys (struct command_builder *command_builder, int no_snooze) | |
| 708 { | |
| 709 /* This function can GC */ | |
| 710 double echo_keystrokes; | |
| 711 struct frame *f = selected_frame (); | |
| 853 | 712 int depth = begin_dont_check_for_quit (); |
| 713 | |
| 428 | 714 /* Message turns off echoing unless more keystrokes turn it on again. */ |
| 715 if (echo_area_active (f) && !EQ (Qcommand, echo_area_status (f))) | |
| 853 | 716 goto done; |
| 428 | 717 |
| 718 if (INTP (Vecho_keystrokes) || FLOATP (Vecho_keystrokes)) | |
| 719 echo_keystrokes = extract_float (Vecho_keystrokes); | |
| 720 else | |
| 721 echo_keystrokes = 0; | |
| 722 | |
| 723 if (minibuf_level == 0 | |
| 724 && echo_keystrokes > 0.0 | |
| 442 | 725 #if defined (HAVE_X_WINDOWS) && defined (LWLIB_MENUBARS_LUCID) |
| 726 && !x_kludge_lw_menu_active () | |
| 727 #endif | |
| 728 ) | |
| 428 | 729 { |
| 730 if (!no_snooze) | |
| 731 { | |
| 732 if (NILP (Fsit_for (Vecho_keystrokes, Qnil))) | |
| 733 /* input came in, so don't echo. */ | |
| 853 | 734 goto done; |
| 428 | 735 } |
| 736 | |
| 737 echo_area_message (f, command_builder->echo_buf, Qnil, 0, | |
| 738 /* not echo_buf_index. That doesn't include | |
| 739 the terminating " - ". */ | |
| 740 strlen ((char *) command_builder->echo_buf), | |
| 741 Qcommand); | |
| 742 } | |
| 853 | 743 |
| 744 done: | |
| 745 Vquit_flag = Qnil; /* see begin_dont_check_for_quit() */ | |
| 746 unbind_to (depth); | |
| 428 | 747 } |
| 748 | |
| 749 static void | |
| 750 reset_key_echo (struct command_builder *command_builder, | |
| 751 int remove_echo_area_echo) | |
| 752 { | |
| 753 /* This function can GC */ | |
| 754 struct frame *f = selected_frame (); | |
| 755 | |
| 757 | 756 if (command_builder) |
| 757 command_builder->echo_buf_index = -1; | |
| 428 | 758 |
| 759 if (remove_echo_area_echo) | |
| 760 clear_echo_area (f, Qcommand, 0); | |
| 761 } | |
| 762 | |
| 763 | |
| 764 /**********************************************************************/ | |
| 765 /* random junk */ | |
| 766 /**********************************************************************/ | |
| 767 | |
| 768 /* NB: The following auto-save stuff is in keyboard.c in FSFmacs, and | |
| 769 keystrokes_since_auto_save is equivalent to the difference between | |
| 770 num_nonmacro_input_chars and last_auto_save. */ | |
| 771 | |
| 444 | 772 /* When an auto-save happens, record the number of keystrokes, and |
| 773 don't do again soon. */ | |
| 428 | 774 |
| 775 void | |
| 776 record_auto_save (void) | |
| 777 { | |
| 778 keystrokes_since_auto_save = 0; | |
| 779 } | |
| 780 | |
| 781 /* Make an auto save happen as soon as possible at command level. */ | |
| 782 | |
| 783 void | |
| 784 force_auto_save_soon (void) | |
| 785 { | |
| 786 keystrokes_since_auto_save = 1 + max (auto_save_interval, 20); | |
| 787 } | |
| 788 | |
| 789 static void | |
| 790 maybe_do_auto_save (void) | |
| 791 { | |
| 792 /* This function can call lisp */ | |
| 793 keystrokes_since_auto_save++; | |
| 794 if (auto_save_interval > 0 && | |
| 795 keystrokes_since_auto_save > max (auto_save_interval, 20) && | |
| 1268 | 796 !detect_input_pending (1)) |
| 428 | 797 { |
| 798 Fdo_auto_save (Qnil, Qnil); | |
| 799 record_auto_save (); | |
| 800 } | |
| 801 } | |
| 802 | |
| 803 static Lisp_Object | |
| 804 print_help (Lisp_Object object) | |
| 805 { | |
| 806 Fprinc (object, Qnil); | |
| 807 return Qnil; | |
| 808 } | |
| 809 | |
| 810 static void | |
| 811 execute_help_form (struct command_builder *command_builder, | |
| 812 Lisp_Object event) | |
| 813 { | |
| 814 /* This function can GC */ | |
| 815 Lisp_Object help = Qnil; | |
| 816 int speccount = specpdl_depth (); | |
| 817 Bytecount buf_index = command_builder->echo_buf_index; | |
| 818 Lisp_Object echo = ((buf_index <= 0) | |
| 819 ? Qnil | |
| 820 : make_string (command_builder->echo_buf, | |
| 821 buf_index)); | |
| 822 struct gcpro gcpro1, gcpro2; | |
| 823 GCPRO2 (echo, help); | |
| 824 | |
|
4775
1d61580e0cf7
Remove Fsave_window_excursion from window.c, it's overridden by Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4718
diff
changeset
|
825 record_unwind_protect (Feval, |
|
1d61580e0cf7
Remove Fsave_window_excursion from window.c, it's overridden by Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4718
diff
changeset
|
826 list2 (Qset_window_configuration, |
|
1d61580e0cf7
Remove Fsave_window_excursion from window.c, it's overridden by Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4718
diff
changeset
|
827 call0 (Qcurrent_window_configuration))); |
| 428 | 828 reset_key_echo (command_builder, 1); |
| 829 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4528
diff
changeset
|
830 help = IGNORE_MULTIPLE_VALUES (Feval (Vhelp_form)); |
| 428 | 831 if (STRINGP (help)) |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4932
diff
changeset
|
832 internal_with_output_to_temp_buffer (build_ascstring ("*Help*"), |
| 428 | 833 print_help, help, Qnil); |
| 834 Fnext_command_event (event, Qnil); | |
| 835 /* Remove the help from the frame */ | |
| 771 | 836 unbind_to (speccount); |
| 428 | 837 /* Hmmmm. Tricky. The unbind restores an old window configuration, |
| 838 apparently bypassing any setting of windows_structure_changed. | |
| 839 So we need to set it so that things get redrawn properly. */ | |
| 840 /* #### This is massive overkill. Look at doing it better once the | |
| 841 new redisplay is fully in place. */ | |
| 842 { | |
| 843 Lisp_Object frmcons, devcons, concons; | |
| 844 FRAME_LOOP_NO_BREAK (frmcons, devcons, concons) | |
| 845 { | |
| 846 struct frame *f = XFRAME (XCAR (frmcons)); | |
| 847 MARK_FRAME_WINDOWS_STRUCTURE_CHANGED (f); | |
| 848 } | |
| 849 } | |
| 850 | |
| 851 redisplay (); | |
| 1204 | 852 if (event_matches_key_specifier_p (event, make_char (' '))) |
| 428 | 853 { |
| 854 /* Discard next key if it is a space */ | |
| 855 reset_key_echo (command_builder, 1); | |
| 856 Fnext_command_event (event, Qnil); | |
| 857 } | |
| 858 | |
| 859 command_builder->echo_buf_index = buf_index; | |
| 860 if (buf_index > 0) | |
| 861 memcpy (command_builder->echo_buf, | |
| 862 XSTRING_DATA (echo), buf_index + 1); /* terminating 0 */ | |
| 863 UNGCPRO; | |
| 864 } | |
| 865 | |
| 866 | |
| 867 /**********************************************************************/ | |
| 868 /* timeouts */ | |
| 869 /**********************************************************************/ | |
| 870 | |
| 593 | 871 /* NOTE: "Low-level" or "interval" timeouts are one-shot timeouts that |
| 872 measure single intervals. "High-level timeouts" or "wakeups" are | |
| 873 the objects generated by `add-timeout' or `add-async-timout' -- | |
| 874 they can fire repeatedly (and in fact can have a different initial | |
| 875 time and resignal time). Given the nature of both setitimer() and | |
| 876 select() -- i.e. all we get is a single one-shot timer -- we have | |
| 877 to decompose all high-level timeouts into a series of intervals or | |
| 878 low-level timeouts. | |
| 879 | |
| 880 Low-level timeouts are of two varieties: synchronous and asynchronous. | |
| 881 The former are handled at the window-system level, the latter in | |
| 882 signal.c. | |
| 883 */ | |
| 884 | |
| 885 /**** Low-level timeout helper functions. **** | |
| 428 | 886 |
| 887 These functions maintain a sorted list of one-shot timeouts (where | |
| 593 | 888 the timeouts are in absolute time so we never lose any time as a |
| 889 result of the delay between noting an interval and firing the next | |
| 890 one). They are intended for use by functions that need to convert | |
| 891 a list of absolute timeouts into a series of intervals to wait | |
| 892 for. */ | |
| 428 | 893 |
| 894 /* We ensure that 0 is never a valid ID, so that a value of 0 can be | |
| 895 used to indicate an absence of a timer. */ | |
| 896 static int low_level_timeout_id_tick; | |
| 897 | |
| 898 static struct low_level_timeout_blocktype | |
| 899 { | |
| 900 Blocktype_declare (struct low_level_timeout); | |
| 901 } *the_low_level_timeout_blocktype; | |
| 902 | |
| 903 /* Add a one-shot timeout at time TIME to TIMEOUT_LIST. Return | |
| 904 a unique ID identifying the timeout. */ | |
| 905 | |
| 906 int | |
| 907 add_low_level_timeout (struct low_level_timeout **timeout_list, | |
| 908 EMACS_TIME thyme) | |
| 909 { | |
| 910 struct low_level_timeout *tm; | |
| 911 struct low_level_timeout *t, **tt; | |
| 912 | |
| 913 /* Allocate a new time struct. */ | |
| 914 | |
| 915 tm = Blocktype_alloc (the_low_level_timeout_blocktype); | |
| 916 tm->next = NULL; | |
| 593 | 917 /* Don't just use ++low_level_timeout_id_tick, for the (admittedly |
| 918 rare) case in which numbers wrap around. */ | |
| 428 | 919 if (low_level_timeout_id_tick == 0) |
| 920 low_level_timeout_id_tick++; | |
| 921 tm->id = low_level_timeout_id_tick++; | |
| 922 tm->time = thyme; | |
| 923 | |
| 924 /* Add it to the queue. */ | |
| 925 | |
| 926 tt = timeout_list; | |
| 927 t = *tt; | |
| 928 while (t && EMACS_TIME_EQUAL_OR_GREATER (tm->time, t->time)) | |
| 929 { | |
| 930 tt = &t->next; | |
| 931 t = *tt; | |
| 932 } | |
| 933 tm->next = t; | |
| 934 *tt = tm; | |
| 935 | |
| 936 return tm->id; | |
| 937 } | |
| 938 | |
| 939 /* Remove the low-level timeout identified by ID from TIMEOUT_LIST. | |
| 940 If the timeout is not there, do nothing. */ | |
| 941 | |
| 942 void | |
| 943 remove_low_level_timeout (struct low_level_timeout **timeout_list, int id) | |
| 944 { | |
| 945 struct low_level_timeout *t, *prev; | |
| 946 | |
| 947 /* find it */ | |
| 948 | |
| 949 for (t = *timeout_list, prev = NULL; t && t->id != id; t = t->next) | |
| 950 prev = t; | |
| 951 | |
| 952 if (!t) | |
| 953 return; /* couldn't find it */ | |
| 954 | |
| 955 if (!prev) | |
| 956 *timeout_list = t->next; | |
| 957 else prev->next = t->next; | |
| 958 | |
| 959 Blocktype_free (the_low_level_timeout_blocktype, t); | |
| 960 } | |
| 961 | |
| 962 /* If there are timeouts on TIMEOUT_LIST, store the relative time | |
| 963 interval to the first timeout on the list into INTERVAL and | |
| 964 return 1. Otherwise, return 0. */ | |
| 965 | |
| 966 int | |
| 967 get_low_level_timeout_interval (struct low_level_timeout *timeout_list, | |
| 968 EMACS_TIME *interval) | |
| 969 { | |
| 970 if (!timeout_list) /* no timer events; block indefinitely */ | |
| 971 return 0; | |
| 972 else | |
| 973 { | |
| 974 EMACS_TIME current_time; | |
| 975 | |
| 976 /* The time to block is the difference between the first | |
| 977 (earliest) timer on the queue and the current time. | |
| 978 If that is negative, then the timer will fire immediately | |
| 979 but we still have to call select(), with a zero-valued | |
| 980 timeout: user events must have precedence over timer events. */ | |
| 981 EMACS_GET_TIME (current_time); | |
| 982 if (EMACS_TIME_GREATER (timeout_list->time, current_time)) | |
| 983 EMACS_SUB_TIME (*interval, timeout_list->time, | |
| 984 current_time); | |
| 985 else | |
| 986 EMACS_SET_SECS_USECS (*interval, 0, 0); | |
| 987 return 1; | |
| 988 } | |
| 989 } | |
| 990 | |
| 991 /* Pop the first (i.e. soonest) timeout off of TIMEOUT_LIST and return | |
| 992 its ID. Also, if TIME_OUT is not 0, store the absolute time of the | |
| 993 timeout into TIME_OUT. */ | |
| 994 | |
| 995 int | |
| 996 pop_low_level_timeout (struct low_level_timeout **timeout_list, | |
| 997 EMACS_TIME *time_out) | |
| 998 { | |
| 999 struct low_level_timeout *tm = *timeout_list; | |
| 1000 int id; | |
| 1001 | |
| 1002 assert (tm); | |
| 1003 id = tm->id; | |
| 1004 if (time_out) | |
| 1005 *time_out = tm->time; | |
| 1006 *timeout_list = tm->next; | |
| 1007 Blocktype_free (the_low_level_timeout_blocktype, tm); | |
| 1008 return id; | |
| 1009 } | |
| 1010 | |
| 1011 | |
| 593 | 1012 /**** High-level timeout functions. **** */ |
| 1013 | |
| 1014 /* We ensure that 0 is never a valid ID, so that a value of 0 can be | |
| 1015 used to indicate an absence of a timer. */ | |
| 428 | 1016 static int timeout_id_tick; |
| 1017 | |
| 1018 static Lisp_Object pending_timeout_list, pending_async_timeout_list; | |
| 1019 | |
| 1020 static Lisp_Object | |
| 1021 mark_timeout (Lisp_Object obj) | |
| 1022 { | |
| 440 | 1023 Lisp_Timeout *tm = XTIMEOUT (obj); |
| 428 | 1024 mark_object (tm->function); |
| 1025 return tm->object; | |
| 1026 } | |
| 1027 | |
| 1204 | 1028 static const struct memory_description timeout_description[] = { |
| 440 | 1029 { XD_LISP_OBJECT, offsetof (Lisp_Timeout, function) }, |
| 1030 { XD_LISP_OBJECT, offsetof (Lisp_Timeout, object) }, | |
| 428 | 1031 { XD_END } |
| 1032 }; | |
| 1033 | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1034 DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT ("timeout", timeout, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1035 mark_timeout, timeout_description, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1036 Lisp_Timeout); |
| 428 | 1037 |
| 1038 /* Generate a timeout and return its ID. */ | |
| 1039 | |
| 1040 int | |
| 1041 event_stream_generate_wakeup (unsigned int milliseconds, | |
| 1042 unsigned int vanilliseconds, | |
| 1043 Lisp_Object function, Lisp_Object object, | |
| 1044 int async_p) | |
| 1045 { | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1046 Lisp_Object op = ALLOC_NORMAL_LISP_OBJECT (timeout); |
| 440 | 1047 Lisp_Timeout *timeout = XTIMEOUT (op); |
| 428 | 1048 EMACS_TIME current_time; |
| 1049 EMACS_TIME interval; | |
| 1050 | |
| 593 | 1051 /* Don't just use ++timeout_id_tick, for the (admittedly rare) case |
| 1052 in which numbers wrap around. */ | |
| 1053 if (timeout_id_tick == 0) | |
| 1054 timeout_id_tick++; | |
| 428 | 1055 timeout->id = timeout_id_tick++; |
| 1056 timeout->resignal_msecs = vanilliseconds; | |
| 1057 timeout->function = function; | |
| 1058 timeout->object = object; | |
| 1059 | |
| 1060 EMACS_GET_TIME (current_time); | |
| 1061 EMACS_SET_SECS_USECS (interval, milliseconds / 1000, | |
| 1062 1000 * (milliseconds % 1000)); | |
| 1063 EMACS_ADD_TIME (timeout->next_signal_time, current_time, interval); | |
| 1064 | |
| 1065 if (async_p) | |
| 1066 { | |
| 1067 timeout->interval_id = | |
| 593 | 1068 signal_add_async_interval_timeout (timeout->next_signal_time); |
| 1069 pending_async_timeout_list = | |
| 1070 noseeum_cons (op, pending_async_timeout_list); | |
| 428 | 1071 } |
| 1072 else | |
| 1073 { | |
| 1074 timeout->interval_id = | |
| 1075 event_stream_add_timeout (timeout->next_signal_time); | |
| 1076 pending_timeout_list = noseeum_cons (op, pending_timeout_list); | |
| 1077 } | |
| 1078 return timeout->id; | |
| 1079 } | |
| 1080 | |
| 1081 /* Given the INTERVAL-ID of a timeout just signalled, resignal the timeout | |
| 1082 as necessary and return the timeout's ID and function and object slots. | |
| 1083 | |
| 1084 This should be called as a result of receiving notice that a timeout | |
| 1085 has fired. INTERVAL-ID is *not* the timeout's ID, but is the ID that | |
| 1086 identifies this particular firing of the timeout. INTERVAL-ID's and | |
| 1087 timeout ID's are in separate number spaces and bear no relation to | |
| 1088 each other. The INTERVAL-ID is all that the event callback routines | |
| 1089 work with: they work only with one-shot intervals, not with timeouts | |
| 1090 that may fire repeatedly. | |
| 1091 | |
| 1092 NOTE: The returned FUNCTION and OBJECT are *not* GC-protected at all. | |
| 1093 */ | |
| 1094 | |
| 593 | 1095 int |
| 428 | 1096 event_stream_resignal_wakeup (int interval_id, int async_p, |
| 1097 Lisp_Object *function, Lisp_Object *object) | |
| 1098 { | |
| 1099 Lisp_Object op = Qnil, rest; | |
| 440 | 1100 Lisp_Timeout *timeout; |
| 428 | 1101 Lisp_Object *timeout_list; |
| 1102 struct gcpro gcpro1; | |
| 1103 int id; | |
| 1104 | |
| 1105 GCPRO1 (op); /* just in case ... because it's removed from the list | |
| 1106 for awhile. */ | |
| 1107 | |
| 1108 timeout_list = async_p ? &pending_async_timeout_list : &pending_timeout_list; | |
| 1109 | |
| 1110 /* Find the timeout on the list of pending ones. */ | |
| 1111 LIST_LOOP (rest, *timeout_list) | |
| 1112 { | |
| 1113 timeout = XTIMEOUT (XCAR (rest)); | |
| 1114 if (timeout->interval_id == interval_id) | |
| 1115 break; | |
| 1116 } | |
| 1117 | |
| 1118 assert (!NILP (rest)); | |
| 1119 op = XCAR (rest); | |
| 1120 timeout = XTIMEOUT (op); | |
| 1121 /* We make sure to snarf the data out of the timeout object before | |
| 1122 we free it with free_managed_lcrecord(). */ | |
| 1123 id = timeout->id; | |
| 1124 *function = timeout->function; | |
| 1125 *object = timeout->object; | |
| 1126 | |
| 1127 /* Remove this one from the list of pending timeouts */ | |
| 1128 *timeout_list = delq_no_quit_and_free_cons (op, *timeout_list); | |
| 1129 | |
| 1130 /* If this timeout wants to be resignalled, do it now. */ | |
| 1131 if (timeout->resignal_msecs) | |
| 1132 { | |
| 1133 EMACS_TIME current_time; | |
| 1134 EMACS_TIME interval; | |
| 1135 | |
| 1136 /* Determine the time that the next resignalling should occur. | |
| 1137 We do that by adding the interval time to the last signalled | |
| 1138 time until we get a time that's current. | |
| 1139 | |
| 1140 (This way, it doesn't matter if the timeout was signalled | |
| 1141 exactly when we asked for it, or at some time later.) | |
| 1142 */ | |
| 1143 EMACS_GET_TIME (current_time); | |
| 1144 EMACS_SET_SECS_USECS (interval, timeout->resignal_msecs / 1000, | |
| 1145 1000 * (timeout->resignal_msecs % 1000)); | |
| 1146 do | |
| 1147 { | |
| 1148 EMACS_ADD_TIME (timeout->next_signal_time, timeout->next_signal_time, | |
| 1149 interval); | |
| 1150 } while (EMACS_TIME_GREATER (current_time, timeout->next_signal_time)); | |
| 1151 | |
| 1152 if (async_p) | |
| 1153 timeout->interval_id = | |
| 593 | 1154 signal_add_async_interval_timeout (timeout->next_signal_time); |
| 428 | 1155 else |
| 1156 timeout->interval_id = | |
| 1157 event_stream_add_timeout (timeout->next_signal_time); | |
| 1158 /* Add back onto the list. Note that the effect of this | |
| 1159 is to move frequently-hit timeouts to the front of the | |
| 1160 list, which is a good thing. */ | |
| 1161 *timeout_list = noseeum_cons (op, *timeout_list); | |
| 1162 } | |
| 1163 else | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1164 free_normal_lisp_object (op); |
| 428 | 1165 |
| 1166 UNGCPRO; | |
| 1167 return id; | |
| 1168 } | |
| 1169 | |
| 1170 void | |
| 1171 event_stream_disable_wakeup (int id, int async_p) | |
| 1172 { | |
| 440 | 1173 Lisp_Timeout *timeout = 0; |
| 428 | 1174 Lisp_Object rest; |
| 1175 Lisp_Object *timeout_list; | |
| 1176 | |
| 1177 if (async_p) | |
| 1178 timeout_list = &pending_async_timeout_list; | |
| 1179 else | |
| 1180 timeout_list = &pending_timeout_list; | |
| 1181 | |
| 1182 /* Find the timeout on the list of pending ones, if it's still there. */ | |
| 1183 LIST_LOOP (rest, *timeout_list) | |
| 1184 { | |
| 1185 timeout = XTIMEOUT (XCAR (rest)); | |
| 1186 if (timeout->id == id) | |
| 1187 break; | |
| 1188 } | |
| 1189 | |
| 1190 /* If we found it, remove it from the list and disable the pending | |
| 1191 one-shot. */ | |
| 1192 if (!NILP (rest)) | |
| 1193 { | |
| 1194 Lisp_Object op = XCAR (rest); | |
| 1195 *timeout_list = | |
| 1196 delq_no_quit_and_free_cons (op, *timeout_list); | |
| 1197 if (async_p) | |
| 593 | 1198 signal_remove_async_interval_timeout (timeout->interval_id); |
| 428 | 1199 else |
| 1200 event_stream_remove_timeout (timeout->interval_id); | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1201 free_normal_lisp_object (op); |
| 428 | 1202 } |
| 1203 } | |
| 1204 | |
| 1205 static int | |
| 1206 event_stream_wakeup_pending_p (int id, int async_p) | |
| 1207 { | |
| 440 | 1208 Lisp_Timeout *timeout; |
| 428 | 1209 Lisp_Object rest; |
| 1210 Lisp_Object timeout_list; | |
| 1211 int found = 0; | |
| 1212 | |
| 1213 | |
| 1214 if (async_p) | |
| 1215 timeout_list = pending_async_timeout_list; | |
| 1216 else | |
| 1217 timeout_list = pending_timeout_list; | |
| 1218 | |
| 1219 /* Find the element on the list of pending ones, if it's still there. */ | |
| 1220 LIST_LOOP (rest, timeout_list) | |
| 1221 { | |
| 1222 timeout = XTIMEOUT (XCAR (rest)); | |
| 1223 if (timeout->id == id) | |
| 1224 { | |
| 1225 found = 1; | |
| 1226 break; | |
| 1227 } | |
| 1228 } | |
| 1229 | |
| 1230 return found; | |
| 1231 } | |
| 1232 | |
| 1233 | |
| 1234 /**** Lisp-level timeout functions. ****/ | |
| 1235 | |
| 1236 static unsigned long | |
| 1237 lisp_number_to_milliseconds (Lisp_Object secs, int allow_0) | |
| 1238 { | |
| 1239 double fsecs; | |
| 1240 CHECK_INT_OR_FLOAT (secs); | |
| 1241 fsecs = XFLOATINT (secs); | |
| 1242 if (fsecs < 0) | |
| 563 | 1243 invalid_argument ("timeout is negative", secs); |
| 428 | 1244 if (!allow_0 && fsecs == 0) |
| 563 | 1245 invalid_argument ("timeout is non-positive", secs); |
| 428 | 1246 if (fsecs >= (((unsigned int) 0xFFFFFFFF) / 1000)) |
| 563 | 1247 invalid_argument |
| 428 | 1248 ("timeout would exceed 32 bits when represented in milliseconds", secs); |
| 1249 | |
| 1250 return (unsigned long) (1000 * fsecs); | |
| 1251 } | |
| 1252 | |
| 1253 DEFUN ("add-timeout", Fadd_timeout, 3, 4, 0, /* | |
| 1254 Add a timeout, to be signaled after the timeout period has elapsed. | |
| 1255 SECS is a number of seconds, expressed as an integer or a float. | |
| 1256 FUNCTION will be called after that many seconds have elapsed, with one | |
| 1257 argument, the given OBJECT. If the optional RESIGNAL argument is provided, | |
| 1258 then after this timeout expires, `add-timeout' will automatically be called | |
| 1259 again with RESIGNAL as the first argument. | |
| 1260 | |
| 1261 This function returns an object which is the id number of this particular | |
| 1262 timeout. You can pass that object to `disable-timeout' to turn off the | |
| 1263 timeout before it has been signalled. | |
| 1264 | |
| 1265 NOTE: Id numbers as returned by this function are in a distinct namespace | |
| 1266 from those returned by `add-async-timeout'. This means that the same id | |
| 1267 number could refer to a pending synchronous timeout and a different pending | |
| 1268 asynchronous timeout, and that you cannot pass an id from `add-timeout' | |
| 1269 to `disable-async-timeout', or vice-versa. | |
| 1270 | |
| 1271 The number of seconds may be expressed as a floating-point number, in which | |
| 1272 case some fractional part of a second will be used. Caveat: the usable | |
| 1273 timeout granularity will vary from system to system. | |
| 1274 | |
| 1275 Adding a timeout causes a timeout event to be returned by `next-event', and | |
| 1276 the function will be invoked by `dispatch-event,' so if emacs is in a tight | |
| 1277 loop, the function will not be invoked until the next call to sit-for or | |
| 1278 until the return to top-level (the same is true of process filters). | |
| 1279 | |
| 1280 If you need to have a timeout executed even when XEmacs is in the midst of | |
| 1281 running Lisp code, use `add-async-timeout'. | |
| 1282 | |
| 1283 WARNING: if you are thinking of calling add-timeout from inside of a | |
| 1284 callback function as a way of resignalling a timeout, think again. There | |
| 1285 is a race condition. That's why the RESIGNAL argument exists. | |
| 1286 */ | |
| 1287 (secs, function, object, resignal)) | |
| 1288 { | |
| 1289 unsigned long msecs = lisp_number_to_milliseconds (secs, 0); | |
| 1290 unsigned long msecs2 = (NILP (resignal) ? 0 : | |
| 1291 lisp_number_to_milliseconds (resignal, 0)); | |
| 1292 int id; | |
| 1293 Lisp_Object lid; | |
| 1294 id = event_stream_generate_wakeup (msecs, msecs2, function, object, 0); | |
| 1295 lid = make_int (id); | |
|
5050
6f2158fa75ed
Fix quick-build, use asserts() in place of ABORT()
Ben Wing <ben@xemacs.org>
parents:
4976
diff
changeset
|
1296 assert (id == XINT (lid)); |
| 428 | 1297 return lid; |
| 1298 } | |
| 1299 | |
| 1300 DEFUN ("disable-timeout", Fdisable_timeout, 1, 1, 0, /* | |
| 1301 Disable a timeout from signalling any more. | |
| 1302 ID should be a timeout id number as returned by `add-timeout'. If ID | |
| 1303 corresponds to a one-shot timeout that has already signalled, nothing | |
| 1304 will happen. | |
| 1305 | |
| 1306 It will not work to call this function on an id number returned by | |
| 1307 `add-async-timeout'. Use `disable-async-timeout' for that. | |
| 1308 */ | |
| 1309 (id)) | |
| 1310 { | |
| 1311 CHECK_INT (id); | |
| 1312 event_stream_disable_wakeup (XINT (id), 0); | |
| 1313 return Qnil; | |
| 1314 } | |
| 1315 | |
| 1316 DEFUN ("add-async-timeout", Fadd_async_timeout, 3, 4, 0, /* | |
| 1317 Add an asynchronous timeout, to be signaled after an interval has elapsed. | |
| 1318 SECS is a number of seconds, expressed as an integer or a float. | |
| 1319 FUNCTION will be called after that many seconds have elapsed, with one | |
| 1320 argument, the given OBJECT. If the optional RESIGNAL argument is provided, | |
| 1321 then after this timeout expires, `add-async-timeout' will automatically be | |
| 1322 called again with RESIGNAL as the first argument. | |
| 1323 | |
| 1324 This function returns an object which is the id number of this particular | |
| 1325 timeout. You can pass that object to `disable-async-timeout' to turn off | |
| 1326 the timeout before it has been signalled. | |
| 1327 | |
| 1328 NOTE: Id numbers as returned by this function are in a distinct namespace | |
| 1329 from those returned by `add-timeout'. This means that the same id number | |
| 1330 could refer to a pending synchronous timeout and a different pending | |
| 1331 asynchronous timeout, and that you cannot pass an id from | |
| 1332 `add-async-timeout' to `disable-timeout', or vice-versa. | |
| 1333 | |
| 1334 The number of seconds may be expressed as a floating-point number, in which | |
| 1335 case some fractional part of a second will be used. Caveat: the usable | |
| 1336 timeout granularity will vary from system to system. | |
| 1337 | |
| 1338 Adding an asynchronous timeout causes the function to be invoked as soon | |
| 1339 as the timeout occurs, even if XEmacs is in the midst of executing some | |
| 1340 other code. (This is unlike the synchronous timeouts added with | |
| 1341 `add-timeout', where the timeout will only be signalled when XEmacs is | |
| 1342 waiting for events, i.e. the next return to top-level or invocation of | |
| 1343 `sit-for' or related functions.) This means that the function that is | |
| 1344 called *must* not signal an error or change any global state (e.g. switch | |
| 1345 buffers or windows) except when locking code is in place to make sure | |
| 1346 that race conditions don't occur in the interaction between the | |
| 1347 asynchronous timeout function and other code. | |
| 1348 | |
| 1349 Under most circumstances, you should use `add-timeout' instead, as it is | |
| 1350 much safer. Asynchronous timeouts should only be used when such behavior | |
| 1351 is really necessary. | |
| 1352 | |
| 1353 Asynchronous timeouts are blocked and will not occur when `inhibit-quit' | |
| 1354 is non-nil. As soon as `inhibit-quit' becomes nil again, any pending | |
| 1355 asynchronous timeouts will get called immediately. (Multiple occurrences | |
| 1356 of the same asynchronous timeout are not queued, however.) While the | |
| 1357 callback function of an asynchronous timeout is invoked, `inhibit-quit' | |
| 1358 is automatically bound to non-nil, and thus other asynchronous timeouts | |
| 1359 will be blocked unless the callback function explicitly sets `inhibit-quit' | |
| 1360 to nil. | |
| 1361 | |
| 1362 WARNING: if you are thinking of calling `add-async-timeout' from inside of a | |
| 1363 callback function as a way of resignalling a timeout, think again. There | |
| 1364 is a race condition. That's why the RESIGNAL argument exists. | |
| 1365 */ | |
| 1366 (secs, function, object, resignal)) | |
| 1367 { | |
| 1368 unsigned long msecs = lisp_number_to_milliseconds (secs, 0); | |
| 1369 unsigned long msecs2 = (NILP (resignal) ? 0 : | |
| 1370 lisp_number_to_milliseconds (resignal, 0)); | |
| 1371 int id; | |
| 1372 Lisp_Object lid; | |
| 1373 id = event_stream_generate_wakeup (msecs, msecs2, function, object, 1); | |
| 1374 lid = make_int (id); | |
|
5050
6f2158fa75ed
Fix quick-build, use asserts() in place of ABORT()
Ben Wing <ben@xemacs.org>
parents:
4976
diff
changeset
|
1375 assert (id == XINT (lid)); |
| 428 | 1376 return lid; |
| 1377 } | |
| 1378 | |
| 1379 DEFUN ("disable-async-timeout", Fdisable_async_timeout, 1, 1, 0, /* | |
| 1380 Disable an asynchronous timeout from signalling any more. | |
| 1381 ID should be a timeout id number as returned by `add-async-timeout'. If ID | |
| 1382 corresponds to a one-shot timeout that has already signalled, nothing | |
| 1383 will happen. | |
| 1384 | |
| 1385 It will not work to call this function on an id number returned by | |
| 1386 `add-timeout'. Use `disable-timeout' for that. | |
| 1387 */ | |
| 1388 (id)) | |
| 1389 { | |
| 1390 CHECK_INT (id); | |
| 1391 event_stream_disable_wakeup (XINT (id), 1); | |
| 1392 return Qnil; | |
| 1393 } | |
| 1394 | |
| 1395 | |
| 1396 /**********************************************************************/ | |
| 1397 /* enqueuing and dequeuing events */ | |
| 1398 /**********************************************************************/ | |
| 1399 | |
| 1400 /* Add an event to the back of the command-event queue: it will be the next | |
| 1401 event read after all pending events. This only works on keyboard, | |
| 1402 mouse-click, misc-user, and eval events. | |
| 1403 */ | |
| 1404 static void | |
| 1405 enqueue_command_event (Lisp_Object event) | |
| 1406 { | |
| 1407 enqueue_event (event, &command_event_queue, &command_event_queue_tail); | |
| 1408 } | |
| 1409 | |
| 1410 static Lisp_Object | |
| 1411 dequeue_command_event (void) | |
| 1412 { | |
| 1413 return dequeue_event (&command_event_queue, &command_event_queue_tail); | |
| 1414 } | |
| 1415 | |
| 1204 | 1416 void |
| 1417 enqueue_dispatch_event (Lisp_Object event) | |
| 1418 { | |
| 1419 enqueue_event (event, &dispatch_event_queue, &dispatch_event_queue_tail); | |
| 1420 } | |
| 1421 | |
| 1422 Lisp_Object | |
| 1423 dequeue_dispatch_event (void) | |
| 1424 { | |
| 1425 return dequeue_event (&dispatch_event_queue, &dispatch_event_queue_tail); | |
| 1426 } | |
| 1427 | |
| 428 | 1428 static void |
| 1429 enqueue_command_event_1 (Lisp_Object event_to_copy) | |
| 1430 { | |
| 853 | 1431 enqueue_command_event (Fcopy_event (event_to_copy, Qnil)); |
| 428 | 1432 } |
| 1433 | |
| 1434 void | |
| 1435 enqueue_magic_eval_event (void (*fun) (Lisp_Object), Lisp_Object object) | |
| 1436 { | |
| 1437 Lisp_Object event = Fmake_event (Qnil, Qnil); | |
| 934 | 1438 XSET_EVENT_TYPE (event, magic_eval_event); |
| 1439 /* channel for magic_eval events is nil */ | |
| 1204 | 1440 XSET_EVENT_MAGIC_EVAL_INTERNAL_FUNCTION (event, fun); |
| 1441 XSET_EVENT_MAGIC_EVAL_OBJECT (event, object); | |
| 428 | 1442 enqueue_command_event (event); |
| 1443 } | |
| 1444 | |
| 1445 DEFUN ("enqueue-eval-event", Fenqueue_eval_event, 2, 2, 0, /* | |
| 1446 Add an eval event to the back of the eval event queue. | |
| 1447 When this event is dispatched, FUNCTION (which should be a function | |
| 1448 of one argument) will be called with OBJECT as its argument. | |
| 1449 See `next-event' for a description of event types and how events | |
| 1450 are received. | |
| 1451 */ | |
| 1452 (function, object)) | |
| 1453 { | |
| 1454 Lisp_Object event = Fmake_event (Qnil, Qnil); | |
| 1455 | |
| 934 | 1456 XSET_EVENT_TYPE (event, eval_event); |
| 1457 /* channel for eval events is nil */ | |
| 1204 | 1458 XSET_EVENT_EVAL_FUNCTION (event, function); |
| 1459 XSET_EVENT_EVAL_OBJECT (event, object); | |
| 428 | 1460 enqueue_command_event (event); |
| 1461 | |
| 1462 return event; | |
| 1463 } | |
| 1464 | |
| 1465 Lisp_Object | |
| 1466 enqueue_misc_user_event (Lisp_Object channel, Lisp_Object function, | |
| 1467 Lisp_Object object) | |
| 1468 { | |
| 1469 Lisp_Object event = Fmake_event (Qnil, Qnil); | |
| 934 | 1470 XSET_EVENT_TYPE (event, misc_user_event); |
| 1471 XSET_EVENT_CHANNEL (event, channel); | |
| 1204 | 1472 XSET_EVENT_MISC_USER_FUNCTION (event, function); |
| 1473 XSET_EVENT_MISC_USER_OBJECT (event, object); | |
| 1474 XSET_EVENT_MISC_USER_BUTTON (event, 0); | |
| 1475 XSET_EVENT_MISC_USER_MODIFIERS (event, 0); | |
| 1476 XSET_EVENT_MISC_USER_X (event, -1); | |
| 1477 XSET_EVENT_MISC_USER_Y (event, -1); | |
| 428 | 1478 enqueue_command_event (event); |
| 1479 | |
| 1480 return event; | |
| 1481 } | |
| 1482 | |
| 1483 Lisp_Object | |
| 1484 enqueue_misc_user_event_pos (Lisp_Object channel, Lisp_Object function, | |
| 1485 Lisp_Object object, | |
| 1486 int button, int modifiers, int x, int y) | |
| 1487 { | |
| 1488 Lisp_Object event = Fmake_event (Qnil, Qnil); | |
| 1489 | |
| 934 | 1490 XSET_EVENT_TYPE (event, misc_user_event); |
| 1491 XSET_EVENT_CHANNEL (event, channel); | |
| 1204 | 1492 XSET_EVENT_MISC_USER_FUNCTION (event, function); |
| 1493 XSET_EVENT_MISC_USER_OBJECT (event, object); | |
| 1494 XSET_EVENT_MISC_USER_BUTTON (event, button); | |
| 1495 XSET_EVENT_MISC_USER_MODIFIERS (event, modifiers); | |
| 1496 XSET_EVENT_MISC_USER_X (event, x); | |
| 1497 XSET_EVENT_MISC_USER_Y (event, y); | |
| 428 | 1498 enqueue_command_event (event); |
| 1499 | |
| 1500 return event; | |
| 1501 } | |
| 1502 | |
| 1503 | |
| 1504 /**********************************************************************/ | |
| 1505 /* focus-event handling */ | |
| 1506 /**********************************************************************/ | |
| 1507 | |
| 1508 /* | |
| 1509 | |
| 2367 | 1510 See also |
| 1511 | |
| 1512 (Info-goto-node "(internals)Focus Handling") | |
| 428 | 1513 */ |
| 1514 | |
| 2367 | 1515 |
| 428 | 1516 static void |
| 1517 run_select_frame_hook (void) | |
| 1518 { | |
| 1519 run_hook (Qselect_frame_hook); | |
| 1520 } | |
| 1521 | |
| 1522 static void | |
| 1523 run_deselect_frame_hook (void) | |
| 1524 { | |
| 1525 run_hook (Qdeselect_frame_hook); | |
| 1526 } | |
| 1527 | |
| 1528 /* When select-frame is called and focus_follows_mouse is false, we want | |
| 1529 to tell the window system that the focus should be changed to point to | |
| 1530 the new frame. However, | |
| 1531 sometimes Lisp functions will temporarily change the selected frame | |
| 1532 (e.g. to call a function that operates on the selected frame), | |
| 1533 and it's annoying if this focus-change happens exactly when | |
| 1534 select-frame is called, because then you get some flickering of the | |
| 1535 window-manager border and perhaps other undesirable results. We | |
| 1536 really only want to change the focus when we're about to retrieve | |
| 1537 an event from the user. To do this, we keep track of the frame | |
| 1538 where the window-manager focus lies on, and just before waiting | |
| 1539 for user events, check the currently selected frame and change | |
| 1540 the focus as necessary. | |
| 1541 | |
| 1542 On the other hand, if focus_follows_mouse is true, we need to switch the | |
| 1543 selected frame back to the frame with window manager focus just before we | |
| 1544 execute the next command in Fcommand_loop_1, just as the selected buffer is | |
| 1545 reverted after a set-buffer. | |
| 1546 | |
| 1547 Both cases are handled by this function. It must be called as appropriate | |
| 1548 from these two places, depending on the value of focus_follows_mouse. */ | |
| 1549 | |
| 1550 void | |
| 1551 investigate_frame_change (void) | |
| 1552 { | |
| 1553 Lisp_Object devcons, concons; | |
| 1554 | |
| 1555 /* if the selected frame was changed, change the window-system | |
| 1556 focus to the new frame. We don't do it when select-frame was | |
| 1557 called, to avoid flickering and other unwanted side effects when | |
| 1558 the frame is just changed temporarily. */ | |
| 1559 DEVICE_LOOP_NO_BREAK (devcons, concons) | |
| 1560 { | |
| 1561 struct device *d = XDEVICE (XCAR (devcons)); | |
| 1562 Lisp_Object sel_frame = DEVICE_SELECTED_FRAME (d); | |
| 1563 | |
| 1564 /* You'd think that maybe we should use FRAME_WITH_FOCUS_REAL, | |
| 1565 but that can cause us to end up in an infinite loop focusing | |
| 1566 between two frames. It seems that since the call to `select-frame' | |
| 1567 in emacs_handle_focus_change_final() is based on the _FOR_HOOKS | |
| 1568 value, we need to do so too. */ | |
| 1569 if (!NILP (sel_frame) && | |
| 1570 !EQ (DEVICE_FRAME_THAT_OUGHT_TO_HAVE_FOCUS (d), sel_frame) && | |
| 1571 !NILP (DEVICE_FRAME_WITH_FOCUS_FOR_HOOKS (d)) && | |
| 1572 !EQ (DEVICE_FRAME_WITH_FOCUS_FOR_HOOKS (d), sel_frame)) | |
| 1573 { | |
| 1574 /* At this point, we know that the frame has been changed. Now, if | |
| 1575 * focus_follows_mouse is not set, we finish off the frame change, | |
| 1576 * so that user events will now come from the new frame. Otherwise, | |
| 1577 * if focus_follows_mouse is set, no gratuitous frame changing | |
| 1578 * should take place. Set the focus back to the frame which was | |
| 1579 * originally selected for user input. | |
| 1580 */ | |
| 1581 if (!focus_follows_mouse) | |
| 1582 { | |
| 1583 /* prevent us from issuing the same request more than once */ | |
| 1584 DEVICE_FRAME_THAT_OUGHT_TO_HAVE_FOCUS (d) = sel_frame; | |
| 1585 MAYBE_DEVMETH (d, focus_on_frame, (XFRAME (sel_frame))); | |
| 1586 } | |
| 1587 else | |
| 1588 { | |
| 1589 Lisp_Object old_frame = Qnil; | |
| 1590 | |
| 1591 /* #### Do we really want to check OUGHT ?? | |
| 1592 * It seems to make sense, though I have never seen us | |
| 1593 * get here and have it be non-nil. | |
| 1594 */ | |
| 1595 if (FRAMEP (DEVICE_FRAME_THAT_OUGHT_TO_HAVE_FOCUS (d))) | |
| 1596 old_frame = DEVICE_FRAME_THAT_OUGHT_TO_HAVE_FOCUS (d); | |
| 1597 else if (FRAMEP (DEVICE_FRAME_WITH_FOCUS_FOR_HOOKS (d))) | |
| 1598 old_frame = DEVICE_FRAME_WITH_FOCUS_FOR_HOOKS (d); | |
| 1599 | |
| 1600 /* #### Can old_frame ever be NIL? play it safe.. */ | |
| 1601 if (!NILP (old_frame)) | |
| 1602 { | |
| 1603 /* Fselect_frame is not really the right thing: it frobs the | |
| 1604 * buffer stack. But there's no easy way to do the right | |
| 1605 * thing, and this code already had this problem anyway. | |
| 1606 */ | |
| 1607 Fselect_frame (old_frame); | |
| 1608 } | |
| 1609 } | |
| 1610 } | |
| 1611 } | |
| 1612 } | |
| 1613 | |
| 1614 static Lisp_Object | |
| 1615 cleanup_after_missed_defocusing (Lisp_Object frame) | |
| 1616 { | |
| 1617 if (FRAMEP (frame) && FRAME_LIVE_P (XFRAME (frame))) | |
| 1618 Fselect_frame (frame); | |
| 1619 return Qnil; | |
| 1620 } | |
| 1621 | |
| 1622 void | |
| 1623 emacs_handle_focus_change_preliminary (Lisp_Object frame_inp_and_dev) | |
| 1624 { | |
| 1625 Lisp_Object frame = Fcar (frame_inp_and_dev); | |
| 1626 Lisp_Object device = Fcar (Fcdr (frame_inp_and_dev)); | |
| 1627 int in_p = !NILP (Fcdr (Fcdr (frame_inp_and_dev))); | |
| 1628 struct device *d; | |
| 1629 | |
| 1630 if (!DEVICE_LIVE_P (XDEVICE (device))) | |
| 1631 return; | |
| 1632 else | |
| 1633 d = XDEVICE (device); | |
| 1634 | |
| 1635 /* Any received focus-change notifications render invalid any | |
| 1636 pending focus-change requests. */ | |
| 1637 DEVICE_FRAME_THAT_OUGHT_TO_HAVE_FOCUS (d) = Qnil; | |
| 1638 if (in_p) | |
| 1639 { | |
| 1640 Lisp_Object focus_frame; | |
| 1641 | |
| 1642 if (!FRAME_LIVE_P (XFRAME (frame))) | |
| 1643 return; | |
| 1644 else | |
| 1645 focus_frame = DEVICE_FRAME_WITH_FOCUS_REAL (d); | |
| 1646 | |
| 1647 /* Mark the minibuffer as changed to make sure it gets updated | |
| 1648 properly if the echo area is active. */ | |
| 1649 { | |
| 1650 struct window *w = XWINDOW (FRAME_MINIBUF_WINDOW (XFRAME (frame))); | |
| 1651 MARK_WINDOWS_CHANGED (w); | |
| 1652 } | |
| 1653 | |
| 452 | 1654 if (FRAMEP (focus_frame) && FRAME_LIVE_P (XFRAME (focus_frame)) |
| 1655 && !EQ (frame, focus_frame)) | |
| 428 | 1656 { |
| 1657 /* Oops, we missed a focus-out event. */ | |
| 1658 DEVICE_FRAME_WITH_FOCUS_REAL (d) = Qnil; | |
| 1659 redisplay_redraw_cursor (XFRAME (focus_frame), 1); | |
| 1660 } | |
| 1661 DEVICE_FRAME_WITH_FOCUS_REAL (d) = frame; | |
| 1662 if (!EQ (frame, focus_frame)) | |
| 1663 { | |
| 1664 redisplay_redraw_cursor (XFRAME (frame), 1); | |
| 1665 } | |
| 1666 } | |
| 1667 else | |
| 1668 { | |
| 1669 /* We ignore the frame reported in the event. If it's different | |
| 1670 from where we think the focus was, oh well -- we messed up. | |
| 1671 Nonetheless, we pretend we were right, for sensible behavior. */ | |
| 1672 frame = DEVICE_FRAME_WITH_FOCUS_REAL (d); | |
| 1673 if (!NILP (frame)) | |
| 1674 { | |
| 1675 DEVICE_FRAME_WITH_FOCUS_REAL (d) = Qnil; | |
| 1676 | |
| 1677 if (FRAME_LIVE_P (XFRAME (frame))) | |
| 1678 redisplay_redraw_cursor (XFRAME (frame), 1); | |
| 1679 } | |
| 1680 } | |
| 1681 } | |
| 1682 | |
| 1683 /* Called from the window-system-specific code when we receive a | |
| 1684 notification that the focus lies on a particular frame. | |
| 1685 Argument is a cons: (frame . (device . in-p)) where in-p is non-nil | |
| 1686 for focus-in. | |
| 1687 */ | |
| 1688 void | |
| 1689 emacs_handle_focus_change_final (Lisp_Object frame_inp_and_dev) | |
| 1690 { | |
| 1691 Lisp_Object frame = Fcar (frame_inp_and_dev); | |
| 1692 Lisp_Object device = Fcar (Fcdr (frame_inp_and_dev)); | |
| 1693 int in_p = !NILP (Fcdr (Fcdr (frame_inp_and_dev))); | |
| 1694 struct device *d; | |
| 1695 int count; | |
| 1696 | |
| 1697 if (!DEVICE_LIVE_P (XDEVICE (device))) | |
| 1698 return; | |
| 1699 else | |
| 1700 d = XDEVICE (device); | |
| 1701 | |
| 1702 if (in_p) | |
| 1703 { | |
| 1704 Lisp_Object focus_frame; | |
| 1705 | |
| 1706 if (!FRAME_LIVE_P (XFRAME (frame))) | |
| 1707 return; | |
| 1708 else | |
| 1709 focus_frame = DEVICE_FRAME_WITH_FOCUS_FOR_HOOKS (d); | |
| 1710 | |
| 1711 DEVICE_FRAME_WITH_FOCUS_FOR_HOOKS (d) = frame; | |
| 1712 if (FRAMEP (focus_frame) && !EQ (frame, focus_frame)) | |
| 1713 { | |
| 1714 /* Oops, we missed a focus-out event. */ | |
| 1715 Fselect_frame (focus_frame); | |
| 1716 /* Do an unwind-protect in case an error occurs in | |
| 1717 the deselect-frame-hook */ | |
| 1718 count = specpdl_depth (); | |
| 1719 record_unwind_protect (cleanup_after_missed_defocusing, frame); | |
| 1720 run_deselect_frame_hook (); | |
| 771 | 1721 unbind_to (count); |
| 428 | 1722 /* the cleanup method changed the focus frame to nil, so |
| 1723 we need to reflect this */ | |
| 1724 focus_frame = Qnil; | |
| 1725 } | |
| 1726 else | |
| 1727 Fselect_frame (frame); | |
| 1728 if (!EQ (frame, focus_frame)) | |
| 1729 run_select_frame_hook (); | |
| 1730 } | |
| 1731 else | |
| 1732 { | |
| 1733 /* We ignore the frame reported in the event. If it's different | |
| 1734 from where we think the focus was, oh well -- we messed up. | |
| 1735 Nonetheless, we pretend we were right, for sensible behavior. */ | |
| 1736 frame = DEVICE_FRAME_WITH_FOCUS_FOR_HOOKS (d); | |
| 1737 if (!NILP (frame)) | |
| 1738 { | |
| 1739 DEVICE_FRAME_WITH_FOCUS_FOR_HOOKS (d) = Qnil; | |
| 1740 run_deselect_frame_hook (); | |
| 1741 } | |
| 1742 } | |
| 1743 } | |
| 1744 | |
| 1745 | |
| 1746 /**********************************************************************/ | |
| 1268 | 1747 /* input pending/quit checking */ |
| 1748 /**********************************************************************/ | |
| 1749 | |
| 1750 /* If HOW_MANY is 0, return true if there are any user or non-user events | |
| 1751 pending. If HOW_MANY is > 0, return true if there are that many *user* | |
| 1752 events pending, irrespective of non-user events. */ | |
| 1753 | |
| 1754 static int | |
| 1755 event_stream_event_pending_p (int how_many) | |
| 1756 { | |
| 1757 /* #### Hmmm ... There may be some duplication in "drain queue" and | |
| 1758 "event pending". Couldn't we just drain the queue and see what's in | |
| 1759 it, and not maybe need a separate event method for this? Would this | |
| 1760 work when HOW_MANY is 0? Maybe this would be slow? */ | |
| 1761 return event_stream && event_stream->event_pending_p (how_many); | |
| 1762 } | |
| 1763 | |
| 1764 static void | |
| 1765 event_stream_force_event_pending (struct frame *f) | |
| 1766 { | |
| 1767 if (event_stream->force_event_pending_cb) | |
| 1768 event_stream->force_event_pending_cb (f); | |
| 1769 } | |
| 1770 | |
| 1771 void | |
| 1772 event_stream_drain_queue (void) | |
| 1773 { | |
| 1318 | 1774 /* This can call Lisp */ |
| 1268 | 1775 if (event_stream && event_stream->drain_queue_cb) |
| 1776 event_stream->drain_queue_cb (); | |
| 1777 } | |
| 1778 | |
| 1779 /* Return non-zero if at least HOW_MANY user events are pending. */ | |
| 1780 int | |
| 1781 detect_input_pending (int how_many) | |
| 1782 { | |
| 1318 | 1783 /* This can call Lisp */ |
| 1268 | 1784 Lisp_Object event; |
| 1785 | |
| 1786 if (!NILP (Vunread_command_event)) | |
| 1787 how_many--; | |
| 1788 | |
| 1789 how_many -= XINT (Fsafe_length (Vunread_command_events)); | |
| 1790 | |
| 1791 if (how_many <= 0) | |
| 1792 return 1; | |
| 1793 | |
| 1794 EVENT_CHAIN_LOOP (event, command_event_queue) | |
| 1795 { | |
| 1796 if (XEVENT_TYPE (event) != eval_event | |
| 1797 && XEVENT_TYPE (event) != magic_eval_event) | |
| 1798 { | |
| 1799 how_many--; | |
| 1800 if (how_many <= 0) | |
| 1801 return 1; | |
| 1802 } | |
| 1803 } | |
| 1804 | |
| 1805 return event_stream_event_pending_p (how_many); | |
| 1806 } | |
| 1807 | |
| 1808 DEFUN ("input-pending-p", Finput_pending_p, 0, 0, 0, /* | |
| 1809 Return t if command input is currently available with no waiting. | |
| 1810 Actually, the value is nil only if we can be sure that no input is available. | |
| 1811 */ | |
| 1812 ()) | |
| 1813 { | |
| 1318 | 1814 /* This can call Lisp */ |
| 1268 | 1815 return detect_input_pending (1) ? Qt : Qnil; |
| 1816 } | |
| 1817 | |
| 1818 static int | |
| 1819 maybe_read_quit_event (Lisp_Event *event) | |
| 1820 { | |
| 1821 /* A C-g that came from `sigint_happened' will always come from the | |
| 1822 controlling terminal. If that doesn't exist, however, then the | |
| 1823 user manually sent us a SIGINT, and we pretend the C-g came from | |
| 1824 the selected console. */ | |
| 1825 struct console *con; | |
| 1826 | |
| 1827 if (CONSOLEP (Vcontrolling_terminal) && | |
| 1828 CONSOLE_LIVE_P (XCONSOLE (Vcontrolling_terminal))) | |
| 1829 con = XCONSOLE (Vcontrolling_terminal); | |
| 1830 else | |
| 1831 con = XCONSOLE (Fselected_console ()); | |
| 1832 | |
| 1833 if (sigint_happened) | |
| 1834 { | |
| 1835 sigint_happened = 0; | |
| 1836 Vquit_flag = Qnil; | |
| 1837 Fcopy_event (CONSOLE_QUIT_EVENT (con), wrap_event (event)); | |
| 1838 return 1; | |
| 1839 } | |
| 1840 return 0; | |
| 1841 } | |
| 1842 | |
| 1843 struct remove_quit_p_data | |
| 1844 { | |
| 1845 int critical; | |
| 1846 }; | |
| 1847 | |
| 1848 static int | |
| 1849 remove_quit_p_event (Lisp_Object ev, void *the_data) | |
| 1850 { | |
| 1851 struct remove_quit_p_data *data = (struct remove_quit_p_data *) the_data; | |
| 1852 struct console *con = event_console_or_selected (ev); | |
| 1853 | |
| 1854 if (XEVENT_TYPE (ev) == key_press_event) | |
| 1855 { | |
| 1856 if (event_matches_key_specifier_p (ev, CONSOLE_QUIT_EVENT (con))) | |
| 1857 return 1; | |
| 1858 if (event_matches_key_specifier_p (ev, | |
| 1859 CONSOLE_CRITICAL_QUIT_EVENT (con))) | |
| 1860 { | |
| 1861 data->critical = 1; | |
| 1862 return 1; | |
| 1863 } | |
| 1864 } | |
| 1865 | |
| 1866 return 0; | |
| 1867 } | |
| 1868 | |
| 1869 void | |
| 1870 event_stream_quit_p (void) | |
| 1871 { | |
| 1318 | 1872 /* This can call Lisp */ |
| 1268 | 1873 struct remove_quit_p_data data; |
| 1874 | |
| 1875 /* Quit checking cannot happen in modal loop. Because it attempts to | |
| 1876 retrieve and dispatch events, it will cause lots of problems if we try | |
| 1877 to do this when already in the process of doing this -- deadlocking | |
| 1878 under Windows, crashes in lwlib etc. under X due to non-reentrant | |
| 1879 code. This is automatically caught, however, in | |
| 1880 event_stream_drain_queue() (checks for in_modal_loop in the | |
| 1881 event-specific code). */ | |
| 1882 | |
| 1883 /* Drain queue so we can check for pending C-g events. */ | |
| 1884 event_stream_drain_queue (); | |
| 1885 data.critical = 0; | |
| 1886 | |
| 1887 if (map_event_chain_remove (remove_quit_p_event, | |
| 1888 &dispatch_event_queue, | |
| 1889 &dispatch_event_queue_tail, | |
| 1890 &data, MECR_DEALLOCATE_EVENT)) | |
| 1891 Vquit_flag = data.critical ? Qcritical : Qt; | |
| 1892 } | |
| 1893 | |
| 1894 Lisp_Object | |
| 1895 event_stream_protect_modal_loop (const char *error_string, | |
| 1896 Lisp_Object (*bfun) (void *barg), | |
| 1897 void *barg, int flags) | |
| 1898 { | |
| 1899 Lisp_Object tmp; | |
| 1900 | |
| 1901 ++in_modal_loop; | |
| 1902 tmp = call_trapping_problems (Qevent, error_string, flags, 0, bfun, barg); | |
| 1903 --in_modal_loop; | |
| 1904 | |
| 1905 return tmp; | |
| 1906 } | |
| 1907 | |
| 1908 | |
| 1909 /**********************************************************************/ | |
| 428 | 1910 /* retrieving the next event */ |
| 1911 /**********************************************************************/ | |
| 1912 | |
| 1913 static int in_single_console; | |
| 1914 | |
| 1915 /* #### These functions don't currently do anything. */ | |
| 1916 void | |
| 1917 single_console_state (void) | |
| 1918 { | |
| 1919 in_single_console = 1; | |
| 1920 } | |
| 1921 | |
| 1922 void | |
| 1923 any_console_state (void) | |
| 1924 { | |
| 1925 in_single_console = 0; | |
| 1926 } | |
| 1927 | |
| 1928 int | |
| 1929 in_single_console_state (void) | |
| 1930 { | |
| 1931 return in_single_console; | |
| 1932 } | |
| 1933 | |
| 1268 | 1934 static void |
| 1935 event_stream_next_event (Lisp_Event *event) | |
| 1936 { | |
| 1937 Lisp_Object event_obj; | |
| 1938 | |
| 1939 check_event_stream_ok (); | |
| 1940 | |
| 1941 event_obj = wrap_event (event); | |
| 1942 zero_event (event); | |
| 1943 /* SIGINT occurs when C-g was pressed on a TTY. (SIGINT might have | |
| 1944 been sent manually by the user, but we don't care; we treat it | |
| 1945 the same.) | |
| 1946 | |
| 1947 The SIGINT signal handler sets Vquit_flag as well as sigint_happened | |
| 1948 and write a byte on our "fake pipe", which unblocks us when we are | |
| 1949 waiting for an event. */ | |
| 1950 | |
| 1951 /* If SIGINT was received after we disabled quit checking (because | |
| 1952 we want to read C-g's as characters), but before we got a chance | |
| 1953 to start reading, notice it now and treat it as a character to be | |
| 1954 read. If above callers wanted this to be QUIT, they can | |
| 1955 determine this by comparing the event against quit-char. */ | |
| 1956 | |
| 1957 if (maybe_read_quit_event (event)) | |
| 1958 { | |
| 1959 DEBUG_PRINT_EMACS_EVENT ("SIGINT", event_obj); | |
| 1960 return; | |
| 1961 } | |
| 1962 | |
| 1963 /* If a longjmp() happens in the callback, we're screwed. | |
| 1964 Let's hope it doesn't. I think the code here is fairly | |
| 1965 clean and doesn't do this. */ | |
| 1966 emacs_is_blocking = 1; | |
| 1967 event_stream->next_event_cb (event); | |
| 1968 emacs_is_blocking = 0; | |
| 1969 | |
| 1970 /* Now check to see if C-g was pressed while we were blocking. | |
| 1971 We treat it as an event, just like above. */ | |
| 1972 if (maybe_read_quit_event (event)) | |
| 1973 { | |
| 1974 DEBUG_PRINT_EMACS_EVENT ("SIGINT", event_obj); | |
| 1975 return; | |
| 1976 } | |
| 1977 | |
| 1978 #ifdef DEBUG_XEMACS | |
| 1979 /* timeout events have more info set later, so | |
| 1980 print the event out in next_event_internal(). */ | |
| 1981 if (event->event_type != timeout_event) | |
| 1982 DEBUG_PRINT_EMACS_EVENT ("real", event_obj); | |
| 1983 #endif | |
| 1984 maybe_kbd_translate (event_obj); | |
| 1985 } | |
| 428 | 1986 |
| 853 | 1987 /* Read an event from the window system (or tty). If ALLOW_QUEUED is |
| 1988 non-zero, read from the command-event queue first. | |
| 1989 | |
| 1990 If C-g was pressed, this function will attempt to QUIT. If you want | |
| 1991 to read C-g as an event, wrap this function with a call to | |
| 1992 begin_dont_check_for_quit(), and set Vquit_flag to Qnil just before | |
| 1993 you unbind. In this case, TARGET_EVENT will contain a C-g. | |
| 1994 | |
| 1995 Note that even if you are interested in C-g doing QUIT, a caller of you | |
| 1996 might not be. | |
| 1997 */ | |
| 1998 | |
| 428 | 1999 static void |
| 2000 next_event_internal (Lisp_Object target_event, int allow_queued) | |
| 2001 { | |
| 2002 struct gcpro gcpro1; | |
| 1292 | 2003 PROFILE_DECLARE (); |
| 2004 | |
| 853 | 2005 QUIT; |
| 428 | 2006 |
| 1292 | 2007 PROFILE_RECORD_ENTERING_SECTION (QSnext_event_internal); |
| 2008 | |
| 428 | 2009 assert (NILP (XEVENT_NEXT (target_event))); |
| 2010 | |
| 2011 GCPRO1 (target_event); | |
| 2012 | |
| 2013 /* When focus_follows_mouse is nil, if a frame change took place, we need | |
| 2014 * to actually switch window manager focus to the selected window now. | |
| 2015 */ | |
| 2016 if (!focus_follows_mouse) | |
| 2017 investigate_frame_change (); | |
| 2018 | |
| 2019 if (allow_queued && !NILP (command_event_queue)) | |
| 2020 { | |
| 2021 Lisp_Object event = dequeue_command_event (); | |
| 2022 Fcopy_event (event, target_event); | |
| 2023 Fdeallocate_event (event); | |
| 2024 DEBUG_PRINT_EMACS_EVENT ("command event queue", target_event); | |
| 2025 } | |
| 2026 else | |
| 2027 { | |
| 440 | 2028 Lisp_Event *e = XEVENT (target_event); |
| 428 | 2029 |
| 2030 /* The command_event_queue was empty. Wait for an event. */ | |
| 2031 event_stream_next_event (e); | |
| 2032 /* If this was a timeout, then we need to extract some data | |
| 2033 out of the returned closure and might need to resignal | |
| 2034 it. */ | |
| 934 | 2035 if (EVENT_TYPE (e) == timeout_event) |
| 428 | 2036 { |
| 2037 Lisp_Object tristan, isolde; | |
| 2038 | |
| 1204 | 2039 SET_EVENT_TIMEOUT_ID_NUMBER (e, |
| 2040 event_stream_resignal_wakeup (EVENT_TIMEOUT_INTERVAL_ID (e), 0, &tristan, &isolde)); | |
| 2041 | |
| 2042 SET_EVENT_TIMEOUT_FUNCTION (e, tristan); | |
| 2043 SET_EVENT_TIMEOUT_OBJECT (e, isolde); | |
| 934 | 2044 /* next_event_internal() doesn't print out timeout events |
| 2045 because of the extra info we just set. */ | |
| 428 | 2046 DEBUG_PRINT_EMACS_EVENT ("real, timeout", target_event); |
| 2047 } | |
| 2048 | |
| 853 | 2049 /* If we read a ^G, then set quit-flag and try to QUIT. |
| 2050 This may be blocked (see above). | |
| 428 | 2051 */ |
| 934 | 2052 if (EVENT_TYPE (e) == key_press_event && |
| 428 | 2053 event_matches_key_specifier_p |
| 1204 | 2054 (target_event, CONSOLE_QUIT_EVENT (XCONSOLE (EVENT_CHANNEL (e))))) |
| 428 | 2055 { |
| 2056 Vquit_flag = Qt; | |
| 853 | 2057 QUIT; |
| 428 | 2058 } |
| 2059 } | |
| 2060 | |
| 2061 UNGCPRO; | |
| 1292 | 2062 |
| 2063 PROFILE_RECORD_EXITING_SECTION (QSnext_event_internal); | |
| 428 | 2064 } |
| 2065 | |
| 853 | 2066 void |
| 428 | 2067 run_pre_idle_hook (void) |
| 2068 { | |
| 1318 | 2069 /* This can call Lisp */ |
| 428 | 2070 if (!NILP (Vpre_idle_hook) |
| 1268 | 2071 && !detect_input_pending (1)) |
| 853 | 2072 safe_run_hook_trapping_problems |
| 1333 | 2073 (Qredisplay, Qpre_idle_hook, |
| 1268 | 2074 /* Quit is inhibited as a result of being within next-event so |
| 2075 we need to fix that. */ | |
| 2076 INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION | UNINHIBIT_QUIT); | |
| 428 | 2077 } |
| 2078 | |
| 2079 DEFUN ("next-event", Fnext_event, 0, 2, 0, /* | |
| 2080 Return the next available event. | |
| 2081 Pass this object to `dispatch-event' to handle it. | |
| 2082 In most cases, you will want to use `next-command-event', which returns | |
| 2083 the next available "user" event (i.e. keypress, button-press, | |
| 2084 button-release, or menu selection) instead of this function. | |
| 2085 | |
| 2086 If EVENT is non-nil, it should be an event object and will be filled in | |
| 2087 and returned; otherwise a new event object will be created and returned. | |
| 2088 If PROMPT is non-nil, it should be a string and will be displayed in the | |
| 2089 echo area while this function is waiting for an event. | |
| 2090 | |
| 2091 The next available event will be | |
| 2092 | |
| 2093 -- any events in `unread-command-events' or `unread-command-event'; else | |
| 2094 -- the next event in the currently executing keyboard macro, if any; else | |
| 442 | 2095 -- an event queued by `enqueue-eval-event', if any, or any similar event |
| 2096 queued internally, such as a misc-user event. (For example, when an item | |
| 2097 is selected from a menu or from a `question'-type dialog box, the item's | |
| 2098 callback is not immediately executed, but instead a misc-user event | |
| 2099 is generated and placed onto this queue; when it is dispatched, the | |
| 2100 callback is executed.) Else | |
| 428 | 2101 -- the next available event from the window system or terminal driver. |
| 2102 | |
| 2103 In the last case, this function will block until an event is available. | |
| 2104 | |
| 2105 The returned event will be one of the following types: | |
| 2106 | |
| 2107 -- a key-press event. | |
| 2108 -- a button-press or button-release event. | |
| 2109 -- a misc-user-event, meaning the user selected an item on a menu or used | |
| 2110 the scrollbar. | |
| 2111 -- a process event, meaning that output from a subprocess is available. | |
| 2112 -- a timeout event, meaning that a timeout has elapsed. | |
| 2113 -- an eval event, which simply causes a function to be executed when the | |
| 2114 event is dispatched. Eval events are generated by `enqueue-eval-event' | |
| 2115 or by certain other conditions happening. | |
| 2116 -- a magic event, indicating that some window-system-specific event | |
| 2117 happened (such as a focus-change notification) that must be handled | |
| 2118 synchronously with other events. `dispatch-event' knows what to do with | |
| 2119 these events. | |
| 2120 */ | |
| 2121 (event, prompt)) | |
| 2122 { | |
| 2123 /* This function can call lisp */ | |
| 2124 /* #### We start out using the selected console before an event | |
| 2125 is received, for echoing the partially completed command. | |
| 2126 This is most definitely wrong -- there needs to be a separate | |
| 2127 echo area for each console! */ | |
| 2128 struct console *con = XCONSOLE (Vselected_console); | |
| 2129 struct command_builder *command_builder = | |
| 2130 XCOMMAND_BUILDER (con->command_builder); | |
| 2131 int store_this_key = 0; | |
| 2132 struct gcpro gcpro1; | |
| 853 | 2133 int depth; |
| 1292 | 2134 PROFILE_DECLARE (); |
| 428 | 2135 |
| 2136 GCPRO1 (event); | |
| 853 | 2137 |
| 1268 | 2138 /* This is not strictly necessary. Trying to retrieve an event inside of |
| 2139 a modal loop can cause major problems (see event_stream_quit_p()), but | |
| 2140 the event-specific code knows about this and will make sure we don't | |
| 2141 do anything dangerous. However, if we've gotten here, it's highly | |
| 2142 likely that some code is trying to fetch user events (e.g. in custom | |
| 2143 dialog-box code), and will almost certainly deadlock, so it's probably | |
| 2144 best to error out. #### This could cause problems because there are | |
| 2145 (potentially, at least) legitimate reasons for calling next-event | |
| 2146 inside of a modal loop, in particular if the code is trying to search | |
| 2147 for a timeout event, which will still get retrieved in such a case. | |
| 2148 However, the code to error in such a case has already been present for | |
| 2149 a long time without obvious problems so leaving it in isn't so | |
| 1279 | 2150 bad. |
| 2151 | |
| 2152 #### I used to conditionalize on in_modal_loop but that fails utterly | |
| 2153 because event-msw.c specifically calls Fnext_event() inside of a modal | |
| 2154 loop to clear the dispatch queue. --ben */ | |
| 1315 | 2155 #ifdef HAVE_MENUBARS |
| 1279 | 2156 if (in_menu_callback) |
| 2157 invalid_operation ("Attempt to call next-event inside menu callback", | |
| 1268 | 2158 Qunbound); |
| 1315 | 2159 #endif /* HAVE_MENUBARS */ |
| 1268 | 2160 |
| 1292 | 2161 PROFILE_RECORD_ENTERING_SECTION (Qnext_event); |
| 2162 | |
| 853 | 2163 depth = begin_dont_check_for_quit (); |
| 428 | 2164 |
| 2165 if (NILP (event)) | |
| 2166 event = Fmake_event (Qnil, Qnil); | |
| 2167 else | |
| 2168 CHECK_LIVE_EVENT (event); | |
| 2169 | |
| 2170 if (!NILP (prompt)) | |
| 2171 { | |
| 2172 Bytecount len; | |
| 2173 CHECK_STRING (prompt); | |
| 2174 | |
| 2175 len = XSTRING_LENGTH (prompt); | |
| 2176 if (command_builder->echo_buf_length < len) | |
| 2177 len = command_builder->echo_buf_length - 1; | |
| 2178 memcpy (command_builder->echo_buf, XSTRING_DATA (prompt), len); | |
| 2179 command_builder->echo_buf[len] = 0; | |
| 2180 command_builder->echo_buf_index = len; | |
| 2181 echo_area_message (XFRAME (CONSOLE_SELECTED_FRAME (con)), | |
| 2182 command_builder->echo_buf, | |
| 2183 Qnil, 0, | |
| 2184 command_builder->echo_buf_index, | |
| 2185 Qcommand); | |
| 2186 } | |
| 2187 | |
| 2188 start_over_and_avoid_hosage: | |
| 2189 | |
| 2190 /* If there is something in unread-command-events, simply return it. | |
| 2191 But do some error checking to make sure the user hasn't put something | |
| 2192 in the unread-command-events that they shouldn't have. | |
| 2193 This does not update this-command-keys and recent-keys. | |
| 2194 */ | |
| 2195 if (!NILP (Vunread_command_events)) | |
| 2196 { | |
| 2197 if (!CONSP (Vunread_command_events)) | |
| 2198 { | |
| 2199 Vunread_command_events = Qnil; | |
| 563 | 2200 signal_error_1 (Qwrong_type_argument, |
| 428 | 2201 list3 (Qconsp, Vunread_command_events, |
| 2202 Qunread_command_events)); | |
| 2203 } | |
| 2204 else | |
| 2205 { | |
| 2206 Lisp_Object e = XCAR (Vunread_command_events); | |
| 2207 Vunread_command_events = XCDR (Vunread_command_events); | |
| 2208 if (!EVENTP (e) || !command_event_p (e)) | |
| 563 | 2209 signal_error_1 (Qwrong_type_argument, |
| 428 | 2210 list3 (Qcommand_event_p, e, Qunread_command_events)); |
| 853 | 2211 redisplay_no_pre_idle_hook (); |
| 428 | 2212 if (!EQ (e, event)) |
| 2213 Fcopy_event (e, event); | |
| 2214 DEBUG_PRINT_EMACS_EVENT ("unread-command-events", event); | |
| 2215 } | |
| 2216 } | |
| 2217 | |
| 2218 /* Do similar for unread-command-event (obsoleteness support). */ | |
| 2219 else if (!NILP (Vunread_command_event)) | |
| 2220 { | |
| 2221 Lisp_Object e = Vunread_command_event; | |
| 2222 Vunread_command_event = Qnil; | |
| 2223 | |
| 2224 if (!EVENTP (e) || !command_event_p (e)) | |
| 2225 { | |
| 563 | 2226 signal_error_1 (Qwrong_type_argument, |
| 428 | 2227 list3 (Qeventp, e, Qunread_command_event)); |
| 2228 } | |
| 2229 if (!EQ (e, event)) | |
| 2230 Fcopy_event (e, event); | |
| 853 | 2231 redisplay_no_pre_idle_hook (); |
| 428 | 2232 DEBUG_PRINT_EMACS_EVENT ("unread-command-event", event); |
| 2233 } | |
| 2234 | |
| 2235 /* If we're executing a keyboard macro, take the next event from that, | |
| 2236 and update this-command-keys and recent-keys. | |
| 2237 Note that the unread-command-events take precedence over kbd macros. | |
| 2238 */ | |
| 2239 else | |
| 2240 { | |
| 2241 if (!NILP (Vexecuting_macro)) | |
| 2242 { | |
| 853 | 2243 redisplay_no_pre_idle_hook (); |
| 428 | 2244 pop_kbd_macro_event (event); /* This throws past us at |
| 2245 end-of-macro. */ | |
| 2246 store_this_key = 1; | |
| 2247 DEBUG_PRINT_EMACS_EVENT ("keyboard macro", event); | |
| 2248 } | |
| 2249 /* Otherwise, read a real event, possibly from the | |
| 2250 command_event_queue, and update this-command-keys and | |
| 2251 recent-keys. */ | |
| 2252 else | |
| 2253 { | |
| 2254 redisplay (); | |
| 2255 next_event_internal (event, 1); | |
| 2256 store_this_key = 1; | |
| 2257 } | |
| 2258 } | |
| 2259 | |
| 853 | 2260 /* temporarily reenable quit checking here, because arbitrary lisp |
| 2261 is executed */ | |
| 2262 Vquit_flag = Qnil; /* see begin_dont_check_for_quit() */ | |
| 2263 unbind_to (depth); | |
| 428 | 2264 status_notify (); /* Notice process change */ |
| 853 | 2265 depth = begin_dont_check_for_quit (); |
| 428 | 2266 |
| 2267 /* Since we can free the most stuff here | |
| 2268 * (since this is typically called from | |
| 2269 * the command-loop top-level). */ | |
| 851 | 2270 if (need_to_check_c_alloca) |
| 2271 xemacs_c_alloca (0); /* Cause a garbage collection now */ | |
| 428 | 2272 |
| 2273 if (object_dead_p (XEVENT (event)->channel)) | |
| 2274 /* event_console_or_selected may crash if the channel is dead. | |
| 2275 Best just to eat it and get the next event. */ | |
| 2276 goto start_over_and_avoid_hosage; | |
| 2277 | |
| 2278 /* OK, now we can stop the selected-console kludge and use the | |
| 2279 actual console from the event. */ | |
| 2280 con = event_console_or_selected (event); | |
| 2281 command_builder = XCOMMAND_BUILDER (con->command_builder); | |
| 2282 | |
| 2283 switch (XEVENT_TYPE (event)) | |
| 2284 { | |
| 2285 case button_release_event: | |
| 2286 case misc_user_event: | |
| 2287 /* don't echo menu accelerator keys */ | |
| 2288 reset_key_echo (command_builder, 1); | |
| 2289 goto EXECUTE_KEY; | |
| 2290 case button_press_event: /* key or mouse input can trigger prompting */ | |
| 2291 goto STORE_AND_EXECUTE_KEY; | |
| 2292 case key_press_event: /* any key input can trigger autosave */ | |
| 2293 break; | |
| 898 | 2294 default: |
| 2295 goto RETURN; | |
| 428 | 2296 } |
| 2297 | |
| 853 | 2298 /* temporarily reenable quit checking here, because we could get stuck */ |
| 2299 Vquit_flag = Qnil; /* see begin_dont_check_for_quit() */ | |
| 2300 unbind_to (depth); | |
| 428 | 2301 maybe_do_auto_save (); |
| 853 | 2302 depth = begin_dont_check_for_quit (); |
| 2303 | |
| 428 | 2304 num_input_chars++; |
| 2305 STORE_AND_EXECUTE_KEY: | |
| 2306 if (store_this_key) | |
| 2307 { | |
| 2308 echo_key_event (command_builder, event); | |
| 2309 } | |
| 2310 | |
| 2311 EXECUTE_KEY: | |
| 2312 /* Store the last-input-event. The semantics of this is that it is | |
| 2313 the thing most recently returned by next-command-event. It need | |
| 2314 not have come from the keyboard or a keyboard macro, it may have | |
| 2315 come from unread-command-events. It's always a command-event (a | |
| 2316 key, click, or menu selection), never a motion or process event. | |
| 2317 */ | |
| 2318 if (!EVENTP (Vlast_input_event)) | |
| 2319 Vlast_input_event = Fmake_event (Qnil, Qnil); | |
| 2320 if (XEVENT_TYPE (Vlast_input_event) == dead_event) | |
| 2321 { | |
| 2322 Vlast_input_event = Fmake_event (Qnil, Qnil); | |
| 563 | 2323 invalid_state ("Someone deallocated last-input-event!", Qunbound); |
| 428 | 2324 } |
| 2325 if (! EQ (event, Vlast_input_event)) | |
| 2326 Fcopy_event (event, Vlast_input_event); | |
| 2327 | |
| 2328 /* last-input-char and last-input-time are derived from | |
| 2329 last-input-event. | |
| 2330 Note that last-input-char will never have its high-bit set, in an | |
| 2331 effort to sidestep the ambiguity between M-x and oslash. | |
| 2332 */ | |
| 2862 | 2333 Vlast_input_char = Fevent_to_character (Vlast_input_event, Qnil, Qnil, Qnil); |
| 428 | 2334 { |
| 2335 EMACS_TIME t; | |
| 2336 EMACS_GET_TIME (t); | |
| 2337 if (!CONSP (Vlast_input_time)) | |
| 2338 Vlast_input_time = Fcons (Qnil, Qnil); | |
| 2339 XCAR (Vlast_input_time) = make_int ((EMACS_SECS (t) >> 16) & 0xffff); | |
| 2340 XCDR (Vlast_input_time) = make_int ((EMACS_SECS (t) >> 0) & 0xffff); | |
| 2341 if (!CONSP (Vlast_command_event_time)) | |
| 2342 Vlast_command_event_time = list3 (Qnil, Qnil, Qnil); | |
| 2343 XCAR (Vlast_command_event_time) = | |
| 2344 make_int ((EMACS_SECS (t) >> 16) & 0xffff); | |
| 2345 XCAR (XCDR (Vlast_command_event_time)) = | |
| 2346 make_int ((EMACS_SECS (t) >> 0) & 0xffff); | |
| 2347 XCAR (XCDR (XCDR (Vlast_command_event_time))) | |
| 2348 = make_int (EMACS_USECS (t)); | |
| 2349 } | |
| 2350 /* If this key came from the keyboard or from a keyboard macro, then | |
| 2351 it goes into the recent-keys and this-command-keys vectors. | |
| 2352 If this key came from the keyboard, and we're defining a keyboard | |
| 2353 macro, then it goes into the macro. | |
| 2354 */ | |
| 2355 if (store_this_key) | |
| 2356 { | |
| 479 | 2357 if (!is_scrollbar_event (event)) /* #### not quite right, see |
| 2358 comment in execute_command_event */ | |
| 2359 push_this_command_keys (event); | |
| 428 | 2360 if (!inhibit_input_event_recording) |
| 2361 push_recent_keys (event); | |
| 2362 dribble_out_event (event); | |
| 2363 if (!NILP (con->defining_kbd_macro) && NILP (Vexecuting_macro)) | |
| 2364 { | |
| 2365 if (!EVENTP (command_builder->current_events)) | |
| 2366 finalize_kbd_macro_chars (con); | |
| 2367 store_kbd_macro_event (event); | |
| 2368 } | |
| 2369 } | |
| 853 | 2370 /* If this is the help char and there is a help form, then execute |
| 2371 the help form and swallow this character. Note that | |
| 2372 execute_help_form() calls Fnext_command_event(), which calls this | |
| 2373 function, as well as Fdispatch_event. */ | |
| 428 | 2374 if (!NILP (Vhelp_form) && |
| 1204 | 2375 event_matches_key_specifier_p (event, Vhelp_char)) |
| 853 | 2376 { |
| 2377 /* temporarily reenable quit checking here, because we could get stuck */ | |
| 2378 Vquit_flag = Qnil; /* see begin_dont_check_for_quit() */ | |
| 2379 unbind_to (depth); | |
| 2380 execute_help_form (command_builder, event); | |
| 2381 depth = begin_dont_check_for_quit (); | |
| 2382 } | |
| 428 | 2383 |
| 2384 RETURN: | |
| 853 | 2385 Vquit_flag = Qnil; /* see begin_dont_check_for_quit() */ |
| 2386 unbind_to (depth); | |
| 2387 | |
| 1292 | 2388 PROFILE_RECORD_EXITING_SECTION (Qnext_event); |
| 2389 | |
| 428 | 2390 UNGCPRO; |
| 853 | 2391 |
| 428 | 2392 return event; |
| 2393 } | |
| 2394 | |
| 2395 DEFUN ("next-command-event", Fnext_command_event, 0, 2, 0, /* | |
| 2396 Return the next available "user" event. | |
| 2397 Pass this object to `dispatch-event' to handle it. | |
| 2398 | |
| 2399 If EVENT is non-nil, it should be an event object and will be filled in | |
| 2400 and returned; otherwise a new event object will be created and returned. | |
| 2401 If PROMPT is non-nil, it should be a string and will be displayed in the | |
| 2402 echo area while this function is waiting for an event. | |
| 2403 | |
| 2404 The event returned will be a keyboard, mouse press, or mouse release event. | |
| 2405 If there are non-command events available (mouse motion, sub-process output, | |
| 2406 etc) then these will be executed (with `dispatch-event') and discarded. This | |
| 2407 function is provided as a convenience; it is roughly equivalent to the lisp code | |
| 2408 | |
| 2409 (while (progn | |
| 2410 (next-event event prompt) | |
| 2411 (not (or (key-press-event-p event) | |
| 2412 (button-press-event-p event) | |
| 2413 (button-release-event-p event) | |
| 2414 (misc-user-event-p event)))) | |
| 2415 (dispatch-event event)) | |
| 2416 | |
| 2417 but it also makes a provision for displaying keystrokes in the echo area. | |
| 2418 */ | |
| 2419 (event, prompt)) | |
| 2420 { | |
| 2421 /* This function can GC */ | |
| 2422 struct gcpro gcpro1; | |
| 2423 GCPRO1 (event); | |
| 934 | 2424 |
| 428 | 2425 maybe_echo_keys (XCOMMAND_BUILDER |
| 2426 (XCONSOLE (Vselected_console)-> | |
| 2427 command_builder), 0); /* #### This sucks bigtime */ | |
| 853 | 2428 |
| 428 | 2429 for (;;) |
| 2430 { | |
| 2431 event = Fnext_event (event, prompt); | |
| 2432 if (command_event_p (event)) | |
| 2433 break; | |
| 2434 else | |
| 2435 execute_internal_event (event); | |
| 2436 } | |
| 2437 UNGCPRO; | |
| 2438 return event; | |
| 2439 } | |
| 2440 | |
| 442 | 2441 DEFUN ("dispatch-non-command-events", Fdispatch_non_command_events, 0, 0, 0, /* |
| 2442 Dispatch any pending "magic" events. | |
| 2443 | |
| 2444 This function is useful for forcing the redisplay of native | |
| 2445 widgets. Normally these are redisplayed through a native window-system | |
| 2446 event encoded as magic event, rather than by the redisplay code. This | |
| 2447 function does not call redisplay or do any of the other things that | |
| 2448 `next-event' does. | |
| 2449 */ | |
| 2450 ()) | |
| 2451 { | |
| 2452 /* This function can GC */ | |
| 2453 Lisp_Object event = Qnil; | |
| 2454 struct gcpro gcpro1; | |
| 2455 GCPRO1 (event); | |
| 2456 event = Fmake_event (Qnil, Qnil); | |
| 2457 | |
| 2458 /* Make sure that there will be something in the native event queue | |
| 2459 so that externally managed things (e.g. widgets) get some CPU | |
| 2460 time. */ | |
| 2461 event_stream_force_event_pending (selected_frame ()); | |
| 2462 | |
| 2463 while (event_stream_event_pending_p (0)) | |
| 2464 { | |
| 2465 /* We're a generator of the command_event_queue, so we can't be a | |
| 2466 consumer as well. Also, we have no reason to consult the | |
| 2467 command_event_queue; there are only user and eval-events there, | |
| 2468 and we'd just have to put them back anyway. | |
| 2469 */ | |
| 2470 next_event_internal (event, 0); /* blocks */ | |
| 2471 if (XEVENT_TYPE (event) == magic_event || | |
| 2472 XEVENT_TYPE (event) == timeout_event || | |
| 2473 XEVENT_TYPE (event) == process_event || | |
| 2474 XEVENT_TYPE (event) == pointer_motion_event) | |
| 2475 execute_internal_event (event); | |
| 2476 else | |
| 2477 { | |
| 2478 enqueue_command_event_1 (event); | |
| 2479 break; | |
| 2480 } | |
| 2481 } | |
| 2482 | |
| 2483 Fdeallocate_event (event); | |
| 2484 UNGCPRO; | |
| 2485 return Qnil; | |
| 2486 } | |
| 2487 | |
| 428 | 2488 static void |
| 2489 reset_current_events (struct command_builder *command_builder) | |
| 2490 { | |
| 2491 Lisp_Object event = command_builder->current_events; | |
| 2492 reset_command_builder_event_chain (command_builder); | |
| 2493 if (EVENTP (event)) | |
| 2494 deallocate_event_chain (event); | |
| 2495 } | |
| 2496 | |
| 1268 | 2497 static int |
| 2286 | 2498 command_event_p_cb (Lisp_Object ev, void *UNUSED (the_data)) |
| 1268 | 2499 { |
| 2500 return command_event_p (ev); | |
| 2501 } | |
| 2502 | |
| 428 | 2503 DEFUN ("discard-input", Fdiscard_input, 0, 0, 0, /* |
| 2504 Discard any pending "user" events. | |
| 2505 Also cancel any kbd macro being defined. | |
| 2506 A user event is a key press, button press, button release, or | |
| 2507 "misc-user" event (menu selection or scrollbar action). | |
| 2508 */ | |
| 2509 ()) | |
| 2510 { | |
| 1318 | 2511 /* This can call Lisp */ |
| 1268 | 2512 Lisp_Object concons; |
| 2513 | |
| 2514 CONSOLE_LOOP (concons) | |
| 428 | 2515 { |
| 1268 | 2516 struct console *con = XCONSOLE (XCAR (concons)); |
| 2517 | |
| 2518 /* If a macro was being defined then we have to mark the modeline | |
| 2519 has changed to ensure that it gets updated correctly. */ | |
| 2520 if (!NILP (con->defining_kbd_macro)) | |
| 2521 MARK_MODELINE_CHANGED; | |
| 2522 con->defining_kbd_macro = Qnil; | |
| 2523 reset_current_events (XCOMMAND_BUILDER (con->command_builder)); | |
| 428 | 2524 } |
| 2525 | |
| 1268 | 2526 /* This function used to be a lot more complicated. Now, we just |
| 2527 drain the pending queue and discard all user events from the | |
| 2528 command and dispatch queues. */ | |
| 2529 event_stream_drain_queue (); | |
| 2530 | |
| 2531 map_event_chain_remove (command_event_p_cb, | |
| 2532 &dispatch_event_queue, &dispatch_event_queue_tail, | |
| 2533 0, MECR_DEALLOCATE_EVENT); | |
| 2534 map_event_chain_remove (command_event_p_cb, | |
| 2535 &command_event_queue, &command_event_queue_tail, | |
| 2536 0, MECR_DEALLOCATE_EVENT); | |
| 428 | 2537 |
| 2538 return Qnil; | |
| 2539 } | |
| 2540 | |
| 2541 | |
| 2542 /**********************************************************************/ | |
| 2543 /* pausing until an action occurs */ | |
| 2544 /**********************************************************************/ | |
| 2545 | |
| 2546 /* This is used in accept-process-output, sleep-for and sit-for. | |
| 2547 Before running any process_events in these routines, we set | |
| 1268 | 2548 recursive_sit_for to 1, and use this unwind protect to reset it to |
| 2549 Qnil upon exit. When recursive_sit_for is 1, calling sit-for will | |
| 428 | 2550 cause it to return immediately. |
| 2551 | |
| 2552 All of these routines install timeouts, so we clear the installed | |
| 2553 timeout as well. | |
| 2554 | |
| 2555 Note: It's very easy to break the desired behaviors of these | |
| 2556 3 routines. If you make any changes to anything in this area, run | |
| 2557 the regression tests at the bottom of the file. -- dmoore */ | |
| 2558 | |
| 2559 | |
| 2560 static Lisp_Object | |
| 2561 sit_for_unwind (Lisp_Object timeout_id) | |
| 2562 { | |
| 2563 if (!NILP(timeout_id)) | |
| 2564 Fdisable_timeout (timeout_id); | |
| 2565 | |
| 1268 | 2566 recursive_sit_for = 0; |
| 428 | 2567 return Qnil; |
| 2568 } | |
| 2569 | |
| 2570 /* #### Is (accept-process-output nil 3) supposed to be like (sleep-for 3)? | |
| 2571 */ | |
| 2572 | |
| 2573 DEFUN ("accept-process-output", Faccept_process_output, 0, 3, 0, /* | |
| 2574 Allow any pending output from subprocesses to be read by Emacs. | |
| 2575 It is read into the process' buffers or given to their filter functions. | |
| 2576 Non-nil arg PROCESS means do not return until some output has been received | |
| 2577 from PROCESS. Nil arg PROCESS means do not return until some output has | |
| 2578 been received from any process. | |
| 2579 If the second arg is non-nil, it is the maximum number of seconds to wait: | |
| 2580 this function will return after that much time even if no input has arrived | |
| 2581 from PROCESS. This argument may be a float, meaning wait some fractional | |
| 2582 part of a second. | |
| 2583 If the third arg is non-nil, it is a number of milliseconds that is added | |
| 2584 to the second arg. (This exists only for compatibility.) | |
| 2585 Return non-nil iff we received any output before the timeout expired. | |
| 2586 */ | |
| 2587 (process, timeout_secs, timeout_msecs)) | |
| 2588 { | |
| 2589 /* This function can GC */ | |
| 2590 struct gcpro gcpro1, gcpro2; | |
| 2591 Lisp_Object event = Qnil; | |
| 2592 Lisp_Object result = Qnil; | |
| 2593 int timeout_id = -1; | |
| 2594 int timeout_enabled = 0; | |
| 2595 int done = 0; | |
| 2596 struct buffer *old_buffer = current_buffer; | |
| 2597 int count; | |
| 2598 | |
| 2599 /* We preserve the current buffer but nothing else. If a focus | |
| 2600 change alters the selected window then the top level event loop | |
| 2601 will eventually alter current_buffer to match. In the mean time | |
| 2602 we don't want to mess up whatever called this function. */ | |
| 2603 | |
| 2604 if (!NILP (process)) | |
| 2605 CHECK_PROCESS (process); | |
| 2606 | |
| 2607 GCPRO2 (event, process); | |
| 2608 | |
| 2609 if (!NILP (timeout_secs) || !NILP (timeout_msecs)) | |
| 2610 { | |
| 2611 unsigned long msecs = 0; | |
| 2612 if (!NILP (timeout_secs)) | |
| 2613 msecs = lisp_number_to_milliseconds (timeout_secs, 1); | |
| 2614 if (!NILP (timeout_msecs)) | |
| 2615 { | |
| 2616 CHECK_NATNUM (timeout_msecs); | |
| 2617 msecs += XINT (timeout_msecs); | |
| 2618 } | |
| 2619 if (msecs) | |
| 2620 { | |
| 2621 timeout_id = event_stream_generate_wakeup (msecs, 0, Qnil, Qnil, 0); | |
| 2622 timeout_enabled = 1; | |
| 2623 } | |
| 2624 } | |
| 2625 | |
| 2626 event = Fmake_event (Qnil, Qnil); | |
| 2627 | |
| 2628 count = specpdl_depth (); | |
| 2629 record_unwind_protect (sit_for_unwind, | |
| 2630 timeout_enabled ? make_int (timeout_id) : Qnil); | |
| 1268 | 2631 recursive_sit_for = 1; |
| 428 | 2632 |
| 2633 while (!done && | |
| 2634 ((NILP (process) && timeout_enabled) || | |
| 2635 (NILP (process) && event_stream_event_pending_p (0)) || | |
| 2636 (!NILP (process)))) | |
| 2637 /* Calling detect_input_pending() is the wrong thing here, because | |
| 2638 that considers the Vunread_command_events and command_event_queue. | |
| 2639 We don't need to look at the command_event_queue because we are | |
| 2640 only interested in process events, which don't go on that. In | |
| 2641 fact, we can't read from it anyway, because we put stuff on it. | |
| 2642 | |
| 2643 Note that event_stream->event_pending_p must be called in such | |
| 2644 a way that it says whether any events *of any kind* are ready, | |
| 2645 not just user events, or (accept-process-output nil) will fail | |
| 2646 to dispatch any process events that may be on the queue. It is | |
| 2647 not clear to me that this is important, because the top-level | |
| 2648 loop will process it, and I don't think that there is ever a | |
| 2649 time when one calls accept-process-output with a nil argument | |
| 2650 and really need the processes to be handled. */ | |
| 2651 { | |
| 2652 /* If our timeout has arrived, we move along. */ | |
| 2653 if (timeout_enabled && !event_stream_wakeup_pending_p (timeout_id, 0)) | |
| 2654 { | |
| 2655 timeout_enabled = 0; | |
| 2656 done = 1; /* We're done. */ | |
| 2657 continue; /* Don't call next_event_internal */ | |
| 2658 } | |
| 2659 | |
| 2660 next_event_internal (event, 0); | |
| 2661 switch (XEVENT_TYPE (event)) | |
| 2662 { | |
| 2663 case process_event: | |
| 2664 { | |
| 2665 if (NILP (process) || | |
| 1204 | 2666 EQ (XEVENT_PROCESS_PROCESS (event), process)) |
| 428 | 2667 { |
| 2668 done = 1; | |
| 2669 /* RMS's version always returns nil when proc is nil, | |
| 2670 and only returns t if input ever arrived on proc. */ | |
| 2671 result = Qt; | |
| 2672 } | |
| 2673 | |
| 2674 execute_internal_event (event); | |
| 2675 break; | |
| 2676 } | |
| 2677 case timeout_event: | |
| 2678 /* We execute the event even if it's ours, and notice that it's | |
| 2679 happened above. */ | |
| 2680 case pointer_motion_event: | |
| 2681 case magic_event: | |
| 2682 { | |
| 2683 execute_internal_event (event); | |
| 2684 break; | |
| 2685 } | |
| 2686 default: | |
| 2687 { | |
| 2688 enqueue_command_event_1 (event); | |
| 2689 break; | |
| 2690 } | |
| 2691 } | |
| 2692 } | |
| 2693 | |
| 771 | 2694 unbind_to_1 (count, timeout_enabled ? make_int (timeout_id) : Qnil); |
| 428 | 2695 |
| 2696 Fdeallocate_event (event); | |
| 853 | 2697 |
| 2698 status_notify (); | |
| 2699 | |
| 428 | 2700 UNGCPRO; |
| 2701 current_buffer = old_buffer; | |
| 2702 return result; | |
| 2703 } | |
| 2704 | |
| 2705 DEFUN ("sleep-for", Fsleep_for, 1, 1, 0, /* | |
| 444 | 2706 Pause, without updating display, for SECONDS seconds. |
| 2707 SECONDS may be a float, allowing pauses for fractional parts of a second. | |
| 428 | 2708 |
| 2709 It is recommended that you never call sleep-for from inside of a process | |
| 444 | 2710 filter function or timer event (either synchronous or asynchronous). |
| 428 | 2711 */ |
| 2712 (seconds)) | |
| 2713 { | |
| 2714 /* This function can GC */ | |
| 2715 unsigned long msecs = lisp_number_to_milliseconds (seconds, 1); | |
| 2716 int id; | |
| 2717 Lisp_Object event = Qnil; | |
| 2718 int count; | |
| 2719 struct gcpro gcpro1; | |
| 2720 | |
| 2721 GCPRO1 (event); | |
| 2722 | |
| 2723 id = event_stream_generate_wakeup (msecs, 0, Qnil, Qnil, 0); | |
| 2724 event = Fmake_event (Qnil, Qnil); | |
| 2725 | |
| 2726 count = specpdl_depth (); | |
| 2727 record_unwind_protect (sit_for_unwind, make_int (id)); | |
| 1268 | 2728 recursive_sit_for = 1; |
| 428 | 2729 |
| 2730 while (1) | |
| 2731 { | |
| 2732 /* If our timeout has arrived, we move along. */ | |
| 2733 if (!event_stream_wakeup_pending_p (id, 0)) | |
| 2734 goto DONE_LABEL; | |
| 2735 | |
| 2736 /* We're a generator of the command_event_queue, so we can't be a | |
| 2737 consumer as well. We don't care about command and eval-events | |
| 2738 anyway. | |
| 2739 */ | |
| 2740 next_event_internal (event, 0); /* blocks */ | |
| 2741 switch (XEVENT_TYPE (event)) | |
| 2742 { | |
| 2743 case timeout_event: | |
| 2744 /* We execute the event even if it's ours, and notice that it's | |
| 2745 happened above. */ | |
| 2746 case process_event: | |
| 2747 case pointer_motion_event: | |
| 2748 case magic_event: | |
| 2749 { | |
| 2750 execute_internal_event (event); | |
| 2751 break; | |
| 2752 } | |
| 2753 default: | |
| 2754 { | |
| 2755 enqueue_command_event_1 (event); | |
| 2756 break; | |
| 2757 } | |
| 2758 } | |
| 2759 } | |
| 2760 DONE_LABEL: | |
| 771 | 2761 unbind_to_1 (count, make_int (id)); |
| 428 | 2762 Fdeallocate_event (event); |
| 2763 UNGCPRO; | |
| 2764 return Qnil; | |
| 2765 } | |
| 2766 | |
| 2767 DEFUN ("sit-for", Fsit_for, 1, 2, 0, /* | |
| 444 | 2768 Perform redisplay, then wait SECONDS seconds or until user input is available. |
| 2769 SECONDS may be a float, meaning a fractional part of a second. | |
| 2770 Optional second arg NODISPLAY non-nil means don't redisplay; just wait. | |
| 428 | 2771 Redisplay is preempted as always if user input arrives, and does not |
| 2772 happen if input is available before it starts. | |
| 2773 Value is t if waited the full time with no input arriving. | |
| 2774 | |
| 2775 If sit-for is called from within a process filter function or timer | |
| 2776 event (either synchronous or asynchronous) it will return immediately. | |
| 2777 */ | |
| 2778 (seconds, nodisplay)) | |
| 2779 { | |
| 2780 /* This function can GC */ | |
| 2781 unsigned long msecs = lisp_number_to_milliseconds (seconds, 1); | |
| 2782 Lisp_Object event, result; | |
| 2783 struct gcpro gcpro1; | |
| 2784 int id; | |
| 2785 int count; | |
| 2786 | |
| 2787 /* The unread-command-events count as pending input */ | |
| 2788 if (!NILP (Vunread_command_events) || !NILP (Vunread_command_event)) | |
| 2789 return Qnil; | |
| 2790 | |
| 2791 /* If the command-builder already has user-input on it (not eval events) | |
| 2792 then that means we're done too. | |
| 2793 */ | |
| 2794 if (!NILP (command_event_queue)) | |
| 2795 { | |
| 2796 EVENT_CHAIN_LOOP (event, command_event_queue) | |
| 2797 { | |
| 2798 if (command_event_p (event)) | |
| 2799 return Qnil; | |
| 2800 } | |
| 2801 } | |
| 2802 | |
| 2803 /* If we're in a macro, or noninteractive, or early in temacs, then | |
| 2804 don't wait. */ | |
| 2805 if (noninteractive || !NILP (Vexecuting_macro)) | |
| 2806 return Qnil; | |
| 2807 | |
| 2808 /* Recursive call from a filter function or timeout handler. */ | |
| 1268 | 2809 if (recursive_sit_for) |
| 428 | 2810 { |
| 2811 if (!event_stream_event_pending_p (1) && NILP (nodisplay)) | |
| 2812 redisplay (); | |
| 2813 return Qnil; | |
| 2814 } | |
| 2815 | |
| 2816 | |
| 2817 /* Otherwise, start reading events from the event_stream. | |
| 2818 Do this loop at least once even if (sit-for 0) so that we | |
| 2819 redisplay when no input pending. | |
| 2820 */ | |
| 2821 GCPRO1 (event); | |
| 2822 event = Fmake_event (Qnil, Qnil); | |
| 2823 | |
| 2824 /* Generate the wakeup even if MSECS is 0, so that existing timeout/etc. | |
| 2825 events get processed. The old (pre-19.12) code special-cased this | |
| 2826 and didn't generate a wakeup, but the resulting behavior was less than | |
| 2827 ideal; viz. the occurrence of (sit-for 0.001) scattered throughout | |
| 2828 the E-Lisp universe. */ | |
| 2829 | |
| 2830 id = event_stream_generate_wakeup (msecs, 0, Qnil, Qnil, 0); | |
| 2831 | |
| 2832 count = specpdl_depth (); | |
| 2833 record_unwind_protect (sit_for_unwind, make_int (id)); | |
| 1268 | 2834 recursive_sit_for = 1; |
| 428 | 2835 |
| 2836 while (1) | |
| 2837 { | |
| 2838 /* If there is no user input pending, then redisplay. | |
| 2839 */ | |
| 2840 if (!event_stream_event_pending_p (1) && NILP (nodisplay)) | |
| 2841 redisplay (); | |
| 2842 | |
| 2843 /* If our timeout has arrived, we move along. */ | |
| 2844 if (!event_stream_wakeup_pending_p (id, 0)) | |
| 2845 { | |
| 2846 result = Qt; | |
| 2847 goto DONE_LABEL; | |
| 2848 } | |
| 2849 | |
| 2850 /* We're a generator of the command_event_queue, so we can't be a | |
| 2851 consumer as well. In fact, we know there's nothing on the | |
| 2852 command_event_queue that we didn't just put there. | |
| 2853 */ | |
| 2854 next_event_internal (event, 0); /* blocks */ | |
| 2855 | |
| 2856 if (command_event_p (event)) | |
| 2857 { | |
| 2858 result = Qnil; | |
| 2859 goto DONE_LABEL; | |
| 2860 } | |
| 2861 switch (XEVENT_TYPE (event)) | |
| 2862 { | |
| 2863 case eval_event: | |
| 2864 { | |
| 2865 /* eval-events get delayed until later. */ | |
| 2866 enqueue_command_event (Fcopy_event (event, Qnil)); | |
| 2867 break; | |
| 2868 } | |
| 2869 | |
| 2870 case timeout_event: | |
| 2871 /* We execute the event even if it's ours, and notice that it's | |
| 2872 happened above. */ | |
| 2873 default: | |
| 2874 { | |
| 2875 execute_internal_event (event); | |
| 2876 break; | |
| 2877 } | |
| 2878 } | |
| 2879 } | |
| 2880 | |
| 2881 DONE_LABEL: | |
| 771 | 2882 unbind_to_1 (count, make_int (id)); |
| 428 | 2883 |
| 2884 /* Put back the event (if any) that made Fsit_for() exit before the | |
| 2885 timeout. Note that it is being added to the back of the queue, which | |
| 2886 would be inappropriate if there were any user events on the queue | |
| 2887 already: we would be misordering them. But we know that there are | |
| 2888 no user-events on the queue, or else we would not have reached this | |
| 2889 point at all. | |
| 2890 */ | |
| 2891 if (NILP (result)) | |
| 2892 enqueue_command_event (event); | |
| 2893 else | |
| 2894 Fdeallocate_event (event); | |
| 2895 | |
| 2896 UNGCPRO; | |
| 2897 return result; | |
| 2898 } | |
| 2899 | |
| 442 | 2900 /* This handy little function is used by select-x.c to wait for replies |
| 2901 from processes that aren't really processes (e.g. the X server) */ | |
| 428 | 2902 void |
| 2903 wait_delaying_user_input (int (*predicate) (void *arg), void *predicate_arg) | |
| 2904 { | |
| 2905 /* This function can GC */ | |
| 2906 Lisp_Object event = Fmake_event (Qnil, Qnil); | |
| 2907 struct gcpro gcpro1; | |
| 2908 GCPRO1 (event); | |
| 2909 | |
| 2910 while (!(*predicate) (predicate_arg)) | |
| 2911 { | |
| 2912 /* We're a generator of the command_event_queue, so we can't be a | |
| 2913 consumer as well. Also, we have no reason to consult the | |
| 2914 command_event_queue; there are only user and eval-events there, | |
| 2915 and we'd just have to put them back anyway. | |
| 2916 */ | |
| 2917 next_event_internal (event, 0); | |
| 2918 if (command_event_p (event) | |
| 2919 || (XEVENT_TYPE (event) == eval_event) | |
| 2920 || (XEVENT_TYPE (event) == magic_eval_event)) | |
| 2921 enqueue_command_event_1 (event); | |
| 2922 else | |
| 2923 execute_internal_event (event); | |
| 2924 } | |
| 2925 UNGCPRO; | |
| 2926 } | |
| 2927 | |
| 2928 | |
| 2929 /**********************************************************************/ | |
| 2930 /* dispatching events; command builder */ | |
| 2931 /**********************************************************************/ | |
| 2932 | |
| 2933 static void | |
| 2934 execute_internal_event (Lisp_Object event) | |
| 2935 { | |
| 1292 | 2936 PROFILE_DECLARE (); |
| 2937 | |
| 428 | 2938 /* events on dead channels get silently eaten */ |
| 2939 if (object_dead_p (XEVENT (event)->channel)) | |
| 2940 return; | |
| 2941 | |
| 1292 | 2942 PROFILE_RECORD_ENTERING_SECTION (QSexecute_internal_event); |
| 2943 | |
| 428 | 2944 /* This function can GC */ |
| 2945 switch (XEVENT_TYPE (event)) | |
| 2946 { | |
| 2947 case empty_event: | |
| 1292 | 2948 goto done; |
| 428 | 2949 |
| 2950 case eval_event: | |
| 2951 { | |
| 1204 | 2952 call1 (XEVENT_EVAL_FUNCTION (event), |
| 2953 XEVENT_EVAL_OBJECT (event)); | |
| 1292 | 2954 goto done; |
| 428 | 2955 } |
| 2956 | |
| 2957 case magic_eval_event: | |
| 2958 { | |
| 1204 | 2959 XEVENT_MAGIC_EVAL_INTERNAL_FUNCTION (event) |
| 2960 XEVENT_MAGIC_EVAL_OBJECT (event); | |
| 1292 | 2961 goto done; |
| 428 | 2962 } |
| 2963 | |
| 2964 case pointer_motion_event: | |
| 2965 { | |
| 2966 if (!NILP (Vmouse_motion_handler)) | |
| 2967 call1 (Vmouse_motion_handler, event); | |
| 1292 | 2968 goto done; |
| 428 | 2969 } |
| 2970 | |
| 2971 case process_event: | |
| 2972 { | |
| 1204 | 2973 Lisp_Object p = XEVENT_PROCESS_PROCESS (event); |
| 428 | 2974 Charcount readstatus; |
| 853 | 2975 int iter; |
| 2976 | |
| 2977 assert (PROCESSP (p)); | |
| 2978 for (iter = 0; iter < 2; iter++) | |
| 2979 { | |
| 2980 if (iter == 1 && !process_has_separate_stderr (p)) | |
| 2981 break; | |
| 2982 while ((readstatus = read_process_output (p, iter)) > 0) | |
| 2983 ; | |
| 2984 if (readstatus > 0) | |
| 2985 ; /* this clauses never gets executed but | |
| 2986 allows the #ifdefs to work cleanly. */ | |
| 428 | 2987 #ifdef EWOULDBLOCK |
| 853 | 2988 else if (readstatus == -1 && errno == EWOULDBLOCK) |
| 2989 ; | |
| 428 | 2990 #endif /* EWOULDBLOCK */ |
| 2991 #ifdef EAGAIN | |
| 853 | 2992 else if (readstatus == -1 && errno == EAGAIN) |
| 2993 ; | |
| 428 | 2994 #endif /* EAGAIN */ |
| 853 | 2995 else if ((readstatus == 0 && |
| 2996 /* Note that we cannot distinguish between no input | |
| 2997 available now and a closed pipe. | |
| 2998 With luck, a closed pipe will be accompanied by | |
| 2999 subprocess termination and SIGCHLD. */ | |
| 3000 (!network_connection_p (p) || | |
| 3001 /* | |
| 3002 When connected to ToolTalk (i.e. | |
| 3003 connected_via_filedesc_p()), it's not possible to | |
| 3004 reliably determine whether there is a message | |
| 3005 waiting for ToolTalk to receive. ToolTalk expects | |
| 3006 to have tt_message_receive() called exactly once | |
| 3007 every time the file descriptor becomes active, so | |
| 3008 the filter function forces this by returning 0. | |
| 3009 Emacs must not interpret this as a closed pipe. */ | |
| 3010 connected_via_filedesc_p (XPROCESS (p)))) | |
| 3011 | |
| 3012 /* On some OSs with ptys, when the process on one end of | |
| 3013 a pty exits, the other end gets an error reading with | |
| 3014 errno = EIO instead of getting an EOF (0 bytes read). | |
| 3015 Therefore, if we get an error reading and errno = | |
| 3016 EIO, just continue, because the child process has | |
| 3017 exited and should clean itself up soon (e.g. when we | |
| 3018 get a SIGCHLD). */ | |
| 535 | 3019 #ifdef EIO |
| 853 | 3020 || (readstatus == -1 && errno == EIO) |
| 428 | 3021 #endif |
| 535 | 3022 |
| 853 | 3023 ) |
| 3024 { | |
| 3025 /* Currently, we rely on SIGCHLD to indicate that the | |
| 3026 process has terminated. Unfortunately, on some systems | |
| 3027 the SIGCHLD gets missed some of the time. So we put an | |
| 3028 additional check in status_notify() to see whether a | |
| 3029 process has terminated. We must tell status_notify() | |
| 3030 to enable that check, and we do so now. */ | |
| 3031 kick_status_notify (); | |
| 3032 } | |
| 898 | 3033 else |
| 3034 { | |
| 3035 /* Deactivate network connection */ | |
| 3036 Lisp_Object status = Fprocess_status (p); | |
| 3037 if (EQ (status, Qopen) | |
| 3038 /* In case somebody changes the theory of whether to | |
| 3039 return open as opposed to run for network connection | |
| 3040 "processes"... */ | |
| 3041 || EQ (status, Qrun)) | |
| 3042 update_process_status (p, Qexit, 256, 0); | |
| 3043 deactivate_process (p); | |
| 3044 status_notify (); | |
| 3045 } | |
| 853 | 3046 |
| 3047 /* We must call status_notify here to allow the | |
| 3048 event_stream->unselect_process_cb to be run if appropriate. | |
| 3049 Otherwise, dead fds may be selected for, and we will get a | |
| 3050 continuous stream of process events for them. Since we don't | |
| 3051 return until all process events have been flushed, we would | |
| 3052 get stuck here, processing events on a process whose status | |
| 3025 | 3053 was `exit'. Call this after dispatch-event, or the fds will |
| 853 | 3054 have been closed before we read the last data from them. |
| 3055 It's safe for the filter to signal an error because | |
| 3056 status_notify() will be called on return to top-level. | |
| 3057 */ | |
| 3058 status_notify (); | |
| 428 | 3059 } |
| 1292 | 3060 goto done; |
| 428 | 3061 } |
| 3062 | |
| 3063 case timeout_event: | |
| 3064 { | |
| 440 | 3065 Lisp_Event *e = XEVENT (event); |
| 934 | 3066 |
| 1204 | 3067 if (!NILP (EVENT_TIMEOUT_FUNCTION (e))) |
| 3068 call1 (EVENT_TIMEOUT_FUNCTION (e), | |
| 3069 EVENT_TIMEOUT_OBJECT (e)); | |
| 1292 | 3070 goto done; |
| 428 | 3071 } |
| 3072 case magic_event: | |
| 3073 event_stream_handle_magic_event (XEVENT (event)); | |
| 1292 | 3074 goto done; |
| 428 | 3075 default: |
| 2500 | 3076 ABORT (); |
| 428 | 3077 } |
| 1292 | 3078 |
| 3079 done: | |
| 3080 PROFILE_RECORD_EXITING_SECTION (QSexecute_internal_event); | |
| 428 | 3081 } |
| 3082 | |
| 3083 | |
| 3084 | |
| 3085 static void | |
| 3086 this_command_keys_replace_suffix (Lisp_Object suffix, Lisp_Object chain) | |
| 3087 { | |
| 3088 Lisp_Object first_before_suffix = | |
| 3089 event_chain_find_previous (Vthis_command_keys, suffix); | |
| 3090 | |
| 3091 if (NILP (first_before_suffix)) | |
| 3092 Vthis_command_keys = chain; | |
| 3093 else | |
| 3094 XSET_EVENT_NEXT (first_before_suffix, chain); | |
| 3095 deallocate_event_chain (suffix); | |
| 3096 Vthis_command_keys_tail = event_chain_tail (chain); | |
| 3097 } | |
| 3098 | |
| 3099 static void | |
| 3100 command_builder_replace_suffix (struct command_builder *builder, | |
| 3101 Lisp_Object suffix, Lisp_Object chain) | |
| 3102 { | |
| 3103 Lisp_Object first_before_suffix = | |
| 3104 event_chain_find_previous (builder->current_events, suffix); | |
| 3105 | |
| 3106 if (NILP (first_before_suffix)) | |
| 3107 builder->current_events = chain; | |
| 3108 else | |
| 3109 XSET_EVENT_NEXT (first_before_suffix, chain); | |
| 3110 deallocate_event_chain (suffix); | |
| 3111 builder->most_current_event = event_chain_tail (chain); | |
| 3112 } | |
| 3113 | |
| 3114 static Lisp_Object | |
| 3115 command_builder_find_leaf_1 (struct command_builder *builder) | |
| 3116 { | |
| 3117 Lisp_Object event0 = builder->current_events; | |
| 3118 | |
| 3119 if (NILP (event0)) | |
| 3120 return Qnil; | |
| 3121 | |
| 3122 return event_binding (event0, 1); | |
| 3123 } | |
| 3124 | |
| 1268 | 3125 static void |
| 3126 maybe_kbd_translate (Lisp_Object event) | |
| 3127 { | |
| 3128 Ichar c; | |
| 3129 int did_translate = 0; | |
| 3130 | |
| 3131 if (XEVENT_TYPE (event) != key_press_event) | |
| 3132 return; | |
| 3133 if (!HASH_TABLEP (Vkeyboard_translate_table)) | |
| 3134 return; | |
| 3135 if (EQ (Fhash_table_count (Vkeyboard_translate_table), Qzero)) | |
| 3136 return; | |
| 3137 | |
| 2828 | 3138 c = event_to_character (event, 0, 0); |
| 1268 | 3139 if (c != -1) |
| 3140 { | |
| 3141 Lisp_Object traduit = Fgethash (make_char (c), Vkeyboard_translate_table, | |
| 3142 Qnil); | |
| 3143 if (!NILP (traduit) && SYMBOLP (traduit)) | |
| 3144 { | |
| 3145 XSET_EVENT_KEY_KEYSYM (event, traduit); | |
| 3146 XSET_EVENT_KEY_MODIFIERS (event, 0); | |
| 3147 did_translate = 1; | |
| 3148 } | |
| 3149 else if (CHARP (traduit)) | |
| 3150 { | |
| 3151 /* This used to call Fcharacter_to_event() directly into EVENT, | |
| 3152 but that can eradicate timestamps and other such stuff. | |
| 3153 This way is safer. */ | |
| 3154 Lisp_Object ev2 = Fmake_event (Qnil, Qnil); | |
| 3155 | |
| 3156 character_to_event (XCHAR (traduit), XEVENT (ev2), | |
|
4780
2fd201d73a92
Call character_to_event on characters received from XIM, event-Xt.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
4775
diff
changeset
|
3157 XCONSOLE (XEVENT_CHANNEL (event)), |
|
2fd201d73a92
Call character_to_event on characters received from XIM, event-Xt.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
4775
diff
changeset
|
3158 high_bit_is_meta, 1); |
| 1268 | 3159 XSET_EVENT_KEY_KEYSYM (event, XEVENT_KEY_KEYSYM (ev2)); |
| 3160 XSET_EVENT_KEY_MODIFIERS (event, XEVENT_KEY_MODIFIERS (ev2)); | |
| 3161 Fdeallocate_event (ev2); | |
| 3162 did_translate = 1; | |
| 3163 } | |
| 3164 } | |
| 3165 | |
| 3166 if (!did_translate) | |
| 3167 { | |
| 3168 Lisp_Object traduit = Fgethash (XEVENT_KEY_KEYSYM (event), | |
| 3169 Vkeyboard_translate_table, Qnil); | |
| 3170 if (!NILP (traduit) && SYMBOLP (traduit)) | |
| 3171 { | |
| 3172 XSET_EVENT_KEY_KEYSYM (event, traduit); | |
| 3173 did_translate = 1; | |
| 3174 } | |
| 3175 else if (CHARP (traduit)) | |
| 3176 { | |
| 3177 /* This used to call Fcharacter_to_event() directly into EVENT, | |
| 3178 but that can eradicate timestamps and other such stuff. | |
| 3179 This way is safer. */ | |
| 3180 Lisp_Object ev2 = Fmake_event (Qnil, Qnil); | |
| 3181 | |
| 3182 character_to_event (XCHAR (traduit), XEVENT (ev2), | |
|
4780
2fd201d73a92
Call character_to_event on characters received from XIM, event-Xt.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
4775
diff
changeset
|
3183 XCONSOLE (XEVENT_CHANNEL (event)), |
|
2fd201d73a92
Call character_to_event on characters received from XIM, event-Xt.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
4775
diff
changeset
|
3184 high_bit_is_meta, 1); |
| 1268 | 3185 XSET_EVENT_KEY_KEYSYM (event, XEVENT_KEY_KEYSYM (ev2)); |
| 3186 XSET_EVENT_KEY_MODIFIERS (event, | |
| 3187 XEVENT_KEY_MODIFIERS (event) | | |
| 3188 XEVENT_KEY_MODIFIERS (ev2)); | |
| 3189 | |
| 3190 Fdeallocate_event (ev2); | |
| 3191 did_translate = 1; | |
| 3192 } | |
| 3193 } | |
| 3194 | |
| 3195 #ifdef DEBUG_XEMACS | |
| 3196 if (did_translate) | |
| 3197 DEBUG_PRINT_EMACS_EVENT ("->keyboard-translate-table", event); | |
| 3198 #endif | |
| 3199 } | |
| 3200 | |
| 428 | 3201 /* See if we can do function-key-map or key-translation-map translation |
| 3202 on the current events in the command builder. If so, do this, and | |
| 771 | 3203 return the resulting binding, if any. |
| 3204 | |
| 3205 DID_MUNGE must be initialized before calling this function. If munging | |
| 3206 happened, DID_MUNGE will be non-zero; otherwise, it will be left alone. | |
| 3207 */ | |
| 428 | 3208 |
| 3209 static Lisp_Object | |
| 3210 munge_keymap_translate (struct command_builder *builder, | |
| 3211 enum munge_me_out_the_door munge, | |
| 771 | 3212 int has_normal_binding_p, int *did_munge) |
| 428 | 3213 { |
| 3214 Lisp_Object suffix; | |
| 3215 | |
| 1204 | 3216 EVENT_CHAIN_LOOP (suffix, builder->first_mungeable_event[munge]) |
| 428 | 3217 { |
| 3218 Lisp_Object result = munging_key_map_event_binding (suffix, munge); | |
| 3219 | |
| 3220 if (NILP (result)) | |
| 3221 continue; | |
| 3222 | |
| 3223 if (KEYMAPP (result)) | |
| 3224 { | |
| 3225 if (NILP (builder->last_non_munged_event) | |
| 3226 && !has_normal_binding_p) | |
| 3227 builder->last_non_munged_event = builder->most_current_event; | |
| 3228 } | |
| 3229 else | |
| 3230 builder->last_non_munged_event = Qnil; | |
| 3231 | |
| 3232 if (!KEYMAPP (result) && | |
| 3233 !VECTORP (result) && | |
| 3234 !STRINGP (result)) | |
| 3235 { | |
| 3236 struct gcpro gcpro1; | |
| 3237 GCPRO1 (suffix); | |
| 3238 result = call1 (result, Qnil); | |
| 3239 UNGCPRO; | |
| 3240 if (NILP (result)) | |
| 3241 return Qnil; | |
| 3242 } | |
| 3243 | |
| 3244 if (KEYMAPP (result)) | |
| 3245 return result; | |
| 3246 | |
| 3247 if (VECTORP (result) || STRINGP (result)) | |
| 3248 { | |
| 3249 Lisp_Object new_chain = key_sequence_to_event_chain (result); | |
| 3250 Lisp_Object tempev; | |
| 3251 | |
| 3252 /* If the first_mungeable_event of the other munger is | |
| 3253 within the events we're munging, then it will point to | |
| 3254 deallocated events afterwards, which is bad -- so make it | |
| 3255 point at the beginning of the munged events. */ | |
| 3256 EVENT_CHAIN_LOOP (tempev, suffix) | |
| 3257 { | |
| 3258 Lisp_Object *mungeable_event = | |
| 1204 | 3259 &builder->first_mungeable_event[1 - munge]; |
| 428 | 3260 if (EQ (tempev, *mungeable_event)) |
| 3261 { | |
| 3262 *mungeable_event = new_chain; | |
| 3263 break; | |
| 3264 } | |
| 3265 } | |
| 3266 | |
| 771 | 3267 /* Now munge the current event chain in the command builder. */ |
| 428 | 3268 command_builder_replace_suffix (builder, suffix, new_chain); |
| 1204 | 3269 builder->first_mungeable_event[munge] = Qnil; |
| 771 | 3270 |
| 3271 *did_munge = 1; | |
| 428 | 3272 |
| 793 | 3273 return command_builder_find_leaf_1 (builder); |
| 428 | 3274 } |
| 3275 | |
| 563 | 3276 signal_error (Qinvalid_key_binding, |
| 3277 (munge == MUNGE_ME_FUNCTION_KEY ? | |
| 3278 "Invalid binding in function-key-map" : | |
| 3279 "Invalid binding in key-translation-map"), | |
| 3280 result); | |
| 428 | 3281 } |
| 3282 | |
| 3283 return Qnil; | |
| 3284 } | |
| 3285 | |
| 2828 | 3286 /* Same as command_builder_find_leaf() below, but without offering the |
| 3287 platform-specific event code the opportunity to give a default binding of | |
| 3288 an unseen keysym to self-insert-command, and without the fallback to | |
| 3289 other keymaps for lookups that allows someone with a Cyrillic keyboard | |
| 3290 to pretend it's Qwerty for C-x C-f, for example. */ | |
| 771 | 3291 |
| 428 | 3292 static Lisp_Object |
| 2828 | 3293 command_builder_find_leaf_no_jit_binding (struct command_builder *builder, |
| 771 | 3294 int allow_misc_user_events_p, |
| 3295 int *did_munge) | |
| 428 | 3296 { |
| 3297 /* This function can GC */ | |
| 3298 Lisp_Object result; | |
| 3299 Lisp_Object evee = builder->current_events; | |
| 3300 | |
| 3301 if (XEVENT_TYPE (evee) == misc_user_event) | |
| 3302 { | |
| 3303 if (allow_misc_user_events_p && (NILP (XEVENT_NEXT (evee)))) | |
| 1204 | 3304 return list2 (XEVENT_EVAL_FUNCTION (evee), |
| 3305 XEVENT_EVAL_OBJECT (evee)); | |
| 428 | 3306 else |
| 3307 return Qnil; | |
| 3308 } | |
| 3309 | |
| 442 | 3310 /* if we're currently in a menu accelerator, check there for further |
| 3311 events */ | |
| 3312 /* #### fuck me! who wrote this crap? think "abstraction", baby. */ | |
| 771 | 3313 /* #### this horribly-written crap can mess with global state, which |
| 3314 this function should not do. i'm not fixing it now. someone | |
| 3315 needs to go and rewrite that shit correctly. --ben */ | |
| 1268 | 3316 #if defined (HAVE_X_WINDOWS) && defined (LWLIB_MENUBARS_LUCID) |
| 442 | 3317 if (x_kludge_lw_menu_active ()) |
| 428 | 3318 { |
| 3319 return command_builder_operate_menu_accelerator (builder); | |
| 3320 } | |
| 3321 else | |
| 3322 { | |
| 3323 result = Qnil; | |
| 3324 if (EQ (Vmenu_accelerator_enabled, Qmenu_force)) | |
| 3325 result = command_builder_find_menu_accelerator (builder); | |
| 3326 if (NILP (result)) | |
| 3327 #endif | |
| 3328 result = command_builder_find_leaf_1 (builder); | |
| 1268 | 3329 #if defined (HAVE_X_WINDOWS) && defined (LWLIB_MENUBARS_LUCID) |
| 428 | 3330 if (NILP (result) |
| 3331 && EQ (Vmenu_accelerator_enabled, Qmenu_fallback)) | |
| 3332 result = command_builder_find_menu_accelerator (builder); | |
| 3333 } | |
| 3334 #endif | |
| 3335 | |
| 3336 /* Check to see if we have a potential function-key-map match. */ | |
| 3337 if (NILP (result)) | |
| 771 | 3338 result = munge_keymap_translate (builder, MUNGE_ME_FUNCTION_KEY, 0, |
| 3339 did_munge); | |
| 3340 | |
| 428 | 3341 /* Check to see if we have a potential key-translation-map match. */ |
| 3342 { | |
| 3343 Lisp_Object key_translate_result = | |
| 3344 munge_keymap_translate (builder, MUNGE_ME_KEY_TRANSLATION, | |
| 771 | 3345 !NILP (result), did_munge); |
| 428 | 3346 if (!NILP (key_translate_result)) |
| 771 | 3347 result = key_translate_result; |
| 428 | 3348 } |
| 3349 | |
| 3350 if (!NILP (result)) | |
| 3351 return result; | |
| 3352 | |
| 3353 /* If key-sequence wasn't bound, we'll try some fallbacks. */ | |
| 3354 | |
| 3355 /* If we didn't find a binding, and the last event in the sequence is | |
| 3356 a shifted character, then try again with the lowercase version. */ | |
| 3357 | |
| 3358 if (XEVENT_TYPE (builder->most_current_event) == key_press_event | |
| 3359 && !NILP (Vretry_undefined_key_binding_unshifted)) | |
| 3360 { | |
| 1204 | 3361 if (event_upshifted_p (builder->most_current_event)) |
| 428 | 3362 { |
| 771 | 3363 Lisp_Object neubauten = copy_command_builder (builder, 0); |
| 3364 struct command_builder *neub = XCOMMAND_BUILDER (neubauten); | |
| 3365 struct gcpro gcpro1; | |
| 3366 | |
| 3367 GCPRO1 (neubauten); | |
| 1204 | 3368 downshift_event (event_chain_tail (neub->current_events)); |
| 771 | 3369 result = |
| 2828 | 3370 command_builder_find_leaf_no_jit_binding |
| 771 | 3371 (neub, allow_misc_user_events_p, did_munge); |
| 3372 | |
| 428 | 3373 if (!NILP (result)) |
| 771 | 3374 { |
| 3375 copy_command_builder (neub, builder); | |
| 3376 *did_munge = 1; | |
| 3377 } | |
| 3378 free_command_builder (neub); | |
| 3379 UNGCPRO; | |
| 3380 if (!NILP (result)) | |
| 428 | 3381 return result; |
| 3382 } | |
| 3383 } | |
| 3384 | |
| 3385 /* help-char is `auto-bound' in every keymap */ | |
| 3386 if (!NILP (Vprefix_help_command) && | |
| 1204 | 3387 event_matches_key_specifier_p (builder->most_current_event, Vhelp_char)) |
| 428 | 3388 return Vprefix_help_command; |
| 3389 | |
| 771 | 3390 return Qnil; |
| 3391 } | |
| 3392 | |
| 3393 /* Compare the current state of the command builder against the local and | |
| 3394 global keymaps, and return the binding. If there is no match, try again, | |
| 3395 case-insensitively. The return value will be one of: | |
| 3396 -- nil (there is no binding) | |
| 3397 -- a keymap (part of a command has been specified) | |
| 3398 -- a command (anything that satisfies `commandp'; this includes | |
| 3399 some symbols, lists, subrs, strings, vectors, and | |
| 3400 compiled-function objects) | |
| 3401 | |
| 3402 This may "munge" the current event chain in the command builder; | |
| 3403 i.e. the sequence might be mutated into a different sequence, | |
| 3404 which we then pretend is what the user actually typed instead of | |
| 3405 the passed-in sequence. This happens as a result of: | |
| 3406 | |
| 3407 -- key-translation-map changes | |
| 3408 -- function-key-map changes | |
| 3409 -- retry-undefined-key-binding-unshifted (q.v.) | |
| 3410 -- "Russian C-x problem" changes (see definition of struct key_data, | |
| 3411 events.h) | |
| 3412 | |
| 3413 DID_MUNGE must be initialized before calling this function. If munging | |
| 3414 happened, DID_MUNGE will be non-zero; otherwise, it will be left alone. | |
| 2828 | 3415 |
| 3416 (The above was Ben, I think.) | |
| 3417 | |
| 3418 It might be nice to have lookup-key call this function, directly or | |
| 3419 indirectly. Though it is arguably the right thing if lookup-key fails on | |
| 3420 a keysym that the X11 event code hasn't seen. There's no way to know if | |
| 3421 that keysym is generatable by the keyboard until it's generated, | |
| 3422 therefore there's no reasonable expectation that it be bound before it's | |
| 3423 generated--all the other default bindings depend on our knowing the | |
| 3424 keyboard layout and relying on it. And describe-key works without it, so | |
| 3425 I think we're fine. | |
| 3426 | |
| 3427 Some weirdness with this code--try this on a keyboard where X11 will | |
| 3428 produce ediaeresis with dead-diaeresis and e, but it's not produced by | |
| 3429 any other combination of keys on the keyboard; | |
| 3430 | |
| 3431 (defun ding-command () | |
| 3432 (interactive) | |
| 3433 (ding)) | |
| 3434 | |
| 3435 (define-key global-map 'ediaeresis 'ding-command) | |
| 3436 | |
| 3437 Now, pressing dead-diaeresis and then e will ding. Next; | |
| 3438 | |
| 3439 (define-key global-map 'ediaeresis 'self-insert-command) | |
| 3440 | |
| 3441 and press dead-diaeresis and then e. It'll give you "Invalid argument: | |
| 3442 typed key has no ASCII equivalent" Then; | |
| 3443 | |
| 3444 (define-key global-map 'ediaeresis nil) | |
| 3445 | |
| 3446 and press the combination again; it'll self-insert. The moral of the | |
| 3447 story is, if you want to suppress all bindings to a non-ASCII X11 key, | |
| 3448 bind it to a trivial no-op command, because the automatic mapping to | |
| 3449 self-insert-command will happen if there's no existing binding for the | |
| 3450 symbol. I can't see a way around this. -- Aidan Kehoe, 2005-05-14 */ | |
| 771 | 3451 |
| 3452 static Lisp_Object | |
| 3453 command_builder_find_leaf (struct command_builder *builder, | |
| 3454 int allow_misc_user_events_p, | |
| 3455 int *did_munge) | |
| 3456 { | |
| 3457 Lisp_Object result = | |
| 2828 | 3458 command_builder_find_leaf_no_jit_binding |
| 771 | 3459 (builder, allow_misc_user_events_p, did_munge); |
| 2828 | 3460 Lisp_Object event, console, channel, lookup_res; |
| 3461 int redolookup = 0, i; | |
| 771 | 3462 |
| 3463 if (!NILP (result)) | |
| 3464 return result; | |
| 3465 | |
| 2828 | 3466 /* If some of the events are keyboard events, and this is the first time |
| 3467 the platform event code has seen their keysyms--which will be the case | |
| 3468 the first time we see a composed keysym on X11, for example--offer it | |
| 3469 the chance to define them as a self-insert-command, and do the lookup | |
| 3470 again. | |
| 3471 | |
| 3472 This isn't Mule-specific; in a world where x-iso8859-1.el is gone, it's | |
| 3473 needed for non-Mule too. | |
| 3474 | |
| 3475 Probably this can just be limited to the checking the last | |
| 3476 keypress. */ | |
| 3477 | |
| 3478 EVENT_CHAIN_LOOP (event, builder->current_events) | |
| 3479 { | |
| 3480 /* We can ignore key release events because the preceding presses will | |
| 3481 have initiated the mapping. */ | |
| 3482 if (key_press_event != XEVENT_TYPE (event)) | |
| 3483 continue; | |
| 3484 | |
| 3485 channel = XEVENT_CHANNEL (event); | |
| 3486 if (object_dead_p (channel)) | |
| 3487 continue; | |
| 3488 | |
| 3489 console = CDFW_CONSOLE (channel); | |
| 3490 if (NILP (console)) | |
| 3491 console = Vselected_console; | |
| 3492 | |
| 3493 if (CONSOLE_LIVE_P(XCONSOLE(console))) | |
| 3494 { | |
| 3495 lookup_res = MAYBE_LISP_CONMETH(XCONSOLE(console), | |
| 3496 perhaps_init_unseen_key_defaults, | |
| 3497 (XCONSOLE(console), | |
| 3498 XEVENT_KEY_KEYSYM(event))); | |
| 3499 if (EQ(lookup_res, Qt)) | |
| 3500 { | |
| 3501 redolookup += 1; | |
| 3502 } | |
| 3503 } | |
| 3504 } | |
| 3505 | |
| 3506 if (redolookup) | |
| 428 | 3507 { |
| 2828 | 3508 result = command_builder_find_leaf_no_jit_binding |
| 3509 (builder, allow_misc_user_events_p, did_munge); | |
| 3510 if (!NILP (result)) | |
| 3511 { | |
| 3512 return result; | |
| 3513 } | |
| 3514 } | |
| 3515 | |
| 3516 /* The old composed-character-default-binding handling that used to be | |
| 3517 here was wrong--if a user wants to bind a given key to something other | |
| 3518 than self-insert-command, then they should go ahead and do it, we won't | |
| 3519 override it, and the sane thing to do with any key that has a known | |
| 3520 character correspondence is _always_ to default it to | |
| 3521 self-insert-command, nothing else. | |
| 3522 | |
| 3523 I'm adding the variable to control whether "Russian C-x processing" is | |
| 3524 used because I have a feeling that it's not always the most appropriate | |
| 3525 thing to do--in cases where people are using a non-Qwerty | |
| 3526 Roman-alphabet layout, do they really want C-x with some random letter | |
| 3527 to call `switch-to-buffer'? I can imagine that being very confusing, | |
| 3528 certainly for new users, and it might be that defaulting the value for | |
| 3529 `try-alternate-layouts-for-commands' as part of the language | |
| 3530 environment is the right thing to do, only defaulting to `t' for those | |
| 3531 languages that don't use the Roman alphabet. | |
| 3532 | |
| 3533 Much of that reasoning is tentative on my part, and feel free to change | |
| 3534 this code if you have more experience with the problem and an intuition | |
| 3535 that differs from mine. (Aidan Kehoe, 2005-05-29)*/ | |
| 3536 | |
| 3537 if (!try_alternate_layouts_for_commands) | |
| 3538 { | |
| 3539 return Qnil; | |
| 428 | 3540 } |
| 2828 | 3541 |
| 3542 if (key_press_event == XEVENT_TYPE (builder->most_current_event)) | |
| 3543 { | |
| 3544 Lisp_Object ev = builder->most_current_event, newbuilder; | |
| 3545 Ichar this_alternative; | |
| 3546 | |
| 3547 struct command_builder *newb; | |
| 3548 struct gcpro gcpro1; | |
| 3549 | |
| 3550 /* Ignore the value for CURRENT_LANGENV, because we've checked it | |
| 3551 already, above. */ | |
| 3552 for (i = KEYCHAR_CURRENT_LANGENV, ++i; i < KEYCHAR_LAST; ++i) | |
| 3553 { | |
| 3554 this_alternative = XEVENT_KEY_ALT_KEYCHARS(ev, i); | |
| 3555 | |
| 3556 if (0 == this_alternative) | |
| 3557 continue; | |
| 3558 | |
| 3559 newbuilder = copy_command_builder(builder, 0); | |
| 3560 GCPRO1(newbuilder); | |
| 3561 | |
| 3562 newb = XCOMMAND_BUILDER(newbuilder); | |
| 3563 | |
| 2830 | 3564 XSET_EVENT_KEY_KEYSYM(event_chain_tail |
| 3565 (XCOMMAND_BUILDER(newbuilder)->current_events), | |
| 2828 | 3566 make_char(this_alternative)); |
| 3567 | |
| 3568 result = command_builder_find_leaf_no_jit_binding | |
| 3569 (newb, allow_misc_user_events_p, did_munge); | |
| 3570 | |
| 3571 if (!NILP (result)) | |
| 3572 { | |
| 3573 copy_command_builder (newb, builder); | |
| 3574 *did_munge = 1; | |
| 3575 } | |
| 2830 | 3576 else if (event_upshifted_p |
| 3577 (XCOMMAND_BUILDER(newbuilder)->most_current_event) && | |
| 2828 | 3578 !NILP (Vretry_undefined_key_binding_unshifted) |
| 3579 && isascii(this_alternative)) | |
| 3580 { | |
| 2830 | 3581 downshift_event (event_chain_tail |
| 3582 (XCOMMAND_BUILDER(newbuilder)->current_events)); | |
| 3583 XSET_EVENT_KEY_KEYSYM(event_chain_tail | |
| 3584 (newb->current_events), | |
| 2828 | 3585 make_char(tolower(this_alternative))); |
| 3586 result = command_builder_find_leaf_no_jit_binding | |
| 3587 (newb, allow_misc_user_events_p, did_munge); | |
| 3588 } | |
| 3589 | |
| 3590 free_command_builder (newb); | |
| 3591 UNGCPRO; | |
| 3592 | |
| 3593 if (!NILP (result)) | |
| 3594 return result; | |
| 3595 } | |
| 3596 } | |
| 428 | 3597 |
| 3598 return Qnil; | |
| 3599 } | |
| 3600 | |
| 771 | 3601 /* Like command_builder_find_leaf but update this-command-keys and the |
| 3602 echo area as necessary when the current event chain was munged. */ | |
| 3603 | |
| 3604 static Lisp_Object | |
| 3605 command_builder_find_leaf_and_update_global_state (struct command_builder * | |
| 3606 builder, | |
| 3607 int | |
| 3608 allow_misc_user_events_p) | |
| 3609 { | |
| 3610 int did_munge = 0; | |
| 3611 int orig_length = event_chain_count (builder->current_events); | |
| 3612 Lisp_Object result = command_builder_find_leaf (builder, | |
| 3613 allow_misc_user_events_p, | |
| 3614 &did_munge); | |
| 3615 | |
| 3616 if (did_munge) | |
| 3617 { | |
| 3618 int tck_length = event_chain_count (Vthis_command_keys); | |
| 3619 | |
| 3620 /* We just assume that the events we just replaced are | |
| 3621 sitting in copied form at the end of this-command-keys. | |
| 3622 If the user did weird things with `dispatch-event' this | |
| 3623 may not be the case, but at least we make sure we won't | |
| 3624 crash. */ | |
| 3625 | |
| 3626 if (tck_length >= orig_length) | |
| 3627 { | |
| 3628 Lisp_Object new_chain = | |
| 3629 copy_event_chain (builder->current_events); | |
| 3630 this_command_keys_replace_suffix | |
| 3631 (event_chain_nth (Vthis_command_keys, tck_length - orig_length), | |
| 3632 new_chain); | |
| 3633 | |
| 3634 regenerate_echo_keys_from_this_command_keys (builder); | |
| 3635 } | |
| 3636 } | |
| 3637 | |
| 3638 if (NILP (result)) | |
| 3639 { | |
| 3640 /* If we read extra events attempting to match a function key but end | |
| 3641 up failing, then we release those events back to the command loop | |
| 3642 and fail on the original lookup. The released events will then be | |
| 3643 reprocessed in the context of the first part having failed. */ | |
| 3644 if (!NILP (builder->last_non_munged_event)) | |
| 3645 { | |
| 3646 Lisp_Object event0 = builder->last_non_munged_event; | |
| 3647 | |
| 3648 /* Put the commands back on the event queue. */ | |
| 3649 enqueue_event_chain (XEVENT_NEXT (event0), | |
| 3650 &command_event_queue, | |
| 3651 &command_event_queue_tail); | |
| 3652 | |
| 3653 /* Then remove them from the command builder. */ | |
| 3654 XSET_EVENT_NEXT (event0, Qnil); | |
| 3655 builder->most_current_event = event0; | |
| 3656 builder->last_non_munged_event = Qnil; | |
| 3657 } | |
| 3658 } | |
| 3659 | |
| 3660 return result; | |
| 3661 } | |
| 428 | 3662 |
| 3663 /* Every time a command-event (a key, button, or menu selection) is read by | |
| 3664 Fnext_event(), it is stored in the recent_keys_ring, in Vlast_input_event, | |
| 3665 and in Vthis_command_keys. (Eval-events are not stored there.) | |
| 3666 | |
| 3667 Every time a command is invoked, Vlast_command_event is set to the last | |
| 3668 event in the sequence. | |
| 3669 | |
| 3670 This means that Vthis_command_keys is really about "input read since the | |
| 3671 last command was executed" rather than about "what keys invoked this | |
| 3672 command." This is a little counterintuitive, but that's the way it | |
| 3673 has always worked. | |
| 3674 | |
| 3675 As an extra kink, the function read-key-sequence resets/updates the | |
| 3676 last-command-event and this-command-keys. It doesn't append to the | |
| 3677 command-keys as read-char does. Such are the pitfalls of having to | |
| 3678 maintain compatibility with a program for which the only specification | |
| 3679 is the code itself. | |
| 3680 | |
| 3681 (We could implement recent_keys_ring and Vthis_command_keys as the same | |
| 3682 data structure.) | |
| 3683 */ | |
| 3684 | |
| 3685 DEFUN ("recent-keys", Frecent_keys, 0, 1, 0, /* | |
| 3686 Return a vector of recent keyboard or mouse button events read. | |
| 3687 If NUMBER is non-nil, not more than NUMBER events will be returned. | |
| 3688 Change number of events stored using `set-recent-keys-ring-size'. | |
| 3689 | |
| 3690 This copies the event objects into a new vector; it is safe to keep and | |
| 3691 modify them. | |
| 3692 */ | |
| 3693 (number)) | |
| 3694 { | |
| 3695 struct gcpro gcpro1; | |
| 3696 Lisp_Object val = Qnil; | |
| 3697 int nwanted; | |
| 3698 int start, nkeys, i, j; | |
| 3699 GCPRO1 (val); | |
| 3700 | |
| 3701 if (NILP (number)) | |
| 3702 nwanted = recent_keys_ring_size; | |
| 3703 else | |
| 3704 { | |
| 3705 CHECK_NATNUM (number); | |
| 3706 nwanted = XINT (number); | |
| 3707 } | |
| 3708 | |
| 3709 /* Create the keys ring vector, if none present. */ | |
| 3710 if (NILP (Vrecent_keys_ring)) | |
| 3711 { | |
| 3712 Vrecent_keys_ring = make_vector (recent_keys_ring_size, Qnil); | |
| 3713 /* And return nothing in particular. */ | |
| 446 | 3714 RETURN_UNGCPRO (make_vector (0, Qnil)); |
| 428 | 3715 } |
| 3716 | |
| 3717 if (NILP (XVECTOR_DATA (Vrecent_keys_ring)[recent_keys_ring_index])) | |
| 3718 /* This means the vector has not yet wrapped */ | |
| 3719 { | |
| 3720 nkeys = recent_keys_ring_index; | |
| 3721 start = 0; | |
| 3722 } | |
| 3723 else | |
| 3724 { | |
| 3725 nkeys = recent_keys_ring_size; | |
| 3726 start = ((recent_keys_ring_index == nkeys) ? 0 : recent_keys_ring_index); | |
| 3727 } | |
| 3728 | |
| 3729 if (nwanted < nkeys) | |
| 3730 { | |
| 3731 start += nkeys - nwanted; | |
| 3732 if (start >= recent_keys_ring_size) | |
| 3733 start -= recent_keys_ring_size; | |
| 3734 nkeys = nwanted; | |
| 3735 } | |
| 3736 else | |
| 3737 nwanted = nkeys; | |
| 3738 | |
| 3739 val = make_vector (nwanted, Qnil); | |
| 3740 | |
| 3741 for (i = 0, j = start; i < nkeys; i++) | |
| 3742 { | |
| 3743 Lisp_Object e = XVECTOR_DATA (Vrecent_keys_ring)[j]; | |
| 3744 | |
|
5050
6f2158fa75ed
Fix quick-build, use asserts() in place of ABORT()
Ben Wing <ben@xemacs.org>
parents:
4976
diff
changeset
|
3745 assert (!NILP (e)); |
| 428 | 3746 XVECTOR_DATA (val)[i] = Fcopy_event (e, Qnil); |
| 3747 if (++j >= recent_keys_ring_size) | |
| 3748 j = 0; | |
| 3749 } | |
| 3750 UNGCPRO; | |
| 3751 return val; | |
| 3752 } | |
| 3753 | |
| 3754 | |
| 3755 DEFUN ("recent-keys-ring-size", Frecent_keys_ring_size, 0, 0, 0, /* | |
| 3756 The maximum number of events `recent-keys' can return. | |
| 3757 */ | |
| 3758 ()) | |
| 3759 { | |
| 3760 return make_int (recent_keys_ring_size); | |
| 3761 } | |
| 3762 | |
| 3763 DEFUN ("set-recent-keys-ring-size", Fset_recent_keys_ring_size, 1, 1, 0, /* | |
| 3764 Set the maximum number of events to be stored internally. | |
| 3765 */ | |
| 3766 (size)) | |
| 3767 { | |
| 3768 Lisp_Object new_vector = Qnil; | |
| 3769 int i, j, nkeys, start, min; | |
| 3770 struct gcpro gcpro1; | |
| 3771 | |
| 3772 CHECK_INT (size); | |
| 3773 if (XINT (size) <= 0) | |
| 563 | 3774 invalid_argument ("Recent keys ring size must be positive", size); |
| 428 | 3775 if (XINT (size) == recent_keys_ring_size) |
| 3776 return size; | |
| 3777 | |
| 446 | 3778 GCPRO1 (new_vector); |
| 428 | 3779 new_vector = make_vector (XINT (size), Qnil); |
| 3780 | |
| 3781 if (NILP (Vrecent_keys_ring)) | |
| 3782 { | |
| 3783 Vrecent_keys_ring = new_vector; | |
| 446 | 3784 RETURN_UNGCPRO (size); |
| 428 | 3785 } |
| 3786 | |
| 3787 if (NILP (XVECTOR_DATA (Vrecent_keys_ring)[recent_keys_ring_index])) | |
| 3788 /* This means the vector has not yet wrapped */ | |
| 3789 { | |
| 3790 nkeys = recent_keys_ring_index; | |
| 3791 start = 0; | |
| 3792 } | |
| 3793 else | |
| 3794 { | |
| 3795 nkeys = recent_keys_ring_size; | |
| 3796 start = ((recent_keys_ring_index == nkeys) ? 0 : recent_keys_ring_index); | |
| 3797 } | |
| 3798 | |
| 3799 if (XINT (size) > nkeys) | |
| 3800 min = nkeys; | |
| 3801 else | |
| 3802 min = XINT (size); | |
| 3803 | |
| 3804 for (i = 0, j = start; i < min; i++) | |
| 3805 { | |
| 3806 XVECTOR_DATA (new_vector)[i] = XVECTOR_DATA (Vrecent_keys_ring)[j]; | |
| 3807 if (++j >= recent_keys_ring_size) | |
| 3808 j = 0; | |
| 3809 } | |
| 3810 recent_keys_ring_size = XINT (size); | |
| 3811 recent_keys_ring_index = (i < recent_keys_ring_size) ? i : 0; | |
| 3812 | |
| 3813 Vrecent_keys_ring = new_vector; | |
| 3814 | |
| 3815 UNGCPRO; | |
| 3816 return size; | |
| 3817 } | |
| 3818 | |
| 3819 /* Vthis_command_keys having value Qnil means that the next time | |
| 3820 push_this_command_keys is called, it should start over. | |
| 3821 The times at which the command-keys are reset | |
| 3822 (instead of merely being augmented) are pretty counterintuitive. | |
| 3823 (More specifically: | |
| 3824 | |
| 3825 -- We do not reset this-command-keys when we finish reading a | |
| 3826 command. This is because some commands (e.g. C-u) act | |
| 3827 like command prefixes; they signal this by setting prefix-arg | |
| 3828 to non-nil. | |
| 3829 -- Therefore, we reset this-command-keys when we finish | |
| 3830 executing a command, unless prefix-arg is set. | |
| 3831 -- However, if we ever do a non-local exit out of a command | |
| 3832 loop (e.g. an error in a command), we need to reset | |
| 3833 this-command-keys. We do this by calling reset_this_command_keys() | |
| 3834 from cmdloop.c, whenever an error causes an invocation of the | |
| 3835 default error handler, and whenever there's a throw to top-level.) | |
| 3836 */ | |
| 3837 | |
| 3838 void | |
| 3839 reset_this_command_keys (Lisp_Object console, int clear_echo_area_p) | |
| 3840 { | |
| 757 | 3841 if (!NILP (console)) |
| 3842 { | |
| 3843 /* console is nil if we just deleted the console as a result of C-x 5 | |
| 3844 0. Unfortunately things are currently in a messy situation where | |
| 3845 some stuff is console-local and other stuff isn't, so we need to | |
| 3846 do everything that's not console-local. */ | |
| 3847 struct command_builder *command_builder = | |
| 3848 XCOMMAND_BUILDER (XCONSOLE (console)->command_builder); | |
| 3849 | |
| 3850 reset_key_echo (command_builder, clear_echo_area_p); | |
| 3851 reset_current_events (command_builder); | |
| 3852 } | |
| 3853 else | |
| 3854 reset_key_echo (0, clear_echo_area_p); | |
| 428 | 3855 |
| 3856 deallocate_event_chain (Vthis_command_keys); | |
| 3857 Vthis_command_keys = Qnil; | |
| 3858 Vthis_command_keys_tail = Qnil; | |
| 3859 } | |
| 3860 | |
| 3861 static void | |
| 3862 push_this_command_keys (Lisp_Object event) | |
| 3863 { | |
| 3025 | 3864 Lisp_Object new_ = Fmake_event (Qnil, Qnil); |
| 3865 | |
| 3866 Fcopy_event (event, new_); | |
| 3867 enqueue_event (new_, &Vthis_command_keys, &Vthis_command_keys_tail); | |
| 428 | 3868 } |
| 3869 | |
| 3870 /* The following two functions are used in call-interactively, | |
| 3871 for the @ and e specifications. We used to just use | |
| 3872 `current-mouse-event' (i.e. the last mouse event in this-command-keys), | |
| 3873 but FSF does it more generally so we follow their lead. */ | |
| 3874 | |
| 3875 Lisp_Object | |
| 3876 extract_this_command_keys_nth_mouse_event (int n) | |
| 3877 { | |
| 3878 Lisp_Object event; | |
| 3879 | |
| 3880 EVENT_CHAIN_LOOP (event, Vthis_command_keys) | |
| 3881 { | |
| 3882 if (EVENTP (event) | |
| 3883 && (XEVENT_TYPE (event) == button_press_event | |
| 3884 || XEVENT_TYPE (event) == button_release_event | |
| 3885 || XEVENT_TYPE (event) == misc_user_event)) | |
| 3886 { | |
| 3887 if (!n) | |
| 3888 { | |
| 2500 | 3889 /* must copy to avoid an ABORT() in next_event_internal() */ |
| 428 | 3890 if (!NILP (XEVENT_NEXT (event))) |
| 3891 return Fcopy_event (event, Qnil); | |
| 3892 else | |
| 3893 return event; | |
| 3894 } | |
| 3895 n--; | |
| 3896 } | |
| 3897 } | |
| 3898 | |
| 3899 return Qnil; | |
| 3900 } | |
| 3901 | |
| 3902 Lisp_Object | |
| 3903 extract_vector_nth_mouse_event (Lisp_Object vector, int n) | |
| 3904 { | |
| 3905 int i; | |
| 3906 int len = XVECTOR_LENGTH (vector); | |
| 3907 | |
| 3908 for (i = 0; i < len; i++) | |
| 3909 { | |
| 3910 Lisp_Object event = XVECTOR_DATA (vector)[i]; | |
| 3911 if (EVENTP (event)) | |
| 3912 switch (XEVENT_TYPE (event)) | |
| 3913 { | |
| 3914 case button_press_event : | |
| 3915 case button_release_event : | |
| 3916 case misc_user_event : | |
| 3917 if (n == 0) | |
| 3918 return event; | |
| 3919 n--; | |
| 3920 break; | |
| 3921 default: | |
| 3922 continue; | |
| 3923 } | |
| 3924 } | |
| 3925 | |
| 3926 return Qnil; | |
| 3927 } | |
| 3928 | |
| 3929 static void | |
| 3930 push_recent_keys (Lisp_Object event) | |
| 3931 { | |
| 3932 Lisp_Object e; | |
| 3933 | |
| 3934 if (NILP (Vrecent_keys_ring)) | |
| 3935 Vrecent_keys_ring = make_vector (recent_keys_ring_size, Qnil); | |
| 3936 | |
| 3937 e = XVECTOR_DATA (Vrecent_keys_ring) [recent_keys_ring_index]; | |
| 3938 | |
| 3939 if (NILP (e)) | |
| 3940 { | |
| 3941 e = Fmake_event (Qnil, Qnil); | |
| 3942 XVECTOR_DATA (Vrecent_keys_ring) [recent_keys_ring_index] = e; | |
| 3943 } | |
| 3944 Fcopy_event (event, e); | |
| 3945 if (++recent_keys_ring_index == recent_keys_ring_size) | |
| 3946 recent_keys_ring_index = 0; | |
| 3947 } | |
| 3948 | |
| 3949 | |
| 3950 static Lisp_Object | |
| 3951 current_events_into_vector (struct command_builder *command_builder) | |
| 3952 { | |
| 3953 Lisp_Object vector; | |
| 3954 Lisp_Object event; | |
| 3955 int n = event_chain_count (command_builder->current_events); | |
| 3956 | |
| 3957 /* Copy the vector and the events in it. */ | |
| 3958 /* No need to copy the events, since they're already copies, and | |
| 3959 nobody other than the command-builder has pointers to them */ | |
| 3960 vector = make_vector (n, Qnil); | |
| 3961 n = 0; | |
| 3962 EVENT_CHAIN_LOOP (event, command_builder->current_events) | |
| 3963 XVECTOR_DATA (vector)[n++] = event; | |
| 3964 reset_command_builder_event_chain (command_builder); | |
| 3965 return vector; | |
| 3966 } | |
| 3967 | |
| 3968 | |
| 3969 /* | |
| 3970 Given the current state of the command builder and a new command event | |
| 3971 that has just been dispatched: | |
| 3972 | |
| 3973 -- add the event to the event chain forming the current command | |
| 3974 (doing meta-translation as necessary) | |
| 3975 -- return the binding of this event chain; this will be one of: | |
| 3976 -- nil (there is no binding) | |
| 3977 -- a keymap (part of a command has been specified) | |
| 3978 -- a command (anything that satisfies `commandp'; this includes | |
| 3979 some symbols, lists, subrs, strings, vectors, and | |
| 3980 compiled-function objects) | |
| 3981 */ | |
| 3982 static Lisp_Object | |
| 3983 lookup_command_event (struct command_builder *command_builder, | |
| 3984 Lisp_Object event, int allow_misc_user_events_p) | |
| 3985 { | |
| 3986 /* This function can GC */ | |
| 3987 struct frame *f = selected_frame (); | |
| 3988 /* Clear output from previous command execution */ | |
| 3989 if (!EQ (Qcommand, echo_area_status (f)) | |
| 3990 /* but don't let mouse-up clear what mouse-down just printed */ | |
| 3991 && (XEVENT (event)->event_type != button_release_event)) | |
| 3992 clear_echo_area (f, Qnil, 0); | |
| 3993 | |
| 3994 /* Add the given event to the command builder. | |
| 3995 Extra hack: this also updates the recent_keys_ring and Vthis_command_keys | |
| 3996 vectors to translate "ESC x" to "M-x" (for any "x" of course). | |
| 3997 */ | |
| 3998 { | |
| 3999 Lisp_Object recent = command_builder->most_current_event; | |
| 4000 | |
| 4001 if (EVENTP (recent) | |
| 1204 | 4002 && event_matches_key_specifier_p (recent, Vmeta_prefix_char)) |
| 428 | 4003 { |
| 440 | 4004 Lisp_Event *e; |
| 428 | 4005 /* When we see a sequence like "ESC x", pretend we really saw "M-x". |
| 4006 DoubleThink the recent-keys and this-command-keys as well. */ | |
| 4007 | |
| 4008 /* Modify the previous most-recently-pushed event on the command | |
| 4009 builder to be a copy of this one with the meta-bit set instead of | |
| 4010 pushing a new event. | |
| 4011 */ | |
| 4012 Fcopy_event (event, recent); | |
| 4013 e = XEVENT (recent); | |
| 934 | 4014 if (EVENT_TYPE (e) == key_press_event) |
| 1204 | 4015 SET_EVENT_KEY_MODIFIERS (e, EVENT_KEY_MODIFIERS (e) | |
| 4016 XEMACS_MOD_META); | |
| 934 | 4017 else if (EVENT_TYPE (e) == button_press_event |
| 4018 || EVENT_TYPE (e) == button_release_event) | |
| 1204 | 4019 SET_EVENT_BUTTON_MODIFIERS (e, EVENT_BUTTON_MODIFIERS (e) | |
| 4020 XEMACS_MOD_META); | |
| 428 | 4021 else |
| 2500 | 4022 ABORT (); |
| 428 | 4023 |
| 4024 { | |
| 4025 int tckn = event_chain_count (Vthis_command_keys); | |
| 4026 if (tckn >= 2) | |
| 4027 /* ??? very strange if it's < 2. */ | |
| 4028 this_command_keys_replace_suffix | |
| 4029 (event_chain_nth (Vthis_command_keys, tckn - 2), | |
| 4030 Fcopy_event (recent, Qnil)); | |
| 4031 } | |
| 4032 | |
| 4033 regenerate_echo_keys_from_this_command_keys (command_builder); | |
| 4034 } | |
| 4035 else | |
| 771 | 4036 command_builder_append_event (command_builder, event); |
| 428 | 4037 } |
| 4038 | |
| 4039 { | |
| 771 | 4040 Lisp_Object leaf = |
| 4041 command_builder_find_leaf_and_update_global_state | |
| 4042 (command_builder, | |
| 4043 allow_misc_user_events_p); | |
| 428 | 4044 struct gcpro gcpro1; |
| 4045 GCPRO1 (leaf); | |
| 4046 | |
| 4047 if (KEYMAPP (leaf)) | |
| 4048 { | |
| 442 | 4049 #if defined (HAVE_X_WINDOWS) && defined (LWLIB_MENUBARS_LUCID) |
| 4050 if (!x_kludge_lw_menu_active ()) | |
| 4051 #else | |
| 4052 if (1) | |
| 4053 #endif | |
| 428 | 4054 { |
| 4055 Lisp_Object prompt = Fkeymap_prompt (leaf, Qt); | |
| 4056 if (STRINGP (prompt)) | |
| 4057 { | |
| 4058 /* Append keymap prompt to key echo buffer */ | |
| 4059 int buf_index = command_builder->echo_buf_index; | |
| 4060 Bytecount len = XSTRING_LENGTH (prompt); | |
| 4061 | |
| 4062 if (len + buf_index + 1 <= command_builder->echo_buf_length) | |
| 4063 { | |
| 867 | 4064 Ibyte *echo = command_builder->echo_buf + buf_index; |
| 428 | 4065 memcpy (echo, XSTRING_DATA (prompt), len); |
| 4066 echo[len] = 0; | |
| 4067 } | |
| 4068 maybe_echo_keys (command_builder, 1); | |
| 4069 } | |
| 4070 else | |
| 4071 maybe_echo_keys (command_builder, 0); | |
| 4072 } | |
| 853 | 4073 /* #### i don't trust this at all. --ben */ |
| 4074 #if 0 | |
| 442 | 4075 else if (!NILP (Vquit_flag)) |
| 4076 { | |
| 4077 /* if quit happened during menu acceleration, pretend we read it */ | |
| 4078 struct console *con = XCONSOLE (Fselected_console ()); | |
| 1204 | 4079 |
| 4080 enqueue_command_event (Fcopy_event (CONSOLE_QUIT_EVENT (con), | |
| 4081 Qnil)); | |
| 442 | 4082 Vquit_flag = Qnil; |
| 4083 } | |
| 853 | 4084 #endif |
| 428 | 4085 } |
| 4086 else if (!NILP (leaf)) | |
| 4087 { | |
| 4088 if (EQ (Qcommand, echo_area_status (f)) | |
| 4089 && command_builder->echo_buf_index > 0) | |
| 4090 { | |
| 4091 /* If we had been echoing keys, echo the last one (without | |
| 4092 the trailing dash) and redisplay before executing the | |
| 4093 command. */ | |
| 4094 command_builder->echo_buf[command_builder->echo_buf_index] = 0; | |
| 4095 maybe_echo_keys (command_builder, 1); | |
| 4096 Fsit_for (Qzero, Qt); | |
| 4097 } | |
| 4098 } | |
| 4099 RETURN_UNGCPRO (leaf); | |
| 4100 } | |
| 4101 } | |
| 4102 | |
| 479 | 4103 static int |
| 4932 | 4104 is_scrollbar_event (Lisp_Object USED_IF_SCROLLBARS (event)) |
| 479 | 4105 { |
| 516 | 4106 #ifdef HAVE_SCROLLBARS |
| 479 | 4107 Lisp_Object fun; |
| 4108 | |
| 934 | 4109 if (XEVENT_TYPE (event) != misc_user_event) |
| 4110 return 0; | |
| 1204 | 4111 fun = XEVENT_MISC_USER_FUNCTION (event); |
| 479 | 4112 |
| 4113 return (EQ (fun, Qscrollbar_line_up) || | |
| 4114 EQ (fun, Qscrollbar_line_down) || | |
| 4115 EQ (fun, Qscrollbar_page_up) || | |
| 4116 EQ (fun, Qscrollbar_page_down) || | |
| 4117 EQ (fun, Qscrollbar_to_top) || | |
| 4118 EQ (fun, Qscrollbar_to_bottom) || | |
| 4119 EQ (fun, Qscrollbar_vertical_drag) || | |
| 4120 EQ (fun, Qscrollbar_char_left) || | |
| 4121 EQ (fun, Qscrollbar_char_right) || | |
| 4122 EQ (fun, Qscrollbar_page_left) || | |
| 4123 EQ (fun, Qscrollbar_page_right) || | |
| 4124 EQ (fun, Qscrollbar_to_left) || | |
| 4125 EQ (fun, Qscrollbar_to_right) || | |
| 4126 EQ (fun, Qscrollbar_horizontal_drag)); | |
| 516 | 4127 #else |
| 4128 return 0; | |
| 4129 #endif /* HAVE_SCROLLBARS */ | |
| 479 | 4130 } |
| 4131 | |
| 428 | 4132 static void |
| 4133 execute_command_event (struct command_builder *command_builder, | |
| 4134 Lisp_Object event) | |
| 4135 { | |
| 4136 /* This function can GC */ | |
| 4137 struct console *con = XCONSOLE (command_builder->console); | |
| 4138 struct gcpro gcpro1; | |
| 4139 | |
| 4140 GCPRO1 (event); /* event may be freshly created */ | |
| 444 | 4141 |
| 479 | 4142 /* #### This call to is_scrollbar_event() isn't quite right, but |
| 4143 fixing properly it requires more work than can go into 21.4. | |
| 4144 (We really need to split out menu, scrollbar, dialog, and other | |
| 4145 types of events from misc-user, and put the remaining ones in a | |
| 4146 new `user-eval' type that behaves like an eval event but is a | |
| 4147 user event and thus has all of its semantics -- e.g. being | |
| 4148 delayed during `accept-process-output' and similar wait states.) | |
| 4149 | |
| 4150 The real issue here is that "user events" and "command events" | |
| 4151 are not the same thing, but are very much confused in | |
| 4152 event-stream.c. User events are, essentially, any event that | |
| 4153 should be delayed by accept-process-output, should terminate a | |
| 4154 sit-for, etc. -- basically, any event that needs to be processed | |
| 4155 synchronously with key and mouse events. Command events are | |
| 4156 those that participate in command building; scrollbar events | |
| 4157 clearly don't belong because they should be transparent in a | |
| 4158 sequence like C-x @ h <scrollbar-drag> x, which used to cause a | |
| 4159 crash before checks similar to the is_scrollbar_event() call were | |
| 4160 added. Do other events belong with scrollbar events? I'm not | |
| 4161 sure; we need to categorize all misc-user events and see what | |
| 4162 their semantics are. | |
| 4163 | |
| 4164 (You might ask, why do scrollbar events need to be user events? | |
| 4165 That's a good question. The answer seems to be that they can | |
| 4166 change point, and having this happen asynchronously would be a | |
| 4167 very bad idea. According to the "proper" functioning of | |
| 4168 scrollbars, this should not happen, but XEmacs does not allow | |
| 4169 point to go outside of the window.) | |
| 4170 | |
| 4171 Scrollbar events and similar non-command events should obviously | |
| 4172 not be recorded in this-command-keys, so we need to check for | |
| 4173 this in next-event. | |
| 4174 | |
| 4175 #### We call reset_current_events() twice in this function -- | |
| 4176 #### here, and later as a result of reset_this_command_keys(). | |
| 4177 #### This is almost certainly wrong; need to figure out what's | |
| 4178 #### correct. | |
| 4179 | |
| 4180 #### We need to figure out what's really correct w.r.t. scrollbar | |
| 4181 #### events. With these new fixes in, it actually works to do | |
| 4182 #### C-x <scrollbar-drag> 5 2, but the key echo gets messed up | |
| 4183 #### (starts over at 5). We really need to be special-casing | |
| 4184 #### scrollbar events at a lower level, and not really passing | |
| 4185 #### them through the command builder at all. (e.g. do scrollbar | |
| 4186 #### events belong in macros??? doubtful; probably only the | |
| 4187 #### point movement, if any, belongs, special-cased as a | |
| 4188 #### pseudo-issued M-x goto-char command). #### Need more work | |
| 4189 #### here. Do this when separating out scrollbar events. | |
| 4190 */ | |
| 4191 | |
| 4192 if (!is_scrollbar_event (event)) | |
| 444 | 4193 reset_current_events (command_builder); |
| 428 | 4194 |
| 4195 switch (XEVENT (event)->event_type) | |
| 4196 { | |
| 4197 case key_press_event: | |
| 4198 Vcurrent_mouse_event = Qnil; | |
| 4199 break; | |
| 4200 case button_press_event: | |
| 4201 case button_release_event: | |
| 4202 case misc_user_event: | |
| 4203 Vcurrent_mouse_event = Fcopy_event (event, Qnil); | |
| 4204 break; | |
| 4205 default: break; | |
| 4206 } | |
| 4207 | |
| 4208 /* Store the last-command-event. The semantics of this is that it | |
| 4209 is the last event most recently involved in command-lookup. */ | |
| 4210 if (!EVENTP (Vlast_command_event)) | |
| 4211 Vlast_command_event = Fmake_event (Qnil, Qnil); | |
| 4212 if (XEVENT (Vlast_command_event)->event_type == dead_event) | |
| 4213 { | |
| 4214 Vlast_command_event = Fmake_event (Qnil, Qnil); | |
| 563 | 4215 invalid_state ("Someone deallocated the last-command-event!", Qunbound); |
| 428 | 4216 } |
| 4217 | |
| 4218 if (! EQ (event, Vlast_command_event)) | |
| 4219 Fcopy_event (event, Vlast_command_event); | |
| 4220 | |
| 4221 /* Note that last-command-char will never have its high-bit set, in | |
| 4222 an effort to sidestep the ambiguity between M-x and oslash. */ | |
| 4223 Vlast_command_char = Fevent_to_character (Vlast_command_event, | |
| 2862 | 4224 Qnil, Qnil, Qnil); |
| 428 | 4225 |
| 4226 /* Actually call the command, with all sorts of hair to preserve or clear | |
| 4227 the echo-area and region as appropriate and call the pre- and post- | |
| 4228 command-hooks. */ | |
| 4229 { | |
| 4230 int old_kbd_macro = con->kbd_macro_end; | |
| 4231 struct window *w = XWINDOW (Fselected_window (Qnil)); | |
| 4232 | |
| 4233 /* We're executing a new command, so the old value is irrelevant. */ | |
| 4234 zmacs_region_stays = 0; | |
| 4235 | |
| 4236 /* If the previous command tried to force a specific window-start, | |
| 4237 reset the flag in case this command moves point far away from | |
| 4238 that position. Also, reset the window's buffer's change | |
| 4239 information so that we don't trigger an incremental update. */ | |
| 4240 if (w->force_start) | |
| 4241 { | |
| 4242 w->force_start = 0; | |
| 4243 buffer_reset_changes (XBUFFER (w->buffer)); | |
| 4244 } | |
| 4245 | |
| 4246 pre_command_hook (); | |
| 4247 | |
| 934 | 4248 if (XEVENT_TYPE (event) == misc_user_event) |
| 4249 { | |
| 1204 | 4250 call1 (XEVENT_MISC_USER_FUNCTION (event), |
| 4251 XEVENT_MISC_USER_OBJECT (event)); | |
| 934 | 4252 } |
| 428 | 4253 else |
| 4254 { | |
| 4255 Fcommand_execute (Vthis_command, Qnil, Qnil); | |
| 4256 } | |
| 4257 | |
| 4258 post_command_hook (); | |
| 4259 | |
| 757 | 4260 /* Console might have been deleted by command */ |
| 4261 if (CONSOLE_LIVE_P (con) && !NILP (con->prefix_arg)) | |
| 428 | 4262 { |
| 4263 /* Commands that set the prefix arg don't update last-command, don't | |
| 4264 reset the echoing state, and don't go into keyboard macros unless | |
| 444 | 4265 followed by another command. Also don't quit here. */ |
| 4266 int speccount = specpdl_depth (); | |
| 4267 specbind (Qinhibit_quit, Qt); | |
| 428 | 4268 maybe_echo_keys (command_builder, 0); |
| 771 | 4269 unbind_to (speccount); |
| 428 | 4270 |
| 4271 /* If we're recording a keyboard macro, and the last command | |
| 4272 executed set a prefix argument, then decrement the pointer to | |
| 4273 the "last character really in the macro" to be just before this | |
| 4274 command. This is so that the ^U in "^U ^X )" doesn't go onto | |
| 4275 the end of macro. */ | |
| 4276 if (!NILP (con->defining_kbd_macro)) | |
| 4277 con->kbd_macro_end = old_kbd_macro; | |
| 4278 } | |
| 4279 else | |
| 4280 { | |
| 4281 /* Start a new command next time */ | |
| 4282 Vlast_command = Vthis_command; | |
| 442 | 4283 Vlast_command_properties = Vthis_command_properties; |
| 4284 Vthis_command_properties = Qnil; | |
| 4285 | |
| 428 | 4286 /* Emacs 18 doesn't unconditionally clear the echoed keystrokes, |
| 4287 so we don't either */ | |
| 479 | 4288 |
| 4289 if (!is_scrollbar_event (event)) | |
| 771 | 4290 reset_this_command_keys (CONSOLE_LIVE_P (con) ? wrap_console (con) |
| 757 | 4291 : Qnil, 0); |
| 428 | 4292 } |
| 4293 } | |
| 4294 | |
| 4295 UNGCPRO; | |
| 4296 } | |
| 4297 | |
| 4298 /* Run the pre command hook. */ | |
| 4299 | |
| 4300 static void | |
| 4301 pre_command_hook (void) | |
| 4302 { | |
| 4303 last_point_position = BUF_PT (current_buffer); | |
| 793 | 4304 last_point_position_buffer = wrap_buffer (current_buffer); |
| 428 | 4305 /* This function can GC */ |
| 853 | 4306 safe_run_hook_trapping_problems |
| 1333 | 4307 (Qcommand, Qpre_command_hook, |
| 4308 INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION); | |
| 442 | 4309 |
| 4310 /* This is a kludge, but necessary; see simple.el */ | |
| 4311 call0 (Qhandle_pre_motion_command); | |
| 428 | 4312 } |
| 4313 | |
| 4314 /* Run the post command hook. */ | |
| 4315 | |
| 4316 static void | |
| 4317 post_command_hook (void) | |
| 4318 { | |
| 4319 /* This function can GC */ | |
| 4320 /* Turn off region highlighting unless this command requested that | |
| 4321 it be left on, or we're in the minibuffer. We don't turn it off | |
| 4322 when we're in the minibuffer so that things like M-x write-region | |
| 4323 still work! | |
| 4324 | |
| 4325 This could be done via a function on the post-command-hook, but | |
| 4326 we don't want the user to accidentally remove it. | |
| 4327 */ | |
| 4328 | |
| 4329 Lisp_Object win = Fselected_window (Qnil); | |
| 4330 | |
| 4331 /* If the last command deleted the frame, `win' might be nil. | |
| 4332 It seems safest to do nothing in this case. */ | |
| 442 | 4333 /* Note: Someone added the following comment and put #if 0's around |
| 4334 this code, not realizing that doing this invites a crash in the | |
| 4335 line after. */ | |
| 440 | 4336 /* #### This doesn't really fix the problem, |
| 428 | 4337 if delete-frame is called by some hook */ |
| 4338 if (NILP (win)) | |
| 4339 return; | |
| 442 | 4340 |
| 4341 /* This is a kludge, but necessary; see simple.el */ | |
| 4342 call0 (Qhandle_post_motion_command); | |
| 428 | 4343 |
| 4344 if (! zmacs_region_stays | |
| 4345 && (!MINI_WINDOW_P (XWINDOW (win)) | |
| 4346 || EQ (zmacs_region_buffer (), WINDOW_BUFFER (XWINDOW (win))))) | |
| 4347 zmacs_deactivate_region (); | |
| 4348 else | |
| 4349 zmacs_update_region (); | |
| 4350 | |
| 853 | 4351 safe_run_hook_trapping_problems |
| 1333 | 4352 (Qcommand, Qpost_command_hook, |
|
4718
a27de91ae83c
Don't prevent display objects from being deleted for `post-command-hook'.
Mike Sperber <sperber@deinprogramm.de>
parents:
4677
diff
changeset
|
4353 0); |
| 853 | 4354 |
| 4355 #if 0 /* FSF Emacs */ | |
| 4356 if (!NILP (current_buffer->mark_active)) | |
| 4357 { | |
| 4358 if (!NILP (Vdeactivate_mark) && !NILP (Vtransient_mark_mode)) | |
| 4359 { | |
| 4360 current_buffer->mark_active = Qnil; | |
| 4361 run_hook (intern ("deactivate-mark-hook")); | |
| 4362 } | |
| 4363 else if (current_buffer != prev_buffer || | |
| 4364 BUF_MODIFF (current_buffer) != prev_modiff) | |
| 4365 run_hook (intern ("activate-mark-hook")); | |
| 4366 } | |
| 4367 #endif /* FSF Emacs */ | |
| 428 | 4368 |
| 4369 /* #### Kludge!!! This is necessary to make sure that things | |
| 4370 are properly positioned even if post-command-hook moves point. | |
| 4371 #### There should be a cleaner way of handling this. */ | |
| 4372 call0 (Qauto_show_make_point_visible); | |
| 4373 } | |
| 4374 | |
| 4375 | |
| 4376 DEFUN ("dispatch-event", Fdispatch_event, 1, 1, 0, /* | |
| 444 | 4377 Given an event object EVENT as returned by `next-event', execute it. |
| 428 | 4378 |
| 4379 Key-press, button-press, and button-release events get accumulated | |
| 4380 until a complete key sequence (see `read-key-sequence') is reached, | |
| 4381 at which point the sequence is looked up in the current keymaps and | |
| 4382 acted upon. | |
| 4383 | |
| 4384 Mouse motion events cause the low-level handling function stored in | |
| 4385 `mouse-motion-handler' to be called. (There are very few circumstances | |
| 4386 under which you should change this handler. Use `mode-motion-hook' | |
| 4387 instead.) | |
| 4388 | |
| 4389 Menu, timeout, and eval events cause the associated function or handler | |
| 4390 to be called. | |
| 4391 | |
| 4392 Process events cause the subprocess's output to be read and acted upon | |
| 4393 appropriately (see `start-process'). | |
| 4394 | |
| 4395 Magic events are handled as necessary. | |
| 4396 */ | |
| 4397 (event)) | |
| 4398 { | |
| 4399 /* This function can GC */ | |
| 4400 struct command_builder *command_builder; | |
| 440 | 4401 Lisp_Event *ev; |
| 428 | 4402 Lisp_Object console; |
| 4403 Lisp_Object channel; | |
| 1292 | 4404 PROFILE_DECLARE (); |
| 428 | 4405 |
| 4406 CHECK_LIVE_EVENT (event); | |
| 4407 ev = XEVENT (event); | |
| 4408 | |
| 4409 /* events on dead channels get silently eaten */ | |
| 4410 channel = EVENT_CHANNEL (ev); | |
| 4411 if (object_dead_p (channel)) | |
| 4412 return Qnil; | |
| 4413 | |
| 1292 | 4414 PROFILE_RECORD_ENTERING_SECTION (Qdispatch_event); |
| 4415 | |
| 428 | 4416 /* Some events don't have channels (e.g. eval events). */ |
| 4417 console = CDFW_CONSOLE (channel); | |
| 4418 if (NILP (console)) | |
| 4419 console = Vselected_console; | |
| 4420 else if (!EQ (console, Vselected_console)) | |
| 4421 Fselect_console (console); | |
| 4422 | |
| 4423 command_builder = XCOMMAND_BUILDER (XCONSOLE (console)->command_builder); | |
| 934 | 4424 switch (XEVENT_TYPE (event)) |
| 428 | 4425 { |
| 4426 case button_press_event: | |
| 4427 case button_release_event: | |
| 4428 case key_press_event: | |
| 4429 { | |
| 4430 Lisp_Object leaf = lookup_command_event (command_builder, event, 1); | |
| 4431 | |
| 4432 if (KEYMAPP (leaf)) | |
| 4433 /* Incomplete key sequence */ | |
| 4434 break; | |
| 4435 if (NILP (leaf)) | |
| 4436 { | |
| 4437 /* At this point, we know that the sequence is not bound to a | |
| 4438 command. Normally, we beep and print a message informing the | |
| 4439 user of this. But we do not beep or print a message when: | |
| 4440 | |
| 4441 o the last event in this sequence is a mouse-up event; or | |
| 4442 o the last event in this sequence is a mouse-down event and | |
| 4443 there is a binding for the mouse-up version. | |
| 4444 | |
| 4445 That is, if the sequence ``C-x button1'' is typed, and is not | |
| 4446 bound to a command, but the sequence ``C-x button1up'' is bound | |
| 4447 to a command, we do not complain about the ``C-x button1'' | |
| 4448 sequence. If neither ``C-x button1'' nor ``C-x button1up'' is | |
| 4449 bound to a command, then we complain about the ``C-x button1'' | |
| 4450 sequence, but later will *not* complain about the | |
| 4451 ``C-x button1up'' sequence, which would be redundant. | |
| 4452 | |
| 4453 This is pretty hairy, but I think it's the most intuitive | |
| 4454 behavior. | |
| 4455 */ | |
| 4456 Lisp_Object terminal = command_builder->most_current_event; | |
| 4457 | |
| 4458 if (XEVENT_TYPE (terminal) == button_press_event) | |
| 4459 { | |
| 4460 int no_bitching; | |
| 4461 /* Temporarily pretend the last event was an "up" instead of a | |
| 4462 "down", and look up its binding. */ | |
| 4463 XEVENT_TYPE (terminal) = button_release_event; | |
| 4464 /* If the "up" version is bound, don't complain. */ | |
| 4465 no_bitching | |
| 771 | 4466 = !NILP (command_builder_find_leaf_and_update_global_state |
| 4467 (command_builder, 0)); | |
| 428 | 4468 /* Undo the temporary changes we just made. */ |
| 4469 XEVENT_TYPE (terminal) = button_press_event; | |
| 4470 if (no_bitching) | |
| 4471 { | |
| 4472 /* Pretend this press was not seen (treat as a prefix) */ | |
| 4473 if (EQ (command_builder->current_events, terminal)) | |
| 4474 { | |
| 4475 reset_current_events (command_builder); | |
| 4476 } | |
| 4477 else | |
| 4478 { | |
| 4479 Lisp_Object eve; | |
| 4480 | |
| 4481 EVENT_CHAIN_LOOP (eve, command_builder->current_events) | |
| 4482 if (EQ (XEVENT_NEXT (eve), terminal)) | |
| 4483 break; | |
| 4484 | |
| 4485 Fdeallocate_event (command_builder-> | |
| 4486 most_current_event); | |
| 4487 XSET_EVENT_NEXT (eve, Qnil); | |
| 4488 command_builder->most_current_event = eve; | |
| 4489 } | |
| 4490 maybe_echo_keys (command_builder, 1); | |
| 4491 break; | |
| 4492 } | |
| 4493 } | |
| 4494 | |
| 4495 /* Complain that the typed sequence is not defined, if this is the | |
| 4496 kind of sequence that warrants a complaint. */ | |
| 4497 XCONSOLE (console)->defining_kbd_macro = Qnil; | |
| 4498 XCONSOLE (console)->prefix_arg = Qnil; | |
| 4499 /* Don't complain about undefined button-release events */ | |
| 4500 if (XEVENT_TYPE (terminal) != button_release_event) | |
| 4501 { | |
| 4502 Lisp_Object keys = current_events_into_vector (command_builder); | |
| 4503 struct gcpro gcpro1; | |
| 4504 | |
| 4505 /* Run the pre-command-hook before barfing about an undefined | |
| 4506 key. */ | |
| 4507 Vthis_command = Qnil; | |
| 4508 GCPRO1 (keys); | |
| 4509 pre_command_hook (); | |
| 4510 UNGCPRO; | |
| 4511 /* The post-command-hook doesn't run. */ | |
| 4512 Fsignal (Qundefined_keystroke_sequence, list1 (keys)); | |
| 4513 } | |
| 4514 /* Reset the command builder for reading the next sequence. */ | |
| 4515 reset_this_command_keys (console, 1); | |
| 4516 } | |
| 4517 else /* key sequence is bound to a command */ | |
| 4518 { | |
| 430 | 4519 int magic_undo = 0; |
| 4520 int magic_undo_count = 20; | |
| 4521 | |
| 428 | 4522 Vthis_command = leaf; |
| 430 | 4523 |
| 428 | 4524 /* Don't push an undo boundary if the command set the prefix arg, |
| 4525 or if we are executing a keyboard macro, or if in the | |
| 4526 minibuffer. If the command we are about to execute is | |
| 4527 self-insert, it's tricky: up to 20 consecutive self-inserts may | |
| 4528 be done without an undo boundary. This counter is reset as | |
| 4529 soon as a command other than self-insert-command is executed. | |
| 430 | 4530 |
| 442 | 4531 Programmers can also use the `self-insert-defer-undo' |
| 4532 property to install that behavior on functions other | |
| 430 | 4533 than `self-insert-command', or to change the magic |
| 442 | 4534 number 20 to something else. #### DOCUMENT THIS! */ |
| 430 | 4535 |
| 4536 if (SYMBOLP (leaf)) | |
| 4537 { | |
| 4538 Lisp_Object prop = Fget (leaf, Qself_insert_defer_undo, Qnil); | |
| 4539 if (NATNUMP (prop)) | |
| 4540 magic_undo = 1, magic_undo_count = XINT (prop); | |
| 4541 else if (!NILP (prop)) | |
| 4542 magic_undo = 1; | |
| 4543 else if (EQ (leaf, Qself_insert_command)) | |
| 4544 magic_undo = 1; | |
| 4545 } | |
| 4546 | |
| 4547 if (!magic_undo) | |
| 428 | 4548 command_builder->self_insert_countdown = 0; |
| 4549 if (NILP (XCONSOLE (console)->prefix_arg) | |
| 4550 && NILP (Vexecuting_macro) | |
| 4551 && command_builder->self_insert_countdown == 0) | |
| 4552 Fundo_boundary (); | |
| 4553 | |
| 430 | 4554 if (magic_undo) |
| 428 | 4555 { |
| 4556 if (--command_builder->self_insert_countdown < 0) | |
| 430 | 4557 command_builder->self_insert_countdown = magic_undo_count; |
| 428 | 4558 } |
| 4559 execute_command_event | |
| 4560 (command_builder, | |
| 444 | 4561 internal_equal (event, command_builder->most_current_event, 0) |
| 428 | 4562 ? event |
| 4563 /* Use the translated event that was most recently seen. | |
| 4564 This way, last-command-event becomes f1 instead of | |
| 4565 the P from ESC O P. But we must copy it, else we'll | |
| 4566 lose when the command-builder events are deallocated. */ | |
| 444 | 4567 : Fcopy_event (command_builder->most_current_event, Qnil)); |
| 428 | 4568 } |
| 4569 break; | |
| 4570 } | |
| 4571 case misc_user_event: | |
| 4572 { | |
| 4573 /* Jamie said: | |
| 4574 | |
| 4575 We could just always use the menu item entry, whatever it is, but | |
| 4576 this might break some Lisp code that expects `this-command' to | |
| 4577 always contain a symbol. So only store it if this is a simple | |
| 4578 `call-interactively' sort of menu item. | |
| 4579 | |
| 4580 But this is bogus. `this-command' could be a string or vector | |
| 4581 anyway (for keyboard macros). There's even one instance | |
| 4582 (in pending-del.el) of `this-command' getting set to a cons | |
| 4583 (a lambda expression). So in the `eval' case I'll just | |
| 4584 convert it into a lambda expression. | |
| 4585 */ | |
| 1204 | 4586 if (EQ (XEVENT_MISC_USER_FUNCTION (event), Qcall_interactively) |
| 4587 && SYMBOLP (XEVENT_MISC_USER_OBJECT (event))) | |
| 4588 Vthis_command = XEVENT_MISC_USER_OBJECT (event); | |
| 4589 else if (EQ (XEVENT_MISC_USER_FUNCTION (event), Qeval)) | |
| 934 | 4590 Vthis_command = |
| 1204 | 4591 Fcons (Qlambda, Fcons (Qnil, XEVENT_MISC_USER_OBJECT (event))); |
| 4592 else if (SYMBOLP (XEVENT_MISC_USER_FUNCTION (event))) | |
| 934 | 4593 /* A scrollbar command or the like. */ |
| 1204 | 4594 Vthis_command = XEVENT_MISC_USER_FUNCTION (event); |
| 428 | 4595 else |
| 4596 /* Huh? */ | |
| 4597 Vthis_command = Qnil; | |
| 4598 | |
| 4599 /* clear the echo area */ | |
| 4600 reset_key_echo (command_builder, 1); | |
| 4601 | |
| 4602 command_builder->self_insert_countdown = 0; | |
| 4603 if (NILP (XCONSOLE (console)->prefix_arg) | |
| 4604 && NILP (Vexecuting_macro) | |
| 4605 && !EQ (minibuf_window, Fselected_window (Qnil))) | |
| 4606 Fundo_boundary (); | |
| 4607 execute_command_event (command_builder, event); | |
| 4608 break; | |
| 4609 } | |
| 4610 default: | |
| 4611 execute_internal_event (event); | |
| 4612 break; | |
| 4613 } | |
| 1292 | 4614 |
| 4615 PROFILE_RECORD_EXITING_SECTION (Qdispatch_event); | |
| 428 | 4616 return Qnil; |
| 4617 } | |
| 4618 | |
| 4619 DEFUN ("read-key-sequence", Fread_key_sequence, 1, 3, 0, /* | |
| 4620 Read a sequence of keystrokes or mouse clicks. | |
| 4621 Returns a vector of the event objects read. The vector and the event | |
| 444 | 4622 objects it contains are freshly created (and so will not be side-effected |
| 428 | 4623 by subsequent calls to this function). |
| 4624 | |
| 4625 The sequence read is sufficient to specify a non-prefix command starting | |
| 4626 from the current local and global keymaps. A C-g typed while in this | |
| 4627 function is treated like any other character, and `quit-flag' is not set. | |
| 4628 | |
| 4629 First arg PROMPT is a prompt string. If nil, do not prompt specially. | |
| 444 | 4630 |
| 4631 Second optional arg CONTINUE-ECHO non-nil means this key echoes as a | |
| 4632 continuation of the previous key. | |
| 4633 | |
| 4634 Third optional arg DONT-DOWNCASE-LAST non-nil means do not convert the | |
| 4635 last event to lower case. (Normally any upper case event is converted | |
| 4636 to lower case if the original event is undefined and the lower case | |
| 4637 equivalent is defined.) This argument is provided mostly for FSF | |
| 4638 compatibility; the equivalent effect can be achieved more generally by | |
| 4639 binding `retry-undefined-key-binding-unshifted' to nil around the call | |
| 4640 to `read-key-sequence'. | |
| 428 | 4641 |
| 4642 If the user selects a menu item while we are prompting for a key-sequence, | |
| 4643 the returned value will be a vector of a single menu-selection event. | |
| 4644 An error will be signalled if you pass this value to `lookup-key' or a | |
| 4645 related function. | |
| 4646 | |
| 4647 `read-key-sequence' checks `function-key-map' for function key | |
| 444 | 4648 sequences, where they wouldn't conflict with ordinary bindings. |
| 4649 See `function-key-map' for more details. | |
| 428 | 4650 */ |
| 4651 (prompt, continue_echo, dont_downcase_last)) | |
| 4652 { | |
| 4653 /* This function can GC */ | |
| 4654 struct console *con = XCONSOLE (Vselected_console); /* #### correct? | |
| 4655 Probably not -- see | |
| 4656 comment in | |
| 4657 next-event */ | |
| 4658 struct command_builder *command_builder = | |
| 4659 XCOMMAND_BUILDER (con->command_builder); | |
| 4660 Lisp_Object result; | |
| 4661 Lisp_Object event = Fmake_event (Qnil, Qnil); | |
| 4662 int speccount = specpdl_depth (); | |
| 4663 struct gcpro gcpro1; | |
| 4664 GCPRO1 (event); | |
| 4665 | |
| 707 | 4666 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); |
| 428 | 4667 if (!NILP (prompt)) |
| 4668 CHECK_STRING (prompt); | |
| 4669 /* else prompt = Fkeymap_prompt (current_buffer->keymap); may GC */ | |
| 4670 QUIT; | |
| 4671 | |
| 4672 if (NILP (continue_echo)) | |
| 771 | 4673 reset_this_command_keys (wrap_console (con), 1); |
| 428 | 4674 |
| 4675 if (!NILP (dont_downcase_last)) | |
| 4676 specbind (Qretry_undefined_key_binding_unshifted, Qnil); | |
| 4677 | |
| 4678 for (;;) | |
| 4679 { | |
| 4680 Fnext_event (event, prompt); | |
| 4681 /* restore the selected-console damage */ | |
| 4682 con = event_console_or_selected (event); | |
| 4683 command_builder = XCOMMAND_BUILDER (con->command_builder); | |
| 4684 if (! command_event_p (event)) | |
| 4685 execute_internal_event (event); | |
| 4686 else | |
| 4687 { | |
| 934 | 4688 if (XEVENT_TYPE (event) == misc_user_event) |
| 428 | 4689 reset_current_events (command_builder); |
| 4690 result = lookup_command_event (command_builder, event, 1); | |
| 4691 if (!KEYMAPP (result)) | |
| 4692 { | |
| 4693 result = current_events_into_vector (command_builder); | |
| 4694 reset_key_echo (command_builder, 0); | |
| 4695 break; | |
| 4696 } | |
| 4697 prompt = Qnil; | |
| 4698 } | |
| 4699 } | |
| 4700 | |
| 4701 Fdeallocate_event (event); | |
| 771 | 4702 RETURN_UNGCPRO (unbind_to_1 (speccount, result)); |
| 428 | 4703 } |
| 4704 | |
| 4705 DEFUN ("this-command-keys", Fthis_command_keys, 0, 0, 0, /* | |
| 4706 Return a vector of the keyboard or mouse button events that were used | |
| 4707 to invoke this command. This copies the vector and the events; it is safe | |
| 4708 to keep and modify them. | |
| 4709 */ | |
| 4710 ()) | |
| 4711 { | |
| 4712 Lisp_Object event; | |
| 4713 Lisp_Object result; | |
| 4714 int len; | |
| 4715 | |
| 4716 if (NILP (Vthis_command_keys)) | |
| 4717 return make_vector (0, Qnil); | |
| 4718 | |
| 4719 len = event_chain_count (Vthis_command_keys); | |
| 4720 | |
| 4721 result = make_vector (len, Qnil); | |
| 4722 len = 0; | |
| 4723 EVENT_CHAIN_LOOP (event, Vthis_command_keys) | |
| 4724 XVECTOR_DATA (result)[len++] = Fcopy_event (event, Qnil); | |
| 4725 return result; | |
| 4726 } | |
| 4727 | |
| 4728 DEFUN ("reset-this-command-lengths", Freset_this_command_lengths, 0, 0, 0, /* | |
| 4729 Used for complicated reasons in `universal-argument-other-key'. | |
| 4730 | |
| 4731 `universal-argument-other-key' rereads the event just typed. | |
| 4732 It then gets translated through `function-key-map'. | |
| 4733 The translated event gets included in the echo area and in | |
| 4734 the value of `this-command-keys' in addition to the raw original event. | |
| 4735 That is not right. | |
| 4736 | |
| 4737 Calling this function directs the translated event to replace | |
| 4738 the original event, so that only one version of the event actually | |
| 430 | 4739 appears in the echo area and in the value of `this-command-keys'. |
| 428 | 4740 */ |
| 4741 ()) | |
| 4742 { | |
| 4743 /* #### I don't understand this at all, so currently it does nothing. | |
| 4744 If there is ever a problem, maybe someone should investigate. */ | |
| 4745 return Qnil; | |
| 4746 } | |
| 4747 | |
| 4748 | |
| 4749 static void | |
| 4750 dribble_out_event (Lisp_Object event) | |
| 4751 { | |
| 4752 if (NILP (Vdribble_file)) | |
| 4753 return; | |
| 4754 | |
| 934 | 4755 if (XEVENT_TYPE (event) == key_press_event && |
| 1204 | 4756 !XEVENT_KEY_MODIFIERS (event)) |
| 934 | 4757 { |
| 1204 | 4758 Lisp_Object keysym = XEVENT_KEY_KEYSYM (event); |
| 4759 if (CHARP (XEVENT_KEY_KEYSYM (event))) | |
| 428 | 4760 { |
| 867 | 4761 Ichar ch = XCHAR (keysym); |
| 4762 Ibyte str[MAX_ICHAR_LEN]; | |
| 4763 Bytecount len = set_itext_ichar (str, ch); | |
| 428 | 4764 Lstream_write (XLSTREAM (Vdribble_file), str, len); |
| 4765 } | |
| 826 | 4766 else if (string_char_length (XSYMBOL (keysym)->name) == 1) |
| 428 | 4767 /* one-char key events are printed with just the key name */ |
| 4768 Fprinc (keysym, Vdribble_file); | |
| 4769 else if (EQ (keysym, Qreturn)) | |
| 4770 Lstream_putc (XLSTREAM (Vdribble_file), '\n'); | |
| 4771 else if (EQ (keysym, Qspace)) | |
| 4772 Lstream_putc (XLSTREAM (Vdribble_file), ' '); | |
| 4773 else | |
| 4774 Fprinc (event, Vdribble_file); | |
| 4775 } | |
| 4776 else | |
| 4777 Fprinc (event, Vdribble_file); | |
| 4778 Lstream_flush (XLSTREAM (Vdribble_file)); | |
| 4779 } | |
| 4780 | |
| 4781 DEFUN ("open-dribble-file", Fopen_dribble_file, 1, 1, | |
| 4782 "FOpen dribble file: ", /* | |
| 444 | 4783 Start writing all keyboard characters to a dribble file called FILENAME. |
| 4784 If FILENAME is nil, close any open dribble file. | |
| 428 | 4785 */ |
| 444 | 4786 (filename)) |
| 428 | 4787 { |
| 4788 /* This function can GC */ | |
| 4789 /* XEmacs change: always close existing dribble file. */ | |
| 4790 /* FSFmacs uses FILE *'s here. With lstreams, that's unnecessary. */ | |
| 4791 if (!NILP (Vdribble_file)) | |
| 4792 { | |
| 4793 Lstream_close (XLSTREAM (Vdribble_file)); | |
| 4794 Vdribble_file = Qnil; | |
| 4795 } | |
| 444 | 4796 if (!NILP (filename)) |
| 428 | 4797 { |
| 4798 int fd; | |
| 4799 | |
| 444 | 4800 filename = Fexpand_file_name (filename, Qnil); |
| 771 | 4801 fd = qxe_open (XSTRING_DATA (filename), |
| 4802 O_WRONLY | O_TRUNC | O_CREAT | OPEN_BINARY, | |
| 4803 CREAT_MODE); | |
| 428 | 4804 if (fd < 0) |
| 563 | 4805 report_file_error ("Unable to create dribble file", filename); |
| 428 | 4806 Vdribble_file = make_filedesc_output_stream (fd, 0, 0, LSTR_CLOSING); |
| 4807 #ifdef MULE | |
| 4808 Vdribble_file = | |
| 771 | 4809 make_coding_output_stream |
| 4810 (XLSTREAM (Vdribble_file), | |
| 800 | 4811 Qescape_quoted, CODING_ENCODE, 0); |
| 428 | 4812 #endif |
| 4813 } | |
| 4814 return Qnil; | |
| 4815 } | |
| 4816 | |
| 4817 | |
| 442 | 4818 |
| 4819 DEFUN ("current-event-timestamp", Fcurrent_event_timestamp, 0, 1, 0, /* | |
| 4820 Return the current event timestamp of the window system associated with CONSOLE. | |
| 4821 CONSOLE defaults to the selected console if omitted. | |
| 4822 */ | |
| 4823 (console)) | |
| 4824 { | |
| 4825 struct console *c = decode_console (console); | |
| 4826 int tiempo = event_stream_current_event_timestamp (c); | |
| 4827 | |
| 4828 /* This junk is so that timestamps don't get to be negative, but contain | |
| 4829 as many bits as this particular emacs will allow. | |
| 4830 */ | |
| 2039 | 4831 return make_int (EMACS_INT_MAX & tiempo); |
| 442 | 4832 } |
| 4833 | |
| 4834 | |
| 428 | 4835 /************************************************************************/ |
| 4836 /* initialization */ | |
| 4837 /************************************************************************/ | |
| 4838 | |
| 4839 void | |
| 4840 syms_of_event_stream (void) | |
| 4841 { | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
4842 INIT_LISP_OBJECT (command_builder); |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
4843 INIT_LISP_OBJECT (timeout); |
| 442 | 4844 |
| 563 | 4845 DEFSYMBOL (Qdisabled); |
| 4846 DEFSYMBOL (Qcommand_event_p); | |
| 4847 | |
| 4848 DEFERROR_STANDARD (Qundefined_keystroke_sequence, Qsyntax_error); | |
| 4849 DEFERROR_STANDARD (Qinvalid_key_binding, Qinvalid_state); | |
| 428 | 4850 |
| 4851 DEFSUBR (Frecent_keys); | |
| 4852 DEFSUBR (Frecent_keys_ring_size); | |
| 4853 DEFSUBR (Fset_recent_keys_ring_size); | |
| 4854 DEFSUBR (Finput_pending_p); | |
| 4855 DEFSUBR (Fenqueue_eval_event); | |
| 4856 DEFSUBR (Fnext_event); | |
| 4857 DEFSUBR (Fnext_command_event); | |
| 4858 DEFSUBR (Fdiscard_input); | |
| 4859 DEFSUBR (Fsit_for); | |
| 4860 DEFSUBR (Fsleep_for); | |
| 4861 DEFSUBR (Faccept_process_output); | |
| 4862 DEFSUBR (Fadd_timeout); | |
| 4863 DEFSUBR (Fdisable_timeout); | |
| 4864 DEFSUBR (Fadd_async_timeout); | |
| 4865 DEFSUBR (Fdisable_async_timeout); | |
| 4866 DEFSUBR (Fdispatch_event); | |
| 442 | 4867 DEFSUBR (Fdispatch_non_command_events); |
| 428 | 4868 DEFSUBR (Fread_key_sequence); |
| 4869 DEFSUBR (Fthis_command_keys); | |
| 4870 DEFSUBR (Freset_this_command_lengths); | |
| 4871 DEFSUBR (Fopen_dribble_file); | |
| 442 | 4872 DEFSUBR (Fcurrent_event_timestamp); |
| 428 | 4873 |
| 563 | 4874 DEFSYMBOL (Qpre_command_hook); |
| 4875 DEFSYMBOL (Qpost_command_hook); | |
| 4876 DEFSYMBOL (Qunread_command_events); | |
| 4877 DEFSYMBOL (Qunread_command_event); | |
| 4878 DEFSYMBOL (Qpre_idle_hook); | |
| 4879 DEFSYMBOL (Qhandle_pre_motion_command); | |
| 4880 DEFSYMBOL (Qhandle_post_motion_command); | |
| 4881 DEFSYMBOL (Qretry_undefined_key_binding_unshifted); | |
| 4882 DEFSYMBOL (Qauto_show_make_point_visible); | |
| 4883 | |
| 4884 DEFSYMBOL (Qself_insert_defer_undo); | |
| 4885 DEFSYMBOL (Qcancel_mode_internal); | |
| 1292 | 4886 |
| 4887 DEFSYMBOL (Qnext_event); | |
| 4888 DEFSYMBOL (Qdispatch_event); | |
| 428 | 4889 } |
| 4890 | |
| 4891 void | |
| 4892 reinit_vars_of_event_stream (void) | |
| 4893 { | |
| 4894 recent_keys_ring_index = 0; | |
| 4895 recent_keys_ring_size = 100; | |
| 4896 num_input_chars = 0; | |
| 4897 the_low_level_timeout_blocktype = | |
| 4898 Blocktype_new (struct low_level_timeout_blocktype); | |
| 4899 something_happened = 0; | |
| 1268 | 4900 recursive_sit_for = 0; |
| 4901 in_modal_loop = 0; | |
| 428 | 4902 } |
| 4903 | |
| 4904 void | |
| 4905 vars_of_event_stream (void) | |
| 4906 { | |
| 4907 Vrecent_keys_ring = Qnil; | |
| 4908 staticpro (&Vrecent_keys_ring); | |
| 4909 | |
| 4910 Vthis_command_keys = Qnil; | |
| 4911 staticpro (&Vthis_command_keys); | |
| 4912 Vthis_command_keys_tail = Qnil; | |
| 1204 | 4913 dump_add_root_lisp_object (&Vthis_command_keys_tail); |
| 428 | 4914 |
| 4915 command_event_queue = Qnil; | |
| 4916 staticpro (&command_event_queue); | |
| 4917 command_event_queue_tail = Qnil; | |
| 1204 | 4918 dump_add_root_lisp_object (&command_event_queue_tail); |
| 4919 | |
| 4920 dispatch_event_queue = Qnil; | |
| 4921 staticpro (&dispatch_event_queue); | |
| 4922 dispatch_event_queue_tail = Qnil; | |
| 4923 dump_add_root_lisp_object (&dispatch_event_queue_tail); | |
| 428 | 4924 |
| 4925 Vlast_selected_frame = Qnil; | |
| 4926 staticpro (&Vlast_selected_frame); | |
| 4927 | |
| 4928 pending_timeout_list = Qnil; | |
| 4929 staticpro (&pending_timeout_list); | |
| 4930 | |
| 4931 pending_async_timeout_list = Qnil; | |
| 4932 staticpro (&pending_async_timeout_list); | |
| 4933 | |
| 4934 last_point_position_buffer = Qnil; | |
| 4935 staticpro (&last_point_position_buffer); | |
| 4936 | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4932
diff
changeset
|
4937 QSnext_event_internal = build_ascstring ("next_event_internal()"); |
| 1292 | 4938 staticpro (&QSnext_event_internal); |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4932
diff
changeset
|
4939 QSexecute_internal_event = build_ascstring ("execute_internal_event()"); |
| 1292 | 4940 staticpro (&QSexecute_internal_event); |
| 4941 | |
| 428 | 4942 DEFVAR_LISP ("echo-keystrokes", &Vecho_keystrokes /* |
| 4943 *Nonzero means echo unfinished commands after this many seconds of pause. | |
| 4944 */ ); | |
| 4945 Vecho_keystrokes = make_int (1); | |
| 4946 | |
| 4947 DEFVAR_INT ("auto-save-interval", &auto_save_interval /* | |
| 4948 *Number of keyboard input characters between auto-saves. | |
| 4949 Zero means disable autosaving due to number of characters typed. | |
| 4950 See also the variable `auto-save-timeout'. | |
| 4951 */ ); | |
| 4952 auto_save_interval = 300; | |
| 4953 | |
| 4954 DEFVAR_LISP ("pre-command-hook", &Vpre_command_hook /* | |
| 4955 Function or functions to run before every command. | |
| 4956 This may examine the `this-command' variable to find out what command | |
| 4957 is about to be run, or may change it to cause a different command to run. | |
| 853 | 4958 Errors while running the hook are caught and turned into warnings. |
| 428 | 4959 */ ); |
| 4960 Vpre_command_hook = Qnil; | |
| 4961 | |
| 4962 DEFVAR_LISP ("post-command-hook", &Vpost_command_hook /* | |
| 4963 Function or functions to run after every command. | |
| 4964 This may examine the `this-command' variable to find out what command | |
| 4965 was just executed. | |
| 4966 */ ); | |
| 4967 Vpost_command_hook = Qnil; | |
| 4968 | |
| 4969 DEFVAR_LISP ("pre-idle-hook", &Vpre_idle_hook /* | |
| 4970 Normal hook run when XEmacs it about to be idle. | |
| 4971 This occurs whenever it is going to block, waiting for an event. | |
| 4972 This generally happens as a result of a call to `next-event', | |
| 4973 `next-command-event', `sit-for', `sleep-for', `accept-process-output', | |
| 853 | 4974 or `get-selection'. Errors while running the hook are caught and |
| 4975 turned into warnings. | |
| 428 | 4976 */ ); |
| 4977 Vpre_idle_hook = Qnil; | |
| 4978 | |
| 4979 DEFVAR_BOOL ("focus-follows-mouse", &focus_follows_mouse /* | |
| 4980 *Variable to control XEmacs behavior with respect to focus changing. | |
| 4981 If this variable is set to t, then XEmacs will not gratuitously change | |
| 4982 the keyboard focus. XEmacs cannot in general detect when this mode is | |
| 4983 used by the window manager, so it is up to the user to set it. | |
| 4984 */ ); | |
| 4985 focus_follows_mouse = 0; | |
| 4986 | |
| 4987 DEFVAR_LISP ("last-command-event", &Vlast_command_event /* | |
| 4988 Last keyboard or mouse button event that was part of a command. This | |
| 4989 variable is off limits: you may not set its value or modify the event that | |
| 4990 is its value, as it is destructively modified by `read-key-sequence'. If | |
| 4991 you want to keep a pointer to this value, you must use `copy-event'. | |
| 4992 */ ); | |
| 4993 Vlast_command_event = Qnil; | |
| 4994 | |
| 4995 DEFVAR_LISP ("last-command-char", &Vlast_command_char /* | |
| 4996 If the value of `last-command-event' is a keyboard event, then | |
| 4997 this is the nearest ASCII equivalent to it. This is the value that | |
| 4998 `self-insert-command' will put in the buffer. Remember that there is | |
| 4999 NOT a 1:1 mapping between keyboard events and ASCII characters: the set | |
| 5000 of keyboard events is much larger, so writing code that examines this | |
| 5001 variable to determine what key has been typed is bad practice, unless | |
| 5002 you are certain that it will be one of a small set of characters. | |
| 5003 */ ); | |
| 5004 Vlast_command_char = Qnil; | |
| 5005 | |
| 5006 DEFVAR_LISP ("last-input-event", &Vlast_input_event /* | |
| 5007 Last keyboard or mouse button event received. This variable is off | |
| 5008 limits: you may not set its value or modify the event that is its value, as | |
| 5009 it is destructively modified by `next-event'. If you want to keep a pointer | |
| 5010 to this value, you must use `copy-event'. | |
| 5011 */ ); | |
| 5012 Vlast_input_event = Qnil; | |
| 5013 | |
| 5014 DEFVAR_LISP ("current-mouse-event", &Vcurrent_mouse_event /* | |
| 5015 The mouse-button event which invoked this command, or nil. | |
| 5016 This is usually what `(interactive "e")' returns. | |
| 5017 */ ); | |
| 5018 Vcurrent_mouse_event = Qnil; | |
| 5019 | |
| 5020 DEFVAR_LISP ("last-input-char", &Vlast_input_char /* | |
| 5021 If the value of `last-input-event' is a keyboard event, then | |
| 5022 this is the nearest ASCII equivalent to it. Remember that there is | |
| 5023 NOT a 1:1 mapping between keyboard events and ASCII characters: the set | |
| 5024 of keyboard events is much larger, so writing code that examines this | |
| 5025 variable to determine what key has been typed is bad practice, unless | |
| 5026 you are certain that it will be one of a small set of characters. | |
| 5027 */ ); | |
| 5028 Vlast_input_char = Qnil; | |
| 5029 | |
| 5030 DEFVAR_LISP ("last-input-time", &Vlast_input_time /* | |
| 5031 The time (in seconds since Jan 1, 1970) of the last-command-event, | |
| 5032 represented as a cons of two 16-bit integers. This is destructively | |
| 5033 modified, so copy it if you want to keep it. | |
| 5034 */ ); | |
| 5035 Vlast_input_time = Qnil; | |
| 5036 | |
| 5037 DEFVAR_LISP ("last-command-event-time", &Vlast_command_event_time /* | |
| 5038 The time (in seconds since Jan 1, 1970) of the last-command-event, | |
| 5039 represented as a list of three integers. The first integer contains | |
| 5040 the most significant 16 bits of the number of seconds, and the second | |
| 5041 integer contains the least significant 16 bits. The third integer | |
| 5042 contains the remainder number of microseconds, if the current system | |
| 5043 supports microsecond clock resolution. This list is destructively | |
| 5044 modified, so copy it if you want to keep it. | |
| 5045 */ ); | |
| 5046 Vlast_command_event_time = Qnil; | |
| 5047 | |
| 5048 DEFVAR_LISP ("unread-command-events", &Vunread_command_events /* | |
| 5049 List of event objects to be read as next command input events. | |
| 5050 This can be used to simulate the receipt of events from the user. | |
| 5051 Normally this is nil. | |
| 5052 Events are removed from the front of this list. | |
| 5053 */ ); | |
| 5054 Vunread_command_events = Qnil; | |
| 5055 | |
| 5056 DEFVAR_LISP ("unread-command-event", &Vunread_command_event /* | |
| 5057 Obsolete. Use `unread-command-events' instead. | |
| 5058 */ ); | |
| 5059 Vunread_command_event = Qnil; | |
| 5060 | |
| 5061 DEFVAR_LISP ("last-command", &Vlast_command /* | |
| 5062 The last command executed. Normally a symbol with a function definition, | |
| 5063 but can be whatever was found in the keymap, or whatever the variable | |
| 5064 `this-command' was set to by that command. | |
| 5065 */ ); | |
| 5066 Vlast_command = Qnil; | |
| 5067 | |
| 5068 DEFVAR_LISP ("this-command", &Vthis_command /* | |
| 5069 The command now being executed. | |
| 5070 The command can set this variable; whatever is put here | |
| 5071 will be in `last-command' during the following command. | |
| 5072 */ ); | |
| 5073 Vthis_command = Qnil; | |
| 5074 | |
| 442 | 5075 DEFVAR_LISP ("last-command-properties", &Vlast_command_properties /* |
| 5076 Value of `this-command-properties' for the last command. | |
| 5077 Used by commands to help synchronize consecutive commands, in preference | |
| 5078 to looking at `last-command' directly. | |
| 5079 */ ); | |
| 5080 Vlast_command_properties = Qnil; | |
| 5081 | |
| 5082 DEFVAR_LISP ("this-command-properties", &Vthis_command_properties /* | |
| 5083 Properties set by the current command. | |
| 5084 At the beginning of each command, the current value of this variable is | |
| 5085 copied to `last-command-properties', and then it is set to nil. Use `putf' | |
| 5086 to add properties to this variable. Commands should use this to communicate | |
| 5087 with pre/post-command hooks, subsequent commands, wrapping commands, etc. | |
| 5088 in preference to looking at and/or setting `this-command'. | |
| 5089 */ ); | |
| 5090 Vthis_command_properties = Qnil; | |
| 5091 | |
| 428 | 5092 DEFVAR_LISP ("help-char", &Vhelp_char /* |
| 5093 Character to recognize as meaning Help. | |
| 5094 When it is read, do `(eval help-form)', and display result if it's a string. | |
| 5095 If the value of `help-form' is nil, this char can be read normally. | |
| 5096 This can be any form recognized as a single key specifier. | |
| 5097 The help-char cannot be a negative number in XEmacs. | |
| 5098 */ ); | |
| 5099 Vhelp_char = make_char (8); /* C-h */ | |
| 5100 | |
| 5101 DEFVAR_LISP ("help-form", &Vhelp_form /* | |
| 5102 Form to execute when character help-char is read. | |
| 5103 If the form returns a string, that string is displayed. | |
| 5104 If `help-form' is nil, the help char is not recognized. | |
| 5105 */ ); | |
| 5106 Vhelp_form = Qnil; | |
| 5107 | |
| 5108 DEFVAR_LISP ("prefix-help-command", &Vprefix_help_command /* | |
| 5109 Command to run when `help-char' character follows a prefix key. | |
| 5110 This command is used only when there is no actual binding | |
| 5111 for that character after that prefix key. | |
| 5112 */ ); | |
| 5113 Vprefix_help_command = Qnil; | |
| 5114 | |
| 5115 DEFVAR_CONST_LISP ("keyboard-translate-table", &Vkeyboard_translate_table /* | |
| 5116 Hash table used as translate table for keyboard input. | |
| 5117 Use `keyboard-translate' to portably add entries to this table. | |
| 5118 Each key-press event is looked up in this table as follows: | |
| 5119 | |
| 5120 -- If an entry maps a symbol to a symbol, then a key-press event whose | |
| 5121 keysym is the former symbol (with any modifiers at all) gets its | |
| 5122 keysym changed and its modifiers left alone. This is useful for | |
| 5123 dealing with non-standard X keyboards, such as the grievous damage | |
| 5124 that Sun has inflicted upon the world. | |
| 442 | 5125 -- If an entry maps a symbol to a character, then a key-press event |
| 5126 whose keysym is the former symbol (with any modifiers at all) gets | |
| 5127 changed into a key-press event matching the latter character, and the | |
| 5128 resulting modifiers are the union of the original and new modifiers. | |
| 428 | 5129 -- If an entry maps a character to a character, then a key-press event |
| 5130 matching the former character gets converted to a key-press event | |
| 5131 matching the latter character. This is useful on ASCII terminals | |
| 5132 for (e.g.) making C-\\ look like C-s, to get around flow-control | |
| 5133 problems. | |
| 5134 -- If an entry maps a character to a symbol, then a key-press event | |
| 5135 matching the character gets converted to a key-press event whose | |
| 5136 keysym is the given symbol and which has no modifiers. | |
| 442 | 5137 |
| 5138 Here's an example: This makes typing parens and braces easier by rerouting | |
| 5139 their positions to eliminate the need to use the Shift key. | |
| 5140 | |
| 5141 (keyboard-translate ?[ ?() | |
| 5142 (keyboard-translate ?] ?)) | |
| 5143 (keyboard-translate ?{ ?[) | |
| 5144 (keyboard-translate ?} ?]) | |
| 5145 (keyboard-translate 'f11 ?{) | |
| 5146 (keyboard-translate 'f12 ?}) | |
| 428 | 5147 */ ); |
| 5148 | |
| 5149 DEFVAR_LISP ("retry-undefined-key-binding-unshifted", | |
| 5150 &Vretry_undefined_key_binding_unshifted /* | |
| 5151 If a key-sequence which ends with a shifted keystroke is undefined | |
| 5152 and this variable is non-nil then the command lookup is retried again | |
| 5153 with the last key unshifted. (e.g. C-X C-F would be retried as C-X C-f.) | |
| 5154 If lookup still fails, a normal error is signalled. In general, | |
| 5155 you should *bind* this, not set it. | |
| 5156 */ ); | |
| 5157 Vretry_undefined_key_binding_unshifted = Qt; | |
| 5158 | |
| 442 | 5159 DEFVAR_BOOL ("modifier-keys-are-sticky", &modifier_keys_are_sticky /* |
| 5160 *Non-nil makes modifier keys sticky. | |
| 5161 This means that you can release the modifier key before pressing down | |
| 5162 the key that you wish to be modified. Although this is non-standard | |
| 5163 behavior, it is recommended because it reduces the strain on your hand, | |
| 5164 thus reducing the incidence of the dreaded Emacs-pinky syndrome. | |
| 444 | 5165 |
| 5166 Modifier keys are sticky within the inverval specified by | |
| 5167 `modifier-keys-sticky-time'. | |
| 442 | 5168 */ ); |
| 5169 modifier_keys_are_sticky = 0; | |
| 5170 | |
| 444 | 5171 DEFVAR_LISP ("modifier-keys-sticky-time", &Vmodifier_keys_sticky_time /* |
| 5172 *Modifier keys are sticky within this many milliseconds. | |
| 5173 If you don't want modifier keys sticking to be bounded, set this to | |
| 5174 non-integer value. | |
| 5175 | |
| 5176 This variable has no effect when `modifier-keys-are-sticky' is nil. | |
| 5177 Currently only implemented under X Window System. | |
| 5178 */ ); | |
| 5179 Vmodifier_keys_sticky_time = make_int (500); | |
| 5180 | |
| 428 | 5181 Vcontrolling_terminal = Qnil; |
| 5182 staticpro (&Vcontrolling_terminal); | |
| 5183 | |
| 5184 Vdribble_file = Qnil; | |
| 5185 staticpro (&Vdribble_file); | |
| 5186 | |
| 5187 #ifdef DEBUG_XEMACS | |
| 5188 DEFVAR_INT ("debug-emacs-events", &debug_emacs_events /* | |
| 5189 If non-zero, display debug information about Emacs events that XEmacs sees. | |
| 5190 Information is displayed on stderr. | |
| 5191 | |
| 5192 Before the event, the source of the event is displayed in parentheses, | |
| 5193 and is one of the following: | |
| 5194 | |
| 5195 \(real) A real event from the window system or | |
| 5196 terminal driver, as far as XEmacs can tell. | |
| 5197 | |
| 5198 \(keyboard macro) An event generated from a keyboard macro. | |
| 5199 | |
| 5200 \(unread-command-events) An event taken from `unread-command-events'. | |
| 5201 | |
| 5202 \(unread-command-event) An event taken from `unread-command-event'. | |
| 5203 | |
| 5204 \(command event queue) An event taken from an internal queue. | |
| 5205 Events end up on this queue when | |
| 5206 `enqueue-eval-event' is called or when | |
| 5207 user or eval events are received while | |
| 5208 XEmacs is blocking (e.g. in `sit-for', | |
| 5209 `sleep-for', or `accept-process-output', | |
| 5210 or while waiting for the reply to an | |
| 5211 X selection). | |
| 5212 | |
| 5213 \(->keyboard-translate-table) The result of an event translated through | |
| 5214 keyboard-translate-table. Note that in | |
| 5215 this case, two events are printed even | |
| 5216 though only one is really generated. | |
| 5217 | |
| 5218 \(SIGINT) A faked C-g resulting when XEmacs receives | |
| 5219 a SIGINT (e.g. C-c was pressed in XEmacs' | |
| 5220 controlling terminal or the signal was | |
| 5221 explicitly sent to the XEmacs process). | |
| 5222 */ ); | |
| 5223 debug_emacs_events = 0; | |
| 5224 #endif | |
| 5225 | |
| 2828 | 5226 DEFVAR_BOOL ("inhibit-input-event-recording", |
| 5227 &inhibit_input_event_recording /* | |
| 428 | 5228 Non-nil inhibits recording of input-events to recent-keys ring. |
| 5229 */ ); | |
| 5230 inhibit_input_event_recording = 0; | |
| 771 | 5231 |
| 428 | 5232 Vkeyboard_translate_table = |
| 5233 make_lisp_hash_table (100, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); | |
| 2828 | 5234 |
| 5235 DEFVAR_BOOL ("try-alternate-layouts-for-commands", | |
| 5236 &try_alternate_layouts_for_commands /* | |
| 5237 Non-nil means that if looking up a command from a sequence of keys typed by | |
| 5238 the user would otherwise fail, try it again with some other keyboard | |
| 5239 layout. On X11, the only alternative to the default mapping is American | |
| 5240 QWERTY; on Windows, other mappings may be available, depending on things | |
| 5241 like the default language environment for the current user, for the system, | |
| 5242 &c. | |
| 5243 | |
| 5244 With a Russian keyboard layout on X11, for example, this means that | |
| 5245 C-Cyrillic_che C-Cyrillic_a, if you haven't given that sequence a binding | |
| 5246 yourself, will invoke `find-file.' This is because `Cyrillic_che' is | |
| 5247 physically where `x' is, and `Cyrillic_a' is where `f' is, on an American | |
| 5248 Qwerty layout, and, of course, C-x C-f is a default emacs binding for that | |
| 5249 command. | |
| 5250 */ ); | |
| 5251 try_alternate_layouts_for_commands = 1; | |
| 428 | 5252 } |
| 5253 | |
| 5254 void | |
| 5255 init_event_stream (void) | |
| 5256 { | |
| 814 | 5257 /* Normally we don't initialize the event stream when running a bare |
| 5258 temacs (the check for initialized) because it may do various things | |
| 5259 (e.g. under Xt) that we don't want any traces of in a dumped xemacs. | |
| 5260 However, sometimes we need to process events in a bare temacs (in | |
| 5261 particular, when make-docfile.el is executed); so we initialize as | |
| 5262 necessary in check_event_stream_ok(). */ | |
| 428 | 5263 if (initialized) |
| 5264 { | |
| 5265 #ifdef HAVE_UNIXOID_EVENT_LOOP | |
| 5266 init_event_unixoid (); | |
| 5267 #endif | |
| 5268 #ifdef HAVE_X_WINDOWS | |
| 5269 if (!strcmp (display_use, "x")) | |
| 5270 init_event_Xt_late (); | |
| 5271 else | |
| 5272 #endif | |
| 462 | 5273 #ifdef HAVE_GTK |
| 5274 if (!strcmp (display_use, "gtk")) | |
| 5275 init_event_gtk_late (); | |
| 5276 else | |
| 5277 #endif | |
| 428 | 5278 #ifdef HAVE_MS_WINDOWS |
| 5279 if (!strcmp (display_use, "mswindows")) | |
| 5280 init_event_mswindows_late (); | |
| 5281 else | |
| 5282 #endif | |
| 5283 { | |
| 5284 /* For TTY's, use the Xt event loop if we can; it allows | |
| 5285 us to later open an X connection. */ | |
| 5286 #if defined (HAVE_MS_WINDOWS) && (!defined (HAVE_TTY) \ | |
| 5287 || (defined (HAVE_MSG_SELECT) \ | |
| 5288 && !defined (DEBUG_TTY_EVENT_STREAM))) | |
| 5289 init_event_mswindows_late (); | |
| 5290 #elif defined (HAVE_X_WINDOWS) && !defined (DEBUG_TTY_EVENT_STREAM) | |
| 5291 init_event_Xt_late (); | |
| 5292 #elif defined (HAVE_TTY) | |
| 5293 init_event_tty_late (); | |
| 5294 #endif | |
| 5295 } | |
| 5296 init_interrupts_late (); | |
| 5297 } | |
| 5298 } | |
| 5299 | |
| 5300 | |
| 5301 /* | |
| 853 | 5302 #### this comment is at least 8 years old and some may no longer apply. |
| 5303 | |
| 428 | 5304 useful testcases for v18/v19 compatibility: |
| 5305 | |
| 5306 (defun foo () | |
| 5307 (interactive) | |
| 5308 (setq unread-command-event (character-to-event ?A (allocate-event))) | |
| 5309 (setq x (list (read-char) | |
| 5310 ; (read-key-sequence "") ; try it with and without this | |
| 5311 last-command-char last-input-char | |
| 5312 (recent-keys) (this-command-keys)))) | |
| 5313 (global-set-key "\^Q" 'foo) | |
| 5314 | |
| 5315 without the read-key-sequence: | |
| 444 | 5316 ^Q ==> (?A ?\^Q ?A [... ^Q] [^Q]) |
| 5317 ^U^U^Q ==> (?A ?\^Q ?A [... ^U ^U ^Q] [^U ^U ^Q]) | |
| 5318 ^U^U^U^G^Q ==> (?A ?\^Q ?A [... ^U ^U ^U ^G ^Q] [^Q]) | |
| 428 | 5319 |
| 5320 with the read-key-sequence: | |
| 444 | 5321 ^Qb ==> (?A [b] ?\^Q ?b [... ^Q b] [b]) |
| 5322 ^U^U^Qb ==> (?A [b] ?\^Q ?b [... ^U ^U ^Q b] [b]) | |
| 5323 ^U^U^U^G^Qb ==> (?A [b] ?\^Q ?b [... ^U ^U ^U ^G ^Q b] [b]) | |
| 428 | 5324 |
| 5325 ;the evi-mode command "4dlj.j.j.j.j.j." is also a good testcase (gag) | |
| 5326 | |
| 5327 ;(setq x (list (read-char) quit-flag))^J^G | |
| 5328 ;(let ((inhibit-quit t)) (setq x (list (read-char) quit-flag)))^J^G | |
| 5329 ;for BOTH, x should get set to (7 t), but no result should be printed. | |
| 444 | 5330 ;; #### According to the doc of quit-flag, second test should return |
| 5331 ;; (?\^G nil). Accidentaly XEmacs returns correct value. However, | |
| 5332 ;; XEmacs 21.1.12 and 21.2.36 both fails on first test. | |
| 428 | 5333 |
| 5334 ;also do this: make two frames, one viewing "*scratch*", the other "foo". | |
| 5335 ;in *scratch*, type (sit-for 20)^J | |
| 5336 ;wait a couple of seconds, move cursor to foo, type "a" | |
| 5337 ;a should be inserted in foo. Cursor highlighting should not change in | |
| 5338 ;the meantime. | |
| 5339 | |
| 5340 ;do it with sleep-for. move cursor into foo, then back into *scratch* | |
| 5341 ;before typing. | |
| 5342 ;repeat also with (accept-process-output nil 20) | |
| 5343 | |
| 5344 ;make sure ^G aborts sit-for, sleep-for and accept-process-output: | |
| 5345 | |
| 5346 (defun tst () | |
| 5347 (list (condition-case c | |
| 5348 (sleep-for 20) | |
| 5349 (quit c)) | |
| 5350 (read-char))) | |
| 5351 | |
| 444 | 5352 (tst)^Ja^G ==> ((quit) ?a) with no signal |
| 5353 (tst)^J^Ga ==> ((quit) ?a) with no signal | |
| 5354 (tst)^Jabc^G ==> ((quit) ?a) with no signal, and "bc" inserted in buffer | |
| 428 | 5355 |
| 5356 ; with sit-for only do the 2nd test. | |
| 5357 ; Do all 3 tests with (accept-process-output nil 20) | |
| 5358 | |
| 5359 Do this: | |
| 5360 (setq enable-recursive-minibuffers t | |
| 5361 minibuffer-max-depth nil) | |
| 5362 ESC ESC ESC ESC - there are now two minibuffers active | |
| 5363 C-g C-g C-g - there should be active 0, not 1 | |
| 5364 Similarly: | |
| 5365 C-x C-f ~ / ? - wait for "Making completion list..." to display | |
| 5366 C-g - wait for "Quit" to display | |
| 5367 C-g - minibuffer should not be active | |
| 5368 however C-g before "Quit" is displayed should leave minibuffer active. | |
| 5369 | |
| 5370 ;do it all in both v18 and v19 and make sure all results are the same. | |
| 5371 ;all of these cases matter a lot, but some in quite subtle ways. | |
| 5372 */ | |
| 5373 | |
| 5374 /* | |
| 5375 Additional test cases for accept-process-output, sleep-for, sit-for. | |
| 5376 Be sure you do all of the above checking for C-g and focus, too! | |
| 5377 | |
| 5378 ; Make sure that timer handlers are run during, not after sit-for: | |
| 5379 (defun timer-check () | |
| 5380 (add-timeout 2 '(lambda (ignore) (message "timer ran")) nil) | |
| 5381 (sit-for 5) | |
| 5382 (message "after sit-for")) | |
| 5383 | |
| 5384 ; The first message should appear after 2 seconds, and the final message | |
| 5385 ; 3 seconds after that. | |
| 5386 ; repeat above test with (sleep-for 5) and (accept-process-output nil 5) | |
| 5387 | |
| 5388 | |
| 5389 | |
| 5390 ; Make sure that process filters are run during, not after sit-for. | |
| 5391 (defun fubar () | |
| 5392 (message "sit-for = %s" (sit-for 30))) | |
| 5393 (add-hook 'post-command-hook 'fubar) | |
| 5394 | |
| 5395 ; Now type M-x shell RET | |
| 5396 ; wait for the shell prompt then send: ls RET | |
| 5397 ; the output of ls should fill immediately, and not wait 30 seconds. | |
| 5398 | |
| 5399 ; repeat above test with (sleep-for 30) and (accept-process-output nil 30) | |
| 5400 | |
| 5401 | |
| 5402 | |
| 5403 ; Make sure that recursive invocations return immediately: | |
| 5404 (defmacro test-diff-time (start end) | |
| 5405 `(+ (* (- (car ,end) (car ,start)) 65536.0) | |
| 5406 (- (cadr ,end) (cadr ,start)) | |
| 5407 (/ (- (caddr ,end) (caddr ,start)) 1000000.0))) | |
| 5408 | |
| 5409 (defun testee (ignore) | |
| 5410 (sit-for 10)) | |
| 5411 | |
| 5412 (defun test-them () | |
| 5413 (let ((start (current-time)) | |
| 5414 end) | |
| 5415 (add-timeout 2 'testee nil) | |
| 5416 (sit-for 5) | |
| 5417 (add-timeout 2 'testee nil) | |
| 5418 (sleep-for 5) | |
| 5419 (add-timeout 2 'testee nil) | |
| 5420 (accept-process-output nil 5) | |
| 5421 (setq end (current-time)) | |
| 5422 (test-diff-time start end))) | |
| 5423 | |
| 5424 (test-them) should sit for 15 seconds. | |
| 5425 Repeat with testee set to sleep-for and accept-process-output. | |
| 5426 These should each delay 36 seconds. | |
| 5427 | |
| 5428 */ |