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