1 |
/* Evaluator for GNU Emacs Lisp interpreter. |
/* Evaluator for GNU Emacs Lisp interpreter. |
2 |
Copyright (C) 1985, 86, 87, 93, 94, 95, 99, 2000, 2001, 2002 |
Copyright (C) 1985, 86, 87, 93, 94, 95, 99, 2000, 2001, 2002, 2003 |
3 |
Free Software Foundation, Inc. |
Free Software Foundation, Inc. |
4 |
|
|
5 |
This file is part of GNU Emacs. |
This file is part of GNU Emacs. |
77 |
int lisp_eval_depth; |
int lisp_eval_depth; |
78 |
int pdlcount; |
int pdlcount; |
79 |
int poll_suppress_count; |
int poll_suppress_count; |
80 |
|
int interrupt_input_blocked; |
81 |
struct byte_stack *byte_stack; |
struct byte_stack *byte_stack; |
82 |
}; |
}; |
83 |
|
|
88 |
int gcpro_level; |
int gcpro_level; |
89 |
#endif |
#endif |
90 |
|
|
91 |
Lisp_Object Qautoload, Qmacro, Qexit, Qinteractive, Qcommandp, Qdefun; |
Lisp_Object Qautoload, Qmacro, Qexit, Qinteractive, Qcommandp, Qdefun, Qdefvar; |
92 |
Lisp_Object Qinhibit_quit, Vinhibit_quit, Vquit_flag; |
Lisp_Object Qinhibit_quit, Vinhibit_quit, Vquit_flag; |
93 |
Lisp_Object Qand_rest, Qand_optional; |
Lisp_Object Qand_rest, Qand_optional; |
94 |
Lisp_Object Qdebug_on_error; |
Lisp_Object Qdebug_on_error; |
243 |
Lisp_Object arg; |
Lisp_Object arg; |
244 |
{ |
{ |
245 |
int debug_while_redisplaying; |
int debug_while_redisplaying; |
246 |
int count = specpdl_ptr - specpdl; |
int count = SPECPDL_INDEX (); |
247 |
Lisp_Object val; |
Lisp_Object val; |
248 |
|
|
249 |
if (lisp_eval_depth + 20 > max_lisp_eval_depth) |
if (lisp_eval_depth + 20 > max_lisp_eval_depth) |
250 |
max_lisp_eval_depth = lisp_eval_depth + 20; |
max_lisp_eval_depth = lisp_eval_depth + 20; |
251 |
|
|
252 |
if (specpdl_size + 40 > max_specpdl_size) |
if (specpdl_size + 40 > max_specpdl_size) |
253 |
max_specpdl_size = specpdl_size + 40; |
max_specpdl_size = specpdl_size + 40; |
254 |
|
|
255 |
#ifdef HAVE_X_WINDOWS |
#ifdef HAVE_X_WINDOWS |
256 |
if (display_hourglass_p) |
if (display_hourglass_p) |
257 |
cancel_hourglass (); |
cancel_hourglass (); |
272 |
redisplay, which necessarily leads to display problems. */ |
redisplay, which necessarily leads to display problems. */ |
273 |
specbind (Qinhibit_eval_during_redisplay, Qt); |
specbind (Qinhibit_eval_during_redisplay, Qt); |
274 |
#endif |
#endif |
275 |
|
|
276 |
val = apply1 (Vdebugger, arg); |
val = apply1 (Vdebugger, arg); |
277 |
|
|
278 |
/* Interrupting redisplay and resuming it later is not safe under |
/* Interrupting redisplay and resuming it later is not safe under |
554 |
UNGCPRO; |
UNGCPRO; |
555 |
return val; |
return val; |
556 |
} |
} |
557 |
|
|
558 |
DEFUN ("quote", Fquote, Squote, 1, UNEVALLED, 0, |
DEFUN ("quote", Fquote, Squote, 1, UNEVALLED, 0, |
559 |
doc: /* Return the argument, without evaluating it. `(quote x)' yields `x'. |
doc: /* Return the argument, without evaluating it. `(quote x)' yields `x'. |
560 |
usage: (quote ARG) */) |
usage: (quote ARG) */) |
563 |
{ |
{ |
564 |
return Fcar (args); |
return Fcar (args); |
565 |
} |
} |
566 |
|
|
567 |
DEFUN ("function", Ffunction, Sfunction, 1, UNEVALLED, 0, |
DEFUN ("function", Ffunction, Sfunction, 1, UNEVALLED, 0, |
568 |
doc: /* Like `quote', but preferred for objects which are functions. |
doc: /* Like `quote', but preferred for objects which are functions. |
569 |
In byte compilation, `function' causes its argument to be compiled. |
In byte compilation, `function' causes its argument to be compiled. |
625 |
btp = btp->next; |
btp = btp->next; |
626 |
|
|
627 |
/* If we're running an Emacs 18-style byte-compiled function, there |
/* If we're running an Emacs 18-style byte-compiled function, there |
628 |
may be a frame for Fbytecode. Now, given the strictest |
may be a frame for Fbytecode at the top level. In any version of |
629 |
definition, this function isn't really being called |
Emacs there can be Fbytecode frames for subexpressions evaluated |
630 |
interactively, but because that's the way Emacs 18 always builds |
inside catch and condition-case. Skip past them. |
|
byte-compiled functions, we'll accept it for now. */ |
|
|
if (EQ (*btp->function, Qbytecode)) |
|
|
btp = btp->next; |
|
631 |
|
|
632 |
/* If this isn't a byte-compiled function, then we may now be |
If this isn't a byte-compiled function, then we may now be |
633 |
looking at several frames for special forms. Skip past them. */ |
looking at several frames for special forms. Skip past them. */ |
634 |
while (btp && |
while (btp |
635 |
btp->nargs == UNEVALLED) |
&& (EQ (*btp->function, Qbytecode) |
636 |
|
|| btp->nargs == UNEVALLED)) |
637 |
btp = btp->next; |
btp = btp->next; |
638 |
|
|
639 |
/* btp now points at the frame of the innermost function that isn't |
/* btp now points at the frame of the innermost function that isn't |
643 |
fun = Findirect_function (*btp->function); |
fun = Findirect_function (*btp->function); |
644 |
if (exclude_subrs_p && SUBRP (fun)) |
if (exclude_subrs_p && SUBRP (fun)) |
645 |
return 0; |
return 0; |
646 |
|
|
647 |
/* btp points to the frame of a Lisp function that called interactive-p. |
/* btp points to the frame of a Lisp function that called interactive-p. |
648 |
Return t if that function was called interactively. */ |
Return t if that function was called interactively. */ |
649 |
if (btp && btp->next && EQ (*btp->next->function, Qcall_interactively)) |
if (btp && btp->next && EQ (*btp->next->function, Qcall_interactively)) |
669 |
defn = Fcons (Qclosure, Fcons (Vinternal_interpreter_environment, defn)); |
defn = Fcons (Qclosure, Fcons (Vinternal_interpreter_environment, defn)); |
670 |
if (!NILP (Vpurify_flag)) |
if (!NILP (Vpurify_flag)) |
671 |
defn = Fpurecopy (defn); |
defn = Fpurecopy (defn); |
672 |
|
if (CONSP (XSYMBOL (fn_name)->function) |
673 |
|
&& EQ (XCAR (XSYMBOL (fn_name)->function), Qautoload)) |
674 |
|
LOADHIST_ATTACH (Fcons (Qt, fn_name)); |
675 |
Ffset (fn_name, defn); |
Ffset (fn_name, defn); |
676 |
LOADHIST_ATTACH (fn_name); |
LOADHIST_ATTACH (fn_name); |
677 |
return fn_name; |
return fn_name; |
679 |
|
|
680 |
DEFUN ("defmacro", Fdefmacro, Sdefmacro, 2, UNEVALLED, 0, |
DEFUN ("defmacro", Fdefmacro, Sdefmacro, 2, UNEVALLED, 0, |
681 |
doc: /* Define NAME as a macro. |
doc: /* Define NAME as a macro. |
682 |
The definition is (macro lambda ARGLIST [DOCSTRING] BODY...). |
The actual definition looks like |
683 |
|
(macro lambda ARGLIST [DOCSTRING] [DECL] BODY...). |
684 |
When the macro is called, as in (NAME ARGS...), |
When the macro is called, as in (NAME ARGS...), |
685 |
the function (lambda ARGLIST BODY...) is applied to |
the function (lambda ARGLIST BODY...) is applied to |
686 |
the list ARGS... as it appears in the expression, |
the list ARGS... as it appears in the expression, |
687 |
and the result should be a form to be evaluated instead of the original. |
and the result should be a form to be evaluated instead of the original. |
688 |
usage: (defmacro NAME ARGLIST [DOCSTRING] BODY...) */) |
|
689 |
|
DECL is a declaration, optional, which can specify how to indent |
690 |
|
calls to this macro and how Edebug should handle it. It looks like this: |
691 |
|
(declare SPECS...) |
692 |
|
The elements can look like this: |
693 |
|
(indent INDENT) |
694 |
|
Set NAME's `lisp-indent-function' property to INDENT. |
695 |
|
|
696 |
|
(edebug DEBUG) |
697 |
|
Set NAME's `edebug-form-spec' property to DEBUG. (This is |
698 |
|
equivalent to writing a `def-edebug-spec' for the macro.) |
699 |
|
usage: (defmacro NAME ARGLIST [DOCSTRING] [DECL] BODY...) */) |
700 |
(args) |
(args) |
701 |
Lisp_Object args; |
Lisp_Object args; |
702 |
{ |
{ |
725 |
call2 (Vmacro_declaration_function, fn_name, Fcar (tail)); |
call2 (Vmacro_declaration_function, fn_name, Fcar (tail)); |
726 |
UNGCPRO; |
UNGCPRO; |
727 |
} |
} |
728 |
|
|
729 |
tail = Fcdr (tail); |
tail = Fcdr (tail); |
730 |
} |
} |
731 |
|
|
741 |
|
|
742 |
if (!NILP (Vpurify_flag)) |
if (!NILP (Vpurify_flag)) |
743 |
defn = Fpurecopy (defn); |
defn = Fpurecopy (defn); |
744 |
|
if (CONSP (XSYMBOL (fn_name)->function) |
745 |
|
&& EQ (XCAR (XSYMBOL (fn_name)->function), Qautoload)) |
746 |
|
LOADHIST_ATTACH (Fcons (Qt, fn_name)); |
747 |
Ffset (fn_name, defn); |
Ffset (fn_name, defn); |
748 |
LOADHIST_ATTACH (fn_name); |
LOADHIST_ATTACH (fn_name); |
749 |
return fn_name; |
return fn_name; |
750 |
} |
} |
751 |
|
|
752 |
|
|
753 |
DEFUN ("defvaralias", Fdefvaralias, Sdefvaralias, 2, 2, 0, |
DEFUN ("defvaralias", Fdefvaralias, Sdefvaralias, 2, 3, 0, |
754 |
doc: /* Make SYMBOL a variable alias for symbol ALIASED. |
doc: /* Make SYMBOL a variable alias for symbol ALIASED. |
755 |
Setting the value of SYMBOL will subsequently set the value of ALIASED, |
Setting the value of SYMBOL will subsequently set the value of ALIASED, |
756 |
and getting the value of SYMBOL will return the value ALIASED has. |
and getting the value of SYMBOL will return the value ALIASED has. |
757 |
ALIASED nil means remove the alias; SYMBOL is unbound after that. */) |
ALIASED nil means remove the alias; SYMBOL is unbound after that. |
758 |
(symbol, aliased) |
Third arg DOCSTRING, if non-nil, is documentation for SYMBOL. */) |
759 |
Lisp_Object symbol, aliased; |
(symbol, aliased, docstring) |
760 |
|
Lisp_Object symbol, aliased, docstring; |
761 |
{ |
{ |
762 |
struct Lisp_Symbol *sym; |
struct Lisp_Symbol *sym; |
763 |
|
|
764 |
CHECK_SYMBOL (symbol); |
CHECK_SYMBOL (symbol); |
765 |
CHECK_SYMBOL (aliased); |
CHECK_SYMBOL (aliased); |
766 |
|
|
772 |
sym->declared_special = 1; |
sym->declared_special = 1; |
773 |
sym->value = aliased; |
sym->value = aliased; |
774 |
sym->constant = SYMBOL_CONSTANT_P (aliased); |
sym->constant = SYMBOL_CONSTANT_P (aliased); |
775 |
LOADHIST_ATTACH (symbol); |
LOADHIST_ATTACH (Fcons (Qdefvar, symbol)); |
776 |
|
if (!NILP (docstring)) |
777 |
|
Fput (symbol, Qvariable_documentation, docstring); |
778 |
|
|
779 |
return aliased; |
return aliased; |
780 |
} |
} |
781 |
|
|
818 |
tem = Fpurecopy (tem); |
tem = Fpurecopy (tem); |
819 |
Fput (sym, Qvariable_documentation, tem); |
Fput (sym, Qvariable_documentation, tem); |
820 |
} |
} |
821 |
LOADHIST_ATTACH (sym); |
LOADHIST_ATTACH (Fcons (Qdefvar, sym)); |
822 |
} |
} |
823 |
else |
else |
824 |
/* A (defvar <var>) should not take precedence in the load-history over |
/* Simple (defvar <var>) should not count as a definition at all. |
825 |
an earlier (defvar <var> <val>), so only add to history if the default |
It could get in the way of other definitions, and unloading this |
826 |
value is still unbound. */ |
package could try to make the variable unbound. */ |
827 |
if (NILP (tem)) |
; |
|
LOADHIST_ATTACH (sym); |
|
828 |
|
|
829 |
if (SYMBOLP (sym)) |
if (SYMBOLP (sym)) |
830 |
XSYMBOL (sym)->declared_special = 1; |
XSYMBOL (sym)->declared_special = 1; |
861 |
tem = Fpurecopy (tem); |
tem = Fpurecopy (tem); |
862 |
Fput (sym, Qvariable_documentation, tem); |
Fput (sym, Qvariable_documentation, tem); |
863 |
} |
} |
864 |
LOADHIST_ATTACH (sym); |
LOADHIST_ATTACH (Fcons (Qdefvar, sym)); |
865 |
return sym; |
return sym; |
866 |
} |
} |
867 |
|
|
870 |
\(The alternative is a variable used internally in a Lisp program.) |
\(The alternative is a variable used internally in a Lisp program.) |
871 |
Determined by whether the first character of the documentation |
Determined by whether the first character of the documentation |
872 |
for the variable is `*' or if the variable is customizable (has a non-nil |
for the variable is `*' or if the variable is customizable (has a non-nil |
873 |
value of any of `custom-type', `custom-loads' or `standard-value' |
value of `standard-value' or of `custom-autoload' on its property list). */) |
|
on its property list). */) |
|
874 |
(variable) |
(variable) |
875 |
Lisp_Object variable; |
Lisp_Object variable; |
876 |
{ |
{ |
877 |
Lisp_Object documentation; |
Lisp_Object documentation; |
878 |
|
|
879 |
if (!SYMBOLP (variable)) |
if (!SYMBOLP (variable)) |
880 |
return Qnil; |
return Qnil; |
881 |
|
|
883 |
if (INTEGERP (documentation) && XINT (documentation) < 0) |
if (INTEGERP (documentation) && XINT (documentation) < 0) |
884 |
return Qt; |
return Qt; |
885 |
if (STRINGP (documentation) |
if (STRINGP (documentation) |
886 |
&& ((unsigned char) XSTRING (documentation)->data[0] == '*')) |
&& ((unsigned char) SREF (documentation, 0) == '*')) |
887 |
return Qt; |
return Qt; |
888 |
/* If it is (STRING . INTEGER), a negative integer means a user variable. */ |
/* If it is (STRING . INTEGER), a negative integer means a user variable. */ |
889 |
if (CONSP (documentation) |
if (CONSP (documentation) |
891 |
&& INTEGERP (XCDR (documentation)) |
&& INTEGERP (XCDR (documentation)) |
892 |
&& XINT (XCDR (documentation)) < 0) |
&& XINT (XCDR (documentation)) < 0) |
893 |
return Qt; |
return Qt; |
894 |
/* Customizable? */ |
/* Customizable? See `custom-variable-p'. */ |
895 |
if ((!NILP (Fget (variable, intern ("custom-type")))) |
if ((!NILP (Fget (variable, intern ("standard-value")))) |
896 |
|| (!NILP (Fget (variable, intern ("custom-loads")))) |
|| (!NILP (Fget (variable, intern ("custom-autoload"))))) |
|
|| (!NILP (Fget (variable, intern ("standard-value"))))) |
|
897 |
return Qt; |
return Qt; |
898 |
return Qnil; |
return Qnil; |
899 |
} |
} |
900 |
|
|
901 |
DEFUN ("let*", FletX, SletX, 1, UNEVALLED, 0, |
DEFUN ("let*", FletX, SletX, 1, UNEVALLED, 0, |
902 |
doc: /* Bind variables according to VARLIST then eval BODY. |
doc: /* Bind variables according to VARLIST then eval BODY. |
909 |
Lisp_Object args; |
Lisp_Object args; |
910 |
{ |
{ |
911 |
Lisp_Object varlist, var, val, elt, lexenv; |
Lisp_Object varlist, var, val, elt, lexenv; |
912 |
int count = specpdl_ptr - specpdl; |
int count = SPECPDL_INDEX (); |
913 |
struct gcpro gcpro1, gcpro2, gcpro3; |
struct gcpro gcpro1, gcpro2, gcpro3; |
914 |
|
|
915 |
GCPRO3 (args, elt, varlist); |
GCPRO3 (args, elt, varlist); |
969 |
{ |
{ |
970 |
Lisp_Object *temps, tem, lexenv; |
Lisp_Object *temps, tem, lexenv; |
971 |
register Lisp_Object elt, varlist; |
register Lisp_Object elt, varlist; |
972 |
int count = specpdl_ptr - specpdl; |
int count = SPECPDL_INDEX (); |
973 |
register int argnum; |
register int argnum; |
974 |
struct gcpro gcpro1, gcpro2; |
struct gcpro gcpro1, gcpro2; |
975 |
|
|
1173 |
c.backlist = backtrace_list; |
c.backlist = backtrace_list; |
1174 |
c.handlerlist = handlerlist; |
c.handlerlist = handlerlist; |
1175 |
c.lisp_eval_depth = lisp_eval_depth; |
c.lisp_eval_depth = lisp_eval_depth; |
1176 |
c.pdlcount = specpdl_ptr - specpdl; |
c.pdlcount = SPECPDL_INDEX (); |
1177 |
c.poll_suppress_count = poll_suppress_count; |
c.poll_suppress_count = poll_suppress_count; |
1178 |
|
c.interrupt_input_blocked = interrupt_input_blocked; |
1179 |
c.gcpro = gcprolist; |
c.gcpro = gcprolist; |
1180 |
c.byte_stack = byte_stack_list; |
c.byte_stack = byte_stack_list; |
1181 |
catchlist = &c; |
catchlist = &c; |
1217 |
|
|
1218 |
/* Restore the polling-suppression count. */ |
/* Restore the polling-suppression count. */ |
1219 |
set_poll_suppress_count (catch->poll_suppress_count); |
set_poll_suppress_count (catch->poll_suppress_count); |
1220 |
|
interrupt_input_blocked = catch->interrupt_input_blocked; |
1221 |
|
|
1222 |
do |
do |
1223 |
{ |
{ |
1241 |
#endif |
#endif |
1242 |
backtrace_list = catch->backlist; |
backtrace_list = catch->backlist; |
1243 |
lisp_eval_depth = catch->lisp_eval_depth; |
lisp_eval_depth = catch->lisp_eval_depth; |
1244 |
|
|
1245 |
_longjmp (catch->jmp, 1); |
_longjmp (catch->jmp, 1); |
1246 |
} |
} |
1247 |
|
|
1276 |
Lisp_Object args; |
Lisp_Object args; |
1277 |
{ |
{ |
1278 |
Lisp_Object val; |
Lisp_Object val; |
1279 |
int count = specpdl_ptr - specpdl; |
int count = SPECPDL_INDEX (); |
1280 |
|
|
1281 |
record_unwind_protect (0, Fcdr (args)); |
record_unwind_protect (0, Fcdr (args)); |
1282 |
val = Feval (Fcar (args)); |
val = Feval (Fcar (args)); |
1283 |
return unbind_to (count, val); |
return unbind_to (count, val); |
1284 |
} |
} |
1285 |
|
|
1286 |
/* Chain of condition handlers currently in effect. |
/* Chain of condition handlers currently in effect. |
1342 |
c.backlist = backtrace_list; |
c.backlist = backtrace_list; |
1343 |
c.handlerlist = handlerlist; |
c.handlerlist = handlerlist; |
1344 |
c.lisp_eval_depth = lisp_eval_depth; |
c.lisp_eval_depth = lisp_eval_depth; |
1345 |
c.pdlcount = specpdl_ptr - specpdl; |
c.pdlcount = SPECPDL_INDEX (); |
1346 |
c.poll_suppress_count = poll_suppress_count; |
c.poll_suppress_count = poll_suppress_count; |
1347 |
|
c.interrupt_input_blocked = interrupt_input_blocked; |
1348 |
c.gcpro = gcprolist; |
c.gcpro = gcprolist; |
1349 |
c.byte_stack = byte_stack_list; |
c.byte_stack = byte_stack_list; |
1350 |
if (_setjmp (c.jmp)) |
if (_setjmp (c.jmp)) |
1361 |
} |
} |
1362 |
c.next = catchlist; |
c.next = catchlist; |
1363 |
catchlist = &c; |
catchlist = &c; |
1364 |
|
|
1365 |
h.var = var; |
h.var = var; |
1366 |
h.handler = handlers; |
h.handler = handlers; |
1367 |
h.next = handlerlist; |
h.next = handlerlist; |
1394 |
struct catchtag c; |
struct catchtag c; |
1395 |
struct handler h; |
struct handler h; |
1396 |
|
|
1397 |
#if 0 /* Can't do this check anymore because realize_basic_faces has |
#if 0 /* We now handle interrupt_input_blocked properly. |
1398 |
to BLOCK_INPUT, and can call Lisp. What's really needed is a |
What we still do not handle is exiting a signal handler. */ |
|
flag indicating that we're currently handling a signal. */ |
|
|
/* Since Fsignal resets this to 0, it had better be 0 now |
|
|
or else we have a potential bug. */ |
|
|
if (interrupt_input_blocked != 0) |
|
1399 |
abort (); |
abort (); |
1400 |
#endif |
#endif |
1401 |
|
|
1404 |
c.backlist = backtrace_list; |
c.backlist = backtrace_list; |
1405 |
c.handlerlist = handlerlist; |
c.handlerlist = handlerlist; |
1406 |
c.lisp_eval_depth = lisp_eval_depth; |
c.lisp_eval_depth = lisp_eval_depth; |
1407 |
c.pdlcount = specpdl_ptr - specpdl; |
c.pdlcount = SPECPDL_INDEX (); |
1408 |
c.poll_suppress_count = poll_suppress_count; |
c.poll_suppress_count = poll_suppress_count; |
1409 |
|
c.interrupt_input_blocked = interrupt_input_blocked; |
1410 |
c.gcpro = gcprolist; |
c.gcpro = gcprolist; |
1411 |
c.byte_stack = byte_stack_list; |
c.byte_stack = byte_stack_list; |
1412 |
if (_setjmp (c.jmp)) |
if (_setjmp (c.jmp)) |
1427 |
return val; |
return val; |
1428 |
} |
} |
1429 |
|
|
1430 |
/* Like internal_condition_case but call HFUN with ARG as its argument. */ |
/* Like internal_condition_case but call BFUN with ARG as its argument. */ |
1431 |
|
|
1432 |
Lisp_Object |
Lisp_Object |
1433 |
internal_condition_case_1 (bfun, arg, handlers, hfun) |
internal_condition_case_1 (bfun, arg, handlers, hfun) |
1445 |
c.backlist = backtrace_list; |
c.backlist = backtrace_list; |
1446 |
c.handlerlist = handlerlist; |
c.handlerlist = handlerlist; |
1447 |
c.lisp_eval_depth = lisp_eval_depth; |
c.lisp_eval_depth = lisp_eval_depth; |
1448 |
c.pdlcount = specpdl_ptr - specpdl; |
c.pdlcount = SPECPDL_INDEX (); |
1449 |
c.poll_suppress_count = poll_suppress_count; |
c.poll_suppress_count = poll_suppress_count; |
1450 |
|
c.interrupt_input_blocked = interrupt_input_blocked; |
1451 |
c.gcpro = gcprolist; |
c.gcpro = gcprolist; |
1452 |
c.byte_stack = byte_stack_list; |
c.byte_stack = byte_stack_list; |
1453 |
if (_setjmp (c.jmp)) |
if (_setjmp (c.jmp)) |
1469 |
} |
} |
1470 |
|
|
1471 |
|
|
1472 |
/* Like internal_condition_case but call HFUN with NARGS as first, |
/* Like internal_condition_case but call BFUN with NARGS as first, |
1473 |
and ARGS as second argument. */ |
and ARGS as second argument. */ |
1474 |
|
|
1475 |
Lisp_Object |
Lisp_Object |
1489 |
c.backlist = backtrace_list; |
c.backlist = backtrace_list; |
1490 |
c.handlerlist = handlerlist; |
c.handlerlist = handlerlist; |
1491 |
c.lisp_eval_depth = lisp_eval_depth; |
c.lisp_eval_depth = lisp_eval_depth; |
1492 |
c.pdlcount = specpdl_ptr - specpdl; |
c.pdlcount = SPECPDL_INDEX (); |
1493 |
c.poll_suppress_count = poll_suppress_count; |
c.poll_suppress_count = poll_suppress_count; |
1494 |
|
c.interrupt_input_blocked = interrupt_input_blocked; |
1495 |
c.gcpro = gcprolist; |
c.gcpro = gcprolist; |
1496 |
c.byte_stack = byte_stack_list; |
c.byte_stack = byte_stack_list; |
1497 |
if (_setjmp (c.jmp)) |
if (_setjmp (c.jmp)) |
1533 |
Lisp_Object error_symbol, data; |
Lisp_Object error_symbol, data; |
1534 |
{ |
{ |
1535 |
/* When memory is full, ERROR-SYMBOL is nil, |
/* When memory is full, ERROR-SYMBOL is nil, |
1536 |
and DATA is (REAL-ERROR-SYMBOL . REAL-DATA). */ |
and DATA is (REAL-ERROR-SYMBOL . REAL-DATA). |
1537 |
|
That is a special case--don't do this in other situations. */ |
1538 |
register struct handler *allhandlers = handlerlist; |
register struct handler *allhandlers = handlerlist; |
1539 |
Lisp_Object conditions; |
Lisp_Object conditions; |
1540 |
extern int gc_in_progress; |
extern int gc_in_progress; |
1548 |
if (gc_in_progress || waiting_for_input) |
if (gc_in_progress || waiting_for_input) |
1549 |
abort (); |
abort (); |
1550 |
|
|
|
TOTALLY_UNBLOCK_INPUT; |
|
|
|
|
1551 |
if (NILP (error_symbol)) |
if (NILP (error_symbol)) |
1552 |
real_error_symbol = Fcar (data); |
real_error_symbol = Fcar (data); |
1553 |
else |
else |
1554 |
real_error_symbol = error_symbol; |
real_error_symbol = error_symbol; |
1555 |
|
|
1556 |
|
#if 0 /* rms: I don't know why this was here, |
1557 |
|
but it is surely wrong for an error that is handled. */ |
1558 |
#ifdef HAVE_X_WINDOWS |
#ifdef HAVE_X_WINDOWS |
1559 |
if (display_hourglass_p) |
if (display_hourglass_p) |
1560 |
cancel_hourglass (); |
cancel_hourglass (); |
1561 |
#endif |
#endif |
1562 |
|
#endif |
1563 |
|
|
1564 |
/* This hook is used by edebug. */ |
/* This hook is used by edebug. */ |
1565 |
if (! NILP (Vsignal_hook_function)) |
if (! NILP (Vsignal_hook_function) |
1566 |
|
&& ! NILP (error_symbol)) |
1567 |
call2 (Vsignal_hook_function, error_symbol, data); |
call2 (Vsignal_hook_function, error_symbol, data); |
1568 |
|
|
1569 |
conditions = Fget (real_error_symbol, Qerror_conditions); |
conditions = Fget (real_error_symbol, Qerror_conditions); |
1570 |
|
|
1571 |
/* Remember from where signal was called. Skip over the frame for |
/* Remember from where signal was called. Skip over the frame for |
1572 |
`signal' itself. If a frame for `error' follows, skip that, |
`signal' itself. If a frame for `error' follows, skip that, |
1573 |
too. */ |
too. Don't do this when ERROR_SYMBOL is nil, because that |
1574 |
|
is a memory-full error. */ |
1575 |
Vsignaling_function = Qnil; |
Vsignaling_function = Qnil; |
1576 |
if (backtrace_list) |
if (backtrace_list && !NILP (error_symbol)) |
1577 |
{ |
{ |
1578 |
bp = backtrace_list->next; |
bp = backtrace_list->next; |
1579 |
if (bp && bp->function && EQ (*bp->function, Qerror)) |
if (bp && bp->function && EQ (*bp->function, Qerror)) |
1585 |
for (; handlerlist; handlerlist = handlerlist->next) |
for (; handlerlist; handlerlist = handlerlist->next) |
1586 |
{ |
{ |
1587 |
register Lisp_Object clause; |
register Lisp_Object clause; |
1588 |
|
|
1589 |
if (lisp_eval_depth + 20 > max_lisp_eval_depth) |
if (lisp_eval_depth + 20 > max_lisp_eval_depth) |
1590 |
max_lisp_eval_depth = lisp_eval_depth + 20; |
max_lisp_eval_depth = lisp_eval_depth + 20; |
1591 |
|
|
1592 |
if (specpdl_size + 40 > max_specpdl_size) |
if (specpdl_size + 40 > max_specpdl_size) |
1593 |
max_specpdl_size = specpdl_size + 40; |
max_specpdl_size = specpdl_size + 40; |
1594 |
|
|
1595 |
clause = find_handler_clause (handlerlist->handler, conditions, |
clause = find_handler_clause (handlerlist->handler, conditions, |
1596 |
error_symbol, data, &debugger_value); |
error_symbol, data, &debugger_value); |
1597 |
|
|
|
#if 0 /* Most callers are not prepared to handle gc if this returns. |
|
|
So, since this feature is not very useful, take it out. */ |
|
|
/* If have called debugger and user wants to continue, |
|
|
just return nil. */ |
|
|
if (EQ (clause, Qlambda)) |
|
|
return debugger_value; |
|
|
#else |
|
1598 |
if (EQ (clause, Qlambda)) |
if (EQ (clause, Qlambda)) |
1599 |
{ |
{ |
1600 |
/* We can't return values to code which signaled an error, but we |
/* We can't return values to code which signaled an error, but we |
1604 |
else |
else |
1605 |
error ("Cannot return from the debugger in an error"); |
error ("Cannot return from the debugger in an error"); |
1606 |
} |
} |
|
#endif |
|
1607 |
|
|
1608 |
if (!NILP (clause)) |
if (!NILP (clause)) |
1609 |
{ |
{ |
1632 |
data = Fcons (error_symbol, data); |
data = Fcons (error_symbol, data); |
1633 |
|
|
1634 |
string = Ferror_message_string (data); |
string = Ferror_message_string (data); |
1635 |
fatal ("%s", XSTRING (string)->data, 0); |
fatal ("%s", SDATA (string), 0); |
1636 |
} |
} |
1637 |
|
|
1638 |
/* Return nonzero iff LIST is a non-nil atom or |
/* Return nonzero iff LIST is a non-nil atom or |
1681 |
error_message = Ferror_message_string (data); |
error_message = Ferror_message_string (data); |
1682 |
first_string = 0; |
first_string = 0; |
1683 |
} |
} |
1684 |
|
|
1685 |
if (fast_string_match (XCAR (tail), error_message) >= 0) |
if (fast_string_match (XCAR (tail), error_message) >= 0) |
1686 |
return 1; |
return 1; |
1687 |
} |
} |
1722 |
|| !NILP (Vdebug_on_signal)) /* This says call debugger even if |
|| !NILP (Vdebug_on_signal)) /* This says call debugger even if |
1723 |
there is a handler. */ |
there is a handler. */ |
1724 |
{ |
{ |
1725 |
int count = specpdl_ptr - specpdl; |
int count = SPECPDL_INDEX (); |
1726 |
int debugger_called = 0; |
int debugger_called = 0; |
1727 |
Lisp_Object sig_symbol, combined_data; |
Lisp_Object sig_symbol, combined_data; |
1728 |
/* This is set to 1 if we are handling a memory-full error, |
/* This is set to 1 if we are handling a memory-full error, |
1990 |
do_autoload (fundef, funname) |
do_autoload (fundef, funname) |
1991 |
Lisp_Object fundef, funname; |
Lisp_Object fundef, funname; |
1992 |
{ |
{ |
1993 |
int count = specpdl_ptr - specpdl; |
int count = SPECPDL_INDEX (); |
1994 |
Lisp_Object fun, queue, first, second; |
Lisp_Object fun, queue, first, second; |
1995 |
struct gcpro gcpro1, gcpro2, gcpro3; |
struct gcpro gcpro1, gcpro2, gcpro3; |
1996 |
|
|
1998 |
of what files are preloaded and when. */ |
of what files are preloaded and when. */ |
1999 |
if (! NILP (Vpurify_flag)) |
if (! NILP (Vpurify_flag)) |
2000 |
error ("Attempt to autoload %s while preparing to dump", |
error ("Attempt to autoload %s while preparing to dump", |
2001 |
XSTRING (SYMBOL_NAME (funname))->data); |
SDATA (SYMBOL_NAME (funname))); |
2002 |
|
|
2003 |
fun = funname; |
fun = funname; |
2004 |
CHECK_SYMBOL (funname); |
CHECK_SYMBOL (funname); |
2006 |
|
|
2007 |
/* Preserve the match data. */ |
/* Preserve the match data. */ |
2008 |
record_unwind_protect (Fset_match_data, Fmatch_data (Qnil, Qnil)); |
record_unwind_protect (Fset_match_data, Fmatch_data (Qnil, Qnil)); |
2009 |
|
|
2010 |
/* Value saved here is to be restored into Vautoload_queue. */ |
/* Value saved here is to be restored into Vautoload_queue. */ |
2011 |
record_unwind_protect (un_autoload, Vautoload_queue); |
record_unwind_protect (un_autoload, Vautoload_queue); |
2012 |
Vautoload_queue = Qt; |
Vautoload_queue = Qt; |
2037 |
|
|
2038 |
if (!NILP (Fequal (fun, fundef))) |
if (!NILP (Fequal (fun, fundef))) |
2039 |
error ("Autoloading failed to define function %s", |
error ("Autoloading failed to define function %s", |
2040 |
XSTRING (SYMBOL_NAME (funname))->data); |
SDATA (SYMBOL_NAME (funname))); |
2041 |
UNGCPRO; |
UNGCPRO; |
2042 |
} |
} |
2043 |
|
|
2054 |
|
|
2055 |
if (handling_signal) |
if (handling_signal) |
2056 |
abort (); |
abort (); |
2057 |
|
|
2058 |
if (SYMBOLP (form)) |
if (SYMBOLP (form)) |
2059 |
{ |
{ |
2060 |
if (!NILP (Vinternal_interpreter_environment) |
if (!NILP (Vinternal_interpreter_environment) |
2255 |
if (backtrace.debug_on_exit) |
if (backtrace.debug_on_exit) |
2256 |
val = call_debugger (Fcons (Qexit, Fcons (val, Qnil))); |
val = call_debugger (Fcons (Qexit, Fcons (val, Qnil))); |
2257 |
backtrace_list = backtrace.next; |
backtrace_list = backtrace.next; |
2258 |
|
|
2259 |
|
#ifdef HAVE_CARBON |
2260 |
|
mac_check_for_quit_char(); |
2261 |
|
#endif |
2262 |
return val; |
return val; |
2263 |
} |
} |
2264 |
|
|
2281 |
funcall_args = 0; |
funcall_args = 0; |
2282 |
spread_arg = args [nargs - 1]; |
spread_arg = args [nargs - 1]; |
2283 |
CHECK_LIST (spread_arg); |
CHECK_LIST (spread_arg); |
2284 |
|
|
2285 |
numargs = XINT (Flength (spread_arg)); |
numargs = XINT (Flength (spread_arg)); |
2286 |
|
|
2287 |
if (numargs == 0) |
if (numargs == 0) |
2376 |
|
|
2377 |
return Qnil; |
return Qnil; |
2378 |
} |
} |
2379 |
|
|
2380 |
DEFUN ("run-hook-with-args", Frun_hook_with_args, |
DEFUN ("run-hook-with-args", Frun_hook_with_args, |
2381 |
Srun_hook_with_args, 1, MANY, 0, |
Srun_hook_with_args, 1, MANY, 0, |
2382 |
doc: /* Run HOOK with the specified arguments ARGS. |
doc: /* Run HOOK with the specified arguments ARGS. |
2619 |
{ |
{ |
2620 |
struct gcpro gcpro1; |
struct gcpro gcpro1; |
2621 |
#ifdef NO_ARG_ARRAY |
#ifdef NO_ARG_ARRAY |
2622 |
Lisp_Object args[2]; |
Lisp_Object args[2]; |
2623 |
|
|
2624 |
args[0] = fn; |
args[0] = fn; |
2625 |
args[1] = arg1; |
args[1] = arg1; |
2916 |
default: |
default: |
2917 |
|
|
2918 |
/* If a subr takes more than 8 arguments without using MANY |
/* If a subr takes more than 8 arguments without using MANY |
2919 |
or UNEVALLED, we need to extend this function to support it. |
or UNEVALLED, we need to extend this function to support it. |
2920 |
Until this is done, there is no way to call the function. */ |
Until this is done, there is no way to call the function. */ |
2921 |
abort (); |
abort (); |
2922 |
} |
} |
3028 |
Lisp_Object lexenv; |
Lisp_Object lexenv; |
3029 |
{ |
{ |
3030 |
Lisp_Object val, syms_left, next; |
Lisp_Object val, syms_left, next; |
3031 |
int count = specpdl_ptr - specpdl; |
int count = SPECPDL_INDEX (); |
3032 |
int i, optional, rest; |
int i, optional, rest; |
3033 |
|
|
3034 |
if (COMPILEDP (fun) |
if (COMPILEDP (fun) |
3071 |
for (; CONSP (syms_left); syms_left = XCDR (syms_left)) |
for (; CONSP (syms_left); syms_left = XCDR (syms_left)) |
3072 |
{ |
{ |
3073 |
QUIT; |
QUIT; |
3074 |
|
|
3075 |
next = XCAR (syms_left); |
next = XCAR (syms_left); |
3076 |
while (!SYMBOLP (next)) |
while (!SYMBOLP (next)) |
3077 |
next = Fsignal (Qinvalid_function, Fcons (fun, Qnil)); |
next = Fsignal (Qinvalid_function, Fcons (fun, Qnil)); |
3078 |
|
|
3079 |
if (EQ (next, Qand_rest)) |
if (EQ (next, Qand_rest)) |
3080 |
rest = 1; |
rest = 1; |
3081 |
else if (EQ (next, Qand_optional)) |
else if (EQ (next, Qand_optional)) |
3132 |
AREF (fun, COMPILED_STACK_DEPTH), |
AREF (fun, COMPILED_STACK_DEPTH), |
3133 |
Qnil, 0, 0); |
Qnil, 0, 0); |
3134 |
} |
} |
3135 |
|
|
3136 |
return unbind_to (count, val); |
return unbind_to (count, val); |
3137 |
} |
} |
3138 |
|
|
3151 |
{ |
{ |
3152 |
tem = AREF (object, COMPILED_BYTECODE); |
tem = AREF (object, COMPILED_BYTECODE); |
3153 |
if (CONSP (tem) && STRINGP (XCAR (tem))) |
if (CONSP (tem) && STRINGP (XCAR (tem))) |
3154 |
error ("Invalid byte code in %s", XSTRING (XCAR (tem))->data); |
error ("Invalid byte code in %s", SDATA (XCAR (tem))); |
3155 |
else |
else |
3156 |
error ("Invalid byte code"); |
error ("Invalid byte code"); |
3157 |
} |
} |
3164 |
void |
void |
3165 |
grow_specpdl () |
grow_specpdl () |
3166 |
{ |
{ |
3167 |
register int count = specpdl_ptr - specpdl; |
register int count = SPECPDL_INDEX (); |
3168 |
if (specpdl_size >= max_specpdl_size) |
if (specpdl_size >= max_specpdl_size) |
3169 |
{ |
{ |
3170 |
if (max_specpdl_size < 400) |
if (max_specpdl_size < 400) |
3210 |
else |
else |
3211 |
{ |
{ |
3212 |
Lisp_Object valcontents; |
Lisp_Object valcontents; |
3213 |
|
|
3214 |
ovalue = find_symbol_value (symbol); |
ovalue = find_symbol_value (symbol); |
3215 |
specpdl_ptr->func = 0; |
specpdl_ptr->func = 0; |
3216 |
specpdl_ptr->old_value = ovalue; |
specpdl_ptr->old_value = ovalue; |
3224 |
Lisp_Object where, current_buffer; |
Lisp_Object where, current_buffer; |
3225 |
|
|
3226 |
current_buffer = Fcurrent_buffer (); |
current_buffer = Fcurrent_buffer (); |
3227 |
|
|
3228 |
/* For a local variable, record both the symbol and which |
/* For a local variable, record both the symbol and which |
3229 |
buffer's or frame's value we are saving. */ |
buffer's or frame's value we are saving. */ |
3230 |
if (!NILP (Flocal_variable_p (symbol, Qnil))) |
if (!NILP (Flocal_variable_p (symbol, Qnil))) |
3316 |
Fset_default (symbol, specpdl_ptr->old_value); |
Fset_default (symbol, specpdl_ptr->old_value); |
3317 |
else if (BUFFERP (where)) |
else if (BUFFERP (where)) |
3318 |
set_internal (symbol, specpdl_ptr->old_value, XBUFFER (where), 1); |
set_internal (symbol, specpdl_ptr->old_value, XBUFFER (where), 1); |
3319 |
else |
else |
3320 |
set_internal (symbol, specpdl_ptr->old_value, NULL, 1); |
set_internal (symbol, specpdl_ptr->old_value, NULL, 1); |
3321 |
} |
} |
3322 |
else |
else |
3330 |
set_internal (specpdl_ptr->symbol, specpdl_ptr->old_value, 0, 1); |
set_internal (specpdl_ptr->symbol, specpdl_ptr->old_value, 0, 1); |
3331 |
} |
} |
3332 |
} |
} |
3333 |
|
|
3334 |
if (NILP (Vquit_flag) && quitf) |
if (NILP (Vquit_flag) && quitf) |
3335 |
Vquit_flag = Qt; |
Vquit_flag = Qt; |
3336 |
|
|
3528 |
|
|
3529 |
Qdeclare = intern ("declare"); |
Qdeclare = intern ("declare"); |
3530 |
staticpro (&Qdeclare); |
staticpro (&Qdeclare); |
3531 |
|
|
3532 |
/* Note that the process handling also uses Qexit, but we don't want |
/* Note that the process handling also uses Qexit, but we don't want |
3533 |
to staticpro it twice, so we just do it here. */ |
to staticpro it twice, so we just do it here. */ |
3534 |
Qexit = intern ("exit"); |
Qexit = intern ("exit"); |
3543 |
Qdefun = intern ("defun"); |
Qdefun = intern ("defun"); |
3544 |
staticpro (&Qdefun); |
staticpro (&Qdefun); |
3545 |
|
|
3546 |
|
Qdefvar = intern ("defvar"); |
3547 |
|
staticpro (&Qdefvar); |
3548 |
|
|
3549 |
Qand_rest = intern ("&rest"); |
Qand_rest = intern ("&rest"); |
3550 |
staticpro (&Qand_rest); |
staticpro (&Qand_rest); |
3551 |
|
|