update.
[chise/xemacs-chise.git.1] / src / cmdloop.c
1 /* Editor command loop.
2    Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc.
3    Copyright (C) 1995, 1996 Ben Wing.
4
5 This file is part of XEmacs.
6
7 XEmacs is free software; you can redistribute it and/or modify it
8 under the terms of the GNU General Public License as published by the
9 Free Software Foundation; either version 2, or (at your option) any
10 later version.
11
12 XEmacs is distributed in the hope that it will be useful, but WITHOUT
13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
15 for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with XEmacs; see the file COPYING.  If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA.  */
21
22 /* Synched up with: Mule 2.0.  Not synched with FSF.
23    This was renamed from keyboard.c.  However, it only contains the
24    command-loop stuff from FSF's keyboard.c; all the rest is in
25    event*.c, console.c, or signal.c. */
26
27 /* #### This module purports to separate out the command-loop stuff
28    from event-stream.c, but it doesn't really.  Perhaps this file
29    should just be merged into event-stream.c, given its shortness. */
30
31 #include <config.h>
32 #include "lisp.h"
33
34 #include "buffer.h"
35 #include "commands.h"
36 #include "frame.h"
37 #include "events.h"
38 #include "window.h"
39
40 /* Current depth in recursive edits.  */
41 Fixnum command_loop_level;
42
43 #ifndef LISP_COMMAND_LOOP
44 /* Form to evaluate (if non-nil) when Emacs is started.  */
45 Lisp_Object Vtop_level;
46 #else
47 /* Function to call to evaluate to read and process events.  */
48 Lisp_Object Vcommand_loop;
49 #endif /* LISP_COMMAND_LOOP */
50
51 Lisp_Object Venter_window_hook, Vleave_window_hook;
52
53 /* The error handler.  */
54 Lisp_Object Qcommand_error;
55
56 /* The emergency error handler, before we're ready.  */
57 Lisp_Object Qreally_early_error_handler;
58
59 /* Variable defined in Lisp. */
60 Lisp_Object Qerrors_deactivate_region;
61
62 Lisp_Object Qtop_level;
63
64 static Lisp_Object command_loop_1 (Lisp_Object dummy);
65 EXFUN (Fcommand_loop_1, 0);
66
67 /* There are two possible command loops -- one written entirely in
68    C and one written mostly in Lisp, except stuff written in C for
69    speed.  The advantage of the Lisp command loop is that the user
70    can specify their own command loop to use by changing the variable
71    `command-loop'.  Its disadvantage is that it's slow. */
72
73 static Lisp_Object
74 default_error_handler (Lisp_Object data)
75 {
76   int speccount = specpdl_depth ();
77
78   /* None of this is invoked, normally.  This code is almost identical
79      to the `command-error' function, except `command-error' does cool
80      tricks with sounds.  This function is a fallback, invoked if
81      command-error is unavailable.  */
82
83   Fding (Qnil, Qnil, Qnil);
84
85   if (!NILP (Fboundp (Qerrors_deactivate_region))
86       && !NILP (Fsymbol_value (Qerrors_deactivate_region)))
87     zmacs_deactivate_region ();
88   Fdiscard_input ();
89   specbind (Qinhibit_quit, Qt);
90   Vstandard_output = Qt;
91   Vstandard_input = Qt;
92   Vexecuting_macro = Qnil;
93   Fset (intern ("last-error"), data);
94   clear_echo_area (selected_frame (), Qnil, 0);
95   Fdisplay_error (data, Qt);
96   check_quit (); /* make Vquit_flag accurate */
97   Vquit_flag = Qnil;
98   return (unbind_to (speccount, Qt));
99 }
100
101 DEFUN ("really-early-error-handler", Freally_early_error_handler, 1, 1, 0, /*
102 You should almost certainly not be using this.
103 */
104        (x))
105 {
106   /* This is an error handler used when we're running temacs and when
107      we're in the early stages of XEmacs.  No errors ought to be
108      occurring in those cases (or they ought to be trapped and
109      dealt with elsewhere), but if an error slips through, we need
110      to deal with it.  We could write this function in Lisp (and it
111      used to be this way, at the beginning of loadup.el), but we do
112      it this way in case an error occurs before we get to loading
113      loadup.el.  Note that there is also an `early-error-handler',
114      used in startup.el to catch more reasonable errors that
115      might occur during startup if the sysadmin or whoever fucked
116      up.  This function is more conservative in what it does
117      and is used only as a last resort, indicating that the
118      programmer himself fucked up somewhere. */
119   stderr_out ("*** Error in XEmacs initialization");
120   Fprint (x, Qexternal_debugging_output);
121   stderr_out ("*** Backtrace\n");
122   Fbacktrace (Qexternal_debugging_output, Qt);
123   stderr_out ("*** Killing XEmacs\n");
124 #ifdef HAVE_MS_WINDOWS
125   Fmswindows_message_box (build_string ("Initialization error"),
126                           Qnil, Qnil);
127 #endif
128   return Fkill_emacs (make_int (-1));
129 }
130
131 \f
132 /**********************************************************************/
133 /*                     Command-loop (in C)                            */
134 /**********************************************************************/
135
136 #ifndef LISP_COMMAND_LOOP
137
138 /* The guts of the command loop are in command_loop_1().  This function
139    doesn't catch errors, though -- that's the job of command_loop_2(),
140    which is a condition-case wrapper around command_loop_1().
141    command_loop_1() never returns, but may get thrown out of.
142
143    When an error occurs, cmd_error() is called, which usually
144    invokes the Lisp error handler in `command-error'; however,
145    a default error handler is provided if `command-error' is nil
146    (e.g. during startup).  The purpose of the error handler is
147    simply to display the error message and do associated cleanup;
148    it does not need to throw anywhere.  When the error handler
149    finishes, the condition-case in command_loop_2() will finish and
150    command_loop_2() will reinvoke command_loop_1().
151
152    command_loop_2() is invoked from three places: from
153    initial_command_loop() (called from main() at the end of
154    internal initialization), from the Lisp function `recursive-edit',
155    and from call_command_loop().
156
157    call_command_loop() is called when a macro is started and when the
158    minibuffer is entered; normal termination of the macro or
159    minibuffer causes a throw out of the recursive command loop. (To
160    'execute-kbd-macro for macros and 'exit for minibuffers.  Note also
161    that the low-level minibuffer-entering function,
162    `read-minibuffer-internal', provides its own error handling and
163    does not need command_loop_2()'s error encapsulation; so it tells
164    call_command_loop() to invoke command_loop_1() directly.)
165
166    Note that both read-minibuffer-internal and recursive-edit set
167    up a catch for 'exit; this is why `abort-recursive-edit', which
168    throws to this catch, exits out of either one.
169
170    initial_command_loop(), called from main(), sets up a catch
171    for 'top-level when invoking command_loop_2(), allowing functions
172    to throw all the way to the top level if they really need to.
173    Before invoking command_loop_2(), initial_command_loop() calls
174    top_level_1(), which handles all of the startup stuff (creating
175    the initial frame, handling the command-line options, loading
176    the user's .emacs file, etc.).  The function that actually does this
177    is in Lisp and is pointed to by the variable `top-level';
178    normally this function is `normal-top-level'.  top_level_1() is
179    just an error-handling wrapper similar to command_loop_2().
180    Note also that initial_command_loop() sets up a catch for 'top-level
181    when invoking top_level_1(), just like when it invokes
182    command_loop_2(). */
183
184
185 static Lisp_Object
186 cmd_error (Lisp_Object data, Lisp_Object dummy)
187 {
188   /* This function can GC */
189   check_quit (); /* make Vquit_flag accurate */
190   Vquit_flag = Qnil;
191
192   any_console_state ();
193
194   if (!NILP (Ffboundp (Qcommand_error)))
195     return call1 (Qcommand_error, data);
196
197   return default_error_handler (data);
198 }
199
200 static Lisp_Object
201 top_level_1 (Lisp_Object dummy)
202 {
203   /* This function can GC */
204   /* On entry to the outer level, run the startup file */
205   if (!NILP (Vtop_level))
206     condition_case_1 (Qerror, Feval, Vtop_level, cmd_error, Qnil);
207 #if 1
208   else
209     {
210       message ("\ntemacs can only be run in -batch mode.");
211       noninteractive = 1; /* prevent things under kill-emacs from blowing up */
212       Fkill_emacs (make_int (-1));
213     }
214 #else
215   else if (purify_flag)
216     message ("Bare impure Emacs (standard Lisp code not loaded)");
217   else
218     message ("Bare Emacs (standard Lisp code not loaded)");
219 #endif
220
221   return Qnil;
222 }
223
224 /* Here we catch errors in execution of commands within the
225    editing loop, and reenter the editing loop.
226    When there is an error, cmd_error runs and the call
227    to condition_case_1() returns. */
228
229 /* Avoid confusing the compiler. A helper function for command_loop_2 */
230 static DOESNT_RETURN
231 command_loop_3 (void)
232 {
233 #ifdef LWLIB_MENUBARS_LUCID
234   extern int in_menu_callback;  /* defined in menubar-x.c */
235 #endif /* LWLIB_MENUBARS_LUCID */
236
237 #ifdef LWLIB_MENUBARS_LUCID
238   /*
239    * #### Fix the menu code so this isn't necessary.
240    *
241    * We cannot allow the lwmenu code to be reentered, because the
242    * code is not written to be reentrant and will crash.  Therefore
243    * paths from the menu callbacks back into the menu code have to
244    * be blocked.  Fnext_event is the normal path into the menu code,
245    * but waiting to signal an error there is too late in case where
246    * a new command loop has been started.  The error will be caught
247    * and Fnext_event will be called again, looping forever.  So we
248    * signal an error here to avoid the loop.
249    */
250   if (in_menu_callback)
251     error ("Attempt to enter command_loop_3 inside menu callback");
252 #endif /* LWLIB_MENUBARS_LUCID */
253   /* This function can GC */
254   for (;;)
255     {
256       condition_case_1 (Qerror, command_loop_1, Qnil, cmd_error, Qnil);
257       /* #### wrong with selected-console? */
258       /* See command in initial_command_loop about why this value
259          is 0. */
260       reset_this_command_keys (Vselected_console, 0);
261     }
262 }
263
264 static Lisp_Object
265 command_loop_2 (Lisp_Object dummy)
266 {
267   command_loop_3(); /* doesn't return */
268   return Qnil;
269 }
270
271 /* This is called from emacs.c when it's done with initialization. */
272
273 DOESNT_RETURN
274 initial_command_loop (Lisp_Object load_me)
275 {
276   /* This function can GC */
277   if (!NILP (load_me))
278     Vtop_level = list2 (Qload, load_me);
279
280   /* First deal with startup and command-line arguments.  A throw
281      to 'top-level gets us back here directly (does this ever happen?).
282      Otherwise, this function will return normally when all command-
283      line arguments have been processed, the user's initialization
284      file has been read in, and the first frame has been created. */
285   internal_catch (Qtop_level, top_level_1, Qnil, 0);
286
287   /* If an error occurred during startup and the initial console
288      wasn't created, then die now (the error was already printed out
289      on the terminal device). */
290   if (!noninteractive &&
291       (!CONSOLEP (Vselected_console) ||
292        CONSOLE_STREAM_P (XCONSOLE (Vselected_console))))
293     Fkill_emacs (make_int (-1));
294
295   /* End of -batch run causes exit here. */
296   if (noninteractive)
297     Fkill_emacs (Qt);
298
299   for (;;)
300     {
301       command_loop_level = 0;
302       MARK_MODELINE_CHANGED;
303       /* Now invoke the command loop.  It never returns; however, a
304          throw to 'top-level will place us at the end of this loop. */
305       internal_catch (Qtop_level, command_loop_2, Qnil, 0);
306       /* #### wrong with selected-console? */
307       /* We don't actually call clear_echo_area() here, partially
308          at least because that runs Lisp code and it may be unsafe
309          to do so -- we are outside of the normal catches for
310          errors and such. */
311       reset_this_command_keys (Vselected_console, 0);
312     }
313 }
314
315 /* This function is invoked when a macro or minibuffer starts up.
316    Normal termination of the macro or minibuffer causes a throw past us.
317    See the comment above.
318
319    Note that this function never returns (but may be thrown out of). */
320
321 Lisp_Object
322 call_command_loop (Lisp_Object catch_errors)
323 {
324   /* This function can GC */
325   if (NILP (catch_errors))
326     return (command_loop_1 (Qnil));
327   else
328     return (command_loop_2 (Qnil));
329 }
330
331 static Lisp_Object
332 recursive_edit_unwind (Lisp_Object buffer)
333 {
334   if (!NILP (buffer))
335     Fset_buffer (buffer);
336
337   command_loop_level--;
338   MARK_MODELINE_CHANGED;
339
340   return Qnil;
341 }
342
343 DEFUN ("recursive-edit", Frecursive_edit, 0, 0, "", /*
344 Invoke the editor command loop recursively.
345 To get out of the recursive edit, a command can do `(throw 'exit nil)';
346 that tells this function to return.
347 Alternately, `(throw 'exit t)' makes this function signal an error.
348 */
349        ())
350 {
351   /* This function can GC */
352   Lisp_Object val;
353   int speccount = specpdl_depth ();
354
355   command_loop_level++;
356   MARK_MODELINE_CHANGED;
357
358   record_unwind_protect (recursive_edit_unwind,
359                          ((current_buffer
360                            != XBUFFER (XWINDOW (Fselected_window
361                                                 (Qnil))->buffer))
362                           ? Fcurrent_buffer ()
363                           : Qnil));
364
365   specbind (Qstandard_output, Qt);
366   specbind (Qstandard_input, Qt);
367
368   val = internal_catch (Qexit, command_loop_2, Qnil, 0);
369
370   if (EQ (val, Qt))
371     /* Turn abort-recursive-edit into a quit. */
372     Fsignal (Qquit, Qnil);
373
374   return unbind_to (speccount, Qnil);
375 }
376
377 #endif /* !LISP_COMMAND_LOOP */
378
379 \f
380 /**********************************************************************/
381 /*             Alternate command-loop (largely in Lisp)               */
382 /**********************************************************************/
383
384 #ifdef LISP_COMMAND_LOOP
385
386 static Lisp_Object
387 load1 (Lisp_Object name)
388 {
389   /* This function can GC */
390   call4 (Qload, name, Qnil, Qt, Qnil);
391   return (Qnil);
392 }
393
394 /* emergency backups for cold-load-stream use */
395 static Lisp_Object
396 cold_load_command_error (Lisp_Object datum, Lisp_Object ignored)
397 {
398   /* This function can GC */
399   check_quit (); /* make Vquit_flag accurate */
400   Vquit_flag = Qnil;
401
402   return default_error_handler (datum);
403 }
404
405 static Lisp_Object
406 cold_load_command_loop (Lisp_Object dummy)
407 {
408   /* This function can GC */
409   return (condition_case_1 (Qt,
410                             command_loop_1, Qnil,
411                             cold_load_command_error, Qnil));
412 }
413
414 Lisp_Object
415 call_command_loop (Lisp_Object catch_errors)
416 {
417   /* This function can GC */
418   reset_this_command_keys (Vselected_console, 0); /* #### bleagh */
419
420  loop:
421   for (;;)
422     {
423       if (NILP (Vcommand_loop))
424         break;
425       call1 (Vcommand_loop, catch_errors);
426     }
427
428   /* This isn't a "correct" definition, but you're pretty hosed if
429      you broke "command-loop" anyway */
430   /* #### not correct with Vselected_console */
431   XCONSOLE (Vselected_console)->prefix_arg = Qnil;
432   if (NILP (catch_errors))
433     Fcommand_loop_1 ();
434   else
435     internal_catch (Qtop_level,
436                     cold_load_command_loop, Qnil, 0);
437   goto loop;
438   return Qnil;
439 }
440
441 static Lisp_Object
442 initial_error_handler (Lisp_Object datum, Lisp_Object ignored)
443 {
444   /* This function can GC */
445   Vcommand_loop =  Qnil;
446   Fding (Qnil, Qnil, Qnil);
447
448   if (CONSP (datum) && EQ (XCAR (datum), Qquit))
449     /* Don't bother with the message */
450     return (Qt);
451
452   message ("Error in command-loop!!");
453   Fset (intern ("last-error"), datum); /* #### Better/different name? */
454   Fsit_for (make_int (2), Qnil);
455   cold_load_command_error (datum, Qnil);
456   return (Qt);
457 }
458
459 DOESNT_RETURN
460 initial_command_loop (Lisp_Object load_me)
461 {
462   /* This function can GC */
463   if (!NILP (load_me))
464     {
465       if (!NILP (condition_case_1 (Qt, load1, load_me,
466                                    initial_error_handler, Qnil)))
467         Fkill_emacs (make_int (-1));
468     }
469
470   for (;;)
471     {
472       command_loop_level = 0;
473       MARK_MODELINE_CHANGED;
474
475       condition_case_1 (Qt,
476                         call_command_loop, Qtop_level,
477                         initial_error_handler, Qnil);
478     }
479 }
480
481 #endif /* LISP_COMMAND_LOOP */
482
483 \f
484 /**********************************************************************/
485 /*                     Guts of command loop                           */
486 /**********************************************************************/
487
488 static Lisp_Object
489 command_loop_1 (Lisp_Object dummy)
490 {
491   /* This function can GC */
492   /* #### not correct with Vselected_console */
493   XCONSOLE (Vselected_console)->prefix_arg = Qnil;
494   return (Fcommand_loop_1 ());
495 }
496
497 /* This is the actual command reading loop, sans error-handling
498    encapsulation.  This is used for both the C and Lisp command
499    loops.  Originally this function was written in Lisp when
500    the Lisp command loop was used, but it was too slow that way.
501
502    Under the C command loop, this function will never return
503    (although someone might throw past it).  Under the Lisp
504    command loop, this will return only when the user specifies
505    a new command loop by changing the command-loop variable. */
506
507 DEFUN ("command-loop-1", Fcommand_loop_1, 0, 0, 0, /*
508 Invoke the internals of the canonical editor command loop.
509 Don't call this unless you know what you're doing.
510 */
511        ())
512 {
513   /* This function can GC */
514   Lisp_Object event = Fmake_event (Qnil, Qnil);
515   Lisp_Object old_loop = Qnil;
516   struct gcpro gcpro1, gcpro2;
517   int was_locked = in_single_console_state ();
518   GCPRO2 (event, old_loop);
519
520   /* cancel_echoing (); */
521   /* This magically makes single character keyboard macros work just
522      like the real thing.  This is slightly bogus, but it's in here for
523      compatibility with Emacs 18.  It's not even clear what the "right
524      thing" is. */
525   if (!((STRINGP (Vexecuting_macro) || VECTORP (Vexecuting_macro))
526         && XINT (Flength (Vexecuting_macro)) == 1))
527     Vlast_command = Qt;
528
529 #ifndef LISP_COMMAND_LOOP
530   while (1)
531 #else
532   old_loop = Vcommand_loop;
533   while (EQ (Vcommand_loop, old_loop))
534 #endif /* LISP_COMMAND_LOOP */
535     {
536       /* If focus_follows_mouse, make sure the frame with window manager
537          focus is selected. */
538       if (focus_follows_mouse)
539         investigate_frame_change ();
540
541       /* Make sure the current window's buffer is selected.  */
542       {
543         Lisp_Object selected_window = Fselected_window (Qnil);
544
545         if (!NILP (selected_window) &&
546             (XBUFFER (XWINDOW (selected_window)->buffer) != current_buffer))
547           {
548             set_buffer_internal (XBUFFER (XWINDOW (selected_window)->buffer));
549           }
550       }
551
552 #if 0 /* What's wrong with going through ordinary procedure of quit?
553          quitting here leaves overriding-terminal-local-map
554          when you type C-u C-u C-g. */
555       /* If ^G was typed before we got here (that is, before emacs was
556          idle and waiting for input) then we treat that as an interrupt. */
557       QUIT;
558 #endif
559
560       /* If minibuffer on and echo area in use, wait 2 sec and redraw
561          minibuffer.  Treat a ^G here as a command, not an interrupt.
562        */
563       if (minibuf_level > 0 && echo_area_active (selected_frame ()))
564         {
565           /* Bind dont_check_for_quit to 1 so that C-g gets read in
566              rather than quitting back to the minibuffer.  */
567           int count = specpdl_depth ();
568           begin_dont_check_for_quit ();
569           Fsit_for (make_int (2), Qnil);
570           clear_echo_area (selected_frame (), Qnil, 0);
571           unbind_to (count, Qnil);
572         }
573
574       Fnext_event (event, Qnil);
575       /* If ^G was typed while emacs was reading input from the user, then
576          Fnext_event() will have read it as a normal event and
577          next_event_internal() will have set Vquit_flag.  We reset this
578          so that the ^G is treated as just another key.  This is strange,
579          but it is what emacs 18 did.
580
581          Do not call check_quit() here. */
582       Vquit_flag = Qnil;
583       Fdispatch_event (event);
584
585       if (!was_locked)
586         any_console_state ();
587 #if (defined (_MSC_VER)                         \
588      || defined (__SUNPRO_C)                    \
589      || defined (__SUNPRO_CC)                   \
590      || (defined (DEC_ALPHA)                    \
591          && defined (OSF1)))
592       if (0) return Qnil; /* Shut up compiler */
593 #endif
594     }
595 #ifdef LISP_COMMAND_LOOP
596   UNGCPRO;
597   return Qnil;
598 #endif
599 }
600
601 \f
602 /**********************************************************************/
603 /*                         Initialization                             */
604 /**********************************************************************/
605
606 void
607 syms_of_cmdloop (void)
608 {
609   defsymbol (&Qcommand_error, "command-error");
610   defsymbol (&Qreally_early_error_handler, "really-early-error-handler");
611   defsymbol (&Qtop_level, "top-level");
612   defsymbol (&Qerrors_deactivate_region, "errors-deactivate-region");
613
614 #ifndef LISP_COMMAND_LOOP
615   DEFSUBR (Frecursive_edit);
616 #endif
617   DEFSUBR (Freally_early_error_handler);
618   DEFSUBR (Fcommand_loop_1);
619 }
620
621 void
622 vars_of_cmdloop (void)
623 {
624   DEFVAR_INT ("command-loop-level", &command_loop_level /*
625 Number of recursive edits in progress.
626 */ );
627   command_loop_level = 0;
628
629   DEFVAR_LISP ("disabled-command-hook", &Vdisabled_command_hook /*
630 Value is called instead of any command that is disabled,
631 i.e. has a non-nil `disabled' property.
632 */ );
633   Vdisabled_command_hook = intern ("disabled-command-hook");
634
635   DEFVAR_LISP ("leave-window-hook", &Vleave_window_hook /*
636 Not yet implemented.
637 */ );
638   Vleave_window_hook = Qnil;
639
640   DEFVAR_LISP ("enter-window-hook", &Venter_window_hook /*
641 Not yet implemented.
642 */ );
643   Venter_window_hook = Qnil;
644
645 #ifndef LISP_COMMAND_LOOP
646   DEFVAR_LISP ("top-level", &Vtop_level /*
647 Form to evaluate when Emacs starts up.
648 Useful to set before you dump a modified Emacs.
649 */ );
650   Vtop_level = Qnil;
651 #else
652   DEFVAR_LISP ("command-loop", &Vcommand_loop /*
653 Function or one argument to call to read and process keyboard commands.
654 The passed argument specifies whether or not to handle errors.
655 */ );
656   Vcommand_loop = Qnil;
657 #endif /* LISP_COMMAND_LOOP */
658 }