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