/* 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 (*)()) (fn); \
+ Lisp_Object *PF_av = (av); \
+ switch (ac) \
+ { \
+ default: abort(); \
+ case 0: 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
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;
*/
static Lisp_Object Vcondition_handlers;
+
+#if 0 /* no longer used */
/* Used for error catching purposes by throw_or_bomb_out */
static int throw_level;
-
-static Lisp_Object primitive_funcall (lisp_fn_t fn, int nargs,
- Lisp_Object args[]);
+#endif /* unused */
\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 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);
+ 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*",
+ internal_with_output_to_temp_buffer (build_string ("*Backtrace*"),
backtrace_259,
Qnil,
Qnil);
&& !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*",
+ internal_with_output_to_temp_buffer (build_string ("*Backtrace*"),
backtrace_259,
Qnil,
Qnil);
: 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;
+ REGISTER Lisp_Object arg, val;
- GCPRO1 (args);
-
- 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;
+ REGISTER Lisp_Object arg, val = Qt;
- GCPRO1 (args);
-
- 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, /*
(args))
{
/* This function can GC */
- REGISTER Lisp_Object tail;
- struct gcpro gcpro1;
-
- GCPRO1 (args);
+ REGISTER Lisp_Object val, clause;
- 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 form, 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, form;
+ 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, form, tail;
+ 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_3 (form, args, tail)
+ Feval (form);
UNGCPRO;
return val;
(args))
{
/* This function can GC */
+ Lisp_Object var, tail;
Lisp_Object varlist = XCAR (args);
- Lisp_Object tail;
- int speccount = specpdl_depth_counter;
- struct gcpro gcpro1;
+ Lisp_Object body = XCDR (args);
+ int speccount = specpdl_depth();
- GCPRO1 (args);
-
- 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, /*
(args))
{
/* This function can GC */
+ Lisp_Object var, tail;
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;
-
- LIST_LOOP (tail, varlist)
+ idx = 0;
+ LIST_LOOP_3 (var, varlist, tail)
{
- Lisp_Object elt = XCAR (tail);
- QUIT;
- if (SYMBOLP (elt))
- temps[argnum++] = Qnil;
+ Lisp_Object *value = &temps[idx++];
+ if (SYMBOLP (var))
+ *value = Qnil;
else
{
- CHECK_CONS (elt);
- elt = XCDR (elt);
- if (NILP (elt))
- temps[argnum++] = Qnil;
+ Lisp_Object tem;
+ CHECK_CONS (var);
+ tem = XCDR (var);
+ if (NILP (tem))
+ *value = Qnil;
else
{
- CHECK_CONS (elt);
- temps[argnum++] = Feval (XCAR (elt));
- gcpro2.nvars = argnum;
+ CHECK_CONS (tem);
+ *value = Feval (XCAR (tem));
+ gcpro1.nvars = idx;
- if (!NILP (XCDR (elt)))
+ 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);
}
}
}
- UNGCPRO;
- argnum = 0;
- LIST_LOOP (tail, varlist)
+ idx = 0;
+ LIST_LOOP_3 (var, varlist, tail)
{
- Lisp_Object elt = XCAR (tail);
- specbind (SYMBOLP (elt) ? elt : XCAR (elt), temps[argnum++]);
+ specbind (SYMBOLP (var) ? var : XCAR (var), temps[idx++]);
}
- return unbind_to (speccount, Fprogn (XCDR (args)));
+ UNGCPRO;
+
+ 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)
+{
+ if (purify_flag)
+ defn = Fpurecopy (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, /*
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)))
{
{
/* 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;
- Fset_default (sym, Feval (val));
+ GCPRO1 (val);
+
+ Fset_default (sym, val);
+
+ UNGCPRO;
if (!NILP (args = XCDR (args)))
{
*/
(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, /*
}
\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
backtrace_list = c->backlist;
lisp_eval_depth = c->lisp_eval_depth;
+#if 0 /* no longer used */
throw_level = 0;
+#endif
LONGJMP (c->jmp, 1);
}
(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)
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
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;
+ Lisp_Object handler;
- 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
+ {
+ Lisp_Object condition;
+ 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. */
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);
- return primitive_funcall ((lisp_fn_t) get_opaque_ptr (kludgy_args[0]),
- XINT (kludgy_args[1]), kludgy_args + 2);
+ PRIMITIVE_FUNCALL (val, get_opaque_ptr (kludgy_args[0]),
+ kludgy_args + 2, XINT (kludgy_args[1]));
+ return val;
}
static Lisp_Object
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.
}
\f
-/**********************************************************************/
-/* User commands */
-/**********************************************************************/
+/* Used in core lisp functions for efficiency */
+void
+signal_void_function_error (Lisp_Object function)
+{
+ Fsignal (Qvoid_function, list1 (function));
+}
+
+static void
+signal_invalid_function_error (Lisp_Object function)
+{
+ Fsignal (Qinvalid_function, list1 (function));
+}
+
+static void
+signal_wrong_number_of_arguments_error (Lisp_Object function, int nargs)
+{
+ Fsignal (Qwrong_number_of_arguments, list2 (function, make_int (nargs)));
+}
+
+/* Used in list traversal macros for efficiency. */
+void
+signal_malformed_list_error (Lisp_Object list)
+{
+ Fsignal (Qmalformed_list, list1 (list));
+}
+
+void
+signal_malformed_property_list_error (Lisp_Object list)
+{
+ Fsignal (Qmalformed_property_list, list1 (list));
+}
+
+void
+signal_circular_list_error (Lisp_Object list)
+{
+ Fsignal (Qcircular_list, list1 (list));
+}
+
+void
+signal_circular_property_list_error (Lisp_Object list)
+{
+ Fsignal (Qcircular_property_list, list1 (list));
+}
+\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, /*
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);
}
\f
-/**********************************************************************/
-/* Autoloading */
-/**********************************************************************/
+/************************************************************************/
+/* Autoloading */
+/************************************************************************/
DEFUN ("autoload", Fautoload, 2, 5, 0, /*
Define FUNCTION to autoload from FILE.
CHECK_STRING (file);
/* 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)
{
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;
/* 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);
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)
+ goto wrong_number_of_arguments;
- if (nargs < subr->min_args
- || (max_args >= 0 && max_args < nargs))
- {
- return Fsignal (Qwrong_number_of_arguments,
- list2 (fun, make_int (nargs)));
- }
-
- 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;
+
+ {
+ REGISTER Lisp_Object arg;
+ 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;
+
+ {
+ REGISTER Lisp_Object arg;
+ 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:
+ signal_wrong_number_of_arguments_error (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;
- }
+ {
+ REGISTER Lisp_Object arg;
+ 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 (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;
+
+ {
+ REGISTER Lisp_Object arg;
+ 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:
+ 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)
+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 (fun_nargs < subr->min_args)
+ goto wrong_number_of_arguments;
- 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:
+ FUNCALL_SUBR (val, subr, fun_args, max_args);
}
+ else if (fun_nargs < max_args)
+ {
+ Lisp_Object *p = spacious_args;
- if (max_args == MANY)
+ /* Default optionals to nil */
+ while (fun_nargs--)
+ *p++ = *fun_args++;
+ while (p - spacious_args < max_args)
+ *p++ = Qnil;
+
+ fun_args = spacious_args;
+ goto funcall_subr;
+ }
+ else if (max_args == MANY)
{
val = ((Lisp_Object (*) (int, Lisp_Object *)) (subr_function (subr)))
- (nargs, args + 1);
+ (fun_nargs, fun_args);
}
-
- else if (max_args > nargs)
+ else if (max_args == UNEVALLED) /* Can't funcall a special form */
{
- Lisp_Object argvals[SUBR_MAX_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;
-
- /* val = funcall_subr (subr, argvals); */
- inline_funcall_subr (val, subr, argvals);
+ goto invalid_function;
}
else
- /* val = funcall_subr (subr, args + 1); */
- inline_funcall_subr (val, subr, (&args[1]));
+ {
+ wrong_number_of_arguments:
+ 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 (fun, args[0]);
goto retry;
}
- else
+ else /* Can't funcall a macro */
{
- goto invalid_function;
+ goto invalid_function;
}
}
+ else if (UNBOUNDP (fun))
+ {
+ signal_void_function_error (args[0]);
+ }
+ else
+ {
+ invalid_function:
+ 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));
+ return function_min_args_p ?
+ Fsubr_min_args (function):
+ 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 (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 Fsignal (Qinvalid_function, list1 (function));
}
- return make_int (argcount);
+ {
+ int argcount = 0;
+ Lisp_Object arg;
+
+ 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);
+ Lisp_Object symbol, arglist, body, tail;
+ int speccount = specpdl_depth();
+ REGISTER int i = 0;
- GCPRO3 (*arg_vector, unevalled_args, fun);
- gcpro1.nvars = 0;
+ tail = XCDR (fun);
- 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;
+ if (!CONSP (tail))
+ goto invalid_function;
- backtrace_list->args = arg_vector;
- backtrace_list->nargs = i;
- backtrace_list->evalargs = 0;
- tem = funcall_lambda (fun, numargs, arg_vector);
-
- /* 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;
-}
-
-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_3 (symbol, arglist, tail)
+ {
+ 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 Fsignal (Qwrong_number_of_arguments, list2 (fun, make_int (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 Fsignal (Qinvalid_function, list1 (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.
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
{
+ struct gcpro gcpro1, gcpro2;
GCPRO2 (sym, val);
for (;
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
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;
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);
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;
}
GCPRO2 (opaque, function);
- speccount = specpdl_depth_counter;
+ speccount = specpdl_depth();
specbind (Qinhibit_quit, Qt);
/* gc_currently_forbidden = 1; Currently no reason to do this; */
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;
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;
}
\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 (size_t reserved)
{
- if (specpdl_size >= max_specpdl_size)
+ size_t 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();
}
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);
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)
{
- int quitf;
- struct gcpro gcpro1;
+ UNBIND_TO_GCPRO (count, value);
+ return value;
+}
- GCPRO1 (value);
+/* Don't call this directly.
+ Only for use by UNBIND_TO* macros in backtrace.h */
+void
+unbind_to_hairy (int count)
+{
+ int quitf;
check_quit (); /* make Vquit_flag accurate */
quitf = !NILP (Vquit_flag);
Vquit_flag = Qnil;
+ ++specpdl_ptr;
+ ++specpdl_depth_counter;
+
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. */
+ struct 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.
/* 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;
}
\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
\f
-/**********************************************************************/
-/* Initialization */
-/**********************************************************************/
+/************************************************************************/
+/* Initialization */
+/************************************************************************/
void
syms_of_eval (void)
defsymbol (&Qvalues, "values");
defsymbol (&Qdisplay_warning, "display-warning");
defsymbol (&Qrun_hooks, "run-hooks");
+ defsymbol (&Qif, "if");
DEFSUBR (For);
DEFSUBR (Fand);
DEFSUBR (Fif);
+ DEFSUBR_MACRO (Fwhen);
+ DEFSUBR_MACRO (Funless);
DEFSUBR (Fcond);
DEFSUBR (Fprogn);
DEFSUBR (Fprog1);
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);
/* XEmacs change: increase these values. */
max_specpdl_size = 3000;
max_lisp_eval_depth = 500;
+#if 0 /* no longer used */
throw_level = 0;
+#endif
reinit_eval ();
}
projects / chise / xemacs-chise.git.1 / blobdiff