X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=src%2Feval.c;h=4ac9537a11d0f4d900d7d0b0bb2f02149d873a67;hb=864447fd568460861c031507187fc08f09a588e3;hp=cd288277e1642b1b2db1a44aa866860cd35e4af9;hpb=6883ee56ec887c2c48abe5b06b5e66aa74031910;p=chise%2Fxemacs-chise.git.1 diff --git a/src/eval.c b/src/eval.c index cd28827..4ac9537 100644 --- a/src/eval.c +++ b/src/eval.c @@ -1,6 +1,7 @@ /* Evaluator for XEmacs Lisp interpreter. Copyright (C) 1985-1987, 1992-1994 Free Software Foundation, Inc. Copyright (C) 1995 Sun Microsystems, Inc. + Copyright (C) 2000 Ben Wing. This file is part of XEmacs. @@ -21,10 +22,6 @@ Boston, MA 02111-1307, USA. */ /* Synched up with: FSF 19.30 (except for Fsignal), Mule 2.0. */ -/* Debugging hack */ -int always_gc; - - #include #include "lisp.h" @@ -35,17 +32,67 @@ int always_gc; #include "console.h" #include "opaque.h" +#ifdef ERROR_CHECK_GC +int always_gc; /* Debugging hack */ +#else +#define always_gc 0 +#endif + struct backtrace *backtrace_list; -/* Note you must always fill all of the fields in a backtrace structure +/* Note: you must always fill in all of the fields in a backtrace structure before pushing them on the backtrace_list. The profiling code depends on this. */ -#define PUSH_BACKTRACE(bt) \ - do { (bt).next = backtrace_list; backtrace_list = &(bt); } while (0) +#define PUSH_BACKTRACE(bt) do { \ + (bt).next = backtrace_list; \ + backtrace_list = &(bt); \ +} while (0) + +#define POP_BACKTRACE(bt) do { \ + backtrace_list = (bt).next; \ +} while (0) + +/* Macros for calling subrs with an argument list whose length is only + known at runtime. See EXFUN and DEFUN for similar hackery. */ + +#define AV_0(av) +#define AV_1(av) av[0] +#define AV_2(av) AV_1(av), av[1] +#define AV_3(av) AV_2(av), av[2] +#define AV_4(av) AV_3(av), av[3] +#define AV_5(av) AV_4(av), av[4] +#define AV_6(av) AV_5(av), av[5] +#define AV_7(av) AV_6(av), av[6] +#define AV_8(av) AV_7(av), av[7] + +#define PRIMITIVE_FUNCALL_1(fn, av, ac) \ + (((Lisp_Object (*)(EXFUN_##ac)) (fn)) (AV_##ac (av))) + +/* If subrs take more than 8 arguments, more cases need to be added + to this switch. (But wait - don't do it - if you really need + a SUBR with more than 8 arguments, use max_args == MANY. + See the DEFUN macro in lisp.h) */ +#define PRIMITIVE_FUNCALL(rv, fn, av, ac) do { \ + void (*PF_fn)(void) = (void (*)(void)) fn; \ + Lisp_Object *PF_av = (av); \ + switch (ac) \ + { \ + default:rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 0); break; \ + case 1: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 1); break; \ + case 2: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 2); break; \ + case 3: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 3); break; \ + case 4: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 4); break; \ + case 5: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 5); break; \ + case 6: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 6); break; \ + case 7: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 7); break; \ + case 8: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 8); break; \ + } \ +} while (0) + +#define FUNCALL_SUBR(rv, subr, av, ac) \ + PRIMITIVE_FUNCALL (rv, subr_function (subr), av, ac); -#define POP_BACKTRACE(bt) \ - do { backtrace_list = (bt).next; } while (0) /* This is the list of current catches (and also condition-cases). This is a stack: the most recent catch is at the head of the @@ -80,6 +127,7 @@ Lisp_Object Qrun_hooks; Lisp_Object Qsetq; Lisp_Object Qdisplay_warning; Lisp_Object Vpending_warnings, Vpending_warnings_tail; +Lisp_Object Qif; /* Records whether we want errors to occur. This will be a boolean, nil (errors OK) or t (no errors). If t, an error will cause a @@ -96,19 +144,14 @@ Lisp_Object Vcurrent_warning_class; /* Special catch tag used in call_with_suspended_errors(). */ Lisp_Object Qunbound_suspended_errors_tag; -/* Non-nil means we're going down, so we better not run any hooks - or do other non-essential stuff. */ -int preparing_for_armageddon; - /* Non-nil means record all fset's and provide's, to be undone if the file being autoloaded is not fully loaded. They are recorded by being consed onto the front of Vautoload_queue: (FUN . ODEF) for a defun, (OFEATURES . nil) for a provide. */ - Lisp_Object Vautoload_queue; /* Current number of specbindings allocated in specpdl. */ -static int specpdl_size; +int specpdl_size; /* Pointer to beginning of specpdl. */ struct specbinding *specpdl; @@ -116,18 +159,17 @@ struct specbinding *specpdl; /* Pointer to first unused element in specpdl. */ struct specbinding *specpdl_ptr; -/* specpdl_ptr - specpdl. Callers outside this file should use - * specpdl_depth () function-call */ -static int specpdl_depth_counter; +/* specpdl_ptr - specpdl */ +int specpdl_depth_counter; /* Maximum size allowed for specpdl allocation */ -int max_specpdl_size; +Fixnum max_specpdl_size; /* Depth in Lisp evaluations and function calls. */ -int lisp_eval_depth; +static int lisp_eval_depth; /* Maximum allowed depth in Lisp evaluations and function calls. */ -int max_lisp_eval_depth; +Fixnum max_lisp_eval_depth; /* Nonzero means enter debugger before next function call */ static int debug_on_next_call; @@ -221,95 +263,56 @@ Lisp_Object Vdebugger; */ static Lisp_Object Vcondition_handlers; + +#define DEFEND_AGAINST_THROW_RECURSION + +#ifdef DEFEND_AGAINST_THROW_RECURSION /* Used for error catching purposes by throw_or_bomb_out */ static int throw_level; +#endif -static Lisp_Object primitive_funcall (lisp_fn_t fn, int nargs, - Lisp_Object args[]); +#ifdef ERROR_CHECK_TYPECHECK +void check_error_state_sanity (void); +#endif -/**********************************************************************/ -/* The subr and compiled-function types */ -/**********************************************************************/ +/************************************************************************/ +/* The subr object type */ +/************************************************************************/ static void print_subr (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) { - struct Lisp_Subr *subr = XSUBR (obj); + Lisp_Subr *subr = XSUBR (obj); + const char *header = + (subr->max_args == UNEVALLED) ? "#prompt ? " (interactive)>" : ">"; if (print_readably) - error ("printing unreadable object #", - subr_name (subr)); + error ("printing unreadable object %s%s%s", header, name, trailer); - write_c_string (((subr->max_args == UNEVALLED) - ? "#prompt) ? " (interactive)>" : ">"), - printcharfun); + write_c_string (header, printcharfun); + write_c_string (name, printcharfun); + write_c_string (trailer, printcharfun); } -DEFINE_LRECORD_IMPLEMENTATION ("subr", subr, - this_one_is_unmarkable, print_subr, 0, 0, 0, - struct Lisp_Subr); - -static Lisp_Object -mark_compiled_function (Lisp_Object obj, void (*markobj) (Lisp_Object)) -{ - struct Lisp_Compiled_Function *b = XCOMPILED_FUNCTION (obj); - - ((markobj) (b->bytecodes)); - ((markobj) (b->arglist)); - ((markobj) (b->doc_and_interactive)); -#ifdef COMPILED_FUNCTION_ANNOTATION_HACK - ((markobj) (b->annotated)); -#endif - /* tail-recurse on constants */ - return b->constants; -} +static const struct lrecord_description subr_description[] = { + { XD_DOC_STRING, offsetof (Lisp_Subr, doc) }, + { XD_END } +}; -static int -compiled_function_equal (Lisp_Object o1, Lisp_Object o2, int depth) -{ - struct Lisp_Compiled_Function *b1 = XCOMPILED_FUNCTION (o1); - struct Lisp_Compiled_Function *b2 = XCOMPILED_FUNCTION (o2); - return - (b1->flags.documentationp == b2->flags.documentationp && - b1->flags.interactivep == b2->flags.interactivep && - b1->flags.domainp == b2->flags.domainp && /* I18N3 */ - internal_equal (b1->bytecodes, b2->bytecodes, depth + 1) && - internal_equal (b1->constants, b2->constants, depth + 1) && - internal_equal (b1->arglist, b2->arglist, depth + 1) && - internal_equal (b1->doc_and_interactive, - b2->doc_and_interactive, depth + 1)); -} - -static unsigned long -compiled_function_hash (Lisp_Object obj, int depth) -{ - struct Lisp_Compiled_Function *b = XCOMPILED_FUNCTION (obj); - return HASH3 ((b->flags.documentationp << 2) + - (b->flags.interactivep << 1) + - b->flags.domainp, - internal_hash (b->bytecodes, depth + 1), - internal_hash (b->constants, depth + 1)); -} - -DEFINE_BASIC_LRECORD_IMPLEMENTATION ("compiled-function", compiled_function, - mark_compiled_function, - print_compiled_function, 0, - compiled_function_equal, - compiled_function_hash, - struct Lisp_Compiled_Function); +DEFINE_BASIC_LRECORD_IMPLEMENTATION ("subr", subr, + 0, print_subr, 0, 0, 0, + subr_description, + Lisp_Subr); -/**********************************************************************/ -/* Entering the debugger */ -/**********************************************************************/ +/************************************************************************/ +/* Entering the debugger */ +/************************************************************************/ /* unwind-protect used by call_debugger() to restore the value of - enterring_debugger. (We cannot use specbind() because the + entering_debugger. (We cannot use specbind() because the variable is not Lisp-accessible.) */ static Lisp_Object @@ -337,12 +340,12 @@ call_debugger_259 (Lisp_Object arg) } /* Call the debugger, doing some encapsulation. We make sure we have - some room on the eval and specpdl stacks, and bind enterring_debugger + some room on the eval and specpdl stacks, and bind entering_debugger to 1 during this call. This is used to trap errors that may occur - when enterring the debugger (e.g. the value of `debugger' is invalid), + when entering the debugger (e.g. the value of `debugger' is invalid), so that the debugger will not be recursively entered if debug-on-error is set. (Otherwise, XEmacs would infinitely recurse, attempting to - enter the debugger.) enterring_debugger gets reset to 0 as soon + enter the debugger.) entering_debugger gets reset to 0 as soon as a backtrace is displayed, so that further errors can indeed be handled normally. @@ -383,7 +386,7 @@ call_debugger (Lisp_Object arg) max_specpdl_size = specpdl_size + 40; debug_on_next_call = 0; - speccount = specpdl_depth_counter; + speccount = specpdl_depth(); record_unwind_protect (restore_entering_debugger, (entering_debugger ? Qt : Qnil)); entering_debugger = 1; @@ -542,7 +545,7 @@ signal_call_debugger (Lisp_Object conditions, Lisp_Object val = Qunbound; Lisp_Object all_handlers = Vcondition_handlers; Lisp_Object temp_data = Qnil; - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); struct gcpro gcpro1, gcpro2; GCPRO2 (all_handlers, temp_data); @@ -554,15 +557,18 @@ signal_call_debugger (Lisp_Object conditions, && wants_debugger (Vstack_trace_on_error, conditions) && !skip_debugger (conditions, temp_data)) { - specbind (Qdebug_on_error, Qnil); - specbind (Qstack_trace_on_error, Qnil); - specbind (Qdebug_on_signal, Qnil); + specbind (Qdebug_on_error, Qnil); + specbind (Qstack_trace_on_error, Qnil); + specbind (Qdebug_on_signal, Qnil); specbind (Qstack_trace_on_signal, Qnil); - internal_with_output_to_temp_buffer ("*Backtrace*", - backtrace_259, - Qnil, - Qnil); + if (!noninteractive) + internal_with_output_to_temp_buffer (build_string ("*Backtrace*"), + backtrace_259, + Qnil, + Qnil); + else /* in batch mode, we want this going to stderr. */ + backtrace_259 (Qnil); unbind_to (speccount, Qnil); *stack_trace_displayed = 1; } @@ -574,9 +580,9 @@ signal_call_debugger (Lisp_Object conditions, && !skip_debugger (conditions, temp_data)) { debug_on_quit &= ~2; /* reset critical bit */ - specbind (Qdebug_on_error, Qnil); - specbind (Qstack_trace_on_error, Qnil); - specbind (Qdebug_on_signal, Qnil); + specbind (Qdebug_on_error, Qnil); + specbind (Qstack_trace_on_error, Qnil); + specbind (Qdebug_on_signal, Qnil); specbind (Qstack_trace_on_signal, Qnil); val = call_debugger (list2 (Qerror, (Fcons (sig, data)))); @@ -586,15 +592,18 @@ signal_call_debugger (Lisp_Object conditions, if (!entering_debugger && !*stack_trace_displayed && wants_debugger (Vstack_trace_on_signal, conditions)) { - specbind (Qdebug_on_error, Qnil); - specbind (Qstack_trace_on_error, Qnil); - specbind (Qdebug_on_signal, Qnil); + specbind (Qdebug_on_error, Qnil); + specbind (Qstack_trace_on_error, Qnil); + specbind (Qdebug_on_signal, Qnil); specbind (Qstack_trace_on_signal, Qnil); - internal_with_output_to_temp_buffer ("*Backtrace*", - backtrace_259, - Qnil, - Qnil); + if (!noninteractive) + internal_with_output_to_temp_buffer (build_string ("*Backtrace*"), + backtrace_259, + Qnil, + Qnil); + else /* in batch mode, we want this going to stderr. */ + backtrace_259 (Qnil); unbind_to (speccount, Qnil); *stack_trace_displayed = 1; } @@ -605,9 +614,9 @@ signal_call_debugger (Lisp_Object conditions, : wants_debugger (Vdebug_on_signal, conditions))) { debug_on_quit &= ~2; /* reset critical bit */ - specbind (Qdebug_on_error, Qnil); - specbind (Qstack_trace_on_error, Qnil); - specbind (Qdebug_on_signal, Qnil); + specbind (Qdebug_on_error, Qnil); + specbind (Qstack_trace_on_error, Qnil); + specbind (Qdebug_on_signal, Qnil); specbind (Qstack_trace_on_signal, Qnil); val = call_debugger (list2 (Qerror, (Fcons (sig, data)))); @@ -620,13 +629,12 @@ signal_call_debugger (Lisp_Object conditions, } -/**********************************************************************/ -/* The basic special forms */ -/**********************************************************************/ +/************************************************************************/ +/* The basic special forms */ +/************************************************************************/ -/* NOTE!!! Every function that can call EVAL must protect its args - and temporaries from garbage collection while it needs them. - The definition of `For' shows what you have to do. */ +/* Except for Fprogn(), the basic special forms below are only called + from interpreted code. The byte compiler turns them into bytecodes. */ DEFUN ("or", For, 0, UNEVALLED, 0, /* Eval args until one of them yields non-nil, then return that value. @@ -636,22 +644,14 @@ If all args return nil, return nil. (args)) { /* This function can GC */ - REGISTER Lisp_Object tail; - struct gcpro gcpro1; - - GCPRO1 (args); + REGISTER Lisp_Object val; - LIST_LOOP (tail, args) + LIST_LOOP_2 (arg, args) { - Lisp_Object val = Feval (XCAR (tail)); - if (!NILP (val)) - { - UNGCPRO; - return val; - } + if (!NILP (val = Feval (arg))) + return val; } - UNGCPRO; return Qnil; } @@ -663,19 +663,14 @@ If no arg yields nil, return the last arg's value. (args)) { /* This function can GC */ - REGISTER Lisp_Object tail, val = Qt; - struct gcpro gcpro1; - - GCPRO1 (args); + REGISTER Lisp_Object val = Qt; - LIST_LOOP (tail, args) + LIST_LOOP_2 (arg, args) { - val = Feval (XCAR (tail)); - if (NILP (val)) - break; + if (NILP (val = Feval (arg))) + return val; } - UNGCPRO; return val; } @@ -688,22 +683,51 @@ If COND yields nil, and there are no ELSE's, the value is nil. (args)) { /* This function can GC */ - Lisp_Object val; - struct gcpro gcpro1; - - GCPRO1 (args); + Lisp_Object condition = XCAR (args); + Lisp_Object then_form = XCAR (XCDR (args)); + Lisp_Object else_forms = XCDR (XCDR (args)); - if (!NILP (Feval (XCAR (args)))) - val = Feval (XCAR (XCDR ((args)))); + if (!NILP (Feval (condition))) + return Feval (then_form); else - val = Fprogn (XCDR (XCDR (args))); + return Fprogn (else_forms); +} - UNGCPRO; - return val; +/* Macros `when' and `unless' are trivially defined in Lisp, + but it helps for bootstrapping to have them ALWAYS defined. */ + +DEFUN ("when", Fwhen, 1, MANY, 0, /* +\(when COND BODY...): if COND yields non-nil, do BODY, else return nil. +BODY can be zero or more expressions. If BODY is nil, return nil. +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object cond = args[0]; + Lisp_Object body; + + switch (nargs) + { + case 1: body = Qnil; break; + case 2: body = args[1]; break; + default: body = Fcons (Qprogn, Flist (nargs-1, args+1)); break; + } + + return list3 (Qif, cond, body); +} + +DEFUN ("unless", Funless, 1, MANY, 0, /* +\(unless COND BODY...): if COND yields nil, do BODY, else return nil. +BODY can be zero or more expressions. If BODY is nil, return nil. +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object cond = args[0]; + Lisp_Object body = Flist (nargs-1, args+1); + return Fcons (Qif, Fcons (cond, Fcons (Qnil, body))); } DEFUN ("cond", Fcond, 0, UNEVALLED, 0, /* -(cond CLAUSES...): try each clause until one succeeds. +\(cond CLAUSES...): try each clause until one succeeds. Each clause looks like (CONDITION BODY...). CONDITION is evaluated and, if the value is non-nil, this clause succeeds: then the expressions in BODY are evaluated and the last one's @@ -715,30 +739,21 @@ CONDITION's value if non-nil is returned from the cond-form. (args)) { /* This function can GC */ - REGISTER Lisp_Object tail; - struct gcpro gcpro1; - - GCPRO1 (args); + REGISTER Lisp_Object val; - LIST_LOOP (tail, args) + LIST_LOOP_2 (clause, args) { - Lisp_Object val; - Lisp_Object clause = XCAR (tail); CHECK_CONS (clause); - val = Feval (XCAR (clause)); - if (!NILP (val)) + if (!NILP (val = Feval (XCAR (clause)))) { - Lisp_Object clause_tail = XCDR (clause); - if (!NILP (clause_tail)) + if (!NILP (clause = XCDR (clause))) { - CHECK_TRUE_LIST (clause_tail); - val = Fprogn (clause_tail); + CHECK_TRUE_LIST (clause); + val = Fprogn (clause); } - UNGCPRO; return val; } } - UNGCPRO; return Qnil; } @@ -749,61 +764,72 @@ DEFUN ("progn", Fprogn, 0, UNEVALLED, 0, /* (args)) { /* This function can GC */ - REGISTER Lisp_Object tail, val = Qnil; + /* Caller must provide a true list in ARGS */ + REGISTER Lisp_Object val = Qnil; struct gcpro gcpro1; GCPRO1 (args); - LIST_LOOP (tail, args) - val = Feval (XCAR (tail)); + { + LIST_LOOP_2 (form, args) + val = Feval (form); + } UNGCPRO; return val; } +/* Fprog1() is the canonical example of a function that must GCPRO a + Lisp_Object across calls to Feval(). */ + DEFUN ("prog1", Fprog1, 1, UNEVALLED, 0, /* -\(prog1 FIRST BODY...): eval FIRST and BODY sequentially; value from FIRST. -The value of FIRST is saved during the evaluation of the remaining args, +Similar to `progn', but the value of the first form is returned. +\(prog1 FIRST BODY...): All the arguments are evaluated sequentially. +The value of FIRST is saved during evaluation of the remaining args, whose values are discarded. */ (args)) { /* This function can GC */ - REGISTER Lisp_Object tail = args; - Lisp_Object val = Qnil; - struct gcpro gcpro1, gcpro2; + REGISTER Lisp_Object val; + struct gcpro gcpro1; - GCPRO2 (args, val); + val = Feval (XCAR (args)); - val = Feval (XCAR (tail)); + GCPRO1 (val); - LIST_LOOP (tail, XCDR (tail)) - Feval (XCAR (tail)); + { + LIST_LOOP_2 (form, XCDR (args)) + Feval (form); + } UNGCPRO; return val; } DEFUN ("prog2", Fprog2, 2, UNEVALLED, 0, /* -\(prog2 X Y BODY...): eval X, Y and BODY sequentially; value from Y. -The value of Y is saved during the evaluation of the remaining args, +Similar to `progn', but the value of the second form is returned. +\(prog2 FIRST SECOND BODY...): All the arguments are evaluated sequentially. +The value of SECOND is saved during evaluation of the remaining args, whose values are discarded. */ (args)) { /* This function can GC */ - REGISTER Lisp_Object tail = args; - Lisp_Object val = Qnil; - struct gcpro gcpro1, gcpro2; + REGISTER Lisp_Object val; + struct gcpro gcpro1; - GCPRO2 (args, val); + Feval (XCAR (args)); + args = XCDR (args); + val = Feval (XCAR (args)); + args = XCDR (args); - Feval (XCAR (tail)); - tail = XCDR (tail); - val = Feval (XCAR (tail)); + GCPRO1 (val); - LIST_LOOP (tail, XCDR (tail)) - Feval (XCAR (tail)); + { + LIST_LOOP_2 (form, args) + Feval (form); + } UNGCPRO; return val; @@ -820,41 +846,33 @@ Each VALUEFORM can refer to the symbols already bound by this VARLIST. { /* This function can GC */ Lisp_Object varlist = XCAR (args); - Lisp_Object tail; - int speccount = specpdl_depth_counter; - struct gcpro gcpro1; - - GCPRO1 (args); + Lisp_Object body = XCDR (args); + int speccount = specpdl_depth(); - EXTERNAL_LIST_LOOP (tail, varlist) + EXTERNAL_LIST_LOOP_3 (var, varlist, tail) { - Lisp_Object elt = XCAR (tail); - QUIT; - if (SYMBOLP (elt)) - specbind (elt, Qnil); + Lisp_Object symbol, value, tem; + if (SYMBOLP (var)) + symbol = var, value = Qnil; else { - Lisp_Object sym, form; - CHECK_CONS (elt); - sym = XCAR (elt); - elt = XCDR (elt); - if (NILP (elt)) - form = Qnil; + CHECK_CONS (var); + symbol = XCAR (var); + tem = XCDR (var); + if (NILP (tem)) + value = Qnil; else { - CHECK_CONS (elt); - form = XCAR (elt); - elt = XCDR (elt); - if (!NILP (elt)) + CHECK_CONS (tem); + value = Feval (XCAR (tem)); + if (!NILP (XCDR (tem))) signal_simple_error - ("`let' bindings can have only one value-form", - XCAR (tail)); + ("`let' bindings can have only one value-form", var); } - specbind (sym, Feval (form)); } + specbind (symbol, value); } - UNGCPRO; - return unbind_to (speccount, Fprogn (XCDR (args))); + return unbind_to (speccount, Fprogn (body)); } DEFUN ("let", Flet, 1, UNEVALLED, 0, /* @@ -868,60 +886,62 @@ All the VALUEFORMs are evalled before any symbols are bound. { /* This function can GC */ Lisp_Object varlist = XCAR (args); - REGISTER Lisp_Object tail; + Lisp_Object body = XCDR (args); + int speccount = specpdl_depth(); Lisp_Object *temps; - int speccount = specpdl_depth_counter; - REGISTER int argnum = 0; - struct gcpro gcpro1, gcpro2; + int idx; + struct gcpro gcpro1; /* Make space to hold the values to give the bound variables. */ { - int varcount = 0; - EXTERNAL_LIST_LOOP (tail, varlist) - varcount++; + int varcount; + GET_EXTERNAL_LIST_LENGTH (varlist, varcount); temps = alloca_array (Lisp_Object, varcount); } /* Compute the values and store them in `temps' */ + GCPRO1 (*temps); + gcpro1.nvars = 0; - GCPRO2 (args, *temps); - gcpro2.nvars = 0; + idx = 0; + { + LIST_LOOP_2 (var, varlist) + { + Lisp_Object *value = &temps[idx++]; + if (SYMBOLP (var)) + *value = Qnil; + else + { + Lisp_Object tem; + CHECK_CONS (var); + tem = XCDR (var); + if (NILP (tem)) + *value = Qnil; + else + { + CHECK_CONS (tem); + *value = Feval (XCAR (tem)); + gcpro1.nvars = idx; + + if (!NILP (XCDR (tem))) + signal_simple_error + ("`let' bindings can have only one value-form", var); + } + } + } + } - LIST_LOOP (tail, varlist) - { - Lisp_Object elt = XCAR (tail); - QUIT; - if (SYMBOLP (elt)) - temps[argnum++] = Qnil; - else - { - CHECK_CONS (elt); - elt = XCDR (elt); - if (NILP (elt)) - temps[argnum++] = Qnil; - else - { - CHECK_CONS (elt); - temps[argnum++] = Feval (XCAR (elt)); - gcpro2.nvars = argnum; + idx = 0; + { + LIST_LOOP_2 (var, varlist) + { + specbind (SYMBOLP (var) ? var : XCAR (var), temps[idx++]); + } + } - if (!NILP (XCDR (elt))) - signal_simple_error - ("`let' bindings can have only one value-form", - XCAR (tail)); - } - } - } UNGCPRO; - argnum = 0; - LIST_LOOP (tail, varlist) - { - Lisp_Object elt = XCAR (tail); - specbind (SYMBOLP (elt) ? elt : XCAR (elt), temps[argnum++]); - } - - return unbind_to (speccount, Fprogn (XCDR (args))); + return unbind_to (speccount, Fprogn (body)); } DEFUN ("while", Fwhile, 1, UNEVALLED, 0, /* @@ -932,20 +952,15 @@ until TEST returns nil. (args)) { /* This function can GC */ - Lisp_Object tem; Lisp_Object test = XCAR (args); Lisp_Object body = XCDR (args); - struct gcpro gcpro1, gcpro2; - GCPRO2 (test, body); - - while (tem = Feval (test), !NILP (tem)) + while (!NILP (Feval (test))) { QUIT; Fprogn (body); } - UNGCPRO; return Qnil; } @@ -961,34 +976,21 @@ The return value of the `setq' form is the value of the last VAL. (args)) { /* This function can GC */ + Lisp_Object symbol, tail, val = Qnil; + int nargs; struct gcpro gcpro1; - Lisp_Object val = Qnil; - GCPRO1 (args); + GET_LIST_LENGTH (args, nargs); - { - REGISTER int i = 0; - Lisp_Object args2; - for (args2 = args; !NILP (args2); args2 = XCDR (args2)) - { - i++; - /* - * uncomment the QUIT if there is some way a circular - * arglist can get in here. I think Feval or Fapply would - * spin first and the list would never get here. - */ - /* QUIT; */ - } - if (i & 1) /* Odd number of arguments? */ - Fsignal (Qwrong_number_of_arguments, list2 (Qsetq, make_int(i))); - } + if (nargs & 1) /* Odd number of arguments? */ + Fsignal (Qwrong_number_of_arguments, list2 (Qsetq, make_int (nargs))); - while (!NILP (args)) + GCPRO1 (val); + + PROPERTY_LIST_LOOP (tail, symbol, val, args) { - Lisp_Object sym = XCAR (args); - val = Feval (XCAR (XCDR (args))); - Fset (sym, val); - args = XCDR (XCDR (args)); + val = Feval (val); + Fset (symbol, val); } UNGCPRO; @@ -1014,9 +1016,16 @@ In byte compilation, `function' causes its argument to be compiled. } -/**********************************************************************/ -/* Defining functions/variables */ -/**********************************************************************/ +/************************************************************************/ +/* Defining functions/variables */ +/************************************************************************/ +static Lisp_Object +define_function (Lisp_Object name, Lisp_Object defn) +{ + Ffset (name, defn); + LOADHIST_ATTACH (name); + return name; +} DEFUN ("defun", Fdefun, 2, UNEVALLED, 0, /* \(defun NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function. @@ -1026,14 +1035,8 @@ See also the function `interactive'. (args)) { /* This function can GC */ - Lisp_Object fn_name = XCAR (args); - Lisp_Object defn = Fcons (Qlambda, XCDR (args)); - - if (purify_flag) - defn = Fpurecopy (defn); - Ffset (fn_name, defn); - LOADHIST_ATTACH (fn_name); - return fn_name; + return define_function (XCAR (args), + Fcons (Qlambda, XCDR (args))); } DEFUN ("defmacro", Fdefmacro, 2, UNEVALLED, 0, /* @@ -1047,14 +1050,8 @@ and the result should be a form to be evaluated instead of the original. (args)) { /* This function can GC */ - Lisp_Object fn_name = XCAR (args); - Lisp_Object defn = Fcons (Qmacro, Fcons (Qlambda, XCDR (args))); - - if (purify_flag) - defn = Fpurecopy (defn); - Ffset (fn_name, defn); - LOADHIST_ATTACH (fn_name); - return fn_name; + return define_function (XCAR (args), + Fcons (Qmacro, Fcons (Qlambda, XCDR (args)))); } DEFUN ("defvar", Fdefvar, 1, UNEVALLED, 0, /* @@ -1071,7 +1068,7 @@ If SYMBOL is buffer-local, its default value is what is set; buffer-local values are not affected. INITVALUE and DOCSTRING are optional. If DOCSTRING starts with *, this variable is identified as a user option. - This means that M-x set-variable and M-x edit-options recognize it. + This means that M-x set-variable recognizes it. If INITVALUE is missing, SYMBOL's value is not set. In lisp-interaction-mode defvar is treated as defconst. @@ -1086,19 +1083,18 @@ In lisp-interaction-mode defvar is treated as defconst. Lisp_Object val = XCAR (args); if (NILP (Fdefault_boundp (sym))) - Fset_default (sym, Feval (val)); + { + struct gcpro gcpro1; + GCPRO1 (val); + val = Feval (val); + Fset_default (sym, val); + UNGCPRO; + } if (!NILP (args = XCDR (args))) { Lisp_Object doc = XCAR (args); -#if 0 /* FSFmacs */ - /* #### We should probably do this but it might be dangerous */ - if (purify_flag) - doc = Fpurecopy (doc); Fput (sym, Qvariable_documentation, doc); -#else - pure_put (sym, Qvariable_documentation, doc); -#endif if (!NILP (args = XCDR (args))) error ("too many arguments"); } @@ -1106,7 +1102,7 @@ In lisp-interaction-mode defvar is treated as defconst. #ifdef I18N3 if (!NILP (Vfile_domain)) - pure_put (sym, Qvariable_domain, Vfile_domain); + Fput (sym, Qvariable_domain, Vfile_domain); #endif LOADHIST_ATTACH (sym); @@ -1122,7 +1118,7 @@ If SYMBOL is buffer-local, its default value is what is set; buffer-local values are not affected. DOCSTRING is optional. If DOCSTRING starts with *, this variable is identified as a user option. - This means that M-x set-variable and M-x edit-options recognize it. + This means that M-x set-variable recognizes it. Note: do not use `defconst' for user options in libraries that are not normally loaded, since it is useful for users to be able to specify @@ -1134,28 +1130,26 @@ Since `defconst' unconditionally assigns the variable, { /* This function can GC */ Lisp_Object sym = XCAR (args); - Lisp_Object val = XCAR (args = XCDR (args)); + Lisp_Object val = Feval (XCAR (args = XCDR (args))); + struct gcpro gcpro1; + + GCPRO1 (val); - Fset_default (sym, Feval (val)); + Fset_default (sym, val); + + UNGCPRO; if (!NILP (args = XCDR (args))) { Lisp_Object doc = XCAR (args); -#if 0 /* FSFmacs */ - /* #### We should probably do this but it might be dangerous */ - if (purify_flag) - doc = Fpurecopy (doc); Fput (sym, Qvariable_documentation, doc); -#else - pure_put (sym, Qvariable_documentation, doc); -#endif if (!NILP (args = XCDR (args))) error ("too many arguments"); } #ifdef I18N3 if (!NILP (Vfile_domain)) - pure_put (sym, Qvariable_domain, Vfile_domain); + Fput (sym, Qvariable_domain, Vfile_domain); #endif LOADHIST_ATTACH (sym); @@ -1170,21 +1164,20 @@ for the variable is `*'. */ (variable)) { - Lisp_Object documentation; + Lisp_Object documentation = Fget (variable, Qvariable_documentation, Qnil); - documentation = Fget (variable, Qvariable_documentation, Qnil); - if (INTP (documentation) && XINT (documentation) < 0) - return Qt; - if ((STRINGP (documentation)) && - (string_byte (XSTRING (documentation), 0) == '*')) - return Qt; - /* If it is (STRING . INTEGER), a negative integer means a user variable. */ - if (CONSP (documentation) + return + ((INTP (documentation) && XINT (documentation) < 0) || + + (STRINGP (documentation) && + (string_byte (XSTRING (documentation), 0) == '*')) || + + /* If (STRING . INTEGER), a negative integer means a user variable. */ + (CONSP (documentation) && STRINGP (XCAR (documentation)) && INTP (XCDR (documentation)) - && XINT (XCDR (documentation)) < 0) - return Qt; - return Qnil; + && XINT (XCDR (documentation)) < 0)) ? + Qt : Qnil; } DEFUN ("macroexpand-internal", Fmacroexpand_internal, 1, 2, 0, /* @@ -1193,10 +1186,10 @@ If FORM is not a macro call, it is returned unchanged. Otherwise, the macro is expanded and the expansion is considered in place of FORM. When a non-macro-call results, it is returned. -The second optional arg ENVIRONMENT species an environment of macro +The second optional arg ENVIRONMENT specifies an environment of macro definitions to shadow the loaded ones for use in file byte-compilation. */ - (form, env)) + (form, environment)) { /* This function can GC */ /* With cleanups from Hallvard Furuseth. */ @@ -1217,7 +1210,7 @@ definitions to shadow the loaded ones for use in file byte-compilation. { QUIT; sym = def; - tem = Fassq (sym, env); + tem = Fassq (sym, environment); if (NILP (tem)) { def = XSYMBOL (sym)->function; @@ -1226,11 +1219,11 @@ definitions to shadow the loaded ones for use in file byte-compilation. } break; } - /* Right now TEM is the result from SYM in ENV, + /* Right now TEM is the result from SYM in ENVIRONMENT, and if TEM is nil then DEF is SYM's function definition. */ if (NILP (tem)) { - /* SYM is not mentioned in ENV. + /* SYM is not mentioned in ENVIRONMENT. Look at its function definition. */ if (UNBOUNDP (def) || !CONSP (def)) @@ -1243,6 +1236,7 @@ definitions to shadow the loaded ones for use in file byte-compilation. if (EQ (tem, Qt) || EQ (tem, Qmacro)) { /* Yes, load it and try again. */ + /* do_autoload GCPROs both arguments */ do_autoload (def, sym); continue; } @@ -1265,9 +1259,9 @@ definitions to shadow the loaded ones for use in file byte-compilation. } -/**********************************************************************/ -/* Non-local exits */ -/**********************************************************************/ +/************************************************************************/ +/* Non-local exits */ +/************************************************************************/ DEFUN ("catch", Fcatch, 1, UNEVALLED, 0, /* \(catch TAG BODY...): eval BODY allowing nonlocal exits using `throw'. @@ -1279,13 +1273,9 @@ If a throw happens, it specifies the value to return from `catch'. (args)) { /* This function can GC */ - Lisp_Object tag; - struct gcpro gcpro1; - - GCPRO1 (args); - tag = Feval (XCAR (args)); - UNGCPRO; - return internal_catch (tag, Fprogn, XCDR (args), 0); + Lisp_Object tag = Feval (XCAR (args)); + Lisp_Object body = XCDR (args); + return internal_catch (tag, Fprogn, body, 0); } /* Set up a catch, then call C function FUNC on argument ARG. @@ -1311,7 +1301,7 @@ internal_catch (Lisp_Object tag, c.handlerlist = handlerlist; #endif c.lisp_eval_depth = lisp_eval_depth; - c.pdlcount = specpdl_depth_counter; + c.pdlcount = specpdl_depth(); #if 0 /* FSFmacs */ c.poll_suppress_count = async_timer_suppress_count; #endif @@ -1328,6 +1318,9 @@ internal_catch (Lisp_Object tag, c.val = (*func) (arg); if (threw) *threw = 0; catchlist = c.next; +#ifdef ERROR_CHECK_TYPECHECK + check_error_state_sanity (); +#endif return c.val; } @@ -1384,19 +1377,27 @@ unwind_to_catch (struct catchtag *c, Lisp_Object val) unbind_to (catchlist->pdlcount, Qnil); handlerlist = catchlist->handlerlist; catchlist = catchlist->next; +#ifdef ERROR_CHECK_TYPECHECK + check_error_state_sanity (); +#endif } while (! last_time); #else /* Actual XEmacs code */ /* Unwind the specpdl stack */ unbind_to (c->pdlcount, Qnil); catchlist = c->next; +#ifdef ERROR_CHECK_TYPECHECK + check_error_state_sanity (); +#endif #endif gcprolist = c->gcpro; backtrace_list = c->backlist; lisp_eval_depth = c->lisp_eval_depth; +#ifdef DEFEND_AGAINST_THROW_RECURSION throw_level = 0; +#endif LONGJMP (c->jmp, 1); } @@ -1404,10 +1405,10 @@ static DOESNT_RETURN throw_or_bomb_out (Lisp_Object tag, Lisp_Object val, int bomb_out_p, Lisp_Object sig, Lisp_Object data) { -#if 0 +#ifdef DEFEND_AGAINST_THROW_RECURSION /* die if we recurse more than is reasonable */ if (++throw_level > 20) - abort(); + ABORT(); #endif /* If bomb_out_p is t, this is being called from Fsignal as a @@ -1471,12 +1472,12 @@ throw_or_bomb_out (Lisp_Object tag, Lisp_Object val, int bomb_out_p, */ DEFUN ("throw", Fthrow, 2, 2, 0, /* -\(throw TAG VALUE): throw to the catch for TAG and return VALUE from it. +Throw to the catch for TAG and return VALUE from it. Both TAG and VALUE are evalled. */ - (tag, val)) + (tag, value)) { - throw_or_bomb_out (tag, val, 0, Qnil, Qnil); /* Doesn't return */ + throw_or_bomb_out (tag, value, 0, Qnil, Qnil); /* Doesn't return */ return Qnil; } @@ -1490,23 +1491,21 @@ If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway. (args)) { /* This function can GC */ - Lisp_Object val; - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); record_unwind_protect (Fprogn, XCDR (args)); - val = Feval (XCAR (args)); - return unbind_to (speccount, val); + return unbind_to (speccount, Feval (XCAR (args))); } -/**********************************************************************/ -/* Signalling and trapping errors */ -/**********************************************************************/ +/************************************************************************/ +/* Signalling and trapping errors */ +/************************************************************************/ static Lisp_Object condition_bind_unwind (Lisp_Object loser) { - struct Lisp_Cons *victim; + Lisp_Cons *victim; /* ((handler-fun . handler-args) ... other handlers) */ Lisp_Object tem = XCAR (loser); @@ -1528,7 +1527,7 @@ condition_bind_unwind (Lisp_Object loser) static Lisp_Object condition_case_unwind (Lisp_Object loser) { - struct Lisp_Cons *victim; + Lisp_Cons *victim; /* (( . clauses) ... other handlers */ victim = XCONS (XCAR (loser)); @@ -1599,7 +1598,7 @@ condition_case_1 (Lisp_Object handlers, Lisp_Object (*hfun) (Lisp_Object val, Lisp_Object harg), Lisp_Object harg) { - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); struct catchtag c; struct gcpro gcpro1; @@ -1622,7 +1621,7 @@ condition_case_1 (Lisp_Object handlers, c.handlerlist = handlerlist; #endif c.lisp_eval_depth = lisp_eval_depth; - c.pdlcount = specpdl_depth_counter; + c.pdlcount = specpdl_depth(); #if 0 /* FSFmacs */ c.poll_suppress_count = async_timer_suppress_count; #endif @@ -1659,6 +1658,9 @@ condition_case_1 (Lisp_Object handlers, have this code here, and it doesn't cost anything, so I'm leaving it.*/ UNGCPRO; catchlist = c.next; +#ifdef ERROR_CHECK_TYPECHECK + check_error_state_sanity (); +#endif Vcondition_handlers = XCDR (c.tag); return unbind_to (speccount, c.val); @@ -1674,17 +1676,18 @@ run_condition_case_handlers (Lisp_Object val, Lisp_Object var) val = Fprogn (Fcdr (h.chosen_clause)); /* Note that this just undoes the binding of h.var; whoever - longjumped to us unwound the stack to c.pdlcount before + longjmp()ed to us unwound the stack to c.pdlcount before throwing. */ unbind_to (c.pdlcount, Qnil); return val; #else int speccount; + CHECK_TRUE_LIST (val); if (NILP (var)) - return Fprogn (Fcdr (val)); /* tailcall */ + return Fprogn (Fcdr (val)); /* tail call */ - speccount = specpdl_depth_counter; + speccount = specpdl_depth(); specbind (var, Fcar (val)); val = Fprogn (Fcdr (val)); return unbind_to (speccount, val); @@ -1698,30 +1701,42 @@ Lisp_Object condition_case_3 (Lisp_Object bodyform, Lisp_Object var, Lisp_Object handlers) { /* This function can GC */ - Lisp_Object val; - - CHECK_SYMBOL (var); - - for (val = handlers; ! NILP (val); val = Fcdr (val)) + EXTERNAL_LIST_LOOP_2 (handler, handlers) { - Lisp_Object tem; - tem = Fcar (val); - if ((!NILP (tem)) - && (!CONSP (tem) - || (!SYMBOLP (XCAR (tem)) && !CONSP (XCAR (tem))))) - signal_simple_error ("Invalid condition handler", tem); + if (NILP (handler)) + ; + else if (CONSP (handler)) + { + Lisp_Object conditions = XCAR (handler); + /* CONDITIONS must a condition name or a list of condition names */ + if (SYMBOLP (conditions)) + ; + else + { + EXTERNAL_LIST_LOOP_2 (condition, conditions) + if (!SYMBOLP (condition)) + goto invalid_condition_handler; + } + } + else + { + invalid_condition_handler: + signal_simple_error ("Invalid condition handler", handler); + } } + CHECK_SYMBOL (var); + return condition_case_1 (handlers, - Feval, bodyform, - run_condition_case_handlers, - var); + Feval, bodyform, + run_condition_case_handlers, + var); } DEFUN ("condition-case", Fcondition_case, 2, UNEVALLED, 0, /* Regain control when an error is signalled. Usage looks like (condition-case VAR BODYFORM HANDLERS...). -executes BODYFORM and returns its value if no error happens. +Executes BODYFORM and returns its value if no error happens. Each element of HANDLERS looks like (CONDITION-NAME BODY...) where the BODY is made of Lisp expressions. @@ -1755,9 +1770,10 @@ rather than when the handler was set, use `call-with-condition-handler'. (args)) { /* This function can GC */ - return condition_case_3 (XCAR (XCDR (args)), - XCAR (args), - XCDR (XCDR (args))); + Lisp_Object var = XCAR (args); + Lisp_Object bodyform = XCAR (XCDR (args)); + Lisp_Object handlers = XCDR (XCDR (args)); + return condition_case_3 (bodyform, var, handlers); } DEFUN ("call-with-condition-handler", Fcall_with_condition_handler, 2, MANY, 0, /* @@ -1779,20 +1795,19 @@ and invokes the standard error-handler if none is found.) (int nargs, Lisp_Object *args)) /* Note! Args side-effected! */ { /* This function can GC */ - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); Lisp_Object tem; /* #### If there were a way to check that args[0] were a function which accepted one arg, that should be done here ... */ /* (handler-fun . handler-args) */ - tem = noseeum_cons (list1 (args[0]), Vcondition_handlers); + tem = noseeum_cons (list1 (args[0]), Vcondition_handlers); record_unwind_protect (condition_bind_unwind, tem); Vcondition_handlers = tem; /* Caller should have GC-protected args */ - tem = Ffuncall (nargs - 1, args + 1); - return unbind_to (speccount, tem); + return unbind_to (speccount, Ffuncall (nargs - 1, args + 1)); } static int @@ -1802,25 +1817,15 @@ condition_type_p (Lisp_Object type, Lisp_Object conditions) /* (condition-case c # (t c)) catches -all- signals * Use with caution! */ return 1; - else - { - if (SYMBOLP (type)) - { - return !NILP (Fmemq (type, conditions)); - } - else if (CONSP (type)) - { - while (CONSP (type)) - { - if (!NILP (Fmemq (Fcar (type), conditions))) - return 1; - type = XCDR (type); - } - return 0; - } - else - return 0; - } + + if (SYMBOLP (type)) + return !NILP (Fmemq (type, conditions)); + + for (; CONSP (type); type = XCDR (type)) + if (!NILP (Fmemq (XCAR (type), conditions))) + return 1; + + return 0; } static Lisp_Object @@ -1842,7 +1847,9 @@ return_from_signal (Lisp_Object value) extern int in_display; -/****************** the workhorse error-signaling function ******************/ +/************************************************************************/ +/* the workhorse error-signaling function */ +/************************************************************************/ /* #### This function has not been synched with FSF. It diverges significantly. */ @@ -1867,14 +1874,16 @@ signal_1 (Lisp_Object sig, Lisp_Object data) { /* who knows how much has been initialized? Safest bet is just to bomb out immediately. */ + /* let's not use stderr_out() here, because that does a bunch of + things that might not be safe yet. */ fprintf (stderr, "Error before initialization is complete!\n"); - abort (); + ABORT (); } if (gc_in_progress || in_display) /* This is one of many reasons why you can't run lisp code from redisplay. There is no sensible way to handle errors there. */ - abort (); + ABORT (); conditions = Fget (sig, Qerror_conditions, Qnil); @@ -2039,7 +2048,7 @@ user invokes the "return from signal" option. warn_when_safe_lispobj (Vcurrent_warning_class, Qwarning, Fcons (error_symbol, data)); Fthrow (Qunbound_suspended_errors_tag, Qnil); - abort (); /* Better not get here! */ + ABORT (); /* Better not get here! */ } RETURN_UNGCPRO (signal_1 (error_symbol, data)); } @@ -2052,14 +2061,25 @@ signal_error (Lisp_Object sig, Lisp_Object data) for (;;) Fsignal (sig, data); } - -static Lisp_Object -call_with_suspended_errors_1 (Lisp_Object opaque_arg) +#ifdef ERROR_CHECK_TYPECHECK +void +check_error_state_sanity (void) { - Lisp_Object *kludgy_args = (Lisp_Object *) get_opaque_ptr (opaque_arg); - return primitive_funcall ((lisp_fn_t) get_opaque_ptr (kludgy_args[0]), - XINT (kludgy_args[1]), kludgy_args + 2); + struct catchtag *c; + int found_error_tag = 0; + + for (c = catchlist; c; c = c->next) + { + if (EQ (c->tag, Qunbound_suspended_errors_tag)) + { + found_error_tag = 1; + break; + } + } + + assert (found_error_tag || NILP (Vcurrent_error_state)); } +#endif static Lisp_Object restore_current_warning_class (Lisp_Object warning_class) @@ -2075,6 +2095,25 @@ restore_current_error_state (Lisp_Object error_state) return Qnil; } +static Lisp_Object +call_with_suspended_errors_1 (Lisp_Object opaque_arg) +{ + Lisp_Object val; + Lisp_Object *kludgy_args = (Lisp_Object *) get_opaque_ptr (opaque_arg); + Lisp_Object no_error = kludgy_args[2]; + int speccount = specpdl_depth (); + + if (!EQ (Vcurrent_error_state, no_error)) + { + record_unwind_protect (restore_current_error_state, + Vcurrent_error_state); + Vcurrent_error_state = no_error; + } + PRIMITIVE_FUNCALL (val, get_opaque_ptr (kludgy_args[0]), + kludgy_args + 3, XINT (kludgy_args[1])); + return unbind_to (speccount, val); +} + /* Many functions would like to do one of three things if an error occurs: @@ -2097,8 +2136,8 @@ call_with_suspended_errors (lisp_fn_t fun, volatile Lisp_Object retval, { va_list vargs; int speccount; - Lisp_Object kludgy_args[22]; - Lisp_Object *args = kludgy_args + 2; + Lisp_Object kludgy_args[23]; + Lisp_Object *args = kludgy_args + 3; int i; Lisp_Object no_error; @@ -2134,9 +2173,13 @@ call_with_suspended_errors (lisp_fn_t fun, volatile Lisp_Object retval, enabled error-checking. */ if (ERRB_EQ (errb, ERROR_ME)) - return primitive_funcall (fun, nargs, args); + { + Lisp_Object val; + PRIMITIVE_FUNCALL (val, fun, args, nargs); + return val; + } - speccount = specpdl_depth_counter; + speccount = specpdl_depth (); if (NILP (class) || NILP (Vcurrent_warning_class)) { /* If we're currently calling for no warnings, then make it so. @@ -2147,12 +2190,6 @@ call_with_suspended_errors (lisp_fn_t fun, volatile Lisp_Object retval, Vcurrent_warning_class); Vcurrent_warning_class = class; } - if (!EQ (Vcurrent_error_state, no_error)) - { - record_unwind_protect (restore_current_error_state, - Vcurrent_error_state); - Vcurrent_error_state = no_error; - } { int threw; @@ -2164,6 +2201,7 @@ call_with_suspended_errors (lisp_fn_t fun, volatile Lisp_Object retval, GCPRO2 (opaque1, opaque2); kludgy_args[0] = opaque2; kludgy_args[1] = make_int (nargs); + kludgy_args[2] = no_error; the_retval = internal_catch (Qunbound_suspended_errors_tag, call_with_suspended_errors_1, opaque1, &threw); @@ -2218,28 +2256,29 @@ maybe_signal_continuable_error (Lisp_Object sig, Lisp_Object data, /****************** Error functions class 2 ******************/ /* Class 2: Printf-like functions that signal an error. - These functions signal an error of type Qerror, whose data + These functions signal an error of a specified type, whose data is a single string, created using the arguments. */ /* dump an error message; called like printf */ DOESNT_RETURN -error (CONST char *fmt, ...) +type_error (Lisp_Object type, const char *fmt, ...) { Lisp_Object obj; va_list args; va_start (args, fmt); - obj = emacs_doprnt_string_va ((CONST Bufbyte *) GETTEXT (fmt), Qnil, -1, + obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1, args); va_end (args); /* Fsignal GC-protects its args */ - signal_error (Qerror, list1 (obj)); + signal_error (type, list1 (obj)); } void -maybe_error (Lisp_Object class, Error_behavior errb, CONST char *fmt, ...) +maybe_type_error (Lisp_Object type, Lisp_Object class, Error_behavior errb, + const char *fmt, ...) { Lisp_Object obj; va_list args; @@ -2249,32 +2288,32 @@ maybe_error (Lisp_Object class, Error_behavior errb, CONST char *fmt, ...) return; va_start (args, fmt); - obj = emacs_doprnt_string_va ((CONST Bufbyte *) GETTEXT (fmt), Qnil, -1, + obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1, args); va_end (args); /* Fsignal GC-protects its args */ - maybe_signal_error (Qerror, list1 (obj), class, errb); + maybe_signal_error (type, list1 (obj), class, errb); } Lisp_Object -continuable_error (CONST char *fmt, ...) +continuable_type_error (Lisp_Object type, const char *fmt, ...) { Lisp_Object obj; va_list args; va_start (args, fmt); - obj = emacs_doprnt_string_va ((CONST Bufbyte *) GETTEXT (fmt), Qnil, -1, + obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1, args); va_end (args); /* Fsignal GC-protects its args */ - return Fsignal (Qerror, list1 (obj)); + return Fsignal (type, list1 (obj)); } Lisp_Object -maybe_continuable_error (Lisp_Object class, Error_behavior errb, - CONST char *fmt, ...) +maybe_continuable_type_error (Lisp_Object type, Lisp_Object class, + Error_behavior errb, const char *fmt, ...) { Lisp_Object obj; va_list args; @@ -2284,54 +2323,60 @@ maybe_continuable_error (Lisp_Object class, Error_behavior errb, return Qnil; va_start (args, fmt); - obj = emacs_doprnt_string_va ((CONST Bufbyte *) GETTEXT (fmt), Qnil, -1, + obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1, args); va_end (args); /* Fsignal GC-protects its args */ - return maybe_signal_continuable_error (Qerror, list1 (obj), class, errb); + return maybe_signal_continuable_error (type, list1 (obj), class, errb); } /****************** Error functions class 3 ******************/ /* Class 3: Signal an error with a string and an associated object. - These functions signal an error of type Qerror, whose data + These functions signal an error of a specified type, whose data is two objects, a string and a related Lisp object (usually the object where the error is occurring). */ DOESNT_RETURN -signal_simple_error (CONST char *reason, Lisp_Object frob) +signal_type_error (Lisp_Object type, const char *reason, Lisp_Object frob) { - signal_error (Qerror, list2 (build_translated_string (reason), frob)); + if (UNBOUNDP (frob)) + signal_error (type, list1 (build_translated_string (reason))); + else + signal_error (type, list2 (build_translated_string (reason), frob)); } void -maybe_signal_simple_error (CONST char *reason, Lisp_Object frob, - Lisp_Object class, Error_behavior errb) +maybe_signal_type_error (Lisp_Object type, const char *reason, + Lisp_Object frob, Lisp_Object class, + Error_behavior errb) { /* Optimization: */ if (ERRB_EQ (errb, ERROR_ME_NOT)) return; - maybe_signal_error (Qerror, list2 (build_translated_string (reason), frob), + maybe_signal_error (type, list2 (build_translated_string (reason), frob), class, errb); } Lisp_Object -signal_simple_continuable_error (CONST char *reason, Lisp_Object frob) +signal_type_continuable_error (Lisp_Object type, const char *reason, + Lisp_Object frob) { - return Fsignal (Qerror, list2 (build_translated_string (reason), frob)); + return Fsignal (type, list2 (build_translated_string (reason), frob)); } Lisp_Object -maybe_signal_simple_continuable_error (CONST char *reason, Lisp_Object frob, - Lisp_Object class, Error_behavior errb) +maybe_signal_type_continuable_error (Lisp_Object type, const char *reason, + Lisp_Object frob, Lisp_Object class, + Error_behavior errb) { /* Optimization: */ if (ERRB_EQ (errb, ERROR_ME_NOT)) return Qnil; return maybe_signal_continuable_error - (Qerror, list2 (build_translated_string (reason), + (type, list2 (build_translated_string (reason), frob), class, errb); } @@ -2339,19 +2384,273 @@ maybe_signal_simple_continuable_error (CONST char *reason, Lisp_Object frob, /****************** Error functions class 4 ******************/ /* Class 4: Printf-like functions that signal an error. + These functions signal an error of a specified type, whose data + is a two objects, a string (created using the arguments) and a + Lisp object. +*/ + +DOESNT_RETURN +type_error_with_frob (Lisp_Object type, Lisp_Object frob, const char *fmt, ...) +{ + Lisp_Object obj; + va_list args; + + va_start (args, fmt); + obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1, + args); + va_end (args); + + /* Fsignal GC-protects its args */ + signal_error (type, list2 (obj, frob)); +} + +void +maybe_type_error_with_frob (Lisp_Object type, Lisp_Object frob, + Lisp_Object class, Error_behavior errb, + const char *fmt, ...) +{ + Lisp_Object obj; + va_list args; + + /* Optimization: */ + if (ERRB_EQ (errb, ERROR_ME_NOT)) + return; + + va_start (args, fmt); + obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1, + args); + va_end (args); + + /* Fsignal GC-protects its args */ + maybe_signal_error (type, list2 (obj, frob), class, errb); +} + +Lisp_Object +continuable_type_error_with_frob (Lisp_Object type, Lisp_Object frob, + const char *fmt, ...) +{ + Lisp_Object obj; + va_list args; + + va_start (args, fmt); + obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1, + args); + va_end (args); + + /* Fsignal GC-protects its args */ + return Fsignal (type, list2 (obj, frob)); +} + +Lisp_Object +maybe_continuable_type_error_with_frob (Lisp_Object type, Lisp_Object frob, + Lisp_Object class, Error_behavior errb, + const char *fmt, ...) +{ + Lisp_Object obj; + va_list args; + + /* Optimization: */ + if (ERRB_EQ (errb, ERROR_ME_NOT)) + return Qnil; + + va_start (args, fmt); + obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1, + args); + va_end (args); + + /* Fsignal GC-protects its args */ + return maybe_signal_continuable_error (type, list2 (obj, frob), + class, errb); +} + + +/****************** Error functions class 5 ******************/ + +/* Class 5: Signal an error with a string and two associated objects. + These functions signal an error of a specified type, whose data + is three objects, a string and two related Lisp objects. */ + +DOESNT_RETURN +signal_type_error_2 (Lisp_Object type, const char *reason, + Lisp_Object frob0, Lisp_Object frob1) +{ + signal_error (type, list3 (build_translated_string (reason), frob0, + frob1)); +} + +void +maybe_signal_type_error_2 (Lisp_Object type, const char *reason, + Lisp_Object frob0, Lisp_Object frob1, + Lisp_Object class, Error_behavior errb) +{ + /* Optimization: */ + if (ERRB_EQ (errb, ERROR_ME_NOT)) + return; + maybe_signal_error (type, list3 (build_translated_string (reason), frob0, + frob1), class, errb); +} + + +Lisp_Object +signal_type_continuable_error_2 (Lisp_Object type, const char *reason, + Lisp_Object frob0, Lisp_Object frob1) +{ + return Fsignal (type, list3 (build_translated_string (reason), frob0, + frob1)); +} + +Lisp_Object +maybe_signal_type_continuable_error_2 (Lisp_Object type, const char *reason, + Lisp_Object frob0, Lisp_Object frob1, + Lisp_Object class, Error_behavior errb) +{ + /* Optimization: */ + if (ERRB_EQ (errb, ERROR_ME_NOT)) + return Qnil; + return maybe_signal_continuable_error + (type, list3 (build_translated_string (reason), frob0, + frob1), + class, errb); +} + + +/****************** Simple error functions class 2 ******************/ + +/* Simple class 2: Printf-like functions that signal an error. + These functions signal an error of type Qerror, whose data + is a single string, created using the arguments. */ + +/* dump an error message; called like printf */ + +DOESNT_RETURN +error (const char *fmt, ...) +{ + Lisp_Object obj; + va_list args; + + va_start (args, fmt); + obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1, + args); + va_end (args); + + /* Fsignal GC-protects its args */ + signal_error (Qerror, list1 (obj)); +} + +void +maybe_error (Lisp_Object class, Error_behavior errb, const char *fmt, ...) +{ + Lisp_Object obj; + va_list args; + + /* Optimization: */ + if (ERRB_EQ (errb, ERROR_ME_NOT)) + return; + + va_start (args, fmt); + obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1, + args); + va_end (args); + + /* Fsignal GC-protects its args */ + maybe_signal_error (Qerror, list1 (obj), class, errb); +} + +Lisp_Object +continuable_error (const char *fmt, ...) +{ + Lisp_Object obj; + va_list args; + + va_start (args, fmt); + obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1, + args); + va_end (args); + + /* Fsignal GC-protects its args */ + return Fsignal (Qerror, list1 (obj)); +} + +Lisp_Object +maybe_continuable_error (Lisp_Object class, Error_behavior errb, + const char *fmt, ...) +{ + Lisp_Object obj; + va_list args; + + /* Optimization: */ + if (ERRB_EQ (errb, ERROR_ME_NOT)) + return Qnil; + + va_start (args, fmt); + obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1, + args); + va_end (args); + + /* Fsignal GC-protects its args */ + return maybe_signal_continuable_error (Qerror, list1 (obj), class, errb); +} + + +/****************** Simple error functions class 3 ******************/ + +/* Simple class 3: Signal an error with a string and an associated object. + These functions signal an error of type Qerror, whose data + is two objects, a string and a related Lisp object (usually the object + where the error is occurring). */ + +DOESNT_RETURN +signal_simple_error (const char *reason, Lisp_Object frob) +{ + signal_error (Qerror, list2 (build_translated_string (reason), frob)); +} + +void +maybe_signal_simple_error (const char *reason, Lisp_Object frob, + Lisp_Object class, Error_behavior errb) +{ + /* Optimization: */ + if (ERRB_EQ (errb, ERROR_ME_NOT)) + return; + maybe_signal_error (Qerror, list2 (build_translated_string (reason), frob), + class, errb); +} + +Lisp_Object +signal_simple_continuable_error (const char *reason, Lisp_Object frob) +{ + return Fsignal (Qerror, list2 (build_translated_string (reason), frob)); +} + +Lisp_Object +maybe_signal_simple_continuable_error (const char *reason, Lisp_Object frob, + Lisp_Object class, Error_behavior errb) +{ + /* Optimization: */ + if (ERRB_EQ (errb, ERROR_ME_NOT)) + return Qnil; + return maybe_signal_continuable_error + (Qerror, list2 (build_translated_string (reason), + frob), class, errb); +} + + +/****************** Simple error functions class 4 ******************/ + +/* Simple class 4: Printf-like functions that signal an error. These functions signal an error of type Qerror, whose data is a two objects, a string (created using the arguments) and a Lisp object. */ DOESNT_RETURN -error_with_frob (Lisp_Object frob, CONST char *fmt, ...) +error_with_frob (Lisp_Object frob, const char *fmt, ...) { Lisp_Object obj; va_list args; va_start (args, fmt); - obj = emacs_doprnt_string_va ((CONST Bufbyte *) GETTEXT (fmt), Qnil, -1, + obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1, args); va_end (args); @@ -2361,7 +2660,7 @@ error_with_frob (Lisp_Object frob, CONST char *fmt, ...) void maybe_error_with_frob (Lisp_Object frob, Lisp_Object class, - Error_behavior errb, CONST char *fmt, ...) + Error_behavior errb, const char *fmt, ...) { Lisp_Object obj; va_list args; @@ -2371,7 +2670,7 @@ maybe_error_with_frob (Lisp_Object frob, Lisp_Object class, return; va_start (args, fmt); - obj = emacs_doprnt_string_va ((CONST Bufbyte *) GETTEXT (fmt), Qnil, -1, + obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1, args); va_end (args); @@ -2380,13 +2679,13 @@ maybe_error_with_frob (Lisp_Object frob, Lisp_Object class, } Lisp_Object -continuable_error_with_frob (Lisp_Object frob, CONST char *fmt, ...) +continuable_error_with_frob (Lisp_Object frob, const char *fmt, ...) { Lisp_Object obj; va_list args; va_start (args, fmt); - obj = emacs_doprnt_string_va ((CONST Bufbyte *) GETTEXT (fmt), Qnil, -1, + obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1, args); va_end (args); @@ -2396,7 +2695,7 @@ continuable_error_with_frob (Lisp_Object frob, CONST char *fmt, ...) Lisp_Object maybe_continuable_error_with_frob (Lisp_Object frob, Lisp_Object class, - Error_behavior errb, CONST char *fmt, ...) + Error_behavior errb, const char *fmt, ...) { Lisp_Object obj; va_list args; @@ -2406,7 +2705,7 @@ maybe_continuable_error_with_frob (Lisp_Object frob, Lisp_Object class, return Qnil; va_start (args, fmt); - obj = emacs_doprnt_string_va ((CONST Bufbyte *) GETTEXT (fmt), Qnil, -1, + obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1, args); va_end (args); @@ -2416,14 +2715,14 @@ maybe_continuable_error_with_frob (Lisp_Object frob, Lisp_Object class, } -/****************** Error functions class 5 ******************/ +/****************** Simple error functions class 5 ******************/ -/* Class 5: Signal an error with a string and two associated objects. +/* Simple class 5: Signal an error with a string and two associated objects. These functions signal an error of type Qerror, whose data is three objects, a string and two related Lisp objects. */ DOESNT_RETURN -signal_simple_error_2 (CONST char *reason, +signal_simple_error_2 (const char *reason, Lisp_Object frob0, Lisp_Object frob1) { signal_error (Qerror, list3 (build_translated_string (reason), frob0, @@ -2431,7 +2730,7 @@ signal_simple_error_2 (CONST char *reason, } void -maybe_signal_simple_error_2 (CONST char *reason, Lisp_Object frob0, +maybe_signal_simple_error_2 (const char *reason, Lisp_Object frob0, Lisp_Object frob1, Lisp_Object class, Error_behavior errb) { @@ -2444,7 +2743,7 @@ maybe_signal_simple_error_2 (CONST char *reason, Lisp_Object frob0, Lisp_Object -signal_simple_continuable_error_2 (CONST char *reason, Lisp_Object frob0, +signal_simple_continuable_error_2 (const char *reason, Lisp_Object frob0, Lisp_Object frob1) { return Fsignal (Qerror, list3 (build_translated_string (reason), frob0, @@ -2452,7 +2751,7 @@ signal_simple_continuable_error_2 (CONST char *reason, Lisp_Object frob0, } Lisp_Object -maybe_signal_simple_continuable_error_2 (CONST char *reason, Lisp_Object frob0, +maybe_signal_simple_continuable_error_2 (const char *reason, Lisp_Object frob0, Lisp_Object frob1, Lisp_Object class, Error_behavior errb) { @@ -2479,9 +2778,103 @@ signal_quit (void) } -/**********************************************************************/ -/* User commands */ -/**********************************************************************/ +/* Used in core lisp functions for efficiency */ +Lisp_Object +signal_void_function_error (Lisp_Object function) +{ + return Fsignal (Qvoid_function, list1 (function)); +} + +Lisp_Object +signal_invalid_function_error (Lisp_Object function) +{ + return Fsignal (Qinvalid_function, list1 (function)); +} + +Lisp_Object +signal_wrong_number_of_arguments_error (Lisp_Object function, int nargs) +{ + return Fsignal (Qwrong_number_of_arguments, + list2 (function, make_int (nargs))); +} + +/* Used in list traversal macros for efficiency. */ +DOESNT_RETURN +signal_malformed_list_error (Lisp_Object list) +{ + signal_error (Qmalformed_list, list1 (list)); +} + +DOESNT_RETURN +signal_malformed_property_list_error (Lisp_Object list) +{ + signal_error (Qmalformed_property_list, list1 (list)); +} + +DOESNT_RETURN +signal_circular_list_error (Lisp_Object list) +{ + signal_error (Qcircular_list, list1 (list)); +} + +DOESNT_RETURN +signal_circular_property_list_error (Lisp_Object list) +{ + signal_error (Qcircular_property_list, list1 (list)); +} + +DOESNT_RETURN +syntax_error (const char *reason, Lisp_Object frob) +{ + signal_type_error (Qsyntax_error, reason, frob); +} + +DOESNT_RETURN +syntax_error_2 (const char *reason, Lisp_Object frob1, Lisp_Object frob2) +{ + signal_type_error_2 (Qsyntax_error, reason, frob1, frob2); +} + +DOESNT_RETURN +invalid_argument (const char *reason, Lisp_Object frob) +{ + signal_type_error (Qinvalid_argument, reason, frob); +} + +DOESNT_RETURN +invalid_argument_2 (const char *reason, Lisp_Object frob1, Lisp_Object frob2) +{ + signal_type_error_2 (Qinvalid_argument, reason, frob1, frob2); +} + +DOESNT_RETURN +invalid_operation (const char *reason, Lisp_Object frob) +{ + signal_type_error (Qinvalid_operation, reason, frob); +} + +DOESNT_RETURN +invalid_operation_2 (const char *reason, Lisp_Object frob1, Lisp_Object frob2) +{ + signal_type_error_2 (Qinvalid_operation, reason, frob1, frob2); +} + +DOESNT_RETURN +invalid_change (const char *reason, Lisp_Object frob) +{ + signal_type_error (Qinvalid_change, reason, frob); +} + +DOESNT_RETURN +invalid_change_2 (const char *reason, Lisp_Object frob1, Lisp_Object frob2) +{ + signal_type_error_2 (Qinvalid_change, reason, frob1, frob2); +} + + +/************************************************************************/ +/* User commands */ +/************************************************************************/ DEFUN ("commandp", Fcommandp, 1, 1, 0, /* Return t if FUNCTION makes provisions for interactive calling. @@ -2505,35 +2898,32 @@ Also, a symbol satisfies `commandp' if its function definition does so. { Lisp_Object fun = indirect_function (function, 0); - if (UNBOUNDP (fun)) - return Qnil; + if (COMPILED_FUNCTIONP (fun)) + return XCOMPILED_FUNCTION (fun)->flags.interactivep ? Qt : Qnil; + + /* Lists may represent commands. */ + if (CONSP (fun)) + { + Lisp_Object funcar = XCAR (fun); + if (EQ (funcar, Qlambda)) + return Fassq (Qinteractive, Fcdr (Fcdr (fun))); + if (EQ (funcar, Qautoload)) + return Fcar (Fcdr (Fcdr (Fcdr (fun)))); + else + return Qnil; + } /* Emacs primitives are interactive if their DEFUN specifies an interactive spec. */ if (SUBRP (fun)) return XSUBR (fun)->prompt ? Qt : Qnil; - if (COMPILED_FUNCTIONP (fun)) - return XCOMPILED_FUNCTION (fun)->flags.interactivep ? Qt : Qnil; - /* Strings and vectors are keyboard macros. */ if (VECTORP (fun) || STRINGP (fun)) return Qt; - /* Lists may represent commands. */ - if (!CONSP (fun)) - return Qnil; - { - Lisp_Object funcar = XCAR (fun); - if (!SYMBOLP (funcar)) - return Fsignal (Qinvalid_function, list1 (fun)); - if (EQ (funcar, Qlambda)) - return Fassq (Qinteractive, Fcdr (Fcdr (fun))); - if (EQ (funcar, Qautoload)) - return Fcar (Fcdr (Fcdr (Fcdr (fun)))); - else - return Qnil; - } + /* Everything else (including Qunbound) is not a command. */ + return Qnil; } DEFUN ("command-execute", Fcommand_execute, 1, 3, 0, /* @@ -2543,7 +2933,7 @@ Optional second arg RECORD-FLAG is as in `call-interactively'. The argument KEYS specifies the value to use instead of (this-command-keys) when reading the arguments. */ - (cmd, record, keys)) + (cmd, record_flag, keys)) { /* This function can GC */ Lisp_Object prefixarg; @@ -2563,25 +2953,25 @@ when reading the arguments. { final = indirect_function (cmd, 1); if (CONSP (final) && EQ (Fcar (final), Qautoload)) - do_autoload (final, cmd); + { + /* do_autoload GCPROs both arguments */ + do_autoload (final, cmd); + } else break; } if (CONSP (final) || SUBRP (final) || COMPILED_FUNCTIONP (final)) { -#ifdef EMACS_BTL - backtrace.id_number = 0; -#endif backtrace.function = &Qcall_interactively; backtrace.args = &cmd; backtrace.nargs = 1; backtrace.evalargs = 0; - backtrace.pdlcount = specpdl_depth_counter; + backtrace.pdlcount = specpdl_depth(); backtrace.debug_on_exit = 0; PUSH_BACKTRACE (backtrace); - final = Fcall_interactively (cmd, record, keys); + final = Fcall_interactively (cmd, record_flag, keys); POP_BACKTRACE (backtrace); return final; @@ -2594,7 +2984,7 @@ when reading the arguments. { Fsignal (Qwrong_type_argument, Fcons (Qcommandp, - ((EQ (cmd, final)) + (EQ (cmd, final) ? list1 (cmd) : list2 (cmd, final)))); return Qnil; @@ -2675,47 +3065,47 @@ and input is currently coming from the keyboard (not in keyboard macro). } -/**********************************************************************/ -/* Autoloading */ -/**********************************************************************/ +/************************************************************************/ +/* Autoloading */ +/************************************************************************/ DEFUN ("autoload", Fautoload, 2, 5, 0, /* -Define FUNCTION to autoload from FILE. -FUNCTION is a symbol; FILE is a file name string to pass to `load'. -Third arg DOCSTRING is documentation for the function. -Fourth arg INTERACTIVE if non-nil says function can be called interactively. -Fifth arg TYPE indicates the type of the object: +Define FUNCTION to autoload from FILENAME. +FUNCTION is a symbol; FILENAME is a file name string to pass to `load'. +The remaining optional arguments provide additional info about the +real definition. +DOCSTRING is documentation for FUNCTION. +INTERACTIVE, if non-nil, says FUNCTION can be called interactively. +TYPE indicates the type of the object: nil or omitted says FUNCTION is a function, `keymap' says FUNCTION is really a keymap, and `macro' or t says FUNCTION is really a macro. -Third through fifth args give info about the real definition. -They default to nil. -If FUNCTION is already defined other than as an autoload, -this does nothing and returns nil. +If FUNCTION already has a non-void function definition that is not an +autoload object, this function does nothing and returns nil. */ - (function, file, docstring, interactive, type)) + (function, filename, docstring, interactive, type)) { /* This function can GC */ CHECK_SYMBOL (function); - CHECK_STRING (file); + CHECK_STRING (filename); /* If function is defined and not as an autoload, don't override */ - if (!UNBOUNDP (XSYMBOL (function)->function) - && !(CONSP (XSYMBOL (function)->function) - && EQ (XCAR (XSYMBOL (function)->function), Qautoload))) - return Qnil; + { + Lisp_Object f = XSYMBOL (function)->function; + if (!UNBOUNDP (f) && !(CONSP (f) && EQ (XCAR (f), Qautoload))) + return Qnil; + } if (purify_flag) { /* Attempt to avoid consing identical (string=) pure strings. */ - file = Fsymbol_name (Fintern (file, Qnil)); + filename = Fsymbol_name (Fintern (filename, Qnil)); } - return Ffset (function, - Fpurecopy (Fcons (Qautoload, list4 (file, - docstring, - interactive, - type)))); + return Ffset (function, Fcons (Qautoload, list4 (filename, + docstring, + interactive, + type))); } Lisp_Object @@ -2730,7 +3120,7 @@ un_autoload (Lisp_Object oldqueue) Vautoload_queue = oldqueue; while (CONSP (queue)) { - first = Fcar (queue); + first = XCAR (queue); second = Fcdr (first); first = Fcar (first); if (NILP (second)) @@ -2747,39 +3137,35 @@ do_autoload (Lisp_Object fundef, Lisp_Object funname) { /* This function can GC */ - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); Lisp_Object fun = funname; - struct gcpro gcpro1, gcpro2; + struct gcpro gcpro1, gcpro2, gcpro3; CHECK_SYMBOL (funname); - GCPRO2 (fun, funname); + GCPRO3 (fun, funname, fundef); /* Value saved here is to be restored into Vautoload_queue */ record_unwind_protect (un_autoload, Vautoload_queue); Vautoload_queue = Qt; - call4 (Qload, Fcar (Fcdr (fundef)), Qnil, noninteractive ? Qt : Qnil, - Qnil); + call4 (Qload, Fcar (Fcdr (fundef)), Qnil, noninteractive ? Qt : Qnil, Qnil); { - Lisp_Object queue = Vautoload_queue; + Lisp_Object queue; /* Save the old autoloads, in case we ever do an unload. */ - queue = Vautoload_queue; - while (CONSP (queue)) - { - Lisp_Object first = Fcar (queue); - Lisp_Object second = Fcdr (first); - - first = Fcar (first); + for (queue = Vautoload_queue; CONSP (queue); queue = XCDR (queue)) + { + Lisp_Object first = XCAR (queue); + Lisp_Object second = Fcdr (first); - /* Note: This test is subtle. The cdr of an autoload-queue entry - may be an atom if the autoload entry was generated by a defalias - or fset. */ - if (CONSP (second)) - Fput (first, Qautoload, (Fcdr (second))); + first = Fcar (first); - queue = Fcdr (queue); - } + /* Note: This test is subtle. The cdr of an autoload-queue entry + may be an atom if the autoload entry was generated by a defalias + or fset. */ + if (CONSP (second)) + Fput (first, Qautoload, (XCDR (second))); + } } /* Once loading finishes, don't undo it. */ @@ -2801,14 +3187,12 @@ do_autoload (Lisp_Object fundef, } -/**********************************************************************/ -/* eval, funcall, apply */ -/**********************************************************************/ +/************************************************************************/ +/* eval, funcall, apply */ +/************************************************************************/ static Lisp_Object funcall_lambda (Lisp_Object fun, - int nargs, Lisp_Object args[]); -static Lisp_Object apply_lambda (Lisp_Object fun, - int nargs, Lisp_Object args); + int nargs, Lisp_Object args[]); static int in_warnings; static Lisp_Object @@ -2818,51 +3202,6 @@ in_warnings_restore (Lisp_Object minimus) return Qnil; } -#define AV_0(av) -#define AV_1(av) av[0] -#define AV_2(av) AV_1(av), av[1] -#define AV_3(av) AV_2(av), av[2] -#define AV_4(av) AV_3(av), av[3] -#define AV_5(av) AV_4(av), av[4] -#define AV_6(av) AV_5(av), av[5] -#define AV_7(av) AV_6(av), av[6] -#define AV_8(av) AV_7(av), av[7] - -#define PRIMITIVE_FUNCALL(fn, av, ac) \ -(((Lisp_Object (*)(EXFUN_##ac)) (fn)) (AV_##ac (av))) - -/* If subr's take more than 8 arguments, more cases need to be added - to this switch. (But don't do it - if you really need a SUBR with - more than 8 arguments, use max_args == MANY. - See the DEFUN macro in lisp.h) */ -#define inline_funcall_fn(rv, fn, av, ac) do { \ - switch (ac) { \ - case 0: rv = PRIMITIVE_FUNCALL(fn, av, 0); break; \ - case 1: rv = PRIMITIVE_FUNCALL(fn, av, 1); break; \ - case 2: rv = PRIMITIVE_FUNCALL(fn, av, 2); break; \ - case 3: rv = PRIMITIVE_FUNCALL(fn, av, 3); break; \ - case 4: rv = PRIMITIVE_FUNCALL(fn, av, 4); break; \ - case 5: rv = PRIMITIVE_FUNCALL(fn, av, 5); break; \ - case 6: rv = PRIMITIVE_FUNCALL(fn, av, 6); break; \ - case 7: rv = PRIMITIVE_FUNCALL(fn, av, 7); break; \ - case 8: rv = PRIMITIVE_FUNCALL(fn, av, 8); break; \ - default: abort(); rv = Qnil; break; \ - } \ -} while (0) - -#define inline_funcall_subr(rv, subr, av) do { \ - void (*fn)() = (void (*)()) (subr_function(subr)); \ - inline_funcall_fn (rv, fn, av, subr->max_args); \ -} while (0) - -static Lisp_Object -primitive_funcall (lisp_fn_t fn, int nargs, Lisp_Object args[]) -{ - Lisp_Object rv; - inline_funcall_fn (rv, fn, args, nargs); - return rv; -} - DEFUN ("eval", Feval, 1, 1, 0, /* Evaluate FORM and return its value. */ @@ -2877,7 +3216,7 @@ Evaluate FORM and return its value. while (!in_warnings && !NILP (Vpending_warnings)) { struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); Lisp_Object this_warning_cons, this_warning, class, level, messij; record_unwind_protect (in_warnings_restore, Qnil); @@ -2905,11 +3244,13 @@ Evaluate FORM and return its value. unbind_to (speccount, Qnil); } - if (SYMBOLP (form)) - return Fsymbol_value (form); - if (!CONSP (form)) - return form; + { + if (SYMBOLP (form)) + return Fsymbol_value (form); + else + return form; + } QUIT; if ((consing_since_gc > gc_cons_threshold) || always_gc) @@ -2928,34 +3269,13 @@ Evaluate FORM and return its value. error ("Lisp nesting exceeds `max-lisp-eval-depth'"); } - /* - * At this point we know that `form' is a Lisp_Cons so we can safely - * use XCAR and XCDR. - */ - original_fun = XCAR (form); + /* We guaranteed CONSP (form) above */ + original_fun = XCAR (form); original_args = XCDR (form); - /* - * Formerly we used a call to Flength here, but that is slow and - * wasteful due to type checking, stack push/pop and initialization. - * We know we're dealing with a cons, so open code it for speed. - * - * We call QUIT in the loop so that a circular arg list won't lock - * up the editor. - */ - for (nargs = 0, val = original_args ; CONSP (val) ; val = XCDR (val)) - { - nargs++; - QUIT; - } - if (! NILP (val)) - signal_simple_error ("Argument list must be nil-terminated", - original_args); + GET_EXTERNAL_LIST_LENGTH (original_args, nargs); -#ifdef EMACS_BTL - backtrace.id_number = 0; -#endif - backtrace.pdlcount = specpdl_depth_counter; + backtrace.pdlcount = specpdl_depth(); backtrace.function = &original_fun; /* This also protects them from gc */ backtrace.args = &original_args; backtrace.nargs = UNEVALLED; @@ -2970,125 +3290,170 @@ Evaluate FORM and return its value. profile_increase_call_count (original_fun); /* At this point, only original_fun and original_args - have values that will be used below */ + have values that will be used below. */ retry: fun = indirect_function (original_fun, 1); if (SUBRP (fun)) { - struct Lisp_Subr *subr = XSUBR (fun); + Lisp_Subr *subr = XSUBR (fun); int max_args = subr->max_args; - Lisp_Object argvals[SUBR_MAX_ARGS]; - Lisp_Object args_left; - REGISTER int i; - - args_left = original_args; - if (nargs < subr->min_args - || (max_args >= 0 && max_args < nargs)) - { - return Fsignal (Qwrong_number_of_arguments, - list2 (fun, make_int (nargs))); - } + if (nargs < subr->min_args) + goto wrong_number_of_arguments; - if (max_args == UNEVALLED) + if (max_args == UNEVALLED) /* Optimize for the common case */ { backtrace.evalargs = 0; - val = ((Lisp_Object (*) (Lisp_Object)) (subr_function (subr))) (args_left); + val = (((Lisp_Object (*) (Lisp_Object)) subr_function (subr)) + (original_args)); } + else if (nargs <= max_args) + { + struct gcpro gcpro1; + Lisp_Object args[SUBR_MAX_ARGS]; + REGISTER Lisp_Object *p = args; + + GCPRO1 (args[0]); + gcpro1.nvars = 0; + + { + LIST_LOOP_2 (arg, original_args) + { + *p++ = Feval (arg); + gcpro1.nvars++; + } + } + + /* &optional args default to nil. */ + while (p - args < max_args) + *p++ = Qnil; + + backtrace.args = args; + backtrace.nargs = nargs; + + FUNCALL_SUBR (val, subr, args, max_args); + UNGCPRO; + } else if (max_args == MANY) { /* Pass a vector of evaluated arguments */ - Lisp_Object *vals; - REGISTER int argnum; - struct gcpro gcpro1, gcpro2, gcpro3; - - vals = alloca_array (Lisp_Object, nargs); - - GCPRO3 (args_left, fun, vals[0]); - gcpro3.nvars = 0; - - argnum = 0; - while (CONSP (args_left)) - { - vals[argnum++] = Feval (XCAR (args_left)); - args_left = XCDR (args_left); - gcpro3.nvars = argnum; - } - - backtrace.args = vals; + struct gcpro gcpro1; + Lisp_Object *args = alloca_array (Lisp_Object, nargs); + REGISTER Lisp_Object *p = args; + + GCPRO1 (args[0]); + gcpro1.nvars = 0; + + { + LIST_LOOP_2 (arg, original_args) + { + *p++ = Feval (arg); + gcpro1.nvars++; + } + } + + backtrace.args = args; backtrace.nargs = nargs; - val = ((Lisp_Object (*) (int, Lisp_Object *)) (subr_function (subr))) - (nargs, vals); - - /* Have to duplicate this code because if the - * debugger is called it must be in a scope in - * which the `alloca'-ed data in vals is still valid. - * (And GC-protected.) - */ - lisp_eval_depth--; - if (backtrace.debug_on_exit) - val = do_debug_on_exit (val); - POP_BACKTRACE (backtrace); + val = (((Lisp_Object (*) (int, Lisp_Object *)) subr_function (subr)) + (nargs, args)); + UNGCPRO; - return val; } - else - { - struct gcpro gcpro1, gcpro2, gcpro3; + { + wrong_number_of_arguments: + val = signal_wrong_number_of_arguments_error (original_fun, nargs); + } + } + else if (COMPILED_FUNCTIONP (fun)) + { + struct gcpro gcpro1; + Lisp_Object *args = alloca_array (Lisp_Object, nargs); + REGISTER Lisp_Object *p = args; - GCPRO3 (args_left, fun, fun); - gcpro3.var = argvals; - gcpro3.nvars = 0; + GCPRO1 (args[0]); + gcpro1.nvars = 0; - for (i = 0; i < nargs; args_left = XCDR (args_left)) - { - argvals[i] = Feval (XCAR (args_left)); - gcpro3.nvars = ++i; - } + { + LIST_LOOP_2 (arg, original_args) + { + *p++ = Feval (arg); + gcpro1.nvars++; + } + } - UNGCPRO; + backtrace.args = args; + backtrace.nargs = nargs; + backtrace.evalargs = 0; - /* i == nargs at this point */ - for (; i < max_args; i++) - argvals[i] = Qnil; + val = funcall_compiled_function (fun, nargs, args); - backtrace.args = argvals; - backtrace.nargs = nargs; + /* Do the debug-on-exit now, while args is still GCPROed. */ + if (backtrace.debug_on_exit) + val = do_debug_on_exit (val); + /* Don't do it again when we return to eval. */ + backtrace.debug_on_exit = 0; - /* val = funcall_subr (subr, argvals); */ - inline_funcall_subr (val, subr, argvals); - } + UNGCPRO; } - else if (COMPILED_FUNCTIONP (fun)) - val = apply_lambda (fun, nargs, original_args); - else + else if (CONSP (fun)) { - Lisp_Object funcar; + Lisp_Object funcar = XCAR (fun); - if (!CONSP (fun)) - goto invalid_function; - funcar = XCAR (fun); - if (!SYMBOLP (funcar)) - goto invalid_function; if (EQ (funcar, Qautoload)) { + /* do_autoload GCPROs both arguments */ do_autoload (fun, original_fun); goto retry; } - if (EQ (funcar, Qmacro)) - val = Feval (apply1 (XCDR (fun), original_args)); + else if (EQ (funcar, Qmacro)) + { + val = Feval (apply1 (XCDR (fun), original_args)); + } else if (EQ (funcar, Qlambda)) - val = apply_lambda (fun, nargs, original_args); + { + struct gcpro gcpro1; + Lisp_Object *args = alloca_array (Lisp_Object, nargs); + REGISTER Lisp_Object *p = args; + + GCPRO1 (args[0]); + gcpro1.nvars = 0; + + { + LIST_LOOP_2 (arg, original_args) + { + *p++ = Feval (arg); + gcpro1.nvars++; + } + } + + UNGCPRO; + + backtrace.args = args; /* this also GCPROs `args' */ + backtrace.nargs = nargs; + backtrace.evalargs = 0; + + val = funcall_lambda (fun, nargs, args); + + /* Do the debug-on-exit now, while args is still GCPROed. */ + if (backtrace.debug_on_exit) + val = do_debug_on_exit (val); + /* Don't do it again when we return to eval. */ + backtrace.debug_on_exit = 0; + } else { - invalid_function: - return Fsignal (Qinvalid_function, list1 (fun)); + goto invalid_function; } } + else /* ! (SUBRP (fun) || COMPILED_FUNCTIONP (fun) || CONSP (fun)) */ + { + invalid_function: + val = signal_invalid_function_error (fun); + } lisp_eval_depth--; if (backtrace.debug_on_exit) @@ -3098,15 +3463,19 @@ Evaluate FORM and return its value. } -Lisp_Object -funcall_recording_as (Lisp_Object recorded_as, int nargs, - Lisp_Object *args) +/* #### Why is Feval so anal about GCPRO, Ffuncall so cavalier? */ +DEFUN ("funcall", Ffuncall, 1, MANY, 0, /* +Call first argument as a function, passing the remaining arguments to it. +Thus, (funcall 'cons 'x 'y) returns (x . y). +*/ + (int nargs, Lisp_Object *args)) { /* This function can GC */ Lisp_Object fun; Lisp_Object val; struct backtrace backtrace; - REGISTER int i; + int fun_nargs = nargs - 1; + Lisp_Object *fun_args = args + 1; QUIT; if ((consing_since_gc > gc_cons_threshold) || always_gc) @@ -3121,16 +3490,10 @@ funcall_recording_as (Lisp_Object recorded_as, int nargs, error ("Lisp nesting exceeds `max-lisp-eval-depth'"); } - /* Count number of arguments to function */ - nargs = nargs - 1; - -#ifdef EMACS_BTL - backtrace.id_number = 0; -#endif - backtrace.pdlcount = specpdl_depth_counter; + backtrace.pdlcount = specpdl_depth(); backtrace.function = &args[0]; - backtrace.args = &args[1]; - backtrace.nargs = nargs; + backtrace.args = fun_args; + backtrace.nargs = fun_nargs; backtrace.evalargs = 0; backtrace.debug_on_exit = 0; PUSH_BACKTRACE (backtrace); @@ -3142,86 +3505,101 @@ funcall_recording_as (Lisp_Object recorded_as, int nargs, fun = args[0]; -#ifdef EMACS_BTL - { - extern int emacs_btl_elisp_only_p; - extern int btl_symbol_id_number (); - if (emacs_btl_elisp_only_p) - backtrace.id_number = btl_symbol_id_number (fun); - } -#endif - /* It might be useful to place this *after* all the checks. */ if (profiling_active) profile_increase_call_count (fun); + /* We could call indirect_function directly, but profiling shows + this is worth optimizing by partially unrolling the loop. */ if (SYMBOLP (fun)) - fun = indirect_function (fun, 1); + { + fun = XSYMBOL (fun)->function; + if (SYMBOLP (fun)) + { + fun = XSYMBOL (fun)->function; + if (SYMBOLP (fun)) + fun = indirect_function (fun, 1); + } + } if (SUBRP (fun)) { - struct Lisp_Subr *subr = XSUBR (fun); + Lisp_Subr *subr = XSUBR (fun); int max_args = subr->max_args; + Lisp_Object spacious_args[SUBR_MAX_ARGS]; - if (max_args == UNEVALLED) - return Fsignal (Qinvalid_function, list1 (fun)); - - if (nargs < subr->min_args - || (max_args >= 0 && max_args < nargs)) + if (fun_nargs == max_args) /* Optimize for the common case */ { - return Fsignal (Qwrong_number_of_arguments, - list2 (fun, make_int (nargs))); + funcall_subr: + { + /* The "extra" braces placate GCC 2.95.4. */ + FUNCALL_SUBR (val, subr, fun_args, max_args); + } } - - if (max_args == MANY) + else if (fun_nargs < subr->min_args) { - val = ((Lisp_Object (*) (int, Lisp_Object *)) (subr_function (subr))) - (nargs, args + 1); + goto wrong_number_of_arguments; } - - else if (max_args > nargs) + else if (fun_nargs < max_args) { - Lisp_Object argvals[SUBR_MAX_ARGS]; + Lisp_Object *p = spacious_args; /* Default optionals to nil */ - for (i = 0; i < nargs; i++) - argvals[i] = args[i + 1]; - for (i = nargs; i < max_args; i++) - argvals[i] = Qnil; + while (fun_nargs--) + *p++ = *fun_args++; + while (p - spacious_args < max_args) + *p++ = Qnil; - /* val = funcall_subr (subr, argvals); */ - inline_funcall_subr (val, subr, argvals); + fun_args = spacious_args; + goto funcall_subr; + } + else if (max_args == MANY) + { + val = SUBR_FUNCTION (subr, MANY) (fun_nargs, fun_args); + } + else if (max_args == UNEVALLED) /* Can't funcall a special form */ + { + goto invalid_function; } else - /* val = funcall_subr (subr, args + 1); */ - inline_funcall_subr (val, subr, (&args[1])); + { + wrong_number_of_arguments: + val = signal_wrong_number_of_arguments_error (fun, fun_nargs); + } } else if (COMPILED_FUNCTIONP (fun)) - val = funcall_lambda (fun, nargs, args + 1); - else if (!CONSP (fun)) { - invalid_function: - return Fsignal (Qinvalid_function, list1 (fun)); + val = funcall_compiled_function (fun, fun_nargs, fun_args); } - else + else if (CONSP (fun)) { - /* `fun' is a Lisp_Cons so XCAR is safe */ Lisp_Object funcar = XCAR (fun); - if (!SYMBOLP (funcar)) - goto invalid_function; if (EQ (funcar, Qlambda)) - val = funcall_lambda (fun, nargs, args + 1); + { + val = funcall_lambda (fun, fun_nargs, fun_args); + } else if (EQ (funcar, Qautoload)) { + /* do_autoload GCPROs both arguments */ do_autoload (fun, args[0]); goto retry; } - else + else /* Can't funcall a macro */ { - goto invalid_function; + goto invalid_function; } } + else if (UNBOUNDP (fun)) + { + val = signal_void_function_error (args[0]); + } + else + { + invalid_function: + val = signal_invalid_function_error (fun); + } + lisp_eval_depth--; if (backtrace.debug_on_exit) val = do_debug_on_exit (val); @@ -3229,25 +3607,30 @@ funcall_recording_as (Lisp_Object recorded_as, int nargs, return val; } -DEFUN ("funcall", Ffuncall, 1, MANY, 0, /* -Call first argument as a function, passing remaining arguments to it. -Thus, (funcall 'cons 'x 'y) returns (x . y). +DEFUN ("functionp", Ffunctionp, 1, 1, 0, /* +Return t if OBJECT can be called as a function, else nil. +A function is an object that can be applied to arguments, +using for example `funcall' or `apply'. */ - (int nargs, Lisp_Object *args)) + (object)) { - return funcall_recording_as (args[0], nargs, args); + if (SYMBOLP (object)) + object = indirect_function (object, 0); + + return + (SUBRP (object) || + COMPILED_FUNCTIONP (object) || + (CONSP (object) && + (EQ (XCAR (object), Qlambda) || + EQ (XCAR (object), Qautoload)))) + ? Qt : Qnil; } -DEFUN ("function-min-args", Ffunction_min_args, 1, 1, 0, /* -Return the number of arguments a function may be called with. The -function may be any form that can be passed to `funcall', any special -form, or any macro. -*/ - (function)) +static Lisp_Object +function_argcount (Lisp_Object function, int function_min_args_p) { Lisp_Object orig_function = function; Lisp_Object arglist; - int argcount; retry: @@ -3255,148 +3638,111 @@ form, or any macro. function = indirect_function (function, 1); if (SUBRP (function)) - return Fsubr_min_args (function); - else if (!COMPILED_FUNCTIONP (function) && !CONSP (function)) { - invalid_function: - return Fsignal (Qinvalid_function, list1 (function)); + /* Using return with the ?: operator tickles a DEC CC compiler bug. */ + if (function_min_args_p) + return Fsubr_min_args (function); + else + return Fsubr_max_args (function); + } + else if (COMPILED_FUNCTIONP (function)) + { + arglist = compiled_function_arglist (XCOMPILED_FUNCTION (function)); } - - if (CONSP (function)) + else if (CONSP (function)) { Lisp_Object funcar = XCAR (function); - if (!SYMBOLP (funcar)) - goto invalid_function; if (EQ (funcar, Qmacro)) { function = XCDR (function); goto retry; } - if (EQ (funcar, Qautoload)) + else if (EQ (funcar, Qautoload)) { + /* do_autoload GCPROs both arguments */ do_autoload (function, orig_function); + function = orig_function; goto retry; } - if (EQ (funcar, Qlambda)) - arglist = Fcar (XCDR (function)); + else if (EQ (funcar, Qlambda)) + { + arglist = Fcar (XCDR (function)); + } else - goto invalid_function; + { + goto invalid_function; + } } else - arglist = XCOMPILED_FUNCTION (function)->arglist; - - argcount = 0; - while (!NILP (arglist)) { - QUIT; - if (EQ (Fcar (arglist), Qand_optional) - || EQ (Fcar (arglist), Qand_rest)) - break; - argcount++; - arglist = Fcdr (arglist); + invalid_function: + return signal_invalid_function_error (orig_function); } - return make_int (argcount); + { + int argcount = 0; + + EXTERNAL_LIST_LOOP_2 (arg, arglist) + { + if (EQ (arg, Qand_optional)) + { + if (function_min_args_p) + break; + } + else if (EQ (arg, Qand_rest)) + { + if (function_min_args_p) + break; + else + return Qnil; + } + else + { + argcount++; + } + } + + return make_int (argcount); + } } -DEFUN ("function-max-args", Ffunction_max_args, 1, 1, 0, /* -Return the number of arguments a function may be called with. If the -function takes an arbitrary number of arguments or is a built-in -special form, nil is returned. The function may be any form that can -be passed to `funcall', any special form, or any macro. +DEFUN ("function-min-args", Ffunction_min_args, 1, 1, 0, /* +Return the number of arguments a function may be called with. +The function may be any form that can be passed to `funcall', +any special form, or any macro. */ (function)) { - Lisp_Object orig_function = function; - Lisp_Object arglist; - int argcount; - - retry: - - if (SYMBOLP (function)) - function = indirect_function (function, 1); - - if (SUBRP (function)) - return Fsubr_max_args (function); - else if (!COMPILED_FUNCTIONP (function) && !CONSP (function)) - { - invalid_function: - return Fsignal (Qinvalid_function, list1 (function)); - } - - if (CONSP (function)) - { - Lisp_Object funcar = XCAR (function); - - if (!SYMBOLP (funcar)) - goto invalid_function; - if (EQ (funcar, Qmacro)) - { - function = XCDR (function); - goto retry; - } - if (EQ (funcar, Qautoload)) - { - do_autoload (function, orig_function); - goto retry; - } - if (EQ (funcar, Qlambda)) - arglist = Fcar (XCDR (function)); - else - goto invalid_function; - } - else - arglist = XCOMPILED_FUNCTION (function)->arglist; - - argcount = 0; - while (!NILP (arglist)) - { - QUIT; - if (EQ (Fcar (arglist), Qand_optional)) - { - arglist = Fcdr (arglist); - continue; - } - if (EQ (Fcar (arglist), Qand_rest)) - return Qnil; - argcount++; - arglist = Fcdr (arglist); - } + return function_argcount (function, 1); +} - return make_int (argcount); +DEFUN ("function-max-args", Ffunction_max_args, 1, 1, 0, /* +Return the number of arguments a function may be called with. +The function may be any form that can be passed to `funcall', +any special form, or any macro. +If the function takes an arbitrary number of arguments or is +a built-in special form, nil is returned. +*/ + (function)) +{ + return function_argcount (function, 0); } DEFUN ("apply", Fapply, 2, MANY, 0, /* -Call FUNCTION with our remaining args, using our last arg as list of args. +Call FUNCTION with the remaining args, using the last arg as a list of args. Thus, (apply '+ 1 2 '(3 4)) returns 10. */ (int nargs, Lisp_Object *args)) { /* This function can GC */ Lisp_Object fun = args[0]; - Lisp_Object spread_arg = args [nargs - 1], p; + Lisp_Object spread_arg = args [nargs - 1]; int numargs; int funcall_nargs; - CHECK_LIST (spread_arg); - - /* - * Formerly we used a call to Flength here, but that is slow and - * wasteful due to type checking, stack push/pop and initialization. - * We know we're dealing with a cons, so open code it for speed. - * - * We call QUIT in the loop so that a circular arg list won't lock - * up the editor. - */ - for (numargs = 0, p = spread_arg ; CONSP (p) ; p = XCDR (p)) - { - numargs++; - QUIT; - } - if (! NILP (p)) - signal_simple_error ("Argument list must be nil-terminated", spread_arg); + GET_EXTERNAL_LIST_LENGTH (spread_arg, numargs); if (numargs == 0) /* (apply foo 0 1 '()) */ @@ -3415,14 +3761,10 @@ Thus, (apply '+ 1 2 '(3 4)) returns 10. if (SYMBOLP (fun)) fun = indirect_function (fun, 0); - if (UNBOUNDP (fun)) - { - /* Let funcall get the error */ - fun = args[0]; - } - else if (SUBRP (fun)) + + if (SUBRP (fun)) { - struct Lisp_Subr *subr = XSUBR (fun); + Lisp_Subr *subr = XSUBR (fun); int max_args = subr->max_args; if (numargs < subr->min_args @@ -3437,6 +3779,12 @@ Thus, (apply '+ 1 2 '(3 4)) returns 10. funcall_nargs += (max_args - numargs); } } + else if (UNBOUNDP (fun)) + { + /* Let funcall get the error */ + fun = args[0]; + } + { REGISTER int i; Lisp_Object *funcall_args = alloca_array (Lisp_Object, funcall_nargs); @@ -3465,145 +3813,66 @@ Thus, (apply '+ 1 2 '(3 4)) returns 10. } -/* FSFmacs has an extra arg EVAL_FLAG. If false, some of - the statements below are not done. But it's always true - in all the calls to apply_lambda(). */ +/* Apply lambda list FUN to the NARGS evaluated arguments in ARGS and + return the result of evaluation. */ static Lisp_Object -apply_lambda (Lisp_Object fun, int numargs, Lisp_Object unevalled_args) +funcall_lambda (Lisp_Object fun, int nargs, Lisp_Object args[]) { /* This function can GC */ - struct gcpro gcpro1, gcpro2, gcpro3; - REGISTER int i; - REGISTER Lisp_Object tem; - REGISTER Lisp_Object *arg_vector = alloca_array (Lisp_Object, numargs); - - GCPRO3 (*arg_vector, unevalled_args, fun); - gcpro1.nvars = 0; - - for (i = 0; i < numargs;) - { - /* - * unevalled_args is always a normal list, or Feval would have - * rejected it, so use XCAR and XCDR. - */ - tem = XCAR (unevalled_args), unevalled_args = XCDR (unevalled_args); - tem = Feval (tem); - arg_vector[i++] = tem; - gcpro1.nvars = i; - } - - UNGCPRO; + Lisp_Object arglist, body, tail; + int speccount = specpdl_depth(); + REGISTER int i = 0; - backtrace_list->args = arg_vector; - backtrace_list->nargs = i; - backtrace_list->evalargs = 0; - tem = funcall_lambda (fun, numargs, arg_vector); + tail = XCDR (fun); - /* Do the debug-on-exit now, while arg_vector still exists. */ - if (backtrace_list->debug_on_exit) - tem = do_debug_on_exit (tem); - /* Don't do it again when we return to eval. */ - backtrace_list->debug_on_exit = 0; - return tem; -} + if (!CONSP (tail)) + goto invalid_function; -DEFUN ("fetch-bytecode", Ffetch_bytecode, 1, 1, 0, /* -If byte-compiled OBJECT is lazy-loaded, fetch it now. -*/ - (object)) -{ - if (COMPILED_FUNCTIONP (object) - && CONSP (XCOMPILED_FUNCTION (object)->bytecodes)) - { - Lisp_Object tem = - read_doc_string (XCOMPILED_FUNCTION (object)->bytecodes); - if (!CONSP (tem)) - signal_simple_error ("invalid lazy-loaded byte code", tem); - /* v18 or v19 bytecode file. Need to Ebolify. */ - if (XCOMPILED_FUNCTION (object)->flags.ebolified - && VECTORP (XCDR (tem))) - ebolify_bytecode_constants (XCDR (tem)); - /* VERY IMPORTANT to purecopy here!!!!! - See load_force_doc_string_unwind. */ - XCOMPILED_FUNCTION (object)->bytecodes = Fpurecopy (XCAR (tem)); - XCOMPILED_FUNCTION (object)->constants = Fpurecopy (XCDR (tem)); - } - return object; -} + arglist = XCAR (tail); + body = XCDR (tail); -/* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR - and return the result of evaluation. - FUN must be either a lambda-expression or a compiled-code object. */ + { + int optional = 0, rest = 0; -static Lisp_Object -funcall_lambda (Lisp_Object fun, int nargs, Lisp_Object arg_vector[]) -{ - /* This function can GC */ - Lisp_Object val, tem; - REGISTER Lisp_Object syms_left; - REGISTER Lisp_Object next; - int speccount = specpdl_depth_counter; - REGISTER int i; - int optional = 0, rest = 0; + EXTERNAL_LIST_LOOP_2 (symbol, arglist) + { + if (!SYMBOLP (symbol)) + goto invalid_function; + if (EQ (symbol, Qand_rest)) + rest = 1; + else if (EQ (symbol, Qand_optional)) + optional = 1; + else if (rest) + { + specbind (symbol, Flist (nargs - i, &args[i])); + i = nargs; + } + else if (i < nargs) + specbind (symbol, args[i++]); + else if (!optional) + goto wrong_number_of_arguments; + else + specbind (symbol, Qnil); + } + } - if (CONSP (fun)) - syms_left = Fcar (XCDR (fun)); - else if (COMPILED_FUNCTIONP (fun)) - syms_left = XCOMPILED_FUNCTION (fun)->arglist; - else abort (); + if (i < nargs) + goto wrong_number_of_arguments; - i = 0; - for (; CONSP (syms_left); syms_left = XCDR (syms_left)) - { - QUIT; - next = XCAR (syms_left); - if (!SYMBOLP (next)) - signal_error (Qinvalid_function, list1 (fun)); - if (EQ (next, Qand_rest)) - rest = 1; - else if (EQ (next, Qand_optional)) - optional = 1; - else if (rest) - { - specbind (next, Flist (nargs - i, &arg_vector[i])); - i = nargs; - } - else if (i < nargs) - { - tem = arg_vector[i++]; - specbind (next, tem); - } - else if (!optional) - return Fsignal (Qwrong_number_of_arguments, - list2 (fun, make_int (nargs))); - else - specbind (next, Qnil); - } + return unbind_to (speccount, Fprogn (body)); - if (i < nargs) - return Fsignal (Qwrong_number_of_arguments, - list2 (fun, make_int (nargs))); + wrong_number_of_arguments: + return signal_wrong_number_of_arguments_error (fun, nargs); - if (CONSP (fun)) - val = Fprogn (Fcdr (XCDR (fun))); - else - { - struct Lisp_Compiled_Function *b = XCOMPILED_FUNCTION (fun); - /* If we have not actually read the bytecode string - and constants vector yet, fetch them from the file. */ - if (CONSP (b->bytecodes)) - Ffetch_bytecode (fun); - val = Fbyte_code (b->bytecodes, - b->constants, - make_int (b->maxdepth)); - } - return unbind_to (speccount, val); + invalid_function: + return signal_invalid_function_error (fun); } + -/**********************************************************************/ -/* Run hook variables in various ways. */ -/**********************************************************************/ +/************************************************************************/ +/* Run hook variables in various ways. */ +/************************************************************************/ DEFUN ("run-hooks", Frun_hooks, 1, MANY, 0, /* Run each hook in HOOKS. Major mode functions use this. @@ -3635,7 +3904,7 @@ called to run the hook. If the value is a function, it is called with the given arguments and its return value is returned. If it is a list of functions, those functions are called, in order, with the given arguments ARGS. -It is best not to depend on the value return by `run-hook-with-args', +It is best not to depend on the value returned by `run-hook-with-args', as that may change. To make a hook variable buffer-local, use `make-local-hook', @@ -3691,7 +3960,6 @@ run_hook_with_args_in_buffer (struct buffer *buf, int nargs, Lisp_Object *args, enum run_hooks_condition cond) { Lisp_Object sym, val, ret; - struct gcpro gcpro1, gcpro2; if (!initialized || preparing_for_armageddon) /* We need to bail out of here pronto. */ @@ -3714,7 +3982,9 @@ run_hook_with_args_in_buffer (struct buffer *buf, int nargs, Lisp_Object *args, } else { - GCPRO2 (sym, val); + struct gcpro gcpro1, gcpro2, gcpro3; + Lisp_Object globals = Qnil; + GCPRO3 (sym, val, globals); for (; CONSP (val) && ((cond == RUN_HOOKS_TO_COMPLETION) @@ -3726,7 +3996,7 @@ run_hook_with_args_in_buffer (struct buffer *buf, int nargs, Lisp_Object *args, { /* t indicates this hook has a local binding; it means to run the global binding too. */ - Lisp_Object globals = Fdefault_value (sym); + globals = Fdefault_value (sym); if ((! CONSP (globals) || EQ (XCAR (globals), Qlambda)) && ! NILP (globals)) @@ -3784,11 +4054,10 @@ run_hook_with_args (int nargs, Lisp_Object *args, Lisp_Object run_hook_list_with_args (Lisp_Object funlist, int nargs, Lisp_Object *args) { - Lisp_Object sym; + Lisp_Object sym = args[0]; Lisp_Object val; struct gcpro gcpro1, gcpro2; - sym = args[0]; GCPRO2 (sym, val); for (val = funlist; CONSP (val); val = XCDR (val)) @@ -3874,9 +4143,9 @@ run_hook (Lisp_Object hook) } -/**********************************************************************/ -/* Front-ends to eval, funcall, apply */ -/**********************************************************************/ +/************************************************************************/ +/* Front-ends to eval, funcall, apply */ +/************************************************************************/ /* Apply fn to arg */ Lisp_Object @@ -4066,7 +4335,7 @@ call0_in_buffer (struct buffer *buf, Lisp_Object fn) else { Lisp_Object val; - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); set_buffer_internal (buf); val = call0 (fn); @@ -4084,7 +4353,7 @@ call1_in_buffer (struct buffer *buf, Lisp_Object fn, else { Lisp_Object val; - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); set_buffer_internal (buf); val = call1 (fn, arg0); @@ -4102,7 +4371,7 @@ call2_in_buffer (struct buffer *buf, Lisp_Object fn, else { Lisp_Object val; - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); set_buffer_internal (buf); val = call2 (fn, arg0, arg1); @@ -4120,7 +4389,7 @@ call3_in_buffer (struct buffer *buf, Lisp_Object fn, else { Lisp_Object val; - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); set_buffer_internal (buf); val = call3 (fn, arg0, arg1, arg2); @@ -4139,7 +4408,7 @@ call4_in_buffer (struct buffer *buf, Lisp_Object fn, else { Lisp_Object val; - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); set_buffer_internal (buf); val = call4 (fn, arg0, arg1, arg2, arg3); @@ -4156,7 +4425,7 @@ eval_in_buffer (struct buffer *buf, Lisp_Object form) else { Lisp_Object val; - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); set_buffer_internal (buf); val = Feval (form); @@ -4166,7 +4435,9 @@ eval_in_buffer (struct buffer *buf, Lisp_Object form) } -/***** Error-catching front-ends to eval, funcall, apply */ +/************************************************************************/ +/* Error-catching front-ends to eval, funcall, apply */ +/************************************************************************/ /* Call function fn on no arguments, with condition handler */ Lisp_Object @@ -4233,7 +4504,7 @@ caught_a_squirmer (Lisp_Object errordata, Lisp_Object arg) args[1] = errordata; warn_when_safe_lispobj (Qerror, Qwarning, - emacs_doprnt_string_lisp ((CONST Bufbyte *) "%s: %s", + emacs_doprnt_string_lisp ((const Bufbyte *) "%s: %s", Qnil, -1, 2, args)); } return Qunbound; @@ -4276,10 +4547,10 @@ catch_them_squirmers_eval_in_buffer (Lisp_Object cons) } Lisp_Object -eval_in_buffer_trapping_errors (CONST char *warning_string, +eval_in_buffer_trapping_errors (const char *warning_string, struct buffer *buf, Lisp_Object form) { - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); Lisp_Object tem; Lisp_Object buffer; Lisp_Object cons; @@ -4292,14 +4563,14 @@ eval_in_buffer_trapping_errors (CONST char *warning_string, /* gc_currently_forbidden = 1; Currently no reason to do this; */ cons = noseeum_cons (buffer, form); - opaque = (warning_string ? make_opaque_ptr (warning_string) : Qnil); + opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil); GCPRO2 (cons, opaque); /* Qerror not Qt, so you can get a backtrace */ tem = condition_case_1 (Qerror, catch_them_squirmers_eval_in_buffer, cons, caught_a_squirmer, opaque); free_cons (XCONS (cons)); - if (OPAQUEP (opaque)) + if (OPAQUE_PTRP (opaque)) free_opaque_ptr (opaque); UNGCPRO; @@ -4316,7 +4587,7 @@ catch_them_squirmers_run_hook (Lisp_Object hook_symbol) } Lisp_Object -run_hook_trapping_errors (CONST char *warning_string, Lisp_Object hook_symbol) +run_hook_trapping_errors (const char *warning_string, Lisp_Object hook_symbol) { int speccount; Lisp_Object tem; @@ -4329,16 +4600,16 @@ run_hook_trapping_errors (CONST char *warning_string, Lisp_Object hook_symbol) if (NILP (tem) || UNBOUNDP (tem)) return Qnil; - speccount = specpdl_depth_counter; + speccount = specpdl_depth(); specbind (Qinhibit_quit, Qt); - opaque = (warning_string ? make_opaque_ptr (warning_string) : Qnil); + opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil); GCPRO1 (opaque); /* Qerror not Qt, so you can get a backtrace */ tem = condition_case_1 (Qerror, catch_them_squirmers_run_hook, hook_symbol, caught_a_squirmer, opaque); - if (OPAQUEP (opaque)) + if (OPAQUE_PTRP (opaque)) free_opaque_ptr (opaque); UNGCPRO; @@ -4349,11 +4620,11 @@ run_hook_trapping_errors (CONST char *warning_string, Lisp_Object hook_symbol) if an error occurs. */ Lisp_Object -safe_run_hook_trapping_errors (CONST char *warning_string, +safe_run_hook_trapping_errors (const char *warning_string, Lisp_Object hook_symbol, int allow_quit) { - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); Lisp_Object tem; Lisp_Object cons = Qnil; struct gcpro gcpro1; @@ -4368,7 +4639,7 @@ safe_run_hook_trapping_errors (CONST char *warning_string, specbind (Qinhibit_quit, Qt); cons = noseeum_cons (hook_symbol, - warning_string ? make_opaque_ptr (warning_string) + warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil); GCPRO1 (cons); /* Qerror not Qt, so you can get a backtrace */ @@ -4379,7 +4650,7 @@ safe_run_hook_trapping_errors (CONST char *warning_string, allow_quit_safe_run_hook_caught_a_squirmer : safe_run_hook_caught_a_squirmer, cons); - if (OPAQUEP (XCDR (cons))) + if (OPAQUE_PTRP (XCDR (cons))) free_opaque_ptr (XCDR (cons)); free_cons (XCONS (cons)); UNGCPRO; @@ -4395,7 +4666,7 @@ catch_them_squirmers_call0 (Lisp_Object function) } Lisp_Object -call0_trapping_errors (CONST char *warning_string, Lisp_Object function) +call0_trapping_errors (const char *warning_string, Lisp_Object function) { int speccount; Lisp_Object tem; @@ -4410,16 +4681,16 @@ call0_trapping_errors (CONST char *warning_string, Lisp_Object function) } GCPRO2 (opaque, function); - speccount = specpdl_depth_counter; + speccount = specpdl_depth(); specbind (Qinhibit_quit, Qt); /* gc_currently_forbidden = 1; Currently no reason to do this; */ - opaque = (warning_string ? make_opaque_ptr (warning_string) : Qnil); + opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil); /* Qerror not Qt, so you can get a backtrace */ tem = condition_case_1 (Qerror, catch_them_squirmers_call0, function, caught_a_squirmer, opaque); - if (OPAQUEP (opaque)) + if (OPAQUE_PTRP (opaque)) free_opaque_ptr (opaque); UNGCPRO; @@ -4442,10 +4713,10 @@ catch_them_squirmers_call2 (Lisp_Object cons) } Lisp_Object -call1_trapping_errors (CONST char *warning_string, Lisp_Object function, +call1_trapping_errors (const char *warning_string, Lisp_Object function, Lisp_Object object) { - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); Lisp_Object tem; Lisp_Object cons = Qnil; Lisp_Object opaque = Qnil; @@ -4464,12 +4735,12 @@ call1_trapping_errors (CONST char *warning_string, Lisp_Object function, /* gc_currently_forbidden = 1; Currently no reason to do this; */ cons = noseeum_cons (function, object); - opaque = (warning_string ? make_opaque_ptr (warning_string) : Qnil); + opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil); /* Qerror not Qt, so you can get a backtrace */ tem = condition_case_1 (Qerror, catch_them_squirmers_call1, cons, caught_a_squirmer, opaque); - if (OPAQUEP (opaque)) + if (OPAQUE_PTRP (opaque)) free_opaque_ptr (opaque); free_cons (XCONS (cons)); UNGCPRO; @@ -4479,10 +4750,10 @@ call1_trapping_errors (CONST char *warning_string, Lisp_Object function, } Lisp_Object -call2_trapping_errors (CONST char *warning_string, Lisp_Object function, +call2_trapping_errors (const char *warning_string, Lisp_Object function, Lisp_Object object1, Lisp_Object object2) { - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); Lisp_Object tem; Lisp_Object cons = Qnil; Lisp_Object opaque = Qnil; @@ -4500,12 +4771,12 @@ call2_trapping_errors (CONST char *warning_string, Lisp_Object function, /* gc_currently_forbidden = 1; Currently no reason to do this; */ cons = list3 (function, object1, object2); - opaque = (warning_string ? make_opaque_ptr (warning_string) : Qnil); + opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil); /* Qerror not Qt, so you can get a backtrace */ tem = condition_case_1 (Qerror, catch_them_squirmers_call2, cons, caught_a_squirmer, opaque); - if (OPAQUEP (opaque)) + if (OPAQUE_PTRP (opaque)) free_opaque_ptr (opaque); free_list (cons); UNGCPRO; @@ -4515,33 +4786,40 @@ call2_trapping_errors (CONST char *warning_string, Lisp_Object function, } -/**********************************************************************/ -/* The special binding stack */ -/**********************************************************************/ +/************************************************************************/ +/* The special binding stack */ +/* Most C code should simply use specbind() and unbind_to(). */ +/* When performance is critical, use the macros in backtrace.h. */ +/************************************************************************/ #define min_max_specpdl_size 400 -static void -grow_specpdl (void) +void +grow_specpdl (EMACS_INT reserved) { - if (specpdl_size >= max_specpdl_size) + EMACS_INT size_needed = specpdl_depth() + reserved; + if (size_needed >= max_specpdl_size) { if (max_specpdl_size < min_max_specpdl_size) max_specpdl_size = min_max_specpdl_size; - if (specpdl_size >= max_specpdl_size) + if (size_needed >= max_specpdl_size) { - if (!NILP (Vdebug_on_error) || !NILP (Vdebug_on_signal)) + if (!NILP (Vdebug_on_error) || + !NILP (Vdebug_on_signal)) /* Leave room for some specpdl in the debugger. */ - max_specpdl_size = specpdl_size + 100; + max_specpdl_size = size_needed + 100; continuable_error ("Variable binding depth exceeds max-specpdl-size"); } } - specpdl_size *= 2; - if (specpdl_size > max_specpdl_size) - specpdl_size = max_specpdl_size; + while (specpdl_size < size_needed) + { + specpdl_size *= 2; + if (specpdl_size > max_specpdl_size) + specpdl_size = max_specpdl_size; + } XREALLOC_ARRAY (specpdl, struct specbinding, specpdl_size); - specpdl_ptr = specpdl + specpdl_depth_counter; + specpdl_ptr = specpdl + specpdl_depth(); } @@ -4551,7 +4829,7 @@ specbind_unwind_local (Lisp_Object ovalue) { Lisp_Object current = Fcurrent_buffer (); Lisp_Object symbol = specpdl_ptr->symbol; - struct Lisp_Cons *victim = XCONS (ovalue); + Lisp_Cons *victim = XCONS (ovalue); Lisp_Object buf = get_buffer (victim->car, 0); ovalue = victim->cdr; @@ -4620,14 +4898,15 @@ specbind_unwind_wasnt_local (Lisp_Object buffer) void specbind (Lisp_Object symbol, Lisp_Object value) { - int buffer_local; - - CHECK_SYMBOL (symbol); + SPECBIND (symbol, value); +} - if (specpdl_depth_counter >= specpdl_size) - grow_specpdl (); +void +specbind_magic (Lisp_Object symbol, Lisp_Object value) +{ + int buffer_local = + symbol_value_buffer_local_info (symbol, current_buffer); - buffer_local = symbol_value_buffer_local_info (symbol, current_buffer); if (buffer_local == 0) { specpdl_ptr->old_value = find_symbol_value (symbol); @@ -4654,12 +4933,14 @@ specbind (Lisp_Object symbol, Lisp_Object value) Fset (symbol, value); } +/* Note: As long as the unwind-protect exists, its arg is automatically + GCPRO'd. */ + void record_unwind_protect (Lisp_Object (*function) (Lisp_Object arg), Lisp_Object arg) { - if (specpdl_depth_counter >= specpdl_size) - grow_specpdl (); + SPECPDL_RESERVE (1); specpdl_ptr->func = function; specpdl_ptr->symbol = Qnil; specpdl_ptr->old_value = arg; @@ -4669,13 +4950,25 @@ record_unwind_protect (Lisp_Object (*function) (Lisp_Object arg), extern int check_sigio (void); +/* Unwind the stack till specpdl_depth() == COUNT. + VALUE is not used, except that, purely as a convenience to the + caller, it is protected from garbage-protection. */ Lisp_Object unbind_to (int count, Lisp_Object value) { + UNBIND_TO_GCPRO (count, value); + return value; +} + +/* Don't call this directly. + Only for use by UNBIND_TO* macros in backtrace.h */ +void +unbind_to_hairy (int count) +{ int quitf; - struct gcpro gcpro1; - GCPRO1 (value); + ++specpdl_ptr; + ++specpdl_depth_counter; check_quit (); /* make Vquit_flag accurate */ quitf = !NILP (Vquit_flag); @@ -4683,17 +4976,24 @@ unbind_to (int count, Lisp_Object value) while (specpdl_depth_counter != count) { - Lisp_Object ovalue; --specpdl_ptr; --specpdl_depth_counter; - ovalue = specpdl_ptr->old_value; if (specpdl_ptr->func != 0) /* An unwind-protect */ - (*specpdl_ptr->func) (ovalue); + (*specpdl_ptr->func) (specpdl_ptr->old_value); else - Fset (specpdl_ptr->symbol, ovalue); + { + /* We checked symbol for validity when we specbound it, + so only need to call Fset if symbol has magic value. */ + Lisp_Symbol *sym = XSYMBOL (specpdl_ptr->symbol); + if (!SYMBOL_VALUE_MAGIC_P (sym->value)) + sym->value = specpdl_ptr->old_value; + else + Fset (specpdl_ptr->symbol, specpdl_ptr->old_value); + } +#if 0 /* martin */ #ifndef EXCEEDINGLY_QUESTIONABLE_CODE /* There should never be anything here for us to remove. If so, it indicates a logic error in Emacs. Catches @@ -4711,21 +5011,12 @@ unbind_to (int count, Lisp_Object value) /* Don't mess with gcprolist, backtrace_list here */ } #endif +#endif } if (quitf) Vquit_flag = Qt; - - UNGCPRO; - - return value; } - -int -specpdl_depth (void) -{ - return specpdl_depth_counter; -} /* Get the value of symbol's global binding, even if that binding is @@ -4767,9 +5058,9 @@ top_level_set (Lisp_Object symbol, Lisp_Object newval) #endif /* 0 */ -/**********************************************************************/ -/* Backtraces */ -/**********************************************************************/ +/************************************************************************/ +/* Backtraces */ +/************************************************************************/ DEFUN ("backtrace-debug", Fbacktrace_debug, 2, 2, 0, /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG. @@ -4821,18 +5112,18 @@ backtrace_specials (int speccount, int speclimit, Lisp_Object stream) DEFUN ("backtrace", Fbacktrace, 0, 2, "", /* Print a trace of Lisp function calls currently active. -Option arg STREAM specifies the output stream to send the backtrace to, -and defaults to the value of `standard-output'. Optional second arg -DETAILED means show places where currently active variable bindings, -catches, condition-cases, and unwind-protects were made as well as -function calls. +Optional arg STREAM specifies the output stream to send the backtrace to, +and defaults to the value of `standard-output'. +Optional second arg DETAILED non-nil means show places where currently +active variable bindings, catches, condition-cases, and +unwind-protects, as well as function calls, were made. */ (stream, detailed)) { /* This function can GC */ struct backtrace *backlist = backtrace_list; struct catchtag *catches = catchlist; - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); int old_nl = print_escape_newlines; int old_pr = print_readably; @@ -4864,8 +5155,8 @@ function calls. if (!NILP (detailed) && catches && catches->backlist == backlist) { int catchpdl = catches->pdlcount; - if (specpdl[catchpdl].func == condition_case_unwind - && speccount > catchpdl) + if (speccount > catchpdl + && specpdl[catchpdl].func == condition_case_unwind) /* This is a condition-case catchpoint */ catchpdl = catchpdl + 1; @@ -4936,8 +5227,8 @@ function calls. Fprin1 (backlist->args[i], stream); } } + write_c_string (")\n", stream); } - write_c_string (")\n", stream); backlist = backlist->next; } } @@ -4950,8 +5241,8 @@ function calls. } -DEFUN ("backtrace-frame", Fbacktrace_frame, 1, 1, "", /* -Return the function and arguments N frames up from current execution point. +DEFUN ("backtrace-frame", Fbacktrace_frame, 1, 1, 0, /* +Return the function and arguments NFRAMES up from current execution point. If that frame has not evaluated the arguments yet (or is a special form), the value is (nil FUNCTION ARG-FORMS...). If that frame has evaluated its arguments and called its function already, @@ -4959,7 +5250,7 @@ the value is (t FUNCTION ARG-VALUES...). A &rest arg is represented as the tail of the list ARG-VALUES. FUNCTION is whatever was supplied as car of evaluated list, or a lambda expression for macro calls. -If N is more than the number of frames, the value is nil. +If NFRAMES is more than the number of frames, the value is nil. */ (nframes)) { @@ -4989,9 +5280,9 @@ If N is more than the number of frames, the value is nil. } -/**********************************************************************/ -/* Warnings */ -/**********************************************************************/ +/************************************************************************/ +/* Warnings */ +/************************************************************************/ void warn_when_safe_lispobj (Lisp_Object class, Lisp_Object level, @@ -5011,17 +5302,17 @@ warn_when_safe_lispobj (Lisp_Object class, Lisp_Object level, to make sure that Feval() isn't called, since it might not be safe. An alternative approach is to just pass some non-string type of - Lisp Object to warn_when_safe_lispobj(); `prin1-to-string' will + Lisp_Object to warn_when_safe_lispobj(); `prin1-to-string' will automatically be called when it is safe to do so. */ void -warn_when_safe (Lisp_Object class, Lisp_Object level, CONST char *fmt, ...) +warn_when_safe (Lisp_Object class, Lisp_Object level, const char *fmt, ...) { Lisp_Object obj; va_list args; va_start (args, fmt); - obj = emacs_doprnt_string_va ((CONST Bufbyte *) GETTEXT (fmt), + obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1, args); va_end (args); @@ -5031,13 +5322,15 @@ warn_when_safe (Lisp_Object class, Lisp_Object level, CONST char *fmt, ...) -/**********************************************************************/ -/* Initialization */ -/**********************************************************************/ +/************************************************************************/ +/* Initialization */ +/************************************************************************/ void syms_of_eval (void) { + INIT_LRECORD_IMPLEMENTATION (subr); + defsymbol (&Qinhibit_quit, "inhibit-quit"); defsymbol (&Qautoload, "autoload"); defsymbol (&Qdebug_on_error, "debug-on-error"); @@ -5058,10 +5351,13 @@ syms_of_eval (void) defsymbol (&Qvalues, "values"); defsymbol (&Qdisplay_warning, "display-warning"); defsymbol (&Qrun_hooks, "run-hooks"); + defsymbol (&Qif, "if"); DEFSUBR (For); DEFSUBR (Fand); DEFSUBR (Fif); + DEFSUBR_MACRO (Fwhen); + DEFSUBR_MACRO (Funless); DEFSUBR (Fcond); DEFSUBR (Fprogn); DEFSUBR (Fprog1); @@ -5091,13 +5387,13 @@ syms_of_eval (void) DEFSUBR (Feval); DEFSUBR (Fapply); DEFSUBR (Ffuncall); + DEFSUBR (Ffunctionp); DEFSUBR (Ffunction_min_args); DEFSUBR (Ffunction_max_args); DEFSUBR (Frun_hooks); DEFSUBR (Frun_hook_with_args); DEFSUBR (Frun_hook_with_args_until_success); DEFSUBR (Frun_hook_with_args_until_failure); - DEFSUBR (Ffetch_bytecode); DEFSUBR (Fbacktrace_debug); DEFSUBR (Fbacktrace); DEFSUBR (Fbacktrace_frame); @@ -5118,8 +5414,28 @@ reinit_eval (void) } void +reinit_vars_of_eval (void) +{ + preparing_for_armageddon = 0; + in_warnings = 0; + Qunbound_suspended_errors_tag = make_opaque_ptr (&Qunbound_suspended_errors_tag); + staticpro_nodump (&Qunbound_suspended_errors_tag); + + specpdl_size = 50; + specpdl = xnew_array (struct specbinding, specpdl_size); + /* XEmacs change: increase these values. */ + max_specpdl_size = 3000; + max_lisp_eval_depth = 1000; +#ifdef DEFEND_AGAINST_THROW_RECURSION + throw_level = 0; +#endif +} + +void vars_of_eval (void) { + reinit_vars_of_eval (); + DEFVAR_INT ("max-specpdl-size", &max_specpdl_size /* Limit on number of Lisp variable bindings & unwind-protects before error. */ ); @@ -5221,13 +5537,10 @@ If due to `eval' entry, one arg, t. */ ); Vdebugger = Qnil; - preparing_for_armageddon = 0; - staticpro (&Vpending_warnings); Vpending_warnings = Qnil; - Vpending_warnings_tail = Qnil; /* no need to protect this */ - - in_warnings = 0; + dump_add_root_object (&Vpending_warnings_tail); + Vpending_warnings_tail = Qnil; staticpro (&Vautoload_queue); Vautoload_queue = Qnil; @@ -5240,16 +5553,5 @@ If due to `eval' entry, one arg, t. staticpro (&Vcurrent_error_state); Vcurrent_error_state = Qnil; /* errors as normal */ - Qunbound_suspended_errors_tag = make_opaque_long (0); - staticpro (&Qunbound_suspended_errors_tag); - - specpdl_size = 50; - specpdl_depth_counter = 0; - specpdl = xnew_array (struct specbinding, specpdl_size); - /* XEmacs change: increase these values. */ - max_specpdl_size = 3000; - max_lisp_eval_depth = 500; - throw_level = 0; - reinit_eval (); }