/* 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.
/* Synched up with: FSF 19.30 (except for Fsignal), Mule 2.0. */
-/* Debugging hack */
-int always_gc;
-
-
#include <config.h>
#include "lisp.h"
#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
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
/* 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;
/* 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;
*/
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
\f
-/**********************************************************************/
-/* 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) ? "#<special-form " : "#<subr ";
+ const char *name = subr_name (subr);
+ const char *trailer = subr->prompt ? " (interactive)>" : ">";
if (print_readably)
- error ("printing unreadable object #<subr %s>",
- subr_name (subr));
+ error ("printing unreadable object %s%s%s", header, name, trailer);
- write_c_string (((subr->max_args == UNEVALLED)
- ? "#<special-form "
- : "#<subr "),
- printcharfun);
-
- write_c_string (subr_name (subr), printcharfun);
- write_c_string (((subr->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);
-\f
-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);
\f
-/**********************************************************************/
-/* 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
}
/* 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.
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;
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);
&& 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;
}
&& !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))));
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;
}
: 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))));
}
\f
-/**********************************************************************/
-/* 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.
(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;
}
(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;
}
(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
(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;
}
(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;
{
/* 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, /*
{
/* 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, /*
(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;
}
(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;
}
\f
-/**********************************************************************/
-/* 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.
(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, /*
(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, /*
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.
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");
}
#ifdef I18N3
if (!NILP (Vfile_domain))
- pure_put (sym, Qvariable_domain, Vfile_domain);
+ Fput (sym, Qvariable_domain, Vfile_domain);
#endif
LOADHIST_ATTACH (sym);
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
{
/* 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);
*/
(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, /*
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. */
{
QUIT;
sym = def;
- tem = Fassq (sym, env);
+ tem = Fassq (sym, environment);
if (NILP (tem))
{
def = XSYMBOL (sym)->function;
}
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))
if (EQ (tem, Qt) || EQ (tem, Qmacro))
{
/* Yes, load it and try again. */
+ /* do_autoload GCPROs both arguments */
do_autoload (def, sym);
continue;
}
}
\f
-/**********************************************************************/
-/* Non-local exits */
-/**********************************************************************/
+/************************************************************************/
+/* Non-local exits */
+/************************************************************************/
DEFUN ("catch", Fcatch, 1, UNEVALLED, 0, /*
\(catch TAG BODY...): eval BODY allowing nonlocal exits using `throw'.
(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.
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
c.val = (*func) (arg);
if (threw) *threw = 0;
catchlist = c.next;
+#ifdef ERROR_CHECK_TYPECHECK
+ check_error_state_sanity ();
+#endif
return c.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);
}
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
*/
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;
}
(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)));
}
\f
-/**********************************************************************/
-/* 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);
static Lisp_Object
condition_case_unwind (Lisp_Object loser)
{
- struct Lisp_Cons *victim;
+ Lisp_Cons *victim;
/* ((<unbound> . clauses) ... other handlers */
victim = XCONS (XCAR (loser));
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;
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
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);
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);
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.
(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, /*
(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
/* (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
extern int in_display;
\f
-/****************** the workhorse error-signaling function ******************/
+/************************************************************************/
+/* the workhorse error-signaling function */
+/************************************************************************/
/* #### This function has not been synched with FSF. It diverges
significantly. */
{
/* 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);
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));
}
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)
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:
{
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;
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.
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;
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);
/****************** 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;
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;
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);
}
\f
/****************** 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);
}
/****************** 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);
+}
+
+\f
+/****************** 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);
+}
+
+\f
+/****************** 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);
+}
+
+\f
+/****************** 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);
+}
+
+\f
+/****************** 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);
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;
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);
}
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);
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;
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);
}
\f
-/****************** 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,
}
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)
{
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,
}
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)
{
}
\f
-/**********************************************************************/
-/* 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);
+}
+
+\f
+/************************************************************************/
+/* User commands */
+/************************************************************************/
DEFUN ("commandp", Fcommandp, 1, 1, 0, /*
Return t if FUNCTION makes provisions for interactive calling.
{
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, /*
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;
{
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;
{
Fsignal (Qwrong_type_argument,
Fcons (Qcommandp,
- ((EQ (cmd, final))
+ (EQ (cmd, final)
? list1 (cmd)
: list2 (cmd, final))));
return Qnil;
}
\f
-/**********************************************************************/
-/* 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
Vautoload_queue = oldqueue;
while (CONSP (queue))
{
- first = Fcar (queue);
+ first = XCAR (queue);
second = Fcdr (first);
first = Fcar (first);
if (NILP (second))
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. */
}
\f
-/**********************************************************************/
-/* 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
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.
*/
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);
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)
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;
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)
}
\f
-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)
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);
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);
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:
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);
}
\f
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 '()) */
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
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);
}
\f
-/* 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);
}
+
\f
-/**********************************************************************/
-/* 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.
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',
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. */
}
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)
{
/* 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))
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))
}
\f
-/**********************************************************************/
-/* Front-ends to eval, funcall, apply */
-/**********************************************************************/
+/************************************************************************/
+/* Front-ends to eval, funcall, apply */
+/************************************************************************/
/* Apply fn to arg */
Lisp_Object
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);
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);
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);
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);
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);
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);
}
\f
-/***** 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
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;
}
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;
/* 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;
}
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;
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;
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;
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 */
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;
}
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;
}
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;
}
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;
/* 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;
}
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;
/* 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;
}
\f
-/**********************************************************************/
-/* 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();
}
{
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;
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);
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;
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);
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
/* 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;
-}
\f
/* Get the value of symbol's global binding, even if that binding is
#endif /* 0 */
\f
-/**********************************************************************/
-/* Backtraces */
-/**********************************************************************/
+/************************************************************************/
+/* Backtraces */
+/************************************************************************/
DEFUN ("backtrace-debug", Fbacktrace_debug, 2, 2, 0, /*
Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
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;
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;
Fprin1 (backlist->args[i], stream);
}
}
+ write_c_string (")\n", stream);
}
- write_c_string (")\n", stream);
backlist = backlist->next;
}
}
}
-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,
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))
{
}
\f
-/**********************************************************************/
-/* Warnings */
-/**********************************************************************/
+/************************************************************************/
+/* Warnings */
+/************************************************************************/
void
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);
\f
-/**********************************************************************/
-/* 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");
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);
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);
}
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.
*/ );
*/ );
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;
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 ();
}
projects / chise / xemacs-chise.git.1 / blobdiff