1 /* Evaluator for GNU Emacs Lisp interpreter.
3 Copyright (C) 1985-1987, 1993-1995, 1999-2014 Free Software Foundation,
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or
11 (at your option) any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
26 #include "blockinput.h"
29 #include "dispextern.h"
32 static void unbind_once (void *ignore
);
34 /* Chain of condition and catch handlers currently in effect. */
36 struct handler
*handlerlist
;
39 /* Count levels of GCPRO to detect failure to UNGCPRO. */
43 Lisp_Object Qautoload
, Qmacro
, Qexit
, Qinteractive
, Qcommandp
;
44 Lisp_Object Qinhibit_quit
;
45 Lisp_Object Qand_rest
;
46 static Lisp_Object Qand_optional
;
47 static Lisp_Object Qinhibit_debugger
;
48 static Lisp_Object Qdeclare
;
49 Lisp_Object Qinternal_interpreter_environment
, Qclosure
;
51 static Lisp_Object Qdebug
;
53 /* This holds either the symbol `run-hooks' or nil.
54 It is nil at an early stage of startup, and when Emacs
57 Lisp_Object Vrun_hooks
;
59 /* Non-nil means record all fset's and provide's, to be undone
60 if the file being autoloaded is not fully loaded.
61 They are recorded by being consed onto the front of Vautoload_queue:
62 (FUN . ODEF) for a defun, (0 . OFEATURES) for a provide. */
64 Lisp_Object Vautoload_queue
;
66 /* Current number of specbindings allocated in specpdl, not counting
67 the dummy entry specpdl[-1]. */
69 ptrdiff_t specpdl_size
;
71 /* Pointer to beginning of specpdl. A dummy entry specpdl[-1] exists
72 only so that its address can be taken. */
74 union specbinding
*specpdl
;
76 /* Pointer to first unused element in specpdl. */
78 union specbinding
*specpdl_ptr
;
80 /* Depth in Lisp evaluations and function calls. */
82 EMACS_INT lisp_eval_depth
;
84 /* The value of num_nonmacro_input_events as of the last time we
85 started to enter the debugger. If we decide to enter the debugger
86 again when this is still equal to num_nonmacro_input_events, then we
87 know that the debugger itself has an error, and we should just
88 signal the error instead of entering an infinite loop of debugger
91 static EMACS_INT when_entered_debugger
;
93 /* The function from which the last `signal' was called. Set in
95 /* FIXME: We should probably get rid of this! */
96 Lisp_Object Vsignaling_function
;
98 /* If non-nil, Lisp code must not be run since some part of Emacs is
99 in an inconsistent state. Currently, x-create-frame uses this to
100 avoid triggering window-configuration-change-hook while the new
101 frame is half-initialized. */
102 Lisp_Object inhibit_lisp_code
;
104 /* These would ordinarily be static, but they need to be visible to GDB. */
105 bool backtrace_p (union specbinding
*) EXTERNALLY_VISIBLE
;
106 Lisp_Object
*backtrace_args (union specbinding
*) EXTERNALLY_VISIBLE
;
107 Lisp_Object
backtrace_function (union specbinding
*) EXTERNALLY_VISIBLE
;
108 union specbinding
*backtrace_next (union specbinding
*) EXTERNALLY_VISIBLE
;
109 union specbinding
*backtrace_top (void) EXTERNALLY_VISIBLE
;
111 static Lisp_Object
funcall_lambda (Lisp_Object
, ptrdiff_t, Lisp_Object
*);
112 static Lisp_Object
apply_lambda (Lisp_Object fun
, Lisp_Object args
);
115 specpdl_symbol (union specbinding
*pdl
)
117 eassert (pdl
->kind
>= SPECPDL_LET
);
118 return pdl
->let
.symbol
;
122 specpdl_old_value (union specbinding
*pdl
)
124 eassert (pdl
->kind
>= SPECPDL_LET
);
125 return pdl
->let
.old_value
;
129 set_specpdl_old_value (union specbinding
*pdl
, Lisp_Object val
)
131 eassert (pdl
->kind
>= SPECPDL_LET
);
132 pdl
->let
.old_value
= val
;
136 specpdl_where (union specbinding
*pdl
)
138 eassert (pdl
->kind
> SPECPDL_LET
);
139 return pdl
->let
.where
;
143 backtrace_function (union specbinding
*pdl
)
145 eassert (pdl
->kind
== SPECPDL_BACKTRACE
);
146 return pdl
->bt
.function
;
150 backtrace_nargs (union specbinding
*pdl
)
152 eassert (pdl
->kind
== SPECPDL_BACKTRACE
);
153 return pdl
->bt
.nargs
;
157 backtrace_args (union specbinding
*pdl
)
159 eassert (pdl
->kind
== SPECPDL_BACKTRACE
);
164 backtrace_debug_on_exit (union specbinding
*pdl
)
166 eassert (pdl
->kind
== SPECPDL_BACKTRACE
);
167 return pdl
->bt
.debug_on_exit
;
170 /* Functions to modify slots of backtrace records. */
173 set_backtrace_args (union specbinding
*pdl
, Lisp_Object
*args
)
175 eassert (pdl
->kind
== SPECPDL_BACKTRACE
);
180 set_backtrace_nargs (union specbinding
*pdl
, ptrdiff_t n
)
182 eassert (pdl
->kind
== SPECPDL_BACKTRACE
);
187 set_backtrace_debug_on_exit (union specbinding
*pdl
, bool doe
)
189 eassert (pdl
->kind
== SPECPDL_BACKTRACE
);
190 pdl
->bt
.debug_on_exit
= doe
;
193 /* Helper functions to scan the backtrace. */
196 backtrace_p (union specbinding
*pdl
)
197 { return pdl
>= specpdl
; }
202 union specbinding
*pdl
= specpdl_ptr
- 1;
203 while (backtrace_p (pdl
) && pdl
->kind
!= SPECPDL_BACKTRACE
)
209 backtrace_next (union specbinding
*pdl
)
212 while (backtrace_p (pdl
) && pdl
->kind
!= SPECPDL_BACKTRACE
)
218 make_catch_handler (Lisp_Object tag
)
220 struct handler
*c
= xmalloc (sizeof (*c
));
226 c
->next
= handlerlist
;
227 c
->lisp_eval_depth
= lisp_eval_depth
;
228 c
->interrupt_input_blocked
= interrupt_input_blocked
;
229 c
->ptag
= make_prompt_tag ();
234 make_condition_handler (Lisp_Object tag
)
236 struct handler
*c
= xmalloc (sizeof (*c
));
237 c
->type
= CONDITION_CASE
;
242 c
->next
= handlerlist
;
243 c
->lisp_eval_depth
= lisp_eval_depth
;
244 c
->interrupt_input_blocked
= interrupt_input_blocked
;
245 c
->ptag
= make_prompt_tag ();
249 static Lisp_Object eval_fn
;
250 static Lisp_Object funcall_fn
;
253 init_eval_once (void)
256 union specbinding
*pdlvec
= xmalloc ((size
+ 1) * sizeof *specpdl
);
258 specpdl
= specpdl_ptr
= pdlvec
+ 1;
259 /* Don't forget to update docs (lispref node "Local Variables"). */
260 max_specpdl_size
= 10000; /* 1000 is not enough for CEDET's c-by.el. */
261 max_lisp_eval_depth
= 10000;
265 eval_fn
= scm_c_public_ref ("language elisp runtime", "eval-elisp");
266 funcall_fn
= scm_c_public_ref ("elisp-functions", "funcall");
269 static struct handler
*handlerlist_sentinel
;
274 specpdl_ptr
= specpdl
;
275 handlerlist_sentinel
= make_catch_handler (Qunbound
);
276 handlerlist
= handlerlist_sentinel
;
278 debug_on_next_call
= 0;
283 /* This is less than the initial value of num_nonmacro_input_events. */
284 when_entered_debugger
= -1;
287 /* Unwind-protect function used by call_debugger. */
290 restore_stack_limits (Lisp_Object data
)
292 max_specpdl_size
= XINT (XCAR (data
));
293 max_lisp_eval_depth
= XINT (XCDR (data
));
296 static void grow_specpdl (void);
298 /* Call the Lisp debugger, giving it argument ARG. */
301 call_debugger (Lisp_Object arg
)
303 bool debug_while_redisplaying
;
306 EMACS_INT old_depth
= max_lisp_eval_depth
;
307 /* Do not allow max_specpdl_size less than actual depth (Bug#16603). */
308 EMACS_INT old_max
= max_specpdl_size
;
310 if (lisp_eval_depth
+ 40 > max_lisp_eval_depth
)
311 max_lisp_eval_depth
= lisp_eval_depth
+ 40;
313 /* Restore limits after leaving the debugger. */
314 record_unwind_protect (restore_stack_limits
,
315 Fcons (make_number (old_max
),
316 make_number (old_depth
)));
318 #ifdef HAVE_WINDOW_SYSTEM
319 if (display_hourglass_p
)
323 debug_on_next_call
= 0;
324 when_entered_debugger
= num_nonmacro_input_events
;
326 /* Resetting redisplaying_p to 0 makes sure that debug output is
327 displayed if the debugger is invoked during redisplay. */
328 debug_while_redisplaying
= redisplaying_p
;
330 specbind (intern ("debugger-may-continue"),
331 debug_while_redisplaying
? Qnil
: Qt
);
332 specbind (Qinhibit_redisplay
, Qnil
);
333 specbind (Qinhibit_debugger
, Qt
);
335 #if 0 /* Binding this prevents execution of Lisp code during
336 redisplay, which necessarily leads to display problems. */
337 specbind (Qinhibit_eval_during_redisplay
, Qt
);
340 val
= apply1 (Vdebugger
, arg
);
342 /* Interrupting redisplay and resuming it later is not safe under
343 all circumstances. So, when the debugger returns, abort the
344 interrupted redisplay by going back to the top-level. */
345 if (debug_while_redisplaying
)
353 do_debug_on_call (Lisp_Object code
)
355 debug_on_next_call
= 0;
356 set_backtrace_debug_on_exit (specpdl_ptr
- 1, true);
357 call_debugger (list1 (code
));
360 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
361 doc
: /* Eval BODY forms sequentially and return value of last one.
362 usage: (progn BODY...) */)
365 Lisp_Object val
= Qnil
;
372 val
= eval_sub (XCAR (body
));
380 /* Evaluate BODY sequentially, discarding its value. Suitable for
381 record_unwind_protect. */
384 unwind_body (Lisp_Object body
)
390 Ffunction (Lisp_Object args
)
392 Lisp_Object quoted
= XCAR (args
);
394 if (CONSP (XCDR (args
)))
395 xsignal2 (Qwrong_number_of_arguments
, Qfunction
, Flength (args
));
397 if (!NILP (Vinternal_interpreter_environment
)
399 && EQ (XCAR (quoted
), Qlambda
))
400 /* This is a lambda expression within a lexical environment;
401 return an interpreted closure instead of a simple lambda. */
402 return Fcons (Qclosure
, Fcons (Vinternal_interpreter_environment
,
405 /* Simply quote the argument. */
409 DEFUN ("defvaralias", Fdefvaralias
, Sdefvaralias
, 2, 3, 0,
410 doc
: /* Make NEW-ALIAS a variable alias for symbol BASE-VARIABLE.
411 Aliased variables always have the same value; setting one sets the other.
412 Third arg DOCSTRING, if non-nil, is documentation for NEW-ALIAS. If it is
413 omitted or nil, NEW-ALIAS gets the documentation string of BASE-VARIABLE,
414 or of the variable at the end of the chain of aliases, if BASE-VARIABLE is
415 itself an alias. If NEW-ALIAS is bound, and BASE-VARIABLE is not,
416 then the value of BASE-VARIABLE is set to that of NEW-ALIAS.
417 The return value is BASE-VARIABLE. */)
418 (Lisp_Object new_alias
, Lisp_Object base_variable
, Lisp_Object docstring
)
422 CHECK_SYMBOL (new_alias
);
423 CHECK_SYMBOL (base_variable
);
425 sym
= XSYMBOL (new_alias
);
427 if (SYMBOL_CONSTANT (sym
))
428 /* Not sure why, but why not? */
429 error ("Cannot make a constant an alias");
431 switch (SYMBOL_REDIRECT (sym
))
433 case SYMBOL_FORWARDED
:
434 error ("Cannot make an internal variable an alias");
435 case SYMBOL_LOCALIZED
:
436 error ("Don't know how to make a localized variable an alias");
439 /* http://lists.gnu.org/archive/html/emacs-devel/2008-04/msg00834.html
440 If n_a is bound, but b_v is not, set the value of b_v to n_a,
441 so that old-code that affects n_a before the aliasing is setup
443 if (NILP (Fboundp (base_variable
)))
444 set_internal (base_variable
, find_symbol_value (new_alias
), Qnil
, 1);
447 union specbinding
*p
;
449 for (p
= specpdl_ptr
; p
> specpdl
; )
450 if ((--p
)->kind
>= SPECPDL_LET
451 && (EQ (new_alias
, specpdl_symbol (p
))))
452 error ("Don't know how to make a let-bound variable an alias");
455 SET_SYMBOL_DECLARED_SPECIAL (sym
, 1);
456 SET_SYMBOL_DECLARED_SPECIAL (XSYMBOL (base_variable
), 1);
457 SET_SYMBOL_REDIRECT (sym
, SYMBOL_VARALIAS
);
458 SET_SYMBOL_ALIAS (sym
, XSYMBOL (base_variable
));
459 SET_SYMBOL_CONSTANT (sym
, SYMBOL_CONSTANT_P (base_variable
));
460 LOADHIST_ATTACH (new_alias
);
461 /* Even if docstring is nil: remove old docstring. */
462 Fput (new_alias
, Qvariable_documentation
, docstring
);
464 return base_variable
;
467 static union specbinding
*
468 default_toplevel_binding (Lisp_Object symbol
)
470 union specbinding
*binding
= NULL
;
471 union specbinding
*pdl
= specpdl_ptr
;
472 while (pdl
> specpdl
)
474 switch ((--pdl
)->kind
)
476 case SPECPDL_LET_DEFAULT
:
478 if (EQ (specpdl_symbol (pdl
), symbol
))
486 DEFUN ("default-toplevel-value", Fdefault_toplevel_value
, Sdefault_toplevel_value
, 1, 1, 0,
487 doc
: /* Return SYMBOL's toplevel default value.
488 "Toplevel" means outside of any let binding. */)
491 union specbinding
*binding
= default_toplevel_binding (symbol
);
493 = binding
? specpdl_old_value (binding
) : Fdefault_value (symbol
);
494 if (!EQ (value
, Qunbound
))
496 xsignal1 (Qvoid_variable
, symbol
);
499 DEFUN ("set-default-toplevel-value", Fset_default_toplevel_value
,
500 Sset_default_toplevel_value
, 2, 2, 0,
501 doc
: /* Set SYMBOL's toplevel default value to VALUE.
502 "Toplevel" means outside of any let binding. */)
503 (Lisp_Object symbol
, Lisp_Object value
)
505 union specbinding
*binding
= default_toplevel_binding (symbol
);
507 set_specpdl_old_value (binding
, value
);
509 Fset_default (symbol
, value
);
513 /* Make SYMBOL lexically scoped. */
514 DEFUN ("internal-make-var-non-special", Fmake_var_non_special
,
515 Smake_var_non_special
, 1, 1, 0,
516 doc
: /* Internal function. */)
519 CHECK_SYMBOL (symbol
);
520 SET_SYMBOL_DECLARED_SPECIAL (XSYMBOL (symbol
), 0);
525 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
526 doc
: /* Return result of expanding macros at top level of FORM.
527 If FORM is not a macro call, it is returned unchanged.
528 Otherwise, the macro is expanded and the expansion is considered
529 in place of FORM. When a non-macro-call results, it is returned.
531 The second optional arg ENVIRONMENT specifies an environment of macro
532 definitions to shadow the loaded ones for use in file byte-compilation. */)
533 (Lisp_Object form
, Lisp_Object environment
)
535 /* With cleanups from Hallvard Furuseth. */
536 register Lisp_Object expander
, sym
, def
, tem
;
540 /* Come back here each time we expand a macro call,
541 in case it expands into another macro call. */
544 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
545 def
= sym
= XCAR (form
);
547 /* Trace symbols aliases to other symbols
548 until we get a symbol that is not an alias. */
549 while (SYMBOLP (def
))
553 tem
= Fassq (sym
, environment
);
556 def
= SYMBOL_FUNCTION (sym
);
562 /* Right now TEM is the result from SYM in ENVIRONMENT,
563 and if TEM is nil then DEF is SYM's function definition. */
566 /* SYM is not mentioned in ENVIRONMENT.
567 Look at its function definition. */
570 def
= Fautoload_do_load (def
, sym
, Qmacro
);
573 /* Not defined or definition not suitable. */
575 if (!EQ (XCAR (def
), Qmacro
))
577 else expander
= XCDR (def
);
581 expander
= XCDR (tem
);
586 Lisp_Object newform
= apply1 (expander
, XCDR (form
));
587 if (EQ (form
, newform
))
596 DEFUN ("call-with-catch", Fcatch
, Scatch
, 2, 2, 0,
597 doc
: /* Eval BODY allowing nonlocal exits using `throw'.
598 TAG is evalled to get the tag to use; it must not be nil.
600 Then the BODY is executed.
601 Within BODY, a call to `throw' with the same TAG exits BODY and this `catch'.
602 If no throw happens, `catch' returns the value of the last BODY form.
603 If a throw happens, it specifies the value to return from `catch'.
604 usage: (catch TAG BODY...) */)
605 (Lisp_Object tag
, Lisp_Object thunk
)
607 return internal_catch (tag
, call0
, thunk
);
610 /* Assert that E is true, as a comment only. Use this instead of
611 eassert (E) when E contains variables that might be clobbered by a
614 #define clobbered_eassert(E) ((void) 0)
617 set_handlerlist (void *data
)
623 restore_handler (void *data
)
625 struct handler
*c
= data
;
626 unblock_input_to (c
->interrupt_input_blocked
);
632 enum { ICC_0
, ICC_1
, ICC_2
, ICC_3
, ICC_N
} type
;
635 Lisp_Object (*fun0
) (void);
636 Lisp_Object (*fun1
) (Lisp_Object
);
637 Lisp_Object (*fun2
) (Lisp_Object
, Lisp_Object
);
638 Lisp_Object (*fun3
) (Lisp_Object
, Lisp_Object
, Lisp_Object
);
639 Lisp_Object (*funn
) (ptrdiff_t, Lisp_Object
*);
659 icc_thunk (void *data
)
662 struct icc_thunk_env
*e
= data
;
663 scm_dynwind_begin (0);
664 scm_dynwind_unwind_handler (restore_handler
, e
->c
, 0);
665 scm_dynwind_unwind_handler (set_handlerlist
,
667 SCM_F_WIND_EXPLICITLY
);
675 tem
= e
->fun1 (e
->arg1
);
678 tem
= e
->fun2 (e
->arg1
, e
->arg2
);
681 tem
= e
->fun3 (e
->arg1
, e
->arg2
, e
->arg3
);
684 tem
= e
->funn (e
->nargs
, e
->args
);
694 icc_handler (void *data
, Lisp_Object k
, Lisp_Object v
)
696 Lisp_Object (*f
) (Lisp_Object
) = data
;
700 struct icc_handler_n_env
702 Lisp_Object (*fun
) (Lisp_Object
, ptrdiff_t, Lisp_Object
*);
708 icc_handler_n (void *data
, Lisp_Object k
, Lisp_Object v
)
710 struct icc_handler_n_env
*e
= data
;
711 return e
->fun (v
, e
->nargs
, e
->args
);
715 icc_lisp_handler (void *data
, Lisp_Object k
, Lisp_Object val
)
718 struct handler
*h
= data
;
719 Lisp_Object var
= h
->var
;
720 scm_dynwind_begin (0);
724 if (!NILP (Vinternal_interpreter_environment
))
725 specbind (Qinternal_interpreter_environment
,
726 Fcons (Fcons (var
, val
),
727 Vinternal_interpreter_environment
));
732 tem
= Fprogn (h
->body
);
737 /* Set up a catch, then call C function FUNC on argument ARG.
738 FUNC should return a Lisp_Object.
739 This is how catches are done from within C code. */
742 internal_catch (Lisp_Object tag
, Lisp_Object (*func
) (Lisp_Object
), Lisp_Object arg
)
744 struct handler
*c
= make_catch_handler (tag
);
745 struct icc_thunk_env env
= { .type
= ICC_1
,
749 return call_with_prompt (c
->ptag
,
750 make_c_closure (icc_thunk
, &env
, 0, 0),
751 make_c_closure (icc_handler
, Fidentity
, 2, 0));
754 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
755 jump to that CATCH, returning VALUE as the value of that catch.
757 This is the guts of Fthrow and Fsignal; they differ only in the way
758 they choose the catch tag to throw to. A catch tag for a
759 condition-case form has a TAG of Qnil.
761 Before each catch is discarded, unbind all special bindings and
762 execute all unwind-protect clauses made above that catch. Unwind
763 the handler stack as we go, so that the proper handlers are in
764 effect for each unwind-protect clause we run. At the end, restore
765 some static info saved in CATCH, and longjmp to the location
768 This is used for correct unwinding in Fthrow and Fsignal. */
770 static Lisp_Object
unbind_to_1 (ptrdiff_t, Lisp_Object
, bool);
772 static _Noreturn
void
773 unwind_to_catch (struct handler
*catch, Lisp_Object value
)
775 abort_to_prompt (catch->ptag
, scm_list_1 (value
));
778 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
779 doc
: /* Throw to the catch for TAG and return VALUE from it.
780 Both TAG and VALUE are evalled. */)
781 (register Lisp_Object tag
, Lisp_Object value
)
786 for (c
= handlerlist
; c
; c
= c
->next
)
788 if (c
->type
== CATCHER
&& EQ (c
->tag_or_ch
, tag
))
789 unwind_to_catch (c
, value
);
791 xsignal2 (Qno_catch
, tag
, value
);
794 DEFUN ("call-with-handler", Fcall_with_handler
, Scall_with_handler
, 4, 4, 0,
795 doc
: /* Regain control when an error is signaled.
796 Executes BODYFORM and returns its value if no error happens.
797 Each element of HANDLERS looks like (CONDITION-NAME BODY...)
798 where the BODY is made of Lisp expressions.
800 A handler is applicable to an error
801 if CONDITION-NAME is one of the error's condition names.
802 If an error happens, the first applicable handler is run.
804 The car of a handler may be a list of condition names instead of a
805 single condition name; then it handles all of them. If the special
806 condition name `debug' is present in this list, it allows another
807 condition in the list to run the debugger if `debug-on-error' and the
808 other usual mechanisms says it should (otherwise, `condition-case'
809 suppresses the debugger).
811 When a handler handles an error, control returns to the `condition-case'
812 and it executes the handler's BODY...
813 with VAR bound to (ERROR-SYMBOL . SIGNAL-DATA) from the error.
814 \(If VAR is nil, the handler can't access that information.)
815 Then the value of the last BODY form is returned from the `condition-case'
818 See also the function `signal' for more info.
819 usage: (condition-case VAR BODYFORM &rest HANDLERS) */)
821 Lisp_Object conditions
,
825 return internal_lisp_condition_case (var
,
826 list2 (intern ("funcall"), thunk
),
827 list1 (list2 (conditions
, list2 (intern ("funcall"), hthunk
))));
831 ilcc1 (Lisp_Object var
, Lisp_Object bodyform
, Lisp_Object handlers
)
833 if (CONSP (handlers
))
835 Lisp_Object clause
= XCAR (handlers
);
836 Lisp_Object condition
= XCAR (clause
);
837 Lisp_Object body
= XCDR (clause
);
838 if (!CONSP (condition
))
839 condition
= Fcons (condition
, Qnil
);
840 struct handler
*c
= make_condition_handler (condition
);
843 struct icc_thunk_env env
= { .type
= ICC_3
,
847 .arg3
= XCDR (handlers
),
849 return call_with_prompt (c
->ptag
,
850 make_c_closure (icc_thunk
, &env
, 0, 0),
851 make_c_closure (icc_lisp_handler
, c
, 2, 0));
855 return eval_sub (bodyform
);
859 /* Like Fcondition_case, but the args are separate
860 rather than passed in a list. Used by Fbyte_code. */
863 internal_lisp_condition_case (volatile Lisp_Object var
, Lisp_Object bodyform
,
864 Lisp_Object handlers
)
868 struct handler
*oldhandlerlist
= handlerlist
;
872 for (val
= handlers
; CONSP (val
); val
= XCDR (val
))
874 Lisp_Object tem
= XCAR (val
);
877 && (SYMBOLP (XCAR (tem
))
878 || CONSP (XCAR (tem
))))))
879 error ("Invalid condition handler: %s",
880 SDATA (Fprin1_to_string (tem
, Qt
)));
883 return ilcc1 (var
, bodyform
, Freverse (handlers
));
886 /* Call the function BFUN with no arguments, catching errors within it
887 according to HANDLERS. If there is an error, call HFUN with
888 one argument which is the data that describes the error:
891 HANDLERS can be a list of conditions to catch.
892 If HANDLERS is Qt, catch all errors.
893 If HANDLERS is Qerror, catch all errors
894 but allow the debugger to run if that is enabled. */
897 internal_condition_case (Lisp_Object (*bfun
) (void), Lisp_Object handlers
,
898 Lisp_Object (*hfun
) (Lisp_Object
))
901 struct handler
*c
= make_condition_handler (handlers
);
903 struct icc_thunk_env env
= { .type
= ICC_0
, .fun0
= bfun
, .c
= c
};
904 return call_with_prompt (c
->ptag
,
905 make_c_closure (icc_thunk
, &env
, 0, 0),
906 make_c_closure (icc_handler
, hfun
, 2, 0));
909 /* Like internal_condition_case but call BFUN with ARG as its argument. */
912 internal_condition_case_1 (Lisp_Object (*bfun
) (Lisp_Object
), Lisp_Object arg
,
913 Lisp_Object handlers
, Lisp_Object (*hfun
) (Lisp_Object
))
916 struct handler
*c
= make_condition_handler (handlers
);
918 struct icc_thunk_env env
= { .type
= ICC_1
,
922 return call_with_prompt (c
->ptag
,
923 make_c_closure (icc_thunk
, &env
, 0, 0),
924 make_c_closure (icc_handler
, hfun
, 2, 0));
927 /* Like internal_condition_case_1 but call BFUN with ARG1 and ARG2 as
931 internal_condition_case_2 (Lisp_Object (*bfun
) (Lisp_Object
, Lisp_Object
),
934 Lisp_Object handlers
,
935 Lisp_Object (*hfun
) (Lisp_Object
))
938 struct handler
*c
= make_condition_handler (handlers
);
939 struct icc_thunk_env env
= { .type
= ICC_2
,
944 return call_with_prompt (c
->ptag
,
945 make_c_closure (icc_thunk
, &env
, 0, 0),
946 make_c_closure (icc_handler
, hfun
, 2, 0));
949 /* Like internal_condition_case but call BFUN with NARGS as first,
950 and ARGS as second argument. */
953 internal_condition_case_n (Lisp_Object (*bfun
) (ptrdiff_t, Lisp_Object
*),
956 Lisp_Object handlers
,
957 Lisp_Object (*hfun
) (Lisp_Object err
,
962 struct handler
*c
= make_condition_handler (handlers
);
964 struct icc_thunk_env env
= { .type
= ICC_N
,
969 struct icc_handler_n_env henv
= { .fun
= hfun
, .nargs
= nargs
, .args
= args
};
970 return call_with_prompt (c
->ptag
,
971 make_c_closure (icc_thunk
, &env
, 0, 0),
972 make_c_closure (icc_handler_n
, &henv
, 2, 0));
976 static Lisp_Object
find_handler_clause (Lisp_Object
, Lisp_Object
);
977 static bool maybe_call_debugger (Lisp_Object conditions
, Lisp_Object sig
,
981 process_quit_flag (void)
983 Lisp_Object flag
= Vquit_flag
;
985 if (EQ (flag
, Qkill_emacs
))
987 if (EQ (Vthrow_on_input
, flag
))
988 Fthrow (Vthrow_on_input
, Qt
);
989 Fsignal (Qquit
, Qnil
);
992 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
993 doc
: /* Signal an error. Args are ERROR-SYMBOL and associated DATA.
994 This function does not return.
996 An error symbol is a symbol with an `error-conditions' property
997 that is a list of condition names.
998 A handler for any of those names will get to handle this signal.
999 The symbol `error' should normally be one of them.
1001 DATA should be a list. Its elements are printed as part of the error message.
1002 See Info anchor `(elisp)Definition of signal' for some details on how this
1003 error message is constructed.
1004 If the signal is handled, DATA is made available to the handler.
1005 See also the function `condition-case'. */)
1006 (Lisp_Object error_symbol
, Lisp_Object data
)
1008 /* When memory is full, ERROR-SYMBOL is nil,
1009 and DATA is (REAL-ERROR-SYMBOL . REAL-DATA).
1010 That is a special case--don't do this in other situations. */
1011 Lisp_Object conditions
;
1013 Lisp_Object real_error_symbol
1014 = (NILP (error_symbol
) ? Fcar (data
) : error_symbol
);
1015 register Lisp_Object clause
= Qnil
;
1019 if (waiting_for_input
)
1022 #if 0 /* rms: I don't know why this was here,
1023 but it is surely wrong for an error that is handled. */
1024 #ifdef HAVE_WINDOW_SYSTEM
1025 if (display_hourglass_p
)
1026 cancel_hourglass ();
1030 /* This hook is used by edebug. */
1031 if (! NILP (Vsignal_hook_function
)
1032 && ! NILP (error_symbol
))
1034 /* Edebug takes care of restoring these variables when it exits. */
1035 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
1036 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
1038 if (SPECPDL_INDEX () + 40 > max_specpdl_size
)
1039 max_specpdl_size
= SPECPDL_INDEX () + 40;
1041 call2 (Vsignal_hook_function
, error_symbol
, data
);
1044 conditions
= Fget (real_error_symbol
, Qerror_conditions
);
1046 /* Remember from where signal was called. Skip over the frame for
1047 `signal' itself. If a frame for `error' follows, skip that,
1048 too. Don't do this when ERROR_SYMBOL is nil, because that
1049 is a memory-full error. */
1050 Vsignaling_function
= Qnil
;
1051 if (!NILP (error_symbol
))
1053 union specbinding
*pdl
= backtrace_next (backtrace_top ());
1054 if (backtrace_p (pdl
) && EQ (backtrace_function (pdl
), Qerror
))
1055 pdl
= backtrace_next (pdl
);
1056 if (backtrace_p (pdl
))
1057 Vsignaling_function
= backtrace_function (pdl
);
1060 for (h
= handlerlist
; h
; h
= h
->next
)
1062 if (h
->type
!= CONDITION_CASE
)
1064 clause
= find_handler_clause (h
->tag_or_ch
, conditions
);
1069 if (/* Don't run the debugger for a memory-full error.
1070 (There is no room in memory to do that!) */
1071 !NILP (error_symbol
)
1072 && (!NILP (Vdebug_on_signal
)
1073 /* If no handler is present now, try to run the debugger. */
1075 /* A `debug' symbol in the handler list disables the normal
1076 suppression of the debugger. */
1077 || (CONSP (clause
) && CONSP (clause
)
1078 && !NILP (Fmemq (Qdebug
, clause
)))
1079 /* Special handler that means "print a message and run debugger
1081 || EQ (h
->tag_or_ch
, Qerror
)))
1083 bool debugger_called
1084 = maybe_call_debugger (conditions
, error_symbol
, data
);
1085 /* We can't return values to code which signaled an error, but we
1086 can continue code which has signaled a quit. */
1087 if (debugger_called
&& EQ (real_error_symbol
, Qquit
))
1093 Lisp_Object unwind_data
1094 = (NILP (error_symbol
) ? data
: Fcons (error_symbol
, data
));
1096 unwind_to_catch (h
, unwind_data
);
1100 if (handlerlist
!= handlerlist_sentinel
)
1101 /* FIXME: This will come right back here if there's no `top-level'
1102 catcher. A better solution would be to abort here, and instead
1103 add a catch-all condition handler so we never come here. */
1104 Fthrow (Qtop_level
, Qt
);
1107 if (! NILP (error_symbol
))
1108 data
= Fcons (error_symbol
, data
);
1110 string
= Ferror_message_string (data
);
1111 fatal ("%s", SDATA (string
));
1114 /* Internal version of Fsignal that never returns.
1115 Used for anything but Qquit (which can return from Fsignal). */
1118 xsignal (Lisp_Object error_symbol
, Lisp_Object data
)
1120 Fsignal (error_symbol
, data
);
1124 /* Like xsignal, but takes 0, 1, 2, or 3 args instead of a list. */
1127 xsignal0 (Lisp_Object error_symbol
)
1129 xsignal (error_symbol
, Qnil
);
1133 xsignal1 (Lisp_Object error_symbol
, Lisp_Object arg
)
1135 xsignal (error_symbol
, list1 (arg
));
1139 xsignal2 (Lisp_Object error_symbol
, Lisp_Object arg1
, Lisp_Object arg2
)
1141 xsignal (error_symbol
, list2 (arg1
, arg2
));
1145 xsignal3 (Lisp_Object error_symbol
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
1147 xsignal (error_symbol
, list3 (arg1
, arg2
, arg3
));
1150 /* Signal `error' with message S, and additional arg ARG.
1151 If ARG is not a genuine list, make it a one-element list. */
1154 signal_error (const char *s
, Lisp_Object arg
)
1156 Lisp_Object tortoise
, hare
;
1158 hare
= tortoise
= arg
;
1159 while (CONSP (hare
))
1166 tortoise
= XCDR (tortoise
);
1168 if (EQ (hare
, tortoise
))
1175 xsignal (Qerror
, Fcons (build_string (s
), arg
));
1179 /* Return true if LIST is a non-nil atom or
1180 a list containing one of CONDITIONS. */
1183 wants_debugger (Lisp_Object list
, Lisp_Object conditions
)
1190 while (CONSP (conditions
))
1192 Lisp_Object
this, tail
;
1193 this = XCAR (conditions
);
1194 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1195 if (EQ (XCAR (tail
), this))
1197 conditions
= XCDR (conditions
);
1202 /* Return true if an error with condition-symbols CONDITIONS,
1203 and described by SIGNAL-DATA, should skip the debugger
1204 according to debugger-ignored-errors. */
1207 skip_debugger (Lisp_Object conditions
, Lisp_Object data
)
1210 bool first_string
= 1;
1211 Lisp_Object error_message
;
1213 error_message
= Qnil
;
1214 for (tail
= Vdebug_ignored_errors
; CONSP (tail
); tail
= XCDR (tail
))
1216 if (STRINGP (XCAR (tail
)))
1220 error_message
= Ferror_message_string (data
);
1224 if (fast_string_match (XCAR (tail
), error_message
) >= 0)
1229 Lisp_Object contail
;
1231 for (contail
= conditions
; CONSP (contail
); contail
= XCDR (contail
))
1232 if (EQ (XCAR (tail
), XCAR (contail
)))
1240 /* Call the debugger if calling it is currently enabled for CONDITIONS.
1241 SIG and DATA describe the signal. There are two ways to pass them:
1242 = SIG is the error symbol, and DATA is the rest of the data.
1243 = SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
1244 This is for memory-full errors only. */
1246 maybe_call_debugger (Lisp_Object conditions
, Lisp_Object sig
, Lisp_Object data
)
1248 Lisp_Object combined_data
;
1250 combined_data
= Fcons (sig
, data
);
1253 /* Don't try to run the debugger with interrupts blocked.
1254 The editing loop would return anyway. */
1255 ! input_blocked_p ()
1256 && NILP (Vinhibit_debugger
)
1257 /* Does user want to enter debugger for this kind of error? */
1260 : wants_debugger (Vdebug_on_error
, conditions
))
1261 && ! skip_debugger (conditions
, combined_data
)
1262 /* RMS: What's this for? */
1263 && when_entered_debugger
< num_nonmacro_input_events
)
1265 call_debugger (list2 (Qerror
, combined_data
));
1273 find_handler_clause (Lisp_Object handlers
, Lisp_Object conditions
)
1275 register Lisp_Object h
;
1277 /* t is used by handlers for all conditions, set up by C code. */
1278 if (EQ (handlers
, Qt
))
1281 /* error is used similarly, but means print an error message
1282 and run the debugger if that is enabled. */
1283 if (EQ (handlers
, Qerror
))
1286 for (h
= handlers
; CONSP (h
); h
= XCDR (h
))
1288 Lisp_Object handler
= XCAR (h
);
1289 if (!NILP (Fmemq (handler
, conditions
)))
1297 /* Dump an error message; called like vprintf. */
1299 verror (const char *m
, va_list ap
)
1302 ptrdiff_t size
= sizeof buf
;
1303 ptrdiff_t size_max
= STRING_BYTES_BOUND
+ 1;
1308 used
= evxprintf (&buffer
, &size
, buf
, size_max
, m
, ap
);
1309 string
= make_string (buffer
, used
);
1313 xsignal1 (Qerror
, string
);
1317 /* Dump an error message; called like printf. */
1321 error (const char *m
, ...)
1328 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 2, 0,
1329 doc
: /* Non-nil if FUNCTION makes provisions for interactive calling.
1330 This means it contains a description for how to read arguments to give it.
1331 The value is nil for an invalid function or a symbol with no function
1334 Interactively callable functions include strings and vectors (treated
1335 as keyboard macros), lambda-expressions that contain a top-level call
1336 to `interactive', autoload definitions made by `autoload' with non-nil
1337 fourth argument, and some of the built-in functions of Lisp.
1339 Also, a symbol satisfies `commandp' if its function definition does so.
1341 If the optional argument FOR-CALL-INTERACTIVELY is non-nil,
1342 then strings and vectors are not accepted. */)
1343 (Lisp_Object function
, Lisp_Object for_call_interactively
)
1345 register Lisp_Object fun
;
1346 register Lisp_Object funcar
;
1347 Lisp_Object if_prop
= Qnil
;
1351 fun
= indirect_function (fun
); /* Check cycles. */
1355 /* Check an `interactive-form' property if present, analogous to the
1356 function-documentation property. */
1358 while (SYMBOLP (fun
))
1360 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
1363 fun
= Fsymbol_function (fun
);
1366 if (scm_is_true (scm_procedure_p (fun
)))
1367 return (scm_is_pair (scm_assq (Qinteractive_form
,
1368 scm_procedure_properties (fun
)))
1370 /* Bytecode objects are interactive if they are long enough to
1371 have an element whose index is COMPILED_INTERACTIVE, which is
1372 where the interactive spec is stored. */
1373 else if (COMPILEDP (fun
))
1374 return ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
1377 /* Strings and vectors are keyboard macros. */
1378 if (STRINGP (fun
) || VECTORP (fun
))
1379 return (NILP (for_call_interactively
) ? Qt
: Qnil
);
1381 /* Lists may represent commands. */
1384 funcar
= XCAR (fun
);
1385 if (EQ (funcar
, Qclosure
))
1386 return (!NILP (Fassq (Qinteractive
, Fcdr (Fcdr (XCDR (fun
)))))
1388 else if (EQ (funcar
, Qlambda
))
1389 return !NILP (Fassq (Qinteractive
, Fcdr (XCDR (fun
)))) ? Qt
: if_prop
;
1390 else if (EQ (funcar
, Qautoload
))
1391 return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun
))))) ? Qt
: if_prop
;
1396 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
1397 doc
: /* Define FUNCTION to autoload from FILE.
1398 FUNCTION is a symbol; FILE is a file name string to pass to `load'.
1399 Third arg DOCSTRING is documentation for the function.
1400 Fourth arg INTERACTIVE if non-nil says function can be called interactively.
1401 Fifth arg TYPE indicates the type of the object:
1402 nil or omitted says FUNCTION is a function,
1403 `keymap' says FUNCTION is really a keymap, and
1404 `macro' or t says FUNCTION is really a macro.
1405 Third through fifth args give info about the real definition.
1406 They default to nil.
1407 If FUNCTION is already defined other than as an autoload,
1408 this does nothing and returns nil. */)
1409 (Lisp_Object function
, Lisp_Object file
, Lisp_Object docstring
, Lisp_Object interactive
, Lisp_Object type
)
1411 CHECK_SYMBOL (function
);
1412 CHECK_STRING (file
);
1414 /* If function is defined and not as an autoload, don't override. */
1415 if (!NILP (SYMBOL_FUNCTION (function
))
1416 && !AUTOLOADP (SYMBOL_FUNCTION (function
)))
1419 return Fdefalias (function
,
1420 list5 (Qautoload
, file
, docstring
, interactive
, type
),
1425 un_autoload (Lisp_Object oldqueue
)
1427 Lisp_Object queue
, first
, second
;
1429 /* Queue to unwind is current value of Vautoload_queue.
1430 oldqueue is the shadowed value to leave in Vautoload_queue. */
1431 queue
= Vautoload_queue
;
1432 Vautoload_queue
= oldqueue
;
1433 while (CONSP (queue
))
1435 first
= XCAR (queue
);
1436 second
= Fcdr (first
);
1437 first
= Fcar (first
);
1438 if (EQ (first
, make_number (0)))
1441 Ffset (first
, second
);
1442 queue
= XCDR (queue
);
1446 /* Load an autoloaded function.
1447 FUNNAME is the symbol which is the function's name.
1448 FUNDEF is the autoload definition (a list). */
1450 DEFUN ("autoload-do-load", Fautoload_do_load
, Sautoload_do_load
, 1, 3, 0,
1451 doc
: /* Load FUNDEF which should be an autoload.
1452 If non-nil, FUNNAME should be the symbol whose function value is FUNDEF,
1453 in which case the function returns the new autoloaded function value.
1454 If equal to `macro', MACRO-ONLY specifies that FUNDEF should only be loaded if
1455 it is defines a macro. */)
1456 (Lisp_Object fundef
, Lisp_Object funname
, Lisp_Object macro_only
)
1459 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1461 if (!CONSP (fundef
) || !EQ (Qautoload
, XCAR (fundef
))) {
1466 if (EQ (macro_only
, Qmacro
))
1468 Lisp_Object kind
= Fnth (make_number (4), fundef
);
1469 if (! (EQ (kind
, Qt
) || EQ (kind
, Qmacro
))) {
1475 /* This is to make sure that loadup.el gives a clear picture
1476 of what files are preloaded and when. */
1477 if (! NILP (Vpurify_flag
))
1478 error ("Attempt to autoload %s while preparing to dump",
1479 SDATA (SYMBOL_NAME (funname
)));
1481 CHECK_SYMBOL (funname
);
1482 GCPRO3 (funname
, fundef
, macro_only
);
1484 /* Preserve the match data. */
1485 record_unwind_save_match_data ();
1487 /* If autoloading gets an error (which includes the error of failing
1488 to define the function being called), we use Vautoload_queue
1489 to undo function definitions and `provide' calls made by
1490 the function. We do this in the specific case of autoloading
1491 because autoloading is not an explicit request "load this file",
1492 but rather a request to "call this function".
1494 The value saved here is to be restored into Vautoload_queue. */
1495 record_unwind_protect (un_autoload
, Vautoload_queue
);
1496 Vautoload_queue
= Qt
;
1497 /* If `macro_only', assume this autoload to be a "best-effort",
1498 so don't signal an error if autoloading fails. */
1499 Fload (Fcar (Fcdr (fundef
)), macro_only
, Qt
, Qnil
, Qt
);
1501 /* Once loading finishes, don't undo it. */
1502 Vautoload_queue
= Qt
;
1511 Lisp_Object fun
= Findirect_function (funname
, Qnil
);
1513 if (!NILP (Fequal (fun
, fundef
)))
1514 error ("Autoloading failed to define function %s",
1515 SDATA (SYMBOL_NAME (funname
)));
1522 DEFUN ("eval", Feval
, Seval
, 1, 2, 0,
1523 doc
: /* Evaluate FORM and return its value.
1524 If LEXICAL is t, evaluate using lexical scoping.
1525 LEXICAL can also be an actual lexical environment, in the form of an
1526 alist mapping symbols to their value. */)
1527 (Lisp_Object form
, Lisp_Object lexical
)
1530 specbind (Qinternal_interpreter_environment
,
1531 CONSP (lexical
) || NILP (lexical
) ? lexical
: list1 (Qt
));
1532 Lisp_Object tem0
= eval_sub (form
);
1537 /* Grow the specpdl stack by one entry.
1538 The caller should have already initialized the entry.
1539 Signal an error on stack overflow.
1541 Make sure that there is always one unused entry past the top of the
1542 stack, so that the just-initialized entry is safely unwound if
1543 memory exhausted and an error is signaled here. Also, allocate a
1544 never-used entry just before the bottom of the stack; sometimes its
1545 address is taken. */
1552 if (specpdl_ptr
== specpdl
+ specpdl_size
)
1554 ptrdiff_t count
= SPECPDL_INDEX ();
1555 ptrdiff_t max_size
= min (max_specpdl_size
, PTRDIFF_MAX
- 1000);
1556 union specbinding
*pdlvec
= specpdl
- 1;
1557 ptrdiff_t pdlvecsize
= specpdl_size
+ 1;
1558 if (max_size
<= specpdl_size
)
1560 if (max_specpdl_size
< 400)
1561 max_size
= max_specpdl_size
= 400;
1562 if (max_size
<= specpdl_size
)
1563 signal_error ("Variable binding depth exceeds max-specpdl-size",
1566 pdlvec
= xpalloc (pdlvec
, &pdlvecsize
, 1, max_size
+ 1, sizeof *specpdl
);
1567 specpdl
= pdlvec
+ 1;
1568 specpdl_size
= pdlvecsize
- 1;
1569 specpdl_ptr
= specpdl
+ count
;
1574 record_in_backtrace (Lisp_Object function
, Lisp_Object
*args
, ptrdiff_t nargs
)
1576 eassert (nargs
>= UNEVALLED
);
1577 specpdl_ptr
->bt
.kind
= SPECPDL_BACKTRACE
;
1578 specpdl_ptr
->bt
.debug_on_exit
= false;
1579 specpdl_ptr
->bt
.function
= function
;
1580 specpdl_ptr
->bt
.args
= args
;
1581 specpdl_ptr
->bt
.nargs
= nargs
;
1583 scm_dynwind_unwind_handler (unbind_once
, NULL
, SCM_F_WIND_EXPLICITLY
);
1587 set_lisp_eval_depth (void *data
)
1589 EMACS_INT n
= (EMACS_INT
) data
;
1590 lisp_eval_depth
= n
;
1593 /* Eval a sub-expression of the current expression (i.e. in the same
1596 eval_sub_1 (Lisp_Object form
)
1598 Lisp_Object fun
, val
, original_fun
, original_args
;
1600 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1604 /* Look up its binding in the lexical environment.
1605 We do not pay attention to the declared_special flag here, since we
1606 already did that when let-binding the variable. */
1607 Lisp_Object lex_binding
1608 = !NILP (Vinternal_interpreter_environment
) /* Mere optimization! */
1609 ? Fassq (form
, Vinternal_interpreter_environment
)
1611 if (CONSP (lex_binding
))
1612 return XCDR (lex_binding
);
1614 return Fsymbol_value (form
);
1626 scm_dynwind_begin (0);
1627 scm_dynwind_unwind_handler (set_lisp_eval_depth
,
1628 (void *) lisp_eval_depth
,
1629 SCM_F_WIND_EXPLICITLY
);
1631 if (++lisp_eval_depth
> max_lisp_eval_depth
)
1633 if (max_lisp_eval_depth
< 100)
1634 max_lisp_eval_depth
= 100;
1635 if (lisp_eval_depth
> max_lisp_eval_depth
)
1636 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
1639 original_fun
= XCAR (form
);
1640 original_args
= XCDR (form
);
1642 /* This also protects them from gc. */
1643 record_in_backtrace (original_fun
, &original_args
, UNEVALLED
);
1645 if (debug_on_next_call
)
1646 do_debug_on_call (Qt
);
1648 /* At this point, only original_fun and original_args
1649 have values that will be used below. */
1652 /* Optimize for no indirection. */
1655 fun
= Ffunction (Fcons (fun
, Qnil
));
1656 else if (!NILP (fun
) && (fun
= SYMBOL_FUNCTION (fun
), SYMBOLP (fun
)))
1657 fun
= indirect_function (fun
);
1659 if (COMPILEDP (fun
))
1660 val
= apply_lambda (fun
, original_args
);
1662 val
= scm_call_1 (eval_fn
, form
);
1664 if (backtrace_debug_on_exit (specpdl_ptr
- 1))
1665 val
= call_debugger (list2 (Qexit
, val
));
1672 eval_sub (Lisp_Object form
)
1674 return scm_c_value_ref (eval_sub_1 (form
), 0);
1678 values_to_list (Lisp_Object values
)
1680 Lisp_Object list
= Qnil
;
1681 for (int i
= scm_c_nvalues (values
) - 1; i
>= 0; i
--)
1682 list
= Fcons (scm_c_value_ref (values
, i
), list
);
1686 DEFUN ("multiple-value-call", Fmultiple_value_call
, Smultiple_value_call
,
1688 doc
: /* Call with multiple values.
1689 usage: (multiple-value-call FUNCTION-FORM FORM) */)
1692 Lisp_Object function_form
= eval_sub (XCAR (args
));
1693 Lisp_Object values
= Qnil
;
1694 while (CONSP (args
= XCDR (args
)))
1695 values
= nconc2 (Fnreverse (values_to_list (eval_sub_1 (XCAR (args
)))),
1697 return apply1 (function_form
, Fnreverse (values
));
1700 DEFUN ("values", Fvalues
, Svalues
, 0, MANY
, 0,
1701 doc
: /* Return multiple values. */)
1702 (ptrdiff_t nargs
, Lisp_Object
*args
)
1704 return scm_c_values (args
, nargs
);
1708 Fapply (ptrdiff_t nargs
, Lisp_Object
*args
)
1712 register Lisp_Object spread_arg
;
1713 register Lisp_Object
*funcall_args
;
1714 Lisp_Object fun
, retval
;
1715 struct gcpro gcpro1
;
1720 spread_arg
= args
[nargs
- 1];
1721 CHECK_LIST (spread_arg
);
1723 numargs
= XINT (Flength (spread_arg
));
1726 return Ffuncall (nargs
- 1, args
);
1727 else if (numargs
== 1)
1729 args
[nargs
- 1] = XCAR (spread_arg
);
1730 return Ffuncall (nargs
, args
);
1733 numargs
+= nargs
- 2;
1735 /* Optimize for no indirection. */
1736 if (SYMBOLP (fun
) && !NILP (fun
)
1737 && (fun
= SYMBOL_FUNCTION (fun
), SYMBOLP (fun
)))
1738 fun
= indirect_function (fun
);
1741 /* Let funcall get the error. */
1745 /* We add 1 to numargs because funcall_args includes the
1746 function itself as well as its arguments. */
1749 SAFE_ALLOCA_LISP (funcall_args
, 1 + numargs
);
1750 GCPRO1 (*funcall_args
);
1751 gcpro1
.nvars
= 1 + numargs
;
1754 memcpy (funcall_args
, args
, nargs
* word_size
);
1755 /* Spread the last arg we got. Its first element goes in
1756 the slot that it used to occupy, hence this value of I. */
1758 while (!NILP (spread_arg
))
1760 funcall_args
[i
++] = XCAR (spread_arg
);
1761 spread_arg
= XCDR (spread_arg
);
1764 /* By convention, the caller needs to gcpro Ffuncall's args. */
1765 retval
= Ffuncall (gcpro1
.nvars
, funcall_args
);
1772 /* Run hook variables in various ways. */
1775 funcall_nil (ptrdiff_t nargs
, Lisp_Object
*args
)
1777 Ffuncall (nargs
, args
);
1781 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 0, MANY
, 0,
1782 doc
: /* Run each hook in HOOKS.
1783 Each argument should be a symbol, a hook variable.
1784 These symbols are processed in the order specified.
1785 If a hook symbol has a non-nil value, that value may be a function
1786 or a list of functions to be called to run the hook.
1787 If the value is a function, it is called with no arguments.
1788 If it is a list, the elements are called, in order, with no arguments.
1790 Major modes should not use this function directly to run their mode
1791 hook; they should use `run-mode-hooks' instead.
1793 Do not use `make-local-variable' to make a hook variable buffer-local.
1794 Instead, use `add-hook' and specify t for the LOCAL argument.
1795 usage: (run-hooks &rest HOOKS) */)
1796 (ptrdiff_t nargs
, Lisp_Object
*args
)
1798 Lisp_Object hook
[1];
1801 for (i
= 0; i
< nargs
; i
++)
1804 run_hook_with_args (1, hook
, funcall_nil
);
1810 DEFUN ("run-hook-with-args", Frun_hook_with_args
,
1811 Srun_hook_with_args
, 1, MANY
, 0,
1812 doc
: /* Run HOOK with the specified arguments ARGS.
1813 HOOK should be a symbol, a hook variable. The value of HOOK
1814 may be nil, a function, or a list of functions. Call each
1815 function in order with arguments ARGS. The final return value
1818 Do not use `make-local-variable' to make a hook variable buffer-local.
1819 Instead, use `add-hook' and specify t for the LOCAL argument.
1820 usage: (run-hook-with-args HOOK &rest ARGS) */)
1821 (ptrdiff_t nargs
, Lisp_Object
*args
)
1823 return run_hook_with_args (nargs
, args
, funcall_nil
);
1826 /* NB this one still documents a specific non-nil return value.
1827 (As did run-hook-with-args and run-hook-with-args-until-failure
1828 until they were changed in 24.1.) */
1829 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success
,
1830 Srun_hook_with_args_until_success
, 1, MANY
, 0,
1831 doc
: /* Run HOOK with the specified arguments ARGS.
1832 HOOK should be a symbol, a hook variable. The value of HOOK
1833 may be nil, a function, or a list of functions. Call each
1834 function in order with arguments ARGS, stopping at the first
1835 one that returns non-nil, and return that value. Otherwise (if
1836 all functions return nil, or if there are no functions to call),
1839 Do not use `make-local-variable' to make a hook variable buffer-local.
1840 Instead, use `add-hook' and specify t for the LOCAL argument.
1841 usage: (run-hook-with-args-until-success HOOK &rest ARGS) */)
1842 (ptrdiff_t nargs
, Lisp_Object
*args
)
1844 return run_hook_with_args (nargs
, args
, Ffuncall
);
1848 funcall_not (ptrdiff_t nargs
, Lisp_Object
*args
)
1850 return NILP (Ffuncall (nargs
, args
)) ? Qt
: Qnil
;
1853 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure
,
1854 Srun_hook_with_args_until_failure
, 1, MANY
, 0,
1855 doc
: /* Run HOOK with the specified arguments ARGS.
1856 HOOK should be a symbol, a hook variable. The value of HOOK
1857 may be nil, a function, or a list of functions. Call each
1858 function in order with arguments ARGS, stopping at the first
1859 one that returns nil, and return nil. Otherwise (if all functions
1860 return non-nil, or if there are no functions to call), return non-nil
1861 \(do not rely on the precise return value in this case).
1863 Do not use `make-local-variable' to make a hook variable buffer-local.
1864 Instead, use `add-hook' and specify t for the LOCAL argument.
1865 usage: (run-hook-with-args-until-failure HOOK &rest ARGS) */)
1866 (ptrdiff_t nargs
, Lisp_Object
*args
)
1868 return NILP (run_hook_with_args (nargs
, args
, funcall_not
)) ? Qt
: Qnil
;
1872 run_hook_wrapped_funcall (ptrdiff_t nargs
, Lisp_Object
*args
)
1874 Lisp_Object tmp
= args
[0], ret
;
1877 ret
= Ffuncall (nargs
, args
);
1883 DEFUN ("run-hook-wrapped", Frun_hook_wrapped
, Srun_hook_wrapped
, 2, MANY
, 0,
1884 doc
: /* Run HOOK, passing each function through WRAP-FUNCTION.
1885 I.e. instead of calling each function FUN directly with arguments ARGS,
1886 it calls WRAP-FUNCTION with arguments FUN and ARGS.
1887 As soon as a call to WRAP-FUNCTION returns non-nil, `run-hook-wrapped'
1888 aborts and returns that value.
1889 usage: (run-hook-wrapped HOOK WRAP-FUNCTION &rest ARGS) */)
1890 (ptrdiff_t nargs
, Lisp_Object
*args
)
1892 return run_hook_with_args (nargs
, args
, run_hook_wrapped_funcall
);
1895 /* ARGS[0] should be a hook symbol.
1896 Call each of the functions in the hook value, passing each of them
1897 as arguments all the rest of ARGS (all NARGS - 1 elements).
1898 FUNCALL specifies how to call each function on the hook.
1899 The caller (or its caller, etc) must gcpro all of ARGS,
1900 except that it isn't necessary to gcpro ARGS[0]. */
1903 run_hook_with_args (ptrdiff_t nargs
, Lisp_Object
*args
,
1904 Lisp_Object (*funcall
) (ptrdiff_t nargs
, Lisp_Object
*args
))
1906 Lisp_Object sym
, val
, ret
= Qnil
;
1907 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1909 /* If we are dying or still initializing,
1910 don't do anything--it would probably crash if we tried. */
1911 if (NILP (Vrun_hooks
))
1915 val
= find_symbol_value (sym
);
1917 if (EQ (val
, Qunbound
) || NILP (val
))
1919 else if (!CONSP (val
) || FUNCTIONP (val
))
1922 return funcall (nargs
, args
);
1926 Lisp_Object global_vals
= Qnil
;
1927 GCPRO3 (sym
, val
, global_vals
);
1930 CONSP (val
) && NILP (ret
);
1933 if (EQ (XCAR (val
), Qt
))
1935 /* t indicates this hook has a local binding;
1936 it means to run the global binding too. */
1937 global_vals
= Fdefault_value (sym
);
1938 if (NILP (global_vals
)) continue;
1940 if (!CONSP (global_vals
) || EQ (XCAR (global_vals
), Qlambda
))
1942 args
[0] = global_vals
;
1943 ret
= funcall (nargs
, args
);
1948 CONSP (global_vals
) && NILP (ret
);
1949 global_vals
= XCDR (global_vals
))
1951 args
[0] = XCAR (global_vals
);
1952 /* In a global value, t should not occur. If it does, we
1953 must ignore it to avoid an endless loop. */
1954 if (!EQ (args
[0], Qt
))
1955 ret
= funcall (nargs
, args
);
1961 args
[0] = XCAR (val
);
1962 ret
= funcall (nargs
, args
);
1971 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
1974 run_hook_with_args_2 (Lisp_Object hook
, Lisp_Object arg1
, Lisp_Object arg2
)
1976 Lisp_Object temp
[3];
1981 Frun_hook_with_args (3, temp
);
1984 /* Apply fn to arg. */
1986 apply1 (Lisp_Object fn
, Lisp_Object arg
)
1988 struct gcpro gcpro1
;
1992 return Ffuncall (1, &fn
);
1995 Lisp_Object args
[2];
1999 return Fapply (2, args
);
2003 /* Call function fn on no arguments. */
2005 call0 (Lisp_Object fn
)
2007 struct gcpro gcpro1
;
2010 return Ffuncall (1, &fn
);
2013 /* Call function fn with 1 argument arg1. */
2016 call1 (Lisp_Object fn
, Lisp_Object arg1
)
2018 struct gcpro gcpro1
;
2019 Lisp_Object args
[2];
2025 return Ffuncall (2, args
);
2028 /* Call function fn with 2 arguments arg1, arg2. */
2031 call2 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
)
2033 struct gcpro gcpro1
;
2034 Lisp_Object args
[3];
2040 return Ffuncall (3, args
);
2043 /* Call function fn with 3 arguments arg1, arg2, arg3. */
2046 call3 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
2048 struct gcpro gcpro1
;
2049 Lisp_Object args
[4];
2056 return Ffuncall (4, args
);
2059 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4. */
2062 call4 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2065 struct gcpro gcpro1
;
2066 Lisp_Object args
[5];
2074 return Ffuncall (5, args
);
2077 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5. */
2080 call5 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2081 Lisp_Object arg4
, Lisp_Object arg5
)
2083 struct gcpro gcpro1
;
2084 Lisp_Object args
[6];
2093 return Ffuncall (6, args
);
2096 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6. */
2099 call6 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2100 Lisp_Object arg4
, Lisp_Object arg5
, Lisp_Object arg6
)
2102 struct gcpro gcpro1
;
2103 Lisp_Object args
[7];
2113 return Ffuncall (7, args
);
2116 /* Call function fn with 7 arguments arg1, arg2, arg3, arg4, arg5, arg6, arg7. */
2119 call7 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2120 Lisp_Object arg4
, Lisp_Object arg5
, Lisp_Object arg6
, Lisp_Object arg7
)
2122 struct gcpro gcpro1
;
2123 Lisp_Object args
[8];
2134 return Ffuncall (8, args
);
2137 /* The caller should GCPRO all the elements of ARGS. */
2139 DEFUN ("functionp", Ffunctionp
, Sfunctionp
, 1, 1, 0,
2140 doc
: /* Non-nil if OBJECT is a function. */)
2141 (Lisp_Object object
)
2143 if (FUNCTIONP (object
))
2149 Ffuncall1 (ptrdiff_t nargs
, Lisp_Object
*args
)
2151 return scm_call_n (funcall_fn
, args
, nargs
);
2155 Ffuncall (ptrdiff_t nargs
, Lisp_Object
*args
)
2157 return scm_c_value_ref (Ffuncall1 (nargs
, args
), 0);
2161 apply_lambda (Lisp_Object fun
, Lisp_Object args
)
2163 Lisp_Object args_left
;
2166 register Lisp_Object
*arg_vector
;
2167 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2168 register Lisp_Object tem
;
2171 numargs
= XFASTINT (Flength (args
));
2172 SAFE_ALLOCA_LISP (arg_vector
, numargs
);
2175 GCPRO3 (*arg_vector
, args_left
, fun
);
2178 for (i
= 0; i
< numargs
; )
2180 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
2181 tem
= eval_sub (tem
);
2182 arg_vector
[i
++] = tem
;
2188 set_backtrace_args (specpdl_ptr
- 1, arg_vector
);
2189 set_backtrace_nargs (specpdl_ptr
- 1, i
);
2190 tem
= funcall_lambda (fun
, numargs
, arg_vector
);
2192 /* Do the debug-on-exit now, while arg_vector still exists. */
2193 if (backtrace_debug_on_exit (specpdl_ptr
- 1))
2195 /* Don't do it again when we return to eval. */
2196 set_backtrace_debug_on_exit (specpdl_ptr
- 1, false);
2197 tem
= call_debugger (list2 (Qexit
, tem
));
2203 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
2204 and return the result of evaluation.
2205 FUN must be either a lambda-expression or a compiled-code object. */
2208 funcall_lambda (Lisp_Object fun
, ptrdiff_t nargs
,
2209 register Lisp_Object
*arg_vector
)
2211 Lisp_Object val
, syms_left
, next
, lexenv
;
2214 bool optional
, rest
;
2218 if (EQ (XCAR (fun
), Qclosure
))
2220 fun
= XCDR (fun
); /* Drop `closure'. */
2221 lexenv
= XCAR (fun
);
2222 CHECK_LIST_CONS (fun
, fun
);
2226 syms_left
= XCDR (fun
);
2227 if (CONSP (syms_left
))
2228 syms_left
= XCAR (syms_left
);
2230 xsignal1 (Qinvalid_function
, fun
);
2232 else if (COMPILEDP (fun
))
2234 syms_left
= AREF (fun
, COMPILED_ARGLIST
);
2235 if (INTEGERP (syms_left
))
2236 /* A byte-code object with a non-nil `push args' slot means we
2237 shouldn't bind any arguments, instead just call the byte-code
2238 interpreter directly; it will push arguments as necessary.
2240 Byte-code objects with either a non-existent, or a nil value for
2241 the `push args' slot (the default), have dynamically-bound
2242 arguments, and use the argument-binding code below instead (as do
2243 all interpreted functions, even lexically bound ones). */
2245 /* If we have not actually read the bytecode string
2246 and constants vector yet, fetch them from the file. */
2247 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
2248 Ffetch_bytecode (fun
);
2250 return exec_byte_code (AREF (fun
, COMPILED_BYTECODE
),
2251 AREF (fun
, COMPILED_CONSTANTS
),
2252 AREF (fun
, COMPILED_STACK_DEPTH
),
2261 i
= optional
= rest
= 0;
2262 for (; CONSP (syms_left
); syms_left
= XCDR (syms_left
))
2266 next
= XCAR (syms_left
);
2267 if (!SYMBOLP (next
))
2268 xsignal1 (Qinvalid_function
, fun
);
2270 if (EQ (next
, Qand_rest
))
2272 else if (EQ (next
, Qand_optional
))
2279 arg
= Flist (nargs
- i
, &arg_vector
[i
]);
2283 arg
= arg_vector
[i
++];
2285 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
2289 /* Bind the argument. */
2290 if (!NILP (lexenv
) && SYMBOLP (next
))
2291 /* Lexically bind NEXT by adding it to the lexenv alist. */
2292 lexenv
= Fcons (Fcons (next
, arg
), lexenv
);
2294 /* Dynamically bind NEXT. */
2295 specbind (next
, arg
);
2299 if (!NILP (syms_left
))
2300 xsignal1 (Qinvalid_function
, fun
);
2302 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
2304 if (!EQ (lexenv
, Vinternal_interpreter_environment
))
2305 /* Instantiate a new lexical environment. */
2306 specbind (Qinternal_interpreter_environment
, lexenv
);
2309 val
= Fprogn (XCDR (XCDR (fun
)));
2312 /* If we have not actually read the bytecode string
2313 and constants vector yet, fetch them from the file. */
2314 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
2315 Ffetch_bytecode (fun
);
2316 val
= exec_byte_code (AREF (fun
, COMPILED_BYTECODE
),
2317 AREF (fun
, COMPILED_CONSTANTS
),
2318 AREF (fun
, COMPILED_STACK_DEPTH
),
2326 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
2328 doc
: /* If byte-compiled OBJECT is lazy-loaded, fetch it now. */)
2329 (Lisp_Object object
)
2333 if (COMPILEDP (object
) && CONSP (AREF (object
, COMPILED_BYTECODE
)))
2335 tem
= read_doc_string (AREF (object
, COMPILED_BYTECODE
));
2338 tem
= AREF (object
, COMPILED_BYTECODE
);
2339 if (CONSP (tem
) && STRINGP (XCAR (tem
)))
2340 error ("Invalid byte code in %s", SDATA (XCAR (tem
)));
2342 error ("Invalid byte code");
2344 ASET (object
, COMPILED_BYTECODE
, XCAR (tem
));
2345 ASET (object
, COMPILED_CONSTANTS
, XCDR (tem
));
2350 /* Return true if SYMBOL currently has a let-binding
2351 which was made in the buffer that is now current. */
2354 let_shadows_buffer_binding_p (sym_t symbol
)
2356 union specbinding
*p
;
2357 Lisp_Object buf
= Fcurrent_buffer ();
2359 for (p
= specpdl_ptr
; p
> specpdl
; )
2360 if ((--p
)->kind
> SPECPDL_LET
)
2362 sym_t let_bound_symbol
= XSYMBOL (specpdl_symbol (p
));
2363 eassert (SYMBOL_REDIRECT (let_bound_symbol
) != SYMBOL_VARALIAS
);
2364 if (symbol
== let_bound_symbol
2365 && EQ (specpdl_where (p
), buf
))
2373 let_shadows_global_binding_p (Lisp_Object symbol
)
2375 union specbinding
*p
;
2377 for (p
= specpdl_ptr
; p
> specpdl
; )
2378 if ((--p
)->kind
>= SPECPDL_LET
&& EQ (specpdl_symbol (p
), symbol
))
2384 /* `specpdl_ptr' describes which variable is
2385 let-bound, so it can be properly undone when we unbind_to.
2386 It can be either a plain SPECPDL_LET or a SPECPDL_LET_LOCAL/DEFAULT.
2387 - SYMBOL is the variable being bound. Note that it should not be
2388 aliased (i.e. when let-binding V1 that's aliased to V2, we want
2390 - WHERE tells us in which buffer the binding took place.
2391 This is used for SPECPDL_LET_LOCAL bindings (i.e. bindings to a
2392 buffer-local variable) as well as for SPECPDL_LET_DEFAULT bindings,
2393 i.e. bindings to the default value of a variable which can be
2397 specbind (Lisp_Object symbol
, Lisp_Object value
)
2401 CHECK_SYMBOL (symbol
);
2402 sym
= XSYMBOL (symbol
);
2405 switch (SYMBOL_REDIRECT (sym
))
2407 case SYMBOL_VARALIAS
:
2408 sym
= indirect_variable (sym
); XSETSYMBOL (symbol
, sym
); goto start
;
2409 case SYMBOL_PLAINVAL
:
2410 /* The most common case is that of a non-constant symbol with a
2411 trivial value. Make that as fast as we can. */
2412 specpdl_ptr
->let
.kind
= SPECPDL_LET
;
2413 specpdl_ptr
->let
.symbol
= symbol
;
2414 specpdl_ptr
->let
.old_value
= SYMBOL_VAL (sym
);
2416 if (! SYMBOL_CONSTANT (sym
))
2417 SET_SYMBOL_VAL (sym
, value
);
2419 set_internal (symbol
, value
, Qnil
, 1);
2421 case SYMBOL_LOCALIZED
:
2422 if (SYMBOL_BLV (sym
)->frame_local
)
2423 error ("Frame-local vars cannot be let-bound");
2424 case SYMBOL_FORWARDED
:
2426 Lisp_Object ovalue
= find_symbol_value (symbol
);
2427 specpdl_ptr
->let
.kind
= SPECPDL_LET_LOCAL
;
2428 specpdl_ptr
->let
.symbol
= symbol
;
2429 specpdl_ptr
->let
.old_value
= ovalue
;
2430 specpdl_ptr
->let
.where
= Fcurrent_buffer ();
2432 eassert (SYMBOL_REDIRECT (sym
) != SYMBOL_LOCALIZED
2433 || (EQ (SYMBOL_BLV (sym
)->where
, Fcurrent_buffer ())));
2435 if (SYMBOL_REDIRECT (sym
) == SYMBOL_LOCALIZED
)
2437 if (!blv_found (SYMBOL_BLV (sym
)))
2438 specpdl_ptr
->let
.kind
= SPECPDL_LET_DEFAULT
;
2440 else if (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)))
2442 /* If SYMBOL is a per-buffer variable which doesn't have a
2443 buffer-local value here, make the `let' change the global
2444 value by changing the value of SYMBOL in all buffers not
2445 having their own value. This is consistent with what
2446 happens with other buffer-local variables. */
2447 if (NILP (Flocal_variable_p (symbol
, Qnil
)))
2449 specpdl_ptr
->let
.kind
= SPECPDL_LET_DEFAULT
;
2451 Fset_default (symbol
, value
);
2456 specpdl_ptr
->let
.kind
= SPECPDL_LET
;
2459 set_internal (symbol
, value
, Qnil
, 1);
2462 default: emacs_abort ();
2466 scm_dynwind_unwind_handler (unbind_once
, NULL
, SCM_F_WIND_EXPLICITLY
);
2469 /* Push unwind-protect entries of various types. */
2472 record_unwind_protect_1 (void (*function
) (Lisp_Object
), Lisp_Object arg
,
2473 bool wind_explicitly
)
2475 record_unwind_protect_ptr_1 (function
, arg
, wind_explicitly
);
2479 record_unwind_protect (void (*function
) (Lisp_Object
), Lisp_Object arg
)
2481 record_unwind_protect_1 (function
, arg
, true);
2485 record_unwind_protect_ptr_1 (void (*function
) (void *), void *arg
,
2486 bool wind_explicitly
)
2488 scm_dynwind_unwind_handler (function
,
2491 ? SCM_F_WIND_EXPLICITLY
2496 record_unwind_protect_ptr (void (*function
) (void *), void *arg
)
2498 record_unwind_protect_ptr_1 (function
, arg
, true);
2502 record_unwind_protect_int_1 (void (*function
) (int), int arg
,
2503 bool wind_explicitly
)
2505 record_unwind_protect_ptr_1 (function
, arg
, wind_explicitly
);
2509 record_unwind_protect_int (void (*function
) (int), int arg
)
2511 record_unwind_protect_int_1 (function
, arg
, true);
2515 call_void (void *data
)
2517 ((void (*) (void)) data
) ();
2521 record_unwind_protect_void_1 (void (*function
) (void),
2522 bool wind_explicitly
)
2524 record_unwind_protect_ptr_1 (call_void
, function
, wind_explicitly
);
2528 record_unwind_protect_void (void (*function
) (void))
2530 record_unwind_protect_void_1 (function
, true);
2534 unbind_once (void *ignore
)
2536 /* Decrement specpdl_ptr before we do the work to unbind it, so
2537 that an error in unbinding won't try to unbind the same entry
2538 again. Take care to copy any parts of the binding needed
2539 before invoking any code that can make more bindings. */
2543 switch (specpdl_ptr
->kind
)
2545 case SPECPDL_BACKTRACE
:
2548 { /* If variable has a trivial value (no forwarding), we can
2549 just set it. No need to check for constant symbols here,
2550 since that was already done by specbind. */
2551 sym_t sym
= XSYMBOL (specpdl_symbol (specpdl_ptr
));
2552 if (SYMBOL_REDIRECT (sym
) == SYMBOL_PLAINVAL
)
2554 SET_SYMBOL_VAL (sym
, specpdl_old_value (specpdl_ptr
));
2559 NOTE: we only ever come here if make_local_foo was used for
2560 the first time on this var within this let. */
2563 case SPECPDL_LET_DEFAULT
:
2564 Fset_default (specpdl_symbol (specpdl_ptr
),
2565 specpdl_old_value (specpdl_ptr
));
2567 case SPECPDL_LET_LOCAL
:
2569 Lisp_Object symbol
= specpdl_symbol (specpdl_ptr
);
2570 Lisp_Object where
= specpdl_where (specpdl_ptr
);
2571 Lisp_Object old_value
= specpdl_old_value (specpdl_ptr
);
2572 eassert (BUFFERP (where
));
2574 /* If this was a local binding, reset the value in the appropriate
2575 buffer, but only if that buffer's binding still exists. */
2576 if (!NILP (Flocal_variable_p (symbol
, where
)))
2577 set_internal (symbol
, old_value
, where
, 1);
2584 dynwind_begin (void)
2586 scm_dynwind_begin (0);
2595 DEFUN ("special-variable-p", Fspecial_variable_p
, Sspecial_variable_p
, 1, 1, 0,
2596 doc
: /* Return non-nil if SYMBOL's global binding has been declared special.
2597 A special variable is one that will be bound dynamically, even in a
2598 context where binding is lexical by default. */)
2599 (Lisp_Object symbol
)
2601 CHECK_SYMBOL (symbol
);
2602 return SYMBOL_DECLARED_SPECIAL (XSYMBOL (symbol
)) ? Qt
: Qnil
;
2606 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
2607 doc
: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
2608 The debugger is entered when that frame exits, if the flag is non-nil. */)
2609 (Lisp_Object level
, Lisp_Object flag
)
2611 union specbinding
*pdl
= backtrace_top ();
2612 register EMACS_INT i
;
2614 CHECK_NUMBER (level
);
2616 for (i
= 0; backtrace_p (pdl
) && i
< XINT (level
); i
++)
2617 pdl
= backtrace_next (pdl
);
2619 if (backtrace_p (pdl
))
2620 set_backtrace_debug_on_exit (pdl
, !NILP (flag
));
2625 DEFUN ("backtrace", Fbacktrace
, Sbacktrace
, 0, 0, "",
2626 doc
: /* Print a trace of Lisp function calls currently active.
2627 Output stream used is value of `standard-output'. */)
2630 union specbinding
*pdl
= backtrace_top ();
2632 Lisp_Object old_print_level
= Vprint_level
;
2634 if (NILP (Vprint_level
))
2635 XSETFASTINT (Vprint_level
, 8);
2637 while (backtrace_p (pdl
))
2639 write_string (backtrace_debug_on_exit (pdl
) ? "* " : " ", 2);
2640 if (backtrace_nargs (pdl
) == UNEVALLED
)
2642 Fprin1 (Fcons (backtrace_function (pdl
), *backtrace_args (pdl
)),
2644 write_string ("\n", -1);
2648 tem
= backtrace_function (pdl
);
2649 Fprin1 (tem
, Qnil
); /* This can QUIT. */
2650 write_string ("(", -1);
2653 for (i
= 0; i
< backtrace_nargs (pdl
); i
++)
2655 if (i
) write_string (" ", -1);
2656 Fprin1 (backtrace_args (pdl
)[i
], Qnil
);
2659 write_string (")\n", -1);
2661 pdl
= backtrace_next (pdl
);
2664 Vprint_level
= old_print_level
;
2668 static union specbinding
*
2669 get_backtrace_frame (Lisp_Object nframes
, Lisp_Object base
)
2671 union specbinding
*pdl
= backtrace_top ();
2672 register EMACS_INT i
;
2674 CHECK_NATNUM (nframes
);
2677 { /* Skip up to `base'. */
2678 base
= Findirect_function (base
, Qt
);
2679 while (backtrace_p (pdl
)
2680 && !EQ (base
, Findirect_function (backtrace_function (pdl
), Qt
)))
2681 pdl
= backtrace_next (pdl
);
2684 /* Find the frame requested. */
2685 for (i
= XFASTINT (nframes
); i
> 0 && backtrace_p (pdl
); i
--)
2686 pdl
= backtrace_next (pdl
);
2691 DEFUN ("backtrace-frame", Fbacktrace_frame
, Sbacktrace_frame
, 1, 2, NULL
,
2692 doc
: /* Return the function and arguments NFRAMES up from current execution point.
2693 If that frame has not evaluated the arguments yet (or is a special form),
2694 the value is (nil FUNCTION ARG-FORMS...).
2695 If that frame has evaluated its arguments and called its function already,
2696 the value is (t FUNCTION ARG-VALUES...).
2697 A &rest arg is represented as the tail of the list ARG-VALUES.
2698 FUNCTION is whatever was supplied as car of evaluated list,
2699 or a lambda expression for macro calls.
2700 If NFRAMES is more than the number of frames, the value is nil.
2701 If BASE is non-nil, it should be a function and NFRAMES counts from its
2702 nearest activation frame. */)
2703 (Lisp_Object nframes
, Lisp_Object base
)
2705 union specbinding
*pdl
= get_backtrace_frame (nframes
, base
);
2707 if (!backtrace_p (pdl
))
2709 if (backtrace_nargs (pdl
) == UNEVALLED
)
2711 Fcons (backtrace_function (pdl
), *backtrace_args (pdl
)));
2714 Lisp_Object tem
= Flist (backtrace_nargs (pdl
), backtrace_args (pdl
));
2716 return Fcons (Qt
, Fcons (backtrace_function (pdl
), tem
));
2720 /* For backtrace-eval, we want to temporarily unwind the last few elements of
2721 the specpdl stack, and then rewind them. We store the pre-unwind values
2722 directly in the pre-existing specpdl elements (i.e. we swap the current
2723 value and the old value stored in the specpdl), kind of like the inplace
2724 pointer-reversal trick. As it turns out, the rewind does the same as the
2725 unwind, except it starts from the other end of the specpdl stack, so we use
2726 the same function for both unwind and rewind. */
2728 backtrace_eval_unrewind (int distance
)
2730 union specbinding
*tmp
= specpdl_ptr
;
2733 { /* It's a rewind rather than unwind. */
2734 tmp
+= distance
- 1;
2736 distance
= -distance
;
2739 for (; distance
> 0; distance
--)
2745 case SPECPDL_BACKTRACE
:
2748 { /* If variable has a trivial value (no forwarding), we can
2749 just set it. No need to check for constant symbols here,
2750 since that was already done by specbind. */
2751 sym_t sym
= XSYMBOL (specpdl_symbol (tmp
));
2752 if (SYMBOL_REDIRECT (sym
) == SYMBOL_PLAINVAL
)
2754 Lisp_Object old_value
= specpdl_old_value (tmp
);
2755 set_specpdl_old_value (tmp
, SYMBOL_VAL (sym
));
2756 SET_SYMBOL_VAL (sym
, old_value
);
2761 NOTE: we only ever come here if make_local_foo was used for
2762 the first time on this var within this let. */
2765 case SPECPDL_LET_DEFAULT
:
2767 Lisp_Object sym
= specpdl_symbol (tmp
);
2768 Lisp_Object old_value
= specpdl_old_value (tmp
);
2769 set_specpdl_old_value (tmp
, Fdefault_value (sym
));
2770 Fset_default (sym
, old_value
);
2773 case SPECPDL_LET_LOCAL
:
2775 Lisp_Object symbol
= specpdl_symbol (tmp
);
2776 Lisp_Object where
= specpdl_where (tmp
);
2777 Lisp_Object old_value
= specpdl_old_value (tmp
);
2778 eassert (BUFFERP (where
));
2780 /* If this was a local binding, reset the value in the appropriate
2781 buffer, but only if that buffer's binding still exists. */
2782 if (!NILP (Flocal_variable_p (symbol
, where
)))
2784 set_specpdl_old_value
2785 (tmp
, Fbuffer_local_value (symbol
, where
));
2786 set_internal (symbol
, old_value
, where
, 1);
2794 DEFUN ("backtrace-eval", Fbacktrace_eval
, Sbacktrace_eval
, 2, 3, NULL
,
2795 doc
: /* Evaluate EXP in the context of some activation frame.
2796 NFRAMES and BASE specify the activation frame to use, as in `backtrace-frame'. */)
2797 (Lisp_Object exp
, Lisp_Object nframes
, Lisp_Object base
)
2799 union specbinding
*pdl
= get_backtrace_frame (nframes
, base
);
2801 ptrdiff_t distance
= specpdl_ptr
- pdl
;
2802 eassert (distance
>= 0);
2804 if (!backtrace_p (pdl
))
2805 error ("Activation frame not found!");
2807 backtrace_eval_unrewind (distance
);
2808 record_unwind_protect_int (backtrace_eval_unrewind
, -distance
);
2810 /* Use eval_sub rather than Feval since the main motivation behind
2811 backtrace-eval is to be able to get/set the value of lexical variables
2812 from the debugger. */
2813 Lisp_Object tem1
= eval_sub (exp
);
2818 DEFUN ("backtrace--locals", Fbacktrace__locals
, Sbacktrace__locals
, 1, 2, NULL
,
2819 doc
: /* Return names and values of local variables of a stack frame.
2820 NFRAMES and BASE specify the activation frame to use, as in `backtrace-frame'. */)
2821 (Lisp_Object nframes
, Lisp_Object base
)
2823 union specbinding
*frame
= get_backtrace_frame (nframes
, base
);
2824 union specbinding
*prevframe
2825 = get_backtrace_frame (make_number (XFASTINT (nframes
) - 1), base
);
2826 ptrdiff_t distance
= specpdl_ptr
- frame
;
2827 Lisp_Object result
= Qnil
;
2828 eassert (distance
>= 0);
2830 if (!backtrace_p (prevframe
))
2831 error ("Activation frame not found!");
2832 if (!backtrace_p (frame
))
2833 error ("Activation frame not found!");
2835 /* The specpdl entries normally contain the symbol being bound along with its
2836 `old_value', so it can be restored. The new value to which it is bound is
2837 available in one of two places: either in the current value of the
2838 variable (if it hasn't been rebound yet) or in the `old_value' slot of the
2839 next specpdl entry for it.
2840 `backtrace_eval_unrewind' happens to swap the role of `old_value'
2841 and "new value", so we abuse it here, to fetch the new value.
2842 It's ugly (we'd rather not modify global data) and a bit inefficient,
2843 but it does the job for now. */
2844 backtrace_eval_unrewind (distance
);
2848 union specbinding
*tmp
= prevframe
;
2849 for (; tmp
> frame
; tmp
--)
2854 case SPECPDL_LET_DEFAULT
:
2855 case SPECPDL_LET_LOCAL
:
2857 Lisp_Object sym
= specpdl_symbol (tmp
);
2858 Lisp_Object val
= specpdl_old_value (tmp
);
2859 if (EQ (sym
, Qinternal_interpreter_environment
))
2861 Lisp_Object env
= val
;
2862 for (; CONSP (env
); env
= XCDR (env
))
2864 Lisp_Object binding
= XCAR (env
);
2865 if (CONSP (binding
))
2866 result
= Fcons (Fcons (XCAR (binding
),
2872 result
= Fcons (Fcons (sym
, val
), result
);
2878 /* Restore values from specpdl to original place. */
2879 backtrace_eval_unrewind (-distance
);
2886 get_backtrace (Lisp_Object array
)
2888 union specbinding
*pdl
= backtrace_next (backtrace_top ());
2889 ptrdiff_t i
= 0, asize
= ASIZE (array
);
2891 /* Copy the backtrace contents into working memory. */
2892 for (; i
< asize
; i
++)
2894 if (backtrace_p (pdl
))
2896 ASET (array
, i
, backtrace_function (pdl
));
2897 pdl
= backtrace_next (pdl
);
2900 ASET (array
, i
, Qnil
);
2904 Lisp_Object
backtrace_top_function (void)
2906 union specbinding
*pdl
= backtrace_top ();
2907 return (backtrace_p (pdl
) ? backtrace_function (pdl
) : Qnil
);
2911 abort_to_prompt (SCM tag
, SCM arglst
)
2913 static SCM var
= SCM_UNDEFINED
;
2914 if (SCM_UNBNDP (var
))
2915 var
= scm_c_public_lookup ("guile", "abort-to-prompt");
2917 scm_apply_1 (scm_variable_ref (var
), tag
, arglst
);
2922 call_with_prompt (SCM tag
, SCM thunk
, SCM handler
)
2924 static SCM var
= SCM_UNDEFINED
;
2925 if (SCM_UNBNDP (var
))
2926 var
= scm_c_public_lookup ("guile", "call-with-prompt");
2928 return scm_call_3 (scm_variable_ref (var
), tag
, thunk
, handler
);
2932 make_prompt_tag (void)
2934 static SCM var
= SCM_UNDEFINED
;
2935 if (SCM_UNBNDP (var
))
2936 var
= scm_c_public_lookup ("guile", "make-prompt-tag");
2938 return scm_call_0 (scm_variable_ref (var
));
2946 DEFVAR_INT ("max-specpdl-size", max_specpdl_size
,
2947 doc
: /* Limit on number of Lisp variable bindings and `unwind-protect's.
2948 If Lisp code tries to increase the total number past this amount,
2949 an error is signaled.
2950 You can safely use a value considerably larger than the default value,
2951 if that proves inconveniently small. However, if you increase it too far,
2952 Emacs could run out of memory trying to make the stack bigger.
2953 Note that this limit may be silently increased by the debugger
2954 if `debug-on-error' or `debug-on-quit' is set. */);
2956 DEFVAR_INT ("max-lisp-eval-depth", max_lisp_eval_depth
,
2957 doc
: /* Limit on depth in `eval', `apply' and `funcall' before error.
2959 This limit serves to catch infinite recursions for you before they cause
2960 actual stack overflow in C, which would be fatal for Emacs.
2961 You can safely make it considerably larger than its default value,
2962 if that proves inconveniently small. However, if you increase it too far,
2963 Emacs could overflow the real C stack, and crash. */);
2965 DEFVAR_LISP ("quit-flag", Vquit_flag
,
2966 doc
: /* Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
2967 If the value is t, that means do an ordinary quit.
2968 If the value equals `throw-on-input', that means quit by throwing
2969 to the tag specified in `throw-on-input'; it's for handling `while-no-input'.
2970 Typing C-g sets `quit-flag' to t, regardless of `inhibit-quit',
2971 but `inhibit-quit' non-nil prevents anything from taking notice of that. */);
2974 DEFVAR_LISP ("inhibit-quit", Vinhibit_quit
,
2975 doc
: /* Non-nil inhibits C-g quitting from happening immediately.
2976 Note that `quit-flag' will still be set by typing C-g,
2977 so a quit will be signaled as soon as `inhibit-quit' is nil.
2978 To prevent this happening, set `quit-flag' to nil
2979 before making `inhibit-quit' nil. */);
2980 Vinhibit_quit
= Qnil
;
2982 DEFSYM (Qinhibit_quit
, "inhibit-quit");
2983 DEFSYM (Qautoload
, "autoload");
2984 DEFSYM (Qinhibit_debugger
, "inhibit-debugger");
2985 DEFSYM (Qmacro
, "macro");
2986 DEFSYM (Qdeclare
, "declare");
2988 /* Note that the process handling also uses Qexit, but we don't want
2989 to staticpro it twice, so we just do it here. */
2990 DEFSYM (Qexit
, "exit");
2992 DEFSYM (Qinteractive
, "interactive");
2993 DEFSYM (Qcommandp
, "commandp");
2994 DEFSYM (Qand_rest
, "&rest");
2995 DEFSYM (Qand_optional
, "&optional");
2996 DEFSYM (Qclosure
, "closure");
2997 DEFSYM (Qdebug
, "debug");
2999 DEFVAR_LISP ("inhibit-debugger", Vinhibit_debugger
,
3000 doc
: /* Non-nil means never enter the debugger.
3001 Normally set while the debugger is already active, to avoid recursive
3003 Vinhibit_debugger
= Qnil
;
3005 DEFVAR_LISP ("debug-on-error", Vdebug_on_error
,
3006 doc
: /* Non-nil means enter debugger if an error is signaled.
3007 Does not apply to errors handled by `condition-case' or those
3008 matched by `debug-ignored-errors'.
3009 If the value is a list, an error only means to enter the debugger
3010 if one of its condition symbols appears in the list.
3011 When you evaluate an expression interactively, this variable
3012 is temporarily non-nil if `eval-expression-debug-on-error' is non-nil.
3013 The command `toggle-debug-on-error' toggles this.
3014 See also the variable `debug-on-quit' and `inhibit-debugger'. */);
3015 Vdebug_on_error
= Qnil
;
3017 DEFVAR_LISP ("debug-ignored-errors", Vdebug_ignored_errors
,
3018 doc
: /* List of errors for which the debugger should not be called.
3019 Each element may be a condition-name or a regexp that matches error messages.
3020 If any element applies to a given error, that error skips the debugger
3021 and just returns to top level.
3022 This overrides the variable `debug-on-error'.
3023 It does not apply to errors handled by `condition-case'. */);
3024 Vdebug_ignored_errors
= Qnil
;
3026 DEFVAR_BOOL ("debug-on-quit", debug_on_quit
,
3027 doc
: /* Non-nil means enter debugger if quit is signaled (C-g, for example).
3028 Does not apply if quit is handled by a `condition-case'. */);
3031 DEFVAR_BOOL ("debug-on-next-call", debug_on_next_call
,
3032 doc
: /* Non-nil means enter debugger before next `eval', `apply' or `funcall'. */);
3034 DEFVAR_BOOL ("debugger-may-continue", debugger_may_continue
,
3035 doc
: /* Non-nil means debugger may continue execution.
3036 This is nil when the debugger is called under circumstances where it
3037 might not be safe to continue. */);
3038 debugger_may_continue
= 1;
3040 DEFVAR_LISP ("debugger", Vdebugger
,
3041 doc
: /* Function to call to invoke debugger.
3042 If due to frame exit, args are `exit' and the value being returned;
3043 this function's value will be returned instead of that.
3044 If due to error, args are `error' and a list of the args to `signal'.
3045 If due to `apply' or `funcall' entry, one arg, `lambda'.
3046 If due to `eval' entry, one arg, t. */);
3049 DEFVAR_LISP ("signal-hook-function", Vsignal_hook_function
,
3050 doc
: /* If non-nil, this is a function for `signal' to call.
3051 It receives the same arguments that `signal' was given.
3052 The Edebug package uses this to regain control. */);
3053 Vsignal_hook_function
= Qnil
;
3055 DEFVAR_LISP ("debug-on-signal", Vdebug_on_signal
,
3056 doc
: /* Non-nil means call the debugger regardless of condition handlers.
3057 Note that `debug-on-error', `debug-on-quit' and friends
3058 still determine whether to handle the particular condition. */);
3059 Vdebug_on_signal
= Qnil
;
3061 /* When lexical binding is being used,
3062 Vinternal_interpreter_environment is non-nil, and contains an alist
3063 of lexically-bound variable, or (t), indicating an empty
3064 environment. The lisp name of this variable would be
3065 `internal-interpreter-environment' if it weren't hidden.
3066 Every element of this list can be either a cons (VAR . VAL)
3067 specifying a lexical binding, or a single symbol VAR indicating
3068 that this variable should use dynamic scoping. */
3069 DEFSYM (Qinternal_interpreter_environment
,
3070 "internal-interpreter-environment");
3071 DEFVAR_LISP ("internal-interpreter-environment",
3072 Vinternal_interpreter_environment
,
3073 doc
: /* If non-nil, the current lexical environment of the lisp interpreter.
3074 When lexical binding is not being used, this variable is nil.
3075 A value of `(t)' indicates an empty environment, otherwise it is an
3076 alist of active lexical bindings. */);
3077 Vinternal_interpreter_environment
= Qnil
;
3078 /* Don't export this variable to Elisp, so no one can mess with it
3079 (Just imagine if someone makes it buffer-local). */
3080 //Funintern (Qinternal_interpreter_environment, Qnil);
3082 DEFSYM (Vrun_hooks
, "run-hooks");
3084 staticpro (&Vautoload_queue
);
3085 Vautoload_queue
= Qnil
;
3086 staticpro (&Vsignaling_function
);
3087 Vsignaling_function
= Qnil
;
3089 inhibit_lisp_code
= Qnil
;