Mercurial > hg > xemacs-beta

comparison src/cmdloop.c @ 0:376386a54a3c r19-14

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