Mercurial > hg > xemacs-beta
diff src/event-stream.c @ 0:376386a54a3c r19-14
Import from CVS: tag r19-14
author | cvs |
---|---|
date | Mon, 13 Aug 2007 08:45:50 +0200 |
parents | |
children | ac2d302a0011 |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/event-stream.c Mon Aug 13 08:45:50 2007 +0200 @@ -0,0 +1,4477 @@ +/* The portable interface to event streams. + Copyright (C) 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. + Copyright (C) 1995 Board of Trustees, University of Illinois. + Copyright (C) 1995 Sun Microsystems, Inc. + Copyright (C) 1995, 1996 Ben Wing. + +This file is part of XEmacs. + +XEmacs is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +XEmacs is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with XEmacs; see the file COPYING. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* Synched up with: Not in FSF. */ + +/* This file has been Mule-ized. */ + +/* + * DANGER!! + * + * If you ever change ANYTHING in this file, you MUST run the + * testcases at the end to make sure that you haven't changed + * the semantics of recent-keys, last-input-char, or keyboard + * macros. You'd be surprised how easy it is to break this. + * + */ + +#include <config.h> +#include "lisp.h" + +#include "buffer.h" +#include "commands.h" +#include "device.h" +#include "elhash.h" +#include "events.h" +#include "frame.h" +#include "insdel.h" /* for buffer_reset_changes */ +#include "keymap.h" +#include "lstream.h" +#include "macros.h" /* for defining_keyboard_macro */ +#include "opaque.h" +#include "process.h" +#include "window.h" + +#include "sysdep.h" /* init_poll_for_quit() */ +#include "syssignal.h" /* SIGCHLD, etc. */ +#include "systime.h" /* to set Vlast_input_time */ + +#include <errno.h> + +/* The number of keystrokes between auto-saves. */ +static int auto_save_interval; + +Lisp_Object Qundefined_keystroke_sequence; + +Lisp_Object Qcommand_execute; + +Lisp_Object Qcommand_event_p; + +/* Hooks to run before and after each command. */ +Lisp_Object Vpre_command_hook, Vpost_command_hook; +Lisp_Object Qpre_command_hook, Qpost_command_hook; + +/* Hook run when XEmacs is about to be idle. */ +Lisp_Object Qpre_idle_hook, Vpre_idle_hook; + +#ifdef ILL_CONCEIVED_HOOK +/* Hook run after a command if there's no more input soon. */ +Lisp_Object Qpost_command_idle_hook, Vpost_command_idle_hook; + +/* Delay time in microseconds before running post-command-idle-hook. */ +int post_command_idle_delay; +#endif /* ILL_CONCEIVED_HOOK */ + +#ifdef DEFERRED_ACTION_CRAP +/* List of deferred actions to be performed at a later time. + The precise format isn't relevant here; we just check whether it is nil. */ +Lisp_Object Vdeferred_action_list; + +/* Function to call to handle deferred actions, when there are any. */ +Lisp_Object Vdeferred_action_function; +Lisp_Object Qdeferred_action_function; +#endif /* DEFERRED_ACTION_CRAP */ + +/* Non-nil disable property on a command means + do not execute it; call disabled-command-hook's value instead. */ +Lisp_Object Qdisabled, Vdisabled_command_hook; + +static void pre_command_hook (void); +static void post_command_hook (void); + +/* Last keyboard or mouse input event read as a command. */ +Lisp_Object Vlast_command_event; + +/* The nearest ASCII equivalent of the above. */ +Lisp_Object Vlast_command_char; + +/* Last keyboard or mouse event read for any purpose. */ +Lisp_Object Vlast_input_event; + +/* The nearest ASCII equivalent of the above. */ +Lisp_Object Vlast_input_char; + +Lisp_Object Vcurrent_mouse_event; + +/* If not Qnil, event objects to be read as the next command input */ +Lisp_Object Vunread_command_events; +Lisp_Object Vunread_command_event; /* obsoleteness support */ + +static Lisp_Object Qunread_command_events, Qunread_command_event; + +/* Previous command, represented by a Lisp object. + Does not include prefix commands and arg setting commands */ +Lisp_Object Vlast_command; + +/* If a command sets this, the value goes into + previous-command for the next command. */ +Lisp_Object Vthis_command; + +/* The value of point when the last command was executed. */ +Bufpos last_point_position; + +/* The frame that was current when the last command was started. */ +Lisp_Object Vlast_selected_frame; + +/* The buffer that was current when the last command was started. */ +Lisp_Object last_point_position_buffer; + +/* A (16bit . 16bit) representation of the time of the last-command-event. + */ +Lisp_Object Vlast_input_time; + +/* Character to recognize as the help char. */ +Lisp_Object Vhelp_char; + +/* Form to execute when help char is typed. */ +Lisp_Object Vhelp_form; + +/* Flag to tell QUIT that some interesting occurrence (e.g. a keypress) + may have happened. */ +volatile int something_happened; + +/* Command to run when the help character follows a prefix key. */ +Lisp_Object Vprefix_help_command; + +/* Hash table to translate keysyms through */ +Lisp_Object Vkeyboard_translate_table; + +/* If control-meta-super-shift-X is undefined, try control-meta-super-x */ +Lisp_Object Vretry_undefined_key_binding_unshifted; +Lisp_Object Qretry_undefined_key_binding_unshifted; + +/* Console that corresponds to our controlling terminal */ +Lisp_Object Vcontrolling_terminal; + +/* An event (actually an event chain linked through event_next) or Qnil. + */ +Lisp_Object Vthis_command_keys; +Lisp_Object Vthis_command_keys_tail; + +/* #### kludge! */ +Lisp_Object Qauto_show_make_point_visible; + +/* File in which we write all commands we read; an lstream */ +static Lisp_Object Vdribble_file; + +#ifdef DEBUG_XEMACS +int debug_emacs_events; +#endif + + +/* The callback routines for the window system or terminal driver */ +struct event_stream *event_stream; + +/* This structure is what we use to excapsulate the state of a command sequence + being composed; key events are executed by adding themselves to the command + builder; if the command builder is then complete (does not still represent + a prefix key sequence) it executes the corresponding command. + */ +struct command_builder +{ + struct lcrecord_header header; + Lisp_Object console; /* back pointer to the console this command + builder is for */ + /* Qnil, or a Lisp_Event representing the first event read + * after the last command completed. Threaded. */ + /* #### NYI */ + Lisp_Object prefix_events; + /* Qnil, or a Lisp_Event representing event in the current + * keymap-lookup sequence. Subsequent events are threaded via + * the event's next slot */ + Lisp_Object current_events; + /* Last elt of above */ + Lisp_Object most_current_event; + /* Last elt before function map code took over. + What this means is: All prefixes up to (but not including) + this event have non-nil bindings, but the prefix including + this event has a nil binding. Any events in the chain after + this one were read solely because we're part of a possible + function key. If we end up with something that's not part + of a possible function key, we have to unread all of those + events. */ + Lisp_Object last_non_munged_event; + /* One set of values for function-key-map, one for key-translation-map */ + struct munging_key_translation + { + /* First event that can begin a possible function key sequence + (to be translated according to function-key-map). Normally + this is the first event in the chain. However, once we've + translated a sequence through function-key-map, this will + point to the first event after the translated sequence: + we don't ever want to translate any events twice through + function-key-map, or things could get really screwed up + (e.g. if the user created a translation loop). If this + is nil, then the next-read event is the first that can + begin a function key sequence. */ + Lisp_Object first_mungeable_event; + } munge_me[2]; + + Bufbyte *echo_buf; + Bytecount echo_buf_length; /* size of echo_buf */ + Bytecount echo_buf_index; /* index into echo_buf + * -1 before doing echoing for new cmd */ + /* Self-insert-command is magic in that it doesn't always push an undo- + boundary: up to 20 consecutive self-inserts can happen before an undo- + boundary is pushed. This variable is that counter. + */ + int self_insert_countdown; +}; + +static void echo_key_event (struct command_builder *, Lisp_Object event); +static void maybe_kbd_translate (Lisp_Object event); + +/* This structure is basically a typeahead queue: things like + wait-reading-process-output will delay the execution of + keyboard and mouse events by pushing them here. + + Chained through event_next() + command_event_queue_tail is a pointer to the last-added element. + */ +static Lisp_Object command_event_queue; +static Lisp_Object command_event_queue_tail; + +/* Nonzero means echo unfinished commands after this many seconds of pause. */ +static int echo_keystrokes; + +/* The number of keystrokes since the last auto-save. */ +static int keystrokes_since_auto_save; + +/* Used by the C-g signal handler so that it will never "hard quit" + when waiting for an event. Otherwise holding down C-g could + cause a suspension back to the shell, which is generally + undesirable. (#### This doesn't fully work.) */ + +int emacs_is_blocking; + + +/**********************************************************************/ +/* Command-builder object */ +/**********************************************************************/ + +#define XCOMMAND_BUILDER(x) \ + XRECORD (x, command_builder, struct command_builder) +#define XSETCOMMAND_BUILDER(x, p) XSETRECORD (x, p, command_builder) +#define COMMAND_BUILDERP(x) RECORDP (x, command_builder) +#define GC_COMMAND_BUILDERP(x) GC_RECORDP (x, command_builder) +#define CHECK_COMMAND_BUILDER(x) CHECK_RECORD (x, command_builder) + +static Lisp_Object mark_command_builder (Lisp_Object obj, + void (*markobj) (Lisp_Object)); +static void finalize_command_builder (void *header, int for_disksave); +DEFINE_LRECORD_IMPLEMENTATION ("command-builder", command_builder, + mark_command_builder, internal_object_printer, + finalize_command_builder, 0, 0, + struct command_builder); + +static Lisp_Object +mark_command_builder (Lisp_Object obj, void (*markobj) (Lisp_Object)) +{ + struct command_builder *builder = XCOMMAND_BUILDER (obj); + (markobj) (builder->prefix_events); + (markobj) (builder->current_events); + (markobj) (builder->most_current_event); + (markobj) (builder->last_non_munged_event); + (markobj) (builder->munge_me[0].first_mungeable_event); + (markobj) (builder->munge_me[1].first_mungeable_event); + return builder->console; +} + +static void +finalize_command_builder (void *header, int for_disksave) +{ + struct command_builder *c = (struct command_builder *) header; + + if (!for_disksave) + { + xfree (c->echo_buf); + c->echo_buf = 0; + } +} + +static void +reset_command_builder_event_chain (struct command_builder *builder) +{ + builder->prefix_events = Qnil; + builder->current_events = Qnil; + builder->most_current_event = Qnil; + builder->last_non_munged_event = Qnil; + builder->munge_me[0].first_mungeable_event = Qnil; + builder->munge_me[1].first_mungeable_event = Qnil; +} + +Lisp_Object +allocate_command_builder (Lisp_Object console) +{ + Lisp_Object builder_obj = Qnil; + struct command_builder *builder = + alloc_lcrecord (sizeof (struct command_builder), + lrecord_command_builder); + + builder->console = console; + reset_command_builder_event_chain (builder); + builder->echo_buf_length = 300; /* #### Kludge */ + builder->echo_buf = + (Bufbyte *) xmalloc (builder->echo_buf_length); + builder->echo_buf[0] = 0; + builder->echo_buf_index = -1; + builder->echo_buf_index = -1; + builder->self_insert_countdown = 0; + + XSETCOMMAND_BUILDER (builder_obj, builder); + return builder_obj; +} + +static void +command_builder_append_event (struct command_builder *builder, + Lisp_Object event) +{ + assert (EVENTP (event)); + + if (EVENTP (builder->most_current_event)) + XSET_EVENT_NEXT (builder->most_current_event, event); + else + builder->current_events = event; + + builder->most_current_event = event; + if (NILP (builder->munge_me[0].first_mungeable_event)) + builder->munge_me[0].first_mungeable_event = event; + if (NILP (builder->munge_me[1].first_mungeable_event)) + builder->munge_me[1].first_mungeable_event = event; +} + + +/**********************************************************************/ +/* Low-level interfaces onto event methods */ +/**********************************************************************/ + +enum event_stream_operation +{ + EVENT_STREAM_PROCESS, + EVENT_STREAM_TIMEOUT, + EVENT_STREAM_CONSOLE, + EVENT_STREAM_READ +}; + +static void +check_event_stream_ok (enum event_stream_operation op) +{ + if (!event_stream && noninteractive) + { + switch (op) + { + case EVENT_STREAM_PROCESS: + error ("Can't start subprocesses in -batch mode"); + case EVENT_STREAM_TIMEOUT: + error ("Can't add timeouts in -batch mode"); + case EVENT_STREAM_CONSOLE: + error ("Can't add consoles in -batch mode"); + case EVENT_STREAM_READ: + error ("Can't read events in -batch mode"); + default: + abort (); + } + } + else if (!event_stream) + { + error ("event-stream callbacks not initialized (internal error?)"); + } +} + +int +event_stream_event_pending_p (int user) +{ + if (!event_stream) + return 0; + return event_stream->event_pending_p (user); +} + +static int +maybe_read_quit_event (struct Lisp_Event *event) +{ + /* A C-g that came from `sigint_happened' will always come from the + controlling terminal. If that doesn't exist, however, then the + user manually sent us a SIGINT, and we pretend the C-g came from + the selected console. */ + struct console *con; + + if (CONSOLEP (Vcontrolling_terminal) && + CONSOLE_LIVE_P (XCONSOLE (Vcontrolling_terminal))) + con = XCONSOLE (Vcontrolling_terminal); + else + con = XCONSOLE (Fselected_console ()); + + if (sigint_happened) + { + int ch = CONSOLE_QUIT_CHAR (con); + sigint_happened = 0; + Vquit_flag = Qnil; + character_to_event (ch, event, con, 1); + event->channel = make_console (con); + return 1; + } + return 0; +} + +void +event_stream_next_event (struct Lisp_Event *event) +{ + Lisp_Object event_obj = Qnil; + + check_event_stream_ok (EVENT_STREAM_READ); + + XSETEVENT (event_obj, event); + zero_event (event); + /* If C-g was pressed, treat it as a character to be read. + Note that if C-g was pressed while we were blocking, + the SIGINT signal handler will be called. It will + set Vquit_flag and write a byte on our "fake pipe", + which will unblock us. */ + if (maybe_read_quit_event (event)) + { +#ifdef DEBUG_XEMACS + if (debug_emacs_events) + { + write_c_string ("(SIGINT) ", + Qexternal_debugging_output); + print_internal (event_obj, Qexternal_debugging_output, 1); + write_c_string ("\n", Qexternal_debugging_output); + } +#endif + return; + } + + /* If a longjmp() happens in the callback, we're screwed. + Let's hope it doesn't. I think the code here is fairly + clean and doesn't do this. */ + emacs_is_blocking = 1; +#if 0 + /* Do this if the poll-for-quit timer seems to be taking too + much CPU time when idle ... */ + reset_poll_for_quit (); +#endif + event_stream->next_event_cb (event); +#if 0 + init_poll_for_quit (); +#endif + emacs_is_blocking = 0; + +#ifdef DEBUG_XEMACS + if (debug_emacs_events) + { + write_c_string ("(real) ", + Qexternal_debugging_output); + /* timeout events have more info set later, so + print the event out in next_event_internal(). */ + if (event->event_type != timeout_event) + { + print_internal (event_obj, Qexternal_debugging_output, 1); + write_c_string ("\n", Qexternal_debugging_output); + } + } +#endif + maybe_kbd_translate (event_obj); +} + +void +event_stream_handle_magic_event (struct Lisp_Event *event) +{ + check_event_stream_ok (EVENT_STREAM_READ); + event_stream->handle_magic_event_cb (event); +} + +static int +event_stream_add_timeout (EMACS_TIME timeout) +{ + check_event_stream_ok (EVENT_STREAM_TIMEOUT); + return event_stream->add_timeout_cb (timeout); +} + +static void +event_stream_remove_timeout (int id) +{ + check_event_stream_ok (EVENT_STREAM_TIMEOUT); + event_stream->remove_timeout_cb (id); +} + +void +event_stream_select_console (struct console *con) +{ + check_event_stream_ok (EVENT_STREAM_CONSOLE); + if (!con->input_enabled) + { + event_stream->select_console_cb (con); + con->input_enabled = 1; + } +} + +void +event_stream_unselect_console (struct console *con) +{ + check_event_stream_ok (EVENT_STREAM_CONSOLE); + if (con->input_enabled) + { + event_stream->unselect_console_cb (con); + con->input_enabled = 0; + } +} + +void +event_stream_select_process (struct Lisp_Process *proc) +{ + check_event_stream_ok (EVENT_STREAM_PROCESS); + if (!get_process_selected_p (proc)) + { + event_stream->select_process_cb (proc); + set_process_selected_p (proc, 1); + } +} + +void +event_stream_unselect_process (struct Lisp_Process *proc) +{ + check_event_stream_ok (EVENT_STREAM_PROCESS); + if (get_process_selected_p (proc)) + { + event_stream->unselect_process_cb (proc); + set_process_selected_p (proc, 0); + } +} + +void +event_stream_quit_p (void) +{ + if (event_stream) + event_stream->quit_p_cb (); +} + + + +/**********************************************************************/ +/* Character prompting */ +/**********************************************************************/ + +static void +echo_key_event (struct command_builder *command_builder, + Lisp_Object event) +{ + /* This function can GC */ + char buf[255]; + Bytecount buf_index = command_builder->echo_buf_index; + Bufbyte *e; + Bytecount len; + + if (buf_index < 0) + { + buf_index = 0; /* We're echoing now */ + clear_echo_area (selected_frame (), Qnil, 0); + } + + format_event_object (buf, XEVENT (event), 1); + len = strlen (buf); + + if (len + buf_index + 4 > command_builder->echo_buf_length) + return; + e = command_builder->echo_buf + buf_index; + memcpy (e, buf, len); + e += len; + + e[0] = ' '; + e[1] = '-'; + e[2] = ' '; + e[3] = 0; + + command_builder->echo_buf_index = buf_index + len + 1; +} + +static void +regenerate_echo_keys_from_this_command_keys (struct command_builder * + builder) +{ + Lisp_Object event; + + builder->echo_buf_index = 0; + + EVENT_CHAIN_LOOP (event, Vthis_command_keys) + echo_key_event (builder, event); +} + +static void +maybe_echo_keys (struct command_builder *command_builder, int no_snooze) +{ + /* This function can GC */ + struct frame *f = selected_frame (); + /* Message turns off echoing unless more keystrokes turn it on again. */ + if (echo_area_active (f) && !EQ (Qcommand, echo_area_status (f))) + return; + + if (minibuf_level == 0 + && echo_keystrokes > 0) + { + if (!no_snooze) + { + /* #### C-g here will cause QUIT. Setting dont_check_for_quit + doesn't work. See check_quit. */ + if (NILP (Fsit_for (make_int (echo_keystrokes), Qnil))) + /* input came in, so don't echo. */ + return; + } + + echo_area_message (f, command_builder->echo_buf, Qnil, 0, + /* not echo_buf_index. That doesn't include + the terminating " - ". */ + strlen ((char *) command_builder->echo_buf), + Qcommand); + } +} + +static void +reset_key_echo (struct command_builder *command_builder, + int remove_echo_area_echo) +{ + /* This function can GC */ + struct frame *f = selected_frame (); + + command_builder->echo_buf_index = -1; + + if (remove_echo_area_echo) + clear_echo_area (f, Qcommand, 0); +} + + +/**********************************************************************/ +/* random junk */ +/**********************************************************************/ + +static void +maybe_kbd_translate (Lisp_Object event) +{ + Emchar c; + int did_translate = 0; + + if (XEVENT_TYPE (event) != key_press_event) + return; + if (!HASHTABLEP (Vkeyboard_translate_table)) + return; + if (EQ (Fhashtable_fullness (Vkeyboard_translate_table), Qzero)) + return; + + c = event_to_character (XEVENT (event), 0, 0, 0); + if (c != -1) + { + Lisp_Object traduit = Fgethash (make_char (c), Vkeyboard_translate_table, + Qnil); + if (!NILP (traduit) && SYMBOLP (traduit)) + { + XEVENT (event)->event.key.keysym = traduit; + XEVENT (event)->event.key.modifiers = 0; + did_translate = 1; + } + else if (CHARP (traduit)) + { + struct Lisp_Event ev2; + + /* This used to call Fcharacter_to_event() directly into EVENT, + but that can eradicate timestamps and other such stuff. + This way is safer. */ + zero_event (&ev2); + character_to_event (XCHAR (traduit), &ev2, + XCONSOLE (EVENT_CHANNEL (XEVENT (event))), 1); + XEVENT (event)->event.key.keysym = ev2.event.key.keysym; + XEVENT (event)->event.key.modifiers = ev2.event.key.modifiers; + did_translate = 1; + } + } + + if (!did_translate) + { + Lisp_Object traduit = Fgethash (XEVENT (event)->event.key.keysym, + Vkeyboard_translate_table, Qnil); + if (!NILP (traduit) && SYMBOLP (traduit)) + { + XEVENT (event)->event.key.keysym = traduit; + did_translate = 1; + } + } + +#ifdef DEBUG_XEMACS + if (did_translate && debug_emacs_events) + { + write_c_string ("(->keyboard-translate-table) ", + Qexternal_debugging_output); + print_internal (event, Qexternal_debugging_output, 1); + write_c_string ("\n", Qexternal_debugging_output); + } +#endif +} + +/* NB: The following auto-save stuff is in keyboard.c in FSFmacs, and + keystrokes_since_auto_save is equivalent to the difference between + num_nonmacro_input_chars and last_auto_save. */ + +/* When an auto-save happens, record the "time", and don't do again soon. */ + +void +record_auto_save (void) +{ + keystrokes_since_auto_save = 0; +} + +/* Make an auto save happen as soon as possible at command level. */ + +void +force_auto_save_soon (void) +{ + keystrokes_since_auto_save = 1 + max (auto_save_interval, 20); + +#if 0 /* FSFmacs */ + record_asynch_buffer_change (); +#endif +} + +static void +maybe_do_auto_save (void) +{ + /* This function can GC */ + keystrokes_since_auto_save++; + if (auto_save_interval > 0 && + keystrokes_since_auto_save > max (auto_save_interval, 20) && + !detect_input_pending ()) + { + Fdo_auto_save (Qnil, Qnil); + record_auto_save (); + } +} + +static Lisp_Object +print_help (Lisp_Object object) +{ + Fprinc (object, Qnil); + return Qnil; +} + +static void +execute_help_form (struct command_builder *command_builder, + Lisp_Object event) +{ + /* This function can GC */ + Lisp_Object help = Qnil; + int speccount = specpdl_depth (); + Bytecount buf_index = command_builder->echo_buf_index; + Lisp_Object echo = ((buf_index <= 0) + ? Qnil + : make_string (command_builder->echo_buf, + buf_index)); + struct gcpro gcpro1, gcpro2; + GCPRO2 (echo, help); + + record_unwind_protect (save_window_excursion_unwind, + Fcurrent_window_configuration (Qnil)); + reset_key_echo (command_builder, 1); + + help = Feval (Vhelp_form); + if (STRINGP (help)) + internal_with_output_to_temp_buffer ("*Help*", + print_help, help, Qnil); + Fnext_command_event (event, Qnil); + /* Remove the help from the frame */ + unbind_to (speccount, Qnil); + /* Hmmmm. Tricky. The unbind restores an old window configuration, + apparently bypassing any setting of windows_structure_changed. + So we need to set it so that things get redrawn properly. */ + /* #### This is massive overkill. Look at doing it better once the + new redisplay is fully in place. */ + { + Lisp_Object frmcons, devcons, concons; + FRAME_LOOP_NO_BREAK (frmcons, devcons, concons) + { + MARK_FRAME_WINDOWS_STRUCTURE_CHANGED (XFRAME (XCAR (frmcons))); + } + } + + redisplay (); + if (event_matches_key_specifier_p (XEVENT (event), make_char (' '))) + { + /* Discard next key if is is a space */ + reset_key_echo (command_builder, 1); + Fnext_command_event (event, Qnil); + } + + command_builder->echo_buf_index = buf_index; + if (buf_index > 0) + memcpy (command_builder->echo_buf, + string_data (XSTRING (echo)), buf_index + 1); /* terminating 0 */ + UNGCPRO; +} + + +/**********************************************************************/ +/* input pending */ +/**********************************************************************/ + +int +detect_input_pending (void) +{ + /* Always call the event_pending_p hook even if there's an unread + character, because that might do some needed ^G detection (on + systems without SIGIO, for example). + */ + if (event_stream_event_pending_p (1)) + return 1; + if (!NILP (Vunread_command_events) || !NILP (Vunread_command_event)) + return 1; + if (!NILP (command_event_queue)) + { + Lisp_Object event; + + EVENT_CHAIN_LOOP (event, command_event_queue) + { + if (XEVENT_TYPE (event) != eval_event + && XEVENT_TYPE (event) != magic_eval_event) + return (1); + } + } + return 0; +} + +DEFUN ("input-pending-p", Finput_pending_p, Sinput_pending_p, 0, 0, 0 /* +T if command input is currently available with no waiting. +Actually, the value is nil only if we can be sure that no input is available. +*/ ) + () +{ + return ((detect_input_pending ()) ? Qt : Qnil); +} + + +/**********************************************************************/ +/* timeouts */ +/**********************************************************************/ + +/**** Low-level timeout functions. **** + + These functions maintain a sorted list of one-shot timeouts (where + the timeouts are in absolute time). They are intended for use by + functions that need to convert a list of absolute timeouts into a + series of intervals to wait for. */ + +/* We ensure that 0 is never a valid ID, so that a value of 0 can be + used to indicate an absence of a timer. */ +static int low_level_timeout_id_tick; + +struct low_level_timeout_blocktype +{ + Blocktype_declare (struct low_level_timeout); +} *the_low_level_timeout_blocktype; + +/* Add a one-shot timeout at time TIME to TIMEOUT_LIST. Return + a unique ID identifying the timeout. */ + +int +add_low_level_timeout (struct low_level_timeout **timeout_list, + EMACS_TIME thyme) +{ + struct low_level_timeout *tm; + struct low_level_timeout *t, **tt; + + /* Allocate a new time struct. */ + + tm = Blocktype_alloc (the_low_level_timeout_blocktype); + tm->next = NULL; + if (low_level_timeout_id_tick == 0) + low_level_timeout_id_tick++; + tm->id = low_level_timeout_id_tick++; + tm->time = thyme; + + /* Add it to the queue. */ + + tt = timeout_list; + t = *tt; + while (t && EMACS_TIME_EQUAL_OR_GREATER (tm->time, t->time)) + { + tt = &t->next; + t = *tt; + } + tm->next = t; + *tt = tm; + + return tm->id; +} + +/* Remove the low-level timeout identified by ID from TIMEOUT_LIST. + If the timeout is not there, do nothing. */ + +void +remove_low_level_timeout (struct low_level_timeout **timeout_list, int id) +{ + struct low_level_timeout *t, *prev; + + /* find it */ + + for (t = *timeout_list, prev = NULL; t && t->id != id; t = t->next) + prev = t; + + if (!t) + return; /* couldn't find it */ + + if (!prev) + *timeout_list = t->next; + else prev->next = t->next; + + Blocktype_free (the_low_level_timeout_blocktype, t); +} + +/* If there are timeouts on TIMEOUT_LIST, store the relative time + interval to the first timeout on the list into INTERVAL and + return 1. Otherwise, return 0. */ + +int +get_low_level_timeout_interval (struct low_level_timeout *timeout_list, + EMACS_TIME *interval) +{ + if (!timeout_list) /* no timer events; block indefinitely */ + return 0; + else + { + EMACS_TIME current_time; + + /* The time to block is the difference between the first + (earliest) timer on the queue and the current time. + If that is negative, then the timer will fire immediately + but we still have to call select(), with a zero-valued + timeout: user events must have precedence over timer events. */ + EMACS_GET_TIME (current_time); + if (EMACS_TIME_GREATER (timeout_list->time, current_time)) + EMACS_SUB_TIME (*interval, timeout_list->time, + current_time); + else + EMACS_SET_SECS_USECS (*interval, 0, 0); + return 1; + } +} + +/* Pop the first (i.e. soonest) timeout off of TIMEOUT_LIST and return + its ID. Also, if TIME_OUT is not 0, store the absolute time of the + timeout into TIME_OUT. */ + +int +pop_low_level_timeout (struct low_level_timeout **timeout_list, + EMACS_TIME *time_out) +{ + struct low_level_timeout *tm = *timeout_list; + int id; + + assert (tm); + id = tm->id; + if (time_out) + *time_out = tm->time; + *timeout_list = tm->next; + Blocktype_free (the_low_level_timeout_blocktype, tm); + return id; +} + + +/**** High-level timeout functions. ****/ + +static int timeout_id_tick; + +/* Since timeout structures contain Lisp_Objects, they need to be GC'd + properly. The opaque data type provides a convenient way of doing + this without having to create a new Lisp object, since we can + provide our own mark function. */ + +struct timeout +{ + int id; /* Id we use to identify the timeout over its lifetime */ + int interval_id; /* Id for this particular interval; this may + be different each time the timeout is + signalled.*/ + Lisp_Object function, object; /* Function and object associated + with timeout. */ + EMACS_TIME next_signal_time; /* Absolute time when the timeout + is next going to be signalled. */ + unsigned int resignal_msecs; /* How far after the next timeout + should the one after that + occur? */ +}; + +static Lisp_Object pending_timeout_list, pending_async_timeout_list; + +static Lisp_Object Vtimeout_free_list; + +static Lisp_Object +mark_timeout (Lisp_Object obj, void (*markobj) (Lisp_Object)) +{ + struct timeout *tm = (struct timeout *) XOPAQUE_DATA (obj); + (markobj) (tm->function); + return tm->object; +} + +/* Generate a timeout and return its ID. */ + +int +event_stream_generate_wakeup (unsigned int milliseconds, + unsigned int vanilliseconds, + Lisp_Object function, Lisp_Object object, + int async_p) +{ + Lisp_Object op = allocate_managed_opaque (Vtimeout_free_list, 0); + struct timeout *timeout = (struct timeout *) XOPAQUE_DATA (op); + EMACS_TIME current_time; + EMACS_TIME interval; + + timeout->id = timeout_id_tick++; + timeout->resignal_msecs = vanilliseconds; + timeout->function = function; + timeout->object = object; + + EMACS_GET_TIME (current_time); + EMACS_SET_SECS_USECS (interval, milliseconds / 1000, + 1000 * (milliseconds % 1000)); + EMACS_ADD_TIME (timeout->next_signal_time, current_time, interval); + + if (async_p) + { + timeout->interval_id = + event_stream_add_async_timeout (timeout->next_signal_time); + pending_async_timeout_list = noseeum_cons (op, + pending_async_timeout_list); + } + else + { + timeout->interval_id = + event_stream_add_timeout (timeout->next_signal_time); + pending_timeout_list = noseeum_cons (op, pending_timeout_list); + } + return timeout->id; +} + +/* Given the INTERVAL-ID of a timeout just signalled, resignal the timeout + as necessary and return the timeout's ID and function and object slots. + + This should be called as a result of receiving notice that a timeout + has fired. INTERVAL-ID is *not* the timeout's ID, but is the ID that + identifies this particular firing of the timeout. INTERVAL-ID's and + timeout ID's are in separate number spaces and bear no relation to + each other. The INTERVAL-ID is all that the event callback routines + work with: they work only with one-shot intervals, not with timeouts + that may fire repeatedly. + + NOTE: The returned FUNCTION and OBJECT are *not* GC-protected at all. +*/ + +static int +event_stream_resignal_wakeup (int interval_id, int async_p, + Lisp_Object *function, Lisp_Object *object) +{ + Lisp_Object op = Qnil, rest; + struct timeout *timeout; + Lisp_Object *timeout_list; + struct gcpro gcpro1; + int id; + + GCPRO1 (op); /* just in case ... because it's removed from the list + for awhile. */ + + if (async_p) + timeout_list = &pending_async_timeout_list; + else + timeout_list = &pending_timeout_list; + + /* Find the timeout on the list of pending ones. */ + LIST_LOOP (rest, *timeout_list) + { + timeout = (struct timeout *) XOPAQUE_DATA (XCAR (rest)); + if (timeout->interval_id == interval_id) + break; + } + + assert (!NILP (rest)); + op = XCAR (rest); + timeout = (struct timeout *) XOPAQUE_DATA (op); + /* We make sure to snarf the data out of the timeout object before + we free it with free_managed_opaque(). */ + id = timeout->id; + *function = timeout->function; + *object = timeout->object; + + /* Remove this one from the list of pending timeouts */ + *timeout_list = delq_no_quit_and_free_cons (op, *timeout_list); + + /* If this timeout wants to be resignalled, do it now. */ + if (timeout->resignal_msecs) + { + EMACS_TIME current_time; + EMACS_TIME interval; + + /* Determine the time that the next resignalling should occur. + We do that by adding the interval time to the last signalled + time until we get a time that's current. + + (This way, it doesn't matter if the timeout was signalled + exactly when we asked for it, or at some time later.) + */ + EMACS_GET_TIME (current_time); + EMACS_SET_SECS_USECS (interval, timeout->resignal_msecs / 1000, + 1000 * (timeout->resignal_msecs % 1000)); + do + { + EMACS_ADD_TIME (timeout->next_signal_time, timeout->next_signal_time, + interval); + } while (EMACS_TIME_GREATER (current_time, timeout->next_signal_time)); + + if (async_p) + timeout->interval_id = + event_stream_add_async_timeout (timeout->next_signal_time); + else + timeout->interval_id = + event_stream_add_timeout (timeout->next_signal_time); + /* Add back onto the list. Note that the effect of this + is to move frequently-hit timeouts to the front of the + list, which is a good thing. */ + *timeout_list = noseeum_cons (op, *timeout_list); + } + else + free_managed_opaque (Vtimeout_free_list, op); + + UNGCPRO; + return id; +} + +void +event_stream_disable_wakeup (int id, int async_p) +{ + struct timeout *timeout = 0; + Lisp_Object rest = Qnil; + Lisp_Object *timeout_list; + + if (async_p) + timeout_list = &pending_async_timeout_list; + else + timeout_list = &pending_timeout_list; + + /* Find the timeout on the list of pending ones, if it's still there. */ + LIST_LOOP (rest, *timeout_list) + { + timeout = (struct timeout *) XOPAQUE_DATA (XCAR (rest)); + if (timeout->id == id) + break; + } + + /* If we found it, remove it from the list and disable the pending + one-shot. */ + if (!NILP (rest)) + { + Lisp_Object op = XCAR (rest); + *timeout_list = + delq_no_quit_and_free_cons (op, *timeout_list); + if (async_p) + event_stream_remove_async_timeout (timeout->interval_id); + else + event_stream_remove_timeout (timeout->interval_id); + free_managed_opaque (Vtimeout_free_list, op); + } +} + + +/**** Asynch. timeout functions (see also signal.c) ****/ + +#if !defined (SIGIO) && !defined (DONT_POLL_FOR_QUIT) +extern int poll_for_quit_id; +#endif + +#ifndef SIGCHLD +extern int poll_for_sigchld_id; +#endif + +void +event_stream_deal_with_async_timeout (int interval_id) +{ + /* This function can GC */ + Lisp_Object humpty, dumpty; +#if (!defined (SIGIO) && !defined (DONT_POLL_FOR_QUIT)) || !defined (SIGCHLD) + int id = +#endif + event_stream_resignal_wakeup (interval_id, 1, &humpty, &dumpty); + +#if !defined (SIGIO) && !defined (DONT_POLL_FOR_QUIT) + if (id == poll_for_quit_id) + { + quit_check_signal_happened = 1; + quit_check_signal_tick_count++; + return; + } +#endif + +#if !defined (SIGCHLD) + if (id == poll_for_sigchld_id) + { + kick_status_notify (); + return; + } +#endif + + /* call1 GC-protects its arguments */ + call1_trapping_errors ("Error in asynchronous timeout callback", + humpty, dumpty); +} + + +/**** Lisp-level timeout functions. ****/ + +static unsigned long +lisp_number_to_milliseconds (Lisp_Object secs, int allow_0) +{ + unsigned long msecs; +#ifdef LISP_FLOAT_TYPE + double fsecs; + CHECK_INT_OR_FLOAT (secs); + fsecs = XFLOATINT (secs); +#else + long fsecs; + CHECK_INT_OR_FLOAT (secs); + fsecs = XINT (secs); +#endif + msecs = 1000 * fsecs; + if (fsecs < 0) + signal_simple_error ("timeout is negative", secs); + if (!allow_0 && fsecs == 0) + signal_simple_error ("timeout is non-positive", secs); + if (fsecs >= (((unsigned int) 0xFFFFFFFF) / 1000)) + signal_simple_error + ("timeout would exceed 32 bits when represented in milliseconds", secs); + return msecs; +} + +DEFUN ("add-timeout", Fadd_timeout, Sadd_timeout, 3, 4, 0 /* +Add a timeout, to be signaled after the timeout period has elapsed. +SECS is a number of seconds, expressed as an integer or a float. +FUNCTION will be called after that many seconds have elapsed, with one +argument, the given OBJECT. If the optional RESIGNAL argument is provided, +then after this timeout expires, `add-timeout' will automatically be called +again with RESIGNAL as the first argument. + +This function returns an object which is the id number of this particular +timeout. You can pass that object to `disable-timeout' to turn off the +timeout before it has been signalled. + +NOTE: Id numbers as returned by this function are in a distinct namespace +from those returned by `add-async-timeout'. This means that the same id +number could refer to a pending synchronous timeout and a different pending +asynchronous timeout, and that you cannot pass an id from `add-timeout' +to `disable-async-timeout', or vice-versa. + +The number of seconds may be expressed as a floating-point number, in which +case some fractional part of a second will be used. Caveat: the usable +timeout granularity will vary from system to system. + +Adding a timeout causes a timeout event to be returned by `next-event', and +the function will be invoked by `dispatch-event,' so if emacs is in a tight +loop, the function will not be invoked until the next call to sit-for or +until the return to top-level (the same is true of process filters). + +If you need to have a timeout executed even when XEmacs is in the midst of +running Lisp code, use `add-async-timeout'. + +WARNING: if you are thinking of calling add-timeout from inside of a +callback function as a way of resignalling a timeout, think again. There +is a race condition. That's why the RESIGNAL argument exists. +*/ ) + (secs, function, object, resignal) + Lisp_Object secs, function, object, resignal; +{ + unsigned long msecs = lisp_number_to_milliseconds (secs, 0); + unsigned long msecs2 = (NILP (resignal) ? 0 : + lisp_number_to_milliseconds (resignal, 0)); + int id; + Lisp_Object lid; + id = event_stream_generate_wakeup (msecs, msecs2, function, object, 0); + lid = make_int (id); + if (id != XINT (lid)) abort (); + return lid; +} + +DEFUN ("disable-timeout", Fdisable_timeout, Sdisable_timeout, 1, 1, 0 /* +Disable a timeout from signalling any more. +ID should be a timeout id number as returned by `add-timeout'. If ID +corresponds to a one-shot timeout that has already signalled, nothing +will happen. + +It will not work to call this function on an id number returned by +`add-async-timeout'. Use `disable-async-timeout' for that. +*/ ) + (id) + Lisp_Object id; +{ + CHECK_INT (id); + event_stream_disable_wakeup (XINT (id), 0); + return Qnil; +} + +DEFUN ("add-async-timeout", Fadd_async_timeout, Sadd_async_timeout, 3, 4, 0 /* +Add an asynchronous timeout, to be signaled after an interval has elapsed. +SECS is a number of seconds, expressed as an integer or a float. +FUNCTION will be called after that many seconds have elapsed, with one +argument, the given OBJECT. If the optional RESIGNAL argument is provided, +then after this timeout expires, `add-async-timeout' will automatically be +called again with RESIGNAL as the first argument. + +This function returns an object which is the id number of this particular +timeout. You can pass that object to `disable-async-timeout' to turn off +the timeout before it has been signalled. + +NOTE: Id numbers as returned by this function are in a distinct namespace +from those returned by `add-timeout'. This means that the same id number +could refer to a pending synchronous timeout and a different pending +asynchronous timeout, and that you cannot pass an id from +`add-async-timeout' to `disable-timeout', or vice-versa. + +The number of seconds may be expressed as a floating-point number, in which +case some fractional part of a second will be used. Caveat: the usable +timeout granularity will vary from system to system. + +Adding an asynchronous timeout causes the function to be invoked as soon +as the timeout occurs, even if XEmacs is in the midst of executing some +other code. (This is unlike the synchronous timeouts added with +`add-timeout', where the timeout will only be signalled when XEmacs is +waiting for events, i.e. the next return to top-level or invocation of +`sit-for' or related functions.) This means that the function that is +called *must* not signal an error or change any global state (e.g. switch +buffers or windows) except when locking code is in place to make sure +that race conditions don't occur in the interaction between the +asynchronous timeout function and other code. + +Under most circumstances, you should use `add-timeout' instead, as it is +much safer. Asynchronous timeouts should only be used when such behavior +is really necessary. + +Asynchronous timeouts are blocked and will not occur when `inhibit-quit' +is non-nil. As soon as `inhibit-quit' becomes nil again, any pending +asynchronous timeouts will get called immediately. (Multiple occurrences +of the same asynchronous timeout are not queued, however.) While the +callback function of an asynchronous timeout is invoked, `inhibit-quit' +is automatically bound to non-nil, and thus other asynchronous timeouts +will be blocked unless the callback function explicitly sets `inhibit-quit' +to nil. + +WARNING: if you are thinking of calling `add-async-timeout' from inside of a +callback function as a way of resignalling a timeout, think again. There +is a race condition. That's why the RESIGNAL argument exists. +*/ ) + (secs, function, object, resignal) + Lisp_Object secs, function, object, resignal; +{ + unsigned long msecs = lisp_number_to_milliseconds (secs, 0); + unsigned long msecs2 = (NILP (resignal) ? 0 : + lisp_number_to_milliseconds (resignal, 0)); + int id; + Lisp_Object lid; + id = event_stream_generate_wakeup (msecs, msecs2, function, object, 1); + lid = make_int (id); + if (id != XINT (lid)) abort (); + return lid; +} + +DEFUN ("disable-async-timeout", Fdisable_async_timeout, + Sdisable_async_timeout, 1, 1, 0 /* +Disable an asynchronous timeout from signalling any more. +ID should be a timeout id number as returned by `add-async-timeout'. If ID +corresponds to a one-shot timeout that has already signalled, nothing +will happen. + +It will not work to call this function on an id number returned by +`add-timeout'. Use `disable-timeout' for that. +*/ ) + (id) + Lisp_Object id; +{ + CHECK_INT (id); + event_stream_disable_wakeup (XINT (id), 1); + return Qnil; +} + + +/**********************************************************************/ +/* enqueuing and dequeuing events */ +/**********************************************************************/ + +/* Add an event to the back of the command-event queue: it will be the next + event read after all pending events. This only works on keyboard, + mouse-click, misc-user, and eval events. + */ +void +enqueue_command_event (Lisp_Object event) +{ + enqueue_event (event, &command_event_queue, &command_event_queue_tail); +} + +Lisp_Object +dequeue_command_event (void) +{ + return dequeue_event (&command_event_queue, &command_event_queue_tail); +} + +/* put the event on the typeahead queue, unless + the event is the quit char, in which case the `QUIT' + which will occur on the next trip through this loop is + all the processing we should do - leaving it on the queue + would cause the quit to be processed twice. + */ +static void +enqueue_command_event_1 (Lisp_Object event_to_copy) +{ + /* do not call check_quit() here. Vquit_flag was set in + next_event_internal. */ + if (NILP (Vquit_flag)) + enqueue_command_event (Fcopy_event (event_to_copy, Qnil)); +} + +void +enqueue_magic_eval_event (void (*fun) (Lisp_Object), Lisp_Object object) +{ + Lisp_Object event; + + event = Fmake_event (); + + XEVENT (event)->event_type = magic_eval_event; + /* channel for magic_eval events is nil */ + XEVENT (event)->event.magic_eval.internal_function = fun; + XEVENT (event)->event.magic_eval.object = object; + enqueue_command_event (event); +} + +DEFUN ("enqueue-eval-event", Fenqueue_eval_event, Senqueue_eval_event, + 2, 2, 0 /* +Add an eval event to the back of the eval event queue. +When this event is dispatched, FUNCTION (which should be a function +of one argument) will be called with OBJECT as its argument. +See `next-event' for a description of event types and how events +are received. +*/ ) + (function, object) + Lisp_Object function, object; +{ + Lisp_Object event; + + event = Fmake_event (); + + XEVENT (event)->event_type = eval_event; + /* channel for eval events is nil */ + XEVENT (event)->event.eval.function = function; + XEVENT (event)->event.eval.object = object; + enqueue_command_event (event); + + return event; +} + +Lisp_Object +enqueue_misc_user_event (Lisp_Object channel, Lisp_Object function, + Lisp_Object object) +{ + Lisp_Object event; + + event = Fmake_event (); + + XEVENT (event)->event_type = misc_user_event; + XEVENT (event)->channel = channel; + XEVENT (event)->event.eval.function = function; + XEVENT (event)->event.eval.object = object; + enqueue_command_event (event); + + return event; +} + + +/**********************************************************************/ +/* focus-event handling */ +/**********************************************************************/ + +/* + +Ben's capsule lecture on focus: + +In FSFmacs `select-frame' never changes the window-manager frame +focus. All it does is change the "selected frame". This is similar +to what happens when we call `select-device' or `select-console'. +Whenever an event comes in (including a keyboard event), its frame is +selected; therefore, evaluating `select-frame' in *scratch* won't +cause any effects because the next received event (in the same frame) +will cause a switch back to the frame displaying *scratch*. + +Whenever a focus-change event is received from the window manager, it +generates a `switch-frame' event, which causes the Lisp function +`handle-switch-frame' to get run. This basically just runs +`select-frame' (see below, however). + +In FSFmacs, if you want to have an operation run when a frame is +selected, you supply an event binding for `switch-frame' (and then +maybe call `handle-switch-frame', or something ...). + +In XEmacs, we *do* change the window-manager frame focus as a result +of `select-frame', but not until the next time an event is received, +so that a function that momentarily changes the selected frame won't +cause WM focus flashing. (#### There's something not quite right here; +this is causing the wrong-cursor-focus problems that you occasionally +see. But the general idea is correct.) This approach is winning for +people who use the explicit-focus model, but is trickier to implement. + +We also don't make the `switch-frame' event visible but instead have +`select-frame-hook', which is a better approach. + +There is the problem of surrogate minibuffers, where when we enter the +minibuffer, you essentially want to temporarily switch the WM focus to +the frame with the minibuffer, and switch it back when you exit the +minibuffer. + +FSFmacs solves this with the crockish `redirect-frame-focus', which +says "for keyboard events received from FRAME, act like they're +coming from FOCUS-FRAME". I think what this means is that, when +a keyboard event comes in and the event manager is about to select the +event's frame, if that frame has its focus redirected, the redirected-to +frame is selected instead. That way, if you're in a minibufferless +frame and enter the minibuffer, then all Lisp functions that run see +the selected frame as the minibuffer's frame rather than the minibufferless +frame you came from, so that (e.g.) your typing actually appears in +the minibuffer's frame and things behave sanely. + +There's also some weird logic that switches the redirected frame focus +from one frame to another if Lisp code explicitly calls `select-frame' +\(but not if `handle-switch-frame' is called), and saves and restores +the frame focus in window configurations, etc. etc. All of this logic +is heavily #if 0'd, with lots of comments saying "No, this approach +doesn't seem to work, so I'm trying this ... is it reasonable? +Well, I'm not sure ..." that are a red flag indicating crockishness. + +Because of our way of doing things, we can avoid all this crock. +Keyboard events never cause a select-frame (who cares what frame +they're associated with? They come from a console, only). We change +the actual WM focus to a surrogate minibuffer frame, so we don't have +to do any internal redirection. In order to get the focus back, +I took the approach in minibuf.el of just checking to see if the +frame we moved to is still the selected frame, and move back to the +old one if so. Conceivably we might have to do the weird "tracking" +that FSFmacs does when `select-frame' is called, but I don't think +so. If the selected frame moved from the minibuffer frame, then +we just leave it there, figuring that someone knows what they're +doing. Because we don't have any redirection recorded anywhere, +it's safe to do this, and we don't end up with unwanted redirection. + +*/ + +static void +run_select_frame_hook (void) +{ + run_hook (Qselect_frame_hook); +} + +static void +run_deselect_frame_hook (void) +{ +#if 0 /* unclean! FSF calls this at all sorts of random places, + including a bunch of places in their mouse.el. If this + is implemented, it has to be done cleanly. */ + run_hook (Qmouse_leave_buffer_hook); /* #### Correct? It's also + called in `call-interactively'. + Does this mean it will be + called twice? Oh well, FSF + bug -- FSF calls it in + `handle-switch-frame', + which is approximately the + same as the caller of this + function. */ +#endif + run_hook (Qdeselect_frame_hook); +} + +/* When select-frame is called, we want to tell the window system that + the focus should be changed to point to the new frame. However, + sometimes Lisp functions will temporarily change the selected frame + (e.g. to call a function that operates on the selected frame), + and it's annoying if this focus-change happens exactly when + select-frame is called, because then you get some flickering of the + window-manager border and perhaps other undesirable results. We + really only want to change the focus when we're about to retrieve + an event from the user. To do this, we keep track of the frame + where the window-manager focus lies on, and just before waiting + for user events, check the currently selected frame and change + the focus as necessary. */ + +static void +investigate_frame_change (void) +{ + Lisp_Object devcons, concons; + + /* if the selected frame was changed, change the window-system + focus to the new frame. We don't do it when select-frame was + called, to avoid flickering and other unwanted side effects when + the frame is just changed temporarily. */ + DEVICE_LOOP_NO_BREAK (devcons, concons) + { + struct device *d = XDEVICE (XCAR (devcons)); + Lisp_Object sel_frame = DEVICE_SELECTED_FRAME (d); + + /* You'd think that maybe we should use FRAME_WITH_FOCUS_REAL, + but that can cause us to end up in an infinite loop focussing + between two frames. It seems that since the call to `select-frame' + in emacs_handle_focus_change_final() is based on the _FOR_HOOKS + value, we need to do so too. */ + if (!NILP (sel_frame) && + !EQ (DEVICE_FRAME_THAT_OUGHT_TO_HAVE_FOCUS (d), sel_frame) && + !NILP (DEVICE_FRAME_WITH_FOCUS_FOR_HOOKS (d)) && + !EQ (DEVICE_FRAME_WITH_FOCUS_FOR_HOOKS (d), sel_frame)) + { + /* prevent us from issuing the same request more than once */ + DEVICE_FRAME_THAT_OUGHT_TO_HAVE_FOCUS (d) = sel_frame; + MAYBE_DEVMETH (d, focus_on_frame, (XFRAME (sel_frame))); + } + } +} + +static Lisp_Object +cleanup_after_missed_defocusing (Lisp_Object frame) +{ + if (FRAMEP (frame) && FRAME_LIVE_P (XFRAME (frame))) + Fselect_frame (frame); + return Qnil; +} + +void +emacs_handle_focus_change_preliminary (Lisp_Object frame_inp_and_dev) +{ + Lisp_Object frame = Fcar (frame_inp_and_dev); + Lisp_Object device = Fcar (Fcdr (frame_inp_and_dev)); + int in_p = !NILP (Fcdr (Fcdr (frame_inp_and_dev))); + struct device *d; + + if (!DEVICE_LIVE_P (XDEVICE (device))) + return; + else + d = XDEVICE (device); + + /* Any received focus-change notifications render invalid any + pending focus-change requests. */ + DEVICE_FRAME_THAT_OUGHT_TO_HAVE_FOCUS (d) = Qnil; + if (in_p) + { + Lisp_Object focus_frame; + + if (!FRAME_LIVE_P (XFRAME (frame))) + return; + else + focus_frame = DEVICE_FRAME_WITH_FOCUS_REAL (d); + + /* Mark the minibuffer as changed to make sure it gets updated + properly if the echo area is active. */ + MARK_WINDOWS_CHANGED (XWINDOW (FRAME_MINIBUF_WINDOW (XFRAME (frame)))); + + if (FRAMEP (focus_frame) && !EQ (frame, focus_frame)) + { + /* Oops, we missed a focus-out event. */ + DEVICE_FRAME_WITH_FOCUS_REAL (d) = Qnil; + redisplay_redraw_cursor (XFRAME (focus_frame), 1); + } + DEVICE_FRAME_WITH_FOCUS_REAL (d) = frame; + if (!EQ (frame, focus_frame)) + { + redisplay_redraw_cursor (XFRAME (frame), 1); + } + } + else + { + /* We ignore the frame reported in the event. If it's different + from where we think the focus was, oh well -- we messed up. + Nonetheless, we pretend we were right, for sensible behavior. */ + frame = DEVICE_FRAME_WITH_FOCUS_REAL (d); + if (!NILP (frame)) + { + DEVICE_FRAME_WITH_FOCUS_REAL (d) = Qnil; + + if (FRAME_LIVE_P (XFRAME (frame))) + redisplay_redraw_cursor (XFRAME (frame), 1); + } + } +} + +/* Called from the window-system-specific code when we receive a + notification that the focus lies on a particular frame. + Argument is a cons: (frame . (device . in-p)) where in-p is non-nil + for focus-in. + */ +void +emacs_handle_focus_change_final (Lisp_Object frame_inp_and_dev) +{ + Lisp_Object frame = Fcar (frame_inp_and_dev); + Lisp_Object device = Fcar (Fcdr (frame_inp_and_dev)); + int in_p = !NILP (Fcdr (Fcdr (frame_inp_and_dev))); + struct device *d; + int count; + + if (!DEVICE_LIVE_P (XDEVICE (device))) + return; + else + d = XDEVICE (device); + + if (in_p) + { + Lisp_Object focus_frame; + + if (!FRAME_LIVE_P (XFRAME (frame))) + return; + else + focus_frame = DEVICE_FRAME_WITH_FOCUS_FOR_HOOKS (d); + + DEVICE_FRAME_WITH_FOCUS_FOR_HOOKS (d) = frame; + if (FRAMEP (focus_frame) && !EQ (frame, focus_frame)) + { + /* Oops, we missed a focus-out event. */ + Fselect_frame (focus_frame); + /* Do an unwind-protect in case an error occurs in + the deselect-frame-hook */ + count = specpdl_depth (); + record_unwind_protect (cleanup_after_missed_defocusing, frame); + run_deselect_frame_hook (); + unbind_to (count, Qnil); + /* the cleanup method changed the focus frame to nil, so + we need to reflect this */ + focus_frame = Qnil; + } + else + Fselect_frame (frame); + if (!EQ (frame, focus_frame)) + run_select_frame_hook (); + } + else + { + /* We ignore the frame reported in the event. If it's different + from where we think the focus was, oh well -- we messed up. + Nonetheless, we pretend we were right, for sensible behavior. */ + frame = DEVICE_FRAME_WITH_FOCUS_FOR_HOOKS (d); + if (!NILP (frame)) + { + DEVICE_FRAME_WITH_FOCUS_FOR_HOOKS (d) = Qnil; + run_deselect_frame_hook (); + } + } +} + + +/**********************************************************************/ +/* retrieving the next event */ +/**********************************************************************/ + +static int in_single_console; + +/* #### These functions don't currently do anything. */ +void +single_console_state (void) +{ + in_single_console = 1; +} + +void +any_console_state (void) +{ + in_single_console = 0; +} + +int +in_single_console_state (void) +{ + return in_single_console; +} + +/* the number of keyboard characters read. callint.c wants this. + */ +Charcount num_input_chars; + +static void +next_event_internal (Lisp_Object target_event, int allow_queued) +{ + struct gcpro gcpro1; + /* QUIT; This is incorrect - the caller must do this because some + callers (ie, Fnext_event()) do not want to QUIT. */ + + assert (NILP (XEVENT_NEXT (target_event))); + + GCPRO1 (target_event); + investigate_frame_change (); + + if (allow_queued && !NILP (command_event_queue)) + { + Lisp_Object event = dequeue_command_event (); + Fcopy_event (event, target_event); + Fdeallocate_event (event); +#ifdef DEBUG_XEMACS + if (debug_emacs_events) + { + write_c_string ("(command event queue) ", + Qexternal_debugging_output); + print_internal (target_event, Qexternal_debugging_output, 1); + write_c_string ("\n", Qexternal_debugging_output); + } +#endif + } + else + { + struct Lisp_Event *e = XEVENT (target_event); + + /* The command_event_queue was empty. Wait for an event. */ + event_stream_next_event (e); + /* If this was a timeout, then we need to extract some data + out of the returned closure and might need to resignal + it. */ + if (e->event_type == timeout_event) + { + Lisp_Object tristan, isolde; + + e->event.timeout.id_number = + event_stream_resignal_wakeup (e->event.timeout.interval_id, 0, + &tristan, &isolde); + + e->event.timeout.function = tristan; + e->event.timeout.object = isolde; +#ifdef DEBUG_XEMACS + /* next_event_internal() doesn't print out timeout events + because of the extra info we just set. */ + if (debug_emacs_events) + { + print_internal (target_event, Qexternal_debugging_output, 1); + write_c_string ("\n", Qexternal_debugging_output); + } +#endif + } + + /* If we read a ^G, then set quit-flag but do not discard the ^G. + The callers of next_event_internal() will do one of two things: + + -- set Vquit_flag to Qnil. (next-event does this.) This will + cause the ^G to be treated as a normal keystroke. + -- not change Vquit_flag but attempt to enqueue the ^G, at + which point it will be discarded. The next time QUIT is + called, it will notice that Vquit_flag was set. + + */ + if (e->event_type == key_press_event && + event_matches_key_specifier_p + (e, make_char (CONSOLE_QUIT_CHAR (XCONSOLE (EVENT_CHANNEL (e)))))) + { + Vquit_flag = Qt; + } + } + + UNGCPRO; +} + +static void +run_pre_idle_hook (void) +{ + if (!NILP (Vpre_idle_hook) + && !detect_input_pending ()) + safe_run_hook_trapping_errors + ("Error in `pre-idle-hook' (setting hook to nil)", + Qpre_idle_hook, 1); +} + +static void push_this_command_keys (Lisp_Object event); +static void push_recent_keys (Lisp_Object event); +static void dribble_out_event (Lisp_Object event); +static void execute_internal_event (Lisp_Object event); + +DEFUN ("next-event", Fnext_event, Snext_event, 0, 2, 0 /* +Return the next available event. +Pass this object to `dispatch-event' to handle it. +In most cases, you will want to use `next-command-event', which returns +the next available \"user\" event (i.e. keypress, button-press, +button-release, or menu selection) instead of this function. + +If EVENT is non-nil, it should be an event object and will be filled in +and returned; otherwise a new event object will be created and returned. +If PROMPT is non-nil, it should be a string and will be displayed in the +echo area while this function is waiting for an event. + +The next available event will be + +-- any events in `unread-command-events' or `unread-command-event'; else +-- the next event in the currently executing keyboard macro, if any; else +-- an event queued by `enqueue-eval-event', if any; else +-- the next available event from the window system or terminal driver. + +In the last case, this function will block until an event is available. + +The returned event will be one of the following types: + +-- a key-press event. +-- a button-press or button-release event. +-- a misc-user-event, meaning the user selected an item on a menu or used + the scrollbar. +-- a process event, meaning that output from a subprocess is available. +-- a timeout event, meaning that a timeout has elapsed. +-- an eval event, which simply causes a function to be executed when the + event is dispatched. Eval events are generated by `enqueue-eval-event' + or by certain other conditions happening. +-- a magic event, indicating that some window-system-specific event + happened (such as an focus-change notification) that must be handled + synchronously with other events. `dispatch-event' knows what to do with + these events. +*/ ) + (event, prompt) + Lisp_Object event, prompt; +{ + /* This function can GC */ + /* #### We start out using the selected console before an event + is received, for echoing the partially completed command. + This is most definitely wrong -- there needs to be a separate + echo area for each console! */ + struct console *con = XCONSOLE (Vselected_console); + struct command_builder *command_builder = + XCOMMAND_BUILDER (con->command_builder); + int store_this_key = 0; + struct gcpro gcpro1; + GCPRO1 (event); + + /* DO NOT do QUIT anywhere within this function or the functions it calls. + We want to read the ^G as an event. */ + + if (NILP (event)) + event = Fmake_event (); + else + CHECK_LIVE_EVENT (event); + + if (!NILP (prompt)) + { + Bytecount len; + CHECK_STRING (prompt); + + len = string_length (XSTRING (prompt)); + if (command_builder->echo_buf_length < len) + len = command_builder->echo_buf_length - 1; + memcpy (command_builder->echo_buf, string_data (XSTRING (prompt)), len); + command_builder->echo_buf[len] = 0; + command_builder->echo_buf_index = len; + echo_area_message (XFRAME (CONSOLE_SELECTED_FRAME (con)), + command_builder->echo_buf, + Qnil, 0, + command_builder->echo_buf_index, + Qcommand); + } + + start_over_and_avoid_hosage: + + /* If there is something in unread-command-events, simply return it. + But do some error checking to make sure the user hasn't put something + in the unread-command-events that they shouldn't have. + This does not update this-command-keys and recent-keys. + */ + if (!NILP (Vunread_command_events)) + { + if (!CONSP (Vunread_command_events)) + { + Vunread_command_events = Qnil; + signal_error (Qwrong_type_argument, + list3 (Qconsp, Vunread_command_events, + Qunread_command_events)); + } + else + { + Lisp_Object e = XCAR (Vunread_command_events); + Vunread_command_events = XCDR (Vunread_command_events); + if (!EVENTP (e) || !command_event_p (e)) + signal_error (Qwrong_type_argument, + list3 (Qcommand_event_p, e, Qunread_command_events)); + redisplay (); + if (!EQ (e, event)) + Fcopy_event (e, event); +#ifdef DEBUG_XEMACS + if (debug_emacs_events) + { + write_c_string ("(unread-command-events) ", + Qexternal_debugging_output); + print_internal (event, Qexternal_debugging_output, 1); + write_c_string ("\n", Qexternal_debugging_output); + } +#endif + } + } + + /* Do similar for unread-command-event (obsoleteness support). + */ + else if (!NILP (Vunread_command_event)) + { + Lisp_Object e = Vunread_command_event; + Vunread_command_event = Qnil; + + if (!EVENTP (e) || !command_event_p (e)) + { + signal_error (Qwrong_type_argument, + list3 (Qeventp, e, Qunread_command_event)); + } + if (!EQ (e, event)) + Fcopy_event (e, event); + redisplay (); +#ifdef DEBUG_XEMACS + if (debug_emacs_events) + { + write_c_string ("(unread-command-event) ", + Qexternal_debugging_output); + print_internal (event, Qexternal_debugging_output, 1); + write_c_string ("\n", Qexternal_debugging_output); + } +#endif + } + + /* If we're executing a keyboard macro, take the next event from that, + and update this-command-keys and recent-keys. + Note that the unread-command-events take precedence over kbd macros. + */ + else + { + if (!NILP (Vexecuting_macro)) + { + redisplay (); + pop_kbd_macro_event (event); /* This throws past us at + end-of-macro. */ + store_this_key = 1; +#ifdef DEBUG_XEMACS + if (debug_emacs_events) + { + write_c_string ("(keyboard macro) ", + Qexternal_debugging_output); + print_internal (event, Qexternal_debugging_output, 1); + write_c_string ("\n", Qexternal_debugging_output); + } +#endif + } + /* Otherwise, read a real event, possibly from the + command_event_queue, and update this-command-keys and + recent-keys. */ + else + { + run_pre_idle_hook (); + redisplay (); + next_event_internal (event, 1); + Vquit_flag = Qnil; /* Read C-g as an event. */ + store_this_key = 1; + } + } + + status_notify (); /* Notice process change */ + +#ifdef C_ALLOCA + alloca (0); /* Cause a garbage collection now */ + /* Since we can free the most stuff here + * (since this is typically called from + * the command-loop top-level). */ +#endif /* C_ALLOCA */ + + if (object_dead_p (XEVENT (event)->channel)) + /* event_console_or_selected may crash if the channel is dead. + Best just to eat it and get the next event. */ + goto start_over_and_avoid_hosage; + + /* OK, now we can stop the selected-console kludge and use the + actual console from the event. */ + con = event_console_or_selected (event); + command_builder = XCOMMAND_BUILDER (con->command_builder); + + switch (XEVENT_TYPE (event)) + { + default: + goto RETURN; + case button_release_event: + case misc_user_event: + goto EXECUTE_KEY; + case button_press_event: /* key or mouse input can trigger prompting */ + goto STORE_AND_EXECUTE_KEY; + case key_press_event: /* any key input can trigger autosave */ + break; + } + + maybe_do_auto_save (); + num_input_chars++; + STORE_AND_EXECUTE_KEY: + if (store_this_key) + { + echo_key_event (command_builder, event); + } + + EXECUTE_KEY: + /* Store the last-input-event. The semantics of this is that it is + the thing most recently returned by next-command-event. It need + not have come from the keyboard or a keyboard macro, it may have + come from unread-command-events. It's always a command-event (a + key, click, or menu selection), never a motion or process event. + */ + if (!EVENTP (Vlast_input_event)) + Vlast_input_event = Fmake_event (); + if (XEVENT_TYPE (Vlast_input_event) == dead_event) + { + Vlast_input_event = Fmake_event (); + error ("Someone deallocated last-input-event!"); + } + if (! EQ (event, Vlast_input_event)) + Fcopy_event (event, Vlast_input_event); + + /* last-input-char and last-input-time are derived from + last-input-event. + Note that last-input-char will never have its high-bit set, in an + effort to sidestep the ambiguity between M-x and oslash. + */ + Vlast_input_char = Fevent_to_character (Vlast_input_event, + Qnil, Qnil, Qnil); + { + EMACS_TIME t; + EMACS_GET_TIME (t); + if (!CONSP (Vlast_input_time)) + Vlast_input_time = Fcons (Qnil, Qnil); + XCAR (Vlast_input_time) + = make_int ((EMACS_SECS (t) >> 16) & 0xffff); + XCDR (Vlast_input_time) + = make_int ((EMACS_SECS (t) >> 0) & 0xffff); + } + + /* If this key came from the keyboard or from a keyboard macro, then + it goes into the recent-keys and this-command-keys vectors. + If this key came from the keyboard, and we're defining a keyboard + macro, then it goes into the macro. + */ + if (store_this_key) + { + push_this_command_keys (event); + push_recent_keys (event); + dribble_out_event (event); + if (!NILP (con->defining_kbd_macro) && NILP (Vexecuting_macro)) + { + if (!EVENTP (command_builder->current_events)) + finalize_kbd_macro_chars (con); + store_kbd_macro_event (event); + } + } + /* If this is the help char and there is a help form, then execute the + help form and swallow this character. This is the only place where + calling Fnext_event() can cause arbitrary lisp code to run. Note + that execute_help_form() calls Fnext_command_event(), which calls + this function, as well as Fdispatch_event. + */ + if (!NILP (Vhelp_form) && + event_matches_key_specifier_p (XEVENT (event), Vhelp_char)) + execute_help_form (command_builder, event); + + RETURN: + UNGCPRO; + return (event); +} + +DEFUN ("next-command-event", Fnext_command_event, Snext_command_event, + 0, 2, 0 /* +Return the next available \"user\" event. +Pass this object to `dispatch-event' to handle it. + +If EVENT is non-nil, it should be an event object and will be filled in +and returned; otherwise a new event object will be created and returned. +If PROMPT is non-nil, it should be a string and will be displayed in the +echo area while this function is waiting for an event. + +The event returned will be a keyboard, mouse press, or mouse release event. +If there are non-command events available (mouse motion, sub-process output, +etc) then these will be executed (with `dispatch-event') and discarded. This +function is provided as a convenience; it is equivalent to the lisp code + + (while (progn + (next-event event prompt) + (not (or (key-press-event-p event) + (button-press-event-p event) + (button-release-event-p event) + (misc-user-event-p event)))) + (dispatch-event event)) + +*/ ) + (event, prompt) + Lisp_Object event, prompt; +{ + /* This function can GC */ + struct gcpro gcpro1; + GCPRO1 (event); + maybe_echo_keys (XCOMMAND_BUILDER + (XCONSOLE (Vselected_console)-> + command_builder), 0); /* #### This sucks bigtime */ + for (;;) + { + event = Fnext_event (event, prompt); + if (command_event_p (event)) + break; + else + execute_internal_event (event); + } + UNGCPRO; + return (event); +} + +static void +reset_current_events (struct command_builder *command_builder) +{ + Lisp_Object event = command_builder->current_events; + reset_command_builder_event_chain (command_builder); + if (EVENTP (event)) + deallocate_event_chain (event); +} + +DEFUN ("discard-input", Fdiscard_input, Sdiscard_input, 0, 0, 0 /* +Discard any pending \"user\" events. +Also cancel any kbd macro being defined. +A user event is a key press, button press, button release, or +\"other-user\" event (menu selection or scrollbar action). +*/ ) + () +{ + /* This throws away user-input on the queue, but doesn't process any + events. Calling dispatch_event() here leads to a race condition. + */ + Lisp_Object event = Fmake_event (); + Lisp_Object head = Qnil, tail = Qnil; + Lisp_Object oiq = Vinhibit_quit; + struct gcpro gcpro1, gcpro2; + /* #### not correct here with Vselected_console? Should + discard-input take a console argument, or maybe map over + all consoles? */ + struct console *con = XCONSOLE (Vselected_console); + + /* next_event_internal() can cause arbitrary Lisp code to be evalled */ + GCPRO2 (event, oiq); + Vinhibit_quit = Qt; + /* If a macro was being defined then we have to mark the modeline + has changed to ensure that it gets updated correctly. */ + if (!NILP (con->defining_kbd_macro)) + MARK_MODELINE_CHANGED; + con->defining_kbd_macro = Qnil; + reset_current_events (XCOMMAND_BUILDER (con->command_builder)); + + while (!NILP (command_event_queue) + || event_stream_event_pending_p (1)) + { + /* This will take stuff off the command_event_queue, or read it + from the event_stream, but it will not block. + */ + next_event_internal (event, 1); + Vquit_flag = Qnil; /* Treat C-g as a user event (ignore it). + It is vitally important that we reset + Vquit_flag here. Otherwise, if we're + reading from a TTY console, + maybe_read_quit_event() will notice + that C-g has been set and send us + another C-g. That will cause us + to get right back here, and read + another C-g, ad infinitum ... */ + + /* If the event is a user event, ignore it. */ + if (!command_event_p (event)) + { + /* Otherwise, chain the event onto our list of events not to ignore, + and keep reading until the queue is empty. This does not mean + that if a subprocess is generating an infinite amount of output, + we will never terminate (*provided* that the behavior of + next_event_cb() is correct -- see the comment in events.h), + because this loop ends as soon as there are no more user events + on the command_event_queue or event_stream. + */ + enqueue_event (Fcopy_event (event, Qnil), &head, &tail); + } + } + + if (!NILP (command_event_queue) || !NILP (command_event_queue_tail)) + abort (); + + /* Now tack our chain of events back on to the front of the queue. + Actually, since the queue is now drained, we can just replace it. + The effect of this will be that we have deleted all user events + from the input stream without changing the relative ordering of + any other events. (Some events may have been taken from the + event_stream and added to the command_event_queue, however.) + + At this time, the command_event_queue will contain only eval_events. + */ + + command_event_queue = head; + command_event_queue_tail = tail; + + Fdeallocate_event (event); + UNGCPRO; + + Vinhibit_quit = oiq; + return Qnil; +} + + +/**********************************************************************/ +/* pausing until an action occurs */ +/**********************************************************************/ + +/* #### Is (accept-process-output nil 3) supposed to be like (sleep-for 3)? + */ + +DEFUN ("accept-process-output", Faccept_process_output, Saccept_process_output, + 0, 3, 0 /* +Allow any pending output from subprocesses to be read by Emacs. +It is read into the process' buffers or given to their filter functions. +Non-nil arg PROCESS means do not return until some output has been received + from PROCESS. +If the second arg is non-nil, it is the maximum number of seconds to wait: + this function will return after that much time even if no input has arrived + from PROCESS. This argument may be a float, meaning wait some fractional + part of a second. +If the third arg is non-nil, it is a number of milliseconds that is added + to the second arg. (This exists only for compatibility.) +Return non-nil iff we received any output before the timeout expired. +*/ ) + (process, timeout_secs, timeout_msecs) + Lisp_Object process, timeout_secs, timeout_msecs; +{ + /* This function can GC */ + struct gcpro gcpro1, gcpro2; + Lisp_Object event = Qnil; + Lisp_Object result = Qnil; + int timeout_id; + int timeout_enabled = 0; + struct buffer *old_buffer = current_buffer; + + /* We preserve the current buffer but nothing else. If a focus + change alters the selected window then the top level event loop + will eventually alter current_buffer to match. In the mean time + we don't want to mess up whatever called this function. */ + + if (!NILP (process)) + CHECK_PROCESS (process); + + GCPRO2 (event, process); + + if (!NILP (process) && (!NILP (timeout_secs) || !NILP (timeout_msecs))) + { + unsigned long msecs = 0; + if (!NILP (timeout_secs)) + msecs = lisp_number_to_milliseconds (timeout_secs, 1); + if (!NILP (timeout_msecs)) + { + CHECK_NATNUM (timeout_msecs); + msecs += XINT (timeout_msecs); + } + if (msecs) + { + timeout_id = event_stream_generate_wakeup (msecs, 0, Qnil, Qnil, 0); + timeout_enabled = 1; + } + } + + event = Fmake_event (); + + while (!NILP (process) + /* Calling detect_input_pending() is the wrong thing here, because + that considers the Vunread_command_events and command_event_queue. + We don't need to look at the command_event_queue because we are + only interested in process events, which don't go on that. In + fact, we can't read from it anyway, because we put stuff on it. + + Note that event_stream->event_pending_p must be called in such + a way that it says whether any events *of any kind* are ready, + not just user events, or (accept-process-output nil) will fail + to dispatch any process events that may be on the queue. It is + not clear to me that this is important, because the top-level + loop will process it, and I don't think that there is ever a + time when one calls accept-process-output with a nil argument + and really need the processes to be handled. */ + || (!EQ (result, Qt) && event_stream_event_pending_p (0))) + { + QUIT; /* next_event_internal() does not QUIT, so check for ^G + before reading output from the process - this makes it + less likely that the filter will actually be aborted. + */ + + next_event_internal (event, 0); + /* If C-g was pressed while we were waiting, Vquit_flag got + set and next_event_internal() also returns C-g. When + we enqueue the C-g below, it will get discarded. The + next time through, QUIT will be called and will signal a quit. */ + switch (XEVENT_TYPE (event)) + { + case process_event: + { + if (EQ (XEVENT (event)->event.process.process, process)) + { + process = Qnil; + /* RMS's version always returns nil when proc is nil, + and only returns t if input ever arrived on proc. */ + result = Qt; + } + + execute_internal_event (event); + break; + } + case timeout_event: + { + if (timeout_enabled && + XEVENT (event)->event.timeout.id_number == timeout_id) + { + timeout_enabled = 0; + process = Qnil; /* we're done */ + } + else /* a timeout that's not the one we're waiting for */ + goto EXECUTE_INTERNAL; + break; + } + case pointer_motion_event: + case magic_event: + { + EXECUTE_INTERNAL: + execute_internal_event (event); + break; + } + default: + { + enqueue_command_event_1 (event); + break; + } + } + } + + /* If our timeout has not been signalled yet, disable it. */ + if (timeout_enabled) + event_stream_disable_wakeup (timeout_id, 0); + + Fdeallocate_event (event); + UNGCPRO; + current_buffer = old_buffer; + return result; +} + +DEFUN ("sleep-for", Fsleep_for, Ssleep_for, 1, 1, 0 /* +Pause, without updating display, for ARG seconds. +ARG may be a float, meaning pause for some fractional part of a second. +*/ ) + (seconds) + Lisp_Object seconds; +{ + /* This function can GC */ + unsigned long msecs = lisp_number_to_milliseconds (seconds, 1); + int id; + Lisp_Object event = Qnil; + struct gcpro gcpro1; + + GCPRO1 (event); + + id = event_stream_generate_wakeup (msecs, 0, Qnil, Qnil, 0); + event = Fmake_event (); + while (1) + { + QUIT; /* next_event_internal() does not QUIT, so check for ^G + before reading output from the process - this makes it + less likely that the filter will actually be aborted. + */ + /* We're a generator of the command_event_queue, so we can't be a + consumer as well. We don't care about command and eval-events + anyway. + */ + next_event_internal (event, 0); /* blocks */ + /* See the comment in accept-process-output about Vquit_flag */ + switch (XEVENT_TYPE (event)) + { + case timeout_event: + { + if (XEVENT (event)->event.timeout.id_number == id) + goto DONE_LABEL; + else + goto EXECUTE_INTERNAL; + } + case pointer_motion_event: + case process_event: + case magic_event: + { + EXECUTE_INTERNAL: + execute_internal_event (event); + break; + } + default: + { + enqueue_command_event_1 (event); + break; + } + } + } + DONE_LABEL: + Fdeallocate_event (event); + UNGCPRO; + return Qnil; +} + +DEFUN ("sit-for", Fsit_for, Ssit_for, 1, 2, 0 /* +Perform redisplay, then wait ARG seconds or until user input is available. +ARG may be a float, meaning a fractional part of a second. +Optional second arg non-nil means don't redisplay, just wait for input. +Redisplay is preempted as always if user input arrives, and does not +happen if input is available before it starts. +Value is t if waited the full time with no input arriving. +*/ ) + (seconds, nodisplay) + Lisp_Object seconds, nodisplay; +{ + /* This function can GC */ + unsigned long msecs = lisp_number_to_milliseconds (seconds, 1); + Lisp_Object event, result; + struct gcpro gcpro1; + int id; + + /* The unread-command-events count as pending input */ + if (!NILP (Vunread_command_events) || !NILP (Vunread_command_event)) + return Qnil; + + /* If the command-builder already has user-input on it (not eval events) + then that means we're done too. + */ + if (!NILP (command_event_queue)) + { + EVENT_CHAIN_LOOP (event, command_event_queue) + { + if (command_event_p (event)) + return (Qnil); + } + } + + /* If we're in a macro, or noninteractive, or early in temacs, then + don't wait. */ + if (noninteractive || !NILP (Vexecuting_macro)) + return (Qnil); + + /* Otherwise, start reading events from the event_stream. + Do this loop at least once even if (sit-for 0) so that we + redisplay when no input pending. + */ + event = Fmake_event (); + GCPRO1 (event); + + /* Generate the wakeup even if MSECS is 0, so that existing timeout/etc. + events get processed. The old (pre-19.12) code special-cased this + and didn't generate a wakeup, but the resulting behavior was less than + ideal; viz. the occurrence of (sit-for 0.001) scattered throughout + the E-Lisp universe. */ + + id = event_stream_generate_wakeup (msecs, 0, Qnil, Qnil, 0); + + while (1) + { + /* If there is no user input pending, then redisplay. + */ + if (!event_stream_event_pending_p (1) && NILP (nodisplay)) + { + run_pre_idle_hook (); + redisplay (); + } + + /* If we're no longer waiting for a timeout, bug out. */ + if (! id) + { + result = Qt; + goto DONE_LABEL; + } + + QUIT; /* next_event_internal() does not QUIT, so check for ^G + before reading output from the process - this makes it + less likely that the filter will actually be aborted. + */ + /* We're a generator of the command_event_queue, so we can't be a + consumer as well. In fact, we know there's nothing on the + command_event_queue that we didn't just put there. + */ + next_event_internal (event, 0); /* blocks */ + /* See the comment in accept-process-output about Vquit_flag */ + + if (command_event_p (event)) + { + result = Qnil; + goto DONE_LABEL; + } + switch (XEVENT_TYPE (event)) + { + case eval_event: + { + /* eval-events get delayed until later. */ + enqueue_command_event (Fcopy_event (event, Qnil)); + break; + } + case timeout_event: + { + if (XEVENT (event)->event.timeout.id_number != id) + /* a timeout that wasn't the one we're waiting for */ + goto EXECUTE_INTERNAL; + id = 0; /* assert that we are no longer waiting for it. */ + result = Qt; + goto DONE_LABEL; + } + default: + { + EXECUTE_INTERNAL: + execute_internal_event (event); + break; + } + } + } + + DONE_LABEL: + /* If our timeout has not been signalled yet, disable it. */ + if (id) + event_stream_disable_wakeup (id, 0); + + /* Put back the event (if any) that made Fsit_for() exit before the + timeout. Note that it is being added to the back of the queue, which + would be inappropriate if there were any user events on the queue + already: we would be misordering them. But we know that there are + no user-events on the queue, or else we would not have reached this + point at all. + */ + if (NILP (result)) + enqueue_command_event (event); + else + Fdeallocate_event (event); + + UNGCPRO; + return (result); +} + +/* This handy little function is used by xselect.c and energize.c to + wait for replies from processes that aren't really processes (that is, + the X server and the Energize server). + */ +void +wait_delaying_user_input (int (*predicate) (void *arg), void *predicate_arg) +{ + /* This function can GC */ + Lisp_Object event = Fmake_event (); + struct gcpro gcpro1; + GCPRO1 (event); + + while (!(*predicate) (predicate_arg)) + { + QUIT; /* next_event_internal() does not QUIT. */ + + /* We're a generator of the command_event_queue, so we can't be a + consumer as well. Also, we have no reason to consult the + command_event_queue; there are only user and eval-events there, + and we'd just have to put them back anyway. + */ + next_event_internal (event, 0); + /* See the comment in accept-process-output about Vquit_flag */ + if (command_event_p (event) + || (XEVENT_TYPE (event) == eval_event) + || (XEVENT_TYPE (event) == magic_eval_event)) + enqueue_command_event_1 (event); + else + execute_internal_event (event); + } + UNGCPRO; +} + + +/**********************************************************************/ +/* dispatching events; command builder */ +/**********************************************************************/ + +static void +execute_internal_event (Lisp_Object event) +{ + /* events on dead channels get silently eaten */ + if (object_dead_p (XEVENT (event)->channel)) + return; + + /* This function can GC */ + switch (XEVENT_TYPE (event)) + { + case empty_event: + return; + + case eval_event: + { + call1 (XEVENT (event)->event.eval.function, + XEVENT (event)->event.eval.object); + return; + } + + case magic_eval_event: + { + (XEVENT (event)->event.magic_eval.internal_function) + (XEVENT (event)->event.magic_eval.object); + return; + } + + case pointer_motion_event: + { + if (!NILP (Vmouse_motion_handler)) + call1 (Vmouse_motion_handler, event); + return; + } + + case process_event: + { + Lisp_Object p = XEVENT (event)->event.process.process; + Charcount readstatus; + + assert (PROCESSP (p)); + while ((readstatus = read_process_output (p)) > 0) + ; + if (readstatus > 0) + ; /* this clauses never gets executed but allows the #ifdefs + to work cleanly. */ +#ifdef EWOULDBLOCK + else if (readstatus == -1 && errno == EWOULDBLOCK) + ; +#endif /* EWOULDBLOCK */ +#ifdef EAGAIN + else if (readstatus == -1 && errno == EAGAIN) + ; +#endif /* EAGAIN */ + else if ((readstatus == 0 && + /* Note that we cannot distinguish between no input + available now and a closed pipe. + With luck, a closed pipe will be accompanied by + subprocess termination and SIGCHLD. */ + (!network_connection_p (p) || + /* + When connected to ToolTalk (i.e. + connected_via_filedesc_p()), it's not possible to + reliably determine whether there is a message + waiting for ToolTalk to receive. ToolTalk expects + to have tt_message_receive() called exactly once + every time the file descriptor becomes active, so + the filter function forces this by returning 0. + Emacs must not interpret this as a closed pipe. */ + connected_via_filedesc_p (XPROCESS (p)))) +#ifdef HAVE_PTYS + /* On some OSs with ptys, when the process on one end of + a pty exits, the other end gets an error reading with + errno = EIO instead of getting an EOF (0 bytes read). + Therefore, if we get an error reading and errno = + EIO, just continue, because the child process has + exited and should clean itself up soon (e.g. when we + get a SIGCHLD). */ + || (readstatus == -1 && errno == EIO) +#endif + ) + { + /* Currently, we rely on SIGCHLD to indicate that + the process has terminated. Unfortunately, it + appears that on some systems the SIGCHLD gets + missed some of the time. So, we put in am + additional check in status_notify() to see + whether a process has terminated. We have to + tell status_notify() to enable that check, and + we do so now. */ + kick_status_notify (); + } + else + { + /* Deactivate network connection */ + Lisp_Object status = Fprocess_status (p); + if (EQ (status, Qopen) + /* In case somebody changes the theory of whether to + return open as opposed to run for network connection + "processes"... */ + || EQ (status, Qrun)) + update_process_status (p, Qexit, 256, 0); + deactivate_process (p); + } + + /* We must call status_notify here to allow the + event_stream->unselect_process_cb to be run if appropriate. + Otherwise, dead fds may be selected for, and we will get a + continuous stream of process events for them. Since we don't + return until all process events have been flushed, we would + get stuck here, processing events on a process whose status + was 'exit. Call this after dispatch-event, or the fds will + have been closed before we read the last data from them. + It's safe for the filter to signal an error because + status_notify() will be called on return to top-level. + */ + status_notify (); + return; + } + + case timeout_event: + { + struct Lisp_Event *e = XEVENT (event); + if (!NILP (e->event.timeout.function)) + call1 (e->event.timeout.function, + e->event.timeout.object); + return; + } + case magic_event: + { + event_stream_handle_magic_event (XEVENT (event)); + return; + } + default: + abort (); + } +} + + + +static void +this_command_keys_replace_suffix (Lisp_Object suffix, Lisp_Object chain) +{ + Lisp_Object first_before_suffix = + event_chain_find_previous (Vthis_command_keys, suffix); + + if (NILP (first_before_suffix)) + Vthis_command_keys = chain; + else + XSET_EVENT_NEXT (first_before_suffix, chain); + deallocate_event_chain (suffix); + Vthis_command_keys_tail = event_chain_tail (chain); +} + +static void +command_builder_replace_suffix (struct command_builder *builder, + Lisp_Object suffix, Lisp_Object chain) +{ + Lisp_Object first_before_suffix = + event_chain_find_previous (builder->current_events, suffix); + + if (NILP (first_before_suffix)) + builder->current_events = chain; + else + XSET_EVENT_NEXT (first_before_suffix, chain); + deallocate_event_chain (suffix); + builder->most_current_event = event_chain_tail (chain); +} + +static Lisp_Object +command_builder_find_leaf_1 (struct command_builder *builder) +{ + Lisp_Object event0 = builder->current_events; + + if (NILP (event0)) + return (Qnil); + + return event_binding (event0, 1); +} + +/* See if we can do function-key-map or key-translation-map translation + on the current events in the command builder. If so, do this, and + return the resulting binding, if any. */ + +static Lisp_Object +munge_keymap_translate (struct command_builder *builder, + enum munge_me_out_the_door munge, + int has_normal_binding_p) +{ + Lisp_Object suffix; + + EVENT_CHAIN_LOOP (suffix, builder->munge_me[munge].first_mungeable_event) + { + Lisp_Object result = munging_key_map_event_binding (suffix, munge); + + if (!NILP (result)) + { + if (KEYMAPP (result)) + { + if (NILP (builder->last_non_munged_event) + && !has_normal_binding_p) + builder->last_non_munged_event = + builder->most_current_event; + } + else + builder->last_non_munged_event = Qnil; + + if (!KEYMAPP (result) && !VECTORP (result) + && !STRINGP (result)) + { + struct gcpro gcpro1; + GCPRO1 (suffix); + result = call1 (result, Qnil); + UNGCPRO; + } + + if (KEYMAPP (result)) + return result; + + if (VECTORP (result) || STRINGP (result)) + { + Lisp_Object new_chain = + key_sequence_to_event_chain (result); + Lisp_Object tempev; + int n, tckn; + + /* If the first_mungeable_event of the other munger + is within the events we're munging, then it will + point to deallocated events afterwards, which is + bad -- so make it point at the beginning of the + munged events. */ + EVENT_CHAIN_LOOP (tempev, suffix) + { + if (EQ (tempev, builder->munge_me[1 - munge]. + first_mungeable_event)) + { + builder->munge_me[1 - munge].first_mungeable_event = + new_chain; + break; + } + } + + n = event_chain_count (suffix); + command_builder_replace_suffix (builder, suffix, new_chain); + builder->munge_me[munge].first_mungeable_event = Qnil; + /* Now hork this-command-keys as well. */ + + /* We just assume that the events we just replaced + are sitting in copied form at the end of this-command-keys. + If the user did weird things with `dispatch-event' + this may not be the case, but at least we make + sure we won't crash. */ + new_chain = copy_event_chain (new_chain); + tckn = event_chain_count (Vthis_command_keys); + if (tckn >= n) + { + this_command_keys_replace_suffix + (event_chain_nth (Vthis_command_keys, tckn - n), + new_chain); + } + + result = command_builder_find_leaf_1 (builder); + return result; + } + + if (munge == MUNGE_ME_FUNCTION_KEY) + signal_simple_error ("Invalid binding in function-key-map", + result); + else + signal_simple_error ("Invalid binding in key-translation-map", + result); + } + } + + return Qnil; +} + +/* Compare the current state of the command builder against the local and + global keymaps, and return the binding. If there is no match, try again, + case-insensitively. The return value will be + + -- nil (there is no binding) + -- a keymap (part of a command has been specified) + -- a command (anything that satisfies `commandp'; this includes + some symbols, lists, subrs, strings, vectors, and + compiled-function objects) + */ +static Lisp_Object +command_builder_find_leaf (struct command_builder *builder, + int allow_misc_user_events_p) +{ + /* This function can GC */ + Lisp_Object result; + Lisp_Object evee = builder->current_events; + + if (allow_misc_user_events_p + && (NILP (XEVENT_NEXT (evee))) + && (XEVENT_TYPE (evee) == misc_user_event)) + { + Lisp_Object fn = XEVENT (evee)->event.eval.function; + Lisp_Object arg = XEVENT (evee)->event.eval.object; + return (list2 (fn, arg)); + } + + else if (XEVENT_TYPE (evee) == misc_user_event) + return Qnil; + + result = command_builder_find_leaf_1 (builder); + + /* Check to see if we have a potential function-key-map match. */ + if (NILP (result)) + { + result = munge_keymap_translate (builder, MUNGE_ME_FUNCTION_KEY, 0); + regenerate_echo_keys_from_this_command_keys (builder); + } + /* Check to see if we have a potential key-translation-map match. */ + { + Lisp_Object key_translate_result = + munge_keymap_translate (builder, MUNGE_ME_KEY_TRANSLATION, + !NILP (result)); + if (!NILP (key_translate_result)) + { + result = key_translate_result; + regenerate_echo_keys_from_this_command_keys (builder); + } + } + + if (!NILP (result)) + return result; + + /* If key-sequence wasn't bound, we'll try some fallbacks. */ + + { + Lisp_Object terminal = builder->most_current_event; + + /* If we didn't find a binding, and the last event in the sequence is + a shifted character, then try again with the lowercase version. */ + + if (!NILP (Vretry_undefined_key_binding_unshifted) + && XEVENT_TYPE (terminal) == key_press_event + && ((XEVENT (terminal)->event.key.modifiers & MOD_SHIFT) + || (CHAR_OR_CHAR_INTP (XEVENT (terminal)->event.key.keysym) + && XCHAR_OR_CHAR_INT (XEVENT (terminal)->event.key.keysym) + >= 'A' + && XCHAR_OR_CHAR_INT (XEVENT (terminal)->event.key.keysym) + <= 'Z'))) + { + struct Lisp_Event terminal_copy; + terminal_copy = *XEVENT (terminal); + + if (XEVENT (terminal)->event.key.modifiers & MOD_SHIFT) + XEVENT (terminal)->event.key.modifiers &= (~ MOD_SHIFT); + else + XEVENT (terminal)->event.key.keysym + = make_char (XCHAR_OR_CHAR_INT (XEVENT (terminal)-> + event.key.keysym) + + 'a' - 'A'); + + result = command_builder_find_leaf (builder, allow_misc_user_events_p); + if (!NILP (result)) + return (result); + /* If there was no match with the lower-case version either, then + put back the upper-case event for the error message. + But make sure that function-key-map didn't change things out + from under us. */ + if (EQ (terminal, builder->most_current_event)) + *XEVENT (terminal) = terminal_copy; + } + } + + if (!NILP (Vprefix_help_command) && + event_matches_key_specifier_p (XEVENT (builder->most_current_event), + Vhelp_char)) + return (Vprefix_help_command); + + /* If we read extra events attempting to match a function key but end + up failing, then we release those events back to the command loop + and fail on the original lookup. The released events will then be + reprocessed in the context of the first part having failed. */ + if (!NILP (builder->last_non_munged_event)) + { + Lisp_Object event0 = builder->last_non_munged_event; + + /* Put the commands back on the event queue. */ + enqueue_event_chain (XEVENT_NEXT (event0), + &command_event_queue, + &command_event_queue_tail); + + /* Then remove them from the command builder. */ + XSET_EVENT_NEXT (event0, Qnil); + builder->most_current_event = event0; + builder->last_non_munged_event = Qnil; + } + + return Qnil; +} + + +/* Every time a command-event (a key, button, or menu selection) is read by + Fnext_event(), it is stored in the recent_keys_ring, in Vlast_input_event, + and in Vthis_command_keys. (Eval-events are not stored there.) + + Every time a command is invoked, Vlast_command_event is set to the last + event in the sequence. + + This means that Vthis_command_keys is really about "input read since the + last command was executed" rather than about "what keys invoked this + command." This is a little counterintuitive, but that's the way it + has always worked. + + As an extra kink, the function read-key-sequence resets/updates the + last-command-event and this-command-keys. It doesn't append to the + command-keys as read-char does. Such are the pitfalls of having to + maintain compatibility with a program for which the only specification + is the code itself. + + (We could implement recent_keys_ring and Vthis_command_keys as the same + data structure.) + */ + +#define RECENT_KEYS_SIZE 100 +Lisp_Object recent_keys_ring; +int recent_keys_ring_index; + +DEFUN ("recent-keys", Frecent_keys, Srecent_keys, 0, 0, 0 /* +Return vector of last 100 or so keyboard or mouse button events read. +This copies the event objects into a new vector; it is safe to keep and +modify them. +*/ ) + () +{ + struct gcpro gcpro1; + Lisp_Object val = Qnil; + int size = XVECTOR (recent_keys_ring)->size; + int start, nkeys, i, j; + GCPRO1 (val); + + if (NILP (vector_data (XVECTOR (recent_keys_ring))[recent_keys_ring_index])) + /* This means the vector has not yet wrapped */ + { + nkeys = recent_keys_ring_index; + start = 0; + } + else + { + nkeys = size; + start = ((recent_keys_ring_index == size) ? 0 : recent_keys_ring_index); + } + + val = make_vector (nkeys, Qnil); + + for (i = 0, j = start; i < nkeys; i++) + { + Lisp_Object e = vector_data (XVECTOR (recent_keys_ring))[j]; + + if (NILP (e)) + abort (); + vector_data (XVECTOR (val))[i] = Fcopy_event (e, Qnil); + if (++j >= size) + j = 0; + } + UNGCPRO; + return (val); +} + +/* Vthis_command_keys having value Qnil means that the next time + push_this_command_keys is called, it should start over. + The times at which the the command-keys are reset + (instead of merely being augmented) are pretty conterintuitive. + (More specifically: + + -- We do not reset this-command-keys when we finish reading a + command. This is because some commands (e.g. C-u) act + like command prefixes; they signal this by setting prefix-arg + to non-nil. + -- Therefore, we reset this-command-keys when we finish + executing a comand, unless prefix-arg is set. + -- However, if we ever do a non-local exit out of a command + loop (e.g. an error in a command), we need to reset + this-command-keys. We do this by calling reset_this_command_keys() + from cmdloop.c, whenever an error causes an invocation of the + default error handler, and whenever there's a throw to top-level.) + */ + +void +reset_this_command_keys (Lisp_Object console, int clear_echo_area_p) +{ + struct command_builder *command_builder = + XCOMMAND_BUILDER (XCONSOLE (console)->command_builder); + + reset_key_echo (command_builder, clear_echo_area_p); + + deallocate_event_chain (Vthis_command_keys); + Vthis_command_keys = Qnil; + Vthis_command_keys_tail = Qnil; + + reset_current_events (command_builder); +} + +static void +push_this_command_keys (Lisp_Object event) +{ + Lisp_Object new = Fmake_event (); + + Fcopy_event (event, new); + enqueue_event (new, &Vthis_command_keys, &Vthis_command_keys_tail); +} + +/* The following two functions are used in call-interactively, + for the @ and e specifications. We used to just use + `current-mouse-event' (i.e. the last mouse event in this-comand-keys), + but FSF does it more generally so we follow their lead. */ + +Lisp_Object +extract_this_command_keys_nth_mouse_event (int n) +{ + Lisp_Object event; + + EVENT_CHAIN_LOOP (event, Vthis_command_keys) + { + if (EVENTP (event) + && (XEVENT_TYPE (event) == button_press_event + || XEVENT_TYPE (event) == button_release_event + || XEVENT_TYPE (event) == misc_user_event)) + { + if (!n) + { + /* must copy to avoid an abort() in next_event_internal() */ + if (!NILP (XEVENT_NEXT (event))) + return Fcopy_event (event, Qnil); + else + return event; + } + n--; + } + } + + return Qnil; +} + +Lisp_Object +extract_vector_nth_mouse_event (Lisp_Object vector, int n) +{ + int i; + + for (i = 0; i < vector_length (XVECTOR (vector)); i++) + { + Lisp_Object event = vector_data (XVECTOR (vector))[i]; + if (EVENTP (event) + && (XEVENT_TYPE (event) == button_press_event + || XEVENT_TYPE (event) == button_release_event + || XEVENT_TYPE (event) == misc_user_event)) + { + if (!n) + return event; + n--; + } + } + + return Qnil; +} + +static void +push_recent_keys (Lisp_Object event) +{ + Lisp_Object e + = vector_data (XVECTOR (recent_keys_ring)) [recent_keys_ring_index]; + + if (NILP (e)) + { + e = Fmake_event (); + vector_data (XVECTOR (recent_keys_ring)) [recent_keys_ring_index] = e; + } + Fcopy_event (event, e); + if (++recent_keys_ring_index == XVECTOR (recent_keys_ring)->size) + recent_keys_ring_index = 0; +} + + +static Lisp_Object +current_events_into_vector (struct command_builder *command_builder) +{ + Lisp_Object vector; + Lisp_Object event; + int n = event_chain_count (command_builder->current_events); + + /* Copy the vector and the events in it. */ + /* No need to copy the events, since they're already copies, and + nobody other than the command-builder has pointers to them */ + vector = make_vector (n, Qnil); + n = 0; + EVENT_CHAIN_LOOP (event, command_builder->current_events) + vector_data (XVECTOR (vector))[n++] = event; + reset_command_builder_event_chain (command_builder); + return (vector); +} + + +/* + Given the current state of the command builder and a new command event + that has just been dispatched: + + -- add the event to the event chain forming the current command + (doing meta-translation as necessary) + -- return the binding of the this event chain; this will be one of + -- nil (there is no binding) + -- a keymap (part of a command has been specified) + -- a command (anything that satisfies `commandp'; this includes + some symbols, lists, subrs, strings, vectors, and + compiled-function objects) + + */ +static Lisp_Object +lookup_command_event (struct command_builder *command_builder, + Lisp_Object event, int allow_misc_user_events_p) +{ + /* This function can GC */ + struct frame *f = selected_frame (); + /* Clear output from previous command execution */ + if (!EQ (Qcommand, echo_area_status (f)) + /* but don't let mouse-up clear what mouse-down just printed */ + && (XEVENT (event)->event_type != button_release_event)) + clear_echo_area (f, Qnil, 0); + + /* Add the given event to the command builder. + Extra hack: this also updates the recent_keys_ring and Vthis_command_keys + vectors to translate "ESC x" to "M-x" (for any "x" of course). + */ + { + Lisp_Object recent = command_builder->most_current_event; + + if (EVENTP (recent) + && event_matches_key_specifier_p (XEVENT (recent), Vmeta_prefix_char)) + { + struct Lisp_Event *e; + /* When we see a sequence like "ESC x", pretend we really saw "M-x". + DoubleThink the recent-keys and this-command-keys as well. */ + + /* Modify the previous most-recently-pushed event on the command + builder to be a copy of this one with the meta-bit set instead of + pushing a new event. + */ + Fcopy_event (event, recent); + e = XEVENT (recent); + if (e->event_type == key_press_event) + e->event.key.modifiers |= MOD_META; + else if (e->event_type == button_press_event + || e->event_type == button_release_event) + e->event.button.modifiers |= MOD_META; + else + abort (); + + { + int tckn = event_chain_count (Vthis_command_keys); + if (tckn >= 2) + /* ??? very strange if it's < 2. */ + this_command_keys_replace_suffix + (event_chain_nth (Vthis_command_keys, tckn - 2), + Fcopy_event (recent, Qnil)); + } + + regenerate_echo_keys_from_this_command_keys (command_builder); + } + else + { + event = Fcopy_event (event, Fmake_event ()); + + command_builder_append_event (command_builder, event); + } + } + + { + Lisp_Object leaf = command_builder_find_leaf (command_builder, + allow_misc_user_events_p); + struct gcpro gcpro1; + GCPRO1 (leaf); + + if (KEYMAPP (leaf)) + { + Lisp_Object prompt = Fkeymap_prompt (leaf, Qt); + if (STRINGP (prompt)) + { + /* Append keymap prompt to key echo buffer */ + int buf_index = command_builder->echo_buf_index; + Bytecount len = string_length (XSTRING (prompt)); + + if (len + buf_index + 1 <= command_builder->echo_buf_length) + { + Bufbyte *echo = command_builder->echo_buf + buf_index; + memcpy (echo, string_data (XSTRING (prompt)), len); + echo[len] = 0; + } + maybe_echo_keys (command_builder, 1); + } + else + maybe_echo_keys (command_builder, 0); + } + else if (!NILP (leaf)) + { + if (EQ (Qcommand, echo_area_status (f)) + && command_builder->echo_buf_index > 0) + { + /* If we had been echoing keys, echo the last one (without + the trailing dash) and redisplay before executing the + command. */ + command_builder->echo_buf[command_builder->echo_buf_index] = 0; + maybe_echo_keys (command_builder, 1); + Fsit_for (Qzero, Qt); + } + } + RETURN_UNGCPRO (leaf); + } +} + +static void +execute_command_event (struct command_builder *command_builder, + Lisp_Object event) +{ + /* This function can GC */ + struct console *con = XCONSOLE (command_builder->console); + struct gcpro gcpro1; + + GCPRO1 (event); /* event may be freshly created */ + reset_current_events (command_builder); + + if (XEVENT (event)->event_type == key_press_event) + Vcurrent_mouse_event = Qnil; + else if (XEVENT (event)->event_type == button_press_event + || XEVENT (event)->event_type == button_release_event + || XEVENT (event)->event_type == misc_user_event) + Vcurrent_mouse_event = Fcopy_event (event, Qnil); + + /* Store the last-command-event. The semantics of this is that it is + the last event most recently involved in command-lookup. + */ + if (!EVENTP (Vlast_command_event)) + Vlast_command_event = Fmake_event (); + if (XEVENT (Vlast_command_event)->event_type == dead_event) + { + Vlast_command_event = Fmake_event (); + error ("Someone deallocated the last-command-event!"); + } + + if (! EQ (event, Vlast_command_event)) + Fcopy_event (event, Vlast_command_event); + + /* Note that last-command-char will never have its high-bit set, in + an effort to sidestep the ambiguity between M-x and oslash. + */ + Vlast_command_char = Fevent_to_character (Vlast_command_event, + Qnil, Qnil, Qnil); + + /* Actually call the command, with all sorts of hair to preserve or clear + the echo-area and region as appropriate and call the pre- and post- + command-hooks. + */ + { + int old_kbd_macro = con->kbd_macro_end; + struct window *w; + + w = XWINDOW (Fselected_window (Qnil)); + + /* We're executing a new command, so the old value of is irrelevant. */ + zmacs_region_stays = 0; + + /* If the previous command tried to force a specific window-start, + reset the flag in case this command moves point far away from + that position. Also, reset the window's buffer's change + information so that we don't trigger an incremental update. */ + if (w->force_start) + { + w->force_start = 0; + buffer_reset_changes (XBUFFER (w->buffer)); + } + + pre_command_hook (); + + if (XEVENT (event)->event_type == misc_user_event) + { + call1 (XEVENT (event)->event.eval.function, + XEVENT (event)->event.eval.object); + } + else + { +#if 0 + call3 (Qcommand_execute, Vthis_command, Qnil, Qnil); +#else + Fcommand_execute (Vthis_command, Qnil, Qnil); +#endif + } + + post_command_hook (); + + if (!NILP (con->prefix_arg)) + { + /* Commands that set the prefix arg don't update last-command, don't + reset the echoing state, and don't go into keyboard macros unless + followed by another command. + */ + maybe_echo_keys (command_builder, 0); + + /* If we're recording a keyboard macro, and the last command + executed set a prefix argument, then decrement the pointer to + the "last character really in the macro" to be just before this + command. This is so that the ^U in "^U ^X )" doesn't go onto + the end of macro. + */ + if (!NILP (con->defining_kbd_macro)) + con->kbd_macro_end = old_kbd_macro; + } + else + { + /* Start a new command next time */ + Vlast_command = Vthis_command; + /* Emacs 18 doesn't unconditionally clear the echoed keystrokes, + so we don't either */ + reset_this_command_keys (make_console (con), 0); + } + } + + UNGCPRO; +} + +/* Run the pre command hook. */ + +static void +pre_command_hook (void) +{ + last_point_position = BUF_PT (current_buffer); + XSETBUFFER (last_point_position_buffer, current_buffer); + /* This function can GC */ + safe_run_hook_trapping_errors + ("Error in `pre-command-hook' (setting hook to nil)", + Qpre_command_hook, 1); +} + +/* Run the post command hook. */ + +static void +post_command_hook (void) +{ + /* This function can GC */ + /* Turn off region highlighting unless this command requested that + it be left on, or we're in the minibuffer. We don't turn it off + when we're in the minibuffer so that things like M-x write-region + still work! + + This could be done via a function on the post-command-hook, but + we don't want the user to accidentally remove it. + */ + if (! zmacs_region_stays + && (!MINI_WINDOW_P (XWINDOW (Fselected_window (Qnil))) + /* but don't leave the region around if it's in the + minibuffer. */ + || EQ (zmacs_region_buffer (), + WINDOW_BUFFER (XWINDOW (Fselected_window (Qnil)))))) + zmacs_deactivate_region (); + else + zmacs_update_region (); + + safe_run_hook_trapping_errors + ("Error in `post-command-hook' (setting hook to nil)", + Qpost_command_hook, 1); + +#ifdef DEFERRED_ACTION_CRAP + if (!NILP (Vdeferred_action_list)) + call0 (Vdeferred_action_function); +#endif + +#ifdef ILL_CONCEIVED_HOOK + if (NILP (Vunread_command_events) + && NILP (Vexecuting_macro) + && !NILP (Vpost_command_idle_hook) + && !NILP (Fsit_for (make_float ((double) post_command_idle_delay + / 1000000), Qnil))) + safe_run_hook_trapping_errors + ("Error in `post-command-idle-hook' (setting hook to nil)", + Qpost_command_idle_hook, 1); +#endif + +#if 0 /* FSFmacs */ + if (!NILP (current_buffer->mark_active)) + { + if (!NILP (Vdeactivate_mark) && !NILP (Vtransient_mark_mode)) + { + current_buffer->mark_active = Qnil; + run_hook (intern ("deactivate-mark-hook")); + } + else if (current_buffer != prev_buffer || + BUF_MODIFF (current_buffer) != prev_modiff) + run_hook (intern ("activate-mark-hook")); + } +#endif /* FSFmacs */ + + /* #### Kludge!!! This is necessary to make sure that things + are properly positioned even if post-command-hook moves point. + #### There should be a cleaner way of handling this. */ + call0 (Qauto_show_make_point_visible); +} + + +DEFUN ("dispatch-event", Fdispatch_event, Sdispatch_event, 1, 1, 0 /* +Given an event object as returned by `next-event', execute it. + +Key-press, button-press, and button-release events get accumulated +until a complete key sequence (see `read-key-sequence') is reached, +at which point the sequence is looked up in the current keymaps and +acted upon. + +Mouse motion events cause the low-level handling function stored in +`mouse-motion-handler' to be called. (There are very few circumstances +under which you should change this handler. Use `mode-motion-hook' +instead.) + +Menu, timeout, and eval events cause the associated function or handler +to be called. + +Process events cause the subprocess's output to be read and acted upon +appropriately (see `start-process'). + +Magic events are handled as necessary. +*/ ) + (event) + Lisp_Object event; +{ + /* This function can GC */ + struct command_builder *command_builder; + struct Lisp_Event *ev; + Lisp_Object console; + Lisp_Object channel; + + CHECK_LIVE_EVENT (event); + ev = XEVENT (event); + + /* events on dead channels get silently eaten */ + channel = EVENT_CHANNEL (ev); + if (object_dead_p (channel)) + return Qnil; + + /* Some events don't have channels (e.g. eval events). */ + console = CDFW_CONSOLE (channel); + if (NILP (console)) + console = Vselected_console; + else if (!EQ (console, Vselected_console)) + Fselect_console (console); + + command_builder = XCOMMAND_BUILDER (XCONSOLE (console)->command_builder); + switch (XEVENT (event)->event_type) + { + case button_press_event: + case button_release_event: + case key_press_event: + { + Lisp_Object leaf; + + leaf = lookup_command_event (command_builder, event, 1); + if (KEYMAPP (leaf)) + /* Incomplete key sequence */ + break; + if (NILP (leaf)) + { + /* At this point, we know that the sequence is not bound to a + command. Normally, we beep and print a message informing the + user of this. But we do not beep or print a message when: + + o the last event in this sequence is a mouse-up event; or + o the last event in this sequence is a mouse-down event and + there is a binding for the mouse-up version. + + That is, if the sequence ``C-x button1'' is typed, and is not + bound to a command, but the sequence ``C-x button1up'' is bound + to a command, we do not complain about the ``C-x button1'' + sequence. If neither ``C-x button1'' nor ``C-x button1up'' is + bound to a command, then we complain about the ``C-x button1'' + sequence, but later will *not* complain about the + ``C-x button1up'' sequence, which would be redundant. + + This is pretty hairy, but I think it's the most intuitive + behavior. + */ + Lisp_Object terminal = command_builder->most_current_event; + + if (XEVENT_TYPE (terminal) == button_press_event) + { + int no_bitching; + /* Temporarily pretend the last event was an "up" instead of a + "down", and look up its binding. */ + XEVENT_TYPE (terminal) = button_release_event; + /* If the "up" version is bound, don't complain. */ + no_bitching + = !NILP (command_builder_find_leaf + (command_builder, 0)); + /* Undo the temporary changes we just made. */ + XEVENT_TYPE (terminal) = button_press_event; + if (no_bitching) + { + /* Pretend this press was not seen (treat as a prefix) */ + if (EQ (command_builder->current_events, terminal)) + { + reset_current_events (command_builder); + } + else + { + Lisp_Object eve; + + EVENT_CHAIN_LOOP (eve, command_builder->current_events) + if (EQ (XEVENT_NEXT (eve), terminal)) + break; + + Fdeallocate_event (command_builder-> + most_current_event); + XSET_EVENT_NEXT (eve, Qnil); + command_builder->most_current_event = eve; + } + maybe_echo_keys (command_builder, 1); + break; + } + } + + /* Complain that the typed sequence is not defined, if this is the + kind of sequence that warrants a complaint. + */ + XCONSOLE (console)->defining_kbd_macro = Qnil; + XCONSOLE (console)->prefix_arg = Qnil; + /* Don't complain about undefined button-release events */ + if (XEVENT_TYPE (terminal) != button_release_event) + { + Lisp_Object keys = + current_events_into_vector (command_builder); + struct gcpro gcpro1; + + /* Run the pre-command-hook before barfing about an undefined + key. */ + Vthis_command = Qnil; + GCPRO1 (keys); + pre_command_hook (); + UNGCPRO; + /* The post-command-hook doesn't run. */ + Fsignal (Qundefined_keystroke_sequence, list1 (keys)); + } + /* Reset the command builder for reading the next sequence. */ + reset_this_command_keys (console, 1); + } + else + { + Vthis_command = leaf; + /* Don't push an undo boundary if the command set the prefix arg, + or if we are executing a keyboard macro, or if in the + minibuffer. If the command we are about to execute is + self-insert, it's tricky: up to 20 consecutive self-inserts may + be done without an undo boundary. This counter is reset as + soon as a command other than self-insert-command is executed. + */ + if (! EQ (leaf, Qself_insert_command)) + command_builder->self_insert_countdown = 0; + if (NILP (XCONSOLE (console)->prefix_arg) + && NILP (Vexecuting_macro) +#if 0 + /* This was done in the days when there was no undo + in the minibuffer. If we don't disable this code, + then each instance of "undo" undoes everything in + the minibuffer. */ + && !EQ (minibuf_window, Fselected_window (Qnil)) +#endif + && command_builder->self_insert_countdown == 0) + Fundo_boundary (); + + if (EQ (leaf, Qself_insert_command)) + { + if (--command_builder->self_insert_countdown < 0) + command_builder->self_insert_countdown = 20; + } + execute_command_event (command_builder, + !NILP (Fequal (event, + command_builder-> + most_current_event)) + ? event + /* Use the translated event that + was most recently seen. This way, + last-command-event becomes f1 + instead of the P from ESC O P. + But must copy it, else we'll lose + when the command-builder events + are deallocated. */ + : Fcopy_event (command_builder-> + most_current_event, Qnil)); + } + break; + } + case misc_user_event: + { + /* Jamie said: + + We could just always use the menu item entry, whatever it is, but + this might break some Lisp code that expects `this-command' to + always contain a symbol. So only store it if this is a simple + `call-interactively' sort of menu item. + + But this is bogus. `this-command' could be a string or vector + anyway (for keyboard macros). There's even one instance + (in pending-del.el) of `this-command' getting set to a cons + (a lambda expression). So in the `eval' case I'll just + convert it into a lambda expression. + */ + if (EQ (XEVENT (event)->event.eval.function, Qcall_interactively) + && SYMBOLP (XEVENT (event)->event.eval.object)) + Vthis_command = XEVENT (event)->event.eval.object; + else if (EQ (XEVENT (event)->event.eval.function, Qeval)) + Vthis_command = + Fcons (Qlambda, Fcons (Qnil, XEVENT (event)->event.eval.object)); + else if (SYMBOLP (XEVENT (event)->event.eval.function)) + /* A scrollbar command or the like. */ + Vthis_command = XEVENT (event)->event.eval.function; + else + /* Huh? */ + Vthis_command = Qnil; + + command_builder->self_insert_countdown = 0; + if (NILP (XCONSOLE (console)->prefix_arg) + && NILP (Vexecuting_macro) + && !EQ (minibuf_window, Fselected_window (Qnil))) + Fundo_boundary (); + execute_command_event (command_builder, event); + break; + } + default: + { + execute_internal_event (event); + break; + } + } + return (Qnil); +} + +DEFUN ("read-key-sequence", Fread_key_sequence, Sread_key_sequence, 1, 3, 0 /* +Read a sequence of keystrokes or mouse clicks. +Returns a vector of the event objects read. The vector and the event +objects it contains are freshly created (and will not be side-effected +by subsequent calls to this function). + +The sequence read is sufficient to specify a non-prefix command starting +from the current local and global keymaps. A C-g typed while in this +function is treated like any other character, and `quit-flag' is not set. + +First arg PROMPT is a prompt string. If nil, do not prompt specially. +Second (optional) arg CONTINUE-ECHO, if non-nil, means this key echos +as a continuation of the previous key. + +The third (optional) arg DONT-DOWNCASE-LAST, if non-nil, means do not +convert the last event to lower case. (Normally any upper case event +is converted to lower case if the original event is undefined and the lower +case equivalent is defined.) This argument is provided mostly for +FSF compatibility; the equivalent effect can be achieved more generally +by binding `retry-undefined-key-binding-unshifted' to nil around the +call to `read-key-sequence'. + +A C-g typed while in this function is treated like any other character, +and `quit-flag' is not set. + +If the user selects a menu item while we are prompting for a key-sequence, +the returned value will be a vector of a single menu-selection event. +An error will be signalled if you pass this value to `lookup-key' or a +related function. + +`read-key-sequence' checks `function-key-map' for function key +sequences, where they wouldn't conflict with ordinary bindings. See +`function-key-map' for more details. +*/ ) + (prompt, continue_echo, dont_downcase_last) + Lisp_Object prompt, continue_echo, dont_downcase_last; +{ + /* This function can GC */ + struct console *con = XCONSOLE (Vselected_console); /* #### correct? + Probably not -- see + comment in + next-event */ + struct command_builder *command_builder = + XCOMMAND_BUILDER (con->command_builder); + Lisp_Object result; + Lisp_Object event = Fmake_event (); + int speccount = specpdl_depth (); + struct gcpro gcpro1; + GCPRO1 (event); + + if (!NILP (prompt)) + CHECK_STRING (prompt); + /* else prompt = Fkeymap_prompt (current_buffer->keymap); may GC */ + QUIT; + + if (NILP (continue_echo)) + reset_this_command_keys (make_console (con), 1); + + specbind (Qinhibit_quit, Qt); + + if (!NILP (dont_downcase_last)) + specbind (Qretry_undefined_key_binding_unshifted, Qnil); + + for (;;) + { + Fnext_event (event, prompt); + /* restore the selected-console damage */ + con = event_console_or_selected (event); + command_builder = XCOMMAND_BUILDER (con->command_builder); + if (! command_event_p (event)) + execute_internal_event (event); + else + { + if (XEVENT (event)->event_type == misc_user_event) + reset_current_events (command_builder); + result = lookup_command_event (command_builder, event, 1); + if (!KEYMAPP (result)) + { + result = current_events_into_vector (command_builder); + reset_key_echo (command_builder, 0); + break; + } + prompt = Qnil; + } + } + + Vquit_flag = Qnil; /* In case we read a ^G; do not call check_quit() here */ + Fdeallocate_event (event); + RETURN_UNGCPRO (unbind_to (speccount, result)); +} + +DEFUN ("this-command-keys", Fthis_command_keys, Sthis_command_keys, 0, 0, 0 /* +Return a vector of the keyboard or mouse button events that were used +to invoke this command. This copies the vector and the events; it is safe +to keep and modify them. +*/ ) + () +{ + Lisp_Object event; + Lisp_Object result; + int len; + + if (NILP (Vthis_command_keys)) + return (make_vector (0, Qnil)); + + len = event_chain_count (Vthis_command_keys); + + result = make_vector (len, Qnil); + len = 0; + EVENT_CHAIN_LOOP (event, Vthis_command_keys) + vector_data (XVECTOR (result))[len++] = Fcopy_event (event, Qnil); + return (result); +} + +DEFUN ("reset-this-command-lengths", Freset_this_command_lengths, + Sreset_this_command_lengths, 0, 0, 0 /* +Used for complicated reasons in `universal-argument-other-key'. + +`universal-argument-other-key' rereads the event just typed. +It then gets translated through `function-key-map'. +The translated event gets included in the echo area and in +the value of `this-command-keys' in addition to the raw original event. +That is not right. + +Calling this function directs the translated event to replace +the original event, so that only one version of the event actually +appears in the echo area and in the value of `this-command-keys.'. +*/ ) + () +{ + /* #### I don't understand this at all, so currently it does nothing. + If there is ever a problem, maybe someone should investigate. */ + return Qnil; +} + + +static void +dribble_out_event (Lisp_Object event) +{ + if (NILP (Vdribble_file)) + return; + + if (XEVENT (event)->event_type == key_press_event && + !XEVENT (event)->event.key.modifiers) + { + Lisp_Object keysym = XEVENT (event)->event.key.keysym; + if (CHARP (XEVENT (event)->event.key.keysym)) + { + Emchar ch = XCHAR (keysym); + Bufbyte str[MAX_EMCHAR_LEN]; + Bytecount len; + + len = set_charptr_emchar (str, ch); + Lstream_write (XLSTREAM (Vdribble_file), str, len); + } + else if (string_char_length (XSYMBOL (keysym)->name) == 1) + /* one-char key events are printed with just the key name */ + Fprinc (keysym, Vdribble_file); + else if (EQ (keysym, Qreturn)) + Lstream_putc (XLSTREAM (Vdribble_file), '\n'); + else if (EQ (keysym, Qspace)) + Lstream_putc (XLSTREAM (Vdribble_file), ' '); + else + Fprinc (event, Vdribble_file); + } + else + Fprinc (event, Vdribble_file); + Lstream_flush (XLSTREAM (Vdribble_file)); +} + +DEFUN ("open-dribble-file", Fopen_dribble_file, Sopen_dribble_file, 1, 1, + "FOpen dribble file: " /* +Start writing all keyboard characters to a dribble file called FILE. +If FILE is nil, close any open dribble file. +*/ ) + (file) + Lisp_Object file; +{ + /* This function can GC */ + /* XEmacs change: always close existing dribble file. */ + /* FSFmacs uses FILE *'s here. With lstreams, that's unnecessary. */ + if (!NILP (Vdribble_file)) + { + Lstream_close (XLSTREAM (Vdribble_file)); + Vdribble_file = Qnil; + } + if (!NILP (file)) + { + int fd; + + file = Fexpand_file_name (file, Qnil); + fd = creat ((char *) string_data (XSTRING (file)), 0666); + if (fd < 0) + error ("Unable to create dribble file"); + Vdribble_file = make_filedesc_output_stream (fd, 0, 0, LSTR_CLOSING); + } + return Qnil; +} + + +/************************************************************************/ +/* initialization */ +/************************************************************************/ + +void +syms_of_event_stream (void) +{ + defsymbol (&Qdisabled, "disabled"); + defsymbol (&Qcommand_event_p, "command-event-p"); + + deferror (&Qundefined_keystroke_sequence, "undefined-keystroke-sequence", + "Undefined keystroke sequence", Qerror); + defsymbol (&Qcommand_execute, "command-execute"); + + defsubr (&Srecent_keys); + defsubr (&Sinput_pending_p); + defsubr (&Senqueue_eval_event); + defsubr (&Snext_event); + defsubr (&Snext_command_event); + defsubr (&Sdiscard_input); + defsubr (&Ssit_for); + defsubr (&Ssleep_for); + defsubr (&Saccept_process_output); + defsubr (&Sadd_timeout); + defsubr (&Sdisable_timeout); + defsubr (&Sadd_async_timeout); + defsubr (&Sdisable_async_timeout); + defsubr (&Sdispatch_event); + defsubr (&Sread_key_sequence); + defsubr (&Sthis_command_keys); + defsubr (&Sreset_this_command_lengths); + defsubr (&Sopen_dribble_file); + + defsymbol (&Qpre_command_hook, "pre-command-hook"); + defsymbol (&Qpost_command_hook, "post-command-hook"); + defsymbol (&Qunread_command_events, "unread-command-events"); + defsymbol (&Qunread_command_event, "unread-command-event"); + defsymbol (&Qpre_idle_hook, "pre-idle-hook"); +#ifdef ILL_CONCEIVED_HOOK + defsymbol (&Qpost_command_idle_hook, "post-command-idle-hook"); +#endif +#ifdef DEFERRED_ACTION_CRAP + defsymbol (&Qdeferred_action_function, "deferred-action-function"); +#endif + defsymbol (&Qretry_undefined_key_binding_unshifted, + "retry-undefined-key-binding-unshifted"); + defsymbol (&Qauto_show_make_point_visible, + "auto-show-make-point-visible"); +} + +void +vars_of_event_stream (void) +{ +#ifdef HAVE_X_WINDOWS + vars_of_event_Xt (); +#endif +#if defined (DEBUG_TTY_EVENT_STREAM) || !defined (HAVE_X_WINDOWS) + vars_of_event_tty (); +#endif +#ifdef HAVE_NEXTSTEP + vars_of_event_ns (); +#endif + + + recent_keys_ring_index = 0; + recent_keys_ring = make_vector (RECENT_KEYS_SIZE, Qnil); + staticpro (&recent_keys_ring); + + Vthis_command_keys = Qnil; + staticpro (&Vthis_command_keys); + Vthis_command_keys_tail = Qnil; + + num_input_chars = 0; + + command_event_queue = Qnil; + staticpro (&command_event_queue); + command_event_queue_tail = Qnil; + + Vlast_selected_frame = Qnil; + staticpro (&Vlast_selected_frame); + + pending_timeout_list = Qnil; + staticpro (&pending_timeout_list); + + pending_async_timeout_list = Qnil; + staticpro (&pending_async_timeout_list); + + Vtimeout_free_list = make_opaque_list (sizeof (struct timeout), + mark_timeout); + staticpro (&Vtimeout_free_list); + + the_low_level_timeout_blocktype = + Blocktype_new (struct low_level_timeout_blocktype); + + something_happened = 0; + + last_point_position_buffer = Qnil; + staticpro (&last_point_position_buffer); + + DEFVAR_INT ("echo-keystrokes", &echo_keystrokes /* +*Nonzero means echo unfinished commands after this many seconds of pause. +*/ ); + echo_keystrokes = 1; + + DEFVAR_INT ("auto-save-interval", &auto_save_interval /* +*Number of keyboard input characters between auto-saves. +Zero means disable autosaving due to number of characters typed. +See also the variable `auto-save-timeout'. +*/ ); + auto_save_interval = 300; + + DEFVAR_LISP ("pre-command-hook", &Vpre_command_hook /* +Function or functions to run before every command. +This may examine the `this-command' variable to find out what command +is about to be run, or may change it to cause a different command to run. +Function on this hook must be careful to avoid signalling errors! +*/ ); + Vpre_command_hook = Qnil; + + DEFVAR_LISP ("post-command-hook", &Vpost_command_hook /* +Function or functions to run after every command. +This may examine the `this-command' variable to find out what command +was just executed. +*/ ); + Vpost_command_hook = Qnil; + + DEFVAR_LISP ("pre-idle-hook", &Vpre_idle_hook /* +Normal hook run when XEmacs it about to be idle. +This occurs whenever it is going to block, waiting for an event. +This generally happens as a result of a call to `next-event', +`next-command-event', `sit-for', `sleep-for', `accept-process-output', +`x-get-selection', or various Energize-specific commands. +Errors running the hook are caught and ignored. +*/ ); + Vpre_idle_hook = Qnil; + +#ifdef ILL_CONCEIVED_HOOK + /* Ill-conceived because it's not run in all sorts of cases + where XEmacs is blocking. That's what `pre-idle-hook' + is designed to solve. */ + xxDEFVAR_LISP ("post-command-idle-hook", &Vpost_command_idle_hook /* +Normal hook run after each command is executed, if idle. +`post-command-idle-delay' specifies a time in microseconds that XEmacs +must be idle for in order for the functions on this hook to be called. +Errors running the hook are caught and ignored. +*/ ); + Vpost_command_idle_hook = Qnil; + + xxDEFVAR_INT ("post-command-idle-delay", &post_command_idle_delay /* +Delay time before running `post-command-idle-hook'. +This is measured in microseconds. +*/ ); + post_command_idle_delay = 5000; +#endif /* ILL_CONCEIVED_HOOK */ + +#ifdef DEFERRED_ACTION_CRAP + /* Random FSFmacs crap. There is absolutely nothing to gain, + and a great deal to lose, in using this in place of just + setting `post-command-hook'. */ + xxDEFVAR_LISP ("deferred-action-list", &Vdeferred_action_list /* +List of deferred actions to be performed at a later time. +The precise format isn't relevant here; we just check whether it is nil. +*/ ); + Vdeferred_action_list = Qnil; + + xxDEFVAR_LISP ("deferred-action-function", &Vdeferred_action_function /* +Function to call to handle deferred actions, after each command. +This function is called with no arguments after each command +whenever `deferred-action-list' is non-nil. +*/ ); + Vdeferred_action_function = Qnil; +#endif /* DEFERRED_ACTION_CRAP */ + + DEFVAR_LISP ("last-command-event", &Vlast_command_event /* +Last keyboard or mouse button event that was part of a command. This +variable is off limits: you may not set its value or modify the event that +is its value, as it is destructively modified by `read-key-sequence'. If +you want to keep a pointer to this value, you must use `copy-event'. +*/ ); + Vlast_command_event = Qnil; + + DEFVAR_LISP ("last-command-char", &Vlast_command_char /* +If the value of `last-command-event' is a keyboard event, then +this is the nearest ASCII equivalent to it. This the the value that +`self-insert-command' will put in the buffer. Remember that there is +NOT a 1:1 mapping between keyboard events and ASCII characters: the set +of keyboard events is much larger, so writing code that examines this +variable to determine what key has been typed is bad practice, unless +you are certain that it will be one of a small set of characters. +*/ ); + Vlast_command_char = Qnil; + + DEFVAR_LISP ("last-input-event", &Vlast_input_event /* +Last keyboard or mouse button event received. This variable is off +limits: you may not set its value or modify the event that is its value, as +it is destructively modified by `next-event'. If you want to keep a pointer +to this value, you must use `copy-event'. +*/ ); + Vlast_input_event = Qnil; + + DEFVAR_LISP ("current-mouse-event", &Vcurrent_mouse_event /* +The mouse-button event which invoked this command, or nil. +This is usually what `(interactive \"e\")' returns. +*/ ); + Vcurrent_mouse_event = Qnil; + + DEFVAR_LISP ("last-input-char", &Vlast_input_char /* +If the value of `last-input-event' is a keyboard event, then +this is the nearest ASCII equivalent to it. Remember that there is +NOT a 1:1 mapping between keyboard events and ASCII characters: the set +of keyboard events is much larger, so writing code that examines this +variable to determine what key has been typed is bad practice, unless +you are certain that it will be one of a small set of characters. +*/ ); + Vlast_input_char = Qnil; + + DEFVAR_LISP ("last-input-time", &Vlast_input_time /* +The time (in seconds since Jan 1, 1970) of the last-command-event, +represented as a cons of two 16-bit integers. This is destructively +modified, so copy it if you want to keep it. +*/ ); + Vlast_input_time = Qnil; + + DEFVAR_LISP ("unread-command-events", &Vunread_command_events /* +List of event objects to be read as next command input events. +This can be used to simulate the receipt of events from the user. +Normally this is nil. +Events are removed from the front of this list. +*/ ); + Vunread_command_events = Qnil; + + DEFVAR_LISP ("unread-command-event", &Vunread_command_event /* +Obsolete. Use `unread-command-events' instead. +*/ ); + Vunread_command_event = Qnil; + + DEFVAR_LISP ("last-command", &Vlast_command /* +The last command executed. Normally a symbol with a function definition, +but can be whatever was found in the keymap, or whatever the variable +`this-command' was set to by that command. +*/ ); + Vlast_command = Qnil; + + DEFVAR_LISP ("this-command", &Vthis_command /* +The command now being executed. +The command can set this variable; whatever is put here +will be in `last-command' during the following command. +*/ ); + Vthis_command = Qnil; + + DEFVAR_LISP ("help-char", &Vhelp_char /* +Character to recognize as meaning Help. +When it is read, do `(eval help-form)', and display result if it's a string. +If the value of `help-form' is nil, this char can be read normally. +This can be any form recognized as a single key specifier. +To disable the help-char, set it to a negative number. +*/ ); + Vhelp_char = make_char (8); /* C-h */ + + DEFVAR_LISP ("help-form", &Vhelp_form /* +Form to execute when character help-char is read. +If the form returns a string, that string is displayed. +If `help-form' is nil, the help char is not recognized. +*/ ); + Vhelp_form = Qnil; + + DEFVAR_LISP ("prefix-help-command", &Vprefix_help_command /* +Command to run when `help-char' character follows a prefix key. +This command is used only when there is no actual binding +for that character after that prefix key. +*/ ); + Vprefix_help_command = Qnil; + + DEFVAR_CONST_LISP ("keyboard-translate-table", &Vkeyboard_translate_table /* +Hash table used as translate table for keyboard input. +Use `keyboard-translate' to portably add entries to this table. +Each key-press event is looked up in this table as follows: + +-- If an entry maps a symbol to a symbol, then a key-press event whose + keysym is the former symbol (with any modifiers at all) gets its + keysym changed and its modifiers left alone. This is useful for + dealing with non-standard X keyboards, such as the grievous damage + that Sun has inflicted upon the world. +-- If an entry maps a character to a character, then a key-press event + matching the former character gets converted to a key-press event + matching the latter character. This is useful on ASCII terminals + for (e.g.) making C-\\ look like C-s, to get around flow-control + problems. +-- If an entry maps a character to a symbol, then a key-press event + matching the character gets converted to a key-press event whose + keysym is the given symbol and which has no modifiers. +*/ ); + + DEFVAR_LISP ("retry-undefined-key-binding-unshifted", + &Vretry_undefined_key_binding_unshifted /* +If a key-sequence which ends with a shifted keystroke is undefined +and this variable is non-nil then the command lookup is retried again +with the last key unshifted. (e.g. C-X C-F would be retried as C-X C-f.) +If lookup still fails, a normal error is signalled. In general, +you should *bind* this, not set it. +*/ ); + Vretry_undefined_key_binding_unshifted = Qt; + + Vcontrolling_terminal = Qnil; + staticpro (&Vcontrolling_terminal); + + Vdribble_file = Qnil; + staticpro (&Vdribble_file); + +#ifdef DEBUG_XEMACS + DEFVAR_INT ("debug-emacs-events", &debug_emacs_events /* +If non-zero, display debug information about Emacs events that XEmacs sees. +Information is displayed on stderr. + +Before the event, the source of the event is displayed in parentheses, +and is one of the following: + +\(real) A real event from the window system or + terminal driver, as far as XEmacs can tell. + +\(keyboard macro) An event generated from a keyboard macro. + +\(unread-command-events) An event taken from `unread-command-events'. + +\(unread-command-event) An event taken from `unread-command-event'. + +\(command event queue) An event taken from an internal queue. + Events end up on this queue when + `enqueue-eval-event' is called or when + user or eval events are received while + XEmacs is blocking (e.g. in `sit-for', + `sleep-for', or `accept-process-output', + or while waiting for the reply to an + X selection). + +\(->keyboard-translate-table) The result of an event translated through + keyboard-translate-table. Note that in + this case, two events are printed even + though only one is really generated. + +\(SIGINT) A faked C-g resulting when XEmacs receives + a SIGINT (e.g. C-c was pressed in XEmacs' + controlling terminal or the signal was + explicitly sent to the XEmacs process). +*/ ); + debug_emacs_events = 0; +#endif +} + +void +complex_vars_of_event_stream (void) +{ + Vkeyboard_translate_table = Fmake_hashtable (make_int (100), Qnil); +} + +void +init_event_stream (void) +{ + if (initialized) + { +#ifdef HAVE_UNIXOID_EVENT_LOOP + init_event_unixoid (); +#endif + +#ifdef HAVE_X_WINDOWS + if (!strcmp (display_use, "x")) + init_event_Xt_late (); + else +#endif +#ifdef HAVE_NEXTSTEP + if (!strcmp (display_use, "ns")) + init_event_ns_late (); + else +#endif + { + /* For TTY's, use the Xt event loop if we can; it allows + us to later open an X connection. */ +#if defined (HAVE_X_WINDOWS) && !defined (DEBUG_TTY_EVENT_STREAM) + init_event_Xt_late (); +#else + init_event_tty_late (); +#endif + } + init_interrupts_late (); + } +} + + +/* +useful testcases for v18/v19 compatibility: + +(defun foo () + (interactive) + (setq unread-command-event (character-to-event ?A (allocate-event))) + (setq x (list (read-char) +; (read-key-sequence "") ; try it with and without this + last-command-char last-input-char + (recent-keys) (this-command-keys)))) +(global-set-key "\^Q" 'foo) + +without the read-key-sequence: + ^Q ==> (65 17 65 [... ^Q] [^Q]) + ^U^U^Q ==> (65 17 65 [... ^U ^U ^Q] [^U ^U ^Q]) + ^U^U^U^G^Q ==> (65 17 65 [... ^U ^U ^U ^G ^Q] [^Q]) + +with the read-key-sequence: + ^Qb ==> (65 [b] 17 98 [... ^Q b] [b]) + ^U^U^Qb ==> (65 [b] 17 98 [... ^U ^U ^Q b] [b]) + ^U^U^U^G^Qb ==> (65 [b] 17 98 [... ^U ^U ^U ^G ^Q b] [b]) + +;the evi-mode command "4dlj.j.j.j.j.j." is also a good testcase (gag) + +;(setq x (list (read-char) quit-flag))^J^G +;(let ((inhibit-quit t)) (setq x (list (read-char) quit-flag)))^J^G +;for BOTH, x should get set to (7 t), but no result should be printed. + +;also do this: make two frames, one viewing "*scratch*", the other "foo". +;in *scratch*, type (sit-for 20)^J +;wait a couple of seconds, move cursor to foo, type "a" +;a should be inserted in foo. Cursor highlighting should not change in +;the meantime. + +;do it with sleep-for. move cursor into foo, then back into *scratch* +;before typing. + +;make sure ^G aborts both sit-for and sleep-for. + + (defun tst () + (list (condition-case c + (sleep-for 20) + (quit c)) + (read-char))) + + (tst)^Ja^G ==> ((quit) 97) with no signal + (tst)^J^Ga ==> ((quit) 97) with no signal + (tst)^Jabc^G ==> ((quit) 97) with no signal, and "bc" inserted in buffer + +Do this: + (setq enable-recursive-minibuffers t + minibuffer-max-depth nil) + ESC ESC ESC ESC - there are now two minibuffers active + C-g C-g C-g - there should be active 0, not 1 +Similarly: + C-x C-f ~ / ? - wait for "Making completion list..." to display + C-g - wait for "Quit" to display + C-g - minibuffer should not be active +however C-g before "Quit" is displayed should leave minibuffer active. + +;do it all in both v18 and v19 and make sure all results are the same. +;all of these cases matter a lot, but some in quite subtle ways. +*/