Mercurial > hg > xemacs-beta
annotate src/cmdloop.c @ 5167:e374ea766cc1
clean up, rearrange allocation statistics code
-------------------- ChangeLog entries follow: --------------------
src/ChangeLog addition:
2010-03-21 Ben Wing <ben@xemacs.org>
* alloc.c:
* alloc.c (assert_proper_sizing):
* alloc.c (c_readonly):
* alloc.c (malloced_storage_size):
* alloc.c (fixed_type_block_overhead):
* alloc.c (lisp_object_storage_size):
* alloc.c (inc_lrecord_stats):
* alloc.c (dec_lrecord_stats):
* alloc.c (pluralize_word):
* alloc.c (object_memory_usage_stats):
* alloc.c (Fobject_memory_usage):
* alloc.c (compute_memusage_stats_length):
* alloc.c (disksave_object_finalization_1):
* alloc.c (Fgarbage_collect):
* mc-alloc.c:
* mc-alloc.c (mc_alloced_storage_size):
* mc-alloc.h:
No functionality change here. Collect the allocations-statistics
code that was scattered throughout alloc.c into one place. Add
remaining section headings so that all sections have headings
clearly identifying the start of the section and its purpose.
Expose mc_alloced_storage_size() even when not MEMORY_USAGE_STATS;
this fixes build problems and is related to the export of
lisp_object_storage_size() and malloced_storage_size() when
non-MEMORY_USAGE_STATS in the previous change set.
| author | Ben Wing <ben@xemacs.org> |
|---|---|
| date | Sun, 21 Mar 2010 04:41:49 -0500 |
| parents | 838630c0734f |
| children | 308d34e9f07d |
| rev | line source |
|---|---|
| 428 | 1 /* Editor command loop. |
| 2 Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc. | |
|
4841
3465c3161fea
when `debug', abort when lisp error during loadup
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
3 Copyright (C) 1995, 1996, 2001, 2002, 2003, 2005 Ben Wing. |
| 428 | 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" | |
| 872 | 35 #include "console-impl.h" |
| 800 | 36 #include "device.h" |
| 428 | 37 #include "commands.h" |
| 38 #include "frame.h" | |
| 39 #include "events.h" | |
| 40 #include "window.h" | |
| 41 | |
| 872 | 42 #ifdef HAVE_MS_WINDOWS |
| 43 #include "console-msw.h" | |
| 44 #endif | |
| 45 | |
| 428 | 46 /* Current depth in recursive edits. */ |
| 458 | 47 Fixnum command_loop_level; |
| 428 | 48 |
| 49 #ifndef LISP_COMMAND_LOOP | |
| 50 /* Form to evaluate (if non-nil) when Emacs is started. */ | |
| 51 Lisp_Object Vtop_level; | |
| 52 #else | |
| 53 /* Function to call to evaluate to read and process events. */ | |
| 54 Lisp_Object Vcommand_loop; | |
| 55 #endif /* LISP_COMMAND_LOOP */ | |
| 56 | |
| 57 Lisp_Object Venter_window_hook, Vleave_window_hook; | |
| 58 | |
| 733 | 59 Lisp_Object Qdisabled_command_hook, Vdisabled_command_hook; |
| 60 | |
| 428 | 61 /* The error handler. */ |
| 62 Lisp_Object Qcommand_error; | |
| 63 | |
| 64 /* The emergency error handler, before we're ready. */ | |
| 65 Lisp_Object Qreally_early_error_handler; | |
| 66 | |
| 67 /* Variable defined in Lisp. */ | |
| 68 Lisp_Object Qerrors_deactivate_region; | |
| 69 | |
| 70 Lisp_Object Qtop_level; | |
| 1703 | 71 Lisp_Object Vminibuffer_echo_wait_function; |
| 428 | 72 |
| 2268 | 73 #ifdef LISP_COMMAND_LOOP |
| 428 | 74 static Lisp_Object command_loop_1 (Lisp_Object dummy); |
| 75 EXFUN (Fcommand_loop_1, 0); | |
| 2268 | 76 #else |
| 77 static DECLARE_DOESNT_RETURN_TYPE (Lisp_Object, | |
| 78 command_loop_1 (Lisp_Object dummy)); | |
| 79 EXFUN_NORETURN (Fcommand_loop_1, 0); | |
| 80 #endif | |
| 428 | 81 |
| 82 /* There are two possible command loops -- one written entirely in | |
| 83 C and one written mostly in Lisp, except stuff written in C for | |
| 84 speed. The advantage of the Lisp command loop is that the user | |
| 85 can specify their own command loop to use by changing the variable | |
| 86 `command-loop'. Its disadvantage is that it's slow. */ | |
| 87 | |
| 88 static Lisp_Object | |
| 89 default_error_handler (Lisp_Object data) | |
| 90 { | |
| 91 int speccount = specpdl_depth (); | |
| 92 | |
| 93 /* None of this is invoked, normally. This code is almost identical | |
| 94 to the `command-error' function, except `command-error' does cool | |
| 95 tricks with sounds. This function is a fallback, invoked if | |
| 96 command-error is unavailable. */ | |
| 97 | |
| 98 Fding (Qnil, Qnil, Qnil); | |
| 99 | |
| 100 if (!NILP (Fboundp (Qerrors_deactivate_region)) | |
| 101 && !NILP (Fsymbol_value (Qerrors_deactivate_region))) | |
| 102 zmacs_deactivate_region (); | |
| 103 Fdiscard_input (); | |
| 104 specbind (Qinhibit_quit, Qt); | |
| 105 Vstandard_output = Qt; | |
| 106 Vstandard_input = Qt; | |
| 107 Vexecuting_macro = Qnil; | |
| 108 Fset (intern ("last-error"), data); | |
| 109 clear_echo_area (selected_frame (), Qnil, 0); | |
| 110 Fdisplay_error (data, Qt); | |
| 111 check_quit (); /* make Vquit_flag accurate */ | |
| 112 Vquit_flag = Qnil; | |
| 771 | 113 return (unbind_to_1 (speccount, Qt)); |
| 428 | 114 } |
| 115 | |
| 2268 | 116 DEFUN_NORETURN ("really-early-error-handler", Freally_early_error_handler, |
| 117 1, 1, 0, /* | |
| 428 | 118 You should almost certainly not be using this. |
| 119 */ | |
| 120 (x)) | |
| 121 { | |
| 122 /* This is an error handler used when we're running temacs and when | |
| 123 we're in the early stages of XEmacs. No errors ought to be | |
| 124 occurring in those cases (or they ought to be trapped and | |
| 125 dealt with elsewhere), but if an error slips through, we need | |
| 126 to deal with it. We could write this function in Lisp (and it | |
| 127 used to be this way, at the beginning of loadup.el), but we do | |
| 128 it this way in case an error occurs before we get to loading | |
| 129 loadup.el. Note that there is also an `early-error-handler', | |
| 130 used in startup.el to catch more reasonable errors that | |
| 131 might occur during startup if the sysadmin or whoever fucked | |
| 132 up. This function is more conservative in what it does | |
| 133 and is used only as a last resort, indicating that the | |
| 134 programmer himself fucked up somewhere. */ | |
| 135 stderr_out ("*** Error in XEmacs initialization"); | |
| 136 Fprint (x, Qexternal_debugging_output); | |
| 137 stderr_out ("*** Backtrace\n"); | |
| 138 Fbacktrace (Qexternal_debugging_output, Qt); | |
| 139 stderr_out ("*** Killing XEmacs\n"); | |
|
4841
3465c3161fea
when `debug', abort when lisp error during loadup
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
140 #ifdef DEBUG_XEMACS |
|
3465c3161fea
when `debug', abort when lisp error during loadup
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
141 /* When configured --with-debug, and debug-on-error is set, exit to the |
|
3465c3161fea
when `debug', abort when lisp error during loadup
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
142 debugger and abort. This will happen during loadup/dumping. There is |
|
3465c3161fea
when `debug', abort when lisp error during loadup
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
143 also code in signal_call_debugger() to do the same whenever running |
|
3465c3161fea
when `debug', abort when lisp error during loadup
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
144 noninteractively. That's intended for use debugging e.g. batch byte |
|
3465c3161fea
when `debug', abort when lisp error during loadup
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
145 compilation, AFTER dumping has already happened, where the XEMACSDEBUG |
|
3465c3161fea
when `debug', abort when lisp error during loadup
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
146 variable can be set to '(setq debug-on-error t)' to trigger the |
|
3465c3161fea
when `debug', abort when lisp error during loadup
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
147 behavior. |
|
3465c3161fea
when `debug', abort when lisp error during loadup
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
148 |
|
3465c3161fea
when `debug', abort when lisp error during loadup
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
149 Why do we need to duplicate the bomb-out check here? Well, |
|
3465c3161fea
when `debug', abort when lisp error during loadup
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
150 signal_call_debugger() doesn't want to bomb out unless it has an |
|
3465c3161fea
when `debug', abort when lisp error during loadup
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
151 uncaught error, and in this case, we've installed a |
|
3465c3161fea
when `debug', abort when lisp error during loadup
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
152 call-with-condition-case handler, and so signal_call_debugger() can't |
|
3465c3161fea
when `debug', abort when lisp error during loadup
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
153 bomb out before calling us. If we returned and let the error be |
|
3465c3161fea
when `debug', abort when lisp error during loadup
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
154 processed further, it *would* trigger the bomb-out-to-debugger |
|
3465c3161fea
when `debug', abort when lisp error during loadup
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
155 behavior, but in fact it never gets there because we do `kill-emacs'. |
|
3465c3161fea
when `debug', abort when lisp error during loadup
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
156 Therefore, we have to provide the bomb-to-debugger feature |
|
3465c3161fea
when `debug', abort when lisp error during loadup
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
157 ourselves. */ |
|
3465c3161fea
when `debug', abort when lisp error during loadup
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
158 if (!NILP (Vdebug_on_error)) |
|
3465c3161fea
when `debug', abort when lisp error during loadup
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
159 { |
|
3465c3161fea
when `debug', abort when lisp error during loadup
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
160 stderr_out ("XEmacs exiting to debugger.\n"); |
|
3465c3161fea
when `debug', abort when lisp error during loadup
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
161 Fforce_debugging_signal (Qt); |
|
3465c3161fea
when `debug', abort when lisp error during loadup
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
162 } |
|
3465c3161fea
when `debug', abort when lisp error during loadup
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
163 #endif |
|
5023
838630c0734f
error-checking, Windows shutdown changes
Ben Wing <ben@xemacs.org>
parents:
4841
diff
changeset
|
164 #if defined (HAVE_MS_WINDOWS) && defined (WIN32_NATIVE) |
|
838630c0734f
error-checking, Windows shutdown changes
Ben Wing <ben@xemacs.org>
parents:
4841
diff
changeset
|
165 /* Don't do this under Cygwin, since we have output on stderr. */ |
| 771 | 166 Fmswindows_message_box (build_msg_string ("Initialization error"), |
| 442 | 167 Qnil, Qnil); |
| 168 #endif | |
| 2268 | 169 Fkill_emacs (make_int (-1)); |
| 170 RETURN_NOT_REACHED (Qnil); | |
| 428 | 171 } |
| 172 | |
| 173 | |
| 174 /**********************************************************************/ | |
| 175 /* Command-loop (in C) */ | |
| 176 /**********************************************************************/ | |
| 177 | |
| 178 #ifndef LISP_COMMAND_LOOP | |
| 179 | |
| 180 /* The guts of the command loop are in command_loop_1(). This function | |
| 181 doesn't catch errors, though -- that's the job of command_loop_2(), | |
| 182 which is a condition-case wrapper around command_loop_1(). | |
| 183 command_loop_1() never returns, but may get thrown out of. | |
| 184 | |
| 185 When an error occurs, cmd_error() is called, which usually | |
| 186 invokes the Lisp error handler in `command-error'; however, | |
| 187 a default error handler is provided if `command-error' is nil | |
| 188 (e.g. during startup). The purpose of the error handler is | |
| 189 simply to display the error message and do associated cleanup; | |
| 190 it does not need to throw anywhere. When the error handler | |
| 191 finishes, the condition-case in command_loop_2() will finish and | |
| 192 command_loop_2() will reinvoke command_loop_1(). | |
| 193 | |
| 194 command_loop_2() is invoked from three places: from | |
| 195 initial_command_loop() (called from main() at the end of | |
| 196 internal initialization), from the Lisp function `recursive-edit', | |
| 197 and from call_command_loop(). | |
| 198 | |
| 199 call_command_loop() is called when a macro is started and when the | |
| 200 minibuffer is entered; normal termination of the macro or | |
| 201 minibuffer causes a throw out of the recursive command loop. (To | |
| 3025 | 202 `execute-kbd-macro' for macros and `exit' for minibuffers. Note also |
| 428 | 203 that the low-level minibuffer-entering function, |
| 204 `read-minibuffer-internal', provides its own error handling and | |
| 205 does not need command_loop_2()'s error encapsulation; so it tells | |
| 206 call_command_loop() to invoke command_loop_1() directly.) | |
| 207 | |
| 208 Note that both read-minibuffer-internal and recursive-edit set | |
| 3025 | 209 up a catch for `exit'; this is why `abort-recursive-edit', which |
| 428 | 210 throws to this catch, exits out of either one. |
| 211 | |
| 212 initial_command_loop(), called from main(), sets up a catch | |
| 3025 | 213 for `top-level' when invoking command_loop_2(), allowing functions |
| 428 | 214 to throw all the way to the top level if they really need to. |
| 215 Before invoking command_loop_2(), initial_command_loop() calls | |
| 216 top_level_1(), which handles all of the startup stuff (creating | |
| 217 the initial frame, handling the command-line options, loading | |
| 218 the user's .emacs file, etc.). The function that actually does this | |
| 219 is in Lisp and is pointed to by the variable `top-level'; | |
| 220 normally this function is `normal-top-level'. top_level_1() is | |
| 221 just an error-handling wrapper similar to command_loop_2(). | |
| 3025 | 222 Note also that initial_command_loop() sets up a catch for `top-level' |
| 428 | 223 when invoking top_level_1(), just like when it invokes |
| 224 command_loop_2(). */ | |
| 225 | |
| 226 | |
| 227 static Lisp_Object | |
| 2286 | 228 cmd_error (Lisp_Object data, Lisp_Object UNUSED (dummy)) |
| 428 | 229 { |
| 230 /* This function can GC */ | |
| 231 check_quit (); /* make Vquit_flag accurate */ | |
| 232 Vquit_flag = Qnil; | |
| 233 | |
| 234 any_console_state (); | |
| 235 | |
| 236 if (!NILP (Ffboundp (Qcommand_error))) | |
| 237 return call1 (Qcommand_error, data); | |
| 238 | |
| 239 return default_error_handler (data); | |
| 240 } | |
| 241 | |
| 242 static Lisp_Object | |
| 2286 | 243 top_level_1 (Lisp_Object UNUSED (dummy)) |
| 428 | 244 { |
| 245 /* This function can GC */ | |
| 246 /* On entry to the outer level, run the startup file */ | |
| 247 if (!NILP (Vtop_level)) | |
| 248 condition_case_1 (Qerror, Feval, Vtop_level, cmd_error, Qnil); | |
| 249 #if 1 | |
| 250 else | |
| 251 { | |
| 252 message ("\ntemacs can only be run in -batch mode."); | |
| 253 noninteractive = 1; /* prevent things under kill-emacs from blowing up */ | |
| 254 Fkill_emacs (make_int (-1)); | |
| 255 } | |
| 256 #else | |
| 257 else if (purify_flag) | |
| 258 message ("Bare impure Emacs (standard Lisp code not loaded)"); | |
| 259 else | |
| 260 message ("Bare Emacs (standard Lisp code not loaded)"); | |
| 261 #endif | |
| 262 | |
| 263 return Qnil; | |
| 264 } | |
| 265 | |
| 266 /* Here we catch errors in execution of commands within the | |
| 267 editing loop, and reenter the editing loop. | |
| 268 When there is an error, cmd_error runs and the call | |
| 269 to condition_case_1() returns. */ | |
| 270 | |
| 271 /* Avoid confusing the compiler. A helper function for command_loop_2 */ | |
| 2268 | 272 static DECLARE_DOESNT_RETURN (command_loop_3 (void)); |
| 273 | |
| 428 | 274 static DOESNT_RETURN |
| 275 command_loop_3 (void) | |
| 276 { | |
| 277 /* | |
| 1268 | 278 * If we are inside of a menu callback we cannot reenter the command loop |
| 279 * because we will deadlock, as no input is allowed. | |
| 428 | 280 */ |
| 1268 | 281 if (in_modal_loop) |
| 282 invalid_operation ("Attempt to enter command loop inside menu callback", | |
| 283 Qunbound); | |
| 428 | 284 /* This function can GC */ |
| 285 for (;;) | |
| 286 { | |
| 287 condition_case_1 (Qerror, command_loop_1, Qnil, cmd_error, Qnil); | |
| 288 /* #### wrong with selected-console? */ | |
| 289 /* See command in initial_command_loop about why this value | |
| 290 is 0. */ | |
| 291 reset_this_command_keys (Vselected_console, 0); | |
| 292 } | |
| 293 } | |
| 294 | |
| 2268 | 295 static DECLARE_DOESNT_RETURN_TYPE (Lisp_Object, command_loop_2 (Lisp_Object)); |
| 296 | |
| 297 static DOESNT_RETURN_TYPE (Lisp_Object) | |
| 2286 | 298 command_loop_2 (Lisp_Object UNUSED (dummy)) |
| 428 | 299 { |
| 300 command_loop_3(); /* doesn't return */ | |
| 2268 | 301 RETURN_NOT_REACHED (Qnil); |
| 428 | 302 } |
| 303 | |
| 304 /* This is called from emacs.c when it's done with initialization. */ | |
| 305 | |
| 306 DOESNT_RETURN | |
| 307 initial_command_loop (Lisp_Object load_me) | |
| 308 { | |
| 309 /* This function can GC */ | |
| 310 if (!NILP (load_me)) | |
| 311 Vtop_level = list2 (Qload, load_me); | |
| 312 | |
| 313 /* First deal with startup and command-line arguments. A throw | |
| 3025 | 314 to `top-level' gets us back here directly (does this ever happen?). |
| 428 | 315 Otherwise, this function will return normally when all command- |
| 316 line arguments have been processed, the user's initialization | |
| 317 file has been read in, and the first frame has been created. */ | |
| 2532 | 318 internal_catch (Qtop_level, top_level_1, Qnil, 0, 0, 0); |
| 428 | 319 |
| 320 /* If an error occurred during startup and the initial console | |
| 321 wasn't created, then die now (the error was already printed out | |
| 322 on the terminal device). */ | |
| 323 if (!noninteractive && | |
| 324 (!CONSOLEP (Vselected_console) || | |
| 325 CONSOLE_STREAM_P (XCONSOLE (Vselected_console)))) | |
| 326 Fkill_emacs (make_int (-1)); | |
| 327 | |
| 328 /* End of -batch run causes exit here. */ | |
| 329 if (noninteractive) | |
| 330 Fkill_emacs (Qt); | |
| 331 | |
| 332 for (;;) | |
| 333 { | |
| 334 command_loop_level = 0; | |
| 335 MARK_MODELINE_CHANGED; | |
| 336 /* Now invoke the command loop. It never returns; however, a | |
| 3025 | 337 throw to `top-level' will place us at the end of this loop. */ |
| 2532 | 338 internal_catch (Qtop_level, command_loop_2, Qnil, 0, 0, 0); |
| 428 | 339 /* #### wrong with selected-console? */ |
| 340 /* We don't actually call clear_echo_area() here, partially | |
| 341 at least because that runs Lisp code and it may be unsafe | |
| 342 to do so -- we are outside of the normal catches for | |
| 343 errors and such. */ | |
| 344 reset_this_command_keys (Vselected_console, 0); | |
| 345 } | |
| 346 } | |
| 347 | |
| 348 /* This function is invoked when a macro or minibuffer starts up. | |
| 349 Normal termination of the macro or minibuffer causes a throw past us. | |
| 350 See the comment above. | |
| 351 | |
| 352 Note that this function never returns (but may be thrown out of). */ | |
| 353 | |
| 2268 | 354 DOESNT_RETURN_TYPE (Lisp_Object) |
| 428 | 355 call_command_loop (Lisp_Object catch_errors) |
| 356 { | |
| 357 /* This function can GC */ | |
| 358 if (NILP (catch_errors)) | |
| 2268 | 359 command_loop_1 (Qnil); |
| 428 | 360 else |
| 2268 | 361 command_loop_2 (Qnil); |
| 362 RETURN_NOT_REACHED (Qnil); | |
| 428 | 363 } |
| 364 | |
| 365 static Lisp_Object | |
| 366 recursive_edit_unwind (Lisp_Object buffer) | |
| 367 { | |
| 368 if (!NILP (buffer)) | |
| 369 Fset_buffer (buffer); | |
| 370 | |
| 371 command_loop_level--; | |
| 372 MARK_MODELINE_CHANGED; | |
| 373 | |
| 374 return Qnil; | |
| 375 } | |
| 376 | |
| 377 DEFUN ("recursive-edit", Frecursive_edit, 0, 0, "", /* | |
| 378 Invoke the editor command loop recursively. | |
| 379 To get out of the recursive edit, a command can do `(throw 'exit nil)'; | |
| 380 that tells this function to return. | |
| 381 Alternately, `(throw 'exit t)' makes this function signal an error. | |
| 382 */ | |
| 383 ()) | |
| 384 { | |
| 385 /* This function can GC */ | |
| 386 Lisp_Object val; | |
| 387 int speccount = specpdl_depth (); | |
| 388 | |
| 389 command_loop_level++; | |
| 390 MARK_MODELINE_CHANGED; | |
| 391 | |
| 392 record_unwind_protect (recursive_edit_unwind, | |
| 872 | 393 current_buffer |
| 394 != XWINDOW_XBUFFER (Fselected_window (Qnil)) | |
| 428 | 395 ? Fcurrent_buffer () |
| 872 | 396 : Qnil); |
| 428 | 397 |
| 398 specbind (Qstandard_output, Qt); | |
| 399 specbind (Qstandard_input, Qt); | |
| 400 | |
| 2532 | 401 val = internal_catch (Qexit, command_loop_2, Qnil, 0, 0, 0); |
| 428 | 402 |
| 403 if (EQ (val, Qt)) | |
| 404 /* Turn abort-recursive-edit into a quit. */ | |
| 405 Fsignal (Qquit, Qnil); | |
| 406 | |
| 771 | 407 return unbind_to (speccount); |
| 428 | 408 } |
| 409 | |
| 410 #endif /* !LISP_COMMAND_LOOP */ | |
| 411 | |
| 412 | |
| 413 /**********************************************************************/ | |
| 414 /* Alternate command-loop (largely in Lisp) */ | |
| 415 /**********************************************************************/ | |
| 416 | |
| 417 #ifdef LISP_COMMAND_LOOP | |
| 418 | |
| 419 static Lisp_Object | |
| 420 load1 (Lisp_Object name) | |
| 421 { | |
| 422 /* This function can GC */ | |
| 423 call4 (Qload, name, Qnil, Qt, Qnil); | |
| 424 return (Qnil); | |
| 425 } | |
| 426 | |
| 427 /* emergency backups for cold-load-stream use */ | |
| 428 static Lisp_Object | |
| 429 cold_load_command_error (Lisp_Object datum, Lisp_Object ignored) | |
| 430 { | |
| 431 /* This function can GC */ | |
| 432 check_quit (); /* make Vquit_flag accurate */ | |
| 433 Vquit_flag = Qnil; | |
| 434 | |
| 435 return default_error_handler (datum); | |
| 436 } | |
| 437 | |
| 438 static Lisp_Object | |
| 439 cold_load_command_loop (Lisp_Object dummy) | |
| 440 { | |
| 441 /* This function can GC */ | |
| 442 return (condition_case_1 (Qt, | |
| 443 command_loop_1, Qnil, | |
| 444 cold_load_command_error, Qnil)); | |
| 445 } | |
| 446 | |
| 2268 | 447 DOESNT_RETURN_TYPE (Lisp_Object) |
| 428 | 448 call_command_loop (Lisp_Object catch_errors) |
| 449 { | |
| 450 /* This function can GC */ | |
| 479 | 451 reset_this_command_keys (Vselected_console, 0); /* #### bleagh */ |
| 428 | 452 |
| 453 loop: | |
| 454 for (;;) | |
| 455 { | |
| 456 if (NILP (Vcommand_loop)) | |
| 457 break; | |
| 458 call1 (Vcommand_loop, catch_errors); | |
| 459 } | |
| 460 | |
| 461 /* This isn't a "correct" definition, but you're pretty hosed if | |
| 462 you broke "command-loop" anyway */ | |
| 463 /* #### not correct with Vselected_console */ | |
| 464 XCONSOLE (Vselected_console)->prefix_arg = Qnil; | |
| 465 if (NILP (catch_errors)) | |
| 466 Fcommand_loop_1 (); | |
| 467 else | |
| 2532 | 468 internal_catch (Qtop_level, cold_load_command_loop, Qnil, 0, 0, 0); |
| 428 | 469 goto loop; |
| 2268 | 470 RETURN_NOT_REACHED (Qnil); |
| 428 | 471 } |
| 472 | |
| 473 static Lisp_Object | |
| 474 initial_error_handler (Lisp_Object datum, Lisp_Object ignored) | |
| 475 { | |
| 476 /* This function can GC */ | |
| 477 Vcommand_loop = Qnil; | |
| 478 Fding (Qnil, Qnil, Qnil); | |
| 479 | |
| 480 if (CONSP (datum) && EQ (XCAR (datum), Qquit)) | |
| 481 /* Don't bother with the message */ | |
| 482 return (Qt); | |
| 483 | |
| 484 message ("Error in command-loop!!"); | |
| 485 Fset (intern ("last-error"), datum); /* #### Better/different name? */ | |
| 486 Fsit_for (make_int (2), Qnil); | |
| 487 cold_load_command_error (datum, Qnil); | |
| 488 return (Qt); | |
| 489 } | |
| 490 | |
| 491 DOESNT_RETURN | |
| 492 initial_command_loop (Lisp_Object load_me) | |
| 493 { | |
| 494 /* This function can GC */ | |
| 495 if (!NILP (load_me)) | |
| 496 { | |
| 497 if (!NILP (condition_case_1 (Qt, load1, load_me, | |
| 498 initial_error_handler, Qnil))) | |
| 499 Fkill_emacs (make_int (-1)); | |
| 500 } | |
| 501 | |
| 502 for (;;) | |
| 503 { | |
| 504 command_loop_level = 0; | |
| 505 MARK_MODELINE_CHANGED; | |
| 506 | |
| 507 condition_case_1 (Qt, | |
| 508 call_command_loop, Qtop_level, | |
| 509 initial_error_handler, Qnil); | |
| 510 } | |
| 511 } | |
| 512 | |
| 513 #endif /* LISP_COMMAND_LOOP */ | |
| 514 | |
| 515 | |
| 516 /**********************************************************************/ | |
| 517 /* Guts of command loop */ | |
| 518 /**********************************************************************/ | |
| 519 | |
| 2268 | 520 #ifdef LISP_COMMAND_LOOP |
| 428 | 521 static Lisp_Object |
| 2268 | 522 #else |
| 523 static DOESNT_RETURN_TYPE (Lisp_Object) | |
| 524 #endif | |
| 2286 | 525 command_loop_1 (Lisp_Object UNUSED (dummy)) |
| 428 | 526 { |
| 527 /* This function can GC */ | |
| 528 /* #### not correct with Vselected_console */ | |
| 529 XCONSOLE (Vselected_console)->prefix_arg = Qnil; | |
| 2268 | 530 Fcommand_loop_1 (); |
| 531 #ifdef LISP_COMMAND_LOOP | |
| 532 return Qnil; | |
| 533 #else | |
| 534 RETURN_NOT_REACHED (Qnil); | |
| 535 #endif | |
| 428 | 536 } |
| 537 | |
| 538 /* This is the actual command reading loop, sans error-handling | |
| 539 encapsulation. This is used for both the C and Lisp command | |
| 540 loops. Originally this function was written in Lisp when | |
| 541 the Lisp command loop was used, but it was too slow that way. | |
| 542 | |
| 543 Under the C command loop, this function will never return | |
| 544 (although someone might throw past it). Under the Lisp | |
| 545 command loop, this will return only when the user specifies | |
| 546 a new command loop by changing the command-loop variable. */ | |
| 547 | |
| 2268 | 548 #ifdef LISP_COMMAND_LOOP |
| 549 #define DEFUN_COMMAND_LOOP(a,b,c,d,e,f) DEFUN (a, b, c, d, e, f) | |
| 550 #else | |
| 551 #define DEFUN_COMMAND_LOOP(a,b,c,d,e,f) DEFUN_NORETURN (a, b, c, d, e, f) | |
| 552 #endif | |
| 553 | |
| 554 DEFUN_COMMAND_LOOP ("command-loop-1", Fcommand_loop_1, 0, 0, 0, /* | |
| 428 | 555 Invoke the internals of the canonical editor command loop. |
| 556 Don't call this unless you know what you're doing. | |
| 557 */ | |
| 558 ()) | |
| 559 { | |
| 560 /* This function can GC */ | |
| 561 Lisp_Object event = Fmake_event (Qnil, Qnil); | |
| 562 Lisp_Object old_loop = Qnil; | |
| 563 struct gcpro gcpro1, gcpro2; | |
| 564 int was_locked = in_single_console_state (); | |
| 565 GCPRO2 (event, old_loop); | |
| 566 | |
| 567 /* cancel_echoing (); */ | |
| 568 /* This magically makes single character keyboard macros work just | |
| 569 like the real thing. This is slightly bogus, but it's in here for | |
| 570 compatibility with Emacs 18. It's not even clear what the "right | |
| 571 thing" is. */ | |
| 434 | 572 if (!((STRINGP (Vexecuting_macro) || VECTORP (Vexecuting_macro)) |
| 573 && XINT (Flength (Vexecuting_macro)) == 1)) | |
| 428 | 574 Vlast_command = Qt; |
| 575 | |
| 576 #ifndef LISP_COMMAND_LOOP | |
| 577 while (1) | |
| 578 #else | |
| 579 old_loop = Vcommand_loop; | |
| 580 while (EQ (Vcommand_loop, old_loop)) | |
| 581 #endif /* LISP_COMMAND_LOOP */ | |
| 582 { | |
| 583 /* If focus_follows_mouse, make sure the frame with window manager | |
| 584 focus is selected. */ | |
| 585 if (focus_follows_mouse) | |
| 586 investigate_frame_change (); | |
| 434 | 587 |
| 428 | 588 /* Make sure the current window's buffer is selected. */ |
| 589 { | |
| 590 Lisp_Object selected_window = Fselected_window (Qnil); | |
| 591 | |
| 592 if (!NILP (selected_window) && | |
| 872 | 593 XWINDOW_XBUFFER (selected_window) != current_buffer) |
| 428 | 594 { |
| 872 | 595 set_buffer_internal (XWINDOW_XBUFFER (selected_window)); |
| 428 | 596 } |
| 597 } | |
| 598 | |
| 444 | 599 #if 0 /* What's wrong with going through ordinary procedure of quit? |
| 600 quitting here leaves overriding-terminal-local-map | |
| 601 when you type C-u C-u C-g. */ | |
| 428 | 602 /* If ^G was typed before we got here (that is, before emacs was |
| 603 idle and waiting for input) then we treat that as an interrupt. */ | |
| 604 QUIT; | |
| 444 | 605 #endif |
| 428 | 606 |
| 607 /* If minibuffer on and echo area in use, wait 2 sec and redraw | |
| 608 minibuffer. Treat a ^G here as a command, not an interrupt. | |
| 609 */ | |
| 610 if (minibuf_level > 0 && echo_area_active (selected_frame ())) | |
| 611 { | |
| 612 /* Bind dont_check_for_quit to 1 so that C-g gets read in | |
| 613 rather than quitting back to the minibuffer. */ | |
| 771 | 614 int count = begin_dont_check_for_quit (); |
| 1703 | 615 if (!NILP (Vminibuffer_echo_wait_function)) |
| 616 call0 (Vminibuffer_echo_wait_function); | |
| 617 else | |
| 618 Fsit_for (make_int (2), Qnil); | |
| 428 | 619 clear_echo_area (selected_frame (), Qnil, 0); |
| 853 | 620 Vquit_flag = Qnil; /* see begin_dont_check_for_quit() */ |
| 771 | 621 unbind_to (count); |
| 428 | 622 } |
| 623 | |
| 624 Fnext_event (event, Qnil); | |
| 625 Fdispatch_event (event); | |
| 626 | |
| 627 if (!was_locked) | |
| 628 any_console_state (); | |
| 1204 | 629 |
| 630 DO_NOTHING_DISABLING_NO_RETURN_WARNINGS; | |
| 428 | 631 } |
| 632 #ifdef LISP_COMMAND_LOOP | |
| 633 UNGCPRO; | |
| 634 return Qnil; | |
| 1204 | 635 #else |
| 636 RETURN_NOT_REACHED (Qnil); | |
| 428 | 637 #endif |
| 638 } | |
| 639 | |
| 640 | |
| 641 /**********************************************************************/ | |
| 642 /* Initialization */ | |
| 643 /**********************************************************************/ | |
| 644 | |
| 645 void | |
| 646 syms_of_cmdloop (void) | |
| 647 { | |
| 733 | 648 DEFSYMBOL (Qdisabled_command_hook); |
| 563 | 649 DEFSYMBOL (Qcommand_error); |
| 650 DEFSYMBOL (Qreally_early_error_handler); | |
| 651 DEFSYMBOL (Qtop_level); | |
| 652 DEFSYMBOL (Qerrors_deactivate_region); | |
| 428 | 653 |
| 654 #ifndef LISP_COMMAND_LOOP | |
| 655 DEFSUBR (Frecursive_edit); | |
| 656 #endif | |
| 657 DEFSUBR (Freally_early_error_handler); | |
| 658 DEFSUBR (Fcommand_loop_1); | |
| 659 } | |
| 660 | |
| 661 void | |
| 662 vars_of_cmdloop (void) | |
| 663 { | |
| 664 DEFVAR_INT ("command-loop-level", &command_loop_level /* | |
| 665 Number of recursive edits in progress. | |
| 666 */ ); | |
| 667 command_loop_level = 0; | |
| 668 | |
| 669 DEFVAR_LISP ("disabled-command-hook", &Vdisabled_command_hook /* | |
| 670 Value is called instead of any command that is disabled, | |
| 671 i.e. has a non-nil `disabled' property. | |
| 672 */ ); | |
| 673 Vdisabled_command_hook = intern ("disabled-command-hook"); | |
| 674 | |
| 675 DEFVAR_LISP ("leave-window-hook", &Vleave_window_hook /* | |
| 676 Not yet implemented. | |
| 677 */ ); | |
| 678 Vleave_window_hook = Qnil; | |
| 679 | |
| 680 DEFVAR_LISP ("enter-window-hook", &Venter_window_hook /* | |
| 681 Not yet implemented. | |
| 682 */ ); | |
| 683 Venter_window_hook = Qnil; | |
| 684 | |
| 1703 | 685 DEFVAR_LISP ("minibuffer-echo-wait-function", |
| 686 &Vminibuffer_echo_wait_function /* | |
| 687 The function called by command loop when minibuffer was active and | |
| 688 message was displayed (text appeared in \" *Echo Area*\" buffer). It | |
| 689 must wait after displaying message so that user can read it. If the | |
| 690 variable value is `nil', the equivalent of `(sit-for 2)' is run. | |
| 691 */ ); | |
| 692 Vminibuffer_echo_wait_function = Qnil; | |
| 693 | |
| 428 | 694 #ifndef LISP_COMMAND_LOOP |
| 695 DEFVAR_LISP ("top-level", &Vtop_level /* | |
| 696 Form to evaluate when Emacs starts up. | |
| 697 Useful to set before you dump a modified Emacs. | |
| 698 */ ); | |
| 699 Vtop_level = Qnil; | |
| 700 #else | |
| 701 DEFVAR_LISP ("command-loop", &Vcommand_loop /* | |
| 702 Function or one argument to call to read and process keyboard commands. | |
| 703 The passed argument specifies whether or not to handle errors. | |
| 704 */ ); | |
| 705 Vcommand_loop = Qnil; | |
| 706 #endif /* LISP_COMMAND_LOOP */ | |
| 707 } |