/* 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.
#define AV_8(av) AV_7(av), av[7]
#define PRIMITIVE_FUNCALL_1(fn, av, ac) \
-(((Lisp_Object (*)(EXFUN_##ac)) (fn)) (AV_##ac (av)))
+ (((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
/* 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:
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. */
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;
-#if 0 /* no longer used */
+#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 /* unused */
+#endif
+
+#ifdef ERROR_CHECK_TYPECHECK
+void check_error_state_sanity (void);
+#endif
\f
/************************************************************************/
print_subr (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
{
Lisp_Subr *subr = XSUBR (obj);
- CONST char *header =
+ const char *header =
(subr->max_args == UNEVALLED) ? "#<special-form " : "#<subr ";
- CONST char *name = subr_name (subr);
- CONST char *trailer = subr->prompt ? " (interactive)>" : ">";
+ const char *name = subr_name (subr);
+ const char *trailer = subr->prompt ? " (interactive)>" : ">";
if (print_readably)
error ("printing unreadable object %s%s%s", header, name, trailer);
}
static const struct lrecord_description subr_description[] = {
- { XD_DOC_STRING, offsetof(Lisp_Subr, doc) },
+ { XD_DOC_STRING, offsetof (Lisp_Subr, doc) },
{ XD_END }
};
DEFINE_BASIC_LRECORD_IMPLEMENTATION ("subr", subr,
- this_one_is_unmarkable, print_subr, 0, 0, 0,
+ 0, print_subr, 0, 0, 0,
subr_description,
Lisp_Subr);
\f
specbind (Qdebug_on_signal, Qnil);
specbind (Qstack_trace_on_signal, Qnil);
- internal_with_output_to_temp_buffer (build_string ("*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;
}
specbind (Qdebug_on_signal, Qnil);
specbind (Qstack_trace_on_signal, Qnil);
- internal_with_output_to_temp_buffer (build_string ("*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;
}
(args))
{
/* This function can GC */
- REGISTER Lisp_Object arg, val;
+ REGISTER Lisp_Object val;
LIST_LOOP_2 (arg, args)
{
(args))
{
/* This function can GC */
- REGISTER Lisp_Object arg, val = Qt;
+ REGISTER Lisp_Object val = Qt;
LIST_LOOP_2 (arg, args)
{
}
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 val, clause;
+ REGISTER Lisp_Object val;
LIST_LOOP_2 (clause, args)
{
{
/* This function can GC */
/* Caller must provide a true list in ARGS */
- REGISTER Lisp_Object form, val = Qnil;
+ REGISTER Lisp_Object val = Qnil;
struct gcpro gcpro1;
GCPRO1 (args);
(args))
{
/* This function can GC */
- REGISTER Lisp_Object val, form;
+ REGISTER Lisp_Object val;
struct gcpro gcpro1;
val = Feval (XCAR (args));
(args))
{
/* This function can GC */
- REGISTER Lisp_Object val, form, tail;
+ REGISTER Lisp_Object val;
struct gcpro gcpro1;
Feval (XCAR (args));
GCPRO1 (val);
- LIST_LOOP_3 (form, args, tail)
- Feval (form);
+ {
+ LIST_LOOP_2 (form, args)
+ Feval (form);
+ }
UNGCPRO;
return val;
(args))
{
/* This function can GC */
- Lisp_Object var, tail;
Lisp_Object varlist = XCAR (args);
Lisp_Object body = XCDR (args);
int speccount = specpdl_depth();
(args))
{
/* This function can GC */
- Lisp_Object var, tail;
Lisp_Object varlist = XCAR (args);
Lisp_Object body = XCDR (args);
int speccount = specpdl_depth();
gcpro1.nvars = 0;
idx = 0;
- LIST_LOOP_3 (var, varlist, tail)
- {
- 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;
+ {
+ 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);
- }
- }
- }
+ if (!NILP (XCDR (tem)))
+ signal_simple_error
+ ("`let' bindings can have only one value-form", var);
+ }
+ }
+ }
+ }
idx = 0;
- LIST_LOOP_3 (var, varlist, tail)
- {
- specbind (SYMBOLP (var) ? var : XCAR (var), temps[idx++]);
- }
+ {
+ LIST_LOOP_2 (var, varlist)
+ {
+ specbind (SYMBOLP (var) ? var : XCAR (var), temps[idx++]);
+ }
+ }
UNGCPRO;
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.
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
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;
}
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;
-#if 0 /* no longer used */
+#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;
}
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));
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);
condition_case_3 (Lisp_Object bodyform, Lisp_Object var, Lisp_Object handlers)
{
/* This function can GC */
- Lisp_Object handler;
-
EXTERNAL_LIST_LOOP_2 (handler, handlers)
{
if (NILP (handler))
;
else
{
- Lisp_Object condition;
EXTERNAL_LIST_LOOP_2 (condition, conditions)
if (!SYMBOLP (condition))
goto invalid_condition_handler;
{
/* 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 val;
- Lisp_Object *kludgy_args = (Lisp_Object *) get_opaque_ptr (opaque_arg);
- PRIMITIVE_FUNCALL (val, get_opaque_ptr (kludgy_args[0]),
- kludgy_args + 2, XINT (kludgy_args[1]));
- return val;
+ 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;
return val;
}
- speccount = specpdl_depth();
+ 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 a specified type, whose data
+ is a single string, created using the arguments. */
+
+/* dump an error message; called like printf */
+
+DOESNT_RETURN
+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,
+ args);
+ va_end (args);
+
+ /* Fsignal GC-protects its args */
+ signal_error (type, list1 (obj));
+}
+
+void
+maybe_type_error (Lisp_Object type, 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, list1 (obj), class, errb);
+}
+
+Lisp_Object
+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,
+ args);
+ va_end (args);
+
+ /* Fsignal GC-protects its args */
+ return Fsignal (type, list1 (obj));
+}
+
+Lisp_Object
+maybe_continuable_type_error (Lisp_Object type, 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, 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 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_type_error (Lisp_Object type, const char *reason, Lisp_Object 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_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 (type, list2 (build_translated_string (reason), frob),
+ class, errb);
+}
+
+Lisp_Object
+signal_type_continuable_error (Lisp_Object type, const char *reason,
+ Lisp_Object frob)
+{
+ return Fsignal (type, list2 (build_translated_string (reason), frob));
+}
+
+Lisp_Object
+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
+ (type, list2 (build_translated_string (reason),
+ frob), class, errb);
+}
+
+\f
+/****************** 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, ...)
+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,
+ obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
args);
va_end (args);
}
void
-maybe_error (Lisp_Object class, Error_behavior errb, CONST char *fmt, ...)
+maybe_error (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);
}
Lisp_Object
-continuable_error (CONST char *fmt, ...)
+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,
+ obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
args);
va_end (args);
Lisp_Object
maybe_continuable_error (Lisp_Object class, Error_behavior errb,
- CONST char *fmt, ...)
+ 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 3 ******************/
+/****************** Simple error functions class 3 ******************/
-/* Class 3: Signal an error with a string and an associated object.
+/* 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_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,
+maybe_signal_simple_error (const char *reason, Lisp_Object frob,
Lisp_Object class, Error_behavior errb)
{
/* Optimization: */
}
Lisp_Object
-signal_simple_continuable_error (CONST char *reason, Lisp_Object frob)
+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,
+maybe_signal_simple_continuable_error (const char *reason, Lisp_Object frob,
Lisp_Object class, Error_behavior errb)
{
/* Optimization: */
}
\f
-/****************** Error functions class 4 ******************/
+/****************** Simple error functions class 4 ******************/
-/* Class 4: Printf-like functions that signal an error.
+/* 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)
{
{
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 */
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;
}
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;
/************************************************************************/
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 (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, Fcons (Qautoload, list4 (file,
+
+ return Ffset (function, Fcons (Qautoload, list4 (filename,
docstring,
interactive,
type)));
/* This function can GC */
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);
/************************************************************************/
static Lisp_Object funcall_lambda (Lisp_Object fun,
- int nargs, Lisp_Object args[]);
+ int nargs, Lisp_Object args[]);
static int in_warnings;
static Lisp_Object
gcpro1.nvars = 0;
{
- REGISTER Lisp_Object arg;
LIST_LOOP_2 (arg, original_args)
{
*p++ = Feval (arg);
gcpro1.nvars = 0;
{
- REGISTER Lisp_Object arg;
LIST_LOOP_2 (arg, original_args)
{
*p++ = Feval (arg);
else
{
wrong_number_of_arguments:
- val = signal_wrong_number_of_arguments_error (fun, nargs);
+ val = signal_wrong_number_of_arguments_error (original_fun, nargs);
}
}
else if (COMPILED_FUNCTIONP (fun))
gcpro1.nvars = 0;
{
- REGISTER Lisp_Object arg;
LIST_LOOP_2 (arg, original_args)
{
*p++ = Feval (arg);
if (EQ (funcar, Qautoload))
{
+ /* do_autoload GCPROs both arguments */
do_autoload (fun, original_fun);
goto retry;
}
gcpro1.nvars = 0;
{
- REGISTER Lisp_Object arg;
LIST_LOOP_2 (arg, original_args)
{
*p++ = Feval (arg);
}
\f
+/* #### 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).
if (fun_nargs == max_args) /* Optimize for the common case */
{
funcall_subr:
- FUNCALL_SUBR (val, subr, fun_args, max_args);
+ {
+ /* The "extra" braces placate GCC 2.95.4. */
+ FUNCALL_SUBR (val, subr, fun_args, max_args);
+ }
}
else if (fun_nargs < subr->min_args)
{
}
else if (EQ (funcar, Qautoload))
{
+ /* do_autoload GCPROs both arguments */
do_autoload (fun, args[0]);
goto retry;
}
if (SUBRP (function))
{
- return function_min_args_p ?
- Fsubr_min_args (function):
- Fsubr_max_args (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))
{
}
else if (EQ (funcar, Qautoload))
{
+ /* do_autoload GCPROs both arguments */
do_autoload (function, orig_function);
+ function = orig_function;
goto retry;
}
else if (EQ (funcar, Qlambda))
else
{
invalid_function:
- return signal_invalid_function_error (function);
+ return signal_invalid_function_error (orig_function);
}
{
int argcount = 0;
- Lisp_Object arg;
EXTERNAL_LIST_LOOP_2 (arg, arglist)
{
funcall_lambda (Lisp_Object fun, int nargs, Lisp_Object args[])
{
/* This function can GC */
- Lisp_Object symbol, arglist, body, tail;
+ Lisp_Object arglist, body, tail;
int speccount = specpdl_depth();
REGISTER int i = 0;
{
int optional = 0, rest = 0;
- EXTERNAL_LIST_LOOP_3 (symbol, arglist, tail)
+ EXTERNAL_LIST_LOOP_2 (symbol, arglist)
{
if (!SYMBOLP (symbol))
goto invalid_function;
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',
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();
}
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 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)
{
}
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;
}
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();
}
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();
#define min_max_specpdl_size 400
void
-grow_specpdl (size_t reserved)
+grow_specpdl (EMACS_INT reserved)
{
- size_t size_needed = specpdl_depth() + reserved;
+ EMACS_INT size_needed = specpdl_depth() + reserved;
if (size_needed >= max_specpdl_size)
{
if (max_specpdl_size < min_max_specpdl_size)
{
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;
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)
{
int quitf;
+ ++specpdl_ptr;
+ ++specpdl_depth_counter;
+
check_quit (); /* make Vquit_flag accurate */
quitf = !NILP (Vquit_flag);
Vquit_flag = Qnil;
- ++specpdl_ptr;
- ++specpdl_depth_counter;
-
while (specpdl_depth_counter != count)
{
--specpdl_ptr;
{
/* 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);
+ Lisp_Symbol *sym = XSYMBOL (specpdl_ptr->symbol);
if (!SYMBOL_VALUE_MAGIC_P (sym->value))
sym->value = specpdl_ptr->old_value;
else
DEFUN ("backtrace", Fbacktrace, 0, 2, "", /*
Print a trace of Lisp function calls currently active.
Optional 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.
+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))
{
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))
{
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);
void
syms_of_eval (void)
{
+ INIT_LRECORD_IMPLEMENTATION (subr);
+
defsymbol (&Qinhibit_quit, "inhibit-quit");
defsymbol (&Qautoload, "autoload");
defsymbol (&Qdebug_on_error, "debug-on-error");
specpdl = xnew_array (struct specbinding, specpdl_size);
/* XEmacs change: increase these values. */
max_specpdl_size = 3000;
- max_lisp_eval_depth = 500;
-#if 0 /* no longer used */
+ max_lisp_eval_depth = 1000;
+#ifdef DEFEND_AGAINST_THROW_RECURSION
throw_level = 0;
#endif
}
staticpro (&Vpending_warnings);
Vpending_warnings = Qnil;
- pdump_wire (&Vpending_warnings_tail);
+ dump_add_root_object (&Vpending_warnings_tail);
Vpending_warnings_tail = Qnil;
staticpro (&Vautoload_queue);
projects / chise / xemacs-chise.git.1 / blobdiff