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");
268 scm_set_smob_apply (lisp_vectorlike_tag
, apply_lambda
, 0, 0, 1);
271 static struct handler
*handlerlist_sentinel
;
276 specpdl_ptr
= specpdl
;
277 handlerlist_sentinel
= make_catch_handler (Qunbound
);
278 handlerlist
= handlerlist_sentinel
;
280 debug_on_next_call
= 0;
285 /* This is less than the initial value of num_nonmacro_input_events. */
286 when_entered_debugger
= -1;
289 /* Unwind-protect function used by call_debugger. */
292 restore_stack_limits (Lisp_Object data
)
294 max_specpdl_size
= XINT (XCAR (data
));
295 max_lisp_eval_depth
= XINT (XCDR (data
));
298 static void grow_specpdl (void);
300 /* Call the Lisp debugger, giving it argument ARG. */
303 call_debugger (Lisp_Object arg
)
305 bool debug_while_redisplaying
;
308 EMACS_INT old_depth
= max_lisp_eval_depth
;
309 /* Do not allow max_specpdl_size less than actual depth (Bug#16603). */
310 EMACS_INT old_max
= max_specpdl_size
;
312 if (lisp_eval_depth
+ 40 > max_lisp_eval_depth
)
313 max_lisp_eval_depth
= lisp_eval_depth
+ 40;
315 /* Restore limits after leaving the debugger. */
316 record_unwind_protect (restore_stack_limits
,
317 Fcons (make_number (old_max
),
318 make_number (old_depth
)));
320 #ifdef HAVE_WINDOW_SYSTEM
321 if (display_hourglass_p
)
325 debug_on_next_call
= 0;
326 when_entered_debugger
= num_nonmacro_input_events
;
328 /* Resetting redisplaying_p to 0 makes sure that debug output is
329 displayed if the debugger is invoked during redisplay. */
330 debug_while_redisplaying
= redisplaying_p
;
332 specbind (intern ("debugger-may-continue"),
333 debug_while_redisplaying
? Qnil
: Qt
);
334 specbind (Qinhibit_redisplay
, Qnil
);
335 specbind (Qinhibit_debugger
, Qt
);
337 #if 0 /* Binding this prevents execution of Lisp code during
338 redisplay, which necessarily leads to display problems. */
339 specbind (Qinhibit_eval_during_redisplay
, Qt
);
342 val
= apply1 (Vdebugger
, arg
);
344 /* Interrupting redisplay and resuming it later is not safe under
345 all circumstances. So, when the debugger returns, abort the
346 interrupted redisplay by going back to the top-level. */
347 if (debug_while_redisplaying
)
355 do_debug_on_call (Lisp_Object code
)
357 debug_on_next_call
= 0;
358 set_backtrace_debug_on_exit (specpdl_ptr
- 1, true);
359 call_debugger (list1 (code
));
362 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
363 doc
: /* Eval BODY forms sequentially and return value of last one.
364 usage: (progn BODY...) */)
367 Lisp_Object val
= Qnil
;
374 val
= eval_sub (XCAR (body
));
382 /* Evaluate BODY sequentially, discarding its value. Suitable for
383 record_unwind_protect. */
386 unwind_body (Lisp_Object body
)
392 Ffunction (Lisp_Object args
)
394 Lisp_Object quoted
= XCAR (args
);
396 if (CONSP (XCDR (args
)))
397 xsignal2 (Qwrong_number_of_arguments
, Qfunction
, Flength (args
));
399 if (!NILP (Vinternal_interpreter_environment
)
401 && EQ (XCAR (quoted
), Qlambda
))
402 /* This is a lambda expression within a lexical environment;
403 return an interpreted closure instead of a simple lambda. */
404 return Fcons (Qclosure
, Fcons (Vinternal_interpreter_environment
,
407 /* Simply quote the argument. */
411 DEFUN ("defvaralias", Fdefvaralias
, Sdefvaralias
, 2, 3, 0,
412 doc
: /* Make NEW-ALIAS a variable alias for symbol BASE-VARIABLE.
413 Aliased variables always have the same value; setting one sets the other.
414 Third arg DOCSTRING, if non-nil, is documentation for NEW-ALIAS. If it is
415 omitted or nil, NEW-ALIAS gets the documentation string of BASE-VARIABLE,
416 or of the variable at the end of the chain of aliases, if BASE-VARIABLE is
417 itself an alias. If NEW-ALIAS is bound, and BASE-VARIABLE is not,
418 then the value of BASE-VARIABLE is set to that of NEW-ALIAS.
419 The return value is BASE-VARIABLE. */)
420 (Lisp_Object new_alias
, Lisp_Object base_variable
, Lisp_Object docstring
)
424 CHECK_SYMBOL (new_alias
);
425 CHECK_SYMBOL (base_variable
);
427 sym
= XSYMBOL (new_alias
);
429 if (SYMBOL_CONSTANT (sym
))
430 /* Not sure why, but why not? */
431 error ("Cannot make a constant an alias");
433 switch (SYMBOL_REDIRECT (sym
))
435 case SYMBOL_FORWARDED
:
436 error ("Cannot make an internal variable an alias");
437 case SYMBOL_LOCALIZED
:
438 error ("Don't know how to make a localized variable an alias");
441 /* http://lists.gnu.org/archive/html/emacs-devel/2008-04/msg00834.html
442 If n_a is bound, but b_v is not, set the value of b_v to n_a,
443 so that old-code that affects n_a before the aliasing is setup
445 if (NILP (Fboundp (base_variable
)))
446 set_internal (base_variable
, find_symbol_value (new_alias
), Qnil
, 1);
449 union specbinding
*p
;
451 for (p
= specpdl_ptr
; p
> specpdl
; )
452 if ((--p
)->kind
>= SPECPDL_LET
453 && (EQ (new_alias
, specpdl_symbol (p
))))
454 error ("Don't know how to make a let-bound variable an alias");
457 SET_SYMBOL_DECLARED_SPECIAL (sym
, 1);
458 SET_SYMBOL_DECLARED_SPECIAL (XSYMBOL (base_variable
), 1);
459 SET_SYMBOL_REDIRECT (sym
, SYMBOL_VARALIAS
);
460 SET_SYMBOL_ALIAS (sym
, XSYMBOL (base_variable
));
461 SET_SYMBOL_CONSTANT (sym
, SYMBOL_CONSTANT_P (base_variable
));
462 LOADHIST_ATTACH (new_alias
);
463 /* Even if docstring is nil: remove old docstring. */
464 Fput (new_alias
, Qvariable_documentation
, docstring
);
466 return base_variable
;
469 static union specbinding
*
470 default_toplevel_binding (Lisp_Object symbol
)
472 union specbinding
*binding
= NULL
;
473 union specbinding
*pdl
= specpdl_ptr
;
474 while (pdl
> specpdl
)
476 switch ((--pdl
)->kind
)
478 case SPECPDL_LET_DEFAULT
:
480 if (EQ (specpdl_symbol (pdl
), symbol
))
488 DEFUN ("default-toplevel-value", Fdefault_toplevel_value
, Sdefault_toplevel_value
, 1, 1, 0,
489 doc
: /* Return SYMBOL's toplevel default value.
490 "Toplevel" means outside of any let binding. */)
493 union specbinding
*binding
= default_toplevel_binding (symbol
);
495 = binding
? specpdl_old_value (binding
) : Fdefault_value (symbol
);
496 if (!EQ (value
, Qunbound
))
498 xsignal1 (Qvoid_variable
, symbol
);
501 DEFUN ("set-default-toplevel-value", Fset_default_toplevel_value
,
502 Sset_default_toplevel_value
, 2, 2, 0,
503 doc
: /* Set SYMBOL's toplevel default value to VALUE.
504 "Toplevel" means outside of any let binding. */)
505 (Lisp_Object symbol
, Lisp_Object value
)
507 union specbinding
*binding
= default_toplevel_binding (symbol
);
509 set_specpdl_old_value (binding
, value
);
511 Fset_default (symbol
, value
);
515 /* Make SYMBOL lexically scoped. */
516 DEFUN ("internal-make-var-non-special", Fmake_var_non_special
,
517 Smake_var_non_special
, 1, 1, 0,
518 doc
: /* Internal function. */)
521 CHECK_SYMBOL (symbol
);
522 SET_SYMBOL_DECLARED_SPECIAL (XSYMBOL (symbol
), 0);
527 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
528 doc
: /* Return result of expanding macros at top level of FORM.
529 If FORM is not a macro call, it is returned unchanged.
530 Otherwise, the macro is expanded and the expansion is considered
531 in place of FORM. When a non-macro-call results, it is returned.
533 The second optional arg ENVIRONMENT specifies an environment of macro
534 definitions to shadow the loaded ones for use in file byte-compilation. */)
535 (Lisp_Object form
, Lisp_Object environment
)
537 /* With cleanups from Hallvard Furuseth. */
538 register Lisp_Object expander
, sym
, def
, tem
;
542 /* Come back here each time we expand a macro call,
543 in case it expands into another macro call. */
546 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
547 def
= sym
= XCAR (form
);
549 /* Trace symbols aliases to other symbols
550 until we get a symbol that is not an alias. */
551 while (SYMBOLP (def
))
555 tem
= Fassq (sym
, environment
);
558 def
= SYMBOL_FUNCTION (sym
);
564 /* Right now TEM is the result from SYM in ENVIRONMENT,
565 and if TEM is nil then DEF is SYM's function definition. */
568 /* SYM is not mentioned in ENVIRONMENT.
569 Look at its function definition. */
572 def
= Fautoload_do_load (def
, sym
, Qmacro
);
575 /* Not defined or definition not suitable. */
577 if (!EQ (XCAR (def
), Qmacro
))
579 else expander
= XCDR (def
);
583 expander
= XCDR (tem
);
588 Lisp_Object newform
= apply1 (expander
, XCDR (form
));
589 if (EQ (form
, newform
))
598 DEFUN ("call-with-catch", Fcatch
, Scatch
, 2, 2, 0,
599 doc
: /* Eval BODY allowing nonlocal exits using `throw'.
600 TAG is evalled to get the tag to use; it must not be nil.
602 Then the BODY is executed.
603 Within BODY, a call to `throw' with the same TAG exits BODY and this `catch'.
604 If no throw happens, `catch' returns the value of the last BODY form.
605 If a throw happens, it specifies the value to return from `catch'.
606 usage: (catch TAG BODY...) */)
607 (Lisp_Object tag
, Lisp_Object thunk
)
609 return internal_catch (tag
, call0
, thunk
);
612 /* Assert that E is true, as a comment only. Use this instead of
613 eassert (E) when E contains variables that might be clobbered by a
616 #define clobbered_eassert(E) ((void) 0)
619 set_handlerlist (void *data
)
625 restore_handler (void *data
)
627 struct handler
*c
= data
;
628 unblock_input_to (c
->interrupt_input_blocked
);
634 enum { ICC_0
, ICC_1
, ICC_2
, ICC_3
, ICC_N
} type
;
637 Lisp_Object (*fun0
) (void);
638 Lisp_Object (*fun1
) (Lisp_Object
);
639 Lisp_Object (*fun2
) (Lisp_Object
, Lisp_Object
);
640 Lisp_Object (*fun3
) (Lisp_Object
, Lisp_Object
, Lisp_Object
);
641 Lisp_Object (*funn
) (ptrdiff_t, Lisp_Object
*);
661 icc_thunk (void *data
)
664 struct icc_thunk_env
*e
= data
;
665 scm_dynwind_begin (0);
666 scm_dynwind_unwind_handler (restore_handler
, e
->c
, 0);
667 scm_dynwind_unwind_handler (set_handlerlist
,
669 SCM_F_WIND_EXPLICITLY
);
677 tem
= e
->fun1 (e
->arg1
);
680 tem
= e
->fun2 (e
->arg1
, e
->arg2
);
683 tem
= e
->fun3 (e
->arg1
, e
->arg2
, e
->arg3
);
686 tem
= e
->funn (e
->nargs
, e
->args
);
696 icc_handler (void *data
, Lisp_Object k
, Lisp_Object v
)
698 Lisp_Object (*f
) (Lisp_Object
) = data
;
702 struct icc_handler_n_env
704 Lisp_Object (*fun
) (Lisp_Object
, ptrdiff_t, Lisp_Object
*);
710 icc_handler_n (void *data
, Lisp_Object k
, Lisp_Object v
)
712 struct icc_handler_n_env
*e
= data
;
713 return e
->fun (v
, e
->nargs
, e
->args
);
717 icc_lisp_handler (void *data
, Lisp_Object k
, Lisp_Object val
)
720 struct handler
*h
= data
;
721 Lisp_Object var
= h
->var
;
722 scm_dynwind_begin (0);
726 if (!NILP (Vinternal_interpreter_environment
))
727 specbind (Qinternal_interpreter_environment
,
728 Fcons (Fcons (var
, val
),
729 Vinternal_interpreter_environment
));
734 tem
= Fprogn (h
->body
);
739 /* Set up a catch, then call C function FUNC on argument ARG.
740 FUNC should return a Lisp_Object.
741 This is how catches are done from within C code. */
744 internal_catch (Lisp_Object tag
, Lisp_Object (*func
) (Lisp_Object
), Lisp_Object arg
)
746 struct handler
*c
= make_catch_handler (tag
);
747 struct icc_thunk_env env
= { .type
= ICC_1
,
751 return call_with_prompt (c
->ptag
,
752 make_c_closure (icc_thunk
, &env
, 0, 0),
753 make_c_closure (icc_handler
, Fidentity
, 2, 0));
756 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
757 jump to that CATCH, returning VALUE as the value of that catch.
759 This is the guts of Fthrow and Fsignal; they differ only in the way
760 they choose the catch tag to throw to. A catch tag for a
761 condition-case form has a TAG of Qnil.
763 Before each catch is discarded, unbind all special bindings and
764 execute all unwind-protect clauses made above that catch. Unwind
765 the handler stack as we go, so that the proper handlers are in
766 effect for each unwind-protect clause we run. At the end, restore
767 some static info saved in CATCH, and longjmp to the location
770 This is used for correct unwinding in Fthrow and Fsignal. */
772 static Lisp_Object
unbind_to_1 (ptrdiff_t, Lisp_Object
, bool);
774 static _Noreturn
void
775 unwind_to_catch (struct handler
*catch, Lisp_Object value
)
777 abort_to_prompt (catch->ptag
, scm_list_1 (value
));
780 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
781 doc
: /* Throw to the catch for TAG and return VALUE from it.
782 Both TAG and VALUE are evalled. */)
783 (register Lisp_Object tag
, Lisp_Object value
)
788 for (c
= handlerlist
; c
; c
= c
->next
)
790 if (c
->type
== CATCHER
&& EQ (c
->tag_or_ch
, tag
))
791 unwind_to_catch (c
, value
);
793 xsignal2 (Qno_catch
, tag
, value
);
796 DEFUN ("call-with-handler", Fcall_with_handler
, Scall_with_handler
, 4, 4, 0,
797 doc
: /* Regain control when an error is signaled.
798 Executes BODYFORM and returns its value if no error happens.
799 Each element of HANDLERS looks like (CONDITION-NAME BODY...)
800 where the BODY is made of Lisp expressions.
802 A handler is applicable to an error
803 if CONDITION-NAME is one of the error's condition names.
804 If an error happens, the first applicable handler is run.
806 The car of a handler may be a list of condition names instead of a
807 single condition name; then it handles all of them. If the special
808 condition name `debug' is present in this list, it allows another
809 condition in the list to run the debugger if `debug-on-error' and the
810 other usual mechanisms says it should (otherwise, `condition-case'
811 suppresses the debugger).
813 When a handler handles an error, control returns to the `condition-case'
814 and it executes the handler's BODY...
815 with VAR bound to (ERROR-SYMBOL . SIGNAL-DATA) from the error.
816 \(If VAR is nil, the handler can't access that information.)
817 Then the value of the last BODY form is returned from the `condition-case'
820 See also the function `signal' for more info.
821 usage: (condition-case VAR BODYFORM &rest HANDLERS) */)
823 Lisp_Object conditions
,
827 return internal_lisp_condition_case (var
,
828 list2 (intern ("funcall"), thunk
),
829 list1 (list2 (conditions
, list2 (intern ("funcall"), hthunk
))));
833 ilcc1 (Lisp_Object var
, Lisp_Object bodyform
, Lisp_Object handlers
)
835 if (CONSP (handlers
))
837 Lisp_Object clause
= XCAR (handlers
);
838 Lisp_Object condition
= XCAR (clause
);
839 Lisp_Object body
= XCDR (clause
);
840 if (!CONSP (condition
))
841 condition
= Fcons (condition
, Qnil
);
842 struct handler
*c
= make_condition_handler (condition
);
845 struct icc_thunk_env env
= { .type
= ICC_3
,
849 .arg3
= XCDR (handlers
),
851 return call_with_prompt (c
->ptag
,
852 make_c_closure (icc_thunk
, &env
, 0, 0),
853 make_c_closure (icc_lisp_handler
, c
, 2, 0));
857 return eval_sub (bodyform
);
861 /* Like Fcondition_case, but the args are separate
862 rather than passed in a list. Used by Fbyte_code. */
865 internal_lisp_condition_case (volatile Lisp_Object var
, Lisp_Object bodyform
,
866 Lisp_Object handlers
)
870 struct handler
*oldhandlerlist
= handlerlist
;
874 for (val
= handlers
; CONSP (val
); val
= XCDR (val
))
876 Lisp_Object tem
= XCAR (val
);
879 && (SYMBOLP (XCAR (tem
))
880 || CONSP (XCAR (tem
))))))
881 error ("Invalid condition handler: %s",
882 SDATA (Fprin1_to_string (tem
, Qt
)));
885 return ilcc1 (var
, bodyform
, Freverse (handlers
));
888 /* Call the function BFUN with no arguments, catching errors within it
889 according to HANDLERS. If there is an error, call HFUN with
890 one argument which is the data that describes the error:
893 HANDLERS can be a list of conditions to catch.
894 If HANDLERS is Qt, catch all errors.
895 If HANDLERS is Qerror, catch all errors
896 but allow the debugger to run if that is enabled. */
899 internal_condition_case (Lisp_Object (*bfun
) (void), Lisp_Object handlers
,
900 Lisp_Object (*hfun
) (Lisp_Object
))
903 struct handler
*c
= make_condition_handler (handlers
);
905 struct icc_thunk_env env
= { .type
= ICC_0
, .fun0
= bfun
, .c
= c
};
906 return call_with_prompt (c
->ptag
,
907 make_c_closure (icc_thunk
, &env
, 0, 0),
908 make_c_closure (icc_handler
, hfun
, 2, 0));
911 /* Like internal_condition_case but call BFUN with ARG as its argument. */
914 internal_condition_case_1 (Lisp_Object (*bfun
) (Lisp_Object
), Lisp_Object arg
,
915 Lisp_Object handlers
, Lisp_Object (*hfun
) (Lisp_Object
))
918 struct handler
*c
= make_condition_handler (handlers
);
920 struct icc_thunk_env env
= { .type
= ICC_1
,
924 return call_with_prompt (c
->ptag
,
925 make_c_closure (icc_thunk
, &env
, 0, 0),
926 make_c_closure (icc_handler
, hfun
, 2, 0));
929 /* Like internal_condition_case_1 but call BFUN with ARG1 and ARG2 as
933 internal_condition_case_2 (Lisp_Object (*bfun
) (Lisp_Object
, Lisp_Object
),
936 Lisp_Object handlers
,
937 Lisp_Object (*hfun
) (Lisp_Object
))
940 struct handler
*c
= make_condition_handler (handlers
);
941 struct icc_thunk_env env
= { .type
= ICC_2
,
946 return call_with_prompt (c
->ptag
,
947 make_c_closure (icc_thunk
, &env
, 0, 0),
948 make_c_closure (icc_handler
, hfun
, 2, 0));
951 /* Like internal_condition_case but call BFUN with NARGS as first,
952 and ARGS as second argument. */
955 internal_condition_case_n (Lisp_Object (*bfun
) (ptrdiff_t, Lisp_Object
*),
958 Lisp_Object handlers
,
959 Lisp_Object (*hfun
) (Lisp_Object err
,
964 struct handler
*c
= make_condition_handler (handlers
);
966 struct icc_thunk_env env
= { .type
= ICC_N
,
971 struct icc_handler_n_env henv
= { .fun
= hfun
, .nargs
= nargs
, .args
= args
};
972 return call_with_prompt (c
->ptag
,
973 make_c_closure (icc_thunk
, &env
, 0, 0),
974 make_c_closure (icc_handler_n
, &henv
, 2, 0));
978 static Lisp_Object
find_handler_clause (Lisp_Object
, Lisp_Object
);
979 static bool maybe_call_debugger (Lisp_Object conditions
, Lisp_Object sig
,
983 process_quit_flag (void)
985 Lisp_Object flag
= Vquit_flag
;
987 if (EQ (flag
, Qkill_emacs
))
989 if (EQ (Vthrow_on_input
, flag
))
990 Fthrow (Vthrow_on_input
, Qt
);
991 Fsignal (Qquit
, Qnil
);
994 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
995 doc
: /* Signal an error. Args are ERROR-SYMBOL and associated DATA.
996 This function does not return.
998 An error symbol is a symbol with an `error-conditions' property
999 that is a list of condition names.
1000 A handler for any of those names will get to handle this signal.
1001 The symbol `error' should normally be one of them.
1003 DATA should be a list. Its elements are printed as part of the error message.
1004 See Info anchor `(elisp)Definition of signal' for some details on how this
1005 error message is constructed.
1006 If the signal is handled, DATA is made available to the handler.
1007 See also the function `condition-case'. */)
1008 (Lisp_Object error_symbol
, Lisp_Object data
)
1010 /* When memory is full, ERROR-SYMBOL is nil,
1011 and DATA is (REAL-ERROR-SYMBOL . REAL-DATA).
1012 That is a special case--don't do this in other situations. */
1013 Lisp_Object conditions
;
1015 Lisp_Object real_error_symbol
1016 = (NILP (error_symbol
) ? Fcar (data
) : error_symbol
);
1017 register Lisp_Object clause
= Qnil
;
1021 if (waiting_for_input
)
1024 #if 0 /* rms: I don't know why this was here,
1025 but it is surely wrong for an error that is handled. */
1026 #ifdef HAVE_WINDOW_SYSTEM
1027 if (display_hourglass_p
)
1028 cancel_hourglass ();
1032 /* This hook is used by edebug. */
1033 if (! NILP (Vsignal_hook_function
)
1034 && ! NILP (error_symbol
))
1036 /* Edebug takes care of restoring these variables when it exits. */
1037 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
1038 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
1040 if (SPECPDL_INDEX () + 40 > max_specpdl_size
)
1041 max_specpdl_size
= SPECPDL_INDEX () + 40;
1043 call2 (Vsignal_hook_function
, error_symbol
, data
);
1046 conditions
= Fget (real_error_symbol
, Qerror_conditions
);
1048 /* Remember from where signal was called. Skip over the frame for
1049 `signal' itself. If a frame for `error' follows, skip that,
1050 too. Don't do this when ERROR_SYMBOL is nil, because that
1051 is a memory-full error. */
1052 Vsignaling_function
= Qnil
;
1053 if (!NILP (error_symbol
))
1055 union specbinding
*pdl
= backtrace_next (backtrace_top ());
1056 if (backtrace_p (pdl
) && EQ (backtrace_function (pdl
), Qerror
))
1057 pdl
= backtrace_next (pdl
);
1058 if (backtrace_p (pdl
))
1059 Vsignaling_function
= backtrace_function (pdl
);
1062 for (h
= handlerlist
; h
; h
= h
->next
)
1064 if (h
->type
!= CONDITION_CASE
)
1066 clause
= find_handler_clause (h
->tag_or_ch
, conditions
);
1071 if (/* Don't run the debugger for a memory-full error.
1072 (There is no room in memory to do that!) */
1073 !NILP (error_symbol
)
1074 && (!NILP (Vdebug_on_signal
)
1075 /* If no handler is present now, try to run the debugger. */
1077 /* A `debug' symbol in the handler list disables the normal
1078 suppression of the debugger. */
1079 || (CONSP (clause
) && CONSP (clause
)
1080 && !NILP (Fmemq (Qdebug
, clause
)))
1081 /* Special handler that means "print a message and run debugger
1083 || EQ (h
->tag_or_ch
, Qerror
)))
1085 bool debugger_called
1086 = maybe_call_debugger (conditions
, error_symbol
, data
);
1087 /* We can't return values to code which signaled an error, but we
1088 can continue code which has signaled a quit. */
1089 if (debugger_called
&& EQ (real_error_symbol
, Qquit
))
1095 Lisp_Object unwind_data
1096 = (NILP (error_symbol
) ? data
: Fcons (error_symbol
, data
));
1098 unwind_to_catch (h
, unwind_data
);
1102 if (handlerlist
!= handlerlist_sentinel
)
1103 /* FIXME: This will come right back here if there's no `top-level'
1104 catcher. A better solution would be to abort here, and instead
1105 add a catch-all condition handler so we never come here. */
1106 Fthrow (Qtop_level
, Qt
);
1109 if (! NILP (error_symbol
))
1110 data
= Fcons (error_symbol
, data
);
1112 string
= Ferror_message_string (data
);
1113 fatal ("%s", SDATA (string
));
1116 /* Internal version of Fsignal that never returns.
1117 Used for anything but Qquit (which can return from Fsignal). */
1120 xsignal (Lisp_Object error_symbol
, Lisp_Object data
)
1122 Fsignal (error_symbol
, data
);
1126 /* Like xsignal, but takes 0, 1, 2, or 3 args instead of a list. */
1129 xsignal0 (Lisp_Object error_symbol
)
1131 xsignal (error_symbol
, Qnil
);
1135 xsignal1 (Lisp_Object error_symbol
, Lisp_Object arg
)
1137 xsignal (error_symbol
, list1 (arg
));
1141 xsignal2 (Lisp_Object error_symbol
, Lisp_Object arg1
, Lisp_Object arg2
)
1143 xsignal (error_symbol
, list2 (arg1
, arg2
));
1147 xsignal3 (Lisp_Object error_symbol
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
1149 xsignal (error_symbol
, list3 (arg1
, arg2
, arg3
));
1152 /* Signal `error' with message S, and additional arg ARG.
1153 If ARG is not a genuine list, make it a one-element list. */
1156 signal_error (const char *s
, Lisp_Object arg
)
1158 Lisp_Object tortoise
, hare
;
1160 hare
= tortoise
= arg
;
1161 while (CONSP (hare
))
1168 tortoise
= XCDR (tortoise
);
1170 if (EQ (hare
, tortoise
))
1177 xsignal (Qerror
, Fcons (build_string (s
), arg
));
1181 /* Return true if LIST is a non-nil atom or
1182 a list containing one of CONDITIONS. */
1185 wants_debugger (Lisp_Object list
, Lisp_Object conditions
)
1192 while (CONSP (conditions
))
1194 Lisp_Object
this, tail
;
1195 this = XCAR (conditions
);
1196 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1197 if (EQ (XCAR (tail
), this))
1199 conditions
= XCDR (conditions
);
1204 /* Return true if an error with condition-symbols CONDITIONS,
1205 and described by SIGNAL-DATA, should skip the debugger
1206 according to debugger-ignored-errors. */
1209 skip_debugger (Lisp_Object conditions
, Lisp_Object data
)
1212 bool first_string
= 1;
1213 Lisp_Object error_message
;
1215 error_message
= Qnil
;
1216 for (tail
= Vdebug_ignored_errors
; CONSP (tail
); tail
= XCDR (tail
))
1218 if (STRINGP (XCAR (tail
)))
1222 error_message
= Ferror_message_string (data
);
1226 if (fast_string_match (XCAR (tail
), error_message
) >= 0)
1231 Lisp_Object contail
;
1233 for (contail
= conditions
; CONSP (contail
); contail
= XCDR (contail
))
1234 if (EQ (XCAR (tail
), XCAR (contail
)))
1242 /* Call the debugger if calling it is currently enabled for CONDITIONS.
1243 SIG and DATA describe the signal. There are two ways to pass them:
1244 = SIG is the error symbol, and DATA is the rest of the data.
1245 = SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
1246 This is for memory-full errors only. */
1248 maybe_call_debugger (Lisp_Object conditions
, Lisp_Object sig
, Lisp_Object data
)
1250 Lisp_Object combined_data
;
1252 combined_data
= Fcons (sig
, data
);
1255 /* Don't try to run the debugger with interrupts blocked.
1256 The editing loop would return anyway. */
1257 ! input_blocked_p ()
1258 && NILP (Vinhibit_debugger
)
1259 /* Does user want to enter debugger for this kind of error? */
1262 : wants_debugger (Vdebug_on_error
, conditions
))
1263 && ! skip_debugger (conditions
, combined_data
)
1264 /* RMS: What's this for? */
1265 && when_entered_debugger
< num_nonmacro_input_events
)
1267 call_debugger (list2 (Qerror
, combined_data
));
1275 find_handler_clause (Lisp_Object handlers
, Lisp_Object conditions
)
1277 register Lisp_Object h
;
1279 /* t is used by handlers for all conditions, set up by C code. */
1280 if (EQ (handlers
, Qt
))
1283 /* error is used similarly, but means print an error message
1284 and run the debugger if that is enabled. */
1285 if (EQ (handlers
, Qerror
))
1288 for (h
= handlers
; CONSP (h
); h
= XCDR (h
))
1290 Lisp_Object handler
= XCAR (h
);
1291 if (!NILP (Fmemq (handler
, conditions
)))
1299 /* Dump an error message; called like vprintf. */
1301 verror (const char *m
, va_list ap
)
1304 ptrdiff_t size
= sizeof buf
;
1305 ptrdiff_t size_max
= STRING_BYTES_BOUND
+ 1;
1310 used
= evxprintf (&buffer
, &size
, buf
, size_max
, m
, ap
);
1311 string
= make_string (buffer
, used
);
1315 xsignal1 (Qerror
, string
);
1319 /* Dump an error message; called like printf. */
1323 error (const char *m
, ...)
1330 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 2, 0,
1331 doc
: /* Non-nil if FUNCTION makes provisions for interactive calling.
1332 This means it contains a description for how to read arguments to give it.
1333 The value is nil for an invalid function or a symbol with no function
1336 Interactively callable functions include strings and vectors (treated
1337 as keyboard macros), lambda-expressions that contain a top-level call
1338 to `interactive', autoload definitions made by `autoload' with non-nil
1339 fourth argument, and some of the built-in functions of Lisp.
1341 Also, a symbol satisfies `commandp' if its function definition does so.
1343 If the optional argument FOR-CALL-INTERACTIVELY is non-nil,
1344 then strings and vectors are not accepted. */)
1345 (Lisp_Object function
, Lisp_Object for_call_interactively
)
1347 register Lisp_Object fun
;
1348 register Lisp_Object funcar
;
1349 Lisp_Object if_prop
= Qnil
;
1353 fun
= indirect_function (fun
); /* Check cycles. */
1357 /* Check an `interactive-form' property if present, analogous to the
1358 function-documentation property. */
1360 while (SYMBOLP (fun
))
1362 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
1365 fun
= Fsymbol_function (fun
);
1368 if (scm_is_true (scm_procedure_p (fun
)))
1369 return (scm_is_pair (scm_assq (Qinteractive_form
,
1370 scm_procedure_properties (fun
)))
1372 /* Bytecode objects are interactive if they are long enough to
1373 have an element whose index is COMPILED_INTERACTIVE, which is
1374 where the interactive spec is stored. */
1375 else if (COMPILEDP (fun
))
1376 return ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
1379 /* Strings and vectors are keyboard macros. */
1380 if (STRINGP (fun
) || VECTORP (fun
))
1381 return (NILP (for_call_interactively
) ? Qt
: Qnil
);
1383 /* Lists may represent commands. */
1386 funcar
= XCAR (fun
);
1387 if (EQ (funcar
, Qclosure
))
1388 return (!NILP (Fassq (Qinteractive
, Fcdr (Fcdr (XCDR (fun
)))))
1390 else if (EQ (funcar
, Qlambda
))
1391 return !NILP (Fassq (Qinteractive
, Fcdr (XCDR (fun
)))) ? Qt
: if_prop
;
1392 else if (EQ (funcar
, Qautoload
))
1393 return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun
))))) ? Qt
: if_prop
;
1398 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
1399 doc
: /* Define FUNCTION to autoload from FILE.
1400 FUNCTION is a symbol; FILE is a file name string to pass to `load'.
1401 Third arg DOCSTRING is documentation for the function.
1402 Fourth arg INTERACTIVE if non-nil says function can be called interactively.
1403 Fifth arg TYPE indicates the type of the object:
1404 nil or omitted says FUNCTION is a function,
1405 `keymap' says FUNCTION is really a keymap, and
1406 `macro' or t says FUNCTION is really a macro.
1407 Third through fifth args give info about the real definition.
1408 They default to nil.
1409 If FUNCTION is already defined other than as an autoload,
1410 this does nothing and returns nil. */)
1411 (Lisp_Object function
, Lisp_Object file
, Lisp_Object docstring
, Lisp_Object interactive
, Lisp_Object type
)
1413 CHECK_SYMBOL (function
);
1414 CHECK_STRING (file
);
1416 /* If function is defined and not as an autoload, don't override. */
1417 if (!NILP (SYMBOL_FUNCTION (function
))
1418 && !AUTOLOADP (SYMBOL_FUNCTION (function
)))
1421 return Fdefalias (function
,
1422 list5 (Qautoload
, file
, docstring
, interactive
, type
),
1427 un_autoload (Lisp_Object oldqueue
)
1429 Lisp_Object queue
, first
, second
;
1431 /* Queue to unwind is current value of Vautoload_queue.
1432 oldqueue is the shadowed value to leave in Vautoload_queue. */
1433 queue
= Vautoload_queue
;
1434 Vautoload_queue
= oldqueue
;
1435 while (CONSP (queue
))
1437 first
= XCAR (queue
);
1438 second
= Fcdr (first
);
1439 first
= Fcar (first
);
1440 if (EQ (first
, make_number (0)))
1443 Ffset (first
, second
);
1444 queue
= XCDR (queue
);
1448 /* Load an autoloaded function.
1449 FUNNAME is the symbol which is the function's name.
1450 FUNDEF is the autoload definition (a list). */
1452 DEFUN ("autoload-do-load", Fautoload_do_load
, Sautoload_do_load
, 1, 3, 0,
1453 doc
: /* Load FUNDEF which should be an autoload.
1454 If non-nil, FUNNAME should be the symbol whose function value is FUNDEF,
1455 in which case the function returns the new autoloaded function value.
1456 If equal to `macro', MACRO-ONLY specifies that FUNDEF should only be loaded if
1457 it is defines a macro. */)
1458 (Lisp_Object fundef
, Lisp_Object funname
, Lisp_Object macro_only
)
1461 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1463 if (!CONSP (fundef
) || !EQ (Qautoload
, XCAR (fundef
))) {
1468 if (EQ (macro_only
, Qmacro
))
1470 Lisp_Object kind
= Fnth (make_number (4), fundef
);
1471 if (! (EQ (kind
, Qt
) || EQ (kind
, Qmacro
))) {
1477 /* This is to make sure that loadup.el gives a clear picture
1478 of what files are preloaded and when. */
1479 if (! NILP (Vpurify_flag
))
1480 error ("Attempt to autoload %s while preparing to dump",
1481 SDATA (SYMBOL_NAME (funname
)));
1483 CHECK_SYMBOL (funname
);
1484 GCPRO3 (funname
, fundef
, macro_only
);
1486 /* Preserve the match data. */
1487 record_unwind_save_match_data ();
1489 /* If autoloading gets an error (which includes the error of failing
1490 to define the function being called), we use Vautoload_queue
1491 to undo function definitions and `provide' calls made by
1492 the function. We do this in the specific case of autoloading
1493 because autoloading is not an explicit request "load this file",
1494 but rather a request to "call this function".
1496 The value saved here is to be restored into Vautoload_queue. */
1497 record_unwind_protect (un_autoload
, Vautoload_queue
);
1498 Vautoload_queue
= Qt
;
1499 /* If `macro_only', assume this autoload to be a "best-effort",
1500 so don't signal an error if autoloading fails. */
1501 Fload (Fcar (Fcdr (fundef
)), macro_only
, Qt
, Qnil
, Qt
);
1503 /* Once loading finishes, don't undo it. */
1504 Vautoload_queue
= Qt
;
1513 Lisp_Object fun
= Findirect_function (funname
, Qnil
);
1515 if (!NILP (Fequal (fun
, fundef
)))
1516 error ("Autoloading failed to define function %s",
1517 SDATA (SYMBOL_NAME (funname
)));
1524 DEFUN ("eval", Feval
, Seval
, 1, 2, 0,
1525 doc
: /* Evaluate FORM and return its value.
1526 If LEXICAL is t, evaluate using lexical scoping.
1527 LEXICAL can also be an actual lexical environment, in the form of an
1528 alist mapping symbols to their value. */)
1529 (Lisp_Object form
, Lisp_Object lexical
)
1532 specbind (Qinternal_interpreter_environment
,
1533 CONSP (lexical
) || NILP (lexical
) ? lexical
: list1 (Qt
));
1534 Lisp_Object tem0
= eval_sub (form
);
1539 /* Grow the specpdl stack by one entry.
1540 The caller should have already initialized the entry.
1541 Signal an error on stack overflow.
1543 Make sure that there is always one unused entry past the top of the
1544 stack, so that the just-initialized entry is safely unwound if
1545 memory exhausted and an error is signaled here. Also, allocate a
1546 never-used entry just before the bottom of the stack; sometimes its
1547 address is taken. */
1554 if (specpdl_ptr
== specpdl
+ specpdl_size
)
1556 ptrdiff_t count
= SPECPDL_INDEX ();
1557 ptrdiff_t max_size
= min (max_specpdl_size
, PTRDIFF_MAX
- 1000);
1558 union specbinding
*pdlvec
= specpdl
- 1;
1559 ptrdiff_t pdlvecsize
= specpdl_size
+ 1;
1560 if (max_size
<= specpdl_size
)
1562 if (max_specpdl_size
< 400)
1563 max_size
= max_specpdl_size
= 400;
1564 if (max_size
<= specpdl_size
)
1565 signal_error ("Variable binding depth exceeds max-specpdl-size",
1568 pdlvec
= xpalloc (pdlvec
, &pdlvecsize
, 1, max_size
+ 1, sizeof *specpdl
);
1569 specpdl
= pdlvec
+ 1;
1570 specpdl_size
= pdlvecsize
- 1;
1571 specpdl_ptr
= specpdl
+ count
;
1576 record_in_backtrace (Lisp_Object function
, Lisp_Object
*args
, ptrdiff_t nargs
)
1578 eassert (nargs
>= UNEVALLED
);
1579 specpdl_ptr
->bt
.kind
= SPECPDL_BACKTRACE
;
1580 specpdl_ptr
->bt
.debug_on_exit
= false;
1581 specpdl_ptr
->bt
.function
= function
;
1582 specpdl_ptr
->bt
.args
= args
;
1583 specpdl_ptr
->bt
.nargs
= nargs
;
1585 scm_dynwind_unwind_handler (unbind_once
, NULL
, SCM_F_WIND_EXPLICITLY
);
1589 set_lisp_eval_depth (void *data
)
1591 EMACS_INT n
= (EMACS_INT
) data
;
1592 lisp_eval_depth
= n
;
1595 /* Eval a sub-expression of the current expression (i.e. in the same
1598 eval_sub_1 (Lisp_Object form
)
1601 return scm_call_1 (eval_fn
, form
);
1605 eval_sub (Lisp_Object form
)
1607 return scm_c_value_ref (eval_sub_1 (form
), 0);
1611 values_to_list (Lisp_Object values
)
1613 Lisp_Object list
= Qnil
;
1614 for (int i
= scm_c_nvalues (values
) - 1; i
>= 0; i
--)
1615 list
= Fcons (scm_c_value_ref (values
, i
), list
);
1619 DEFUN ("multiple-value-call", Fmultiple_value_call
, Smultiple_value_call
,
1621 doc
: /* Call with multiple values.
1622 usage: (multiple-value-call FUNCTION-FORM FORM) */)
1625 Lisp_Object function_form
= eval_sub (XCAR (args
));
1626 Lisp_Object values
= Qnil
;
1627 while (CONSP (args
= XCDR (args
)))
1628 values
= nconc2 (Fnreverse (values_to_list (eval_sub_1 (XCAR (args
)))),
1630 return apply1 (function_form
, Fnreverse (values
));
1633 DEFUN ("values", Fvalues
, Svalues
, 0, MANY
, 0,
1634 doc
: /* Return multiple values. */)
1635 (ptrdiff_t nargs
, Lisp_Object
*args
)
1637 return scm_c_values (args
, nargs
);
1641 Fapply (ptrdiff_t nargs
, Lisp_Object
*args
)
1645 register Lisp_Object spread_arg
;
1646 register Lisp_Object
*funcall_args
;
1647 Lisp_Object fun
, retval
;
1648 struct gcpro gcpro1
;
1653 spread_arg
= args
[nargs
- 1];
1654 CHECK_LIST (spread_arg
);
1656 numargs
= XINT (Flength (spread_arg
));
1659 return Ffuncall (nargs
- 1, args
);
1660 else if (numargs
== 1)
1662 args
[nargs
- 1] = XCAR (spread_arg
);
1663 return Ffuncall (nargs
, args
);
1666 numargs
+= nargs
- 2;
1668 /* Optimize for no indirection. */
1669 if (SYMBOLP (fun
) && !NILP (fun
)
1670 && (fun
= SYMBOL_FUNCTION (fun
), SYMBOLP (fun
)))
1671 fun
= indirect_function (fun
);
1674 /* Let funcall get the error. */
1678 /* We add 1 to numargs because funcall_args includes the
1679 function itself as well as its arguments. */
1682 SAFE_ALLOCA_LISP (funcall_args
, 1 + numargs
);
1683 GCPRO1 (*funcall_args
);
1684 gcpro1
.nvars
= 1 + numargs
;
1687 memcpy (funcall_args
, args
, nargs
* word_size
);
1688 /* Spread the last arg we got. Its first element goes in
1689 the slot that it used to occupy, hence this value of I. */
1691 while (!NILP (spread_arg
))
1693 funcall_args
[i
++] = XCAR (spread_arg
);
1694 spread_arg
= XCDR (spread_arg
);
1697 /* By convention, the caller needs to gcpro Ffuncall's args. */
1698 retval
= Ffuncall (gcpro1
.nvars
, funcall_args
);
1705 /* Run hook variables in various ways. */
1708 funcall_nil (ptrdiff_t nargs
, Lisp_Object
*args
)
1710 Ffuncall (nargs
, args
);
1714 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 0, MANY
, 0,
1715 doc
: /* Run each hook in HOOKS.
1716 Each argument should be a symbol, a hook variable.
1717 These symbols are processed in the order specified.
1718 If a hook symbol has a non-nil value, that value may be a function
1719 or a list of functions to be called to run the hook.
1720 If the value is a function, it is called with no arguments.
1721 If it is a list, the elements are called, in order, with no arguments.
1723 Major modes should not use this function directly to run their mode
1724 hook; they should use `run-mode-hooks' instead.
1726 Do not use `make-local-variable' to make a hook variable buffer-local.
1727 Instead, use `add-hook' and specify t for the LOCAL argument.
1728 usage: (run-hooks &rest HOOKS) */)
1729 (ptrdiff_t nargs
, Lisp_Object
*args
)
1731 Lisp_Object hook
[1];
1734 for (i
= 0; i
< nargs
; i
++)
1737 run_hook_with_args (1, hook
, funcall_nil
);
1743 DEFUN ("run-hook-with-args", Frun_hook_with_args
,
1744 Srun_hook_with_args
, 1, MANY
, 0,
1745 doc
: /* Run HOOK with the specified arguments ARGS.
1746 HOOK should be a symbol, a hook variable. The value of HOOK
1747 may be nil, a function, or a list of functions. Call each
1748 function in order with arguments ARGS. The final return value
1751 Do not use `make-local-variable' to make a hook variable buffer-local.
1752 Instead, use `add-hook' and specify t for the LOCAL argument.
1753 usage: (run-hook-with-args HOOK &rest ARGS) */)
1754 (ptrdiff_t nargs
, Lisp_Object
*args
)
1756 return run_hook_with_args (nargs
, args
, funcall_nil
);
1759 /* NB this one still documents a specific non-nil return value.
1760 (As did run-hook-with-args and run-hook-with-args-until-failure
1761 until they were changed in 24.1.) */
1762 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success
,
1763 Srun_hook_with_args_until_success
, 1, MANY
, 0,
1764 doc
: /* Run HOOK with the specified arguments ARGS.
1765 HOOK should be a symbol, a hook variable. The value of HOOK
1766 may be nil, a function, or a list of functions. Call each
1767 function in order with arguments ARGS, stopping at the first
1768 one that returns non-nil, and return that value. Otherwise (if
1769 all functions return nil, or if there are no functions to call),
1772 Do not use `make-local-variable' to make a hook variable buffer-local.
1773 Instead, use `add-hook' and specify t for the LOCAL argument.
1774 usage: (run-hook-with-args-until-success HOOK &rest ARGS) */)
1775 (ptrdiff_t nargs
, Lisp_Object
*args
)
1777 return run_hook_with_args (nargs
, args
, Ffuncall
);
1781 funcall_not (ptrdiff_t nargs
, Lisp_Object
*args
)
1783 return NILP (Ffuncall (nargs
, args
)) ? Qt
: Qnil
;
1786 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure
,
1787 Srun_hook_with_args_until_failure
, 1, MANY
, 0,
1788 doc
: /* Run HOOK with the specified arguments ARGS.
1789 HOOK should be a symbol, a hook variable. The value of HOOK
1790 may be nil, a function, or a list of functions. Call each
1791 function in order with arguments ARGS, stopping at the first
1792 one that returns nil, and return nil. Otherwise (if all functions
1793 return non-nil, or if there are no functions to call), return non-nil
1794 \(do not rely on the precise return value in this case).
1796 Do not use `make-local-variable' to make a hook variable buffer-local.
1797 Instead, use `add-hook' and specify t for the LOCAL argument.
1798 usage: (run-hook-with-args-until-failure HOOK &rest ARGS) */)
1799 (ptrdiff_t nargs
, Lisp_Object
*args
)
1801 return NILP (run_hook_with_args (nargs
, args
, funcall_not
)) ? Qt
: Qnil
;
1805 run_hook_wrapped_funcall (ptrdiff_t nargs
, Lisp_Object
*args
)
1807 Lisp_Object tmp
= args
[0], ret
;
1810 ret
= Ffuncall (nargs
, args
);
1816 DEFUN ("run-hook-wrapped", Frun_hook_wrapped
, Srun_hook_wrapped
, 2, MANY
, 0,
1817 doc
: /* Run HOOK, passing each function through WRAP-FUNCTION.
1818 I.e. instead of calling each function FUN directly with arguments ARGS,
1819 it calls WRAP-FUNCTION with arguments FUN and ARGS.
1820 As soon as a call to WRAP-FUNCTION returns non-nil, `run-hook-wrapped'
1821 aborts and returns that value.
1822 usage: (run-hook-wrapped HOOK WRAP-FUNCTION &rest ARGS) */)
1823 (ptrdiff_t nargs
, Lisp_Object
*args
)
1825 return run_hook_with_args (nargs
, args
, run_hook_wrapped_funcall
);
1828 /* ARGS[0] should be a hook symbol.
1829 Call each of the functions in the hook value, passing each of them
1830 as arguments all the rest of ARGS (all NARGS - 1 elements).
1831 FUNCALL specifies how to call each function on the hook.
1832 The caller (or its caller, etc) must gcpro all of ARGS,
1833 except that it isn't necessary to gcpro ARGS[0]. */
1836 run_hook_with_args (ptrdiff_t nargs
, Lisp_Object
*args
,
1837 Lisp_Object (*funcall
) (ptrdiff_t nargs
, Lisp_Object
*args
))
1839 Lisp_Object sym
, val
, ret
= Qnil
;
1840 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1842 /* If we are dying or still initializing,
1843 don't do anything--it would probably crash if we tried. */
1844 if (NILP (Vrun_hooks
))
1848 val
= find_symbol_value (sym
);
1850 if (EQ (val
, Qunbound
) || NILP (val
))
1852 else if (!CONSP (val
) || FUNCTIONP (val
))
1855 return funcall (nargs
, args
);
1859 Lisp_Object global_vals
= Qnil
;
1860 GCPRO3 (sym
, val
, global_vals
);
1863 CONSP (val
) && NILP (ret
);
1866 if (EQ (XCAR (val
), Qt
))
1868 /* t indicates this hook has a local binding;
1869 it means to run the global binding too. */
1870 global_vals
= Fdefault_value (sym
);
1871 if (NILP (global_vals
)) continue;
1873 if (!CONSP (global_vals
) || EQ (XCAR (global_vals
), Qlambda
))
1875 args
[0] = global_vals
;
1876 ret
= funcall (nargs
, args
);
1881 CONSP (global_vals
) && NILP (ret
);
1882 global_vals
= XCDR (global_vals
))
1884 args
[0] = XCAR (global_vals
);
1885 /* In a global value, t should not occur. If it does, we
1886 must ignore it to avoid an endless loop. */
1887 if (!EQ (args
[0], Qt
))
1888 ret
= funcall (nargs
, args
);
1894 args
[0] = XCAR (val
);
1895 ret
= funcall (nargs
, args
);
1904 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
1907 run_hook_with_args_2 (Lisp_Object hook
, Lisp_Object arg1
, Lisp_Object arg2
)
1909 Lisp_Object temp
[3];
1914 Frun_hook_with_args (3, temp
);
1917 /* Apply fn to arg. */
1919 apply1 (Lisp_Object fn
, Lisp_Object arg
)
1921 struct gcpro gcpro1
;
1925 return Ffuncall (1, &fn
);
1928 Lisp_Object args
[2];
1932 return Fapply (2, args
);
1936 /* Call function fn on no arguments. */
1938 call0 (Lisp_Object fn
)
1940 struct gcpro gcpro1
;
1943 return Ffuncall (1, &fn
);
1946 /* Call function fn with 1 argument arg1. */
1949 call1 (Lisp_Object fn
, Lisp_Object arg1
)
1951 struct gcpro gcpro1
;
1952 Lisp_Object args
[2];
1958 return Ffuncall (2, args
);
1961 /* Call function fn with 2 arguments arg1, arg2. */
1964 call2 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
)
1966 struct gcpro gcpro1
;
1967 Lisp_Object args
[3];
1973 return Ffuncall (3, args
);
1976 /* Call function fn with 3 arguments arg1, arg2, arg3. */
1979 call3 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
1981 struct gcpro gcpro1
;
1982 Lisp_Object args
[4];
1989 return Ffuncall (4, args
);
1992 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4. */
1995 call4 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
1998 struct gcpro gcpro1
;
1999 Lisp_Object args
[5];
2007 return Ffuncall (5, args
);
2010 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5. */
2013 call5 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2014 Lisp_Object arg4
, Lisp_Object arg5
)
2016 struct gcpro gcpro1
;
2017 Lisp_Object args
[6];
2026 return Ffuncall (6, args
);
2029 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6. */
2032 call6 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2033 Lisp_Object arg4
, Lisp_Object arg5
, Lisp_Object arg6
)
2035 struct gcpro gcpro1
;
2036 Lisp_Object args
[7];
2046 return Ffuncall (7, args
);
2049 /* Call function fn with 7 arguments arg1, arg2, arg3, arg4, arg5, arg6, arg7. */
2052 call7 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2053 Lisp_Object arg4
, Lisp_Object arg5
, Lisp_Object arg6
, Lisp_Object arg7
)
2055 struct gcpro gcpro1
;
2056 Lisp_Object args
[8];
2067 return Ffuncall (8, args
);
2070 /* The caller should GCPRO all the elements of ARGS. */
2072 DEFUN ("functionp", Ffunctionp
, Sfunctionp
, 1, 1, 0,
2073 doc
: /* Non-nil if OBJECT is a function. */)
2074 (Lisp_Object object
)
2076 if (FUNCTIONP (object
))
2082 Ffuncall1 (ptrdiff_t nargs
, Lisp_Object
*args
)
2084 return scm_call_n (funcall_fn
, args
, nargs
);
2088 Ffuncall (ptrdiff_t nargs
, Lisp_Object
*args
)
2090 return scm_c_value_ref (Ffuncall1 (nargs
, args
), 0);
2094 apply_lambda (Lisp_Object fun
, Lisp_Object args
)
2096 Lisp_Object args_left
;
2099 register Lisp_Object
*arg_vector
;
2100 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2101 register Lisp_Object tem
;
2104 numargs
= XFASTINT (Flength (args
));
2105 SAFE_ALLOCA_LISP (arg_vector
, numargs
);
2108 GCPRO3 (*arg_vector
, args_left
, fun
);
2111 for (i
= 0; i
< numargs
; )
2113 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
2114 arg_vector
[i
++] = tem
;
2120 //set_backtrace_args (specpdl_ptr - 1, arg_vector);
2121 //set_backtrace_nargs (specpdl_ptr - 1, i);
2122 tem
= funcall_lambda (fun
, numargs
, arg_vector
);
2124 /* Do the debug-on-exit now, while arg_vector still exists. */
2125 if (backtrace_debug_on_exit (specpdl_ptr
- 1))
2127 /* Don't do it again when we return to eval. */
2128 set_backtrace_debug_on_exit (specpdl_ptr
- 1, false);
2129 tem
= call_debugger (list2 (Qexit
, tem
));
2135 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
2136 and return the result of evaluation.
2137 FUN must be either a lambda-expression or a compiled-code object. */
2140 funcall_lambda (Lisp_Object fun
, ptrdiff_t nargs
,
2141 register Lisp_Object
*arg_vector
)
2143 Lisp_Object val
, syms_left
, next
, lexenv
;
2146 bool optional
, rest
;
2150 if (EQ (XCAR (fun
), Qclosure
))
2152 fun
= XCDR (fun
); /* Drop `closure'. */
2153 lexenv
= XCAR (fun
);
2154 CHECK_LIST_CONS (fun
, fun
);
2158 syms_left
= XCDR (fun
);
2159 if (CONSP (syms_left
))
2160 syms_left
= XCAR (syms_left
);
2162 xsignal1 (Qinvalid_function
, fun
);
2164 else if (COMPILEDP (fun
))
2166 syms_left
= AREF (fun
, COMPILED_ARGLIST
);
2167 if (INTEGERP (syms_left
))
2168 /* A byte-code object with a non-nil `push args' slot means we
2169 shouldn't bind any arguments, instead just call the byte-code
2170 interpreter directly; it will push arguments as necessary.
2172 Byte-code objects with either a non-existent, or a nil value for
2173 the `push args' slot (the default), have dynamically-bound
2174 arguments, and use the argument-binding code below instead (as do
2175 all interpreted functions, even lexically bound ones). */
2177 /* If we have not actually read the bytecode string
2178 and constants vector yet, fetch them from the file. */
2179 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
2180 Ffetch_bytecode (fun
);
2182 return exec_byte_code (AREF (fun
, COMPILED_BYTECODE
),
2183 AREF (fun
, COMPILED_CONSTANTS
),
2184 AREF (fun
, COMPILED_STACK_DEPTH
),
2193 i
= optional
= rest
= 0;
2194 for (; CONSP (syms_left
); syms_left
= XCDR (syms_left
))
2198 next
= XCAR (syms_left
);
2199 if (!SYMBOLP (next
))
2200 xsignal1 (Qinvalid_function
, fun
);
2202 if (EQ (next
, Qand_rest
))
2204 else if (EQ (next
, Qand_optional
))
2211 arg
= Flist (nargs
- i
, &arg_vector
[i
]);
2215 arg
= arg_vector
[i
++];
2217 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
2221 /* Bind the argument. */
2222 if (!NILP (lexenv
) && SYMBOLP (next
))
2223 /* Lexically bind NEXT by adding it to the lexenv alist. */
2224 lexenv
= Fcons (Fcons (next
, arg
), lexenv
);
2226 /* Dynamically bind NEXT. */
2227 specbind (next
, arg
);
2231 if (!NILP (syms_left
))
2232 xsignal1 (Qinvalid_function
, fun
);
2234 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
2236 if (!EQ (lexenv
, Vinternal_interpreter_environment
))
2237 /* Instantiate a new lexical environment. */
2238 specbind (Qinternal_interpreter_environment
, lexenv
);
2241 val
= Fprogn (XCDR (XCDR (fun
)));
2244 /* If we have not actually read the bytecode string
2245 and constants vector yet, fetch them from the file. */
2246 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
2247 Ffetch_bytecode (fun
);
2248 val
= exec_byte_code (AREF (fun
, COMPILED_BYTECODE
),
2249 AREF (fun
, COMPILED_CONSTANTS
),
2250 AREF (fun
, COMPILED_STACK_DEPTH
),
2258 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
2260 doc
: /* If byte-compiled OBJECT is lazy-loaded, fetch it now. */)
2261 (Lisp_Object object
)
2265 if (COMPILEDP (object
) && CONSP (AREF (object
, COMPILED_BYTECODE
)))
2267 tem
= read_doc_string (AREF (object
, COMPILED_BYTECODE
));
2270 tem
= AREF (object
, COMPILED_BYTECODE
);
2271 if (CONSP (tem
) && STRINGP (XCAR (tem
)))
2272 error ("Invalid byte code in %s", SDATA (XCAR (tem
)));
2274 error ("Invalid byte code");
2276 ASET (object
, COMPILED_BYTECODE
, XCAR (tem
));
2277 ASET (object
, COMPILED_CONSTANTS
, XCDR (tem
));
2282 /* Return true if SYMBOL currently has a let-binding
2283 which was made in the buffer that is now current. */
2286 let_shadows_buffer_binding_p (sym_t symbol
)
2288 union specbinding
*p
;
2289 Lisp_Object buf
= Fcurrent_buffer ();
2291 for (p
= specpdl_ptr
; p
> specpdl
; )
2292 if ((--p
)->kind
> SPECPDL_LET
)
2294 sym_t let_bound_symbol
= XSYMBOL (specpdl_symbol (p
));
2295 eassert (SYMBOL_REDIRECT (let_bound_symbol
) != SYMBOL_VARALIAS
);
2296 if (symbol
== let_bound_symbol
2297 && EQ (specpdl_where (p
), buf
))
2305 let_shadows_global_binding_p (Lisp_Object symbol
)
2307 union specbinding
*p
;
2309 for (p
= specpdl_ptr
; p
> specpdl
; )
2310 if ((--p
)->kind
>= SPECPDL_LET
&& EQ (specpdl_symbol (p
), symbol
))
2316 /* `specpdl_ptr' describes which variable is
2317 let-bound, so it can be properly undone when we unbind_to.
2318 It can be either a plain SPECPDL_LET or a SPECPDL_LET_LOCAL/DEFAULT.
2319 - SYMBOL is the variable being bound. Note that it should not be
2320 aliased (i.e. when let-binding V1 that's aliased to V2, we want
2322 - WHERE tells us in which buffer the binding took place.
2323 This is used for SPECPDL_LET_LOCAL bindings (i.e. bindings to a
2324 buffer-local variable) as well as for SPECPDL_LET_DEFAULT bindings,
2325 i.e. bindings to the default value of a variable which can be
2329 specbind (Lisp_Object symbol
, Lisp_Object value
)
2333 CHECK_SYMBOL (symbol
);
2334 sym
= XSYMBOL (symbol
);
2337 switch (SYMBOL_REDIRECT (sym
))
2339 case SYMBOL_VARALIAS
:
2340 sym
= indirect_variable (sym
); XSETSYMBOL (symbol
, sym
); goto start
;
2341 case SYMBOL_PLAINVAL
:
2342 /* The most common case is that of a non-constant symbol with a
2343 trivial value. Make that as fast as we can. */
2344 specpdl_ptr
->let
.kind
= SPECPDL_LET
;
2345 specpdl_ptr
->let
.symbol
= symbol
;
2346 specpdl_ptr
->let
.old_value
= SYMBOL_VAL (sym
);
2348 if (! SYMBOL_CONSTANT (sym
))
2349 SET_SYMBOL_VAL (sym
, value
);
2351 set_internal (symbol
, value
, Qnil
, 1);
2353 case SYMBOL_LOCALIZED
:
2354 if (SYMBOL_BLV (sym
)->frame_local
)
2355 error ("Frame-local vars cannot be let-bound");
2356 case SYMBOL_FORWARDED
:
2358 Lisp_Object ovalue
= find_symbol_value (symbol
);
2359 specpdl_ptr
->let
.kind
= SPECPDL_LET_LOCAL
;
2360 specpdl_ptr
->let
.symbol
= symbol
;
2361 specpdl_ptr
->let
.old_value
= ovalue
;
2362 specpdl_ptr
->let
.where
= Fcurrent_buffer ();
2364 eassert (SYMBOL_REDIRECT (sym
) != SYMBOL_LOCALIZED
2365 || (EQ (SYMBOL_BLV (sym
)->where
, Fcurrent_buffer ())));
2367 if (SYMBOL_REDIRECT (sym
) == SYMBOL_LOCALIZED
)
2369 if (!blv_found (SYMBOL_BLV (sym
)))
2370 specpdl_ptr
->let
.kind
= SPECPDL_LET_DEFAULT
;
2372 else if (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)))
2374 /* If SYMBOL is a per-buffer variable which doesn't have a
2375 buffer-local value here, make the `let' change the global
2376 value by changing the value of SYMBOL in all buffers not
2377 having their own value. This is consistent with what
2378 happens with other buffer-local variables. */
2379 if (NILP (Flocal_variable_p (symbol
, Qnil
)))
2381 specpdl_ptr
->let
.kind
= SPECPDL_LET_DEFAULT
;
2383 Fset_default (symbol
, value
);
2388 specpdl_ptr
->let
.kind
= SPECPDL_LET
;
2391 set_internal (symbol
, value
, Qnil
, 1);
2394 default: emacs_abort ();
2398 scm_dynwind_unwind_handler (unbind_once
, NULL
, SCM_F_WIND_EXPLICITLY
);
2401 /* Push unwind-protect entries of various types. */
2404 record_unwind_protect_1 (void (*function
) (Lisp_Object
), Lisp_Object arg
,
2405 bool wind_explicitly
)
2407 record_unwind_protect_ptr_1 (function
, arg
, wind_explicitly
);
2411 record_unwind_protect (void (*function
) (Lisp_Object
), Lisp_Object arg
)
2413 record_unwind_protect_1 (function
, arg
, true);
2417 record_unwind_protect_ptr_1 (void (*function
) (void *), void *arg
,
2418 bool wind_explicitly
)
2420 scm_dynwind_unwind_handler (function
,
2423 ? SCM_F_WIND_EXPLICITLY
2428 record_unwind_protect_ptr (void (*function
) (void *), void *arg
)
2430 record_unwind_protect_ptr_1 (function
, arg
, true);
2434 record_unwind_protect_int_1 (void (*function
) (int), int arg
,
2435 bool wind_explicitly
)
2437 record_unwind_protect_ptr_1 (function
, arg
, wind_explicitly
);
2441 record_unwind_protect_int (void (*function
) (int), int arg
)
2443 record_unwind_protect_int_1 (function
, arg
, true);
2447 call_void (void *data
)
2449 ((void (*) (void)) data
) ();
2453 record_unwind_protect_void_1 (void (*function
) (void),
2454 bool wind_explicitly
)
2456 record_unwind_protect_ptr_1 (call_void
, function
, wind_explicitly
);
2460 record_unwind_protect_void (void (*function
) (void))
2462 record_unwind_protect_void_1 (function
, true);
2466 unbind_once (void *ignore
)
2468 /* Decrement specpdl_ptr before we do the work to unbind it, so
2469 that an error in unbinding won't try to unbind the same entry
2470 again. Take care to copy any parts of the binding needed
2471 before invoking any code that can make more bindings. */
2475 switch (specpdl_ptr
->kind
)
2477 case SPECPDL_BACKTRACE
:
2480 { /* If variable has a trivial value (no forwarding), we can
2481 just set it. No need to check for constant symbols here,
2482 since that was already done by specbind. */
2483 sym_t sym
= XSYMBOL (specpdl_symbol (specpdl_ptr
));
2484 if (SYMBOL_REDIRECT (sym
) == SYMBOL_PLAINVAL
)
2486 SET_SYMBOL_VAL (sym
, specpdl_old_value (specpdl_ptr
));
2491 NOTE: we only ever come here if make_local_foo was used for
2492 the first time on this var within this let. */
2495 case SPECPDL_LET_DEFAULT
:
2496 Fset_default (specpdl_symbol (specpdl_ptr
),
2497 specpdl_old_value (specpdl_ptr
));
2499 case SPECPDL_LET_LOCAL
:
2501 Lisp_Object symbol
= specpdl_symbol (specpdl_ptr
);
2502 Lisp_Object where
= specpdl_where (specpdl_ptr
);
2503 Lisp_Object old_value
= specpdl_old_value (specpdl_ptr
);
2504 eassert (BUFFERP (where
));
2506 /* If this was a local binding, reset the value in the appropriate
2507 buffer, but only if that buffer's binding still exists. */
2508 if (!NILP (Flocal_variable_p (symbol
, where
)))
2509 set_internal (symbol
, old_value
, where
, 1);
2516 dynwind_begin (void)
2518 scm_dynwind_begin (0);
2527 DEFUN ("special-variable-p", Fspecial_variable_p
, Sspecial_variable_p
, 1, 1, 0,
2528 doc
: /* Return non-nil if SYMBOL's global binding has been declared special.
2529 A special variable is one that will be bound dynamically, even in a
2530 context where binding is lexical by default. */)
2531 (Lisp_Object symbol
)
2533 CHECK_SYMBOL (symbol
);
2534 return SYMBOL_DECLARED_SPECIAL (XSYMBOL (symbol
)) ? Qt
: Qnil
;
2538 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
2539 doc
: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
2540 The debugger is entered when that frame exits, if the flag is non-nil. */)
2541 (Lisp_Object level
, Lisp_Object flag
)
2543 union specbinding
*pdl
= backtrace_top ();
2544 register EMACS_INT i
;
2546 CHECK_NUMBER (level
);
2548 for (i
= 0; backtrace_p (pdl
) && i
< XINT (level
); i
++)
2549 pdl
= backtrace_next (pdl
);
2551 if (backtrace_p (pdl
))
2552 set_backtrace_debug_on_exit (pdl
, !NILP (flag
));
2557 DEFUN ("backtrace", Fbacktrace
, Sbacktrace
, 0, 0, "",
2558 doc
: /* Print a trace of Lisp function calls currently active.
2559 Output stream used is value of `standard-output'. */)
2562 union specbinding
*pdl
= backtrace_top ();
2564 Lisp_Object old_print_level
= Vprint_level
;
2566 if (NILP (Vprint_level
))
2567 XSETFASTINT (Vprint_level
, 8);
2569 while (backtrace_p (pdl
))
2571 write_string (backtrace_debug_on_exit (pdl
) ? "* " : " ", 2);
2572 if (backtrace_nargs (pdl
) == UNEVALLED
)
2574 Fprin1 (Fcons (backtrace_function (pdl
), *backtrace_args (pdl
)),
2576 write_string ("\n", -1);
2580 tem
= backtrace_function (pdl
);
2581 Fprin1 (tem
, Qnil
); /* This can QUIT. */
2582 write_string ("(", -1);
2585 for (i
= 0; i
< backtrace_nargs (pdl
); i
++)
2587 if (i
) write_string (" ", -1);
2588 Fprin1 (backtrace_args (pdl
)[i
], Qnil
);
2591 write_string (")\n", -1);
2593 pdl
= backtrace_next (pdl
);
2596 Vprint_level
= old_print_level
;
2600 static union specbinding
*
2601 get_backtrace_frame (Lisp_Object nframes
, Lisp_Object base
)
2603 union specbinding
*pdl
= backtrace_top ();
2604 register EMACS_INT i
;
2606 CHECK_NATNUM (nframes
);
2609 { /* Skip up to `base'. */
2610 base
= Findirect_function (base
, Qt
);
2611 while (backtrace_p (pdl
)
2612 && !EQ (base
, Findirect_function (backtrace_function (pdl
), Qt
)))
2613 pdl
= backtrace_next (pdl
);
2616 /* Find the frame requested. */
2617 for (i
= XFASTINT (nframes
); i
> 0 && backtrace_p (pdl
); i
--)
2618 pdl
= backtrace_next (pdl
);
2623 DEFUN ("backtrace-frame", Fbacktrace_frame
, Sbacktrace_frame
, 1, 2, NULL
,
2624 doc
: /* Return the function and arguments NFRAMES up from current execution point.
2625 If that frame has not evaluated the arguments yet (or is a special form),
2626 the value is (nil FUNCTION ARG-FORMS...).
2627 If that frame has evaluated its arguments and called its function already,
2628 the value is (t FUNCTION ARG-VALUES...).
2629 A &rest arg is represented as the tail of the list ARG-VALUES.
2630 FUNCTION is whatever was supplied as car of evaluated list,
2631 or a lambda expression for macro calls.
2632 If NFRAMES is more than the number of frames, the value is nil.
2633 If BASE is non-nil, it should be a function and NFRAMES counts from its
2634 nearest activation frame. */)
2635 (Lisp_Object nframes
, Lisp_Object base
)
2637 union specbinding
*pdl
= get_backtrace_frame (nframes
, base
);
2639 if (!backtrace_p (pdl
))
2641 if (backtrace_nargs (pdl
) == UNEVALLED
)
2643 Fcons (backtrace_function (pdl
), *backtrace_args (pdl
)));
2646 Lisp_Object tem
= Flist (backtrace_nargs (pdl
), backtrace_args (pdl
));
2648 return Fcons (Qt
, Fcons (backtrace_function (pdl
), tem
));
2652 /* For backtrace-eval, we want to temporarily unwind the last few elements of
2653 the specpdl stack, and then rewind them. We store the pre-unwind values
2654 directly in the pre-existing specpdl elements (i.e. we swap the current
2655 value and the old value stored in the specpdl), kind of like the inplace
2656 pointer-reversal trick. As it turns out, the rewind does the same as the
2657 unwind, except it starts from the other end of the specpdl stack, so we use
2658 the same function for both unwind and rewind. */
2660 backtrace_eval_unrewind (int distance
)
2662 union specbinding
*tmp
= specpdl_ptr
;
2665 { /* It's a rewind rather than unwind. */
2666 tmp
+= distance
- 1;
2668 distance
= -distance
;
2671 for (; distance
> 0; distance
--)
2677 case SPECPDL_BACKTRACE
:
2680 { /* If variable has a trivial value (no forwarding), we can
2681 just set it. No need to check for constant symbols here,
2682 since that was already done by specbind. */
2683 sym_t sym
= XSYMBOL (specpdl_symbol (tmp
));
2684 if (SYMBOL_REDIRECT (sym
) == SYMBOL_PLAINVAL
)
2686 Lisp_Object old_value
= specpdl_old_value (tmp
);
2687 set_specpdl_old_value (tmp
, SYMBOL_VAL (sym
));
2688 SET_SYMBOL_VAL (sym
, old_value
);
2693 NOTE: we only ever come here if make_local_foo was used for
2694 the first time on this var within this let. */
2697 case SPECPDL_LET_DEFAULT
:
2699 Lisp_Object sym
= specpdl_symbol (tmp
);
2700 Lisp_Object old_value
= specpdl_old_value (tmp
);
2701 set_specpdl_old_value (tmp
, Fdefault_value (sym
));
2702 Fset_default (sym
, old_value
);
2705 case SPECPDL_LET_LOCAL
:
2707 Lisp_Object symbol
= specpdl_symbol (tmp
);
2708 Lisp_Object where
= specpdl_where (tmp
);
2709 Lisp_Object old_value
= specpdl_old_value (tmp
);
2710 eassert (BUFFERP (where
));
2712 /* If this was a local binding, reset the value in the appropriate
2713 buffer, but only if that buffer's binding still exists. */
2714 if (!NILP (Flocal_variable_p (symbol
, where
)))
2716 set_specpdl_old_value
2717 (tmp
, Fbuffer_local_value (symbol
, where
));
2718 set_internal (symbol
, old_value
, where
, 1);
2726 DEFUN ("backtrace-eval", Fbacktrace_eval
, Sbacktrace_eval
, 2, 3, NULL
,
2727 doc
: /* Evaluate EXP in the context of some activation frame.
2728 NFRAMES and BASE specify the activation frame to use, as in `backtrace-frame'. */)
2729 (Lisp_Object exp
, Lisp_Object nframes
, Lisp_Object base
)
2731 union specbinding
*pdl
= get_backtrace_frame (nframes
, base
);
2733 ptrdiff_t distance
= specpdl_ptr
- pdl
;
2734 eassert (distance
>= 0);
2736 if (!backtrace_p (pdl
))
2737 error ("Activation frame not found!");
2739 backtrace_eval_unrewind (distance
);
2740 record_unwind_protect_int (backtrace_eval_unrewind
, -distance
);
2742 /* Use eval_sub rather than Feval since the main motivation behind
2743 backtrace-eval is to be able to get/set the value of lexical variables
2744 from the debugger. */
2745 Lisp_Object tem1
= eval_sub (exp
);
2750 DEFUN ("backtrace--locals", Fbacktrace__locals
, Sbacktrace__locals
, 1, 2, NULL
,
2751 doc
: /* Return names and values of local variables of a stack frame.
2752 NFRAMES and BASE specify the activation frame to use, as in `backtrace-frame'. */)
2753 (Lisp_Object nframes
, Lisp_Object base
)
2755 union specbinding
*frame
= get_backtrace_frame (nframes
, base
);
2756 union specbinding
*prevframe
2757 = get_backtrace_frame (make_number (XFASTINT (nframes
) - 1), base
);
2758 ptrdiff_t distance
= specpdl_ptr
- frame
;
2759 Lisp_Object result
= Qnil
;
2760 eassert (distance
>= 0);
2762 if (!backtrace_p (prevframe
))
2763 error ("Activation frame not found!");
2764 if (!backtrace_p (frame
))
2765 error ("Activation frame not found!");
2767 /* The specpdl entries normally contain the symbol being bound along with its
2768 `old_value', so it can be restored. The new value to which it is bound is
2769 available in one of two places: either in the current value of the
2770 variable (if it hasn't been rebound yet) or in the `old_value' slot of the
2771 next specpdl entry for it.
2772 `backtrace_eval_unrewind' happens to swap the role of `old_value'
2773 and "new value", so we abuse it here, to fetch the new value.
2774 It's ugly (we'd rather not modify global data) and a bit inefficient,
2775 but it does the job for now. */
2776 backtrace_eval_unrewind (distance
);
2780 union specbinding
*tmp
= prevframe
;
2781 for (; tmp
> frame
; tmp
--)
2786 case SPECPDL_LET_DEFAULT
:
2787 case SPECPDL_LET_LOCAL
:
2789 Lisp_Object sym
= specpdl_symbol (tmp
);
2790 Lisp_Object val
= specpdl_old_value (tmp
);
2791 if (EQ (sym
, Qinternal_interpreter_environment
))
2793 Lisp_Object env
= val
;
2794 for (; CONSP (env
); env
= XCDR (env
))
2796 Lisp_Object binding
= XCAR (env
);
2797 if (CONSP (binding
))
2798 result
= Fcons (Fcons (XCAR (binding
),
2804 result
= Fcons (Fcons (sym
, val
), result
);
2810 /* Restore values from specpdl to original place. */
2811 backtrace_eval_unrewind (-distance
);
2818 get_backtrace (Lisp_Object array
)
2820 union specbinding
*pdl
= backtrace_next (backtrace_top ());
2821 ptrdiff_t i
= 0, asize
= ASIZE (array
);
2823 /* Copy the backtrace contents into working memory. */
2824 for (; i
< asize
; i
++)
2826 if (backtrace_p (pdl
))
2828 ASET (array
, i
, backtrace_function (pdl
));
2829 pdl
= backtrace_next (pdl
);
2832 ASET (array
, i
, Qnil
);
2836 Lisp_Object
backtrace_top_function (void)
2838 union specbinding
*pdl
= backtrace_top ();
2839 return (backtrace_p (pdl
) ? backtrace_function (pdl
) : Qnil
);
2843 abort_to_prompt (SCM tag
, SCM arglst
)
2845 static SCM var
= SCM_UNDEFINED
;
2846 if (SCM_UNBNDP (var
))
2847 var
= scm_c_public_lookup ("guile", "abort-to-prompt");
2849 scm_apply_1 (scm_variable_ref (var
), tag
, arglst
);
2854 call_with_prompt (SCM tag
, SCM thunk
, SCM handler
)
2856 static SCM var
= SCM_UNDEFINED
;
2857 if (SCM_UNBNDP (var
))
2858 var
= scm_c_public_lookup ("guile", "call-with-prompt");
2860 return scm_call_3 (scm_variable_ref (var
), tag
, thunk
, handler
);
2864 make_prompt_tag (void)
2866 static SCM var
= SCM_UNDEFINED
;
2867 if (SCM_UNBNDP (var
))
2868 var
= scm_c_public_lookup ("guile", "make-prompt-tag");
2870 return scm_call_0 (scm_variable_ref (var
));
2878 DEFVAR_INT ("max-specpdl-size", max_specpdl_size
,
2879 doc
: /* Limit on number of Lisp variable bindings and `unwind-protect's.
2880 If Lisp code tries to increase the total number past this amount,
2881 an error is signaled.
2882 You can safely use a value considerably larger than the default value,
2883 if that proves inconveniently small. However, if you increase it too far,
2884 Emacs could run out of memory trying to make the stack bigger.
2885 Note that this limit may be silently increased by the debugger
2886 if `debug-on-error' or `debug-on-quit' is set. */);
2888 DEFVAR_INT ("max-lisp-eval-depth", max_lisp_eval_depth
,
2889 doc
: /* Limit on depth in `eval', `apply' and `funcall' before error.
2891 This limit serves to catch infinite recursions for you before they cause
2892 actual stack overflow in C, which would be fatal for Emacs.
2893 You can safely make it considerably larger than its default value,
2894 if that proves inconveniently small. However, if you increase it too far,
2895 Emacs could overflow the real C stack, and crash. */);
2897 DEFVAR_LISP ("quit-flag", Vquit_flag
,
2898 doc
: /* Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
2899 If the value is t, that means do an ordinary quit.
2900 If the value equals `throw-on-input', that means quit by throwing
2901 to the tag specified in `throw-on-input'; it's for handling `while-no-input'.
2902 Typing C-g sets `quit-flag' to t, regardless of `inhibit-quit',
2903 but `inhibit-quit' non-nil prevents anything from taking notice of that. */);
2906 DEFVAR_LISP ("inhibit-quit", Vinhibit_quit
,
2907 doc
: /* Non-nil inhibits C-g quitting from happening immediately.
2908 Note that `quit-flag' will still be set by typing C-g,
2909 so a quit will be signaled as soon as `inhibit-quit' is nil.
2910 To prevent this happening, set `quit-flag' to nil
2911 before making `inhibit-quit' nil. */);
2912 Vinhibit_quit
= Qnil
;
2914 DEFSYM (Qinhibit_quit
, "inhibit-quit");
2915 DEFSYM (Qautoload
, "autoload");
2916 DEFSYM (Qinhibit_debugger
, "inhibit-debugger");
2917 DEFSYM (Qmacro
, "macro");
2918 DEFSYM (Qdeclare
, "declare");
2920 /* Note that the process handling also uses Qexit, but we don't want
2921 to staticpro it twice, so we just do it here. */
2922 DEFSYM (Qexit
, "exit");
2924 DEFSYM (Qinteractive
, "interactive");
2925 DEFSYM (Qcommandp
, "commandp");
2926 DEFSYM (Qand_rest
, "&rest");
2927 DEFSYM (Qand_optional
, "&optional");
2928 DEFSYM (Qclosure
, "closure");
2929 DEFSYM (Qdebug
, "debug");
2931 DEFVAR_LISP ("inhibit-debugger", Vinhibit_debugger
,
2932 doc
: /* Non-nil means never enter the debugger.
2933 Normally set while the debugger is already active, to avoid recursive
2935 Vinhibit_debugger
= Qnil
;
2937 DEFVAR_LISP ("debug-on-error", Vdebug_on_error
,
2938 doc
: /* Non-nil means enter debugger if an error is signaled.
2939 Does not apply to errors handled by `condition-case' or those
2940 matched by `debug-ignored-errors'.
2941 If the value is a list, an error only means to enter the debugger
2942 if one of its condition symbols appears in the list.
2943 When you evaluate an expression interactively, this variable
2944 is temporarily non-nil if `eval-expression-debug-on-error' is non-nil.
2945 The command `toggle-debug-on-error' toggles this.
2946 See also the variable `debug-on-quit' and `inhibit-debugger'. */);
2947 Vdebug_on_error
= Qnil
;
2949 DEFVAR_LISP ("debug-ignored-errors", Vdebug_ignored_errors
,
2950 doc
: /* List of errors for which the debugger should not be called.
2951 Each element may be a condition-name or a regexp that matches error messages.
2952 If any element applies to a given error, that error skips the debugger
2953 and just returns to top level.
2954 This overrides the variable `debug-on-error'.
2955 It does not apply to errors handled by `condition-case'. */);
2956 Vdebug_ignored_errors
= Qnil
;
2958 DEFVAR_BOOL ("debug-on-quit", debug_on_quit
,
2959 doc
: /* Non-nil means enter debugger if quit is signaled (C-g, for example).
2960 Does not apply if quit is handled by a `condition-case'. */);
2963 DEFVAR_BOOL ("debug-on-next-call", debug_on_next_call
,
2964 doc
: /* Non-nil means enter debugger before next `eval', `apply' or `funcall'. */);
2966 DEFVAR_BOOL ("debugger-may-continue", debugger_may_continue
,
2967 doc
: /* Non-nil means debugger may continue execution.
2968 This is nil when the debugger is called under circumstances where it
2969 might not be safe to continue. */);
2970 debugger_may_continue
= 1;
2972 DEFVAR_LISP ("debugger", Vdebugger
,
2973 doc
: /* Function to call to invoke debugger.
2974 If due to frame exit, args are `exit' and the value being returned;
2975 this function's value will be returned instead of that.
2976 If due to error, args are `error' and a list of the args to `signal'.
2977 If due to `apply' or `funcall' entry, one arg, `lambda'.
2978 If due to `eval' entry, one arg, t. */);
2981 DEFVAR_LISP ("signal-hook-function", Vsignal_hook_function
,
2982 doc
: /* If non-nil, this is a function for `signal' to call.
2983 It receives the same arguments that `signal' was given.
2984 The Edebug package uses this to regain control. */);
2985 Vsignal_hook_function
= Qnil
;
2987 DEFVAR_LISP ("debug-on-signal", Vdebug_on_signal
,
2988 doc
: /* Non-nil means call the debugger regardless of condition handlers.
2989 Note that `debug-on-error', `debug-on-quit' and friends
2990 still determine whether to handle the particular condition. */);
2991 Vdebug_on_signal
= Qnil
;
2993 /* When lexical binding is being used,
2994 Vinternal_interpreter_environment is non-nil, and contains an alist
2995 of lexically-bound variable, or (t), indicating an empty
2996 environment. The lisp name of this variable would be
2997 `internal-interpreter-environment' if it weren't hidden.
2998 Every element of this list can be either a cons (VAR . VAL)
2999 specifying a lexical binding, or a single symbol VAR indicating
3000 that this variable should use dynamic scoping. */
3001 DEFSYM (Qinternal_interpreter_environment
,
3002 "internal-interpreter-environment");
3003 DEFVAR_LISP ("internal-interpreter-environment",
3004 Vinternal_interpreter_environment
,
3005 doc
: /* If non-nil, the current lexical environment of the lisp interpreter.
3006 When lexical binding is not being used, this variable is nil.
3007 A value of `(t)' indicates an empty environment, otherwise it is an
3008 alist of active lexical bindings. */);
3009 Vinternal_interpreter_environment
= Qnil
;
3010 /* Don't export this variable to Elisp, so no one can mess with it
3011 (Just imagine if someone makes it buffer-local). */
3012 //Funintern (Qinternal_interpreter_environment, Qnil);
3014 DEFSYM (Vrun_hooks
, "run-hooks");
3016 staticpro (&Vautoload_queue
);
3017 Vautoload_queue
= Qnil
;
3018 staticpro (&Vsignaling_function
);
3019 Vsignaling_function
= Qnil
;
3021 inhibit_lisp_code
= Qnil
;