Mercurial > hg > xemacs-beta
annotate src/eval.c @ 4614:afbfad080ddd
The URLs in our current config.guess and config.sub files are obsolete.
Update to the latest upstream release to get correct URLs, as well as fixes
and enhancements to those scripts.
| author | Jerry James <james@xemacs.org> |
|---|---|
| date | Wed, 11 Feb 2009 11:09:35 -0700 |
| parents | 69a1eda3da06 |
| children | 9dd42cb187ed |
| rev | line source |
|---|---|
| 428 | 1 /* Evaluator for XEmacs Lisp interpreter. |
| 2 Copyright (C) 1985-1987, 1992-1994 Free Software Foundation, Inc. | |
| 3 Copyright (C) 1995 Sun Microsystems, Inc. | |
| 2421 | 4 Copyright (C) 2000, 2001, 2002, 2003, 2004 Ben Wing. |
| 428 | 5 |
| 6 This file is part of XEmacs. | |
| 7 | |
| 8 XEmacs is free software; you can redistribute it and/or modify it | |
| 9 under the terms of the GNU General Public License as published by the | |
| 10 Free Software Foundation; either version 2, or (at your option) any | |
| 11 later version. | |
| 12 | |
| 13 XEmacs is distributed in the hope that it will be useful, but WITHOUT | |
| 14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
| 15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
| 16 for more details. | |
| 17 | |
| 18 You should have received a copy of the GNU General Public License | |
| 19 along with XEmacs; see the file COPYING. If not, write to | |
| 20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
| 21 Boston, MA 02111-1307, USA. */ | |
| 22 | |
| 23 /* Synched up with: FSF 19.30 (except for Fsignal), Mule 2.0. */ | |
| 24 | |
| 853 | 25 /* Authorship: |
| 26 | |
| 27 Based on code from pre-release FSF 19, c. 1991. | |
| 28 Some work by Richard Mlynarik long ago (c. 1993?) -- | |
| 29 added call-with-condition-handler; synch. up to released FSF 19.7 | |
| 30 for lemacs 19.8. some signal changes. | |
| 31 Various work by Ben Wing, 1995-1996: | |
| 32 added all stuff dealing with trapping errors, suspended-errors, etc. | |
| 33 added most Fsignal front ends. | |
| 34 added warning code. | |
| 35 reworked the Fsignal code and synched the rest up to FSF 19.30. | |
| 36 Some changes by Martin Buchholz c. 1999? | |
| 37 e.g. PRIMITIVE_FUNCALL macros. | |
| 38 New call_trapping_problems code and large comments below | |
| 39 by Ben Wing, Mar-Apr 2000. | |
| 40 */ | |
| 41 | |
| 42 /* This file has been Mule-ized. */ | |
| 43 | |
| 44 /* What is in this file? | |
| 45 | |
| 46 This file contains the engine for the ELisp interpreter in XEmacs. | |
| 47 The engine does the actual work of implementing function calls, | |
| 48 form evaluation, non-local exits (catch, throw, signal, | |
| 49 condition-case, call-with-condition-handler), unwind-protects, | |
| 50 dynamic bindings, let constructs, backtraces, etc. You might say | |
| 51 that this module is the very heart of XEmacs, and everything else | |
| 52 in XEmacs is merely an auxiliary module implementing some specific | |
| 53 functionality that may be called from the heart at an appropriate | |
| 54 time. | |
| 55 | |
| 56 The only exception is the alloc.c module, which implements the | |
| 57 framework upon which this module (eval.c) works. alloc.c works | |
| 58 with creating the actual Lisp objects themselves and garbage | |
| 1960 | 59 collecting them as necessary, presenting a nice, high-level |
| 853 | 60 interface for object creation, deletion, access, and modification. |
| 61 | |
| 62 The only other exception that could be cited is the event-handling | |
| 63 module in event-stream.c. From its perspective, it is also the | |
| 64 heart of XEmacs, and controls exactly what gets done at what time. | |
| 65 From its perspective, eval.c is merely one of the auxiliary modules | |
| 66 out there that can be invoked by event-stream.c. | |
| 67 | |
| 68 Although the event-stream-centric view is a convenient fiction that | |
| 69 makes sense particularly from the user's perspective and from the | |
| 70 perspective of time, the engine-centric view is actually closest to | |
| 71 the truth, because anywhere within the event-stream module, you are | |
| 72 still somewhere in a Lisp backtrace, and event-loops are begun by | |
| 73 functions such as `command-loop-1', a Lisp function. | |
| 74 | |
| 75 As the Lisp engine is doing its thing, it maintains the state of | |
| 1960 | 76 the engine primarily in five list-like items, which are: |
| 853 | 77 |
| 78 -- the backtrace list | |
| 79 -- the catchtag list | |
| 80 -- the condition-handler list | |
| 81 -- the specbind list | |
| 82 -- the GCPRO list. | |
| 83 | |
| 84 These are described in detail in the next comment. | |
| 85 | |
| 86 --ben | |
| 87 */ | |
| 88 | |
| 89 /* Note that there are five separate lists used to maintain state in | |
| 90 the evaluator. All of them conceptually are stacks (last-in, | |
| 91 first-out). All non-local exits happen ultimately through the | |
| 92 catch/throw mechanism, which uses one of the five lists (the | |
| 93 catchtag list) and records the current state of the others in each | |
| 94 frame of the list (some other information is recorded and restored | |
| 95 as well, such as the current eval depth), so that all the state of | |
| 96 the evaluator is restored properly when a non-local exit occurs. | |
| 97 (Note that the current state of the condition-handler list is not | |
| 98 recorded in the catchtag list. Instead, when a condition-case or | |
| 99 call-with-condition-handler is set up, it installs an | |
| 100 unwind-protect on the specbind list to restore the appropriate | |
| 101 setting for the condition-handler list. During the course of | |
| 102 handling the non-local exit, all entries on the specbind list that | |
| 103 are past the location stored in the catch frame are "unwound" | |
| 104 (i.e. variable bindings are restored and unwind-protects are | |
| 105 executed), so the condition-handler list gets reset properly. | |
| 106 | |
| 107 The five lists are | |
| 108 | |
| 109 1. The backtrace list, which is chained through `struct backtrace's | |
| 110 declared in the stack frames of various primitives, and keeps | |
| 111 track of all Lisp function call entries and exits. | |
| 112 2. The catchtag list, which is chained through `struct catchtag's | |
| 113 declared in the stack frames of internal_catch and condition_case_1, | |
| 114 and keeps track of information needed to reset the internal state | |
| 115 of the evaluator to the state that was current when the catch or | |
| 116 condition-case were established, in the event of a non-local exit. | |
| 117 3. The condition-handler list, which is a simple Lisp list with new | |
| 118 entries consed onto the front of the list. It records condition-cases | |
| 119 and call-with-condition-handlers established either from C or from | |
| 120 Lisp. Unlike with the other lists (but similar to everything else | |
| 121 of a similar nature in the rest of the C and Lisp code), it takes care | |
| 122 of restoring itself appropriately in the event of a non-local exit | |
| 123 through the use of the unwind-protect mechanism. | |
| 124 4. The specbind list, which is a contiguous array of `struct specbinding's, | |
| 125 expanded as necessary using realloc(). It holds dynamic variable | |
| 126 bindings (the only kind we currently have in ELisp) and unwind-protects. | |
| 127 5. The GCPRO list, which is chained through `struct gcpro's declared in | |
| 128 the stack frames of any functions that need to GC-protect Lisp_Objects | |
| 129 declared on the stack. This is one of the most fragile areas of the | |
| 130 entire scheme -- you must not forget to UNGCPRO at the end of your | |
| 131 function, you must make sure you GCPRO in many circumstances you don't | |
| 132 think you have to, etc. See the internals manual for more information | |
| 133 about this. | |
| 134 | |
| 135 --ben | |
| 136 */ | |
| 137 | |
| 428 | 138 #include <config.h> |
| 139 #include "lisp.h" | |
| 140 | |
| 141 #include "commands.h" | |
| 142 #include "backtrace.h" | |
| 143 #include "bytecode.h" | |
| 144 #include "buffer.h" | |
| 872 | 145 #include "console-impl.h" |
| 853 | 146 #include "device.h" |
| 147 #include "frame.h" | |
| 148 #include "lstream.h" | |
| 428 | 149 #include "opaque.h" |
| 1292 | 150 #include "profile.h" |
| 853 | 151 #include "window.h" |
| 428 | 152 |
| 153 struct backtrace *backtrace_list; | |
| 154 | |
| 155 /* Macros for calling subrs with an argument list whose length is only | |
| 156 known at runtime. See EXFUN and DEFUN for similar hackery. */ | |
| 157 | |
| 158 #define AV_0(av) | |
| 159 #define AV_1(av) av[0] | |
| 160 #define AV_2(av) AV_1(av), av[1] | |
| 161 #define AV_3(av) AV_2(av), av[2] | |
| 162 #define AV_4(av) AV_3(av), av[3] | |
| 163 #define AV_5(av) AV_4(av), av[4] | |
| 164 #define AV_6(av) AV_5(av), av[5] | |
| 165 #define AV_7(av) AV_6(av), av[6] | |
| 166 #define AV_8(av) AV_7(av), av[7] | |
| 167 | |
| 168 #define PRIMITIVE_FUNCALL_1(fn, av, ac) \ | |
| 444 | 169 (((Lisp_Object (*)(EXFUN_##ac)) (fn)) (AV_##ac (av))) |
| 428 | 170 |
| 171 /* If subrs take more than 8 arguments, more cases need to be added | |
| 172 to this switch. (But wait - don't do it - if you really need | |
| 173 a SUBR with more than 8 arguments, use max_args == MANY. | |
| 853 | 174 Or better, considering using a property list as one of your args. |
| 428 | 175 See the DEFUN macro in lisp.h) */ |
| 176 #define PRIMITIVE_FUNCALL(rv, fn, av, ac) do { \ | |
| 177 void (*PF_fn)(void) = (void (*)(void)) fn; \ | |
| 178 Lisp_Object *PF_av = (av); \ | |
| 179 switch (ac) \ | |
| 180 { \ | |
| 436 | 181 default:rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 0); break; \ |
| 428 | 182 case 1: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 1); break; \ |
| 183 case 2: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 2); break; \ | |
| 184 case 3: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 3); break; \ | |
| 185 case 4: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 4); break; \ | |
| 186 case 5: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 5); break; \ | |
| 187 case 6: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 6); break; \ | |
| 188 case 7: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 7); break; \ | |
| 189 case 8: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 8); break; \ | |
| 190 } \ | |
| 191 } while (0) | |
| 192 | |
| 193 #define FUNCALL_SUBR(rv, subr, av, ac) \ | |
| 194 PRIMITIVE_FUNCALL (rv, subr_function (subr), av, ac); | |
| 195 | |
| 196 | |
| 197 /* This is the list of current catches (and also condition-cases). | |
| 853 | 198 This is a stack: the most recent catch is at the head of the list. |
| 199 The list is threaded through the stack frames of the C functions | |
| 200 that set up the catches; this is similar to the way the GCPRO list | |
| 201 is handled, but different from the condition-handler list (which is | |
| 202 a simple Lisp list) and the specbind stack, which is a contiguous | |
| 203 array of `struct specbinding's, grown (using realloc()) as | |
| 204 necessary. (Note that all four of these lists behave as a stacks.) | |
| 205 | |
| 3025 | 206 Catches are created by declaring a `struct catchtag' locally, |
| 853 | 207 filling the .TAG field in with the tag, and doing a setjmp() on |
| 208 .JMP. Fthrow() will store the value passed to it in .VAL and | |
| 209 longjmp() back to .JMP, back to the function that established the | |
| 210 catch. This will always be either internal_catch() (catches | |
| 211 established internally or through `catch') or condition_case_1 | |
| 212 (condition-cases established internally or through | |
| 213 `condition-case'). | |
| 428 | 214 |
| 215 The catchtag also records the current position in the | |
| 216 call stack (stored in BACKTRACE_LIST), the current position | |
| 217 in the specpdl stack (used for variable bindings and | |
| 218 unwind-protects), the value of LISP_EVAL_DEPTH, and the | |
| 219 current position in the GCPRO stack. All of these are | |
| 220 restored by Fthrow(). | |
| 853 | 221 */ |
| 428 | 222 |
| 223 struct catchtag *catchlist; | |
| 224 | |
| 853 | 225 /* A special tag that can be used internally from C code to catch |
| 226 every attempt to throw past this level. */ | |
| 227 Lisp_Object Vcatch_everything_tag; | |
| 228 | |
| 428 | 229 Lisp_Object Qautoload, Qmacro, Qexit; |
| 230 Lisp_Object Qinteractive, Qcommandp, Qdefun, Qprogn, Qvalues; | |
| 231 Lisp_Object Vquit_flag, Vinhibit_quit; | |
| 232 Lisp_Object Qand_rest, Qand_optional; | |
| 233 Lisp_Object Qdebug_on_error, Qstack_trace_on_error; | |
| 234 Lisp_Object Qdebug_on_signal, Qstack_trace_on_signal; | |
| 235 Lisp_Object Qdebugger; | |
| 236 Lisp_Object Qinhibit_quit; | |
| 887 | 237 Lisp_Object Qfinalize_list; |
| 428 | 238 Lisp_Object Qrun_hooks; |
| 239 Lisp_Object Qsetq; | |
| 240 Lisp_Object Qdisplay_warning; | |
| 241 Lisp_Object Vpending_warnings, Vpending_warnings_tail; | |
| 242 Lisp_Object Qif; | |
| 243 | |
| 853 | 244 /* Flags specifying which operations are currently inhibited. */ |
| 245 int inhibit_flags; | |
| 246 | |
| 247 /* Buffers, frames, windows, devices, and consoles created since most | |
| 248 recent active | |
| 249 call_trapping_problems (INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION). | |
| 250 */ | |
| 251 Lisp_Object Vdeletable_permanent_display_objects; | |
| 252 | |
| 253 /* Buffers created since most recent active | |
| 254 call_trapping_problems (INHIBIT_EXISTING_BUFFER_TEXT_MODIFICATION). */ | |
| 255 Lisp_Object Vmodifiable_buffers; | |
| 793 | 256 |
| 257 /* Minimum level at which warnings are logged. Below this, they're ignored | |
| 258 entirely -- not even generated. */ | |
| 259 Lisp_Object Vlog_warning_minimum_level; | |
| 260 | |
| 428 | 261 /* Non-nil means record all fset's and provide's, to be undone |
| 262 if the file being autoloaded is not fully loaded. | |
| 263 They are recorded by being consed onto the front of Vautoload_queue: | |
| 264 (FUN . ODEF) for a defun, (OFEATURES . nil) for a provide. */ | |
| 265 Lisp_Object Vautoload_queue; | |
| 266 | |
| 267 /* Current number of specbindings allocated in specpdl. */ | |
| 268 int specpdl_size; | |
| 269 | |
| 270 /* Pointer to beginning of specpdl. */ | |
| 271 struct specbinding *specpdl; | |
| 272 | |
| 273 /* Pointer to first unused element in specpdl. */ | |
| 274 struct specbinding *specpdl_ptr; | |
| 275 | |
| 276 /* specpdl_ptr - specpdl */ | |
| 277 int specpdl_depth_counter; | |
| 278 | |
| 279 /* Maximum size allowed for specpdl allocation */ | |
| 458 | 280 Fixnum max_specpdl_size; |
| 428 | 281 |
| 282 /* Depth in Lisp evaluations and function calls. */ | |
| 1292 | 283 int lisp_eval_depth; |
| 428 | 284 |
| 285 /* Maximum allowed depth in Lisp evaluations and function calls. */ | |
| 458 | 286 Fixnum max_lisp_eval_depth; |
| 428 | 287 |
| 288 /* Nonzero means enter debugger before next function call */ | |
| 289 static int debug_on_next_call; | |
| 290 | |
| 1292 | 291 int backtrace_with_internal_sections; |
| 292 | |
| 428 | 293 /* List of conditions (non-nil atom means all) which cause a backtrace |
| 294 if an error is handled by the command loop's error handler. */ | |
| 295 Lisp_Object Vstack_trace_on_error; | |
| 296 | |
| 297 /* List of conditions (non-nil atom means all) which enter the debugger | |
| 298 if an error is handled by the command loop's error handler. */ | |
| 299 Lisp_Object Vdebug_on_error; | |
| 300 | |
| 301 /* List of conditions and regexps specifying error messages which | |
| 302 do not enter the debugger even if Vdebug_on_error says they should. */ | |
| 303 Lisp_Object Vdebug_ignored_errors; | |
| 304 | |
| 305 /* List of conditions (non-nil atom means all) which cause a backtrace | |
| 306 if any error is signalled. */ | |
| 307 Lisp_Object Vstack_trace_on_signal; | |
| 308 | |
| 309 /* List of conditions (non-nil atom means all) which enter the debugger | |
| 310 if any error is signalled. */ | |
| 311 Lisp_Object Vdebug_on_signal; | |
| 312 | |
| 313 /* Nonzero means enter debugger if a quit signal | |
| 314 is handled by the command loop's error handler. | |
| 315 | |
| 316 From lisp, this is a boolean variable and may have the values 0 and 1. | |
| 317 But, eval.c temporarily uses the second bit of this variable to indicate | |
| 318 that a critical_quit is in progress. The second bit is reset immediately | |
| 319 after it is processed in signal_call_debugger(). */ | |
| 320 int debug_on_quit; | |
| 321 | |
| 322 #if 0 /* FSFmacs */ | |
| 323 /* entering_debugger is basically equivalent */ | |
| 324 /* The value of num_nonmacro_input_chars as of the last time we | |
| 325 started to enter the debugger. If we decide to enter the debugger | |
| 326 again when this is still equal to num_nonmacro_input_chars, then we | |
| 327 know that the debugger itself has an error, and we should just | |
| 328 signal the error instead of entering an infinite loop of debugger | |
| 329 invocations. */ | |
| 330 int when_entered_debugger; | |
| 331 #endif | |
| 332 | |
| 333 /* Nonzero means we are trying to enter the debugger. | |
| 334 This is to prevent recursive attempts. | |
| 335 Cleared by the debugger calling Fbacktrace */ | |
| 336 static int entering_debugger; | |
| 337 | |
| 338 /* Function to call to invoke the debugger */ | |
| 339 Lisp_Object Vdebugger; | |
| 340 | |
| 853 | 341 /* List of condition handlers currently in effect. |
| 342 The elements of this lists were at one point in the past | |
| 343 threaded through the stack frames of Fcondition_case and | |
| 344 related functions, but now are stored separately in a normal | |
| 345 stack. When an error is signaled (by calling Fsignal, below), | |
| 346 this list is searched for an element that applies. | |
| 428 | 347 |
| 348 Each element of this list is one of the following: | |
| 349 | |
| 853 | 350 -- A list of a handler function and possibly args to pass to the |
| 351 function. This is a handler established with the Lisp primitive | |
| 352 `call-with-condition-handler' or related C function | |
| 353 call_with_condition_handler(): | |
| 354 | |
| 355 If the handler function is an opaque ptr object, it is a handler | |
| 356 that was established in C using call_with_condition_handler(), | |
| 357 and the contents of the object are a function pointer which takes | |
| 358 three arguments, the signal name and signal data (same arguments | |
| 359 passed to `signal') and a third Lisp_Object argument, specified | |
| 360 in the call to call_with_condition_handler() and stored as the | |
| 361 second element of the list containing the handler functionl. | |
| 362 | |
| 363 If the handler function is a regular Lisp_Object, it is a handler | |
| 364 that was established using `call-with-condition-handler'. | |
| 365 Currently there are no more arguments in the list containing the | |
| 366 handler function, and only one argument is passed to the handler | |
| 367 function: a cons of the signal name and signal data arguments | |
| 368 passed to `signal'. | |
| 369 | |
| 370 -- A list whose car is Qunbound and whose cdr is Qt. This is a | |
| 371 special condition-case handler established by C code with | |
| 372 condition_case_1(). All errors are trapped; the debugger is not | |
| 373 invoked even if `debug-on-error' was set. | |
| 374 | |
| 375 -- A list whose car is Qunbound and whose cdr is Qerror. This is a | |
| 376 special condition-case handler established by C code with | |
| 377 condition_case_1(). It is like Qt except that the debugger is | |
| 378 invoked normally if it is called for. | |
| 379 | |
| 380 -- A list whose car is Qunbound and whose cdr is a list of lists | |
| 381 (CONDITION-NAME BODY ...) exactly as in `condition-case'. This is | |
| 382 a normal `condition-case' handler. | |
| 383 | |
| 384 Note that in all cases *except* the first, there is a corresponding | |
| 385 catch, whose TAG is the value of Vcondition_handlers just after the | |
| 386 handler data just described is pushed onto it. The reason is that | |
| 387 `condition-case' handlers need to throw back to the place where the | |
| 388 handler was installed before invoking it, while | |
| 389 `call-with-condition-handler' handlers are invoked in the | |
| 390 environment that `signal' was invoked in. */ | |
| 391 | |
| 392 | |
| 428 | 393 static Lisp_Object Vcondition_handlers; |
| 394 | |
| 853 | 395 /* I think we should keep this enabled all the time, not just when |
| 396 error checking is enabled, because if one of these puppies pops up, | |
| 397 it will trash the stack if not caught, making it that much harder to | |
| 398 debug. It doesn't cause speed loss. */ | |
| 442 | 399 #define DEFEND_AGAINST_THROW_RECURSION |
| 400 | |
| 401 #ifdef DEFEND_AGAINST_THROW_RECURSION | |
| 428 | 402 /* Used for error catching purposes by throw_or_bomb_out */ |
| 403 static int throw_level; | |
| 442 | 404 #endif |
| 405 | |
| 1123 | 406 static int warning_will_be_discarded (Lisp_Object level); |
| 2532 | 407 static Lisp_Object maybe_get_trapping_problems_backtrace (void); |
| 1123 | 408 |
| 428 | 409 |
| 410 /************************************************************************/ | |
| 411 /* The subr object type */ | |
| 412 /************************************************************************/ | |
| 413 | |
| 414 static void | |
| 2286 | 415 print_subr (Lisp_Object obj, Lisp_Object printcharfun, int UNUSED (escapeflag)) |
| 428 | 416 { |
| 417 Lisp_Subr *subr = XSUBR (obj); | |
| 867 | 418 const CIbyte *header = |
| 428 | 419 (subr->max_args == UNEVALLED) ? "#<special-form " : "#<subr "; |
| 867 | 420 const CIbyte *name = subr_name (subr); |
| 421 const CIbyte *trailer = subr->prompt ? " (interactive)>" : ">"; | |
| 428 | 422 |
| 423 if (print_readably) | |
| 563 | 424 printing_unreadable_object ("%s%s%s", header, name, trailer); |
| 428 | 425 |
| 826 | 426 write_c_string (printcharfun, header); |
| 427 write_c_string (printcharfun, name); | |
| 428 write_c_string (printcharfun, trailer); | |
| 428 | 429 } |
| 430 | |
| 1204 | 431 static const struct memory_description subr_description[] = { |
| 2551 | 432 { XD_DOC_STRING, offsetof (Lisp_Subr, doc), 0, { 0 }, XD_FLAG_NO_KKCC }, |
| 428 | 433 { XD_END } |
| 434 }; | |
| 435 | |
| 938 | 436 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("subr", subr, |
| 437 1, /*dumpable-flag*/ | |
| 438 0, print_subr, 0, 0, 0, | |
| 439 subr_description, | |
| 440 Lisp_Subr); | |
| 428 | 441 |
| 442 /************************************************************************/ | |
| 443 /* Entering the debugger */ | |
| 444 /************************************************************************/ | |
| 445 | |
| 853 | 446 static Lisp_Object |
| 447 current_warning_level (void) | |
| 448 { | |
| 449 if (inhibit_flags & ISSUE_WARNINGS_AT_DEBUG_LEVEL) | |
| 450 return Qdebug; | |
| 451 else | |
| 452 return Qwarning; | |
| 453 } | |
| 454 | |
| 428 | 455 /* Actually call the debugger. ARG is a list of args that will be |
| 456 passed to the debugger function, as follows; | |
| 457 | |
| 458 If due to frame exit, args are `exit' and the value being returned; | |
| 459 this function's value will be returned instead of that. | |
| 460 If due to error, args are `error' and a list of the args to `signal'. | |
| 461 If due to `apply' or `funcall' entry, one arg, `lambda'. | |
| 462 If due to `eval' entry, one arg, t. | |
| 463 | |
| 464 */ | |
| 465 | |
| 466 static Lisp_Object | |
| 467 call_debugger_259 (Lisp_Object arg) | |
| 468 { | |
| 469 return apply1 (Vdebugger, arg); | |
| 470 } | |
| 471 | |
| 472 /* Call the debugger, doing some encapsulation. We make sure we have | |
| 473 some room on the eval and specpdl stacks, and bind entering_debugger | |
| 474 to 1 during this call. This is used to trap errors that may occur | |
| 475 when entering the debugger (e.g. the value of `debugger' is invalid), | |
| 476 so that the debugger will not be recursively entered if debug-on-error | |
| 477 is set. (Otherwise, XEmacs would infinitely recurse, attempting to | |
| 478 enter the debugger.) entering_debugger gets reset to 0 as soon | |
| 479 as a backtrace is displayed, so that further errors can indeed be | |
| 480 handled normally. | |
| 481 | |
| 3025 | 482 We also establish a catch for `debugger'. If the debugger function |
| 428 | 483 throws to this instead of returning a value, it means that the user |
| 484 pressed 'c' (pretend like the debugger was never entered). The | |
| 485 function then returns Qunbound. (If the user pressed 'r', for | |
| 486 return a value, then the debugger function returns normally with | |
| 487 this value.) | |
| 488 | |
| 489 The difference between 'c' and 'r' is as follows: | |
| 490 | |
| 491 debug-on-call: | |
| 492 No difference. The call proceeds as normal. | |
| 493 debug-on-exit: | |
| 494 With 'r', the specified value is returned as the function's | |
| 495 return value. With 'c', the value that would normally be | |
| 496 returned is returned. | |
| 497 signal: | |
| 498 With 'r', the specified value is returned as the return | |
| 499 value of `signal'. (This is the only time that `signal' | |
| 500 can return, instead of making a non-local exit.) With `c', | |
| 501 `signal' will continue looking for handlers as if the | |
| 502 debugger was never entered, and will probably end up | |
| 503 throwing to a handler or to top-level. | |
| 504 */ | |
| 505 | |
| 506 static Lisp_Object | |
| 507 call_debugger (Lisp_Object arg) | |
| 508 { | |
| 509 int threw; | |
| 510 Lisp_Object val; | |
| 511 int speccount; | |
| 512 | |
| 853 | 513 debug_on_next_call = 0; |
| 514 | |
| 515 if (inhibit_flags & INHIBIT_ENTERING_DEBUGGER) | |
| 516 { | |
| 517 if (!(inhibit_flags & INHIBIT_WARNING_ISSUE)) | |
| 518 warn_when_safe | |
| 519 (Qdebugger, current_warning_level (), | |
| 520 "Unable to enter debugger within critical section"); | |
| 521 return Qunbound; | |
| 522 } | |
| 523 | |
| 428 | 524 if (lisp_eval_depth + 20 > max_lisp_eval_depth) |
| 525 max_lisp_eval_depth = lisp_eval_depth + 20; | |
| 526 if (specpdl_size + 40 > max_specpdl_size) | |
| 527 max_specpdl_size = specpdl_size + 40; | |
| 853 | 528 |
| 529 speccount = internal_bind_int (&entering_debugger, 1); | |
| 2532 | 530 val = internal_catch (Qdebugger, call_debugger_259, arg, &threw, 0, 0); |
| 428 | 531 |
| 771 | 532 return unbind_to_1 (speccount, ((threw) |
| 428 | 533 ? Qunbound /* Not returning a value */ |
| 534 : val)); | |
| 535 } | |
| 536 | |
| 537 /* Called when debug-on-exit behavior is called for. Enter the debugger | |
| 538 with the appropriate args for this. VAL is the exit value that is | |
| 539 about to be returned. */ | |
| 540 | |
| 541 static Lisp_Object | |
| 542 do_debug_on_exit (Lisp_Object val) | |
| 543 { | |
| 544 /* This is falsified by call_debugger */ | |
| 545 Lisp_Object v = call_debugger (list2 (Qexit, val)); | |
| 546 | |
| 547 return !UNBOUNDP (v) ? v : val; | |
| 548 } | |
| 549 | |
| 550 /* Called when debug-on-call behavior is called for. Enter the debugger | |
| 551 with the appropriate args for this. VAL is either t for a call | |
| 3025 | 552 through `eval' or `lambda' for a call through `funcall'. |
| 428 | 553 |
| 554 #### The differentiation here between EVAL and FUNCALL is bogus. | |
| 555 FUNCALL can be defined as | |
| 556 | |
| 557 (defmacro func (fun &rest args) | |
| 558 (cons (eval fun) args)) | |
| 559 | |
| 560 and should be treated as such. | |
| 561 */ | |
| 562 | |
| 563 static void | |
| 564 do_debug_on_call (Lisp_Object code) | |
| 565 { | |
| 566 debug_on_next_call = 0; | |
| 567 backtrace_list->debug_on_exit = 1; | |
| 568 call_debugger (list1 (code)); | |
| 569 } | |
| 570 | |
| 571 /* LIST is the value of one of the variables `debug-on-error', | |
| 572 `debug-on-signal', `stack-trace-on-error', or `stack-trace-on-signal', | |
| 573 and CONDITIONS is the list of error conditions associated with | |
| 574 the error being signalled. This returns non-nil if LIST | |
| 575 matches CONDITIONS. (A nil value for LIST does not match | |
| 576 CONDITIONS. A non-list value for LIST does match CONDITIONS. | |
| 577 A list matches CONDITIONS when one of the symbols in LIST is the | |
| 578 same as one of the symbols in CONDITIONS.) */ | |
| 579 | |
| 580 static int | |
| 581 wants_debugger (Lisp_Object list, Lisp_Object conditions) | |
| 582 { | |
| 583 if (NILP (list)) | |
| 584 return 0; | |
| 585 if (! CONSP (list)) | |
| 586 return 1; | |
| 587 | |
| 588 while (CONSP (conditions)) | |
| 589 { | |
| 2552 | 590 Lisp_Object curr, tail; |
| 591 curr = XCAR (conditions); | |
| 428 | 592 for (tail = list; CONSP (tail); tail = XCDR (tail)) |
| 2552 | 593 if (EQ (XCAR (tail), curr)) |
| 428 | 594 return 1; |
| 595 conditions = XCDR (conditions); | |
| 596 } | |
| 597 return 0; | |
| 598 } | |
| 599 | |
| 600 | |
| 601 /* Return 1 if an error with condition-symbols CONDITIONS, | |
| 602 and described by SIGNAL-DATA, should skip the debugger | |
| 603 according to debugger-ignore-errors. */ | |
| 604 | |
| 605 static int | |
| 606 skip_debugger (Lisp_Object conditions, Lisp_Object data) | |
| 607 { | |
| 608 /* This function can GC */ | |
| 609 Lisp_Object tail; | |
| 610 int first_string = 1; | |
| 611 Lisp_Object error_message = Qnil; | |
| 612 | |
| 613 for (tail = Vdebug_ignored_errors; CONSP (tail); tail = XCDR (tail)) | |
| 614 { | |
| 615 if (STRINGP (XCAR (tail))) | |
| 616 { | |
| 617 if (first_string) | |
| 618 { | |
| 619 error_message = Ferror_message_string (data); | |
| 620 first_string = 0; | |
| 621 } | |
| 622 if (fast_lisp_string_match (XCAR (tail), error_message) >= 0) | |
| 623 return 1; | |
| 624 } | |
| 625 else | |
| 626 { | |
| 627 Lisp_Object contail; | |
| 628 | |
| 629 for (contail = conditions; CONSP (contail); contail = XCDR (contail)) | |
| 630 if (EQ (XCAR (tail), XCAR (contail))) | |
| 631 return 1; | |
| 632 } | |
| 633 } | |
| 634 | |
| 635 return 0; | |
| 636 } | |
| 637 | |
| 638 /* Actually generate a backtrace on STREAM. */ | |
| 639 | |
| 640 static Lisp_Object | |
| 641 backtrace_259 (Lisp_Object stream) | |
| 642 { | |
| 643 return Fbacktrace (stream, Qt); | |
| 644 } | |
| 645 | |
| 1130 | 646 #ifdef DEBUG_XEMACS |
| 647 | |
| 648 static void | |
| 649 trace_out_and_die (Lisp_Object err) | |
| 650 { | |
| 651 Fdisplay_error (err, Qt); | |
| 652 backtrace_259 (Qnil); | |
| 653 stderr_out ("XEmacs exiting to debugger.\n"); | |
| 654 Fforce_debugging_signal (Qt); | |
| 655 /* Unlikely to be reached */ | |
| 656 } | |
| 657 | |
| 658 #endif | |
| 659 | |
| 428 | 660 /* An error was signaled. Maybe call the debugger, if the `debug-on-error' |
| 661 etc. variables call for this. CONDITIONS is the list of conditions | |
| 662 associated with the error being signalled. SIG is the actual error | |
| 663 being signalled, and DATA is the associated data (these are exactly | |
| 664 the same as the arguments to `signal'). ACTIVE_HANDLERS is the | |
| 665 list of error handlers that are to be put in place while the debugger | |
| 666 is called. This is generally the remaining handlers that are | |
| 667 outside of the innermost handler trapping this error. This way, | |
| 668 if the same error occurs inside of the debugger, you usually don't get | |
| 669 the debugger entered recursively. | |
| 670 | |
| 671 This function returns Qunbound if it didn't call the debugger or if | |
| 672 the user asked (through 'c') that XEmacs should pretend like the | |
| 673 debugger was never entered. Otherwise, it returns the value | |
| 674 that the user specified with `r'. (Note that much of the time, | |
| 675 the user will abort with C-], and we will never have a chance to | |
| 676 return anything at all.) | |
| 677 | |
| 678 SIGNAL_VARS_ONLY means we should only look at debug-on-signal | |
| 679 and stack-trace-on-signal to control whether we do anything. | |
| 680 This is so that debug-on-error doesn't make handled errors | |
| 681 cause the debugger to get invoked. | |
| 682 | |
| 683 STACK_TRACE_DISPLAYED and DEBUGGER_ENTERED are used so that | |
| 684 those functions aren't done more than once in a single `signal' | |
| 685 session. */ | |
| 686 | |
| 687 static Lisp_Object | |
| 688 signal_call_debugger (Lisp_Object conditions, | |
| 689 Lisp_Object sig, Lisp_Object data, | |
| 690 Lisp_Object active_handlers, | |
| 691 int signal_vars_only, | |
| 692 int *stack_trace_displayed, | |
| 693 int *debugger_entered) | |
| 694 { | |
| 853 | 695 #ifdef PIGS_FLY_AND_ALL_C_CODE_CAN_HANDLE_GC_OCCURRING_ALMOST_ANYWHERE |
| 428 | 696 /* This function can GC */ |
| 853 | 697 #else /* reality check */ |
| 698 /* This function cannot GC because it inhibits GC during its operation */ | |
| 699 #endif | |
| 700 | |
| 428 | 701 Lisp_Object val = Qunbound; |
| 702 Lisp_Object all_handlers = Vcondition_handlers; | |
| 703 Lisp_Object temp_data = Qnil; | |
| 853 | 704 int outer_speccount = specpdl_depth(); |
| 705 int speccount; | |
| 706 | |
| 707 #ifdef PIGS_FLY_AND_ALL_C_CODE_CAN_HANDLE_GC_OCCURRING_ALMOST_ANYWHERE | |
| 428 | 708 struct gcpro gcpro1, gcpro2; |
| 709 GCPRO2 (all_handlers, temp_data); | |
| 853 | 710 #else |
| 711 begin_gc_forbidden (); | |
| 712 #endif | |
| 713 | |
| 714 speccount = specpdl_depth(); | |
| 428 | 715 |
| 716 Vcondition_handlers = active_handlers; | |
| 717 | |
| 718 temp_data = Fcons (sig, data); /* needed for skip_debugger */ | |
| 719 | |
| 720 if (!entering_debugger && !*stack_trace_displayed && !signal_vars_only | |
| 721 && wants_debugger (Vstack_trace_on_error, conditions) | |
| 722 && !skip_debugger (conditions, temp_data)) | |
| 723 { | |
| 724 specbind (Qdebug_on_error, Qnil); | |
| 725 specbind (Qstack_trace_on_error, Qnil); | |
| 726 specbind (Qdebug_on_signal, Qnil); | |
| 727 specbind (Qstack_trace_on_signal, Qnil); | |
| 728 | |
| 442 | 729 if (!noninteractive) |
| 730 internal_with_output_to_temp_buffer (build_string ("*Backtrace*"), | |
| 731 backtrace_259, | |
| 732 Qnil, | |
| 733 Qnil); | |
| 734 else /* in batch mode, we want this going to stderr. */ | |
| 735 backtrace_259 (Qnil); | |
| 771 | 736 unbind_to (speccount); |
| 428 | 737 *stack_trace_displayed = 1; |
| 738 } | |
| 739 | |
| 740 if (!entering_debugger && !*debugger_entered && !signal_vars_only | |
| 741 && (EQ (sig, Qquit) | |
| 742 ? debug_on_quit | |
| 743 : wants_debugger (Vdebug_on_error, conditions)) | |
| 744 && !skip_debugger (conditions, temp_data)) | |
| 745 { | |
| 746 debug_on_quit &= ~2; /* reset critical bit */ | |
| 1123 | 747 |
| 428 | 748 specbind (Qdebug_on_error, Qnil); |
| 749 specbind (Qstack_trace_on_error, Qnil); | |
| 750 specbind (Qdebug_on_signal, Qnil); | |
| 751 specbind (Qstack_trace_on_signal, Qnil); | |
| 752 | |
| 1130 | 753 #ifdef DEBUG_XEMACS |
| 754 if (noninteractive) | |
| 755 trace_out_and_die (Fcons (sig, data)); | |
| 756 #endif | |
| 757 | |
| 428 | 758 val = call_debugger (list2 (Qerror, (Fcons (sig, data)))); |
| 853 | 759 unbind_to (speccount); |
| 428 | 760 *debugger_entered = 1; |
| 761 } | |
| 762 | |
| 763 if (!entering_debugger && !*stack_trace_displayed | |
| 764 && wants_debugger (Vstack_trace_on_signal, conditions)) | |
| 765 { | |
| 766 specbind (Qdebug_on_error, Qnil); | |
| 767 specbind (Qstack_trace_on_error, Qnil); | |
| 768 specbind (Qdebug_on_signal, Qnil); | |
| 769 specbind (Qstack_trace_on_signal, Qnil); | |
| 770 | |
| 442 | 771 if (!noninteractive) |
| 772 internal_with_output_to_temp_buffer (build_string ("*Backtrace*"), | |
| 773 backtrace_259, | |
| 774 Qnil, | |
| 775 Qnil); | |
| 776 else /* in batch mode, we want this going to stderr. */ | |
| 777 backtrace_259 (Qnil); | |
| 771 | 778 unbind_to (speccount); |
| 428 | 779 *stack_trace_displayed = 1; |
| 780 } | |
| 781 | |
| 782 if (!entering_debugger && !*debugger_entered | |
| 783 && (EQ (sig, Qquit) | |
| 784 ? debug_on_quit | |
| 785 : wants_debugger (Vdebug_on_signal, conditions))) | |
| 786 { | |
| 787 debug_on_quit &= ~2; /* reset critical bit */ | |
| 1123 | 788 |
| 428 | 789 specbind (Qdebug_on_error, Qnil); |
| 790 specbind (Qstack_trace_on_error, Qnil); | |
| 791 specbind (Qdebug_on_signal, Qnil); | |
| 792 specbind (Qstack_trace_on_signal, Qnil); | |
| 793 | |
| 1130 | 794 #ifdef DEBUG_XEMACS |
| 795 if (noninteractive) | |
| 796 trace_out_and_die (Fcons (sig, data)); | |
| 797 #endif | |
| 798 | |
| 428 | 799 val = call_debugger (list2 (Qerror, (Fcons (sig, data)))); |
| 800 *debugger_entered = 1; | |
| 801 } | |
| 802 | |
| 853 | 803 #ifdef PIGS_FLY_AND_ALL_C_CODE_CAN_HANDLE_GC_OCCURRING_ALMOST_ANYWHERE |
| 428 | 804 UNGCPRO; |
| 853 | 805 #endif |
| 428 | 806 Vcondition_handlers = all_handlers; |
| 853 | 807 return unbind_to_1 (outer_speccount, val); |
| 428 | 808 } |
| 809 | |
| 810 | |
| 811 /************************************************************************/ | |
| 812 /* The basic special forms */ | |
| 813 /************************************************************************/ | |
| 814 | |
| 815 /* Except for Fprogn(), the basic special forms below are only called | |
| 816 from interpreted code. The byte compiler turns them into bytecodes. */ | |
| 817 | |
| 818 DEFUN ("or", For, 0, UNEVALLED, 0, /* | |
| 819 Eval args until one of them yields non-nil, then return that value. | |
| 820 The remaining args are not evalled at all. | |
| 821 If all args return nil, return nil. | |
| 822 */ | |
| 823 (args)) | |
| 824 { | |
| 825 /* This function can GC */ | |
| 442 | 826 REGISTER Lisp_Object val; |
| 428 | 827 |
| 828 LIST_LOOP_2 (arg, args) | |
| 829 { | |
| 830 if (!NILP (val = Feval (arg))) | |
| 831 return val; | |
| 832 } | |
| 833 | |
| 834 return Qnil; | |
| 835 } | |
| 836 | |
| 837 DEFUN ("and", Fand, 0, UNEVALLED, 0, /* | |
| 838 Eval args until one of them yields nil, then return nil. | |
| 839 The remaining args are not evalled at all. | |
| 840 If no arg yields nil, return the last arg's value. | |
| 841 */ | |
| 842 (args)) | |
| 843 { | |
| 844 /* This function can GC */ | |
| 442 | 845 REGISTER Lisp_Object val = Qt; |
| 428 | 846 |
| 847 LIST_LOOP_2 (arg, args) | |
| 848 { | |
| 849 if (NILP (val = Feval (arg))) | |
| 850 return val; | |
| 851 } | |
| 852 | |
| 853 return val; | |
| 854 } | |
| 855 | |
| 856 DEFUN ("if", Fif, 2, UNEVALLED, 0, /* | |
| 857 \(if COND THEN ELSE...): if COND yields non-nil, do THEN, else do ELSE... | |
| 858 Returns the value of THEN or the value of the last of the ELSE's. | |
| 859 THEN must be one expression, but ELSE... can be zero or more expressions. | |
| 860 If COND yields nil, and there are no ELSE's, the value is nil. | |
| 861 */ | |
| 862 (args)) | |
| 863 { | |
| 864 /* This function can GC */ | |
| 865 Lisp_Object condition = XCAR (args); | |
| 866 Lisp_Object then_form = XCAR (XCDR (args)); | |
| 867 Lisp_Object else_forms = XCDR (XCDR (args)); | |
| 868 | |
| 869 if (!NILP (Feval (condition))) | |
| 870 return Feval (then_form); | |
| 871 else | |
| 872 return Fprogn (else_forms); | |
| 873 } | |
| 874 | |
| 875 /* Macros `when' and `unless' are trivially defined in Lisp, | |
| 876 but it helps for bootstrapping to have them ALWAYS defined. */ | |
| 877 | |
| 878 DEFUN ("when", Fwhen, 1, MANY, 0, /* | |
| 879 \(when COND BODY...): if COND yields non-nil, do BODY, else return nil. | |
| 880 BODY can be zero or more expressions. If BODY is nil, return nil. | |
| 881 */ | |
| 882 (int nargs, Lisp_Object *args)) | |
| 883 { | |
| 884 Lisp_Object cond = args[0]; | |
| 885 Lisp_Object body; | |
| 853 | 886 |
| 428 | 887 switch (nargs) |
| 888 { | |
| 889 case 1: body = Qnil; break; | |
| 890 case 2: body = args[1]; break; | |
| 891 default: body = Fcons (Qprogn, Flist (nargs-1, args+1)); break; | |
| 892 } | |
| 893 | |
| 894 return list3 (Qif, cond, body); | |
| 895 } | |
| 896 | |
| 897 DEFUN ("unless", Funless, 1, MANY, 0, /* | |
| 898 \(unless COND BODY...): if COND yields nil, do BODY, else return nil. | |
| 899 BODY can be zero or more expressions. If BODY is nil, return nil. | |
| 900 */ | |
| 901 (int nargs, Lisp_Object *args)) | |
| 902 { | |
| 903 Lisp_Object cond = args[0]; | |
| 904 Lisp_Object body = Flist (nargs-1, args+1); | |
| 905 return Fcons (Qif, Fcons (cond, Fcons (Qnil, body))); | |
| 906 } | |
| 907 | |
| 908 DEFUN ("cond", Fcond, 0, UNEVALLED, 0, /* | |
| 444 | 909 \(cond CLAUSES...): try each clause until one succeeds. |
| 428 | 910 Each clause looks like (CONDITION BODY...). CONDITION is evaluated |
| 911 and, if the value is non-nil, this clause succeeds: | |
| 912 then the expressions in BODY are evaluated and the last one's | |
| 913 value is the value of the cond-form. | |
| 914 If no clause succeeds, cond returns nil. | |
| 915 If a clause has one element, as in (CONDITION), | |
| 916 CONDITION's value if non-nil is returned from the cond-form. | |
| 917 */ | |
| 918 (args)) | |
| 919 { | |
| 920 /* This function can GC */ | |
| 442 | 921 REGISTER Lisp_Object val; |
| 428 | 922 |
| 923 LIST_LOOP_2 (clause, args) | |
| 924 { | |
| 925 CHECK_CONS (clause); | |
| 926 if (!NILP (val = Feval (XCAR (clause)))) | |
| 927 { | |
| 928 if (!NILP (clause = XCDR (clause))) | |
| 929 { | |
| 930 CHECK_TRUE_LIST (clause); | |
| 931 val = Fprogn (clause); | |
| 932 } | |
| 933 return val; | |
| 934 } | |
| 935 } | |
| 936 | |
| 937 return Qnil; | |
| 938 } | |
| 939 | |
| 940 DEFUN ("progn", Fprogn, 0, UNEVALLED, 0, /* | |
| 941 \(progn BODY...): eval BODY forms sequentially and return value of last one. | |
| 942 */ | |
| 943 (args)) | |
| 944 { | |
| 945 /* This function can GC */ | |
| 946 /* Caller must provide a true list in ARGS */ | |
| 442 | 947 REGISTER Lisp_Object val = Qnil; |
| 428 | 948 struct gcpro gcpro1; |
| 949 | |
| 950 GCPRO1 (args); | |
| 951 | |
| 952 { | |
| 953 LIST_LOOP_2 (form, args) | |
| 954 val = Feval (form); | |
| 955 } | |
| 956 | |
| 957 UNGCPRO; | |
| 958 return val; | |
| 959 } | |
| 960 | |
| 961 /* Fprog1() is the canonical example of a function that must GCPRO a | |
| 962 Lisp_Object across calls to Feval(). */ | |
| 963 | |
| 964 DEFUN ("prog1", Fprog1, 1, UNEVALLED, 0, /* | |
| 965 Similar to `progn', but the value of the first form is returned. | |
| 966 \(prog1 FIRST BODY...): All the arguments are evaluated sequentially. | |
| 967 The value of FIRST is saved during evaluation of the remaining args, | |
| 968 whose values are discarded. | |
| 969 */ | |
| 970 (args)) | |
| 971 { | |
| 972 /* This function can GC */ | |
| 1849 | 973 Lisp_Object val; |
| 428 | 974 struct gcpro gcpro1; |
| 975 | |
| 976 val = Feval (XCAR (args)); | |
| 977 | |
| 978 GCPRO1 (val); | |
| 979 | |
| 980 { | |
| 981 LIST_LOOP_2 (form, XCDR (args)) | |
| 982 Feval (form); | |
| 983 } | |
| 984 | |
| 985 UNGCPRO; | |
| 986 return val; | |
| 987 } | |
| 988 | |
| 989 DEFUN ("prog2", Fprog2, 2, UNEVALLED, 0, /* | |
| 990 Similar to `progn', but the value of the second form is returned. | |
| 991 \(prog2 FIRST SECOND BODY...): All the arguments are evaluated sequentially. | |
| 992 The value of SECOND is saved during evaluation of the remaining args, | |
| 993 whose values are discarded. | |
| 994 */ | |
| 995 (args)) | |
| 996 { | |
| 997 /* This function can GC */ | |
| 1849 | 998 Lisp_Object val; |
| 428 | 999 struct gcpro gcpro1; |
| 1000 | |
| 1001 Feval (XCAR (args)); | |
| 1002 args = XCDR (args); | |
| 1003 val = Feval (XCAR (args)); | |
| 1004 args = XCDR (args); | |
| 1005 | |
| 1006 GCPRO1 (val); | |
| 1007 | |
| 442 | 1008 { |
| 1009 LIST_LOOP_2 (form, args) | |
| 1010 Feval (form); | |
| 1011 } | |
| 428 | 1012 |
| 1013 UNGCPRO; | |
| 1014 return val; | |
| 1015 } | |
| 1016 | |
| 1017 DEFUN ("let*", FletX, 1, UNEVALLED, 0, /* | |
| 1018 \(let* VARLIST BODY...): bind variables according to VARLIST then eval BODY. | |
| 1019 The value of the last form in BODY is returned. | |
| 1020 Each element of VARLIST is a symbol (which is bound to nil) | |
| 1021 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM). | |
| 1022 Each VALUEFORM can refer to the symbols already bound by this VARLIST. | |
| 1023 */ | |
| 1024 (args)) | |
| 1025 { | |
| 1026 /* This function can GC */ | |
| 1027 Lisp_Object varlist = XCAR (args); | |
| 1028 Lisp_Object body = XCDR (args); | |
| 1029 int speccount = specpdl_depth(); | |
| 1030 | |
| 1031 EXTERNAL_LIST_LOOP_3 (var, varlist, tail) | |
| 1032 { | |
| 1033 Lisp_Object symbol, value, tem; | |
| 1034 if (SYMBOLP (var)) | |
| 1035 symbol = var, value = Qnil; | |
| 1036 else | |
| 1037 { | |
| 1038 CHECK_CONS (var); | |
| 1039 symbol = XCAR (var); | |
| 1040 tem = XCDR (var); | |
| 1041 if (NILP (tem)) | |
| 1042 value = Qnil; | |
| 1043 else | |
| 1044 { | |
| 1045 CHECK_CONS (tem); | |
| 1046 value = Feval (XCAR (tem)); | |
| 1047 if (!NILP (XCDR (tem))) | |
| 563 | 1048 sferror |
| 428 | 1049 ("`let' bindings can have only one value-form", var); |
| 1050 } | |
| 1051 } | |
| 1052 specbind (symbol, value); | |
| 1053 } | |
| 771 | 1054 return unbind_to_1 (speccount, Fprogn (body)); |
| 428 | 1055 } |
| 1056 | |
| 1057 DEFUN ("let", Flet, 1, UNEVALLED, 0, /* | |
| 1058 \(let VARLIST BODY...): bind variables according to VARLIST then eval BODY. | |
| 1059 The value of the last form in BODY is returned. | |
| 1060 Each element of VARLIST is a symbol (which is bound to nil) | |
| 1061 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM). | |
| 1062 All the VALUEFORMs are evalled before any symbols are bound. | |
| 1063 */ | |
| 1064 (args)) | |
| 1065 { | |
| 1066 /* This function can GC */ | |
| 1067 Lisp_Object varlist = XCAR (args); | |
| 1068 Lisp_Object body = XCDR (args); | |
| 1069 int speccount = specpdl_depth(); | |
| 1070 Lisp_Object *temps; | |
| 1071 int idx; | |
| 1072 struct gcpro gcpro1; | |
| 1073 | |
| 1074 /* Make space to hold the values to give the bound variables. */ | |
| 1075 { | |
| 1076 int varcount; | |
| 1077 GET_EXTERNAL_LIST_LENGTH (varlist, varcount); | |
| 1078 temps = alloca_array (Lisp_Object, varcount); | |
| 1079 } | |
| 1080 | |
| 1081 /* Compute the values and store them in `temps' */ | |
| 1082 GCPRO1 (*temps); | |
| 1083 gcpro1.nvars = 0; | |
| 1084 | |
| 1085 idx = 0; | |
| 442 | 1086 { |
| 1087 LIST_LOOP_2 (var, varlist) | |
| 1088 { | |
| 1089 Lisp_Object *value = &temps[idx++]; | |
| 1090 if (SYMBOLP (var)) | |
| 1091 *value = Qnil; | |
| 1092 else | |
| 1093 { | |
| 1094 Lisp_Object tem; | |
| 1095 CHECK_CONS (var); | |
| 1096 tem = XCDR (var); | |
| 1097 if (NILP (tem)) | |
| 1098 *value = Qnil; | |
| 1099 else | |
| 1100 { | |
| 1101 CHECK_CONS (tem); | |
| 1102 *value = Feval (XCAR (tem)); | |
| 1103 gcpro1.nvars = idx; | |
| 1104 | |
| 1105 if (!NILP (XCDR (tem))) | |
| 563 | 1106 sferror |
| 442 | 1107 ("`let' bindings can have only one value-form", var); |
| 1108 } | |
| 1109 } | |
| 1110 } | |
| 1111 } | |
| 428 | 1112 |
| 1113 idx = 0; | |
| 442 | 1114 { |
| 1115 LIST_LOOP_2 (var, varlist) | |
| 1116 { | |
| 1117 specbind (SYMBOLP (var) ? var : XCAR (var), temps[idx++]); | |
| 1118 } | |
| 1119 } | |
| 428 | 1120 |
| 1121 UNGCPRO; | |
| 1122 | |
| 771 | 1123 return unbind_to_1 (speccount, Fprogn (body)); |
| 428 | 1124 } |
| 1125 | |
| 1126 DEFUN ("while", Fwhile, 1, UNEVALLED, 0, /* | |
| 1127 \(while TEST BODY...): if TEST yields non-nil, eval BODY... and repeat. | |
| 1128 The order of execution is thus TEST, BODY, TEST, BODY and so on | |
| 1129 until TEST returns nil. | |
| 1130 */ | |
| 1131 (args)) | |
| 1132 { | |
| 1133 /* This function can GC */ | |
| 1134 Lisp_Object test = XCAR (args); | |
| 1135 Lisp_Object body = XCDR (args); | |
| 1136 | |
| 1137 while (!NILP (Feval (test))) | |
| 1138 { | |
| 1139 QUIT; | |
| 1140 Fprogn (body); | |
| 1141 } | |
| 1142 | |
| 1143 return Qnil; | |
| 1144 } | |
| 1145 | |
| 1146 DEFUN ("setq", Fsetq, 0, UNEVALLED, 0, /* | |
| 1147 \(setq SYM VAL SYM VAL ...): set each SYM to the value of its VAL. | |
| 1148 The symbols SYM are variables; they are literal (not evaluated). | |
| 1149 The values VAL are expressions; they are evaluated. | |
| 1150 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'. | |
| 1151 The second VAL is not computed until after the first SYM is set, and so on; | |
| 1152 each VAL can use the new value of variables set earlier in the `setq'. | |
| 1153 The return value of the `setq' form is the value of the last VAL. | |
| 1154 */ | |
| 1155 (args)) | |
| 1156 { | |
| 1157 /* This function can GC */ | |
| 1158 int nargs; | |
| 2421 | 1159 Lisp_Object retval = Qnil; |
| 428 | 1160 |
| 1161 GET_LIST_LENGTH (args, nargs); | |
| 1162 | |
| 1163 if (nargs & 1) /* Odd number of arguments? */ | |
| 1164 Fsignal (Qwrong_number_of_arguments, list2 (Qsetq, make_int (nargs))); | |
| 1165 | |
| 2421 | 1166 GC_PROPERTY_LIST_LOOP_3 (symbol, val, args) |
| 428 | 1167 { |
| 1168 val = Feval (val); | |
| 1169 Fset (symbol, val); | |
| 2421 | 1170 retval = val; |
| 428 | 1171 } |
| 1172 | |
| 2421 | 1173 END_GC_PROPERTY_LIST_LOOP (symbol); |
| 1174 | |
| 1175 return retval; | |
| 428 | 1176 } |
| 1177 | |
| 1178 DEFUN ("quote", Fquote, 1, UNEVALLED, 0, /* | |
| 1179 Return the argument, without evaluating it. `(quote x)' yields `x'. | |
| 3794 | 1180 |
| 3842 | 1181 `quote' differs from `function' in that it is a hint that an expression is |
| 1182 data, not a function. In particular, under some circumstances the byte | |
| 1183 compiler will compile an expression quoted with `function', but it will | |
| 1184 never do so for an expression quoted with `quote'. These issues are most | |
| 1185 important for lambda expressions (see `lambda'). | |
| 1186 | |
| 1187 There is an alternative, more readable, reader syntax for `quote': a Lisp | |
| 1188 object preceded by `''. Thus, `'x' is equivalent to `(quote x)', in all | |
| 1189 contexts. A print function may use either. Internally the expression is | |
| 1190 represented as `(quote x)'). | |
| 428 | 1191 */ |
| 1192 (args)) | |
| 1193 { | |
| 1194 return XCAR (args); | |
| 1195 } | |
| 1196 | |
| 1197 DEFUN ("function", Ffunction, 1, UNEVALLED, 0, /* | |
| 3842 | 1198 Return the argument, without evaluating it. `(function x)' yields `x'. |
| 1199 | |
| 1200 `function' differs from `quote' in that it is a hint that an expression is | |
| 1201 a function, not data. In particular, under some circumstances the byte | |
| 1202 compiler will compile an expression quoted with `function', but it will | |
| 1203 never do so for an expression quoted with `quote'. However, the byte | |
| 1204 compiler will not compile an expression buried in a data structure such as | |
| 1205 a vector or a list which is not syntactically a function. These issues are | |
| 1206 most important for lambda expressions (see `lambda'). | |
| 1207 | |
| 1208 There is an alternative, more readable, reader syntax for `function': a Lisp | |
| 1209 object preceded by `#''. Thus, #'x is equivalent to (function x), in all | |
| 1210 contexts. A print function may use either. Internally the expression is | |
| 1211 represented as `(function x)'). | |
| 428 | 1212 */ |
| 1213 (args)) | |
| 1214 { | |
| 1215 return XCAR (args); | |
| 1216 } | |
| 1217 | |
| 1218 | |
| 1219 /************************************************************************/ | |
| 1220 /* Defining functions/variables */ | |
| 1221 /************************************************************************/ | |
| 1222 static Lisp_Object | |
| 1223 define_function (Lisp_Object name, Lisp_Object defn) | |
| 1224 { | |
| 1225 Ffset (name, defn); | |
|
4535
69a1eda3da06
Distinguish vars and functions in #'symbol-file, #'describe-{function,variable}
Aidan Kehoe <kehoea@parhasard.net>
parents:
4502
diff
changeset
|
1226 LOADHIST_ATTACH (Fcons (Qdefun, name)); |
| 428 | 1227 return name; |
| 1228 } | |
| 1229 | |
| 1230 DEFUN ("defun", Fdefun, 2, UNEVALLED, 0, /* | |
| 1231 \(defun NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function. | |
| 1232 The definition is (lambda ARGLIST [DOCSTRING] BODY...). | |
| 1233 See also the function `interactive'. | |
| 1234 */ | |
| 1235 (args)) | |
| 1236 { | |
| 1237 /* This function can GC */ | |
| 1238 return define_function (XCAR (args), | |
| 1239 Fcons (Qlambda, XCDR (args))); | |
| 1240 } | |
| 1241 | |
| 1242 DEFUN ("defmacro", Fdefmacro, 2, UNEVALLED, 0, /* | |
| 1243 \(defmacro NAME ARGLIST [DOCSTRING] BODY...): define NAME as a macro. | |
| 1244 The definition is (macro lambda ARGLIST [DOCSTRING] BODY...). | |
| 1245 When the macro is called, as in (NAME ARGS...), | |
| 1246 the function (lambda ARGLIST BODY...) is applied to | |
| 1247 the list ARGS... as it appears in the expression, | |
| 1248 and the result should be a form to be evaluated instead of the original. | |
| 1249 */ | |
| 1250 (args)) | |
| 1251 { | |
| 1252 /* This function can GC */ | |
| 1253 return define_function (XCAR (args), | |
| 1254 Fcons (Qmacro, Fcons (Qlambda, XCDR (args)))); | |
| 1255 } | |
| 1256 | |
| 1257 DEFUN ("defvar", Fdefvar, 1, UNEVALLED, 0, /* | |
| 1258 \(defvar SYMBOL INITVALUE DOCSTRING): define SYMBOL as a variable. | |
| 1259 You are not required to define a variable in order to use it, | |
| 1260 but the definition can supply documentation and an initial value | |
| 1261 in a way that tags can recognize. | |
| 1262 | |
| 1263 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is | |
| 1264 void. (However, when you evaluate a defvar interactively, it acts like a | |
| 1265 defconst: SYMBOL's value is always set regardless of whether it's currently | |
| 1266 void.) | |
| 1267 If SYMBOL is buffer-local, its default value is what is set; | |
| 1268 buffer-local values are not affected. | |
| 1269 INITVALUE and DOCSTRING are optional. | |
| 1270 If DOCSTRING starts with *, this variable is identified as a user option. | |
| 442 | 1271 This means that M-x set-variable recognizes it. |
| 428 | 1272 If INITVALUE is missing, SYMBOL's value is not set. |
| 1273 | |
| 1274 In lisp-interaction-mode defvar is treated as defconst. | |
| 1275 */ | |
| 1276 (args)) | |
| 1277 { | |
| 1278 /* This function can GC */ | |
| 1279 Lisp_Object sym = XCAR (args); | |
| 1280 | |
| 1281 if (!NILP (args = XCDR (args))) | |
| 1282 { | |
| 1283 Lisp_Object val = XCAR (args); | |
| 1284 | |
| 1285 if (NILP (Fdefault_boundp (sym))) | |
| 1286 { | |
| 1287 struct gcpro gcpro1; | |
| 1288 GCPRO1 (val); | |
| 1289 val = Feval (val); | |
| 1290 Fset_default (sym, val); | |
| 1291 UNGCPRO; | |
| 1292 } | |
| 1293 | |
| 1294 if (!NILP (args = XCDR (args))) | |
| 1295 { | |
| 1296 Lisp_Object doc = XCAR (args); | |
| 1297 Fput (sym, Qvariable_documentation, doc); | |
| 1298 if (!NILP (args = XCDR (args))) | |
| 563 | 1299 signal_error (Qwrong_number_of_arguments, "too many arguments", Qunbound); |
| 428 | 1300 } |
| 1301 } | |
| 1302 | |
| 1303 #ifdef I18N3 | |
| 1304 if (!NILP (Vfile_domain)) | |
| 1305 Fput (sym, Qvariable_domain, Vfile_domain); | |
| 1306 #endif | |
| 1307 | |
| 1308 LOADHIST_ATTACH (sym); | |
| 1309 return sym; | |
| 1310 } | |
| 1311 | |
| 1312 DEFUN ("defconst", Fdefconst, 2, UNEVALLED, 0, /* | |
| 1313 \(defconst SYMBOL INITVALUE DOCSTRING): define SYMBOL as a constant | |
| 1314 variable. | |
| 1315 The intent is that programs do not change this value, but users may. | |
| 1316 Always sets the value of SYMBOL to the result of evalling INITVALUE. | |
| 1317 If SYMBOL is buffer-local, its default value is what is set; | |
| 1318 buffer-local values are not affected. | |
| 1319 DOCSTRING is optional. | |
| 1320 If DOCSTRING starts with *, this variable is identified as a user option. | |
| 442 | 1321 This means that M-x set-variable recognizes it. |
| 428 | 1322 |
| 1323 Note: do not use `defconst' for user options in libraries that are not | |
| 1324 normally loaded, since it is useful for users to be able to specify | |
| 1325 their own values for such variables before loading the library. | |
| 1326 Since `defconst' unconditionally assigns the variable, | |
| 1327 it would override the user's choice. | |
| 1328 */ | |
| 1329 (args)) | |
| 1330 { | |
| 1331 /* This function can GC */ | |
| 1332 Lisp_Object sym = XCAR (args); | |
| 1333 Lisp_Object val = Feval (XCAR (args = XCDR (args))); | |
| 1334 struct gcpro gcpro1; | |
| 1335 | |
| 1336 GCPRO1 (val); | |
| 1337 | |
| 1338 Fset_default (sym, val); | |
| 1339 | |
| 1340 UNGCPRO; | |
| 1341 | |
| 1342 if (!NILP (args = XCDR (args))) | |
| 1343 { | |
| 1344 Lisp_Object doc = XCAR (args); | |
| 1345 Fput (sym, Qvariable_documentation, doc); | |
| 1346 if (!NILP (args = XCDR (args))) | |
| 563 | 1347 signal_error (Qwrong_number_of_arguments, "too many arguments", Qunbound); |
| 428 | 1348 } |
| 1349 | |
| 1350 #ifdef I18N3 | |
| 1351 if (!NILP (Vfile_domain)) | |
| 1352 Fput (sym, Qvariable_domain, Vfile_domain); | |
| 1353 #endif | |
| 1354 | |
| 1355 LOADHIST_ATTACH (sym); | |
| 1356 return sym; | |
| 1357 } | |
| 1358 | |
|
4502
8748a3f7ceb4
Handle varalias chains, custom variables in #'user-variable-p.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4162
diff
changeset
|
1359 /* XEmacs: user-variable-p is in symbols.c, since it needs to mess around |
|
8748a3f7ceb4
Handle varalias chains, custom variables in #'user-variable-p.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4162
diff
changeset
|
1360 with the symbol variable aliases. */ |
| 428 | 1361 |
| 1362 DEFUN ("macroexpand-internal", Fmacroexpand_internal, 1, 2, 0, /* | |
| 1363 Return result of expanding macros at top level of FORM. | |
| 1364 If FORM is not a macro call, it is returned unchanged. | |
| 1365 Otherwise, the macro is expanded and the expansion is considered | |
| 1366 in place of FORM. When a non-macro-call results, it is returned. | |
| 1367 | |
| 442 | 1368 The second optional arg ENVIRONMENT specifies an environment of macro |
| 428 | 1369 definitions to shadow the loaded ones for use in file byte-compilation. |
| 1370 */ | |
| 442 | 1371 (form, environment)) |
| 428 | 1372 { |
| 1373 /* This function can GC */ | |
| 1374 /* With cleanups from Hallvard Furuseth. */ | |
| 1375 REGISTER Lisp_Object expander, sym, def, tem; | |
| 1376 | |
| 1377 while (1) | |
| 1378 { | |
| 1379 /* Come back here each time we expand a macro call, | |
| 1380 in case it expands into another macro call. */ | |
| 1381 if (!CONSP (form)) | |
| 1382 break; | |
| 1383 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */ | |
| 1384 def = sym = XCAR (form); | |
| 1385 tem = Qnil; | |
| 1386 /* Trace symbols aliases to other symbols | |
| 1387 until we get a symbol that is not an alias. */ | |
| 1388 while (SYMBOLP (def)) | |
| 1389 { | |
| 1390 QUIT; | |
| 1391 sym = def; | |
| 442 | 1392 tem = Fassq (sym, environment); |
| 428 | 1393 if (NILP (tem)) |
| 1394 { | |
| 1395 def = XSYMBOL (sym)->function; | |
| 1396 if (!UNBOUNDP (def)) | |
| 1397 continue; | |
| 1398 } | |
| 1399 break; | |
| 1400 } | |
| 442 | 1401 /* Right now TEM is the result from SYM in ENVIRONMENT, |
| 428 | 1402 and if TEM is nil then DEF is SYM's function definition. */ |
| 1403 if (NILP (tem)) | |
| 1404 { | |
| 442 | 1405 /* SYM is not mentioned in ENVIRONMENT. |
| 428 | 1406 Look at its function definition. */ |
| 1407 if (UNBOUNDP (def) | |
| 1408 || !CONSP (def)) | |
| 1409 /* Not defined or definition not suitable */ | |
| 1410 break; | |
| 1411 if (EQ (XCAR (def), Qautoload)) | |
| 1412 { | |
| 1413 /* Autoloading function: will it be a macro when loaded? */ | |
| 1414 tem = Felt (def, make_int (4)); | |
| 1415 if (EQ (tem, Qt) || EQ (tem, Qmacro)) | |
| 1416 { | |
| 1417 /* Yes, load it and try again. */ | |
| 970 | 1418 /* do_autoload GCPROs both arguments */ |
| 428 | 1419 do_autoload (def, sym); |
| 1420 continue; | |
| 1421 } | |
| 1422 else | |
| 1423 break; | |
| 1424 } | |
| 1425 else if (!EQ (XCAR (def), Qmacro)) | |
| 1426 break; | |
| 1427 else expander = XCDR (def); | |
| 1428 } | |
| 1429 else | |
| 1430 { | |
| 1431 expander = XCDR (tem); | |
| 1432 if (NILP (expander)) | |
| 1433 break; | |
| 1434 } | |
| 1435 form = apply1 (expander, XCDR (form)); | |
| 1436 } | |
| 1437 return form; | |
| 1438 } | |
| 1439 | |
| 1440 | |
| 1441 /************************************************************************/ | |
| 1442 /* Non-local exits */ | |
| 1443 /************************************************************************/ | |
| 1444 | |
| 1318 | 1445 #ifdef ERROR_CHECK_TRAPPING_PROBLEMS |
| 1446 | |
| 1447 int | |
| 1448 proper_redisplay_wrapping_in_place (void) | |
| 1449 { | |
| 1450 return !in_display | |
| 1451 || ((get_inhibit_flags () & INTERNAL_INHIBIT_ERRORS) | |
| 1452 && (get_inhibit_flags () & INTERNAL_INHIBIT_THROWS)); | |
| 1453 } | |
| 1454 | |
| 1455 static void | |
| 1456 check_proper_critical_section_nonlocal_exit_protection (void) | |
| 1457 { | |
| 1458 assert_with_message | |
| 1459 (proper_redisplay_wrapping_in_place (), | |
| 1460 "Attempted non-local exit from within redisplay without being properly wrapped"); | |
| 1461 } | |
| 1462 | |
| 1463 static void | |
| 1464 check_proper_critical_section_lisp_protection (void) | |
| 1465 { | |
| 1466 assert_with_message | |
| 1467 (proper_redisplay_wrapping_in_place (), | |
| 1468 "Attempt to call Lisp code from within redisplay without being properly wrapped"); | |
| 1469 } | |
| 1470 | |
| 1471 #endif /* ERROR_CHECK_TRAPPING_PROBLEMS */ | |
| 1472 | |
| 428 | 1473 DEFUN ("catch", Fcatch, 1, UNEVALLED, 0, /* |
| 1474 \(catch TAG BODY...): eval BODY allowing nonlocal exits using `throw'. | |
| 1475 TAG is evalled to get the tag to use. Then the BODY is executed. | |
| 3577 | 1476 Within BODY, (throw TAG VAL) with same (`eq') tag exits BODY and this `catch'. |
| 428 | 1477 If no throw happens, `catch' returns the value of the last BODY form. |
| 1478 If a throw happens, it specifies the value to return from `catch'. | |
| 1479 */ | |
| 1480 (args)) | |
| 1481 { | |
| 1482 /* This function can GC */ | |
| 1483 Lisp_Object tag = Feval (XCAR (args)); | |
| 1484 Lisp_Object body = XCDR (args); | |
| 2532 | 1485 return internal_catch (tag, Fprogn, body, 0, 0, 0); |
| 428 | 1486 } |
| 1487 | |
| 1488 /* Set up a catch, then call C function FUNC on argument ARG. | |
| 1489 FUNC should return a Lisp_Object. | |
| 1490 This is how catches are done from within C code. */ | |
| 1491 | |
| 1492 Lisp_Object | |
| 1493 internal_catch (Lisp_Object tag, | |
| 1494 Lisp_Object (*func) (Lisp_Object arg), | |
| 1495 Lisp_Object arg, | |
| 853 | 1496 int * volatile threw, |
| 2532 | 1497 Lisp_Object * volatile thrown_tag, |
| 1498 Lisp_Object * volatile backtrace_before_throw) | |
| 428 | 1499 { |
| 1500 /* This structure is made part of the chain `catchlist'. */ | |
| 1501 struct catchtag c; | |
| 1502 | |
| 1503 /* Fill in the components of c, and put it on the list. */ | |
| 1504 c.next = catchlist; | |
| 1505 c.tag = tag; | |
| 853 | 1506 c.actual_tag = Qnil; |
| 2532 | 1507 c.backtrace = Qnil; |
| 428 | 1508 c.val = Qnil; |
| 1509 c.backlist = backtrace_list; | |
| 1510 #if 0 /* FSFmacs */ | |
| 1511 /* #### */ | |
| 1512 c.handlerlist = handlerlist; | |
| 1513 #endif | |
| 1514 c.lisp_eval_depth = lisp_eval_depth; | |
| 1515 c.pdlcount = specpdl_depth(); | |
| 1516 #if 0 /* FSFmacs */ | |
| 1517 c.poll_suppress_count = async_timer_suppress_count; | |
| 1518 #endif | |
| 1519 c.gcpro = gcprolist; | |
| 1520 catchlist = &c; | |
| 1521 | |
| 1522 /* Call FUNC. */ | |
| 1523 if (SETJMP (c.jmp)) | |
| 1524 { | |
| 1525 /* Throw works by a longjmp that comes right here. */ | |
| 1526 if (threw) *threw = 1; | |
| 853 | 1527 if (thrown_tag) *thrown_tag = c.actual_tag; |
| 2532 | 1528 if (backtrace_before_throw) *backtrace_before_throw = c.backtrace; |
| 428 | 1529 return c.val; |
| 1530 } | |
| 1531 c.val = (*func) (arg); | |
| 1532 if (threw) *threw = 0; | |
| 853 | 1533 if (thrown_tag) *thrown_tag = Qnil; |
| 428 | 1534 catchlist = c.next; |
| 853 | 1535 check_catchlist_sanity (); |
| 428 | 1536 return c.val; |
| 1537 } | |
| 1538 | |
| 1539 | |
| 1540 /* Unwind the specbind, catch, and handler stacks back to CATCH, and | |
| 1541 jump to that CATCH, returning VALUE as the value of that catch. | |
| 1542 | |
| 2297 | 1543 This is the guts of Fthrow and Fsignal; they differ only in the |
| 1544 way they choose the catch tag to throw to. A catch tag for a | |
| 428 | 1545 condition-case form has a TAG of Qnil. |
| 1546 | |
| 1547 Before each catch is discarded, unbind all special bindings and | |
| 1548 execute all unwind-protect clauses made above that catch. Unwind | |
| 1549 the handler stack as we go, so that the proper handlers are in | |
| 1550 effect for each unwind-protect clause we run. At the end, restore | |
| 1551 some static info saved in CATCH, and longjmp to the location | |
| 1552 specified in the | |
| 1553 | |
| 1554 This is used for correct unwinding in Fthrow and Fsignal. */ | |
| 1555 | |
| 2268 | 1556 static DECLARE_DOESNT_RETURN (unwind_to_catch (struct catchtag *, Lisp_Object, |
| 1557 Lisp_Object)); | |
| 1558 | |
| 1559 static DOESNT_RETURN | |
| 853 | 1560 unwind_to_catch (struct catchtag *c, Lisp_Object val, Lisp_Object tag) |
| 428 | 1561 { |
| 1562 REGISTER int last_time; | |
| 1563 | |
| 1564 /* Unwind the specbind, catch, and handler stacks back to CATCH | |
| 1565 Before each catch is discarded, unbind all special bindings | |
| 1566 and execute all unwind-protect clauses made above that catch. | |
| 1567 At the end, restore some static info saved in CATCH, | |
| 1568 and longjmp to the location specified. | |
| 1569 */ | |
| 1570 | |
| 1571 /* Save the value somewhere it will be GC'ed. | |
| 1572 (Can't overwrite tag slot because an unwind-protect may | |
| 1573 want to throw to this same tag, which isn't yet invalid.) */ | |
| 1574 c->val = val; | |
| 853 | 1575 c->actual_tag = tag; |
| 428 | 1576 |
| 1577 #if 0 /* FSFmacs */ | |
| 1578 /* Restore the polling-suppression count. */ | |
| 1579 set_poll_suppress_count (catch->poll_suppress_count); | |
| 1580 #endif | |
| 1581 | |
| 617 | 1582 #if 1 |
| 428 | 1583 do |
| 1584 { | |
| 1585 last_time = catchlist == c; | |
| 1586 | |
| 1587 /* Unwind the specpdl stack, and then restore the proper set of | |
| 1588 handlers. */ | |
| 771 | 1589 unbind_to (catchlist->pdlcount); |
| 428 | 1590 catchlist = catchlist->next; |
| 853 | 1591 check_catchlist_sanity (); |
| 428 | 1592 } |
| 1593 while (! last_time); | |
| 617 | 1594 #else |
| 1595 /* Former XEmacs code. This is definitely not as correct because | |
| 1596 there may be a number of catches we're unwinding, and a number | |
| 1597 of unwind-protects in the process. By not undoing the catches till | |
| 1598 the end, there may be invalid catches still current. (This would | |
| 1599 be a particular problem with code like this: | |
| 1600 | |
| 1601 (catch 'foo | |
| 1602 (call-some-code-which-does... | |
| 1603 (catch 'bar | |
| 1604 (unwind-protect | |
| 1605 (call-some-code-which-does... | |
| 1606 (catch 'bar | |
| 1607 (call-some-code-which-does... | |
| 1608 (throw 'foo nil)))) | |
| 1609 (throw 'bar nil))))) | |
| 1610 | |
| 1611 This would try to throw to the inner (catch 'bar)! | |
| 1612 | |
| 1613 --ben | |
| 1614 */ | |
| 428 | 1615 /* Unwind the specpdl stack */ |
| 771 | 1616 unbind_to (c->pdlcount); |
| 428 | 1617 catchlist = c->next; |
| 853 | 1618 check_catchlist_sanity (); |
| 617 | 1619 #endif /* Former code */ |
| 428 | 1620 |
| 1204 | 1621 UNWIND_GCPRO_TO (c->gcpro); |
| 1292 | 1622 if (profiling_active) |
| 1623 { | |
| 1624 while (backtrace_list != c->backlist) | |
| 1625 { | |
| 1626 profile_record_unwind (backtrace_list); | |
| 1627 backtrace_list = backtrace_list->next; | |
| 1628 } | |
| 1629 } | |
| 1630 else | |
| 1631 backtrace_list = c->backlist; | |
| 428 | 1632 lisp_eval_depth = c->lisp_eval_depth; |
| 1633 | |
| 442 | 1634 #ifdef DEFEND_AGAINST_THROW_RECURSION |
| 428 | 1635 throw_level = 0; |
| 1636 #endif | |
| 1637 LONGJMP (c->jmp, 1); | |
| 1638 } | |
| 1639 | |
| 2268 | 1640 static DECLARE_DOESNT_RETURN (throw_or_bomb_out (Lisp_Object, Lisp_Object, int, |
| 1641 Lisp_Object, Lisp_Object)); | |
| 1642 | |
| 428 | 1643 static DOESNT_RETURN |
| 1644 throw_or_bomb_out (Lisp_Object tag, Lisp_Object val, int bomb_out_p, | |
| 1645 Lisp_Object sig, Lisp_Object data) | |
| 1646 { | |
| 442 | 1647 #ifdef DEFEND_AGAINST_THROW_RECURSION |
| 428 | 1648 /* die if we recurse more than is reasonable */ |
| 1649 if (++throw_level > 20) | |
| 2500 | 1650 ABORT (); |
| 428 | 1651 #endif |
| 1652 | |
| 1318 | 1653 #ifdef ERROR_CHECK_TRAPPING_PROBLEMS |
| 1123 | 1654 check_proper_critical_section_nonlocal_exit_protection (); |
| 1318 | 1655 #endif |
| 1123 | 1656 |
| 428 | 1657 /* If bomb_out_p is t, this is being called from Fsignal as a |
| 1658 "last resort" when there is no handler for this error and | |
| 1659 the debugger couldn't be invoked, so we are throwing to | |
| 3025 | 1660 `top-level'. If this tag doesn't exist (happens during the |
| 428 | 1661 initialization stages) we would get in an infinite recursive |
| 1662 Fsignal/Fthrow loop, so instead we bomb out to the | |
| 1663 really-early-error-handler. | |
| 1664 | |
| 1665 Note that in fact the only time that the "last resort" | |
| 3025 | 1666 occurs is when there's no catch for `top-level' -- the |
| 1667 `top-level' catch and the catch-all error handler are | |
| 428 | 1668 established at the same time, in initial_command_loop/ |
| 1669 top_level_1. | |
| 1670 | |
| 853 | 1671 [[#### Fix this horrifitude!]] |
| 1672 | |
| 1673 I don't think this is horrifitude, just defensive programming. --ben | |
| 428 | 1674 */ |
| 1675 | |
| 1676 while (1) | |
| 1677 { | |
| 1678 REGISTER struct catchtag *c; | |
| 1679 | |
| 1680 #if 0 /* FSFmacs */ | |
| 1681 if (!NILP (tag)) /* #### */ | |
| 1682 #endif | |
| 1683 for (c = catchlist; c; c = c->next) | |
| 1684 { | |
| 2532 | 1685 if (EQ (c->tag, Vcatch_everything_tag)) |
| 1686 c->backtrace = maybe_get_trapping_problems_backtrace (); | |
| 853 | 1687 if (EQ (c->tag, tag) || EQ (c->tag, Vcatch_everything_tag)) |
| 1688 unwind_to_catch (c, val, tag); | |
| 428 | 1689 } |
| 1690 if (!bomb_out_p) | |
| 1691 tag = Fsignal (Qno_catch, list2 (tag, val)); | |
| 1692 else | |
| 1693 call1 (Qreally_early_error_handler, Fcons (sig, data)); | |
| 1694 } | |
| 1695 } | |
| 1696 | |
| 1697 /* See above, where CATCHLIST is defined, for a description of how | |
| 1698 Fthrow() works. | |
| 1699 | |
| 1700 Fthrow() is also called by Fsignal(), to do a non-local jump | |
| 1701 back to the appropriate condition-case handler after (maybe) | |
| 1702 the debugger is entered. In that case, TAG is the value | |
| 1703 of Vcondition_handlers that was in place just after the | |
| 1704 condition-case handler was set up. The car of this will be | |
| 1705 some data referring to the handler: Its car will be Qunbound | |
| 1706 (thus, this tag can never be generated by Lisp code), and | |
| 1707 its CDR will be the HANDLERS argument to condition_case_1() | |
| 1708 (either Qerror, Qt, or a list of handlers as in `condition-case'). | |
| 1709 This works fine because Fthrow() does not care what TAG was | |
| 1710 passed to it: it just looks up the catch list for something | |
| 1711 that is EQ() to TAG. When it finds it, it will longjmp() | |
| 1712 back to the place that established the catch (in this case, | |
| 1713 condition_case_1). See below for more info. | |
| 1714 */ | |
| 1715 | |
| 2268 | 1716 DEFUN_NORETURN ("throw", Fthrow, 2, 2, 0, /* |
| 444 | 1717 Throw to the catch for TAG and return VALUE from it. |
| 2297 | 1718 Both TAG and VALUE are evalled. Tags are the same iff they are `eq'. |
| 428 | 1719 */ |
| 444 | 1720 (tag, value)) |
| 1721 { | |
| 1722 throw_or_bomb_out (tag, value, 0, Qnil, Qnil); /* Doesn't return */ | |
| 2268 | 1723 RETURN_NOT_REACHED (Qnil); |
| 428 | 1724 } |
| 1725 | |
| 1726 DEFUN ("unwind-protect", Funwind_protect, 1, UNEVALLED, 0, /* | |
| 1727 Do BODYFORM, protecting with UNWINDFORMS. | |
| 1728 Usage looks like (unwind-protect BODYFORM UNWINDFORMS...). | |
| 1729 If BODYFORM completes normally, its value is returned | |
| 1730 after executing the UNWINDFORMS. | |
| 1731 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway. | |
| 1732 */ | |
| 1733 (args)) | |
| 1734 { | |
| 1735 /* This function can GC */ | |
| 1736 int speccount = specpdl_depth(); | |
| 1737 | |
| 1738 record_unwind_protect (Fprogn, XCDR (args)); | |
| 771 | 1739 return unbind_to_1 (speccount, Feval (XCAR (args))); |
| 428 | 1740 } |
| 1741 | |
| 1742 | |
| 1743 /************************************************************************/ | |
| 1292 | 1744 /* Trapping errors */ |
| 428 | 1745 /************************************************************************/ |
| 1746 | |
| 1747 static Lisp_Object | |
| 1748 condition_bind_unwind (Lisp_Object loser) | |
| 1749 { | |
| 617 | 1750 /* There is no problem freeing stuff here like there is in |
| 1751 condition_case_unwind(), because there are no outside pointers | |
| 1752 (like the tag below in the catchlist) pointing to the objects. */ | |
| 853 | 1753 |
| 428 | 1754 /* ((handler-fun . handler-args) ... other handlers) */ |
| 1755 Lisp_Object tem = XCAR (loser); | |
| 853 | 1756 int first = 1; |
| 428 | 1757 |
| 1758 while (CONSP (tem)) | |
| 1759 { | |
| 853 | 1760 Lisp_Object victim = tem; |
| 1761 if (first && OPAQUE_PTRP (XCAR (victim))) | |
| 1762 free_opaque_ptr (XCAR (victim)); | |
| 1763 first = 0; | |
| 1764 tem = XCDR (victim); | |
| 428 | 1765 free_cons (victim); |
| 1766 } | |
| 1767 | |
| 1768 if (EQ (loser, Vcondition_handlers)) /* may have been rebound to some tail */ | |
| 853 | 1769 Vcondition_handlers = XCDR (loser); |
| 1770 | |
| 1771 free_cons (loser); | |
| 428 | 1772 return Qnil; |
| 1773 } | |
| 1774 | |
| 1775 static Lisp_Object | |
| 1776 condition_case_unwind (Lisp_Object loser) | |
| 1777 { | |
| 1778 /* ((<unbound> . clauses) ... other handlers */ | |
| 617 | 1779 /* NO! Doing this now leaves the tag deleted in a still-active |
| 1780 catch. With the recent changes to unwind_to_catch(), the | |
| 1781 evil situation might not happen any more; it certainly could | |
| 1782 happen before because it did. But it's very precarious to rely | |
| 1783 on something like this. #### Instead we should rewrite, adopting | |
| 1784 the FSF's mechanism with a struct handler instead of | |
| 1785 Vcondition_handlers; then we have NO Lisp-object structures used | |
| 1786 to hold all of the values, and there's no possibility either of | |
| 1787 crashes from freeing objects too quickly, or objects not getting | |
| 1788 freed and hanging around till the next GC. | |
| 1789 | |
| 1790 In practice, the extra consing here should not matter because | |
| 1791 it only happens when we throw past the condition-case, which almost | |
| 1792 always is the result of an error. Most of the time, there will be | |
| 1793 no error, and we will free the objects below in the main function. | |
| 1794 | |
| 1795 --ben | |
| 1796 | |
| 1797 DO NOT DO: free_cons (XCAR (loser)); | |
| 1798 */ | |
| 1799 | |
| 428 | 1800 if (EQ (loser, Vcondition_handlers)) /* may have been rebound to some tail */ |
| 617 | 1801 Vcondition_handlers = XCDR (loser); |
| 1802 | |
| 1803 /* DO NOT DO: free_cons (loser); */ | |
| 428 | 1804 return Qnil; |
| 1805 } | |
| 1806 | |
| 1807 /* Split out from condition_case_3 so that primitive C callers | |
| 1808 don't have to cons up a lisp handler form to be evaluated. */ | |
| 1809 | |
| 1810 /* Call a function BFUN of one argument BARG, trapping errors as | |
| 1811 specified by HANDLERS. If no error occurs that is indicated by | |
| 1812 HANDLERS as something to be caught, the return value of this | |
| 1813 function is the return value from BFUN. If such an error does | |
| 1814 occur, HFUN is called, and its return value becomes the | |
| 1815 return value of condition_case_1(). The second argument passed | |
| 1816 to HFUN will always be HARG. The first argument depends on | |
| 1817 HANDLERS: | |
| 1818 | |
| 1819 If HANDLERS is Qt, all errors (this includes QUIT, but not | |
| 1820 non-local exits with `throw') cause HFUN to be invoked, and VAL | |
| 1821 (the first argument to HFUN) is a cons (SIG . DATA) of the | |
| 1822 arguments passed to `signal'. The debugger is not invoked even if | |
| 1823 `debug-on-error' was set. | |
| 1824 | |
| 1825 A HANDLERS value of Qerror is the same as Qt except that the | |
| 1826 debugger is invoked if `debug-on-error' was set. | |
| 1827 | |
| 1828 Otherwise, HANDLERS should be a list of lists (CONDITION-NAME BODY ...) | |
| 1829 exactly as in `condition-case', and errors will be trapped | |
| 1830 as indicated in HANDLERS. VAL (the first argument to HFUN) will | |
| 1831 be a cons whose car is the cons (SIG . DATA) and whose CDR is the | |
| 1832 list (BODY ...) from the appropriate slot in HANDLERS. | |
| 1833 | |
| 1834 This function pushes HANDLERS onto the front of Vcondition_handlers | |
| 1835 (actually with a Qunbound marker as well -- see Fthrow() above | |
| 1836 for why), establishes a catch whose tag is this new value of | |
| 1837 Vcondition_handlers, and calls BFUN. When Fsignal() is called, | |
| 1838 it calls Fthrow(), setting TAG to this same new value of | |
| 1839 Vcondition_handlers and setting VAL to the same thing that will | |
| 1840 be passed to HFUN, as above. Fthrow() longjmp()s back to the | |
| 1841 jump point we just established, and we in turn just call the | |
| 1842 HFUN and return its value. | |
| 1843 | |
| 1844 For a real condition-case, HFUN will always be | |
| 1845 run_condition_case_handlers() and HARG is the argument VAR | |
| 1846 to condition-case. That function just binds VAR to the cons | |
| 1847 (SIG . DATA) that is the CAR of VAL, and calls the handler | |
| 1848 (BODY ...) that is the CDR of VAL. Note that before calling | |
| 1849 Fthrow(), Fsignal() restored Vcondition_handlers to the value | |
| 1850 it had *before* condition_case_1() was called. This maintains | |
| 1851 consistency (so that the state of things at exit of | |
| 1852 condition_case_1() is the same as at entry), and implies | |
| 1853 that the handler can signal the same error again (possibly | |
| 1854 after processing of its own), without getting in an infinite | |
| 1855 loop. */ | |
| 1856 | |
| 1857 Lisp_Object | |
| 1858 condition_case_1 (Lisp_Object handlers, | |
| 1859 Lisp_Object (*bfun) (Lisp_Object barg), | |
| 1860 Lisp_Object barg, | |
| 1861 Lisp_Object (*hfun) (Lisp_Object val, Lisp_Object harg), | |
| 1862 Lisp_Object harg) | |
| 1863 { | |
| 1864 int speccount = specpdl_depth(); | |
| 1865 struct catchtag c; | |
| 617 | 1866 struct gcpro gcpro1, gcpro2, gcpro3; |
| 428 | 1867 |
| 1868 #if 0 /* FSFmacs */ | |
| 1869 c.tag = Qnil; | |
| 1870 #else | |
| 1871 /* Do consing now so out-of-memory error happens up front */ | |
| 1872 /* (unbound . stuff) is a special condition-case kludge marker | |
| 1873 which is known specially by Fsignal. | |
| 617 | 1874 [[ This is an abomination, but to fix it would require either |
| 428 | 1875 making condition_case cons (a union of the conditions of the clauses) |
| 617 | 1876 or changing the byte-compiler output (no thanks).]] |
| 1877 | |
| 1878 The above comment is clearly wrong. FSF does not do it this way | |
| 1879 and did not change the byte-compiler output. Instead they use a | |
| 1880 `struct handler' to hold the various values (in place of our | |
| 1881 Vcondition_handlers) and chain them together, with pointers from | |
| 1882 the `struct catchtag' to the `struct handler'. We should perhaps | |
| 1883 consider moving to something similar, but not before I merge my | |
| 1884 stderr-proc workspace, which contains changes to these | |
| 1885 functions. --ben */ | |
| 428 | 1886 c.tag = noseeum_cons (noseeum_cons (Qunbound, handlers), |
| 1887 Vcondition_handlers); | |
| 1888 #endif | |
| 1889 c.val = Qnil; | |
| 853 | 1890 c.actual_tag = Qnil; |
| 2532 | 1891 c.backtrace = Qnil; |
| 428 | 1892 c.backlist = backtrace_list; |
| 1893 #if 0 /* FSFmacs */ | |
| 1894 /* #### */ | |
| 1895 c.handlerlist = handlerlist; | |
| 1896 #endif | |
| 1897 c.lisp_eval_depth = lisp_eval_depth; | |
| 1898 c.pdlcount = specpdl_depth(); | |
| 1899 #if 0 /* FSFmacs */ | |
| 1900 c.poll_suppress_count = async_timer_suppress_count; | |
| 1901 #endif | |
| 1902 c.gcpro = gcprolist; | |
| 1903 /* #### FSFmacs does the following statement *after* the setjmp(). */ | |
| 1904 c.next = catchlist; | |
| 1905 | |
| 1906 if (SETJMP (c.jmp)) | |
| 1907 { | |
| 1908 /* throw does ungcpro, etc */ | |
| 1909 return (*hfun) (c.val, harg); | |
| 1910 } | |
| 1911 | |
| 1912 record_unwind_protect (condition_case_unwind, c.tag); | |
| 1913 | |
| 1914 catchlist = &c; | |
| 1915 #if 0 /* FSFmacs */ | |
| 1916 h.handler = handlers; | |
| 1917 h.var = Qnil; | |
| 1918 h.next = handlerlist; | |
| 1919 h.tag = &c; | |
| 1920 handlerlist = &h; | |
| 1921 #else | |
| 1922 Vcondition_handlers = c.tag; | |
| 1923 #endif | |
| 1924 GCPRO1 (harg); /* Somebody has to gc-protect */ | |
| 1925 c.val = ((*bfun) (barg)); | |
| 1926 UNGCPRO; | |
| 617 | 1927 |
| 1928 /* Once we change `catchlist' below, the stuff in c will not be GCPRO'd. */ | |
| 1929 GCPRO3 (harg, c.val, c.tag); | |
| 1930 | |
| 428 | 1931 catchlist = c.next; |
| 853 | 1932 check_catchlist_sanity (); |
| 617 | 1933 /* Note: The unbind also resets Vcondition_handlers. Maybe we should |
| 1934 delete this here. */ | |
| 428 | 1935 Vcondition_handlers = XCDR (c.tag); |
| 771 | 1936 unbind_to (speccount); |
| 617 | 1937 |
| 1938 UNGCPRO; | |
| 1939 /* free the conses *after* the unbind, because the unbind will run | |
| 1940 condition_case_unwind above. */ | |
| 853 | 1941 free_cons (XCAR (c.tag)); |
| 1942 free_cons (c.tag); | |
| 617 | 1943 return c.val; |
| 428 | 1944 } |
| 1945 | |
| 1946 static Lisp_Object | |
| 1947 run_condition_case_handlers (Lisp_Object val, Lisp_Object var) | |
| 1948 { | |
| 1949 /* This function can GC */ | |
| 1950 #if 0 /* FSFmacs */ | |
| 1951 if (!NILP (h.var)) | |
| 1952 specbind (h.var, c.val); | |
| 1953 val = Fprogn (Fcdr (h.chosen_clause)); | |
| 1954 | |
| 1955 /* Note that this just undoes the binding of h.var; whoever | |
| 1956 longjmp()ed to us unwound the stack to c.pdlcount before | |
| 1957 throwing. */ | |
| 771 | 1958 unbind_to (c.pdlcount); |
| 428 | 1959 return val; |
| 1960 #else | |
| 1961 int speccount; | |
| 1962 | |
| 1963 CHECK_TRUE_LIST (val); | |
| 1964 if (NILP (var)) | |
| 1965 return Fprogn (Fcdr (val)); /* tail call */ | |
| 1966 | |
| 1967 speccount = specpdl_depth(); | |
| 1968 specbind (var, Fcar (val)); | |
| 1969 val = Fprogn (Fcdr (val)); | |
| 771 | 1970 return unbind_to_1 (speccount, val); |
| 428 | 1971 #endif |
| 1972 } | |
| 1973 | |
| 1974 /* Here for bytecode to call non-consfully. This is exactly like | |
| 1975 condition-case except that it takes three arguments rather | |
| 1976 than a single list of arguments. */ | |
| 1977 Lisp_Object | |
| 1978 condition_case_3 (Lisp_Object bodyform, Lisp_Object var, Lisp_Object handlers) | |
| 1979 { | |
| 1980 /* This function can GC */ | |
| 1981 EXTERNAL_LIST_LOOP_2 (handler, handlers) | |
| 1982 { | |
| 1983 if (NILP (handler)) | |
| 1984 ; | |
| 1985 else if (CONSP (handler)) | |
| 1986 { | |
| 1987 Lisp_Object conditions = XCAR (handler); | |
| 1988 /* CONDITIONS must a condition name or a list of condition names */ | |
| 1989 if (SYMBOLP (conditions)) | |
| 1990 ; | |
| 1991 else | |
| 1992 { | |
| 1993 EXTERNAL_LIST_LOOP_2 (condition, conditions) | |
| 1994 if (!SYMBOLP (condition)) | |
| 1995 goto invalid_condition_handler; | |
| 1996 } | |
| 1997 } | |
| 1998 else | |
| 1999 { | |
| 2000 invalid_condition_handler: | |
| 563 | 2001 sferror ("Invalid condition handler", handler); |
| 428 | 2002 } |
| 2003 } | |
| 2004 | |
| 2005 CHECK_SYMBOL (var); | |
| 2006 | |
| 2007 return condition_case_1 (handlers, | |
| 2008 Feval, bodyform, | |
| 2009 run_condition_case_handlers, | |
| 2010 var); | |
| 2011 } | |
| 2012 | |
| 2013 DEFUN ("condition-case", Fcondition_case, 2, UNEVALLED, 0, /* | |
| 2014 Regain control when an error is signalled. | |
| 2015 Usage looks like (condition-case VAR BODYFORM HANDLERS...). | |
| 2016 Executes BODYFORM and returns its value if no error happens. | |
| 2017 Each element of HANDLERS looks like (CONDITION-NAME BODY...) | |
| 2018 where the BODY is made of Lisp expressions. | |
| 2019 | |
| 771 | 2020 A typical usage of `condition-case' looks like this: |
| 2021 | |
| 2022 (condition-case nil | |
| 2023 ;; you need a progn here if you want more than one statement ... | |
| 2024 (progn | |
| 2025 (do-something) | |
| 2026 (do-something-else)) | |
| 2027 (error | |
| 2028 (issue-warning-or) | |
| 2029 ;; but strangely, you don't need one here. | |
| 2030 (return-a-value-etc) | |
| 2031 )) | |
| 2032 | |
| 428 | 2033 A handler is applicable to an error if CONDITION-NAME is one of the |
| 2034 error's condition names. If an error happens, the first applicable | |
| 2035 handler is run. As a special case, a CONDITION-NAME of t matches | |
| 2036 all errors, even those without the `error' condition name on them | |
| 2037 \(e.g. `quit'). | |
| 2038 | |
| 2039 The car of a handler may be a list of condition names | |
| 2040 instead of a single condition name. | |
| 2041 | |
| 2042 When a handler handles an error, | |
| 2043 control returns to the condition-case and the handler BODY... is executed | |
| 2044 with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA). | |
| 2045 VAR may be nil; then you do not get access to the signal information. | |
| 2046 | |
| 2047 The value of the last BODY form is returned from the condition-case. | |
| 2048 See also the function `signal' for more info. | |
| 2049 | |
| 2050 Note that at the time the condition handler is invoked, the Lisp stack | |
| 2051 and the current catches, condition-cases, and bindings have all been | |
| 2052 popped back to the state they were in just before the call to | |
| 2053 `condition-case'. This means that resignalling the error from | |
| 2054 within the handler will not result in an infinite loop. | |
| 2055 | |
| 2056 If you want to establish an error handler that is called with the | |
| 2057 Lisp stack, bindings, etc. as they were when `signal' was called, | |
| 2058 rather than when the handler was set, use `call-with-condition-handler'. | |
| 2059 */ | |
| 2060 (args)) | |
| 2061 { | |
| 2062 /* This function can GC */ | |
| 2063 Lisp_Object var = XCAR (args); | |
| 2064 Lisp_Object bodyform = XCAR (XCDR (args)); | |
| 2065 Lisp_Object handlers = XCDR (XCDR (args)); | |
| 2066 return condition_case_3 (bodyform, var, handlers); | |
| 2067 } | |
| 2068 | |
| 2069 DEFUN ("call-with-condition-handler", Fcall_with_condition_handler, 2, MANY, 0, /* | |
| 2070 Regain control when an error is signalled, without popping the stack. | |
| 2071 Usage looks like (call-with-condition-handler HANDLER FUNCTION &rest ARGS). | |
| 2072 This function is similar to `condition-case', but the handler is invoked | |
| 2073 with the same environment (Lisp stack, bindings, catches, condition-cases) | |
| 2074 that was current when `signal' was called, rather than when the handler | |
| 2075 was established. | |
| 2076 | |
| 2077 HANDLER should be a function of one argument, which is a cons of the args | |
| 2078 \(SIG . DATA) that were passed to `signal'. It is invoked whenever | |
| 2079 `signal' is called (this differs from `condition-case', which allows | |
| 2080 you to specify which errors are trapped). If the handler function | |
| 2081 returns, `signal' continues as if the handler were never invoked. | |
| 2082 \(It continues to look for handlers established earlier than this one, | |
| 2083 and invokes the standard error-handler if none is found.) | |
| 2084 */ | |
| 2085 (int nargs, Lisp_Object *args)) /* Note! Args side-effected! */ | |
| 2086 { | |
| 2087 /* This function can GC */ | |
| 2088 int speccount = specpdl_depth(); | |
| 2089 Lisp_Object tem; | |
| 2090 | |
| 853 | 2091 tem = Ffunction_max_args (args[0]); |
| 2092 if (! (XINT (Ffunction_min_args (args[0])) <= 1 | |
| 2093 && (NILP (tem) || 1 <= XINT (tem)))) | |
| 2094 invalid_argument ("Must be function of one argument", args[0]); | |
| 2095 | |
| 2096 /* (handler-fun . handler-args) but currently there are no handler-args */ | |
| 428 | 2097 tem = noseeum_cons (list1 (args[0]), Vcondition_handlers); |
| 2098 record_unwind_protect (condition_bind_unwind, tem); | |
| 2099 Vcondition_handlers = tem; | |
| 2100 | |
| 2101 /* Caller should have GC-protected args */ | |
| 771 | 2102 return unbind_to_1 (speccount, Ffuncall (nargs - 1, args + 1)); |
| 428 | 2103 } |
| 2104 | |
| 853 | 2105 /* This is the C version of the above function. It calls FUN, passing it |
| 2106 ARG, first setting up HANDLER to catch signals in the environment in | |
| 2107 which they were signalled. (HANDLER is only invoked if there was no | |
| 2108 handler (either from condition-case or call-with-condition-handler) set | |
| 2109 later on that handled the signal; therefore, this is a real error. | |
| 2110 | |
| 2111 HANDLER is invoked with three arguments: the ERROR-SYMBOL and DATA as | |
| 2112 passed to `signal', and HANDLER_ARG. Originally I made HANDLER_ARG and | |
| 2113 ARG be void * to facilitate passing structures, but I changed to | |
| 2114 Lisp_Objects because all the other C interfaces to catch/condition-case/etc. | |
| 2115 take Lisp_Objects, and it is easy enough to use make_opaque_ptr() et al. | |
| 2116 to convert between Lisp_Objects and structure pointers. */ | |
| 2117 | |
| 2118 Lisp_Object | |
| 2119 call_with_condition_handler (Lisp_Object (*handler) (Lisp_Object, Lisp_Object, | |
| 2120 Lisp_Object), | |
| 2121 Lisp_Object handler_arg, | |
| 2122 Lisp_Object (*fun) (Lisp_Object), | |
| 2123 Lisp_Object arg) | |
| 2124 { | |
| 2125 /* This function can GC */ | |
| 1111 | 2126 int speccount = specpdl_depth (); |
| 853 | 2127 Lisp_Object tem; |
| 2128 | |
| 2129 /* ((handler-fun . (handler-arg . nil)) ... ) */ | |
| 1111 | 2130 tem = noseeum_cons (noseeum_cons (make_opaque_ptr ((void *) handler), |
| 853 | 2131 noseeum_cons (handler_arg, Qnil)), |
| 2132 Vcondition_handlers); | |
| 2133 record_unwind_protect (condition_bind_unwind, tem); | |
| 2134 Vcondition_handlers = tem; | |
| 2135 | |
| 2136 return unbind_to_1 (speccount, (*fun) (arg)); | |
| 2137 } | |
| 2138 | |
| 428 | 2139 static int |
| 2140 condition_type_p (Lisp_Object type, Lisp_Object conditions) | |
| 2141 { | |
| 2142 if (EQ (type, Qt)) | |
| 2143 /* (condition-case c # (t c)) catches -all- signals | |
| 2144 * Use with caution! */ | |
| 2145 return 1; | |
| 2146 | |
| 2147 if (SYMBOLP (type)) | |
| 2148 return !NILP (Fmemq (type, conditions)); | |
| 2149 | |
| 2150 for (; CONSP (type); type = XCDR (type)) | |
| 2151 if (!NILP (Fmemq (XCAR (type), conditions))) | |
| 2152 return 1; | |
| 2153 | |
| 2154 return 0; | |
| 2155 } | |
| 2156 | |
| 2157 static Lisp_Object | |
| 2158 return_from_signal (Lisp_Object value) | |
| 2159 { | |
| 2160 #if 1 | |
| 2161 /* Most callers are not prepared to handle gc if this | |
| 2162 returns. So, since this feature is not very useful, | |
| 2163 take it out. */ | |
| 2164 /* Have called debugger; return value to signaller */ | |
| 2165 return value; | |
| 2166 #else /* But the reality is that that stinks, because: */ | |
| 2167 /* GACK!!! Really want some way for debug-on-quit errors | |
| 2168 to be continuable!! */ | |
| 563 | 2169 signal_error (Qunimplemented, |
| 2170 "Returning a value from an error is no longer supported", | |
| 2171 Qunbound); | |
| 428 | 2172 #endif |
| 2173 } | |
| 2174 | |
| 2175 | |
| 2176 /************************************************************************/ | |
| 2177 /* the workhorse error-signaling function */ | |
| 2178 /************************************************************************/ | |
| 2179 | |
| 853 | 2180 /* This exists only for debugging purposes, as a place to put a breakpoint |
| 2181 that won't get signalled for errors occurring when | |
| 2182 call_with_suspended_errors() was invoked. */ | |
| 2183 | |
| 872 | 2184 /* Don't make static or it might be compiled away */ |
| 2185 void signal_1 (void); | |
| 2186 | |
| 2187 void | |
| 853 | 2188 signal_1 (void) |
| 2189 { | |
| 2190 } | |
| 2191 | |
| 428 | 2192 /* #### This function has not been synched with FSF. It diverges |
| 2193 significantly. */ | |
| 2194 | |
| 853 | 2195 /* The simplest external error function: it would be called |
| 2196 signal_continuable_error() in the terminology below, but it's | |
| 2197 Lisp-callable. */ | |
| 2198 | |
| 2199 DEFUN ("signal", Fsignal, 2, 2, 0, /* | |
| 2200 Signal a continuable error. Args are ERROR-SYMBOL, and associated DATA. | |
| 2201 An error symbol is a symbol defined using `define-error'. | |
| 2202 DATA should be a list. Its elements are printed as part of the error message. | |
| 2203 If the signal is handled, DATA is made available to the handler. | |
| 2204 See also the function `signal-error', and the functions to handle errors: | |
| 2205 `condition-case' and `call-with-condition-handler'. | |
| 2206 | |
| 2207 Note that this function can return, if the debugger is invoked and the | |
| 2208 user invokes the "return from signal" option. | |
| 2209 */ | |
| 2210 (error_symbol, data)) | |
| 428 | 2211 { |
| 2212 /* This function can GC */ | |
| 853 | 2213 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; |
| 2214 Lisp_Object conditions = Qnil; | |
| 2215 Lisp_Object handlers = Qnil; | |
| 428 | 2216 /* signal_call_debugger() could get called more than once |
| 2217 (once when a call-with-condition-handler is about to | |
| 2218 be dealt with, and another when a condition-case handler | |
| 2219 is about to be invoked). So make sure the debugger and/or | |
| 2220 stack trace aren't done more than once. */ | |
| 2221 int stack_trace_displayed = 0; | |
| 2222 int debugger_entered = 0; | |
| 853 | 2223 |
| 2224 /* Fsignal() is one of these functions that's called all the time | |
| 2225 with newly-created Lisp objects. We allow this; but we must GC- | |
| 2226 protect the objects because all sorts of weird stuff could | |
| 2227 happen. */ | |
| 2228 | |
| 2229 GCPRO4 (conditions, handlers, error_symbol, data); | |
| 2230 | |
| 2231 if (!(inhibit_flags & CALL_WITH_SUSPENDED_ERRORS)) | |
| 2232 signal_1 (); | |
| 428 | 2233 |
| 2234 if (!initialized) | |
| 2235 { | |
| 2236 /* who knows how much has been initialized? Safest bet is | |
| 2237 just to bomb out immediately. */ | |
| 771 | 2238 stderr_out ("Error before initialization is complete!\n"); |
| 2500 | 2239 ABORT (); |
| 428 | 2240 } |
| 2241 | |
| 3092 | 2242 #ifndef NEW_GC |
| 1123 | 2243 assert (!gc_in_progress); |
| 3092 | 2244 #endif /* not NEW_GC */ |
| 1123 | 2245 |
| 2246 /* We abort if in_display and we are not protected, as garbage | |
| 2247 collections and non-local exits will invariably be fatal, but in | |
| 2248 messy, difficult-to-debug ways. See enter_redisplay_critical_section(). | |
| 2249 */ | |
| 2250 | |
| 1318 | 2251 #ifdef ERROR_CHECK_TRAPPING_PROBLEMS |
| 1123 | 2252 check_proper_critical_section_nonlocal_exit_protection (); |
| 1318 | 2253 #endif |
| 428 | 2254 |
| 853 | 2255 conditions = Fget (error_symbol, Qerror_conditions, Qnil); |
| 428 | 2256 |
| 2257 for (handlers = Vcondition_handlers; | |
| 2258 CONSP (handlers); | |
| 2259 handlers = XCDR (handlers)) | |
| 2260 { | |
| 2261 Lisp_Object handler_fun = XCAR (XCAR (handlers)); | |
| 2262 Lisp_Object handler_data = XCDR (XCAR (handlers)); | |
| 2263 Lisp_Object outer_handlers = XCDR (handlers); | |
| 2264 | |
| 2265 if (!UNBOUNDP (handler_fun)) | |
| 2266 { | |
| 2267 /* call-with-condition-handler */ | |
| 2268 Lisp_Object tem; | |
| 2269 Lisp_Object all_handlers = Vcondition_handlers; | |
| 2270 struct gcpro ngcpro1; | |
| 2271 NGCPRO1 (all_handlers); | |
| 2272 Vcondition_handlers = outer_handlers; | |
| 2273 | |
| 853 | 2274 tem = signal_call_debugger (conditions, error_symbol, data, |
| 428 | 2275 outer_handlers, 1, |
| 2276 &stack_trace_displayed, | |
| 2277 &debugger_entered); | |
| 2278 if (!UNBOUNDP (tem)) | |
| 2279 RETURN_NUNGCPRO (return_from_signal (tem)); | |
| 2280 | |
| 853 | 2281 if (OPAQUE_PTRP (handler_fun)) |
| 2282 { | |
| 2283 if (NILP (handler_data)) | |
| 2284 { | |
| 2285 Lisp_Object (*hfun) (Lisp_Object, Lisp_Object) = | |
| 2286 (Lisp_Object (*) (Lisp_Object, Lisp_Object)) | |
| 2287 (get_opaque_ptr (handler_fun)); | |
| 2288 | |
| 2289 tem = (*hfun) (error_symbol, data); | |
| 2290 } | |
| 2291 else | |
| 2292 { | |
| 2293 Lisp_Object (*hfun) (Lisp_Object, Lisp_Object, Lisp_Object) = | |
| 2294 (Lisp_Object (*) (Lisp_Object, Lisp_Object, Lisp_Object)) | |
| 2295 (get_opaque_ptr (handler_fun)); | |
| 2296 | |
| 2297 assert (NILP (XCDR (handler_data))); | |
| 2298 tem = (*hfun) (error_symbol, data, XCAR (handler_data)); | |
| 2299 } | |
| 2300 } | |
| 2301 else | |
| 2302 { | |
| 2303 tem = Fcons (error_symbol, data); | |
| 2304 if (NILP (handler_data)) | |
| 2305 tem = call1 (handler_fun, tem); | |
| 2306 else | |
| 2307 { | |
| 2308 /* (This code won't be used (for now?).) */ | |
| 2309 struct gcpro nngcpro1; | |
| 2310 Lisp_Object args[3]; | |
| 2311 NNGCPRO1 (args[0]); | |
| 2312 nngcpro1.nvars = 3; | |
| 2313 args[0] = handler_fun; | |
| 2314 args[1] = tem; | |
| 2315 args[2] = handler_data; | |
| 2316 nngcpro1.var = args; | |
| 2317 tem = Fapply (3, args); | |
| 2318 NNUNGCPRO; | |
| 2319 } | |
| 2320 } | |
| 428 | 2321 NUNGCPRO; |
| 2322 #if 0 | |
| 2323 if (!EQ (tem, Qsignal)) | |
| 2324 return return_from_signal (tem); | |
| 2325 #endif | |
| 2326 /* If handler didn't throw, try another handler */ | |
| 2327 Vcondition_handlers = all_handlers; | |
| 2328 } | |
| 2329 | |
| 2330 /* It's a condition-case handler */ | |
| 2331 | |
| 2332 /* t is used by handlers for all conditions, set up by C code. | |
| 2333 * debugger is not called even if debug_on_error */ | |
| 2334 else if (EQ (handler_data, Qt)) | |
| 2335 { | |
| 2336 UNGCPRO; | |
| 853 | 2337 return Fthrow (handlers, Fcons (error_symbol, data)); |
| 428 | 2338 } |
| 2339 /* `error' is used similarly to the way `t' is used, but in | |
| 2340 addition it invokes the debugger if debug_on_error. | |
| 2341 This is normally used for the outer command-loop error | |
| 2342 handler. */ | |
| 2343 else if (EQ (handler_data, Qerror)) | |
| 2344 { | |
| 853 | 2345 Lisp_Object tem = signal_call_debugger (conditions, error_symbol, |
| 2346 data, | |
| 428 | 2347 outer_handlers, 0, |
| 2348 &stack_trace_displayed, | |
| 2349 &debugger_entered); | |
| 2350 | |
| 2351 UNGCPRO; | |
| 2352 if (!UNBOUNDP (tem)) | |
| 2353 return return_from_signal (tem); | |
| 2354 | |
| 853 | 2355 tem = Fcons (error_symbol, data); |
| 428 | 2356 return Fthrow (handlers, tem); |
| 2357 } | |
| 2358 else | |
| 2359 { | |
| 2360 /* handler established by real (Lisp) condition-case */ | |
| 2361 Lisp_Object h; | |
| 2362 | |
| 2363 for (h = handler_data; CONSP (h); h = Fcdr (h)) | |
| 2364 { | |
| 2365 Lisp_Object clause = Fcar (h); | |
| 2366 Lisp_Object tem = Fcar (clause); | |
| 2367 | |
| 2368 if (condition_type_p (tem, conditions)) | |
| 2369 { | |
| 853 | 2370 tem = signal_call_debugger (conditions, error_symbol, data, |
| 428 | 2371 outer_handlers, 1, |
| 2372 &stack_trace_displayed, | |
| 2373 &debugger_entered); | |
| 2374 UNGCPRO; | |
| 2375 if (!UNBOUNDP (tem)) | |
| 2376 return return_from_signal (tem); | |
| 2377 | |
| 2378 /* Doesn't return */ | |
| 853 | 2379 tem = Fcons (Fcons (error_symbol, data), Fcdr (clause)); |
| 428 | 2380 return Fthrow (handlers, tem); |
| 2381 } | |
| 2382 } | |
| 2383 } | |
| 2384 } | |
| 2385 | |
| 2386 /* If no handler is present now, try to run the debugger, | |
| 2387 and if that fails, throw to top level. | |
| 2388 | |
| 2389 #### The only time that no handler is present is during | |
| 2390 temacs or perhaps very early in XEmacs. In both cases, | |
| 3025 | 2391 there is no `top-level' catch. (That's why the |
| 428 | 2392 "bomb-out" hack was added.) |
| 2393 | |
| 853 | 2394 [[#### Fix this horrifitude!]] |
| 2395 | |
| 2396 I don't think this is horrifitude, but just defensive coding. --ben */ | |
| 2397 | |
| 2398 signal_call_debugger (conditions, error_symbol, data, Qnil, 0, | |
| 428 | 2399 &stack_trace_displayed, |
| 2400 &debugger_entered); | |
| 2401 UNGCPRO; | |
| 853 | 2402 throw_or_bomb_out (Qtop_level, Qt, 1, error_symbol, |
| 2403 data); /* Doesn't return */ | |
| 2268 | 2404 RETURN_NOT_REACHED (Qnil); |
| 428 | 2405 } |
| 2406 | |
| 2407 /****************** Error functions class 1 ******************/ | |
| 2408 | |
| 2409 /* Class 1: General functions that signal an error. | |
| 2410 These functions take an error type and a list of associated error | |
| 2411 data. */ | |
| 2412 | |
| 853 | 2413 /* No signal_continuable_error_1(); it's called Fsignal(). */ |
| 428 | 2414 |
| 2415 /* Signal a non-continuable error. */ | |
| 2416 | |
| 2417 DOESNT_RETURN | |
| 563 | 2418 signal_error_1 (Lisp_Object sig, Lisp_Object data) |
| 428 | 2419 { |
| 2420 for (;;) | |
| 2421 Fsignal (sig, data); | |
| 2422 } | |
| 853 | 2423 |
| 2424 #ifdef ERROR_CHECK_CATCH | |
| 2425 | |
| 2426 void | |
| 2427 check_catchlist_sanity (void) | |
| 2428 { | |
| 2429 #if 0 | |
| 2430 /* vou me tomar no cu! i just masked andy's missing-unbind | |
| 2431 bug! */ | |
| 442 | 2432 struct catchtag *c; |
| 2433 int found_error_tag = 0; | |
| 2434 | |
| 2435 for (c = catchlist; c; c = c->next) | |
| 2436 { | |
| 2437 if (EQ (c->tag, Qunbound_suspended_errors_tag)) | |
| 2438 { | |
| 2439 found_error_tag = 1; | |
| 2440 break; | |
| 2441 } | |
| 2442 } | |
| 2443 | |
| 2444 assert (found_error_tag || NILP (Vcurrent_error_state)); | |
| 853 | 2445 #endif /* vou me tomar no cul */ |
| 2446 } | |
| 2447 | |
| 2448 void | |
| 2449 check_specbind_stack_sanity (void) | |
| 2450 { | |
| 2451 } | |
| 2452 | |
| 2453 #endif /* ERROR_CHECK_CATCH */ | |
| 428 | 2454 |
| 2455 /* Signal a non-continuable error or display a warning or do nothing, | |
| 2456 according to ERRB. CLASS is the class of warning and should | |
| 2457 refer to what sort of operation is being done (e.g. Qtoolbar, | |
| 2458 Qresource, etc.). */ | |
| 2459 | |
| 2460 void | |
| 1204 | 2461 maybe_signal_error_1 (Lisp_Object sig, Lisp_Object data, Lisp_Object class_, |
| 578 | 2462 Error_Behavior errb) |
| 428 | 2463 { |
| 2464 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2465 return; | |
| 793 | 2466 else if (ERRB_EQ (errb, ERROR_ME_DEBUG_WARN)) |
| 1204 | 2467 warn_when_safe_lispobj (class_, Qdebug, Fcons (sig, data)); |
| 428 | 2468 else if (ERRB_EQ (errb, ERROR_ME_WARN)) |
| 1204 | 2469 warn_when_safe_lispobj (class_, Qwarning, Fcons (sig, data)); |
| 428 | 2470 else |
| 2471 for (;;) | |
| 2472 Fsignal (sig, data); | |
| 2473 } | |
| 2474 | |
| 2475 /* Signal a continuable error or display a warning or do nothing, | |
| 2476 according to ERRB. */ | |
| 2477 | |
| 2478 Lisp_Object | |
| 563 | 2479 maybe_signal_continuable_error_1 (Lisp_Object sig, Lisp_Object data, |
| 1204 | 2480 Lisp_Object class_, Error_Behavior errb) |
| 428 | 2481 { |
| 2482 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2483 return Qnil; | |
| 793 | 2484 else if (ERRB_EQ (errb, ERROR_ME_DEBUG_WARN)) |
| 2485 { | |
| 1204 | 2486 warn_when_safe_lispobj (class_, Qdebug, Fcons (sig, data)); |
| 793 | 2487 return Qnil; |
| 2488 } | |
| 428 | 2489 else if (ERRB_EQ (errb, ERROR_ME_WARN)) |
| 2490 { | |
| 1204 | 2491 warn_when_safe_lispobj (class_, Qwarning, Fcons (sig, data)); |
| 428 | 2492 return Qnil; |
| 2493 } | |
| 2494 else | |
| 2495 return Fsignal (sig, data); | |
| 2496 } | |
| 2497 | |
| 2498 | |
| 2499 /****************** Error functions class 2 ******************/ | |
| 2500 | |
| 563 | 2501 /* Class 2: Signal an error with a string and an associated object. |
| 2502 Normally these functions are used to attach one associated object, | |
| 2503 but to attach no objects, specify Qunbound for FROB, and for more | |
| 2504 than one object, make a list of the objects with Qunbound as the | |
| 2505 first element. (If you have specifically two objects to attach, | |
| 2506 consider using the function in class 3 below.) These functions | |
| 2507 signal an error of a specified type, whose data is one or more | |
| 2508 objects (usually two), a string the related Lisp object(s) | |
| 2509 specified as FROB. */ | |
| 2510 | |
| 2511 /* Out of REASON and FROB, return a list of elements suitable for passing | |
| 2512 to signal_error_1(). */ | |
| 2513 | |
| 2514 Lisp_Object | |
| 867 | 2515 build_error_data (const CIbyte *reason, Lisp_Object frob) |
| 563 | 2516 { |
| 2517 if (EQ (frob, Qunbound)) | |
| 2518 frob = Qnil; | |
| 2519 else if (CONSP (frob) && EQ (XCAR (frob), Qunbound)) | |
| 2520 frob = XCDR (frob); | |
| 2521 else | |
| 2522 frob = list1 (frob); | |
| 2523 if (!reason) | |
| 2524 return frob; | |
| 2525 else | |
| 771 | 2526 return Fcons (build_msg_string (reason), frob); |
| 563 | 2527 } |
| 2528 | |
| 2529 DOESNT_RETURN | |
| 867 | 2530 signal_error (Lisp_Object type, const CIbyte *reason, Lisp_Object frob) |
| 563 | 2531 { |
| 2532 signal_error_1 (type, build_error_data (reason, frob)); | |
| 2533 } | |
| 2534 | |
| 2535 void | |
| 867 | 2536 maybe_signal_error (Lisp_Object type, const CIbyte *reason, |
| 1204 | 2537 Lisp_Object frob, Lisp_Object class_, |
| 578 | 2538 Error_Behavior errb) |
| 563 | 2539 { |
| 2540 /* Optimization: */ | |
| 2541 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2542 return; | |
| 1204 | 2543 maybe_signal_error_1 (type, build_error_data (reason, frob), class_, errb); |
| 563 | 2544 } |
| 2545 | |
| 2546 Lisp_Object | |
| 867 | 2547 signal_continuable_error (Lisp_Object type, const CIbyte *reason, |
| 563 | 2548 Lisp_Object frob) |
| 2549 { | |
| 2550 return Fsignal (type, build_error_data (reason, frob)); | |
| 2551 } | |
| 2552 | |
| 2553 Lisp_Object | |
| 867 | 2554 maybe_signal_continuable_error (Lisp_Object type, const CIbyte *reason, |
| 1204 | 2555 Lisp_Object frob, Lisp_Object class_, |
| 578 | 2556 Error_Behavior errb) |
| 563 | 2557 { |
| 2558 /* Optimization: */ | |
| 2559 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2560 return Qnil; | |
| 2561 return maybe_signal_continuable_error_1 (type, | |
| 2562 build_error_data (reason, frob), | |
| 1204 | 2563 class_, errb); |
| 563 | 2564 } |
| 2565 | |
| 2566 | |
| 2567 /****************** Error functions class 3 ******************/ | |
| 2568 | |
| 2569 /* Class 3: Signal an error with a string and two associated objects. | |
| 2570 These functions signal an error of a specified type, whose data | |
| 2571 is three objects, a string and two related Lisp objects. | |
| 2572 (The equivalent could be accomplished using the class 2 functions, | |
| 2573 but these are more convenient in this particular case.) */ | |
| 2574 | |
| 2575 DOESNT_RETURN | |
| 867 | 2576 signal_error_2 (Lisp_Object type, const CIbyte *reason, |
| 563 | 2577 Lisp_Object frob0, Lisp_Object frob1) |
| 2578 { | |
| 771 | 2579 signal_error_1 (type, list3 (build_msg_string (reason), frob0, |
| 563 | 2580 frob1)); |
| 2581 } | |
| 2582 | |
| 2583 void | |
| 867 | 2584 maybe_signal_error_2 (Lisp_Object type, const CIbyte *reason, |
| 563 | 2585 Lisp_Object frob0, Lisp_Object frob1, |
| 1204 | 2586 Lisp_Object class_, Error_Behavior errb) |
| 563 | 2587 { |
| 2588 /* Optimization: */ | |
| 2589 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2590 return; | |
| 771 | 2591 maybe_signal_error_1 (type, list3 (build_msg_string (reason), frob0, |
| 1204 | 2592 frob1), class_, errb); |
| 563 | 2593 } |
| 2594 | |
| 2595 Lisp_Object | |
| 867 | 2596 signal_continuable_error_2 (Lisp_Object type, const CIbyte *reason, |
| 563 | 2597 Lisp_Object frob0, Lisp_Object frob1) |
| 2598 { | |
| 771 | 2599 return Fsignal (type, list3 (build_msg_string (reason), frob0, |
| 563 | 2600 frob1)); |
| 2601 } | |
| 2602 | |
| 2603 Lisp_Object | |
| 867 | 2604 maybe_signal_continuable_error_2 (Lisp_Object type, const CIbyte *reason, |
| 563 | 2605 Lisp_Object frob0, Lisp_Object frob1, |
| 1204 | 2606 Lisp_Object class_, Error_Behavior errb) |
| 563 | 2607 { |
| 2608 /* Optimization: */ | |
| 2609 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2610 return Qnil; | |
| 2611 return maybe_signal_continuable_error_1 | |
| 771 | 2612 (type, list3 (build_msg_string (reason), frob0, frob1), |
| 1204 | 2613 class_, errb); |
| 563 | 2614 } |
| 2615 | |
| 2616 | |
| 2617 /****************** Error functions class 4 ******************/ | |
| 2618 | |
| 2619 /* Class 4: Printf-like functions that signal an error. | |
| 442 | 2620 These functions signal an error of a specified type, whose data |
| 428 | 2621 is a single string, created using the arguments. */ |
| 2622 | |
| 2623 DOESNT_RETURN | |
| 867 | 2624 signal_ferror (Lisp_Object type, const CIbyte *fmt, ...) |
| 442 | 2625 { |
| 2626 Lisp_Object obj; | |
| 2627 va_list args; | |
| 2628 | |
| 2629 va_start (args, fmt); | |
| 771 | 2630 obj = emacs_vsprintf_string (CGETTEXT (fmt), args); |
| 442 | 2631 va_end (args); |
| 2632 | |
| 2633 /* Fsignal GC-protects its args */ | |
| 563 | 2634 signal_error (type, 0, obj); |
| 442 | 2635 } |
| 2636 | |
| 2637 void | |
| 1204 | 2638 maybe_signal_ferror (Lisp_Object type, Lisp_Object class_, Error_Behavior errb, |
| 867 | 2639 const CIbyte *fmt, ...) |
| 442 | 2640 { |
| 2641 Lisp_Object obj; | |
| 2642 va_list args; | |
| 2643 | |
| 2644 /* Optimization: */ | |
| 2645 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2646 return; | |
| 2647 | |
| 2648 va_start (args, fmt); | |
| 771 | 2649 obj = emacs_vsprintf_string (CGETTEXT (fmt), args); |
| 442 | 2650 va_end (args); |
| 2651 | |
| 2652 /* Fsignal GC-protects its args */ | |
| 1204 | 2653 maybe_signal_error (type, 0, obj, class_, errb); |
| 442 | 2654 } |
| 2655 | |
| 2656 Lisp_Object | |
| 867 | 2657 signal_continuable_ferror (Lisp_Object type, const CIbyte *fmt, ...) |
| 428 | 2658 { |
| 2659 Lisp_Object obj; | |
| 2660 va_list args; | |
| 2661 | |
| 2662 va_start (args, fmt); | |
| 771 | 2663 obj = emacs_vsprintf_string (CGETTEXT (fmt), args); |
| 442 | 2664 va_end (args); |
| 2665 | |
| 2666 /* Fsignal GC-protects its args */ | |
| 2667 return Fsignal (type, list1 (obj)); | |
| 2668 } | |
| 2669 | |
| 2670 Lisp_Object | |
| 1204 | 2671 maybe_signal_continuable_ferror (Lisp_Object type, Lisp_Object class_, |
| 867 | 2672 Error_Behavior errb, const CIbyte *fmt, ...) |
| 442 | 2673 { |
| 2674 Lisp_Object obj; | |
| 2675 va_list args; | |
| 2676 | |
| 2677 /* Optimization: */ | |
| 2678 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2679 return Qnil; | |
| 2680 | |
| 2681 va_start (args, fmt); | |
| 771 | 2682 obj = emacs_vsprintf_string (CGETTEXT (fmt), args); |
| 442 | 2683 va_end (args); |
| 2684 | |
| 2685 /* Fsignal GC-protects its args */ | |
| 1204 | 2686 return maybe_signal_continuable_error (type, 0, obj, class_, errb); |
| 442 | 2687 } |
| 2688 | |
| 2689 | |
| 2690 /****************** Error functions class 5 ******************/ | |
| 2691 | |
| 563 | 2692 /* Class 5: Printf-like functions that signal an error. |
| 442 | 2693 These functions signal an error of a specified type, whose data |
| 563 | 2694 is a one or more objects, a string (created using the arguments) |
| 2695 and additional Lisp objects specified in FROB. (The syntax of FROB | |
| 2696 is the same as for class 2.) | |
| 2697 | |
| 2698 There is no need for a class 6 because you can always attach 2 | |
| 2699 objects using class 5 (for FROB, specify a list with three | |
| 2700 elements, the first of which is Qunbound), and these functions are | |
| 2701 not commonly used. | |
| 2702 */ | |
| 442 | 2703 |
| 2704 DOESNT_RETURN | |
| 867 | 2705 signal_ferror_with_frob (Lisp_Object type, Lisp_Object frob, const CIbyte *fmt, |
| 563 | 2706 ...) |
| 442 | 2707 { |
| 2708 Lisp_Object obj; | |
| 2709 va_list args; | |
| 2710 | |
| 2711 va_start (args, fmt); | |
| 771 | 2712 obj = emacs_vsprintf_string (CGETTEXT (fmt), args); |
| 442 | 2713 va_end (args); |
| 2714 | |
| 2715 /* Fsignal GC-protects its args */ | |
| 563 | 2716 signal_error_1 (type, Fcons (obj, build_error_data (0, frob))); |
| 442 | 2717 } |
| 2718 | |
| 2719 void | |
| 563 | 2720 maybe_signal_ferror_with_frob (Lisp_Object type, Lisp_Object frob, |
| 1204 | 2721 Lisp_Object class_, Error_Behavior errb, |
| 867 | 2722 const CIbyte *fmt, ...) |
| 442 | 2723 { |
| 2724 Lisp_Object obj; | |
| 2725 va_list args; | |
| 2726 | |
| 2727 /* Optimization: */ | |
| 2728 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2729 return; | |
| 2730 | |
| 2731 va_start (args, fmt); | |
| 771 | 2732 obj = emacs_vsprintf_string (CGETTEXT (fmt), args); |
| 428 | 2733 va_end (args); |
| 2734 | |
| 2735 /* Fsignal GC-protects its args */ | |
| 1204 | 2736 maybe_signal_error_1 (type, Fcons (obj, build_error_data (0, frob)), class_, |
| 563 | 2737 errb); |
| 428 | 2738 } |
| 2739 | |
| 2740 Lisp_Object | |
| 563 | 2741 signal_continuable_ferror_with_frob (Lisp_Object type, Lisp_Object frob, |
| 867 | 2742 const CIbyte *fmt, ...) |
| 428 | 2743 { |
| 2744 Lisp_Object obj; | |
| 2745 va_list args; | |
| 2746 | |
| 2747 va_start (args, fmt); | |
| 771 | 2748 obj = emacs_vsprintf_string (CGETTEXT (fmt), args); |
| 428 | 2749 va_end (args); |
| 2750 | |
| 2751 /* Fsignal GC-protects its args */ | |
| 563 | 2752 return Fsignal (type, Fcons (obj, build_error_data (0, frob))); |
| 428 | 2753 } |
| 2754 | |
| 2755 Lisp_Object | |
| 563 | 2756 maybe_signal_continuable_ferror_with_frob (Lisp_Object type, Lisp_Object frob, |
| 1204 | 2757 Lisp_Object class_, |
| 578 | 2758 Error_Behavior errb, |
| 867 | 2759 const CIbyte *fmt, ...) |
| 428 | 2760 { |
| 2761 Lisp_Object obj; | |
| 2762 va_list args; | |
| 2763 | |
| 2764 /* Optimization: */ | |
| 2765 if (ERRB_EQ (errb, ERROR_ME_NOT)) | |
| 2766 return Qnil; | |
| 2767 | |
| 2768 va_start (args, fmt); | |
| 771 | 2769 obj = emacs_vsprintf_string (CGETTEXT (fmt), args); |
| 428 | 2770 va_end (args); |
| 2771 | |
| 2772 /* Fsignal GC-protects its args */ | |
| 563 | 2773 return maybe_signal_continuable_error_1 (type, |
| 2774 Fcons (obj, | |
| 2775 build_error_data (0, frob)), | |
| 1204 | 2776 class_, errb); |
| 428 | 2777 } |
| 2778 | |
| 2779 | |
| 2780 /* This is what the QUIT macro calls to signal a quit */ | |
| 2781 void | |
| 2782 signal_quit (void) | |
| 2783 { | |
| 853 | 2784 /* This function cannot GC. GC is prohibited because most callers do |
| 2785 not expect GC occurring in QUIT. Remove this if/when that gets fixed. | |
| 2786 --ben */ | |
| 2787 | |
| 2788 int count; | |
| 2789 | |
| 428 | 2790 if (EQ (Vquit_flag, Qcritical)) |
| 2791 debug_on_quit |= 2; /* set critical bit. */ | |
| 2792 Vquit_flag = Qnil; | |
| 853 | 2793 count = begin_gc_forbidden (); |
| 428 | 2794 /* note that this is continuable. */ |
| 2795 Fsignal (Qquit, Qnil); | |
| 853 | 2796 unbind_to (count); |
| 428 | 2797 } |
| 2798 | |
| 2799 | |
| 563 | 2800 /************************ convenience error functions ***********************/ |
| 2801 | |
| 436 | 2802 Lisp_Object |
| 428 | 2803 signal_void_function_error (Lisp_Object function) |
| 2804 { | |
| 436 | 2805 return Fsignal (Qvoid_function, list1 (function)); |
| 428 | 2806 } |
| 2807 | |
| 436 | 2808 Lisp_Object |
| 428 | 2809 signal_invalid_function_error (Lisp_Object function) |
| 2810 { | |
| 436 | 2811 return Fsignal (Qinvalid_function, list1 (function)); |
| 428 | 2812 } |
| 2813 | |
| 436 | 2814 Lisp_Object |
| 428 | 2815 signal_wrong_number_of_arguments_error (Lisp_Object function, int nargs) |
| 2816 { | |
| 436 | 2817 return Fsignal (Qwrong_number_of_arguments, |
| 2818 list2 (function, make_int (nargs))); | |
| 428 | 2819 } |
| 2820 | |
| 2821 /* Used in list traversal macros for efficiency. */ | |
| 436 | 2822 DOESNT_RETURN |
| 428 | 2823 signal_malformed_list_error (Lisp_Object list) |
| 2824 { | |
| 563 | 2825 signal_error (Qmalformed_list, 0, list); |
| 428 | 2826 } |
| 2827 | |
| 436 | 2828 DOESNT_RETURN |
| 428 | 2829 signal_malformed_property_list_error (Lisp_Object list) |
| 2830 { | |
| 563 | 2831 signal_error (Qmalformed_property_list, 0, list); |
| 428 | 2832 } |
| 2833 | |
| 436 | 2834 DOESNT_RETURN |
| 428 | 2835 signal_circular_list_error (Lisp_Object list) |
| 2836 { | |
| 563 | 2837 signal_error (Qcircular_list, 0, list); |
| 428 | 2838 } |
| 2839 | |
| 436 | 2840 DOESNT_RETURN |
| 428 | 2841 signal_circular_property_list_error (Lisp_Object list) |
| 2842 { | |
| 563 | 2843 signal_error (Qcircular_property_list, 0, list); |
| 428 | 2844 } |
| 442 | 2845 |
| 2267 | 2846 /* Called from within emacs_doprnt_1, so REASON is not formatted. */ |
| 442 | 2847 DOESNT_RETURN |
| 867 | 2848 syntax_error (const CIbyte *reason, Lisp_Object frob) |
| 442 | 2849 { |
| 563 | 2850 signal_error (Qsyntax_error, reason, frob); |
| 442 | 2851 } |
| 2852 | |
| 2853 DOESNT_RETURN | |
| 867 | 2854 syntax_error_2 (const CIbyte *reason, Lisp_Object frob1, Lisp_Object frob2) |
| 442 | 2855 { |
| 563 | 2856 signal_error_2 (Qsyntax_error, reason, frob1, frob2); |
| 2857 } | |
| 2858 | |
| 2859 void | |
| 867 | 2860 maybe_syntax_error (const CIbyte *reason, Lisp_Object frob, |
| 1204 | 2861 Lisp_Object class_, Error_Behavior errb) |
| 2862 { | |
| 2863 maybe_signal_error (Qsyntax_error, reason, frob, class_, errb); | |
| 563 | 2864 } |
| 2865 | |
| 2866 DOESNT_RETURN | |
| 867 | 2867 sferror (const CIbyte *reason, Lisp_Object frob) |
| 563 | 2868 { |
| 2869 signal_error (Qstructure_formation_error, reason, frob); | |
| 2870 } | |
| 2871 | |
| 2872 DOESNT_RETURN | |
| 867 | 2873 sferror_2 (const CIbyte *reason, Lisp_Object frob1, Lisp_Object frob2) |
| 563 | 2874 { |
| 2875 signal_error_2 (Qstructure_formation_error, reason, frob1, frob2); | |
| 2876 } | |
| 2877 | |
| 2878 void | |
| 867 | 2879 maybe_sferror (const CIbyte *reason, Lisp_Object frob, |
| 1204 | 2880 Lisp_Object class_, Error_Behavior errb) |
| 2881 { | |
| 2882 maybe_signal_error (Qstructure_formation_error, reason, frob, class_, errb); | |
| 442 | 2883 } |
| 2884 | |
| 2885 DOESNT_RETURN | |
| 867 | 2886 invalid_argument (const CIbyte *reason, Lisp_Object frob) |
| 442 | 2887 { |
| 563 | 2888 signal_error (Qinvalid_argument, reason, frob); |
| 442 | 2889 } |
| 2890 | |
| 2891 DOESNT_RETURN | |
| 867 | 2892 invalid_argument_2 (const CIbyte *reason, Lisp_Object frob1, |
| 609 | 2893 Lisp_Object frob2) |
| 442 | 2894 { |
| 563 | 2895 signal_error_2 (Qinvalid_argument, reason, frob1, frob2); |
| 2896 } | |
| 2897 | |
| 2898 void | |
| 867 | 2899 maybe_invalid_argument (const CIbyte *reason, Lisp_Object frob, |
| 1204 | 2900 Lisp_Object class_, Error_Behavior errb) |
| 2901 { | |
| 2902 maybe_signal_error (Qinvalid_argument, reason, frob, class_, errb); | |
| 563 | 2903 } |
| 2904 | |
| 2905 DOESNT_RETURN | |
| 867 | 2906 invalid_constant (const CIbyte *reason, Lisp_Object frob) |
| 563 | 2907 { |
| 2908 signal_error (Qinvalid_constant, reason, frob); | |
| 2909 } | |
| 2910 | |
| 2911 DOESNT_RETURN | |
| 867 | 2912 invalid_constant_2 (const CIbyte *reason, Lisp_Object frob1, |
| 609 | 2913 Lisp_Object frob2) |
| 563 | 2914 { |
| 2915 signal_error_2 (Qinvalid_constant, reason, frob1, frob2); | |
| 2916 } | |
| 2917 | |
| 2918 void | |
| 867 | 2919 maybe_invalid_constant (const CIbyte *reason, Lisp_Object frob, |
| 1204 | 2920 Lisp_Object class_, Error_Behavior errb) |
| 2921 { | |
| 2922 maybe_signal_error (Qinvalid_constant, reason, frob, class_, errb); | |
| 442 | 2923 } |
| 2924 | |
| 2925 DOESNT_RETURN | |
| 867 | 2926 invalid_operation (const CIbyte *reason, Lisp_Object frob) |
| 442 | 2927 { |
| 563 | 2928 signal_error (Qinvalid_operation, reason, frob); |
| 442 | 2929 } |
| 2930 | |
| 2931 DOESNT_RETURN | |
| 867 | 2932 invalid_operation_2 (const CIbyte *reason, Lisp_Object frob1, |
| 609 | 2933 Lisp_Object frob2) |
| 442 | 2934 { |
| 563 | 2935 signal_error_2 (Qinvalid_operation, reason, frob1, frob2); |
| 2936 } | |
| 2937 | |
| 2938 void | |
| 867 | 2939 maybe_invalid_operation (const CIbyte *reason, Lisp_Object frob, |
| 1204 | 2940 Lisp_Object class_, Error_Behavior errb) |
| 2941 { | |
| 2942 maybe_signal_error (Qinvalid_operation, reason, frob, class_, errb); | |
| 442 | 2943 } |
| 2944 | |
| 2945 DOESNT_RETURN | |
| 867 | 2946 invalid_change (const CIbyte *reason, Lisp_Object frob) |
| 442 | 2947 { |
| 563 | 2948 signal_error (Qinvalid_change, reason, frob); |
| 442 | 2949 } |
| 2950 | |
| 2951 DOESNT_RETURN | |
| 867 | 2952 invalid_change_2 (const CIbyte *reason, Lisp_Object frob1, Lisp_Object frob2) |
| 442 | 2953 { |
| 563 | 2954 signal_error_2 (Qinvalid_change, reason, frob1, frob2); |
| 2955 } | |
| 2956 | |
| 2957 void | |
| 867 | 2958 maybe_invalid_change (const CIbyte *reason, Lisp_Object frob, |
| 1204 | 2959 Lisp_Object class_, Error_Behavior errb) |
| 2960 { | |
| 2961 maybe_signal_error (Qinvalid_change, reason, frob, class_, errb); | |
| 563 | 2962 } |
| 2963 | |
| 2964 DOESNT_RETURN | |
| 867 | 2965 invalid_state (const CIbyte *reason, Lisp_Object frob) |
| 563 | 2966 { |
| 2967 signal_error (Qinvalid_state, reason, frob); | |
| 2968 } | |
| 2969 | |
| 2970 DOESNT_RETURN | |
| 867 | 2971 invalid_state_2 (const CIbyte *reason, Lisp_Object frob1, Lisp_Object frob2) |
| 563 | 2972 { |
| 2973 signal_error_2 (Qinvalid_state, reason, frob1, frob2); | |
| 2974 } | |
| 2975 | |
| 2976 void | |
| 867 | 2977 maybe_invalid_state (const CIbyte *reason, Lisp_Object frob, |
| 1204 | 2978 Lisp_Object class_, Error_Behavior errb) |
| 2979 { | |
| 2980 maybe_signal_error (Qinvalid_state, reason, frob, class_, errb); | |
| 563 | 2981 } |
| 2982 | |
| 2983 DOESNT_RETURN | |
| 867 | 2984 wtaerror (const CIbyte *reason, Lisp_Object frob) |
| 563 | 2985 { |
| 2986 signal_error (Qwrong_type_argument, reason, frob); | |
| 2987 } | |
| 2988 | |
| 2989 DOESNT_RETURN | |
| 867 | 2990 stack_overflow (const CIbyte *reason, Lisp_Object frob) |
| 563 | 2991 { |
| 2992 signal_error (Qstack_overflow, reason, frob); | |
| 2993 } | |
| 2994 | |
| 2995 DOESNT_RETURN | |
| 867 | 2996 out_of_memory (const CIbyte *reason, Lisp_Object frob) |
| 563 | 2997 { |
| 2998 signal_error (Qout_of_memory, reason, frob); | |
| 2999 } | |
| 3000 | |
| 3001 DOESNT_RETURN | |
| 867 | 3002 printing_unreadable_object (const CIbyte *fmt, ...) |
| 563 | 3003 { |
| 3004 Lisp_Object obj; | |
| 3005 va_list args; | |
| 3006 | |
| 3007 va_start (args, fmt); | |
| 771 | 3008 obj = emacs_vsprintf_string (CGETTEXT (fmt), args); |
| 563 | 3009 va_end (args); |
| 3010 | |
| 3011 /* Fsignal GC-protects its args */ | |
| 3012 signal_error (Qprinting_unreadable_object, 0, obj); | |
| 442 | 3013 } |
| 3014 | |
| 428 | 3015 |
| 3016 /************************************************************************/ | |
| 3017 /* User commands */ | |
| 3018 /************************************************************************/ | |
| 3019 | |
| 3020 DEFUN ("commandp", Fcommandp, 1, 1, 0, /* | |
| 3021 Return t if FUNCTION makes provisions for interactive calling. | |
| 3022 This means it contains a description for how to read arguments to give it. | |
| 3023 The value is nil for an invalid function or a symbol with no function | |
| 3024 definition. | |
| 3025 | |
| 3026 Interactively callable functions include | |
| 3027 | |
| 3028 -- strings and vectors (treated as keyboard macros) | |
| 3029 -- lambda-expressions that contain a top-level call to `interactive' | |
| 3030 -- autoload definitions made by `autoload' with non-nil fourth argument | |
| 3031 (i.e. the interactive flag) | |
| 3032 -- compiled-function objects with a non-nil `compiled-function-interactive' | |
| 3033 value | |
| 3034 -- subrs (built-in functions) that are interactively callable | |
| 3035 | |
| 3036 Also, a symbol satisfies `commandp' if its function definition does so. | |
| 3037 */ | |
| 3038 (function)) | |
| 3039 { | |
| 3040 Lisp_Object fun = indirect_function (function, 0); | |
| 3041 | |
| 3042 if (COMPILED_FUNCTIONP (fun)) | |
| 3043 return XCOMPILED_FUNCTION (fun)->flags.interactivep ? Qt : Qnil; | |
| 3044 | |
| 3045 /* Lists may represent commands. */ | |
| 3046 if (CONSP (fun)) | |
| 3047 { | |
| 3048 Lisp_Object funcar = XCAR (fun); | |
| 3049 if (EQ (funcar, Qlambda)) | |
| 3050 return Fassq (Qinteractive, Fcdr (Fcdr (fun))); | |
| 3051 if (EQ (funcar, Qautoload)) | |
| 3052 return Fcar (Fcdr (Fcdr (Fcdr (fun)))); | |
| 3053 else | |
| 3054 return Qnil; | |
| 3055 } | |
| 3056 | |
| 3057 /* Emacs primitives are interactive if their DEFUN specifies an | |
| 3058 interactive spec. */ | |
| 3059 if (SUBRP (fun)) | |
| 3060 return XSUBR (fun)->prompt ? Qt : Qnil; | |
| 3061 | |
| 3062 /* Strings and vectors are keyboard macros. */ | |
| 3063 if (VECTORP (fun) || STRINGP (fun)) | |
| 3064 return Qt; | |
| 3065 | |
| 3066 /* Everything else (including Qunbound) is not a command. */ | |
| 3067 return Qnil; | |
| 3068 } | |
| 3069 | |
| 3070 DEFUN ("command-execute", Fcommand_execute, 1, 3, 0, /* | |
| 3071 Execute CMD as an editor command. | |
| 3072 CMD must be an object that satisfies the `commandp' predicate. | |
| 3073 Optional second arg RECORD-FLAG is as in `call-interactively'. | |
| 3074 The argument KEYS specifies the value to use instead of (this-command-keys) | |
| 3075 when reading the arguments. | |
| 3076 */ | |
| 444 | 3077 (cmd, record_flag, keys)) |
| 428 | 3078 { |
| 3079 /* This function can GC */ | |
| 3080 Lisp_Object prefixarg; | |
| 3081 Lisp_Object final = cmd; | |
| 4162 | 3082 PROFILE_DECLARE(); |
| 428 | 3083 struct console *con = XCONSOLE (Vselected_console); |
| 3084 | |
| 3085 prefixarg = con->prefix_arg; | |
| 3086 con->prefix_arg = Qnil; | |
| 3087 Vcurrent_prefix_arg = prefixarg; | |
| 3088 debug_on_next_call = 0; /* #### from FSFmacs; correct? */ | |
| 3089 | |
| 3090 if (SYMBOLP (cmd) && !NILP (Fget (cmd, Qdisabled, Qnil))) | |
| 733 | 3091 return run_hook (Qdisabled_command_hook); |
| 428 | 3092 |
| 3093 for (;;) | |
| 3094 { | |
| 3095 final = indirect_function (cmd, 1); | |
| 3096 if (CONSP (final) && EQ (Fcar (final), Qautoload)) | |
| 970 | 3097 { |
| 3098 /* do_autoload GCPROs both arguments */ | |
| 3099 do_autoload (final, cmd); | |
| 3100 } | |
| 428 | 3101 else |
| 3102 break; | |
| 3103 } | |
| 3104 | |
| 3105 if (CONSP (final) || SUBRP (final) || COMPILED_FUNCTIONP (final)) | |
| 3106 { | |
| 3107 backtrace.function = &Qcall_interactively; | |
| 3108 backtrace.args = &cmd; | |
| 3109 backtrace.nargs = 1; | |
| 3110 backtrace.evalargs = 0; | |
| 1292 | 3111 backtrace.pdlcount = specpdl_depth (); |
| 428 | 3112 backtrace.debug_on_exit = 0; |
| 1292 | 3113 backtrace.function_being_called = 0; |
| 428 | 3114 PUSH_BACKTRACE (backtrace); |
| 3115 | |
| 1292 | 3116 PROFILE_ENTER_FUNCTION (); |
| 444 | 3117 final = Fcall_interactively (cmd, record_flag, keys); |
| 1292 | 3118 PROFILE_EXIT_FUNCTION (); |
| 428 | 3119 |
| 3120 POP_BACKTRACE (backtrace); | |
| 3121 return final; | |
| 3122 } | |
| 3123 else if (STRINGP (final) || VECTORP (final)) | |
| 3124 { | |
| 3125 return Fexecute_kbd_macro (final, prefixarg); | |
| 3126 } | |
| 3127 else | |
| 3128 { | |
| 3129 Fsignal (Qwrong_type_argument, | |
| 3130 Fcons (Qcommandp, | |
| 3131 (EQ (cmd, final) | |
| 3132 ? list1 (cmd) | |
| 3133 : list2 (cmd, final)))); | |
| 3134 return Qnil; | |
| 3135 } | |
| 3136 } | |
| 3137 | |
| 3138 DEFUN ("interactive-p", Finteractive_p, 0, 0, 0, /* | |
| 3139 Return t if function in which this appears was called interactively. | |
| 3140 This means that the function was called with call-interactively (which | |
| 3141 includes being called as the binding of a key) | |
| 3142 and input is currently coming from the keyboard (not in keyboard macro). | |
| 3143 */ | |
| 3144 ()) | |
| 3145 { | |
| 3146 REGISTER struct backtrace *btp; | |
| 3147 REGISTER Lisp_Object fun; | |
| 3148 | |
| 3149 if (!INTERACTIVE) | |
| 3150 return Qnil; | |
| 3151 | |
| 3152 /* Unless the object was compiled, skip the frame of interactive-p itself | |
| 3153 (if interpreted) or the frame of byte-code (if called from a compiled | |
| 3154 function). Note that *btp->function may be a symbol pointing at a | |
| 3155 compiled function. */ | |
| 3156 btp = backtrace_list; | |
| 3157 | |
| 3158 #if 0 /* FSFmacs */ | |
| 3159 | |
| 3160 /* #### FSFmacs does the following instead. I can't figure | |
| 3161 out which one is more correct. */ | |
| 3162 /* If this isn't a byte-compiled function, there may be a frame at | |
| 3163 the top for Finteractive_p itself. If so, skip it. */ | |
| 3164 fun = Findirect_function (*btp->function); | |
| 3165 if (SUBRP (fun) && XSUBR (fun) == &Sinteractive_p) | |
| 3166 btp = btp->next; | |
| 3167 | |
| 3168 /* If we're running an Emacs 18-style byte-compiled function, there | |
| 3169 may be a frame for Fbyte_code. Now, given the strictest | |
| 3170 definition, this function isn't really being called | |
| 3171 interactively, but because that's the way Emacs 18 always builds | |
| 3172 byte-compiled functions, we'll accept it for now. */ | |
| 3173 if (EQ (*btp->function, Qbyte_code)) | |
| 3174 btp = btp->next; | |
| 3175 | |
| 3176 /* If this isn't a byte-compiled function, then we may now be | |
| 3177 looking at several frames for special forms. Skip past them. */ | |
| 3178 while (btp && | |
| 3179 btp->nargs == UNEVALLED) | |
| 3180 btp = btp->next; | |
| 3181 | |
| 3182 #else | |
| 3183 | |
| 3184 if (! (COMPILED_FUNCTIONP (Findirect_function (*btp->function)))) | |
| 3185 btp = btp->next; | |
| 3186 for (; | |
| 3187 btp && (btp->nargs == UNEVALLED | |
| 3188 || EQ (*btp->function, Qbyte_code)); | |
| 3189 btp = btp->next) | |
| 3190 {} | |
| 3191 /* btp now points at the frame of the innermost function | |
| 3192 that DOES eval its args. | |
| 3193 If it is a built-in function (such as load or eval-region) | |
| 3194 return nil. */ | |
| 3195 /* Beats me why this is necessary, but it is */ | |
| 3196 if (btp && EQ (*btp->function, Qcall_interactively)) | |
| 3197 return Qt; | |
| 3198 | |
| 3199 #endif | |
| 3200 | |
| 3201 fun = Findirect_function (*btp->function); | |
| 3202 if (SUBRP (fun)) | |
| 3203 return Qnil; | |
| 3204 /* btp points to the frame of a Lisp function that called interactive-p. | |
| 3205 Return t if that function was called interactively. */ | |
| 3206 if (btp && btp->next && EQ (*btp->next->function, Qcall_interactively)) | |
| 3207 return Qt; | |
| 3208 return Qnil; | |
| 3209 } | |
| 3210 | |
| 3211 | |
| 3212 /************************************************************************/ | |
| 3213 /* Autoloading */ | |
| 3214 /************************************************************************/ | |
| 3215 | |
| 3216 DEFUN ("autoload", Fautoload, 2, 5, 0, /* | |
| 444 | 3217 Define FUNCTION to autoload from FILENAME. |
| 3218 FUNCTION is a symbol; FILENAME is a file name string to pass to `load'. | |
| 3219 The remaining optional arguments provide additional info about the | |
| 3220 real definition. | |
| 3221 DOCSTRING is documentation for FUNCTION. | |
| 3222 INTERACTIVE, if non-nil, says FUNCTION can be called interactively. | |
| 3223 TYPE indicates the type of the object: | |
| 428 | 3224 nil or omitted says FUNCTION is a function, |
| 3225 `keymap' says FUNCTION is really a keymap, and | |
| 3226 `macro' or t says FUNCTION is really a macro. | |
| 444 | 3227 If FUNCTION already has a non-void function definition that is not an |
| 3228 autoload object, this function does nothing and returns nil. | |
| 428 | 3229 */ |
| 444 | 3230 (function, filename, docstring, interactive, type)) |
| 428 | 3231 { |
| 3232 /* This function can GC */ | |
| 3233 CHECK_SYMBOL (function); | |
| 444 | 3234 CHECK_STRING (filename); |
| 428 | 3235 |
| 3236 /* If function is defined and not as an autoload, don't override */ | |
| 3237 { | |
| 3238 Lisp_Object f = XSYMBOL (function)->function; | |
| 3239 if (!UNBOUNDP (f) && !(CONSP (f) && EQ (XCAR (f), Qautoload))) | |
| 3240 return Qnil; | |
| 3241 } | |
| 3242 | |
| 3243 if (purify_flag) | |
| 3244 { | |
| 3245 /* Attempt to avoid consing identical (string=) pure strings. */ | |
| 444 | 3246 filename = Fsymbol_name (Fintern (filename, Qnil)); |
| 428 | 3247 } |
| 440 | 3248 |
| 444 | 3249 return Ffset (function, Fcons (Qautoload, list4 (filename, |
| 428 | 3250 docstring, |
| 3251 interactive, | |
| 3252 type))); | |
| 3253 } | |
| 3254 | |
| 3255 Lisp_Object | |
| 3256 un_autoload (Lisp_Object oldqueue) | |
| 3257 { | |
| 3258 /* This function can GC */ | |
| 3259 REGISTER Lisp_Object queue, first, second; | |
| 3260 | |
| 3261 /* Queue to unwind is current value of Vautoload_queue. | |
| 3262 oldqueue is the shadowed value to leave in Vautoload_queue. */ | |
| 3263 queue = Vautoload_queue; | |
| 3264 Vautoload_queue = oldqueue; | |
| 3265 while (CONSP (queue)) | |
| 3266 { | |
| 3267 first = XCAR (queue); | |
| 3268 second = Fcdr (first); | |
| 3269 first = Fcar (first); | |
| 3270 if (NILP (second)) | |
| 3271 Vfeatures = first; | |
| 3272 else | |
| 3273 Ffset (first, second); | |
| 3274 queue = Fcdr (queue); | |
| 3275 } | |
| 3276 return Qnil; | |
| 3277 } | |
| 3278 | |
| 970 | 3279 /* do_autoload GCPROs both arguments */ |
| 428 | 3280 void |
| 3281 do_autoload (Lisp_Object fundef, | |
| 3282 Lisp_Object funname) | |
| 3283 { | |
| 3284 /* This function can GC */ | |
| 3285 int speccount = specpdl_depth(); | |
| 3286 Lisp_Object fun = funname; | |
| 970 | 3287 struct gcpro gcpro1, gcpro2, gcpro3; |
| 428 | 3288 |
| 3289 CHECK_SYMBOL (funname); | |
| 970 | 3290 GCPRO3 (fundef, funname, fun); |
| 428 | 3291 |
| 3292 /* Value saved here is to be restored into Vautoload_queue */ | |
| 3293 record_unwind_protect (un_autoload, Vautoload_queue); | |
| 3294 Vautoload_queue = Qt; | |
| 3295 call4 (Qload, Fcar (Fcdr (fundef)), Qnil, noninteractive ? Qt : Qnil, Qnil); | |
| 3296 | |
| 3297 { | |
| 3298 Lisp_Object queue; | |
| 3299 | |
| 3300 /* Save the old autoloads, in case we ever do an unload. */ | |
| 3301 for (queue = Vautoload_queue; CONSP (queue); queue = XCDR (queue)) | |
| 3302 { | |
| 3303 Lisp_Object first = XCAR (queue); | |
| 3304 Lisp_Object second = Fcdr (first); | |
| 3305 | |
| 3306 first = Fcar (first); | |
| 3307 | |
| 3308 /* Note: This test is subtle. The cdr of an autoload-queue entry | |
| 3309 may be an atom if the autoload entry was generated by a defalias | |
| 3310 or fset. */ | |
| 3311 if (CONSP (second)) | |
| 3312 Fput (first, Qautoload, (XCDR (second))); | |
| 3313 } | |
| 3314 } | |
| 3315 | |
| 3316 /* Once loading finishes, don't undo it. */ | |
| 3317 Vautoload_queue = Qt; | |
| 771 | 3318 unbind_to (speccount); |
| 428 | 3319 |
| 3320 fun = indirect_function (fun, 0); | |
| 3321 | |
| 3322 #if 0 /* FSFmacs */ | |
| 3323 if (!NILP (Fequal (fun, fundef))) | |
| 3324 #else | |
| 3325 if (UNBOUNDP (fun) | |
| 3326 || (CONSP (fun) | |
| 3327 && EQ (XCAR (fun), Qautoload))) | |
| 3328 #endif | |
| 563 | 3329 invalid_state ("Autoloading failed to define function", funname); |
| 428 | 3330 UNGCPRO; |
| 3331 } | |
| 3332 | |
| 3333 | |
| 3334 /************************************************************************/ | |
| 3335 /* eval, funcall, apply */ | |
| 3336 /************************************************************************/ | |
| 3337 | |
| 814 | 3338 /* NOTE: If you are hearing the endless complaint that function calls in |
| 3339 elisp are extremely slow, it just isn't true any more! The stuff below | |
| 3340 -- in particular, the calling of subrs and compiled functions, the most | |
| 3341 common cases -- has been highly optimized. There isn't a whole lot left | |
| 3342 to do to squeeze more speed out except by switching to lexical | |
| 3343 variables, which would eliminate the specbind loop. (But the real gain | |
| 3344 from lexical variables would come from better optimization -- with | |
| 3345 dynamic binding, you have the constant problem that any function call | |
| 3346 that you haven't explicitly proven to be side-effect-free might | |
| 3347 potentially side effect your local variables, which makes optimization | |
| 3348 extremely difficult when there are function calls anywhere in a chunk of | |
| 3349 code to be optimized. Even worse, you don't know that *your* local | |
| 3350 variables aren't side-effecting an outer function's local variables, so | |
| 3351 it's impossible to optimize away almost *any* variable assignment.) */ | |
| 3352 | |
| 428 | 3353 static Lisp_Object funcall_lambda (Lisp_Object fun, |
| 442 | 3354 int nargs, Lisp_Object args[]); |
| 428 | 3355 static int in_warnings; |
| 3356 | |
| 3357 | |
| 814 | 3358 void handle_compiled_function_with_and_rest (Lisp_Compiled_Function *f, |
| 3359 int nargs, | |
| 3360 Lisp_Object args[]); | |
| 3361 | |
| 3362 /* The theory behind making this a separate function is to shrink | |
| 3363 funcall_compiled_function() so as to increase the likelihood of a cache | |
| 3364 hit in the L1 cache -- &rest processing is not going to be fast anyway. | |
| 3365 The idea is the same as with execute_rare_opcode() in bytecode.c. We | |
| 3366 make this non-static to ensure the compiler doesn't inline it. */ | |
| 3367 | |
| 3368 void | |
| 3369 handle_compiled_function_with_and_rest (Lisp_Compiled_Function *f, int nargs, | |
| 3370 Lisp_Object args[]) | |
| 3371 { | |
| 3372 REGISTER int i = 0; | |
| 3373 int max_non_rest_args = f->args_in_array - 1; | |
| 3374 int bindargs = min (nargs, max_non_rest_args); | |
| 3375 | |
| 3376 for (i = 0; i < bindargs; i++) | |
| 3092 | 3377 #ifdef NEW_GC |
| 3378 SPECBIND_FAST_UNSAFE (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i], | |
| 3379 args[i]); | |
| 3380 #else /* not NEW_GC */ | |
| 814 | 3381 SPECBIND_FAST_UNSAFE (f->args[i], args[i]); |
| 3092 | 3382 #endif /* not NEW_GC */ |
| 814 | 3383 for (i = bindargs; i < max_non_rest_args; i++) |
| 3092 | 3384 #ifdef NEW_GC |
| 3385 SPECBIND_FAST_UNSAFE (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i], | |
| 3386 Qnil); | |
| 3387 #else /* not NEW_GC */ | |
| 814 | 3388 SPECBIND_FAST_UNSAFE (f->args[i], Qnil); |
| 3092 | 3389 #endif /* not NEW_GC */ |
| 3390 #ifdef NEW_GC | |
| 3391 SPECBIND_FAST_UNSAFE | |
| 3392 (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[max_non_rest_args], | |
| 3393 nargs > max_non_rest_args ? | |
| 3394 Flist (nargs - max_non_rest_args, &args[max_non_rest_args]) : | |
| 3395 Qnil); | |
| 3396 #else /* not NEW_GC */ | |
| 814 | 3397 SPECBIND_FAST_UNSAFE |
| 3398 (f->args[max_non_rest_args], | |
| 3399 nargs > max_non_rest_args ? | |
| 3400 Flist (nargs - max_non_rest_args, &args[max_non_rest_args]) : | |
| 3401 Qnil); | |
| 3092 | 3402 #endif /* not NEW_GC */ |
| 814 | 3403 } |
| 3404 | |
| 3405 /* Apply compiled-function object FUN to the NARGS evaluated arguments | |
| 3406 in ARGS, and return the result of evaluation. */ | |
| 3407 inline static Lisp_Object | |
| 3408 funcall_compiled_function (Lisp_Object fun, int nargs, Lisp_Object args[]) | |
| 3409 { | |
| 3410 /* This function can GC */ | |
| 3411 int speccount = specpdl_depth(); | |
| 3412 REGISTER int i = 0; | |
| 3413 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun); | |
| 3414 | |
| 3415 if (!OPAQUEP (f->instructions)) | |
| 3416 /* Lazily munge the instructions into a more efficient form */ | |
| 3417 optimize_compiled_function (fun); | |
| 3418 | |
| 3419 /* optimize_compiled_function() guaranteed that f->specpdl_depth is | |
| 3420 the required space on the specbinding stack for binding the args | |
| 3421 and local variables of fun. So just reserve it once. */ | |
| 3422 SPECPDL_RESERVE (f->specpdl_depth); | |
| 3423 | |
| 3424 if (nargs == f->max_args) /* Optimize for the common case -- no unspecified | |
| 3425 optional arguments. */ | |
| 3426 { | |
| 3427 #if 1 | |
| 3428 for (i = 0; i < nargs; i++) | |
| 3092 | 3429 #ifdef NEW_GC |
| 3430 SPECBIND_FAST_UNSAFE (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i], | |
| 3431 args[i]); | |
| 3432 #else /* not NEW_GC */ | |
| 814 | 3433 SPECBIND_FAST_UNSAFE (f->args[i], args[i]); |
| 3092 | 3434 #endif /* not NEW_GC */ |
| 814 | 3435 #else |
| 3436 /* Here's an alternate way to write the loop that tries to further | |
| 3437 optimize funcalls for functions with few arguments by partially | |
| 3438 unrolling the loop. It's not clear whether this is a win since it | |
| 3439 increases the size of the function and the possibility of L1 cache | |
| 3440 misses. (Microsoft VC++ 6 with /O2 /G5 generates 0x90 == 144 bytes | |
| 3441 per SPECBIND_FAST_UNSAFE().) Tests under VC++ 6, running the byte | |
| 3442 compiler repeatedly and looking at the total time, show very | |
| 3443 little difference between the simple loop above, the unrolled code | |
| 3444 below, and a "partly unrolled" solution with only cases 0-2 below | |
| 3445 instead of 0-4. Therefore, I'm keeping it at the simple loop | |
| 3446 because it's smaller. */ | |
| 3447 switch (nargs) | |
| 3448 { | |
| 3449 default: | |
| 3450 for (i = nargs - 1; i >= 4; i--) | |
| 3451 SPECBIND_FAST_UNSAFE (f->args[i], args[i]); | |
| 3452 case 4: SPECBIND_FAST_UNSAFE (f->args[3], args[3]); | |
| 3453 case 3: SPECBIND_FAST_UNSAFE (f->args[2], args[2]); | |
| 3454 case 2: SPECBIND_FAST_UNSAFE (f->args[1], args[1]); | |
| 3455 case 1: SPECBIND_FAST_UNSAFE (f->args[0], args[0]); | |
| 3456 case 0: break; | |
| 3457 } | |
| 3458 #endif | |
| 3459 } | |
| 3460 else if (nargs < f->min_args) | |
| 3461 goto wrong_number_of_arguments; | |
| 3462 else if (nargs < f->max_args) | |
| 3463 { | |
| 3464 for (i = 0; i < nargs; i++) | |
| 3092 | 3465 #ifdef NEW_GC |
| 3466 SPECBIND_FAST_UNSAFE (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i], | |
| 3467 args[i]); | |
| 3468 #else /* not NEW_GC */ | |
| 814 | 3469 SPECBIND_FAST_UNSAFE (f->args[i], args[i]); |
| 3092 | 3470 #endif /* not NEW_GC */ |
| 814 | 3471 for (i = nargs; i < f->max_args; i++) |
| 3092 | 3472 #ifdef NEW_GC |
| 3473 SPECBIND_FAST_UNSAFE (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i], | |
| 3474 Qnil); | |
| 3475 #else /* not NEW_GC */ | |
| 814 | 3476 SPECBIND_FAST_UNSAFE (f->args[i], Qnil); |
| 3092 | 3477 #endif /* not NEW_GC */ |
| 814 | 3478 } |
| 3479 else if (f->max_args == MANY) | |
| 3480 handle_compiled_function_with_and_rest (f, nargs, args); | |
| 3481 else | |
| 3482 { | |
| 3483 wrong_number_of_arguments: | |
| 3484 /* The actual printed compiled_function object is incomprehensible. | |
| 3485 Check the backtrace to see if we can get a more meaningful symbol. */ | |
| 3486 if (EQ (fun, indirect_function (*backtrace_list->function, 0))) | |
| 3487 fun = *backtrace_list->function; | |
| 3488 return Fsignal (Qwrong_number_of_arguments, | |
| 3489 list2 (fun, make_int (nargs))); | |
| 3490 } | |
| 3491 | |
| 3492 { | |
| 3493 Lisp_Object value = | |
| 3494 execute_optimized_program ((Opbyte *) XOPAQUE_DATA (f->instructions), | |
| 3495 f->stack_depth, | |
| 3496 XVECTOR_DATA (f->constants)); | |
| 3497 | |
| 3498 /* The attempt to optimize this by only unbinding variables failed | |
| 3499 because using buffer-local variables as function parameters | |
| 3500 leads to specpdl_ptr->func != 0 */ | |
| 3501 /* UNBIND_TO_GCPRO_VARIABLES_ONLY (speccount, value); */ | |
| 3502 UNBIND_TO_GCPRO (speccount, value); | |
| 3503 return value; | |
| 3504 } | |
| 3505 } | |
| 3506 | |
| 428 | 3507 DEFUN ("eval", Feval, 1, 1, 0, /* |
| 3508 Evaluate FORM and return its value. | |
| 3509 */ | |
| 3510 (form)) | |
| 3511 { | |
| 3512 /* This function can GC */ | |
| 3513 Lisp_Object fun, val, original_fun, original_args; | |
| 3514 int nargs; | |
| 4162 | 3515 PROFILE_DECLARE(); |
| 428 | 3516 |
| 1318 | 3517 #ifdef ERROR_CHECK_TRAPPING_PROBLEMS |
| 3518 check_proper_critical_section_lisp_protection (); | |
| 3519 #endif | |
| 3520 | |
| 3989 | 3521 if (!CONSP (form)) |
| 3522 { | |
| 3523 if (SYMBOLP (form)) | |
| 3524 { | |
| 3525 return Fsymbol_value (form); | |
| 3526 } | |
| 3527 | |
| 3528 return form; | |
| 3529 } | |
| 3530 | |
| 428 | 3531 /* I think this is a pretty safe place to call Lisp code, don't you? */ |
| 853 | 3532 while (!in_warnings && !NILP (Vpending_warnings) |
| 3533 /* well, perhaps not so safe after all! */ | |
| 3534 && !(inhibit_flags & INHIBIT_ANY_CHANGE_AFFECTING_REDISPLAY)) | |
| 428 | 3535 { |
| 3536 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; | |
| 1204 | 3537 Lisp_Object this_warning_cons, this_warning, class_, level, messij; |
| 853 | 3538 int speccount = internal_bind_int (&in_warnings, 1); |
| 3539 | |
| 428 | 3540 this_warning_cons = Vpending_warnings; |
| 3541 this_warning = XCAR (this_warning_cons); | |
| 3542 /* in case an error occurs in the warn function, at least | |
| 3543 it won't happen infinitely */ | |
| 3544 Vpending_warnings = XCDR (Vpending_warnings); | |
| 853 | 3545 free_cons (this_warning_cons); |
| 1204 | 3546 class_ = XCAR (this_warning); |
| 428 | 3547 level = XCAR (XCDR (this_warning)); |
| 3548 messij = XCAR (XCDR (XCDR (this_warning))); | |
| 3549 free_list (this_warning); | |
| 3550 | |
| 3551 if (NILP (Vpending_warnings)) | |
| 3552 Vpending_warnings_tail = Qnil; /* perhaps not strictly necessary, | |
| 3553 but safer */ | |
| 3554 | |
| 1204 | 3555 GCPRO4 (form, class_, level, messij); |
| 428 | 3556 if (!STRINGP (messij)) |
| 3557 messij = Fprin1_to_string (messij, Qnil); | |
| 1204 | 3558 call3 (Qdisplay_warning, class_, messij, level); |
| 428 | 3559 UNGCPRO; |
| 771 | 3560 unbind_to (speccount); |
| 428 | 3561 } |
| 3562 | |
| 3563 QUIT; | |
| 814 | 3564 if (need_to_garbage_collect) |
| 428 | 3565 { |
| 3566 struct gcpro gcpro1; | |
| 3567 GCPRO1 (form); | |
| 3092 | 3568 #ifdef NEW_GC |
| 3569 gc_incremental (); | |
| 3570 #else /* not NEW_GC */ | |
| 428 | 3571 garbage_collect_1 (); |
| 3092 | 3572 #endif /* not NEW_GC */ |
| 428 | 3573 UNGCPRO; |
| 3574 } | |
| 3575 | |
| 3576 if (++lisp_eval_depth > max_lisp_eval_depth) | |
| 3577 { | |
| 3578 if (max_lisp_eval_depth < 100) | |
| 3579 max_lisp_eval_depth = 100; | |
| 3580 if (lisp_eval_depth > max_lisp_eval_depth) | |
| 563 | 3581 stack_overflow ("Lisp nesting exceeds `max-lisp-eval-depth'", |
| 3582 Qunbound); | |
| 428 | 3583 } |
| 3584 | |
| 3585 /* We guaranteed CONSP (form) above */ | |
| 3586 original_fun = XCAR (form); | |
| 3587 original_args = XCDR (form); | |
| 3588 | |
| 3589 GET_EXTERNAL_LIST_LENGTH (original_args, nargs); | |
| 3590 | |
| 3591 backtrace.pdlcount = specpdl_depth(); | |
| 3592 backtrace.function = &original_fun; /* This also protects them from gc */ | |
| 3593 backtrace.args = &original_args; | |
| 3594 backtrace.nargs = UNEVALLED; | |
| 3595 backtrace.evalargs = 1; | |
| 3596 backtrace.debug_on_exit = 0; | |
| 1292 | 3597 backtrace.function_being_called = 0; |
| 428 | 3598 PUSH_BACKTRACE (backtrace); |
| 3599 | |
| 3600 if (debug_on_next_call) | |
| 3601 do_debug_on_call (Qt); | |
| 3602 | |
| 3603 /* At this point, only original_fun and original_args | |
| 3604 have values that will be used below. */ | |
| 3605 retry: | |
| 3989 | 3606 /* Optimise for no indirection. */ |
| 3607 fun = original_fun; | |
| 3608 if (SYMBOLP (fun) && !EQ (fun, Qunbound) | |
| 3609 && (fun = XSYMBOL (fun)->function, SYMBOLP (fun))) | |
| 3610 { | |
| 3611 fun = indirect_function(original_fun, 1); | |
| 3612 } | |
| 428 | 3613 |
| 3614 if (SUBRP (fun)) | |
| 3615 { | |
| 3616 Lisp_Subr *subr = XSUBR (fun); | |
| 3617 int max_args = subr->max_args; | |
| 3618 | |
| 3619 if (nargs < subr->min_args) | |
| 3620 goto wrong_number_of_arguments; | |
| 3621 | |
| 3622 if (max_args == UNEVALLED) /* Optimize for the common case */ | |
| 3623 { | |
| 3624 backtrace.evalargs = 0; | |
| 1292 | 3625 PROFILE_ENTER_FUNCTION (); |
| 428 | 3626 val = (((Lisp_Object (*) (Lisp_Object)) subr_function (subr)) |
| 3627 (original_args)); | |
| 1292 | 3628 PROFILE_EXIT_FUNCTION (); |
| 428 | 3629 } |
| 3630 else if (nargs <= max_args) | |
| 3631 { | |
| 3632 struct gcpro gcpro1; | |
| 3633 Lisp_Object args[SUBR_MAX_ARGS]; | |
| 3634 REGISTER Lisp_Object *p = args; | |
| 3635 | |
| 3636 GCPRO1 (args[0]); | |
| 3637 gcpro1.nvars = 0; | |
| 3638 | |
| 3639 { | |
| 3640 LIST_LOOP_2 (arg, original_args) | |
| 3641 { | |
| 3642 *p++ = Feval (arg); | |
| 3643 gcpro1.nvars++; | |
| 3644 } | |
| 3645 } | |
| 3646 | |
| 3647 /* &optional args default to nil. */ | |
| 3648 while (p - args < max_args) | |
| 3649 *p++ = Qnil; | |
| 3650 | |
| 3651 backtrace.args = args; | |
| 3652 backtrace.nargs = nargs; | |
| 3653 | |
| 1292 | 3654 PROFILE_ENTER_FUNCTION (); |
| 428 | 3655 FUNCALL_SUBR (val, subr, args, max_args); |
| 1292 | 3656 PROFILE_EXIT_FUNCTION (); |
| 428 | 3657 |
| 3658 UNGCPRO; | |
| 3659 } | |
| 3660 else if (max_args == MANY) | |
| 3661 { | |
| 3662 /* Pass a vector of evaluated arguments */ | |
| 3663 struct gcpro gcpro1; | |
| 3664 Lisp_Object *args = alloca_array (Lisp_Object, nargs); | |
| 3665 REGISTER Lisp_Object *p = args; | |
| 3666 | |
| 3667 GCPRO1 (args[0]); | |
| 3668 gcpro1.nvars = 0; | |
| 3669 | |
| 3670 { | |
| 3671 LIST_LOOP_2 (arg, original_args) | |
| 3672 { | |
| 3673 *p++ = Feval (arg); | |
| 3674 gcpro1.nvars++; | |
| 3675 } | |
| 3676 } | |
| 3677 | |
| 3678 backtrace.args = args; | |
| 3679 backtrace.nargs = nargs; | |
| 3680 | |
| 1292 | 3681 PROFILE_ENTER_FUNCTION (); |
| 428 | 3682 val = (((Lisp_Object (*) (int, Lisp_Object *)) subr_function (subr)) |
| 3683 (nargs, args)); | |
| 1292 | 3684 PROFILE_EXIT_FUNCTION (); |
| 428 | 3685 |
| 3686 UNGCPRO; | |
| 3687 } | |
| 3688 else | |
| 3689 { | |
| 3690 wrong_number_of_arguments: | |
| 440 | 3691 val = signal_wrong_number_of_arguments_error (original_fun, nargs); |
| 428 | 3692 } |
| 3693 } | |
| 3694 else if (COMPILED_FUNCTIONP (fun)) | |
| 3695 { | |
| 3696 struct gcpro gcpro1; | |
| 3697 Lisp_Object *args = alloca_array (Lisp_Object, nargs); | |
| 3698 REGISTER Lisp_Object *p = args; | |
| 3699 | |
| 3700 GCPRO1 (args[0]); | |
| 3701 gcpro1.nvars = 0; | |
| 3702 | |
| 3703 { | |
| 3704 LIST_LOOP_2 (arg, original_args) | |
| 3705 { | |
| 3706 *p++ = Feval (arg); | |
| 3707 gcpro1.nvars++; | |
| 3708 } | |
| 3709 } | |
| 3710 | |
| 3711 backtrace.args = args; | |
| 3712 backtrace.nargs = nargs; | |
| 3713 backtrace.evalargs = 0; | |
| 3714 | |
| 1292 | 3715 PROFILE_ENTER_FUNCTION (); |
| 428 | 3716 val = funcall_compiled_function (fun, nargs, args); |
| 1292 | 3717 PROFILE_EXIT_FUNCTION (); |
| 428 | 3718 |
| 3719 /* Do the debug-on-exit now, while args is still GCPROed. */ | |
| 3720 if (backtrace.debug_on_exit) | |
| 3721 val = do_debug_on_exit (val); | |
| 3722 /* Don't do it again when we return to eval. */ | |
| 3723 backtrace.debug_on_exit = 0; | |
| 3724 | |
| 3725 UNGCPRO; | |
| 3726 } | |
| 3727 else if (CONSP (fun)) | |
| 3728 { | |
| 3729 Lisp_Object funcar = XCAR (fun); | |
| 3730 | |
| 3731 if (EQ (funcar, Qautoload)) | |
| 3732 { | |
| 970 | 3733 /* do_autoload GCPROs both arguments */ |
| 428 | 3734 do_autoload (fun, original_fun); |
| 3735 goto retry; | |
| 3736 } | |
| 3737 else if (EQ (funcar, Qmacro)) | |
| 3738 { | |
| 1292 | 3739 PROFILE_ENTER_FUNCTION (); |
| 428 | 3740 val = Feval (apply1 (XCDR (fun), original_args)); |
| 1292 | 3741 PROFILE_EXIT_FUNCTION (); |
| 428 | 3742 } |
| 3743 else if (EQ (funcar, Qlambda)) | |
| 3744 { | |
| 3745 struct gcpro gcpro1; | |
| 3746 Lisp_Object *args = alloca_array (Lisp_Object, nargs); | |
| 3747 REGISTER Lisp_Object *p = args; | |
| 3748 | |
| 3749 GCPRO1 (args[0]); | |
| 3750 gcpro1.nvars = 0; | |
| 3751 | |
| 3752 { | |
| 3753 LIST_LOOP_2 (arg, original_args) | |
| 3754 { | |
| 3755 *p++ = Feval (arg); | |
| 3756 gcpro1.nvars++; | |
| 3757 } | |
| 3758 } | |
| 3759 | |
| 3760 UNGCPRO; | |
| 3761 | |
| 3762 backtrace.args = args; /* this also GCPROs `args' */ | |
| 3763 backtrace.nargs = nargs; | |
| 3764 backtrace.evalargs = 0; | |
| 3765 | |
| 1292 | 3766 PROFILE_ENTER_FUNCTION (); |
| 428 | 3767 val = funcall_lambda (fun, nargs, args); |
| 1292 | 3768 PROFILE_EXIT_FUNCTION (); |
| 428 | 3769 |
| 3770 /* Do the debug-on-exit now, while args is still GCPROed. */ | |
| 3771 if (backtrace.debug_on_exit) | |
| 3772 val = do_debug_on_exit (val); | |
| 3773 /* Don't do it again when we return to eval. */ | |
| 3774 backtrace.debug_on_exit = 0; | |
| 3775 } | |
| 3776 else | |
| 3777 { | |
| 3778 goto invalid_function; | |
| 3779 } | |
| 3780 } | |
| 4104 | 3781 else if (UNBOUNDP (fun)) |
| 3782 { | |
| 3783 val = signal_void_function_error (original_fun); | |
| 3784 } | |
| 3785 else /* ! (SUBRP (fun) || COMPILED_FUNCTIONP (fun) || CONSP (fun) | |
| 3786 UNBOUNDP (fun)) */ | |
| 428 | 3787 { |
| 3788 invalid_function: | |
| 436 | 3789 val = signal_invalid_function_error (fun); |
| 428 | 3790 } |
| 3791 | |
| 3792 lisp_eval_depth--; | |
| 3793 if (backtrace.debug_on_exit) | |
| 3794 val = do_debug_on_exit (val); | |
| 3795 POP_BACKTRACE (backtrace); | |
| 3796 return val; | |
| 3797 } | |
| 3798 | |
| 3799 | |
| 1111 | 3800 |
| 3801 static void | |
| 3802 run_post_gc_hook (void) | |
| 3803 { | |
| 3804 Lisp_Object args[2]; | |
| 3805 | |
| 3806 args[0] = Qpost_gc_hook; | |
| 3807 args[1] = Fcons (Fcons (Qfinalize_list, zap_finalize_list ()), Qnil); | |
| 3808 | |
| 3809 run_hook_with_args_trapping_problems | |
| 1333 | 3810 (Qgarbage_collecting, 2, args, RUN_HOOKS_TO_COMPLETION, |
| 1111 | 3811 INHIBIT_QUIT | NO_INHIBIT_ERRORS); |
| 3812 } | |
| 3813 | |
| 428 | 3814 DEFUN ("funcall", Ffuncall, 1, MANY, 0, /* |
| 3815 Call first argument as a function, passing the remaining arguments to it. | |
| 3816 Thus, (funcall 'cons 'x 'y) returns (x . y). | |
| 3817 */ | |
| 3818 (int nargs, Lisp_Object *args)) | |
| 3819 { | |
| 3820 /* This function can GC */ | |
| 3821 Lisp_Object fun; | |
| 3822 Lisp_Object val; | |
| 4162 | 3823 PROFILE_DECLARE(); |
| 428 | 3824 int fun_nargs = nargs - 1; |
| 3825 Lisp_Object *fun_args = args + 1; | |
| 3826 | |
| 1318 | 3827 /* QUIT will check for proper redisplay wrapping */ |
| 3828 | |
| 428 | 3829 QUIT; |
| 851 | 3830 |
| 3831 if (funcall_allocation_flag) | |
| 3832 { | |
| 3833 if (need_to_garbage_collect) | |
| 3834 /* Callers should gcpro lexpr args */ | |
| 3092 | 3835 #ifdef NEW_GC |
| 3836 gc_incremental (); | |
| 3837 #else /* not NEW_GC */ | |
| 851 | 3838 garbage_collect_1 (); |
| 3092 | 3839 #endif /* not NEW_GC */ |
| 851 | 3840 if (need_to_check_c_alloca) |
| 3841 { | |
| 3842 if (++funcall_alloca_count >= MAX_FUNCALLS_BETWEEN_ALLOCA_CLEANUP) | |
| 3843 { | |
| 3844 xemacs_c_alloca (0); | |
| 3845 funcall_alloca_count = 0; | |
| 3846 } | |
| 3847 } | |
| 887 | 3848 if (need_to_signal_post_gc) |
| 3849 { | |
| 3850 need_to_signal_post_gc = 0; | |
| 1111 | 3851 recompute_funcall_allocation_flag (); |
| 3263 | 3852 #ifdef NEW_GC |
| 3853 run_finalizers (); | |
| 3854 #endif /* NEW_GC */ | |
| 1111 | 3855 run_post_gc_hook (); |
| 887 | 3856 } |
| 851 | 3857 } |
| 428 | 3858 |
| 3859 if (++lisp_eval_depth > max_lisp_eval_depth) | |
| 3860 { | |
| 3861 if (max_lisp_eval_depth < 100) | |
| 3862 max_lisp_eval_depth = 100; | |
| 3863 if (lisp_eval_depth > max_lisp_eval_depth) | |
| 563 | 3864 stack_overflow ("Lisp nesting exceeds `max-lisp-eval-depth'", |
| 3865 Qunbound); | |
| 428 | 3866 } |
| 3867 | |
| 1292 | 3868 backtrace.pdlcount = specpdl_depth (); |
| 428 | 3869 backtrace.function = &args[0]; |
| 3870 backtrace.args = fun_args; | |
| 3871 backtrace.nargs = fun_nargs; | |
| 3872 backtrace.evalargs = 0; | |
| 3873 backtrace.debug_on_exit = 0; | |
| 1292 | 3874 backtrace.function_being_called = 0; |
| 428 | 3875 PUSH_BACKTRACE (backtrace); |
| 3876 | |
| 3877 if (debug_on_next_call) | |
| 3878 do_debug_on_call (Qlambda); | |
| 3879 | |
| 3880 retry: | |
| 3881 | |
| 3882 fun = args[0]; | |
| 3883 | |
| 3884 /* We could call indirect_function directly, but profiling shows | |
| 3885 this is worth optimizing by partially unrolling the loop. */ | |
| 3886 if (SYMBOLP (fun)) | |
| 3887 { | |
| 3888 fun = XSYMBOL (fun)->function; | |
| 3889 if (SYMBOLP (fun)) | |
| 3890 { | |
| 3891 fun = XSYMBOL (fun)->function; | |
| 3892 if (SYMBOLP (fun)) | |
| 3893 fun = indirect_function (fun, 1); | |
| 3894 } | |
| 3895 } | |
| 3896 | |
| 3897 if (SUBRP (fun)) | |
| 3898 { | |
| 3899 Lisp_Subr *subr = XSUBR (fun); | |
| 3900 int max_args = subr->max_args; | |
| 3901 Lisp_Object spacious_args[SUBR_MAX_ARGS]; | |
| 3902 | |
| 3903 if (fun_nargs == max_args) /* Optimize for the common case */ | |
| 3904 { | |
| 3905 funcall_subr: | |
| 1292 | 3906 PROFILE_ENTER_FUNCTION (); |
| 428 | 3907 FUNCALL_SUBR (val, subr, fun_args, max_args); |
| 1292 | 3908 PROFILE_EXIT_FUNCTION (); |
| 428 | 3909 } |
| 436 | 3910 else if (fun_nargs < subr->min_args) |
| 3911 { | |
| 3912 goto wrong_number_of_arguments; | |
| 3913 } | |
| 428 | 3914 else if (fun_nargs < max_args) |
| 3915 { | |
| 3916 Lisp_Object *p = spacious_args; | |
| 3917 | |
| 3918 /* Default optionals to nil */ | |
| 3919 while (fun_nargs--) | |
| 3920 *p++ = *fun_args++; | |
| 3921 while (p - spacious_args < max_args) | |
| 3922 *p++ = Qnil; | |
| 3923 | |
| 3924 fun_args = spacious_args; | |
| 3925 goto funcall_subr; | |
| 3926 } | |
| 3927 else if (max_args == MANY) | |
| 3928 { | |
| 1292 | 3929 PROFILE_ENTER_FUNCTION (); |
| 436 | 3930 val = SUBR_FUNCTION (subr, MANY) (fun_nargs, fun_args); |
| 1292 | 3931 PROFILE_EXIT_FUNCTION (); |
| 428 | 3932 } |
| 3933 else if (max_args == UNEVALLED) /* Can't funcall a special form */ | |
| 3934 { | |
| 3935 goto invalid_function; | |
| 3936 } | |
| 3937 else | |
| 3938 { | |
| 3939 wrong_number_of_arguments: | |
| 436 | 3940 val = signal_wrong_number_of_arguments_error (fun, fun_nargs); |
| 428 | 3941 } |
| 3942 } | |
| 3943 else if (COMPILED_FUNCTIONP (fun)) | |
| 3944 { | |
| 1292 | 3945 PROFILE_ENTER_FUNCTION (); |
| 428 | 3946 val = funcall_compiled_function (fun, fun_nargs, fun_args); |
| 1292 | 3947 PROFILE_EXIT_FUNCTION (); |
| 428 | 3948 } |
| 3949 else if (CONSP (fun)) | |
| 3950 { | |
| 3951 Lisp_Object funcar = XCAR (fun); | |
| 3952 | |
| 3953 if (EQ (funcar, Qlambda)) | |
| 3954 { | |
| 1292 | 3955 PROFILE_ENTER_FUNCTION (); |
| 428 | 3956 val = funcall_lambda (fun, fun_nargs, fun_args); |
| 1292 | 3957 PROFILE_EXIT_FUNCTION (); |
| 428 | 3958 } |
| 3959 else if (EQ (funcar, Qautoload)) | |
| 3960 { | |
| 970 | 3961 /* do_autoload GCPROs both arguments */ |
| 428 | 3962 do_autoload (fun, args[0]); |
| 3963 goto retry; | |
| 3964 } | |
| 3965 else /* Can't funcall a macro */ | |
| 3966 { | |
| 3967 goto invalid_function; | |
| 3968 } | |
| 3969 } | |
| 3970 else if (UNBOUNDP (fun)) | |
| 3971 { | |
| 436 | 3972 val = signal_void_function_error (args[0]); |
| 428 | 3973 } |
| 3974 else | |
| 3975 { | |
| 3976 invalid_function: | |
| 436 | 3977 val = signal_invalid_function_error (fun); |
| 428 | 3978 } |
| 3979 | |
| 3980 lisp_eval_depth--; | |
| 3981 if (backtrace.debug_on_exit) | |
| 3982 val = do_debug_on_exit (val); | |
| 3983 POP_BACKTRACE (backtrace); | |
| 3984 return val; | |
| 3985 } | |
| 3986 | |
| 3987 DEFUN ("functionp", Ffunctionp, 1, 1, 0, /* | |
| 3988 Return t if OBJECT can be called as a function, else nil. | |
| 3989 A function is an object that can be applied to arguments, | |
| 3990 using for example `funcall' or `apply'. | |
| 3991 */ | |
| 3992 (object)) | |
| 3993 { | |
| 3994 if (SYMBOLP (object)) | |
| 3995 object = indirect_function (object, 0); | |
| 3996 | |
| 919 | 3997 if (COMPILED_FUNCTIONP (object) || SUBRP (object)) |
| 3998 return Qt; | |
| 3999 if (CONSP (object)) | |
| 4000 { | |
| 4001 Lisp_Object car = XCAR (object); | |
| 4002 if (EQ (car, Qlambda)) | |
| 4003 return Qt; | |
| 4004 if (EQ (car, Qautoload) | |
| 4005 && NILP (Fcar_safe (Fcdr_safe (Fcdr_safe (Fcdr_safe (XCDR (object))))))) | |
| 4006 return Qt; | |
| 4007 } | |
| 4008 return Qnil; | |
| 428 | 4009 } |
| 4010 | |
| 4011 static Lisp_Object | |
| 4012 function_argcount (Lisp_Object function, int function_min_args_p) | |
| 4013 { | |
| 4014 Lisp_Object orig_function = function; | |
| 4015 Lisp_Object arglist; | |
| 4016 | |
| 4017 retry: | |
| 4018 | |
| 4019 if (SYMBOLP (function)) | |
| 4020 function = indirect_function (function, 1); | |
| 4021 | |
| 4022 if (SUBRP (function)) | |
| 4023 { | |
| 442 | 4024 /* Using return with the ?: operator tickles a DEC CC compiler bug. */ |
| 4025 if (function_min_args_p) | |
| 4026 return Fsubr_min_args (function); | |
| 4027 else | |
| 4028 return Fsubr_max_args (function); | |
| 428 | 4029 } |
| 4030 else if (COMPILED_FUNCTIONP (function)) | |
| 4031 { | |
| 814 | 4032 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (function); |
| 4033 | |
| 1737 | 4034 if (!OPAQUEP (f->instructions)) |
| 4035 /* Lazily munge the instructions into a more efficient form */ | |
| 4036 /* Needed to set max_args */ | |
| 4037 optimize_compiled_function (function); | |
| 4038 | |
| 814 | 4039 if (function_min_args_p) |
| 4040 return make_int (f->min_args); | |
| 4041 else if (f->max_args == MANY) | |
| 4042 return Qnil; | |
| 4043 else | |
| 4044 return make_int (f->max_args); | |
| 428 | 4045 } |
| 4046 else if (CONSP (function)) | |
| 4047 { | |
| 4048 Lisp_Object funcar = XCAR (function); | |
| 4049 | |
| 4050 if (EQ (funcar, Qmacro)) | |
| 4051 { | |
| 4052 function = XCDR (function); | |
| 4053 goto retry; | |
| 4054 } | |
| 4055 else if (EQ (funcar, Qautoload)) | |
| 4056 { | |
| 970 | 4057 /* do_autoload GCPROs both arguments */ |
| 428 | 4058 do_autoload (function, orig_function); |
| 442 | 4059 function = orig_function; |
| 428 | 4060 goto retry; |
| 4061 } | |
| 4062 else if (EQ (funcar, Qlambda)) | |
| 4063 { | |
| 4064 arglist = Fcar (XCDR (function)); | |
| 4065 } | |
| 4066 else | |
| 4067 { | |
| 4068 goto invalid_function; | |
| 4069 } | |
| 4070 } | |
| 4071 else | |
| 4072 { | |
| 4073 invalid_function: | |
| 442 | 4074 return signal_invalid_function_error (orig_function); |
| 428 | 4075 } |
| 4076 | |
| 4077 { | |
| 4078 int argcount = 0; | |
| 4079 | |
| 4080 EXTERNAL_LIST_LOOP_2 (arg, arglist) | |
| 4081 { | |
| 4082 if (EQ (arg, Qand_optional)) | |
| 4083 { | |
| 4084 if (function_min_args_p) | |
| 4085 break; | |
| 4086 } | |
| 4087 else if (EQ (arg, Qand_rest)) | |
| 4088 { | |
| 4089 if (function_min_args_p) | |
| 4090 break; | |
| 4091 else | |
| 4092 return Qnil; | |
| 4093 } | |
| 4094 else | |
| 4095 { | |
| 4096 argcount++; | |
| 4097 } | |
| 4098 } | |
| 4099 | |
| 4100 return make_int (argcount); | |
| 4101 } | |
| 4102 } | |
| 4103 | |
| 4104 DEFUN ("function-min-args", Ffunction_min_args, 1, 1, 0, /* | |
| 617 | 4105 Return the minimum number of arguments a function may be called with. |
| 428 | 4106 The function may be any form that can be passed to `funcall', |
| 4107 any special form, or any macro. | |
| 853 | 4108 |
| 4109 To check if a function can be called with a specified number of | |
| 4110 arguments, use `function-allows-args'. | |
| 428 | 4111 */ |
| 4112 (function)) | |
| 4113 { | |
| 4114 return function_argcount (function, 1); | |
| 4115 } | |
| 4116 | |
| 4117 DEFUN ("function-max-args", Ffunction_max_args, 1, 1, 0, /* | |
| 617 | 4118 Return the maximum number of arguments a function may be called with. |
| 428 | 4119 The function may be any form that can be passed to `funcall', |
| 4120 any special form, or any macro. | |
| 4121 If the function takes an arbitrary number of arguments or is | |
| 4122 a built-in special form, nil is returned. | |
| 853 | 4123 |
| 4124 To check if a function can be called with a specified number of | |
| 4125 arguments, use `function-allows-args'. | |
| 428 | 4126 */ |
| 4127 (function)) | |
| 4128 { | |
| 4129 return function_argcount (function, 0); | |
| 4130 } | |
| 4131 | |
| 4132 | |
| 4133 DEFUN ("apply", Fapply, 2, MANY, 0, /* | |
| 4134 Call FUNCTION with the remaining args, using the last arg as a list of args. | |
| 4135 Thus, (apply '+ 1 2 '(3 4)) returns 10. | |
| 4136 */ | |
| 4137 (int nargs, Lisp_Object *args)) | |
| 4138 { | |
| 4139 /* This function can GC */ | |
| 4140 Lisp_Object fun = args[0]; | |
| 4141 Lisp_Object spread_arg = args [nargs - 1]; | |
| 4142 int numargs; | |
| 4143 int funcall_nargs; | |
| 4144 | |
| 4145 GET_EXTERNAL_LIST_LENGTH (spread_arg, numargs); | |
| 4146 | |
| 4147 if (numargs == 0) | |
| 4148 /* (apply foo 0 1 '()) */ | |
| 4149 return Ffuncall (nargs - 1, args); | |
| 4150 else if (numargs == 1) | |
| 4151 { | |
| 4152 /* (apply foo 0 1 '(2)) */ | |
| 4153 args [nargs - 1] = XCAR (spread_arg); | |
| 4154 return Ffuncall (nargs, args); | |
| 4155 } | |
| 4156 | |
| 4157 /* -1 for function, -1 for spread arg */ | |
| 4158 numargs = nargs - 2 + numargs; | |
| 4159 /* +1 for function */ | |
| 4160 funcall_nargs = 1 + numargs; | |
| 4161 | |
| 4162 if (SYMBOLP (fun)) | |
| 4163 fun = indirect_function (fun, 0); | |
| 4164 | |
| 4165 if (SUBRP (fun)) | |
| 4166 { | |
| 4167 Lisp_Subr *subr = XSUBR (fun); | |
| 4168 int max_args = subr->max_args; | |
| 4169 | |
| 4170 if (numargs < subr->min_args | |
| 4171 || (max_args >= 0 && max_args < numargs)) | |
| 4172 { | |
| 4173 /* Let funcall get the error */ | |
| 4174 } | |
| 4175 else if (max_args > numargs) | |
| 4176 { | |
| 4177 /* Avoid having funcall cons up yet another new vector of arguments | |
| 4178 by explicitly supplying nil's for optional values */ | |
| 4179 funcall_nargs += (max_args - numargs); | |
| 4180 } | |
| 4181 } | |
| 4182 else if (UNBOUNDP (fun)) | |
| 4183 { | |
| 4184 /* Let funcall get the error */ | |
| 4185 fun = args[0]; | |
| 4186 } | |
| 4187 | |
| 4188 { | |
| 4189 REGISTER int i; | |
| 4190 Lisp_Object *funcall_args = alloca_array (Lisp_Object, funcall_nargs); | |
| 4191 struct gcpro gcpro1; | |
| 4192 | |
| 4193 GCPRO1 (*funcall_args); | |
| 4194 gcpro1.nvars = funcall_nargs; | |
| 4195 | |
| 4196 /* Copy in the unspread args */ | |
| 4197 memcpy (funcall_args, args, (nargs - 1) * sizeof (Lisp_Object)); | |
| 4198 /* Spread the last arg we got. Its first element goes in | |
| 4199 the slot that it used to occupy, hence this value of I. */ | |
| 4200 for (i = nargs - 1; | |
| 4201 !NILP (spread_arg); /* i < 1 + numargs */ | |
| 4202 i++, spread_arg = XCDR (spread_arg)) | |
| 4203 { | |
| 4204 funcall_args [i] = XCAR (spread_arg); | |
| 4205 } | |
| 4206 /* Supply nil for optional args (to subrs) */ | |
| 4207 for (; i < funcall_nargs; i++) | |
| 4208 funcall_args[i] = Qnil; | |
| 4209 | |
| 4210 | |
| 4211 RETURN_UNGCPRO (Ffuncall (funcall_nargs, funcall_args)); | |
| 4212 } | |
| 4213 } | |
| 4214 | |
| 4215 | |
| 4216 /* Apply lambda list FUN to the NARGS evaluated arguments in ARGS and | |
| 4217 return the result of evaluation. */ | |
| 4218 | |
| 4219 static Lisp_Object | |
| 4220 funcall_lambda (Lisp_Object fun, int nargs, Lisp_Object args[]) | |
| 4221 { | |
| 4222 /* This function can GC */ | |
| 442 | 4223 Lisp_Object arglist, body, tail; |
| 428 | 4224 int speccount = specpdl_depth(); |
| 4225 REGISTER int i = 0; | |
| 4226 | |
| 4227 tail = XCDR (fun); | |
| 4228 | |
| 4229 if (!CONSP (tail)) | |
| 4230 goto invalid_function; | |
| 4231 | |
| 4232 arglist = XCAR (tail); | |
| 4233 body = XCDR (tail); | |
| 4234 | |
| 4235 { | |
| 4236 int optional = 0, rest = 0; | |
| 4237 | |
| 442 | 4238 EXTERNAL_LIST_LOOP_2 (symbol, arglist) |
| 428 | 4239 { |
| 4240 if (!SYMBOLP (symbol)) | |
| 4241 goto invalid_function; | |
| 4242 if (EQ (symbol, Qand_rest)) | |
| 4243 rest = 1; | |
| 4244 else if (EQ (symbol, Qand_optional)) | |
| 4245 optional = 1; | |
| 4246 else if (rest) | |
| 4247 { | |
| 4248 specbind (symbol, Flist (nargs - i, &args[i])); | |
| 4249 i = nargs; | |
| 4250 } | |
| 4251 else if (i < nargs) | |
| 4252 specbind (symbol, args[i++]); | |
| 4253 else if (!optional) | |
| 4254 goto wrong_number_of_arguments; | |
| 4255 else | |
| 4256 specbind (symbol, Qnil); | |
| 4257 } | |
| 4258 } | |
| 4259 | |
| 4260 if (i < nargs) | |
| 4261 goto wrong_number_of_arguments; | |
| 4262 | |
| 771 | 4263 return unbind_to_1 (speccount, Fprogn (body)); |
| 428 | 4264 |
| 4265 wrong_number_of_arguments: | |
| 436 | 4266 return signal_wrong_number_of_arguments_error (fun, nargs); |
| 428 | 4267 |
| 4268 invalid_function: | |
| 436 | 4269 return signal_invalid_function_error (fun); |
| 428 | 4270 } |
| 4271 | |
| 4272 | |
| 4273 /************************************************************************/ | |
| 4274 /* Run hook variables in various ways. */ | |
| 4275 /************************************************************************/ | |
| 4276 | |
| 4277 DEFUN ("run-hooks", Frun_hooks, 1, MANY, 0, /* | |
| 4278 Run each hook in HOOKS. Major mode functions use this. | |
| 4279 Each argument should be a symbol, a hook variable. | |
| 4280 These symbols are processed in the order specified. | |
| 4281 If a hook symbol has a non-nil value, that value may be a function | |
| 4282 or a list of functions to be called to run the hook. | |
| 4283 If the value is a function, it is called with no arguments. | |
| 4284 If it is a list, the elements are called, in order, with no arguments. | |
| 4285 | |
| 4286 To make a hook variable buffer-local, use `make-local-hook', | |
| 4287 not `make-local-variable'. | |
| 4288 */ | |
| 4289 (int nargs, Lisp_Object *args)) | |
| 4290 { | |
| 4291 REGISTER int i; | |
| 4292 | |
| 4293 for (i = 0; i < nargs; i++) | |
| 4294 run_hook_with_args (1, args + i, RUN_HOOKS_TO_COMPLETION); | |
| 4295 | |
| 4296 return Qnil; | |
| 4297 } | |
| 4298 | |
| 4299 DEFUN ("run-hook-with-args", Frun_hook_with_args, 1, MANY, 0, /* | |
| 4300 Run HOOK with the specified arguments ARGS. | |
| 4301 HOOK should be a symbol, a hook variable. If HOOK has a non-nil | |
| 4302 value, that value may be a function or a list of functions to be | |
| 4303 called to run the hook. If the value is a function, it is called with | |
| 4304 the given arguments and its return value is returned. If it is a list | |
| 4305 of functions, those functions are called, in order, | |
| 4306 with the given arguments ARGS. | |
| 444 | 4307 It is best not to depend on the value returned by `run-hook-with-args', |
| 428 | 4308 as that may change. |
| 4309 | |
| 4310 To make a hook variable buffer-local, use `make-local-hook', | |
| 4311 not `make-local-variable'. | |
| 4312 */ | |
| 4313 (int nargs, Lisp_Object *args)) | |
| 4314 { | |
| 4315 return run_hook_with_args (nargs, args, RUN_HOOKS_TO_COMPLETION); | |
| 4316 } | |
| 4317 | |
| 4318 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success, 1, MANY, 0, /* | |
| 4319 Run HOOK with the specified arguments ARGS. | |
| 4320 HOOK should be a symbol, a hook variable. Its value should | |
| 4321 be a list of functions. We call those functions, one by one, | |
| 4322 passing arguments ARGS to each of them, until one of them | |
| 4323 returns a non-nil value. Then we return that value. | |
| 4324 If all the functions return nil, we return nil. | |
| 4325 | |
| 4326 To make a hook variable buffer-local, use `make-local-hook', | |
| 4327 not `make-local-variable'. | |
| 4328 */ | |
| 4329 (int nargs, Lisp_Object *args)) | |
| 4330 { | |
| 4331 return run_hook_with_args (nargs, args, RUN_HOOKS_UNTIL_SUCCESS); | |
| 4332 } | |
| 4333 | |
| 4334 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure, 1, MANY, 0, /* | |
| 4335 Run HOOK with the specified arguments ARGS. | |
| 4336 HOOK should be a symbol, a hook variable. Its value should | |
| 4337 be a list of functions. We call those functions, one by one, | |
| 4338 passing arguments ARGS to each of them, until one of them | |
| 4339 returns nil. Then we return nil. | |
| 4340 If all the functions return non-nil, we return non-nil. | |
| 4341 | |
| 4342 To make a hook variable buffer-local, use `make-local-hook', | |
| 4343 not `make-local-variable'. | |
| 4344 */ | |
| 4345 (int nargs, Lisp_Object *args)) | |
| 4346 { | |
| 4347 return run_hook_with_args (nargs, args, RUN_HOOKS_UNTIL_FAILURE); | |
| 4348 } | |
| 4349 | |
| 4350 /* ARGS[0] should be a hook symbol. | |
| 4351 Call each of the functions in the hook value, passing each of them | |
| 4352 as arguments all the rest of ARGS (all NARGS - 1 elements). | |
| 4353 COND specifies a condition to test after each call | |
| 4354 to decide whether to stop. | |
| 4355 The caller (or its caller, etc) must gcpro all of ARGS, | |
| 4356 except that it isn't necessary to gcpro ARGS[0]. */ | |
| 4357 | |
| 4358 Lisp_Object | |
| 4359 run_hook_with_args_in_buffer (struct buffer *buf, int nargs, Lisp_Object *args, | |
| 4360 enum run_hooks_condition cond) | |
| 4361 { | |
| 4362 Lisp_Object sym, val, ret; | |
| 4363 | |
| 4364 if (!initialized || preparing_for_armageddon) | |
| 4365 /* We need to bail out of here pronto. */ | |
| 4366 return Qnil; | |
| 4367 | |
| 3092 | 4368 #ifndef NEW_GC |
| 428 | 4369 /* Whenever gc_in_progress is true, preparing_for_armageddon |
| 4370 will also be true unless something is really hosed. */ | |
| 4371 assert (!gc_in_progress); | |
| 3092 | 4372 #endif /* not NEW_GC */ |
| 428 | 4373 |
| 4374 sym = args[0]; | |
| 771 | 4375 val = symbol_value_in_buffer (sym, wrap_buffer (buf)); |
| 428 | 4376 ret = (cond == RUN_HOOKS_UNTIL_FAILURE ? Qt : Qnil); |
| 4377 | |
| 4378 if (UNBOUNDP (val) || NILP (val)) | |
| 4379 return ret; | |
| 4380 else if (!CONSP (val) || EQ (XCAR (val), Qlambda)) | |
| 4381 { | |
| 4382 args[0] = val; | |
| 4383 return Ffuncall (nargs, args); | |
| 4384 } | |
| 4385 else | |
| 4386 { | |
| 4387 struct gcpro gcpro1, gcpro2, gcpro3; | |
| 4388 Lisp_Object globals = Qnil; | |
| 4389 GCPRO3 (sym, val, globals); | |
| 4390 | |
| 4391 for (; | |
| 4392 CONSP (val) && ((cond == RUN_HOOKS_TO_COMPLETION) | |
| 4393 || (cond == RUN_HOOKS_UNTIL_SUCCESS ? NILP (ret) | |
| 4394 : !NILP (ret))); | |
| 4395 val = XCDR (val)) | |
| 4396 { | |
| 4397 if (EQ (XCAR (val), Qt)) | |
| 4398 { | |
| 4399 /* t indicates this hook has a local binding; | |
| 4400 it means to run the global binding too. */ | |
| 4401 globals = Fdefault_value (sym); | |
| 4402 | |
| 4403 if ((! CONSP (globals) || EQ (XCAR (globals), Qlambda)) && | |
| 4404 ! NILP (globals)) | |
| 4405 { | |
| 4406 args[0] = globals; | |
| 4407 ret = Ffuncall (nargs, args); | |
| 4408 } | |
| 4409 else | |
| 4410 { | |
| 4411 for (; | |
| 4412 CONSP (globals) && ((cond == RUN_HOOKS_TO_COMPLETION) | |
| 4413 || (cond == RUN_HOOKS_UNTIL_SUCCESS | |
| 4414 ? NILP (ret) | |
| 4415 : !NILP (ret))); | |
| 4416 globals = XCDR (globals)) | |
| 4417 { | |
| 4418 args[0] = XCAR (globals); | |
| 4419 /* In a global value, t should not occur. If it does, we | |
| 4420 must ignore it to avoid an endless loop. */ | |
| 4421 if (!EQ (args[0], Qt)) | |
| 4422 ret = Ffuncall (nargs, args); | |
| 4423 } | |
| 4424 } | |
| 4425 } | |
| 4426 else | |
| 4427 { | |
| 4428 args[0] = XCAR (val); | |
| 4429 ret = Ffuncall (nargs, args); | |
| 4430 } | |
| 4431 } | |
| 4432 | |
| 4433 UNGCPRO; | |
| 4434 return ret; | |
| 4435 } | |
| 4436 } | |
| 4437 | |
| 4438 Lisp_Object | |
| 4439 run_hook_with_args (int nargs, Lisp_Object *args, | |
| 4440 enum run_hooks_condition cond) | |
| 4441 { | |
| 4442 return run_hook_with_args_in_buffer (current_buffer, nargs, args, cond); | |
| 4443 } | |
| 4444 | |
| 4445 #if 0 | |
| 4446 | |
| 853 | 4447 /* From FSF 19.30, not currently used; seems like a big kludge. */ |
| 428 | 4448 |
| 4449 /* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual | |
| 4450 present value of that symbol. | |
| 4451 Call each element of FUNLIST, | |
| 4452 passing each of them the rest of ARGS. | |
| 4453 The caller (or its caller, etc) must gcpro all of ARGS, | |
| 4454 except that it isn't necessary to gcpro ARGS[0]. */ | |
| 4455 | |
| 4456 Lisp_Object | |
| 4457 run_hook_list_with_args (Lisp_Object funlist, int nargs, Lisp_Object *args) | |
| 4458 { | |
| 853 | 4459 omitted; |
| 428 | 4460 } |
| 4461 | |
| 4462 #endif /* 0 */ | |
| 4463 | |
| 4464 void | |
| 4465 va_run_hook_with_args (Lisp_Object hook_var, int nargs, ...) | |
| 4466 { | |
| 4467 /* This function can GC */ | |
| 4468 struct gcpro gcpro1; | |
| 4469 int i; | |
| 4470 va_list vargs; | |
| 4471 Lisp_Object *funcall_args = alloca_array (Lisp_Object, 1 + nargs); | |
| 4472 | |
| 4473 va_start (vargs, nargs); | |
| 4474 funcall_args[0] = hook_var; | |
| 4475 for (i = 0; i < nargs; i++) | |
| 4476 funcall_args[i + 1] = va_arg (vargs, Lisp_Object); | |
| 4477 va_end (vargs); | |
| 4478 | |
| 4479 GCPRO1 (*funcall_args); | |
| 4480 gcpro1.nvars = nargs + 1; | |
| 4481 run_hook_with_args (nargs + 1, funcall_args, RUN_HOOKS_TO_COMPLETION); | |
| 4482 UNGCPRO; | |
| 4483 } | |
| 4484 | |
| 4485 void | |
| 4486 va_run_hook_with_args_in_buffer (struct buffer *buf, Lisp_Object hook_var, | |
| 4487 int nargs, ...) | |
| 4488 { | |
| 4489 /* This function can GC */ | |
| 4490 struct gcpro gcpro1; | |
| 4491 int i; | |
| 4492 va_list vargs; | |
| 4493 Lisp_Object *funcall_args = alloca_array (Lisp_Object, 1 + nargs); | |
| 4494 | |
| 4495 va_start (vargs, nargs); | |
| 4496 funcall_args[0] = hook_var; | |
| 4497 for (i = 0; i < nargs; i++) | |
| 4498 funcall_args[i + 1] = va_arg (vargs, Lisp_Object); | |
| 4499 va_end (vargs); | |
| 4500 | |
| 4501 GCPRO1 (*funcall_args); | |
| 4502 gcpro1.nvars = nargs + 1; | |
| 4503 run_hook_with_args_in_buffer (buf, nargs + 1, funcall_args, | |
| 4504 RUN_HOOKS_TO_COMPLETION); | |
| 4505 UNGCPRO; | |
| 4506 } | |
| 4507 | |
| 4508 Lisp_Object | |
| 4509 run_hook (Lisp_Object hook) | |
| 4510 { | |
| 853 | 4511 return run_hook_with_args (1, &hook, RUN_HOOKS_TO_COMPLETION); |
| 428 | 4512 } |
| 4513 | |
| 4514 | |
| 4515 /************************************************************************/ | |
| 4516 /* Front-ends to eval, funcall, apply */ | |
| 4517 /************************************************************************/ | |
| 4518 | |
| 4519 /* Apply fn to arg */ | |
| 4520 Lisp_Object | |
| 4521 apply1 (Lisp_Object fn, Lisp_Object arg) | |
| 4522 { | |
| 4523 /* This function can GC */ | |
| 4524 struct gcpro gcpro1; | |
| 4525 Lisp_Object args[2]; | |
| 4526 | |
| 4527 if (NILP (arg)) | |
| 4528 return Ffuncall (1, &fn); | |
| 4529 GCPRO1 (args[0]); | |
| 4530 gcpro1.nvars = 2; | |
| 4531 args[0] = fn; | |
| 4532 args[1] = arg; | |
| 4533 RETURN_UNGCPRO (Fapply (2, args)); | |
| 4534 } | |
| 4535 | |
| 4536 /* Call function fn on no arguments */ | |
| 4537 Lisp_Object | |
| 4538 call0 (Lisp_Object fn) | |
| 4539 { | |
| 4540 /* This function can GC */ | |
| 4541 struct gcpro gcpro1; | |
| 4542 | |
| 4543 GCPRO1 (fn); | |
| 4544 RETURN_UNGCPRO (Ffuncall (1, &fn)); | |
| 4545 } | |
| 4546 | |
| 4547 /* Call function fn with argument arg0 */ | |
| 4548 Lisp_Object | |
| 4549 call1 (Lisp_Object fn, | |
| 4550 Lisp_Object arg0) | |
| 4551 { | |
| 4552 /* This function can GC */ | |
| 4553 struct gcpro gcpro1; | |
| 4554 Lisp_Object args[2]; | |
| 4555 args[0] = fn; | |
| 4556 args[1] = arg0; | |
| 4557 GCPRO1 (args[0]); | |
| 4558 gcpro1.nvars = 2; | |
| 4559 RETURN_UNGCPRO (Ffuncall (2, args)); | |
| 4560 } | |
| 4561 | |
| 4562 /* Call function fn with arguments arg0, arg1 */ | |
| 4563 Lisp_Object | |
| 4564 call2 (Lisp_Object fn, | |
| 4565 Lisp_Object arg0, Lisp_Object arg1) | |
| 4566 { | |
| 4567 /* This function can GC */ | |
| 4568 struct gcpro gcpro1; | |
| 4569 Lisp_Object args[3]; | |
| 4570 args[0] = fn; | |
| 4571 args[1] = arg0; | |
| 4572 args[2] = arg1; | |
| 4573 GCPRO1 (args[0]); | |
| 4574 gcpro1.nvars = 3; | |
| 4575 RETURN_UNGCPRO (Ffuncall (3, args)); | |
| 4576 } | |
| 4577 | |
| 4578 /* Call function fn with arguments arg0, arg1, arg2 */ | |
| 4579 Lisp_Object | |
| 4580 call3 (Lisp_Object fn, | |
| 4581 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2) | |
| 4582 { | |
| 4583 /* This function can GC */ | |
| 4584 struct gcpro gcpro1; | |
| 4585 Lisp_Object args[4]; | |
| 4586 args[0] = fn; | |
| 4587 args[1] = arg0; | |
| 4588 args[2] = arg1; | |
| 4589 args[3] = arg2; | |
| 4590 GCPRO1 (args[0]); | |
| 4591 gcpro1.nvars = 4; | |
| 4592 RETURN_UNGCPRO (Ffuncall (4, args)); | |
| 4593 } | |
| 4594 | |
| 4595 /* Call function fn with arguments arg0, arg1, arg2, arg3 */ | |
| 4596 Lisp_Object | |
| 4597 call4 (Lisp_Object fn, | |
| 4598 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2, | |
| 4599 Lisp_Object arg3) | |
| 4600 { | |
| 4601 /* This function can GC */ | |
| 4602 struct gcpro gcpro1; | |
| 4603 Lisp_Object args[5]; | |
| 4604 args[0] = fn; | |
| 4605 args[1] = arg0; | |
| 4606 args[2] = arg1; | |
| 4607 args[3] = arg2; | |
| 4608 args[4] = arg3; | |
| 4609 GCPRO1 (args[0]); | |
| 4610 gcpro1.nvars = 5; | |
| 4611 RETURN_UNGCPRO (Ffuncall (5, args)); | |
| 4612 } | |
| 4613 | |
| 4614 /* Call function fn with arguments arg0, arg1, arg2, arg3, arg4 */ | |
| 4615 Lisp_Object | |
| 4616 call5 (Lisp_Object fn, | |
| 4617 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2, | |
| 4618 Lisp_Object arg3, Lisp_Object arg4) | |
| 4619 { | |
| 4620 /* This function can GC */ | |
| 4621 struct gcpro gcpro1; | |
| 4622 Lisp_Object args[6]; | |
| 4623 args[0] = fn; | |
| 4624 args[1] = arg0; | |
| 4625 args[2] = arg1; | |
| 4626 args[3] = arg2; | |
| 4627 args[4] = arg3; | |
| 4628 args[5] = arg4; | |
| 4629 GCPRO1 (args[0]); | |
| 4630 gcpro1.nvars = 6; | |
| 4631 RETURN_UNGCPRO (Ffuncall (6, args)); | |
| 4632 } | |
| 4633 | |
| 4634 Lisp_Object | |
| 4635 call6 (Lisp_Object fn, | |
| 4636 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2, | |
| 4637 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5) | |
| 4638 { | |
| 4639 /* This function can GC */ | |
| 4640 struct gcpro gcpro1; | |
| 4641 Lisp_Object args[7]; | |
| 4642 args[0] = fn; | |
| 4643 args[1] = arg0; | |
| 4644 args[2] = arg1; | |
| 4645 args[3] = arg2; | |
| 4646 args[4] = arg3; | |
| 4647 args[5] = arg4; | |
| 4648 args[6] = arg5; | |
| 4649 GCPRO1 (args[0]); | |
| 4650 gcpro1.nvars = 7; | |
| 4651 RETURN_UNGCPRO (Ffuncall (7, args)); | |
| 4652 } | |
| 4653 | |
| 4654 Lisp_Object | |
| 4655 call7 (Lisp_Object fn, | |
| 4656 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2, | |
| 4657 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5, | |
| 4658 Lisp_Object arg6) | |
| 4659 { | |
| 4660 /* This function can GC */ | |
| 4661 struct gcpro gcpro1; | |
| 4662 Lisp_Object args[8]; | |
| 4663 args[0] = fn; | |
| 4664 args[1] = arg0; | |
| 4665 args[2] = arg1; | |
| 4666 args[3] = arg2; | |
| 4667 args[4] = arg3; | |
| 4668 args[5] = arg4; | |
| 4669 args[6] = arg5; | |
| 4670 args[7] = arg6; | |
| 4671 GCPRO1 (args[0]); | |
| 4672 gcpro1.nvars = 8; | |
| 4673 RETURN_UNGCPRO (Ffuncall (8, args)); | |
| 4674 } | |
| 4675 | |
| 4676 Lisp_Object | |
| 4677 call8 (Lisp_Object fn, | |
| 4678 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2, | |
| 4679 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5, | |
| 4680 Lisp_Object arg6, Lisp_Object arg7) | |
| 4681 { | |
| 4682 /* This function can GC */ | |
| 4683 struct gcpro gcpro1; | |
| 4684 Lisp_Object args[9]; | |
| 4685 args[0] = fn; | |
| 4686 args[1] = arg0; | |
| 4687 args[2] = arg1; | |
| 4688 args[3] = arg2; | |
| 4689 args[4] = arg3; | |
| 4690 args[5] = arg4; | |
| 4691 args[6] = arg5; | |
| 4692 args[7] = arg6; | |
| 4693 args[8] = arg7; | |
| 4694 GCPRO1 (args[0]); | |
| 4695 gcpro1.nvars = 9; | |
| 4696 RETURN_UNGCPRO (Ffuncall (9, args)); | |
| 4697 } | |
| 4698 | |
| 4699 Lisp_Object | |
| 4700 call0_in_buffer (struct buffer *buf, Lisp_Object fn) | |
| 4701 { | |
| 4702 if (current_buffer == buf) | |
| 4703 return call0 (fn); | |
| 4704 else | |
| 4705 { | |
| 4706 Lisp_Object val; | |
| 4707 int speccount = specpdl_depth(); | |
| 4708 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); | |
| 4709 set_buffer_internal (buf); | |
| 4710 val = call0 (fn); | |
| 771 | 4711 unbind_to (speccount); |
| 428 | 4712 return val; |
| 4713 } | |
| 4714 } | |
| 4715 | |
| 4716 Lisp_Object | |
| 4717 call1_in_buffer (struct buffer *buf, Lisp_Object fn, | |
| 4718 Lisp_Object arg0) | |
| 4719 { | |
| 4720 if (current_buffer == buf) | |
| 4721 return call1 (fn, arg0); | |
| 4722 else | |
| 4723 { | |
| 4724 Lisp_Object val; | |
| 4725 int speccount = specpdl_depth(); | |
| 4726 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); | |
| 4727 set_buffer_internal (buf); | |
| 4728 val = call1 (fn, arg0); | |
| 771 | 4729 unbind_to (speccount); |
| 428 | 4730 return val; |
| 4731 } | |
| 4732 } | |
| 4733 | |
| 4734 Lisp_Object | |
| 4735 call2_in_buffer (struct buffer *buf, Lisp_Object fn, | |
| 4736 Lisp_Object arg0, Lisp_Object arg1) | |
| 4737 { | |
| 4738 if (current_buffer == buf) | |
| 4739 return call2 (fn, arg0, arg1); | |
| 4740 else | |
| 4741 { | |
| 4742 Lisp_Object val; | |
| 4743 int speccount = specpdl_depth(); | |
| 4744 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); | |
| 4745 set_buffer_internal (buf); | |
| 4746 val = call2 (fn, arg0, arg1); | |
| 771 | 4747 unbind_to (speccount); |
| 428 | 4748 return val; |
| 4749 } | |
| 4750 } | |
| 4751 | |
| 4752 Lisp_Object | |
| 4753 call3_in_buffer (struct buffer *buf, Lisp_Object fn, | |
| 4754 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2) | |
| 4755 { | |
| 4756 if (current_buffer == buf) | |
| 4757 return call3 (fn, arg0, arg1, arg2); | |
| 4758 else | |
| 4759 { | |
| 4760 Lisp_Object val; | |
| 4761 int speccount = specpdl_depth(); | |
| 4762 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); | |
| 4763 set_buffer_internal (buf); | |
| 4764 val = call3 (fn, arg0, arg1, arg2); | |
| 771 | 4765 unbind_to (speccount); |
| 428 | 4766 return val; |
| 4767 } | |
| 4768 } | |
| 4769 | |
| 4770 Lisp_Object | |
| 4771 call4_in_buffer (struct buffer *buf, Lisp_Object fn, | |
| 4772 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2, | |
| 4773 Lisp_Object arg3) | |
| 4774 { | |
| 4775 if (current_buffer == buf) | |
| 4776 return call4 (fn, arg0, arg1, arg2, arg3); | |
| 4777 else | |
| 4778 { | |
| 4779 Lisp_Object val; | |
| 4780 int speccount = specpdl_depth(); | |
| 4781 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); | |
| 4782 set_buffer_internal (buf); | |
| 4783 val = call4 (fn, arg0, arg1, arg2, arg3); | |
| 771 | 4784 unbind_to (speccount); |
| 428 | 4785 return val; |
| 4786 } | |
| 4787 } | |
| 4788 | |
| 4789 Lisp_Object | |
| 4790 eval_in_buffer (struct buffer *buf, Lisp_Object form) | |
| 4791 { | |
| 4792 if (current_buffer == buf) | |
| 4793 return Feval (form); | |
| 4794 else | |
| 4795 { | |
| 4796 Lisp_Object val; | |
| 4797 int speccount = specpdl_depth(); | |
| 4798 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); | |
| 4799 set_buffer_internal (buf); | |
| 4800 val = Feval (form); | |
| 771 | 4801 unbind_to (speccount); |
| 428 | 4802 return val; |
| 4803 } | |
| 4804 } | |
| 4805 | |
| 4806 | |
| 4807 /************************************************************************/ | |
| 4808 /* Error-catching front-ends to eval, funcall, apply */ | |
| 4809 /************************************************************************/ | |
| 4810 | |
| 853 | 4811 int |
| 4812 get_inhibit_flags (void) | |
| 4813 { | |
| 4814 return inhibit_flags; | |
| 4815 } | |
| 4816 | |
| 4817 void | |
| 2286 | 4818 check_allowed_operation (int what, Lisp_Object obj, Lisp_Object UNUSED (prop)) |
| 853 | 4819 { |
| 4820 if (inhibit_flags & INHIBIT_EXISTING_BUFFER_TEXT_MODIFICATION) | |
| 4821 { | |
| 4822 if (what == OPERATION_MODIFY_BUFFER_TEXT && BUFFERP (obj) | |
| 4823 && NILP (memq_no_quit (obj, Vmodifiable_buffers))) | |
| 4824 invalid_change | |
| 4825 ("Modification of this buffer not currently permitted", obj); | |
| 4826 } | |
| 4827 if (inhibit_flags & INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION) | |
| 4828 { | |
| 4829 if (what == OPERATION_DELETE_OBJECT | |
| 4830 && (BUFFERP (obj) || WINDOWP (obj) || FRAMEP (obj) || DEVICEP (obj) | |
| 4831 || CONSOLEP (obj)) | |
| 4832 && NILP (memq_no_quit (obj, Vdeletable_permanent_display_objects))) | |
| 4833 invalid_change | |
| 4834 ("Deletion of this object not currently permitted", obj); | |
| 4835 } | |
| 4836 } | |
| 4837 | |
| 4838 void | |
| 4839 note_object_created (Lisp_Object obj) | |
| 4840 { | |
| 4841 if (inhibit_flags & INHIBIT_EXISTING_BUFFER_TEXT_MODIFICATION) | |
| 4842 { | |
| 4843 if (BUFFERP (obj)) | |
| 4844 Vmodifiable_buffers = Fcons (obj, Vmodifiable_buffers); | |
| 4845 } | |
| 4846 if (inhibit_flags & INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION) | |
| 4847 { | |
| 4848 if (BUFFERP (obj) || WINDOWP (obj) || FRAMEP (obj) || DEVICEP (obj) | |
| 4849 || CONSOLEP (obj)) | |
| 4850 Vdeletable_permanent_display_objects = | |
| 4851 Fcons (obj, Vdeletable_permanent_display_objects); | |
| 4852 } | |
| 4853 } | |
| 4854 | |
| 4855 void | |
| 4856 note_object_deleted (Lisp_Object obj) | |
| 4857 { | |
| 4858 if (inhibit_flags & INHIBIT_EXISTING_BUFFER_TEXT_MODIFICATION) | |
| 4859 { | |
| 4860 if (BUFFERP (obj)) | |
| 4861 Vmodifiable_buffers = delq_no_quit (obj, Vmodifiable_buffers); | |
| 4862 } | |
| 4863 if (inhibit_flags & INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION) | |
| 4864 { | |
| 4865 if (BUFFERP (obj) || WINDOWP (obj) || FRAMEP (obj) || DEVICEP (obj) | |
| 4866 || CONSOLEP (obj)) | |
| 4867 Vdeletable_permanent_display_objects = | |
| 4868 delq_no_quit (obj, Vdeletable_permanent_display_objects); | |
| 4869 } | |
| 4870 } | |
| 4871 | |
| 4872 struct call_trapping_problems | |
| 4873 { | |
| 4874 Lisp_Object catchtag; | |
| 4875 Lisp_Object error_conditions; | |
| 4876 Lisp_Object data; | |
| 4877 Lisp_Object backtrace; | |
| 4878 Lisp_Object warning_class; | |
| 4879 | |
| 867 | 4880 const CIbyte *warning_string; |
| 853 | 4881 Lisp_Object (*fun) (void *); |
| 4882 void *arg; | |
| 4883 }; | |
| 428 | 4884 |
| 2532 | 4885 static Lisp_Object |
| 4886 maybe_get_trapping_problems_backtrace (void) | |
| 4887 { | |
| 4888 Lisp_Object backtrace; | |
| 853 | 4889 |
| 1123 | 4890 if (!(inhibit_flags & INHIBIT_WARNING_ISSUE) |
| 2532 | 4891 && !warning_will_be_discarded (current_warning_level ())) |
| 428 | 4892 { |
| 1333 | 4893 struct gcpro gcpro1; |
| 4894 Lisp_Object lstream = Qnil; | |
| 4895 int speccount = specpdl_depth (); | |
| 4896 | |
| 853 | 4897 /* We're no longer protected against errors or quit here, so at |
| 4898 least let's temporarily inhibit quit. We definitely do not | |
| 4899 want to inhibit quit during the calling of the function | |
| 4900 itself!!!!!!!!!!! */ | |
| 4901 | |
| 4902 specbind (Qinhibit_quit, Qt); | |
| 4903 | |
| 4904 GCPRO1 (lstream); | |
| 4905 lstream = make_resizing_buffer_output_stream (); | |
| 4906 Fbacktrace (lstream, Qt); | |
| 4907 Lstream_flush (XLSTREAM (lstream)); | |
| 2532 | 4908 backtrace = resizing_buffer_to_lisp_string (XLSTREAM (lstream)); |
| 853 | 4909 Lstream_delete (XLSTREAM (lstream)); |
| 4910 UNGCPRO; | |
| 4911 | |
| 4912 unbind_to (speccount); | |
| 428 | 4913 } |
| 853 | 4914 else |
| 2532 | 4915 backtrace = Qnil; |
| 4916 | |
| 4917 return backtrace; | |
| 4918 } | |
| 4919 | |
| 4920 static DECLARE_DOESNT_RETURN_TYPE | |
| 4921 (Lisp_Object, flagged_a_squirmer (Lisp_Object, Lisp_Object, Lisp_Object)); | |
| 4922 | |
| 4923 static DOESNT_RETURN_TYPE (Lisp_Object) | |
| 4924 flagged_a_squirmer (Lisp_Object error_conditions, Lisp_Object data, | |
| 4925 Lisp_Object opaque) | |
| 4926 { | |
| 4927 struct call_trapping_problems *p = | |
| 4928 (struct call_trapping_problems *) get_opaque_ptr (opaque); | |
| 4929 | |
| 4930 if (!EQ (error_conditions, Qquit)) | |
| 4931 p->backtrace = maybe_get_trapping_problems_backtrace (); | |
| 4932 else | |
| 853 | 4933 p->backtrace = Qnil; |
| 4934 p->error_conditions = error_conditions; | |
| 4935 p->data = data; | |
| 4936 | |
| 4937 Fthrow (p->catchtag, Qnil); | |
| 2268 | 4938 RETURN_NOT_REACHED (Qnil); |
| 853 | 4939 } |
| 4940 | |
| 4941 static Lisp_Object | |
| 4942 call_trapping_problems_2 (Lisp_Object opaque) | |
| 4943 { | |
| 4944 struct call_trapping_problems *p = | |
| 4945 (struct call_trapping_problems *) get_opaque_ptr (opaque); | |
| 4946 | |
| 4947 return (p->fun) (p->arg); | |
| 428 | 4948 } |
| 4949 | |
| 4950 static Lisp_Object | |
| 853 | 4951 call_trapping_problems_1 (Lisp_Object opaque) |
| 4952 { | |
| 4953 return call_with_condition_handler (flagged_a_squirmer, opaque, | |
| 4954 call_trapping_problems_2, opaque); | |
| 4955 } | |
| 4956 | |
| 1333 | 4957 static void |
| 4958 issue_call_trapping_problems_warning (Lisp_Object warning_class, | |
| 4959 const CIbyte *warning_string, | |
| 4960 struct call_trapping_problems_result *p) | |
| 4961 { | |
| 4962 if (!warning_will_be_discarded (current_warning_level ())) | |
| 4963 { | |
| 4964 int depth = specpdl_depth (); | |
| 4965 | |
| 4966 /* We're no longer protected against errors or quit here, so at | |
| 4967 least let's temporarily inhibit quit. */ | |
| 4968 specbind (Qinhibit_quit, Qt); | |
| 4969 | |
| 4970 if (p->caught_throw) | |
| 4971 { | |
| 4972 Lisp_Object errstr = | |
| 4973 emacs_sprintf_string_lisp | |
| 2532 | 4974 ("%s: Attempt to throw outside of function:" |
| 4975 "To catch `%s' with value `%s'\n\nBacktrace follows:\n\n%s", | |
| 2725 | 4976 Qnil, 4, |
| 1333 | 4977 build_msg_string (warning_string ? warning_string : "error"), |
| 2532 | 4978 p->thrown_tag, p->thrown_value, p->backtrace); |
| 1333 | 4979 warn_when_safe_lispobj (Qerror, current_warning_level (), errstr); |
| 4980 } | |
| 2421 | 4981 else if (p->caught_error && !EQ (p->error_conditions, Qquit)) |
| 1333 | 4982 { |
| 4983 Lisp_Object errstr; | |
| 4984 /* #### This should call | |
| 4985 (with-output-to-string (display-error (cons error_conditions | |
| 4986 data)) | |
| 4987 but that stuff is all in Lisp currently. */ | |
| 4988 errstr = | |
| 4989 emacs_sprintf_string_lisp | |
| 4990 ("%s: (%s %s)\n\nBacktrace follows:\n\n%s", | |
| 4991 Qnil, 4, | |
| 4992 build_msg_string (warning_string ? warning_string : "error"), | |
| 4993 p->error_conditions, p->data, p->backtrace); | |
| 4994 | |
| 4995 warn_when_safe_lispobj (warning_class, current_warning_level (), | |
| 4996 errstr); | |
| 4997 } | |
| 4998 | |
| 4999 unbind_to (depth); | |
| 5000 } | |
| 5001 } | |
| 5002 | |
| 1318 | 5003 /* Turn on the trapping flags in FLAGS -- see call_trapping_problems(). |
| 5004 This cannot handle INTERNAL_INHIBIT_THROWS() or INTERNAL_INHIBIT_ERRORS | |
| 5005 (because they ultimately boil down to a setjmp()!) -- you must directly | |
| 5006 use call_trapping_problems() for that. Turn the flags off with | |
| 5007 unbind_to(). Returns the "canonicalized" flags (particularly in the | |
| 5008 case of INHIBIT_ANY_CHANGE_AFFECTING_REDISPLAY, which is shorthand for | |
| 5009 various other flags). */ | |
| 5010 | |
| 5011 int | |
| 5012 set_trapping_problems_flags (int flags) | |
| 5013 { | |
| 5014 int new_inhibit_flags; | |
| 5015 | |
| 5016 if (flags & INHIBIT_ANY_CHANGE_AFFECTING_REDISPLAY) | |
| 5017 flags |= INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION | |
| 5018 | INHIBIT_EXISTING_BUFFER_TEXT_MODIFICATION | |
| 5019 | INHIBIT_ENTERING_DEBUGGER | |
| 5020 | INHIBIT_WARNING_ISSUE | |
| 5021 | INHIBIT_GC; | |
| 5022 | |
| 5023 new_inhibit_flags = inhibit_flags | flags; | |
| 5024 if (new_inhibit_flags != inhibit_flags) | |
| 5025 internal_bind_int (&inhibit_flags, new_inhibit_flags); | |
| 5026 | |
| 5027 if (flags & INHIBIT_QUIT) | |
| 5028 specbind (Qinhibit_quit, Qt); | |
| 5029 | |
| 5030 if (flags & UNINHIBIT_QUIT) | |
| 5031 begin_do_check_for_quit (); | |
| 5032 | |
| 5033 if (flags & INHIBIT_GC) | |
| 5034 begin_gc_forbidden (); | |
| 5035 | |
| 5036 /* #### If we have nested calls to call_trapping_problems(), and the | |
| 5037 inner one creates some buffers/etc., should the outer one be able | |
| 5038 to delete them? I think so, but it means we need to combine rather | |
| 5039 than just reset the value. */ | |
| 5040 if (flags & INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION) | |
| 5041 internal_bind_lisp_object (&Vdeletable_permanent_display_objects, Qnil); | |
| 5042 | |
| 5043 if (flags & INHIBIT_EXISTING_BUFFER_TEXT_MODIFICATION) | |
| 5044 internal_bind_lisp_object (&Vmodifiable_buffers, Qnil); | |
| 5045 | |
| 5046 return flags; | |
| 5047 } | |
| 5048 | |
| 853 | 5049 /* This is equivalent to (*fun) (arg), except that various conditions |
| 5050 can be trapped or inhibited, according to FLAGS. | |
| 5051 | |
| 5052 If FLAGS does not contain NO_INHIBIT_ERRORS, when an error occurs, | |
| 5053 the error is caught and a warning is issued, specifying the | |
| 5054 specific error that occurred and a backtrace. In that case, | |
| 5055 WARNING_STRING should be given, and will be printed at the | |
| 5056 beginning of the error to indicate where the error occurred. | |
| 5057 | |
| 5058 If FLAGS does not contain NO_INHIBIT_THROWS, all attempts to | |
| 5059 `throw' out of the function being called are trapped, and a warning | |
| 5060 issued. (Again, WARNING_STRING should be given.) | |
| 5061 | |
| 2367 | 5062 If FLAGS contains INHIBIT_WARNING_ISSUE, no warnings are issued; |
| 853 | 5063 this applies to recursive invocations of call_trapping_problems, too. |
| 5064 | |
| 1333 | 5065 If FLAGS contains POSTPONE_WARNING_ISSUE, no warnings are issued; |
| 5066 but values useful for generating a warning are still computed (in | |
| 5067 particular, the backtrace), so that the calling function can issue | |
| 5068 a warning. | |
| 5069 | |
| 853 | 5070 If FLAGS contains ISSUE_WARNINGS_AT_DEBUG_LEVEL, warnings will be |
| 5071 issued, but at level `debug', which normally is below the minimum | |
| 5072 specified by `log-warning-minimum-level', meaning such warnings will | |
| 5073 be ignored entirely. The user can change this variable, however, | |
| 5074 to see the warnings.) | |
| 5075 | |
| 5076 Note: If neither of NO_INHIBIT_THROWS or NO_INHIBIT_ERRORS is | |
| 5077 given, you are *guaranteed* that there will be no non-local exits | |
| 5078 out of this function. | |
| 5079 | |
| 5080 If FLAGS contains INHIBIT_QUIT, QUIT using C-g is inhibited. (This | |
| 5081 is *rarely* a good idea. Unless you use NO_INHIBIT_ERRORS, QUIT is | |
| 5082 automatically caught as well, and treated as an error; you can | |
| 5083 check for this using EQ (problems->error_conditions, Qquit). | |
| 5084 | |
| 5085 If FLAGS contains UNINHIBIT_QUIT, QUIT checking will be explicitly | |
| 5086 turned on. (It will abort the code being called, but will still be | |
| 5087 trapped and reported as an error, unless NO_INHIBIT_ERRORS is | |
| 5088 given.) This is useful when QUIT checking has been turned off by a | |
| 5089 higher-level caller. | |
| 5090 | |
| 5091 If FLAGS contains INHIBIT_GC, garbage collection is inhibited. | |
| 1123 | 5092 This is useful for Lisp called within redisplay, for example. |
| 853 | 5093 |
| 5094 If FLAGS contains INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION, | |
| 5095 Lisp code is not allowed to delete any window, buffers, frames, devices, | |
| 5096 or consoles that were already in existence at the time this function | |
| 5097 was called. (However, it's perfectly legal for code to create a new | |
| 5098 buffer and then delete it.) | |
| 5099 | |
| 5100 #### It might be useful to have a flag that inhibits deletion of a | |
| 5101 specific permanent display object and everything it's attached to | |
| 5102 (e.g. a window, and the buffer, frame, device, and console it's | |
| 5103 attached to. | |
| 5104 | |
| 5105 If FLAGS contains INHIBIT_EXISTING_BUFFER_TEXT_MODIFICATION, Lisp | |
| 5106 code is not allowed to modify the text of any buffers that were | |
| 5107 already in existence at the time this function was called. | |
| 5108 (However, it's perfectly legal for code to create a new buffer and | |
| 5109 then modify its text.) | |
| 5110 | |
| 5111 [These last two flags are implemented using global variables | |
| 5112 Vdeletable_permanent_display_objects and Vmodifiable_buffers, | |
| 5113 which keep track of a list of all buffers or permanent display | |
| 5114 objects created since the last time one of these flags was set. | |
| 5115 The code that deletes buffers, etc. and modifies buffers checks | |
| 5116 | |
| 5117 (1) if the corresponding flag is set (through the global variable | |
| 5118 inhibit_flags or its accessor function get_inhibit_flags()), and | |
| 5119 | |
| 5120 (2) if the object to be modified or deleted is not in the | |
| 5121 appropriate list. | |
| 5122 | |
| 5123 If so, it signals an error. | |
| 5124 | |
| 5125 Recursive calls to call_trapping_problems() are allowed. In | |
| 5126 the case of the two flags mentioned above, the current values | |
| 5127 of the global variables are stored in an unwind-protect, and | |
| 5128 they're reset to nil.] | |
| 5129 | |
| 5130 If FLAGS contains INHIBIT_ENTERING_DEBUGGER, the debugger will not | |
| 5131 be entered if an error occurs inside the Lisp code being called, | |
| 5132 even when the user has requested an error. In such case, a warning | |
| 5133 is issued stating that access to the debugger is denied, unless | |
| 5134 INHIBIT_WARNING_ISSUE has also been supplied. This is useful when | |
| 5135 calling Lisp code inside redisplay, in menu callbacks, etc. because | |
| 5136 in such cases either the display is in an inconsistent state or | |
| 5137 doing window operations is explicitly forbidden by the OS, and the | |
| 5138 debugger would causes visual changes on the screen and might create | |
| 5139 another frame. | |
| 5140 | |
| 5141 If FLAGS contains INHIBIT_ANY_CHANGE_AFFECTING_REDISPLAY, no | |
| 5142 changes of any sort to extents, faces, glyphs, buffer text, | |
| 5143 specifiers relating to display, other variables relating to | |
| 5144 display, splitting, deleting, or resizing windows or frames, | |
| 5145 deleting buffers, windows, frames, devices, or consoles, etc. is | |
| 5146 allowed. This is for things called absolutely in the middle of | |
| 5147 redisplay, which expects things to be *exactly* the same after the | |
| 5148 call as before. This isn't completely implemented and needs to be | |
| 5149 thought out some more to determine exactly what its semantics are. | |
| 5150 For the moment, turning on this flag also turns on | |
| 5151 | |
| 5152 INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION | |
| 5153 INHIBIT_EXISTING_BUFFER_TEXT_MODIFICATION | |
| 5154 INHIBIT_ENTERING_DEBUGGER | |
| 5155 INHIBIT_WARNING_ISSUE | |
| 5156 INHIBIT_GC | |
| 5157 | |
| 5158 #### The following five flags are defined, but unimplemented: | |
| 5159 | |
| 5160 #define INHIBIT_EXISTING_CODING_SYSTEM_DELETION (1<<6) | |
| 5161 #define INHIBIT_EXISTING_CHARSET_DELETION (1<<7) | |
| 5162 #define INHIBIT_PERMANENT_DISPLAY_OBJECT_CREATION (1<<8) | |
| 5163 #define INHIBIT_CODING_SYSTEM_CREATION (1<<9) | |
| 5164 #define INHIBIT_CHARSET_CREATION (1<<10) | |
| 5165 | |
| 5166 FLAGS containing CALL_WITH_SUSPENDED_ERRORS is a sign that | |
| 5167 call_with_suspended_errors() was invoked. This exists only for | |
| 5168 debugging purposes -- often we want to break when a signal happens, | |
| 5169 but ignore signals from call_with_suspended_errors(), because they | |
| 5170 occur often and for legitimate reasons. | |
| 5171 | |
| 5172 If PROBLEM is non-zero, it should be a pointer to a structure into | |
| 5173 which exact information about any occurring problems (either an | |
| 5174 error or an attempted throw past this boundary). | |
| 5175 | |
| 5176 If a problem occurred and aborted operation (error, quit, or | |
| 5177 invalid throw), Qunbound is returned. Otherwise the return value | |
| 5178 from the call to (*fun) (arg) is returned. */ | |
| 5179 | |
| 5180 Lisp_Object | |
| 5181 call_trapping_problems (Lisp_Object warning_class, | |
| 867 | 5182 const CIbyte *warning_string, |
| 853 | 5183 int flags, |
| 5184 struct call_trapping_problems_result *problem, | |
| 5185 Lisp_Object (*fun) (void *), | |
| 5186 void *arg) | |
| 5187 { | |
| 1318 | 5188 int speccount = specpdl_depth (); |
| 853 | 5189 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5; |
| 5190 struct call_trapping_problems package; | |
| 1333 | 5191 struct call_trapping_problems_result real_problem; |
| 2532 | 5192 Lisp_Object opaque, thrown_tag, tem, thrown_backtrace; |
| 853 | 5193 int thrown = 0; |
| 5194 | |
| 5195 assert (SYMBOLP (warning_class)); /* sanity-check */ | |
| 5196 assert (!NILP (warning_class)); | |
| 5197 | |
| 5198 flags ^= INTERNAL_INHIBIT_ERRORS | INTERNAL_INHIBIT_THROWS; | |
| 5199 | |
| 5200 package.warning_class = warning_class; | |
| 5201 package.warning_string = warning_string; | |
| 5202 package.fun = fun; | |
| 5203 package.arg = arg; | |
| 5204 package.catchtag = | |
| 5205 flags & INTERNAL_INHIBIT_THROWS ? Vcatch_everything_tag : | |
| 5206 flags & INTERNAL_INHIBIT_ERRORS ? make_opaque_ptr (0) : | |
| 5207 Qnil; | |
| 5208 package.error_conditions = Qnil; | |
| 5209 package.data = Qnil; | |
| 5210 package.backtrace = Qnil; | |
| 5211 | |
| 1318 | 5212 flags = set_trapping_problems_flags (flags); |
| 853 | 5213 |
| 5214 if (flags & (INTERNAL_INHIBIT_THROWS | INTERNAL_INHIBIT_ERRORS)) | |
| 5215 opaque = make_opaque_ptr (&package); | |
| 5216 else | |
| 5217 opaque = Qnil; | |
| 5218 | |
| 5219 GCPRO5 (package.catchtag, package.error_conditions, package.data, | |
| 5220 package.backtrace, opaque); | |
| 5221 | |
| 5222 if (flags & INTERNAL_INHIBIT_ERRORS) | |
| 5223 /* We need a catch so that our condition-handler can throw back here | |
| 5224 after printing the warning. (We print the warning in the stack | |
| 5225 context of the error, so we can get a backtrace.) */ | |
| 5226 tem = internal_catch (package.catchtag, call_trapping_problems_1, opaque, | |
| 2532 | 5227 &thrown, &thrown_tag, &thrown_backtrace); |
| 853 | 5228 else if (flags & INTERNAL_INHIBIT_THROWS) |
| 5229 /* We skip over the first wrapper, which traps errors. */ | |
| 5230 tem = internal_catch (package.catchtag, call_trapping_problems_2, opaque, | |
| 2532 | 5231 &thrown, &thrown_tag, &thrown_backtrace); |
| 853 | 5232 else |
| 5233 /* Nothing special. */ | |
| 5234 tem = (fun) (arg); | |
| 5235 | |
| 1333 | 5236 if (!problem) |
| 5237 problem = &real_problem; | |
| 5238 | |
| 5239 if (!thrown) | |
| 853 | 5240 { |
| 1333 | 5241 problem->caught_error = 0; |
| 5242 problem->caught_throw = 0; | |
| 5243 problem->error_conditions = Qnil; | |
| 5244 problem->data = Qnil; | |
| 5245 problem->backtrace = Qnil; | |
| 5246 problem->thrown_tag = Qnil; | |
| 5247 problem->thrown_value = Qnil; | |
| 853 | 5248 } |
| 1333 | 5249 else if (EQ (thrown_tag, package.catchtag)) |
| 853 | 5250 { |
| 1333 | 5251 problem->caught_error = 1; |
| 5252 problem->caught_throw = 0; | |
| 5253 problem->error_conditions = package.error_conditions; | |
| 5254 problem->data = package.data; | |
| 5255 problem->backtrace = package.backtrace; | |
| 5256 problem->thrown_tag = Qnil; | |
| 5257 problem->thrown_value = Qnil; | |
| 853 | 5258 } |
| 1333 | 5259 else |
| 5260 { | |
| 5261 problem->caught_error = 0; | |
| 5262 problem->caught_throw = 1; | |
| 5263 problem->error_conditions = Qnil; | |
| 5264 problem->data = Qnil; | |
| 2532 | 5265 problem->backtrace = thrown_backtrace; |
| 1333 | 5266 problem->thrown_tag = thrown_tag; |
| 5267 problem->thrown_value = tem; | |
| 5268 } | |
| 5269 | |
| 5270 if (!(flags & INHIBIT_WARNING_ISSUE) && !(flags & POSTPONE_WARNING_ISSUE)) | |
| 5271 issue_call_trapping_problems_warning (warning_class, warning_string, | |
| 5272 problem); | |
| 853 | 5273 |
| 5274 if (!NILP (package.catchtag) && | |
| 5275 !EQ (package.catchtag, Vcatch_everything_tag)) | |
| 5276 free_opaque_ptr (package.catchtag); | |
| 5277 | |
| 5278 if (!NILP (opaque)) | |
| 5279 free_opaque_ptr (opaque); | |
| 5280 | |
| 5281 unbind_to (speccount); | |
| 5282 RETURN_UNGCPRO (thrown ? Qunbound : tem); | |
| 5283 } | |
| 5284 | |
| 5285 struct va_call_trapping_problems | |
| 5286 { | |
| 5287 lisp_fn_t fun; | |
| 5288 int nargs; | |
| 5289 Lisp_Object *args; | |
| 5290 }; | |
| 5291 | |
| 5292 static Lisp_Object | |
| 5293 va_call_trapping_problems_1 (void *ai_mi_madre) | |
| 5294 { | |
| 5295 struct va_call_trapping_problems *ai_no_corrida = | |
| 5296 (struct va_call_trapping_problems *) ai_mi_madre; | |
| 5297 Lisp_Object pegar_no_bumbum; | |
| 5298 | |
| 5299 PRIMITIVE_FUNCALL (pegar_no_bumbum, ai_no_corrida->fun, | |
| 5300 ai_no_corrida->args, ai_no_corrida->nargs); | |
| 5301 return pegar_no_bumbum; | |
| 5302 } | |
| 5303 | |
| 5304 /* #### document me. */ | |
| 5305 | |
| 5306 Lisp_Object | |
| 5307 va_call_trapping_problems (Lisp_Object warning_class, | |
| 867 | 5308 const CIbyte *warning_string, |
| 853 | 5309 int flags, |
| 5310 struct call_trapping_problems_result *problem, | |
| 5311 lisp_fn_t fun, int nargs, ...) | |
| 5312 { | |
| 5313 va_list vargs; | |
| 5314 Lisp_Object args[20]; | |
| 5315 int i; | |
| 5316 struct va_call_trapping_problems fazer_invocacao_atrapalhando_problemas; | |
| 5317 struct gcpro gcpro1; | |
| 5318 | |
| 5319 assert (nargs >= 0 && nargs < 20); | |
| 5320 | |
| 5321 va_start (vargs, nargs); | |
| 5322 for (i = 0; i < nargs; i++) | |
| 5323 args[i] = va_arg (vargs, Lisp_Object); | |
| 5324 va_end (vargs); | |
| 5325 | |
| 5326 fazer_invocacao_atrapalhando_problemas.fun = fun; | |
| 5327 fazer_invocacao_atrapalhando_problemas.nargs = nargs; | |
| 5328 fazer_invocacao_atrapalhando_problemas.args = args; | |
| 5329 | |
| 5330 GCPRO1_ARRAY (args, nargs); | |
| 5331 RETURN_UNGCPRO | |
| 5332 (call_trapping_problems | |
| 5333 (warning_class, warning_string, flags, problem, | |
| 5334 va_call_trapping_problems_1, &fazer_invocacao_atrapalhando_problemas)); | |
| 5335 } | |
| 5336 | |
| 5337 /* this is an older interface, barely different from | |
| 5338 va_call_trapping_problems. | |
| 5339 | |
| 5340 #### eliminate this or at least merge the ERROR_BEHAVIOR stuff into | |
| 5341 va_call_trapping_problems(). */ | |
| 5342 | |
| 5343 Lisp_Object | |
| 5344 call_with_suspended_errors (lisp_fn_t fun, Lisp_Object retval, | |
| 1204 | 5345 Lisp_Object class_, Error_Behavior errb, |
| 853 | 5346 int nargs, ...) |
| 5347 { | |
| 5348 va_list vargs; | |
| 5349 Lisp_Object args[20]; | |
| 5350 int i; | |
| 5351 struct va_call_trapping_problems fazer_invocacao_atrapalhando_problemas; | |
| 5352 int flags; | |
| 5353 struct gcpro gcpro1; | |
| 5354 | |
| 1204 | 5355 assert (SYMBOLP (class_)); /* sanity-check */ |
| 5356 assert (!NILP (class_)); | |
| 853 | 5357 assert (nargs >= 0 && nargs < 20); |
| 5358 | |
| 5359 va_start (vargs, nargs); | |
| 5360 for (i = 0; i < nargs; i++) | |
| 5361 args[i] = va_arg (vargs, Lisp_Object); | |
| 5362 va_end (vargs); | |
| 5363 | |
| 5364 /* If error-checking is not disabled, just call the function. */ | |
| 5365 | |
| 5366 if (ERRB_EQ (errb, ERROR_ME)) | |
| 5367 { | |
| 5368 Lisp_Object val; | |
| 5369 PRIMITIVE_FUNCALL (val, fun, args, nargs); | |
| 5370 return val; | |
| 5371 } | |
| 5372 | |
| 5373 if (ERRB_EQ (errb, ERROR_ME_NOT)) /* person wants no warnings */ | |
| 5374 flags = INHIBIT_WARNING_ISSUE | INHIBIT_ENTERING_DEBUGGER; | |
| 5375 else if (ERRB_EQ (errb, ERROR_ME_DEBUG_WARN)) | |
| 5376 flags = ISSUE_WARNINGS_AT_DEBUG_LEVEL | INHIBIT_ENTERING_DEBUGGER; | |
| 5377 else | |
| 5378 { | |
| 5379 assert (ERRB_EQ (errb, ERROR_ME_WARN)); | |
| 5380 flags = INHIBIT_ENTERING_DEBUGGER; | |
| 5381 } | |
| 5382 | |
| 5383 flags |= CALL_WITH_SUSPENDED_ERRORS; | |
| 5384 | |
| 5385 fazer_invocacao_atrapalhando_problemas.fun = fun; | |
| 5386 fazer_invocacao_atrapalhando_problemas.nargs = nargs; | |
| 5387 fazer_invocacao_atrapalhando_problemas.args = args; | |
| 5388 | |
| 5389 GCPRO1_ARRAY (args, nargs); | |
| 5390 { | |
| 5391 Lisp_Object its_way_too_goddamn_late = | |
| 5392 call_trapping_problems | |
| 1204 | 5393 (class_, 0, flags, 0, va_call_trapping_problems_1, |
| 853 | 5394 &fazer_invocacao_atrapalhando_problemas); |
| 5395 UNGCPRO; | |
| 5396 if (UNBOUNDP (its_way_too_goddamn_late)) | |
| 5397 return retval; | |
| 5398 else | |
| 5399 return its_way_too_goddamn_late; | |
| 5400 } | |
| 5401 } | |
| 5402 | |
| 5403 struct calln_trapping_problems | |
| 5404 { | |
| 5405 int nargs; | |
| 5406 Lisp_Object *args; | |
| 5407 }; | |
| 5408 | |
| 5409 static Lisp_Object | |
| 5410 calln_trapping_problems_1 (void *puta) | |
| 5411 { | |
| 5412 struct calln_trapping_problems *p = (struct calln_trapping_problems *) puta; | |
| 5413 | |
| 5414 return Ffuncall (p->nargs, p->args); | |
| 428 | 5415 } |
| 5416 | |
| 5417 static Lisp_Object | |
| 853 | 5418 calln_trapping_problems (Lisp_Object warning_class, |
| 867 | 5419 const CIbyte *warning_string, int flags, |
| 853 | 5420 struct call_trapping_problems_result *problem, |
| 5421 int nargs, Lisp_Object *args) | |
| 5422 { | |
| 5423 struct calln_trapping_problems foo; | |
| 5424 struct gcpro gcpro1; | |
| 5425 | |
| 5426 if (SYMBOLP (args[0])) | |
| 5427 { | |
| 5428 Lisp_Object tem = XSYMBOL (args[0])->function; | |
| 5429 if (NILP (tem) || UNBOUNDP (tem)) | |
| 5430 { | |
| 5431 if (problem) | |
| 5432 { | |
| 5433 problem->caught_error = 0; | |
| 5434 problem->caught_throw = 0; | |
| 5435 problem->error_conditions = Qnil; | |
| 5436 problem->data = Qnil; | |
| 5437 problem->backtrace = Qnil; | |
| 5438 problem->thrown_tag = Qnil; | |
| 5439 problem->thrown_value = Qnil; | |
| 5440 } | |
| 5441 return Qnil; | |
| 5442 } | |
| 5443 } | |
| 5444 | |
| 5445 foo.nargs = nargs; | |
| 5446 foo.args = args; | |
| 5447 | |
| 5448 GCPRO1_ARRAY (args, nargs); | |
| 5449 RETURN_UNGCPRO (call_trapping_problems (warning_class, warning_string, | |
| 5450 flags, problem, | |
| 5451 calln_trapping_problems_1, | |
| 5452 &foo)); | |
| 5453 } | |
| 5454 | |
| 5455 /* #### fix these functions to follow the calling convention of | |
| 5456 call_trapping_problems! */ | |
| 5457 | |
| 5458 Lisp_Object | |
| 867 | 5459 call0_trapping_problems (const CIbyte *warning_string, Lisp_Object function, |
| 853 | 5460 int flags) |
| 5461 { | |
| 5462 return calln_trapping_problems (Qerror, warning_string, flags, 0, 1, | |
| 5463 &function); | |
| 428 | 5464 } |
| 5465 | |
| 5466 Lisp_Object | |
| 867 | 5467 call1_trapping_problems (const CIbyte *warning_string, Lisp_Object function, |
| 853 | 5468 Lisp_Object object, int flags) |
| 5469 { | |
| 5470 Lisp_Object args[2]; | |
| 5471 | |
| 5472 args[0] = function; | |
| 5473 args[1] = object; | |
| 5474 | |
| 5475 return calln_trapping_problems (Qerror, warning_string, flags, 0, 2, | |
| 5476 args); | |
| 5477 } | |
| 5478 | |
| 5479 Lisp_Object | |
| 867 | 5480 call2_trapping_problems (const CIbyte *warning_string, Lisp_Object function, |
| 853 | 5481 Lisp_Object object1, Lisp_Object object2, |
| 5482 int flags) | |
| 5483 { | |
| 5484 Lisp_Object args[3]; | |
| 5485 | |
| 5486 args[0] = function; | |
| 5487 args[1] = object1; | |
| 5488 args[2] = object2; | |
| 5489 | |
| 5490 return calln_trapping_problems (Qerror, warning_string, flags, 0, 3, | |
| 5491 args); | |
| 5492 } | |
| 5493 | |
| 5494 Lisp_Object | |
| 867 | 5495 call3_trapping_problems (const CIbyte *warning_string, Lisp_Object function, |
| 853 | 5496 Lisp_Object object1, Lisp_Object object2, |
| 5497 Lisp_Object object3, int flags) | |
| 5498 { | |
| 5499 Lisp_Object args[4]; | |
| 5500 | |
| 5501 args[0] = function; | |
| 5502 args[1] = object1; | |
| 5503 args[2] = object2; | |
| 5504 args[3] = object3; | |
| 5505 | |
| 5506 return calln_trapping_problems (Qerror, warning_string, flags, 0, 4, | |
| 5507 args); | |
| 5508 } | |
| 5509 | |
| 5510 Lisp_Object | |
| 867 | 5511 call4_trapping_problems (const CIbyte *warning_string, Lisp_Object function, |
| 853 | 5512 Lisp_Object object1, Lisp_Object object2, |
| 5513 Lisp_Object object3, Lisp_Object object4, | |
| 5514 int flags) | |
| 5515 { | |
| 5516 Lisp_Object args[5]; | |
| 5517 | |
| 5518 args[0] = function; | |
| 5519 args[1] = object1; | |
| 5520 args[2] = object2; | |
| 5521 args[3] = object3; | |
| 5522 args[4] = object4; | |
| 5523 | |
| 5524 return calln_trapping_problems (Qerror, warning_string, flags, 0, 5, | |
| 5525 args); | |
| 5526 } | |
| 5527 | |
| 5528 Lisp_Object | |
| 867 | 5529 call5_trapping_problems (const CIbyte *warning_string, Lisp_Object function, |
| 853 | 5530 Lisp_Object object1, Lisp_Object object2, |
| 5531 Lisp_Object object3, Lisp_Object object4, | |
| 5532 Lisp_Object object5, int flags) | |
| 5533 { | |
| 5534 Lisp_Object args[6]; | |
| 5535 | |
| 5536 args[0] = function; | |
| 5537 args[1] = object1; | |
| 5538 args[2] = object2; | |
| 5539 args[3] = object3; | |
| 5540 args[4] = object4; | |
| 5541 args[5] = object5; | |
| 5542 | |
| 5543 return calln_trapping_problems (Qerror, warning_string, flags, 0, 6, | |
| 5544 args); | |
| 5545 } | |
| 5546 | |
| 5547 struct eval_in_buffer_trapping_problems | |
| 5548 { | |
| 5549 struct buffer *buf; | |
| 5550 Lisp_Object form; | |
| 5551 }; | |
| 5552 | |
| 5553 static Lisp_Object | |
| 5554 eval_in_buffer_trapping_problems_1 (void *arg) | |
| 5555 { | |
| 5556 struct eval_in_buffer_trapping_problems *p = | |
| 5557 (struct eval_in_buffer_trapping_problems *) arg; | |
| 5558 | |
| 5559 return eval_in_buffer (p->buf, p->form); | |
| 5560 } | |
| 5561 | |
| 5562 /* #### fix these functions to follow the calling convention of | |
| 5563 call_trapping_problems! */ | |
| 5564 | |
| 5565 Lisp_Object | |
| 867 | 5566 eval_in_buffer_trapping_problems (const CIbyte *warning_string, |
| 853 | 5567 struct buffer *buf, Lisp_Object form, |
| 5568 int flags) | |
| 5569 { | |
| 5570 struct eval_in_buffer_trapping_problems p; | |
| 5571 Lisp_Object buffer = wrap_buffer (buf); | |
| 428 | 5572 struct gcpro gcpro1, gcpro2; |
| 5573 | |
| 853 | 5574 GCPRO2 (buffer, form); |
| 5575 p.buf = buf; | |
| 5576 p.form = form; | |
| 5577 RETURN_UNGCPRO (call_trapping_problems (Qerror, warning_string, flags, 0, | |
| 5578 eval_in_buffer_trapping_problems_1, | |
| 5579 &p)); | |
| 5580 } | |
| 5581 | |
| 5582 Lisp_Object | |
| 1333 | 5583 run_hook_trapping_problems (Lisp_Object warning_class, |
| 853 | 5584 Lisp_Object hook_symbol, |
| 5585 int flags) | |
| 5586 { | |
| 1333 | 5587 return run_hook_with_args_trapping_problems (warning_class, 1, &hook_symbol, |
| 853 | 5588 RUN_HOOKS_TO_COMPLETION, |
| 5589 flags); | |
| 428 | 5590 } |
| 5591 | |
| 5592 static Lisp_Object | |
| 853 | 5593 safe_run_hook_trapping_problems_1 (void *puta) |
| 5594 { | |
| 5595 Lisp_Object hook = VOID_TO_LISP (puta); | |
| 5596 | |
| 5597 run_hook (hook); | |
| 428 | 5598 return Qnil; |
| 5599 } | |
| 5600 | |
| 853 | 5601 /* Same as run_hook_trapping_problems() but also set the hook to nil |
| 5602 if an error occurs (but not a quit). */ | |
| 5603 | |
| 428 | 5604 Lisp_Object |
| 1333 | 5605 safe_run_hook_trapping_problems (Lisp_Object warning_class, |
| 5606 Lisp_Object hook_symbol, int flags) | |
| 853 | 5607 { |
| 428 | 5608 Lisp_Object tem; |
| 853 | 5609 struct gcpro gcpro1, gcpro2; |
| 5610 struct call_trapping_problems_result prob; | |
| 428 | 5611 |
| 5612 if (!initialized || preparing_for_armageddon) | |
| 5613 return Qnil; | |
| 5614 tem = find_symbol_value (hook_symbol); | |
| 5615 if (NILP (tem) || UNBOUNDP (tem)) | |
| 5616 return Qnil; | |
| 5617 | |
| 853 | 5618 GCPRO2 (hook_symbol, tem); |
| 1333 | 5619 tem = call_trapping_problems (Qerror, NULL, |
| 5620 flags | POSTPONE_WARNING_ISSUE, | |
| 853 | 5621 &prob, |
| 5622 safe_run_hook_trapping_problems_1, | |
| 5623 LISP_TO_VOID (hook_symbol)); | |
| 1333 | 5624 { |
| 5625 Lisp_Object hook_name = XSYMBOL_NAME (hook_symbol); | |
| 5626 Ibyte *hook_str = XSTRING_DATA (hook_name); | |
| 5627 Ibyte *err = alloca_ibytes (XSTRING_LENGTH (hook_name) + 100); | |
| 5628 | |
| 5629 if (prob.caught_throw || (prob.caught_error && !EQ (prob.error_conditions, | |
| 5630 Qquit))) | |
| 5631 { | |
| 5632 Fset (hook_symbol, Qnil); | |
| 5633 qxesprintf (err, "Error in `%s' (resetting to nil)", hook_str); | |
| 5634 } | |
| 5635 else | |
| 5636 qxesprintf (err, "Quit in `%s'", hook_str); | |
| 5637 | |
| 5638 | |
| 5639 issue_call_trapping_problems_warning (warning_class, (CIbyte *) err, | |
| 5640 &prob); | |
| 5641 } | |
| 5642 | |
| 5643 UNGCPRO; | |
| 5644 return tem; | |
| 853 | 5645 } |
| 5646 | |
| 5647 struct run_hook_with_args_in_buffer_trapping_problems | |
| 5648 { | |
| 5649 struct buffer *buf; | |
| 5650 int nargs; | |
| 5651 Lisp_Object *args; | |
| 5652 enum run_hooks_condition cond; | |
| 5653 }; | |
| 5654 | |
| 5655 static Lisp_Object | |
| 5656 run_hook_with_args_in_buffer_trapping_problems_1 (void *puta) | |
| 5657 { | |
| 5658 struct run_hook_with_args_in_buffer_trapping_problems *porra = | |
| 5659 (struct run_hook_with_args_in_buffer_trapping_problems *) puta; | |
| 5660 | |
| 5661 return run_hook_with_args_in_buffer (porra->buf, porra->nargs, porra->args, | |
| 5662 porra->cond); | |
| 5663 } | |
| 5664 | |
| 5665 /* #### fix these functions to follow the calling convention of | |
| 5666 call_trapping_problems! */ | |
| 428 | 5667 |
| 5668 Lisp_Object | |
| 1333 | 5669 run_hook_with_args_in_buffer_trapping_problems (Lisp_Object warning_class, |
| 853 | 5670 struct buffer *buf, int nargs, |
| 5671 Lisp_Object *args, | |
| 5672 enum run_hooks_condition cond, | |
| 5673 int flags) | |
| 5674 { | |
| 5675 Lisp_Object sym, val, ret; | |
| 5676 struct run_hook_with_args_in_buffer_trapping_problems diversity_and_distrust; | |
| 428 | 5677 struct gcpro gcpro1; |
| 1333 | 5678 Lisp_Object hook_name; |
| 5679 Ibyte *hook_str; | |
| 5680 Ibyte *err; | |
| 428 | 5681 |
| 5682 if (!initialized || preparing_for_armageddon) | |
| 853 | 5683 /* We need to bail out of here pronto. */ |
| 428 | 5684 return Qnil; |
| 5685 | |
| 853 | 5686 GCPRO1_ARRAY (args, nargs); |
| 5687 | |
| 5688 sym = args[0]; | |
| 5689 val = symbol_value_in_buffer (sym, wrap_buffer (buf)); | |
| 5690 ret = (cond == RUN_HOOKS_UNTIL_FAILURE ? Qt : Qnil); | |
| 5691 | |
| 5692 if (UNBOUNDP (val) || NILP (val)) | |
| 5693 RETURN_UNGCPRO (ret); | |
| 5694 | |
| 5695 diversity_and_distrust.buf = buf; | |
| 5696 diversity_and_distrust.nargs = nargs; | |
| 5697 diversity_and_distrust.args = args; | |
| 5698 diversity_and_distrust.cond = cond; | |
| 5699 | |
| 1333 | 5700 hook_name = XSYMBOL_NAME (args[0]); |
| 5701 hook_str = XSTRING_DATA (hook_name); | |
| 5702 err = alloca_ibytes (XSTRING_LENGTH (hook_name) + 100); | |
| 5703 qxesprintf (err, "Error in `%s'", hook_str); | |
| 853 | 5704 RETURN_UNGCPRO |
| 5705 (call_trapping_problems | |
| 1333 | 5706 (warning_class, (CIbyte *) err, flags, 0, |
| 853 | 5707 run_hook_with_args_in_buffer_trapping_problems_1, |
| 5708 &diversity_and_distrust)); | |
| 428 | 5709 } |
| 5710 | |
| 5711 Lisp_Object | |
| 1333 | 5712 run_hook_with_args_trapping_problems (Lisp_Object warning_class, |
| 853 | 5713 int nargs, |
| 5714 Lisp_Object *args, | |
| 5715 enum run_hooks_condition cond, | |
| 5716 int flags) | |
| 5717 { | |
| 5718 return run_hook_with_args_in_buffer_trapping_problems | |
| 1333 | 5719 (warning_class, current_buffer, nargs, args, cond, flags); |
| 428 | 5720 } |
| 5721 | |
| 5722 Lisp_Object | |
| 1333 | 5723 va_run_hook_with_args_trapping_problems (Lisp_Object warning_class, |
| 853 | 5724 Lisp_Object hook_var, |
| 5725 int nargs, ...) | |
| 5726 { | |
| 5727 /* This function can GC */ | |
| 5728 struct gcpro gcpro1; | |
| 5729 int i; | |
| 5730 va_list vargs; | |
| 5731 Lisp_Object *funcall_args = alloca_array (Lisp_Object, 1 + nargs); | |
| 5732 int flags; | |
| 5733 | |
| 5734 va_start (vargs, nargs); | |
| 5735 funcall_args[0] = hook_var; | |
| 5736 for (i = 0; i < nargs; i++) | |
| 5737 funcall_args[i + 1] = va_arg (vargs, Lisp_Object); | |
| 5738 flags = va_arg (vargs, int); | |
| 5739 va_end (vargs); | |
| 5740 | |
| 5741 GCPRO1_ARRAY (funcall_args, nargs + 1); | |
| 5742 RETURN_UNGCPRO (run_hook_with_args_in_buffer_trapping_problems | |
| 1333 | 5743 (warning_class, current_buffer, nargs + 1, funcall_args, |
| 853 | 5744 RUN_HOOKS_TO_COMPLETION, flags)); |
| 428 | 5745 } |
| 5746 | |
| 5747 Lisp_Object | |
| 1333 | 5748 va_run_hook_with_args_in_buffer_trapping_problems (Lisp_Object warning_class, |
| 853 | 5749 struct buffer *buf, |
| 5750 Lisp_Object hook_var, | |
| 5751 int nargs, ...) | |
| 5752 { | |
| 5753 /* This function can GC */ | |
| 5754 struct gcpro gcpro1; | |
| 5755 int i; | |
| 5756 va_list vargs; | |
| 5757 Lisp_Object *funcall_args = alloca_array (Lisp_Object, 1 + nargs); | |
| 5758 int flags; | |
| 5759 | |
| 5760 va_start (vargs, nargs); | |
| 5761 funcall_args[0] = hook_var; | |
| 5762 for (i = 0; i < nargs; i++) | |
| 5763 funcall_args[i + 1] = va_arg (vargs, Lisp_Object); | |
| 5764 flags = va_arg (vargs, int); | |
| 5765 va_end (vargs); | |
| 5766 | |
| 5767 GCPRO1_ARRAY (funcall_args, nargs + 1); | |
| 5768 RETURN_UNGCPRO (run_hook_with_args_in_buffer_trapping_problems | |
| 1333 | 5769 (warning_class, buf, nargs + 1, funcall_args, |
| 853 | 5770 RUN_HOOKS_TO_COMPLETION, flags)); |
| 428 | 5771 } |
| 5772 | |
| 5773 | |
| 5774 /************************************************************************/ | |
| 5775 /* The special binding stack */ | |
| 771 | 5776 /* Most C code should simply use specbind() and unbind_to_1(). */ |
| 428 | 5777 /* When performance is critical, use the macros in backtrace.h. */ |
| 5778 /************************************************************************/ | |
| 5779 | |
| 5780 #define min_max_specpdl_size 400 | |
| 5781 | |
| 5782 void | |
| 647 | 5783 grow_specpdl (EMACS_INT reserved) |
| 5784 { | |
| 5785 EMACS_INT size_needed = specpdl_depth() + reserved; | |
| 428 | 5786 if (size_needed >= max_specpdl_size) |
| 5787 { | |
| 5788 if (max_specpdl_size < min_max_specpdl_size) | |
| 5789 max_specpdl_size = min_max_specpdl_size; | |
| 5790 if (size_needed >= max_specpdl_size) | |
| 5791 { | |
| 1951 | 5792 /* Leave room for some specpdl in the debugger. */ |
| 5793 max_specpdl_size = size_needed + 100; | |
| 5794 if (max_specpdl_size > specpdl_size) | |
| 5795 { | |
| 5796 specpdl_size = max_specpdl_size; | |
| 5797 XREALLOC_ARRAY (specpdl, struct specbinding, specpdl_size); | |
| 5798 specpdl_ptr = specpdl + specpdl_depth(); | |
| 5799 } | |
| 563 | 5800 signal_continuable_error |
| 5801 (Qstack_overflow, | |
| 5802 "Variable binding depth exceeds max-specpdl-size", Qunbound); | |
| 428 | 5803 } |
| 5804 } | |
| 5805 while (specpdl_size < size_needed) | |
| 5806 { | |
| 5807 specpdl_size *= 2; | |
| 5808 if (specpdl_size > max_specpdl_size) | |
| 5809 specpdl_size = max_specpdl_size; | |
| 5810 } | |
| 5811 XREALLOC_ARRAY (specpdl, struct specbinding, specpdl_size); | |
| 5812 specpdl_ptr = specpdl + specpdl_depth(); | |
| 853 | 5813 check_specbind_stack_sanity (); |
| 428 | 5814 } |
| 5815 | |
| 5816 | |
| 5817 /* Handle unbinding buffer-local variables */ | |
| 5818 static Lisp_Object | |
| 5819 specbind_unwind_local (Lisp_Object ovalue) | |
| 5820 { | |
| 5821 Lisp_Object current = Fcurrent_buffer (); | |
| 5822 Lisp_Object symbol = specpdl_ptr->symbol; | |
| 853 | 5823 Lisp_Object victim = ovalue; |
| 5824 Lisp_Object buf = get_buffer (XCAR (victim), 0); | |
| 5825 ovalue = XCDR (victim); | |
| 428 | 5826 |
| 5827 free_cons (victim); | |
| 5828 | |
| 5829 if (NILP (buf)) | |
| 5830 { | |
| 5831 /* Deleted buffer -- do nothing */ | |
| 5832 } | |
| 5833 else if (symbol_value_buffer_local_info (symbol, XBUFFER (buf)) == 0) | |
| 5834 { | |
| 5835 /* Was buffer-local when binding was made, now no longer is. | |
| 5836 * (kill-local-variable can do this.) | |
| 5837 * Do nothing in this case. | |
| 5838 */ | |
| 5839 } | |
| 5840 else if (EQ (buf, current)) | |
| 5841 Fset (symbol, ovalue); | |
| 5842 else | |
| 5843 { | |
| 5844 /* Urk! Somebody switched buffers */ | |
| 5845 struct gcpro gcpro1; | |
| 5846 GCPRO1 (current); | |
| 5847 Fset_buffer (buf); | |
| 5848 Fset (symbol, ovalue); | |
| 5849 Fset_buffer (current); | |
| 5850 UNGCPRO; | |
| 5851 } | |
| 5852 return symbol; | |
| 5853 } | |
| 5854 | |
| 5855 static Lisp_Object | |
| 5856 specbind_unwind_wasnt_local (Lisp_Object buffer) | |
| 5857 { | |
| 5858 Lisp_Object current = Fcurrent_buffer (); | |
| 5859 Lisp_Object symbol = specpdl_ptr->symbol; | |
| 5860 | |
| 5861 buffer = get_buffer (buffer, 0); | |
| 5862 if (NILP (buffer)) | |
| 5863 { | |
| 5864 /* Deleted buffer -- do nothing */ | |
| 5865 } | |
| 5866 else if (symbol_value_buffer_local_info (symbol, XBUFFER (buffer)) == 0) | |
| 5867 { | |
| 5868 /* Was buffer-local when binding was made, now no longer is. | |
| 5869 * (kill-local-variable can do this.) | |
| 5870 * Do nothing in this case. | |
| 5871 */ | |
| 5872 } | |
| 5873 else if (EQ (buffer, current)) | |
| 5874 Fkill_local_variable (symbol); | |
| 5875 else | |
| 5876 { | |
| 5877 /* Urk! Somebody switched buffers */ | |
| 5878 struct gcpro gcpro1; | |
| 5879 GCPRO1 (current); | |
| 5880 Fset_buffer (buffer); | |
| 5881 Fkill_local_variable (symbol); | |
| 5882 Fset_buffer (current); | |
| 5883 UNGCPRO; | |
| 5884 } | |
| 5885 return symbol; | |
| 5886 } | |
| 5887 | |
| 5888 | |
| 5889 void | |
| 5890 specbind (Lisp_Object symbol, Lisp_Object value) | |
| 5891 { | |
| 5892 SPECBIND (symbol, value); | |
| 853 | 5893 |
| 5894 check_specbind_stack_sanity (); | |
| 428 | 5895 } |
| 5896 | |
| 5897 void | |
| 5898 specbind_magic (Lisp_Object symbol, Lisp_Object value) | |
| 5899 { | |
| 5900 int buffer_local = | |
| 5901 symbol_value_buffer_local_info (symbol, current_buffer); | |
| 5902 | |
| 5903 if (buffer_local == 0) | |
| 5904 { | |
| 5905 specpdl_ptr->old_value = find_symbol_value (symbol); | |
| 771 | 5906 specpdl_ptr->func = 0; /* Handled specially by unbind_to_1 */ |
| 428 | 5907 } |
| 5908 else if (buffer_local > 0) | |
| 5909 { | |
| 5910 /* Already buffer-local */ | |
| 5911 specpdl_ptr->old_value = noseeum_cons (Fcurrent_buffer (), | |
| 5912 find_symbol_value (symbol)); | |
| 5913 specpdl_ptr->func = specbind_unwind_local; | |
| 5914 } | |
| 5915 else | |
| 5916 { | |
| 5917 /* About to become buffer-local */ | |
| 5918 specpdl_ptr->old_value = Fcurrent_buffer (); | |
| 5919 specpdl_ptr->func = specbind_unwind_wasnt_local; | |
| 5920 } | |
| 5921 | |
| 5922 specpdl_ptr->symbol = symbol; | |
| 5923 specpdl_ptr++; | |
| 5924 specpdl_depth_counter++; | |
| 5925 | |
| 5926 Fset (symbol, value); | |
| 853 | 5927 |
| 5928 check_specbind_stack_sanity (); | |
| 428 | 5929 } |
| 5930 | |
| 771 | 5931 /* Record an unwind-protect -- FUNCTION will be called with ARG no matter |
| 5932 whether a normal or non-local exit occurs. (You need to call unbind_to_1() | |
| 5933 before your function returns normally, passing in the integer returned | |
| 5934 by this function.) Note: As long as the unwind-protect exists, ARG is | |
| 5935 automatically GCPRO'd. The return value from FUNCTION is completely | |
| 5936 ignored. #### We should eliminate it entirely. */ | |
| 5937 | |
| 5938 int | |
| 428 | 5939 record_unwind_protect (Lisp_Object (*function) (Lisp_Object arg), |
| 5940 Lisp_Object arg) | |
| 5941 { | |
| 5942 SPECPDL_RESERVE (1); | |
| 5943 specpdl_ptr->func = function; | |
| 5944 specpdl_ptr->symbol = Qnil; | |
| 5945 specpdl_ptr->old_value = arg; | |
| 5946 specpdl_ptr++; | |
| 5947 specpdl_depth_counter++; | |
| 853 | 5948 check_specbind_stack_sanity (); |
| 771 | 5949 return specpdl_depth_counter - 1; |
| 5950 } | |
| 5951 | |
| 5952 static Lisp_Object | |
| 802 | 5953 restore_lisp_object (Lisp_Object cons) |
| 5954 { | |
| 5955 Lisp_Object opaque = XCAR (cons); | |
| 5956 Lisp_Object *addr = (Lisp_Object *) get_opaque_ptr (opaque); | |
| 5957 *addr = XCDR (cons); | |
| 5958 free_opaque_ptr (opaque); | |
| 853 | 5959 free_cons (cons); |
| 802 | 5960 return Qnil; |
| 5961 } | |
| 5962 | |
| 5963 /* Establish an unwind-protect which will restore the Lisp_Object pointed to | |
| 5964 by ADDR with the value VAL. */ | |
| 814 | 5965 static int |
| 802 | 5966 record_unwind_protect_restoring_lisp_object (Lisp_Object *addr, |
| 5967 Lisp_Object val) | |
| 5968 { | |
| 5969 Lisp_Object opaque = make_opaque_ptr (addr); | |
| 5970 return record_unwind_protect (restore_lisp_object, | |
| 5971 noseeum_cons (opaque, val)); | |
| 5972 } | |
| 5973 | |
| 5974 /* Similar to specbind() but for any C variable whose value is a | |
| 5975 Lisp_Object. Sets up an unwind-protect to restore the variable | |
| 5976 pointed to by ADDR to its existing value, and then changes its | |
| 5977 value to NEWVAL. Returns the previous value of specpdl_depth(); | |
| 5978 pass this to unbind_to() after you are done. */ | |
| 5979 int | |
| 5980 internal_bind_lisp_object (Lisp_Object *addr, Lisp_Object newval) | |
| 5981 { | |
| 5982 int count = specpdl_depth (); | |
| 5983 record_unwind_protect_restoring_lisp_object (addr, *addr); | |
| 5984 *addr = newval; | |
| 5985 return count; | |
| 5986 } | |
| 5987 | |
| 5988 static Lisp_Object | |
| 5989 restore_int (Lisp_Object cons) | |
| 5990 { | |
| 5991 Lisp_Object opaque = XCAR (cons); | |
| 5992 Lisp_Object lval = XCDR (cons); | |
| 5993 int *addr = (int *) get_opaque_ptr (opaque); | |
| 5994 int val; | |
| 5995 | |
| 4025 | 5996 /* In the event that a C integer will always fit in an Emacs int, we |
| 5997 haven't ever stored a C integer as an opaque pointer. This #ifdef | |
| 5998 eliminates a warning on AMD 64, where EMACS_INT has 63 value bits and C | |
| 5999 integers have 32 value bits. */ | |
| 6000 #if INT_VALBITS < INTBITS | |
| 802 | 6001 if (INTP (lval)) |
| 4025 | 6002 { |
| 6003 val = XINT (lval); | |
| 6004 } | |
| 802 | 6005 else |
| 6006 { | |
| 6007 val = (int) get_opaque_ptr (lval); | |
| 6008 free_opaque_ptr (lval); | |
| 6009 } | |
| 4025 | 6010 #else /* !(INT_VALBITS < INTBITS) */ |
| 6011 val = XINT(lval); | |
| 6012 #endif /* INT_VALBITS < INTBITS */ | |
| 802 | 6013 |
| 6014 *addr = val; | |
| 6015 free_opaque_ptr (opaque); | |
| 853 | 6016 free_cons (cons); |
| 802 | 6017 return Qnil; |
| 6018 } | |
| 6019 | |
| 6020 /* Establish an unwind-protect which will restore the int pointed to | |
| 6021 by ADDR with the value VAL. This function works correctly with | |
| 6022 all ints, even those that don't fit into a Lisp integer. */ | |
| 1333 | 6023 int |
| 802 | 6024 record_unwind_protect_restoring_int (int *addr, int val) |
| 6025 { | |
| 6026 Lisp_Object opaque = make_opaque_ptr (addr); | |
| 6027 Lisp_Object lval; | |
| 6028 | |
| 4025 | 6029 /* In the event that a C integer will always fit in an Emacs int, we don't |
| 6030 ever want to store a C integer as an opaque pointer. This #ifdef | |
| 6031 eliminates a warning on AMD 64, where EMACS_INT has 63 value bits and C | |
| 6032 integers have 32 value bits. */ | |
| 6033 #if INT_VALBITS <= INTBITS | |
| 802 | 6034 if (NUMBER_FITS_IN_AN_EMACS_INT (val)) |
| 6035 lval = make_int (val); | |
| 6036 else | |
| 6037 lval = make_opaque_ptr ((void *) val); | |
| 4025 | 6038 #else /* !(INT_VALBITS < INTBITS) */ |
| 6039 lval = make_int (val); | |
| 6040 #endif /* INT_VALBITS <= INTBITS */ | |
| 6041 | |
| 802 | 6042 return record_unwind_protect (restore_int, noseeum_cons (opaque, lval)); |
| 6043 } | |
| 6044 | |
| 6045 /* Similar to specbind() but for any C variable whose value is an int. | |
| 6046 Sets up an unwind-protect to restore the variable pointed to by | |
| 6047 ADDR to its existing value, and then changes its value to NEWVAL. | |
| 6048 Returns the previous value of specpdl_depth(); pass this to | |
| 6049 unbind_to() after you are done. This function works correctly with | |
| 6050 all ints, even those that don't fit into a Lisp integer. */ | |
| 6051 int | |
| 6052 internal_bind_int (int *addr, int newval) | |
| 6053 { | |
| 6054 int count = specpdl_depth (); | |
| 6055 record_unwind_protect_restoring_int (addr, *addr); | |
| 6056 *addr = newval; | |
| 6057 return count; | |
| 6058 } | |
| 6059 | |
| 6060 static Lisp_Object | |
| 771 | 6061 free_pointer (Lisp_Object opaque) |
| 6062 { | |
| 1726 | 6063 xfree (get_opaque_ptr (opaque), void *); |
| 771 | 6064 free_opaque_ptr (opaque); |
| 6065 return Qnil; | |
| 6066 } | |
| 6067 | |
| 6068 /* Establish an unwind-protect which will free the specified block. | |
| 6069 */ | |
| 6070 int | |
| 6071 record_unwind_protect_freeing (void *ptr) | |
| 6072 { | |
| 6073 Lisp_Object opaque = make_opaque_ptr (ptr); | |
| 6074 return record_unwind_protect (free_pointer, opaque); | |
| 6075 } | |
| 6076 | |
| 6077 static Lisp_Object | |
| 6078 free_dynarr (Lisp_Object opaque) | |
| 6079 { | |
| 6080 Dynarr_free (get_opaque_ptr (opaque)); | |
| 6081 free_opaque_ptr (opaque); | |
| 6082 return Qnil; | |
| 6083 } | |
| 6084 | |
| 6085 int | |
| 6086 record_unwind_protect_freeing_dynarr (void *ptr) | |
| 6087 { | |
| 6088 Lisp_Object opaque = make_opaque_ptr (ptr); | |
| 6089 return record_unwind_protect (free_dynarr, opaque); | |
| 6090 } | |
| 428 | 6091 |
| 6092 /* Unwind the stack till specpdl_depth() == COUNT. | |
| 6093 VALUE is not used, except that, purely as a convenience to the | |
| 771 | 6094 caller, it is protected from garbage-protection and returned. */ |
| 428 | 6095 Lisp_Object |
| 771 | 6096 unbind_to_1 (int count, Lisp_Object value) |
| 428 | 6097 { |
| 6098 UNBIND_TO_GCPRO (count, value); | |
| 853 | 6099 check_specbind_stack_sanity (); |
| 428 | 6100 return value; |
| 6101 } | |
| 6102 | |
| 6103 /* Don't call this directly. | |
| 6104 Only for use by UNBIND_TO* macros in backtrace.h */ | |
| 6105 void | |
| 6106 unbind_to_hairy (int count) | |
| 6107 { | |
| 442 | 6108 ++specpdl_ptr; |
| 6109 ++specpdl_depth_counter; | |
| 6110 | |
| 428 | 6111 while (specpdl_depth_counter != count) |
| 6112 { | |
| 1313 | 6113 Lisp_Object oquit = Qunbound; |
| 6114 | |
| 6115 /* Do this check BEFORE decrementing the values below, because once | |
| 6116 they're decremented, GC protection is lost on | |
| 6117 specpdl_ptr->old_value. */ | |
| 1322 | 6118 if (specpdl_ptr[-1].func == Fprogn) |
| 1313 | 6119 { |
| 6120 /* Allow QUIT within unwind-protect routines, but defer any | |
| 6121 existing QUIT until afterwards. Only do this, however, for | |
| 6122 unwind-protects established by Lisp code, not by C code | |
| 6123 (e.g. free_opaque_ptr() or something), because the act of | |
| 6124 checking for QUIT can cause all sorts of weird things to | |
| 6125 happen, since it churns the event loop -- redisplay, running | |
| 6126 Lisp, etc. Code should not have to worry about this just | |
| 6127 because of establishing an unwind-protect. */ | |
| 6128 check_quit (); /* make Vquit_flag accurate */ | |
| 6129 oquit = Vquit_flag; | |
| 6130 Vquit_flag = Qnil; | |
| 6131 } | |
| 6132 | |
| 428 | 6133 --specpdl_ptr; |
| 6134 --specpdl_depth_counter; | |
| 6135 | |
| 1313 | 6136 /* #### At this point, there is no GC protection on old_value. This |
| 6137 could be a real problem, depending on what unwind-protect function | |
| 6138 is called. It looks like it just so happens that the ones | |
| 6139 actually called don't have a problem with this, e.g. Fprogn. But | |
| 6140 we should look into fixing this. (Many unwind-protect functions | |
| 6141 free values. Is it a problem if freed values are | |
| 6142 GC-protected?) */ | |
| 428 | 6143 if (specpdl_ptr->func != 0) |
| 1313 | 6144 { |
| 6145 /* An unwind-protect */ | |
| 6146 (*specpdl_ptr->func) (specpdl_ptr->old_value); | |
| 6147 } | |
| 6148 | |
| 428 | 6149 else |
| 6150 { | |
| 6151 /* We checked symbol for validity when we specbound it, | |
| 6152 so only need to call Fset if symbol has magic value. */ | |
| 440 | 6153 Lisp_Symbol *sym = XSYMBOL (specpdl_ptr->symbol); |
| 428 | 6154 if (!SYMBOL_VALUE_MAGIC_P (sym->value)) |
| 6155 sym->value = specpdl_ptr->old_value; | |
| 6156 else | |
| 6157 Fset (specpdl_ptr->symbol, specpdl_ptr->old_value); | |
| 6158 } | |
| 6159 | |
| 6160 #if 0 /* martin */ | |
| 6161 #ifndef EXCEEDINGLY_QUESTIONABLE_CODE | |
| 6162 /* There should never be anything here for us to remove. | |
| 6163 If so, it indicates a logic error in Emacs. Catches | |
| 6164 should get removed when a throw or signal occurs, or | |
| 6165 when a catch or condition-case exits normally. But | |
| 6166 it's too dangerous to just remove this code. --ben */ | |
| 6167 | |
| 6168 /* Furthermore, this code is not in FSFmacs!!! | |
| 6169 Braino on mly's part? */ | |
| 6170 /* If we're unwound past the pdlcount of a catch frame, | |
| 6171 that catch can't possibly still be valid. */ | |
| 6172 while (catchlist && catchlist->pdlcount > specpdl_depth_counter) | |
| 6173 { | |
| 6174 catchlist = catchlist->next; | |
| 6175 /* Don't mess with gcprolist, backtrace_list here */ | |
| 6176 } | |
| 6177 #endif | |
| 6178 #endif | |
| 1313 | 6179 |
| 6180 if (!UNBOUNDP (oquit)) | |
| 6181 Vquit_flag = oquit; | |
| 428 | 6182 } |
| 853 | 6183 check_specbind_stack_sanity (); |
| 428 | 6184 } |
| 6185 | |
| 6186 | |
| 6187 | |
| 6188 /* Get the value of symbol's global binding, even if that binding is | |
| 6189 not now dynamically visible. May return Qunbound or magic values. */ | |
| 6190 | |
| 6191 Lisp_Object | |
| 6192 top_level_value (Lisp_Object symbol) | |
| 6193 { | |
| 6194 REGISTER struct specbinding *ptr = specpdl; | |
| 6195 | |
| 6196 CHECK_SYMBOL (symbol); | |
| 6197 for (; ptr != specpdl_ptr; ptr++) | |
| 6198 { | |
| 6199 if (EQ (ptr->symbol, symbol)) | |
| 6200 return ptr->old_value; | |
| 6201 } | |
| 6202 return XSYMBOL (symbol)->value; | |
| 6203 } | |
| 6204 | |
| 6205 #if 0 | |
| 6206 | |
| 6207 Lisp_Object | |
| 6208 top_level_set (Lisp_Object symbol, Lisp_Object newval) | |
| 6209 { | |
| 6210 REGISTER struct specbinding *ptr = specpdl; | |
| 6211 | |
| 6212 CHECK_SYMBOL (symbol); | |
| 6213 for (; ptr != specpdl_ptr; ptr++) | |
| 6214 { | |
| 6215 if (EQ (ptr->symbol, symbol)) | |
| 6216 { | |
| 6217 ptr->old_value = newval; | |
| 6218 return newval; | |
| 6219 } | |
| 6220 } | |
| 6221 return Fset (symbol, newval); | |
| 6222 } | |
| 6223 | |
| 6224 #endif /* 0 */ | |
| 6225 | |
| 6226 | |
| 6227 /************************************************************************/ | |
| 6228 /* Backtraces */ | |
| 6229 /************************************************************************/ | |
| 6230 | |
| 6231 DEFUN ("backtrace-debug", Fbacktrace_debug, 2, 2, 0, /* | |
| 6232 Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG. | |
| 6233 The debugger is entered when that frame exits, if the flag is non-nil. | |
| 6234 */ | |
| 6235 (level, flag)) | |
| 6236 { | |
| 6237 REGISTER struct backtrace *backlist = backtrace_list; | |
| 6238 REGISTER int i; | |
| 6239 | |
| 6240 CHECK_INT (level); | |
| 6241 | |
| 6242 for (i = 0; backlist && i < XINT (level); i++) | |
| 6243 { | |
| 6244 backlist = backlist->next; | |
| 6245 } | |
| 6246 | |
| 6247 if (backlist) | |
| 6248 backlist->debug_on_exit = !NILP (flag); | |
| 6249 | |
| 6250 return flag; | |
| 6251 } | |
| 6252 | |
| 6253 static void | |
| 6254 backtrace_specials (int speccount, int speclimit, Lisp_Object stream) | |
| 6255 { | |
| 6256 int printing_bindings = 0; | |
| 6257 | |
| 6258 for (; speccount > speclimit; speccount--) | |
| 6259 { | |
| 6260 if (specpdl[speccount - 1].func == 0 | |
| 6261 || specpdl[speccount - 1].func == specbind_unwind_local | |
| 6262 || specpdl[speccount - 1].func == specbind_unwind_wasnt_local) | |
| 6263 { | |
| 826 | 6264 write_c_string (stream, !printing_bindings ? " # bind (" : " "); |
| 428 | 6265 Fprin1 (specpdl[speccount - 1].symbol, stream); |
| 6266 printing_bindings = 1; | |
| 6267 } | |
| 6268 else | |
| 6269 { | |
| 826 | 6270 if (printing_bindings) write_c_string (stream, ")\n"); |
| 6271 write_c_string (stream, " # (unwind-protect ...)\n"); | |
| 428 | 6272 printing_bindings = 0; |
| 6273 } | |
| 6274 } | |
| 826 | 6275 if (printing_bindings) write_c_string (stream, ")\n"); |
| 428 | 6276 } |
| 6277 | |
| 1292 | 6278 static Lisp_Object |
| 6279 backtrace_unevalled_args (Lisp_Object *args) | |
| 6280 { | |
| 6281 if (args) | |
| 6282 return *args; | |
| 6283 else | |
| 6284 return list1 (build_string ("[internal]")); | |
| 6285 } | |
| 6286 | |
| 428 | 6287 DEFUN ("backtrace", Fbacktrace, 0, 2, "", /* |
| 6288 Print a trace of Lisp function calls currently active. | |
| 438 | 6289 Optional arg STREAM specifies the output stream to send the backtrace to, |
| 444 | 6290 and defaults to the value of `standard-output'. |
| 6291 Optional second arg DETAILED non-nil means show places where currently | |
| 6292 active variable bindings, catches, condition-cases, and | |
| 6293 unwind-protects, as well as function calls, were made. | |
| 428 | 6294 */ |
| 6295 (stream, detailed)) | |
| 6296 { | |
| 6297 /* This function can GC */ | |
| 6298 struct backtrace *backlist = backtrace_list; | |
| 6299 struct catchtag *catches = catchlist; | |
| 6300 int speccount = specpdl_depth(); | |
| 6301 | |
| 6302 int old_nl = print_escape_newlines; | |
| 6303 int old_pr = print_readably; | |
| 6304 Lisp_Object old_level = Vprint_level; | |
| 6305 Lisp_Object oiq = Vinhibit_quit; | |
| 6306 struct gcpro gcpro1, gcpro2; | |
| 6307 | |
| 6308 /* We can't allow quits in here because that could cause the values | |
| 6309 of print_readably and print_escape_newlines to get screwed up. | |
| 6310 Normally we would use a record_unwind_protect but that would | |
| 6311 screw up the functioning of this function. */ | |
| 6312 Vinhibit_quit = Qt; | |
| 6313 | |
| 6314 entering_debugger = 0; | |
| 6315 | |
| 872 | 6316 if (!NILP (detailed)) |
| 6317 Vprint_level = make_int (50); | |
| 6318 else | |
| 6319 Vprint_level = make_int (3); | |
| 428 | 6320 print_readably = 0; |
| 6321 print_escape_newlines = 1; | |
| 6322 | |
| 6323 GCPRO2 (stream, old_level); | |
| 6324 | |
| 1261 | 6325 stream = canonicalize_printcharfun (stream); |
| 428 | 6326 |
| 6327 for (;;) | |
| 6328 { | |
| 6329 if (!NILP (detailed) && catches && catches->backlist == backlist) | |
| 6330 { | |
| 6331 int catchpdl = catches->pdlcount; | |
| 438 | 6332 if (speccount > catchpdl |
| 6333 && specpdl[catchpdl].func == condition_case_unwind) | |
| 428 | 6334 /* This is a condition-case catchpoint */ |
| 6335 catchpdl = catchpdl + 1; | |
| 6336 | |
| 6337 backtrace_specials (speccount, catchpdl, stream); | |
| 6338 | |
| 6339 speccount = catches->pdlcount; | |
| 6340 if (catchpdl == speccount) | |
| 6341 { | |
| 826 | 6342 write_c_string (stream, " # (catch "); |
| 428 | 6343 Fprin1 (catches->tag, stream); |
| 826 | 6344 write_c_string (stream, " ...)\n"); |
| 428 | 6345 } |
| 6346 else | |
| 6347 { | |
| 826 | 6348 write_c_string (stream, " # (condition-case ... . "); |
| 428 | 6349 Fprin1 (Fcdr (Fcar (catches->tag)), stream); |
| 826 | 6350 write_c_string (stream, ")\n"); |
| 428 | 6351 } |
| 6352 catches = catches->next; | |
| 6353 } | |
| 6354 else if (!backlist) | |
| 6355 break; | |
| 6356 else | |
| 6357 { | |
| 6358 if (!NILP (detailed) && backlist->pdlcount < speccount) | |
| 6359 { | |
| 6360 backtrace_specials (speccount, backlist->pdlcount, stream); | |
| 6361 speccount = backlist->pdlcount; | |
| 6362 } | |
| 826 | 6363 write_c_string (stream, backlist->debug_on_exit ? "* " : " "); |
| 428 | 6364 if (backlist->nargs == UNEVALLED) |
| 6365 { | |
| 1292 | 6366 Fprin1 (Fcons (*backlist->function, |
| 6367 backtrace_unevalled_args (backlist->args)), | |
| 6368 stream); | |
| 826 | 6369 write_c_string (stream, "\n"); /* from FSFmacs 19.30 */ |
| 428 | 6370 } |
| 6371 else | |
| 6372 { | |
| 6373 Lisp_Object tem = *backlist->function; | |
| 6374 Fprin1 (tem, stream); /* This can QUIT */ | |
| 826 | 6375 write_c_string (stream, "("); |
| 428 | 6376 if (backlist->nargs == MANY) |
| 6377 { | |
| 6378 int i; | |
| 6379 Lisp_Object tail = Qnil; | |
| 6380 struct gcpro ngcpro1; | |
| 6381 | |
| 6382 NGCPRO1 (tail); | |
| 6383 for (tail = *backlist->args, i = 0; | |
| 6384 !NILP (tail); | |
| 6385 tail = Fcdr (tail), i++) | |
| 6386 { | |
| 826 | 6387 if (i != 0) write_c_string (stream, " "); |
| 428 | 6388 Fprin1 (Fcar (tail), stream); |
| 6389 } | |
| 6390 NUNGCPRO; | |
| 6391 } | |
| 6392 else | |
| 6393 { | |
| 6394 int i; | |
| 6395 for (i = 0; i < backlist->nargs; i++) | |
| 6396 { | |
| 826 | 6397 if (!i && EQ (tem, Qbyte_code)) |
| 6398 { | |
| 6399 write_c_string (stream, "\"...\""); | |
| 6400 continue; | |
| 6401 } | |
| 6402 if (i != 0) write_c_string (stream, " "); | |
| 428 | 6403 Fprin1 (backlist->args[i], stream); |
| 6404 } | |
| 6405 } | |
| 826 | 6406 write_c_string (stream, ")\n"); |
| 428 | 6407 } |
| 6408 backlist = backlist->next; | |
| 6409 } | |
| 6410 } | |
| 6411 Vprint_level = old_level; | |
| 6412 print_readably = old_pr; | |
| 6413 print_escape_newlines = old_nl; | |
| 6414 UNGCPRO; | |
| 6415 Vinhibit_quit = oiq; | |
| 6416 return Qnil; | |
| 6417 } | |
| 6418 | |
| 6419 | |
| 444 | 6420 DEFUN ("backtrace-frame", Fbacktrace_frame, 1, 1, 0, /* |
| 6421 Return the function and arguments NFRAMES up from current execution point. | |
| 428 | 6422 If that frame has not evaluated the arguments yet (or is a special form), |
| 6423 the value is (nil FUNCTION ARG-FORMS...). | |
| 6424 If that frame has evaluated its arguments and called its function already, | |
| 6425 the value is (t FUNCTION ARG-VALUES...). | |
| 6426 A &rest arg is represented as the tail of the list ARG-VALUES. | |
| 6427 FUNCTION is whatever was supplied as car of evaluated list, | |
| 6428 or a lambda expression for macro calls. | |
| 444 | 6429 If NFRAMES is more than the number of frames, the value is nil. |
| 428 | 6430 */ |
| 6431 (nframes)) | |
| 6432 { | |
| 6433 REGISTER struct backtrace *backlist = backtrace_list; | |
| 6434 REGISTER int i; | |
| 6435 Lisp_Object tem; | |
| 6436 | |
| 6437 CHECK_NATNUM (nframes); | |
| 6438 | |
| 6439 /* Find the frame requested. */ | |
| 6440 for (i = XINT (nframes); backlist && (i-- > 0);) | |
| 6441 backlist = backlist->next; | |
| 6442 | |
| 6443 if (!backlist) | |
| 6444 return Qnil; | |
| 6445 if (backlist->nargs == UNEVALLED) | |
| 1292 | 6446 return Fcons (Qnil, Fcons (*backlist->function, |
| 6447 backtrace_unevalled_args (backlist->args))); | |
| 428 | 6448 else |
| 6449 { | |
| 6450 if (backlist->nargs == MANY) | |
| 6451 tem = *backlist->args; | |
| 6452 else | |
| 6453 tem = Flist (backlist->nargs, backlist->args); | |
| 6454 | |
| 6455 return Fcons (Qt, Fcons (*backlist->function, tem)); | |
| 6456 } | |
| 6457 } | |
| 6458 | |
| 6459 | |
| 6460 /************************************************************************/ | |
| 6461 /* Warnings */ | |
| 6462 /************************************************************************/ | |
| 6463 | |
| 1123 | 6464 static int |
| 6465 warning_will_be_discarded (Lisp_Object level) | |
| 6466 { | |
| 6467 /* Don't even generate debug warnings if they're going to be discarded, | |
| 6468 to avoid excessive consing. */ | |
| 6469 return (EQ (level, Qdebug) && !NILP (Vlog_warning_minimum_level) && | |
| 6470 !EQ (Vlog_warning_minimum_level, Qdebug)); | |
| 6471 } | |
| 6472 | |
| 428 | 6473 void |
| 1204 | 6474 warn_when_safe_lispobj (Lisp_Object class_, Lisp_Object level, |
| 428 | 6475 Lisp_Object obj) |
| 6476 { | |
| 1123 | 6477 if (warning_will_be_discarded (level)) |
| 793 | 6478 return; |
| 1123 | 6479 |
| 1204 | 6480 obj = list1 (list3 (class_, level, obj)); |
| 428 | 6481 if (NILP (Vpending_warnings)) |
| 6482 Vpending_warnings = Vpending_warnings_tail = obj; | |
| 6483 else | |
| 6484 { | |
| 6485 Fsetcdr (Vpending_warnings_tail, obj); | |
| 6486 Vpending_warnings_tail = obj; | |
| 6487 } | |
| 6488 } | |
| 6489 | |
| 6490 /* #### This should probably accept Lisp objects; but then we have | |
| 6491 to make sure that Feval() isn't called, since it might not be safe. | |
| 6492 | |
| 6493 An alternative approach is to just pass some non-string type of | |
| 6494 Lisp_Object to warn_when_safe_lispobj(); `prin1-to-string' will | |
| 6495 automatically be called when it is safe to do so. */ | |
| 6496 | |
| 6497 void | |
| 1204 | 6498 warn_when_safe (Lisp_Object class_, Lisp_Object level, const CIbyte *fmt, ...) |
| 428 | 6499 { |
| 6500 Lisp_Object obj; | |
| 6501 va_list args; | |
| 6502 | |
| 1123 | 6503 if (warning_will_be_discarded (level)) |
| 793 | 6504 return; |
| 1123 | 6505 |
| 428 | 6506 va_start (args, fmt); |
| 771 | 6507 obj = emacs_vsprintf_string (CGETTEXT (fmt), args); |
| 428 | 6508 va_end (args); |
| 6509 | |
| 1204 | 6510 warn_when_safe_lispobj (class_, level, obj); |
| 428 | 6511 } |
| 6512 | |
| 6513 | |
| 6514 | |
| 6515 | |
| 6516 /************************************************************************/ | |
| 6517 /* Initialization */ | |
| 6518 /************************************************************************/ | |
| 6519 | |
| 6520 void | |
| 6521 syms_of_eval (void) | |
| 6522 { | |
| 442 | 6523 INIT_LRECORD_IMPLEMENTATION (subr); |
| 6524 | |
| 563 | 6525 DEFSYMBOL (Qinhibit_quit); |
| 6526 DEFSYMBOL (Qautoload); | |
| 6527 DEFSYMBOL (Qdebug_on_error); | |
| 6528 DEFSYMBOL (Qstack_trace_on_error); | |
| 6529 DEFSYMBOL (Qdebug_on_signal); | |
| 6530 DEFSYMBOL (Qstack_trace_on_signal); | |
| 6531 DEFSYMBOL (Qdebugger); | |
| 6532 DEFSYMBOL (Qmacro); | |
| 428 | 6533 defsymbol (&Qand_rest, "&rest"); |
| 6534 defsymbol (&Qand_optional, "&optional"); | |
| 6535 /* Note that the process code also uses Qexit */ | |
| 563 | 6536 DEFSYMBOL (Qexit); |
| 6537 DEFSYMBOL (Qsetq); | |
| 6538 DEFSYMBOL (Qinteractive); | |
| 6539 DEFSYMBOL (Qcommandp); | |
| 6540 DEFSYMBOL (Qdefun); | |
| 6541 DEFSYMBOL (Qprogn); | |
| 6542 DEFSYMBOL (Qvalues); | |
| 6543 DEFSYMBOL (Qdisplay_warning); | |
| 6544 DEFSYMBOL (Qrun_hooks); | |
| 887 | 6545 DEFSYMBOL (Qfinalize_list); |
| 563 | 6546 DEFSYMBOL (Qif); |
| 428 | 6547 |
| 6548 DEFSUBR (For); | |
| 6549 DEFSUBR (Fand); | |
| 6550 DEFSUBR (Fif); | |
| 6551 DEFSUBR_MACRO (Fwhen); | |
| 6552 DEFSUBR_MACRO (Funless); | |
| 6553 DEFSUBR (Fcond); | |
| 6554 DEFSUBR (Fprogn); | |
| 6555 DEFSUBR (Fprog1); | |
| 6556 DEFSUBR (Fprog2); | |
| 6557 DEFSUBR (Fsetq); | |
| 6558 DEFSUBR (Fquote); | |
| 6559 DEFSUBR (Ffunction); | |
| 6560 DEFSUBR (Fdefun); | |
| 6561 DEFSUBR (Fdefmacro); | |
| 6562 DEFSUBR (Fdefvar); | |
| 6563 DEFSUBR (Fdefconst); | |
| 6564 DEFSUBR (Flet); | |
| 6565 DEFSUBR (FletX); | |
| 6566 DEFSUBR (Fwhile); | |
| 6567 DEFSUBR (Fmacroexpand_internal); | |
| 6568 DEFSUBR (Fcatch); | |
| 6569 DEFSUBR (Fthrow); | |
| 6570 DEFSUBR (Funwind_protect); | |
| 6571 DEFSUBR (Fcondition_case); | |
| 6572 DEFSUBR (Fcall_with_condition_handler); | |
| 6573 DEFSUBR (Fsignal); | |
| 6574 DEFSUBR (Finteractive_p); | |
| 6575 DEFSUBR (Fcommandp); | |
| 6576 DEFSUBR (Fcommand_execute); | |
| 6577 DEFSUBR (Fautoload); | |
| 6578 DEFSUBR (Feval); | |
| 6579 DEFSUBR (Fapply); | |
| 6580 DEFSUBR (Ffuncall); | |
| 6581 DEFSUBR (Ffunctionp); | |
| 6582 DEFSUBR (Ffunction_min_args); | |
| 6583 DEFSUBR (Ffunction_max_args); | |
| 6584 DEFSUBR (Frun_hooks); | |
| 6585 DEFSUBR (Frun_hook_with_args); | |
| 6586 DEFSUBR (Frun_hook_with_args_until_success); | |
| 6587 DEFSUBR (Frun_hook_with_args_until_failure); | |
| 6588 DEFSUBR (Fbacktrace_debug); | |
| 6589 DEFSUBR (Fbacktrace); | |
| 6590 DEFSUBR (Fbacktrace_frame); | |
| 6591 } | |
| 6592 | |
| 6593 void | |
| 814 | 6594 init_eval_semi_early (void) |
| 428 | 6595 { |
| 6596 specpdl_ptr = specpdl; | |
| 6597 specpdl_depth_counter = 0; | |
| 6598 catchlist = 0; | |
| 6599 Vcondition_handlers = Qnil; | |
| 6600 backtrace_list = 0; | |
| 6601 Vquit_flag = Qnil; | |
| 6602 debug_on_next_call = 0; | |
| 6603 lisp_eval_depth = 0; | |
| 6604 entering_debugger = 0; | |
| 6605 } | |
| 6606 | |
| 6607 void | |
| 6608 reinit_vars_of_eval (void) | |
| 6609 { | |
| 6610 preparing_for_armageddon = 0; | |
| 6611 in_warnings = 0; | |
| 6612 specpdl_size = 50; | |
| 6613 specpdl = xnew_array (struct specbinding, specpdl_size); | |
| 6614 /* XEmacs change: increase these values. */ | |
| 6615 max_specpdl_size = 3000; | |
| 442 | 6616 max_lisp_eval_depth = 1000; |
| 6617 #ifdef DEFEND_AGAINST_THROW_RECURSION | |
| 428 | 6618 throw_level = 0; |
| 6619 #endif | |
| 2367 | 6620 init_eval_semi_early (); |
| 428 | 6621 } |
| 6622 | |
| 6623 void | |
| 6624 vars_of_eval (void) | |
| 6625 { | |
| 6626 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size /* | |
| 6627 Limit on number of Lisp variable bindings & unwind-protects before error. | |
| 6628 */ ); | |
| 6629 | |
| 6630 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth /* | |
| 6631 Limit on depth in `eval', `apply' and `funcall' before error. | |
| 6632 This limit is to catch infinite recursions for you before they cause | |
| 6633 actual stack overflow in C, which would be fatal for Emacs. | |
| 6634 You can safely make it considerably larger than its default value, | |
| 6635 if that proves inconveniently small. | |
| 6636 */ ); | |
| 6637 | |
| 6638 DEFVAR_LISP ("quit-flag", &Vquit_flag /* | |
| 853 | 6639 t causes running Lisp code to abort, unless `inhibit-quit' is non-nil. |
| 6640 `critical' causes running Lisp code to abort regardless of `inhibit-quit'. | |
| 6641 Normally, you do not need to set this value yourself. It is set to | |
| 6642 t each time a Control-G is detected, and to `critical' each time a | |
| 6643 Shift-Control-G is detected. The XEmacs core C code is littered with | |
| 6644 calls to the QUIT; macro, which check the values of `quit-flag' and | |
| 2500 | 6645 `inhibit-quit' and ABORT (or more accurately, call (signal 'quit)) if |
| 853 | 6646 it's correct to do so. |
| 428 | 6647 */ ); |
| 6648 Vquit_flag = Qnil; | |
| 6649 | |
| 6650 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit /* | |
| 6651 Non-nil inhibits C-g quitting from happening immediately. | |
| 6652 Note that `quit-flag' will still be set by typing C-g, | |
| 6653 so a quit will be signalled as soon as `inhibit-quit' is nil. | |
| 6654 To prevent this happening, set `quit-flag' to nil | |
| 853 | 6655 before making `inhibit-quit' nil. |
| 6656 | |
| 6657 The value of `inhibit-quit' is ignored if a critical quit is | |
| 6658 requested by typing control-shift-G in a window-system frame; | |
| 6659 this is explained in more detail in `quit-flag'. | |
| 428 | 6660 */ ); |
| 6661 Vinhibit_quit = Qnil; | |
| 6662 | |
| 6663 DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error /* | |
| 6664 *Non-nil means automatically display a backtrace buffer | |
| 6665 after any error that is not handled by a `condition-case'. | |
| 6666 If the value is a list, an error only means to display a backtrace | |
| 6667 if one of its condition symbols appears in the list. | |
| 6668 See also variable `stack-trace-on-signal'. | |
| 6669 */ ); | |
| 6670 Vstack_trace_on_error = Qnil; | |
| 6671 | |
| 6672 DEFVAR_LISP ("stack-trace-on-signal", &Vstack_trace_on_signal /* | |
| 6673 *Non-nil means automatically display a backtrace buffer | |
| 6674 after any error that is signalled, whether or not it is handled by | |
| 6675 a `condition-case'. | |
| 6676 If the value is a list, an error only means to display a backtrace | |
| 6677 if one of its condition symbols appears in the list. | |
| 6678 See also variable `stack-trace-on-error'. | |
| 6679 */ ); | |
| 6680 Vstack_trace_on_signal = Qnil; | |
| 6681 | |
| 6682 DEFVAR_LISP ("debug-ignored-errors", &Vdebug_ignored_errors /* | |
| 6683 *List of errors for which the debugger should not be called. | |
| 6684 Each element may be a condition-name or a regexp that matches error messages. | |
| 6685 If any element applies to a given error, that error skips the debugger | |
| 6686 and just returns to top level. | |
| 6687 This overrides the variable `debug-on-error'. | |
| 6688 It does not apply to errors handled by `condition-case'. | |
| 6689 */ ); | |
| 6690 Vdebug_ignored_errors = Qnil; | |
| 6691 | |
| 6692 DEFVAR_LISP ("debug-on-error", &Vdebug_on_error /* | |
| 6693 *Non-nil means enter debugger if an unhandled error is signalled. | |
| 6694 The debugger will not be entered if the error is handled by | |
| 6695 a `condition-case'. | |
| 6696 If the value is a list, an error only means to enter the debugger | |
| 6697 if one of its condition symbols appears in the list. | |
| 6698 This variable is overridden by `debug-ignored-errors'. | |
| 6699 See also variables `debug-on-quit' and `debug-on-signal'. | |
| 1123 | 6700 |
| 6701 If this variable is set while XEmacs is running noninteractively (using | |
| 6702 `-batch'), and XEmacs was configured with `--debug' (#define XEMACS_DEBUG | |
| 6703 in the C code), instead of trying to invoke the Lisp debugger (which | |
| 6704 obviously won't work), XEmacs will break out to a C debugger using | |
| 6705 \(force-debugging-signal t). This is useful because debugging | |
| 6706 noninteractive runs of XEmacs is often very difficult, since they typically | |
| 6707 happen as part of sometimes large and complex make suites (e.g. rebuilding | |
| 2500 | 6708 the XEmacs packages). NOTE: This runs ABORT()!!! (As well as and after |
| 1123 | 6709 executing INT 3 under MS Windows, which should invoke a debugger if it's |
| 6710 active.) This is guaranteed to kill XEmacs! (But in this situation, XEmacs | |
| 6711 is about to die anyway, and if no debugger is present, this will usefully | |
| 6712 dump core.) The most useful way to set this flag when debugging | |
| 6713 noninteractive runs, especially in makefiles, is using the environment | |
| 6714 variable XEMACSDEBUG, like this: | |
| 771 | 6715 |
| 6716 \(using csh) setenv XEMACSDEBUG '(setq debug-on-error t)' | |
| 6717 \(using bash) export XEMACSDEBUG='(setq debug-on-error t)' | |
| 428 | 6718 */ ); |
| 6719 Vdebug_on_error = Qnil; | |
| 6720 | |
| 6721 DEFVAR_LISP ("debug-on-signal", &Vdebug_on_signal /* | |
| 6722 *Non-nil means enter debugger if an error is signalled. | |
| 6723 The debugger will be entered whether or not the error is handled by | |
| 6724 a `condition-case'. | |
| 6725 If the value is a list, an error only means to enter the debugger | |
| 6726 if one of its condition symbols appears in the list. | |
| 6727 See also variable `debug-on-quit'. | |
| 1123 | 6728 |
| 6729 This will attempt to enter a C debugger when XEmacs is run noninteractively | |
| 6730 and under the same conditions as described in `debug-on-error'. | |
| 428 | 6731 */ ); |
| 6732 Vdebug_on_signal = Qnil; | |
| 6733 | |
| 6734 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit /* | |
| 6735 *Non-nil means enter debugger if quit is signalled (C-G, for example). | |
| 6736 Does not apply if quit is handled by a `condition-case'. Entering the | |
| 6737 debugger can also be achieved at any time (for X11 console) by typing | |
| 6738 control-shift-G to signal a critical quit. | |
| 6739 */ ); | |
| 6740 debug_on_quit = 0; | |
| 6741 | |
| 6742 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call /* | |
| 6743 Non-nil means enter debugger before next `eval', `apply' or `funcall'. | |
| 6744 */ ); | |
| 6745 | |
| 1292 | 6746 DEFVAR_BOOL ("backtrace-with-interal-sections", |
| 6747 &backtrace_with_internal_sections /* | |
| 6748 Non-nil means backtraces will contain additional information indicating | |
| 6749 when particular sections of the C code have been entered, e.g. redisplay(), | |
| 6750 byte-char conversion, internal-external conversion, etc. This can be | |
| 6751 particularly useful when XEmacs crashes, in helping to pinpoint the problem. | |
| 6752 */ ); | |
| 6753 #ifdef ERROR_CHECK_STRUCTURES | |
| 6754 backtrace_with_internal_sections = 1; | |
| 6755 #else | |
| 6756 backtrace_with_internal_sections = 0; | |
| 6757 #endif | |
| 6758 | |
| 428 | 6759 DEFVAR_LISP ("debugger", &Vdebugger /* |
| 6760 Function to call to invoke debugger. | |
| 6761 If due to frame exit, args are `exit' and the value being returned; | |
| 6762 this function's value will be returned instead of that. | |
| 6763 If due to error, args are `error' and a list of the args to `signal'. | |
| 6764 If due to `apply' or `funcall' entry, one arg, `lambda'. | |
| 6765 If due to `eval' entry, one arg, t. | |
| 6766 */ ); | |
| 6767 Vdebugger = Qnil; | |
| 6768 | |
| 853 | 6769 staticpro (&Vcatch_everything_tag); |
| 6770 Vcatch_everything_tag = make_opaque (OPAQUE_CLEAR, 0); | |
| 6771 | |
| 428 | 6772 staticpro (&Vpending_warnings); |
| 6773 Vpending_warnings = Qnil; | |
| 1204 | 6774 dump_add_root_lisp_object (&Vpending_warnings_tail); |
| 428 | 6775 Vpending_warnings_tail = Qnil; |
| 6776 | |
| 793 | 6777 DEFVAR_LISP ("log-warning-minimum-level", &Vlog_warning_minimum_level); |
| 6778 Vlog_warning_minimum_level = Qinfo; | |
| 6779 | |
| 428 | 6780 staticpro (&Vautoload_queue); |
| 6781 Vautoload_queue = Qnil; | |
| 6782 | |
| 6783 staticpro (&Vcondition_handlers); | |
| 6784 | |
| 853 | 6785 staticpro (&Vdeletable_permanent_display_objects); |
| 6786 Vdeletable_permanent_display_objects = Qnil; | |
| 6787 | |
| 6788 staticpro (&Vmodifiable_buffers); | |
| 6789 Vmodifiable_buffers = Qnil; | |
| 6790 | |
| 6791 inhibit_flags = 0; | |
| 6792 } |