#include "xterm.h"
#endif
-/* This definition is duplicated in alloc.c and keyboard.c */
-/* Putting it in lisp.h makes cc bomb out! */
+/* This definition is duplicated in alloc.c and keyboard.c. */
+/* Putting it in lisp.h makes cc bomb out! */
struct backtrace
{
struct backtrace *next;
Lisp_Object *function;
- Lisp_Object *args; /* Points to vector of args. */
+ Lisp_Object *args; /* Points to vector of args. */
int nargs; /* Length of vector.
If nargs is UNEVALLED, args points to slot holding
- list of unevalled args */
+ list of unevalled args. */
char evalargs;
- /* Nonzero means call value of debugger when done with this operation. */
+ /* Nonzero means call value of debugger when done with this operation. */
char debug_on_exit;
};
when_entered_debugger = -1;
}
-/* unwind-protect function used by call_debugger. */
+/* Unwind-protect function used by call_debugger. */
static Lisp_Object
restore_stack_limits (Lisp_Object data)
|| btp->nargs == UNEVALLED))
btp = btp->next;
- /* btp now points at the frame of the innermost function that isn't
+ /* `btp' now points at the frame of the innermost function that isn't
a special form, ignoring frames for Finteractive_p and/or
Fbytecode at the top. If this frame is for a built-in function
(such as load or eval-region) return nil. */
if (exclude_subrs_p && SUBRP (fun))
return 0;
- /* btp points to the frame of a Lisp function that called interactive-p.
+ /* `btp' points to the frame of a Lisp function that called interactive-p.
Return t if that function was called interactively. */
if (btp && btp->next && EQ (*btp->next->function, Qcall_interactively))
return 1;
varlist = Fcar (args);
- /* Make space to hold the values to give the bound variables */
+ /* Make space to hold the values to give the bound variables. */
elt = Flength (varlist);
SAFE_ALLOCA_LISP (temps, XFASTINT (elt));
- /* Compute the values and store them in `temps' */
+ /* Compute the values and store them in `temps'. */
GCPRO2 (args, *temps);
gcpro2.nvars = 0;
/* SYM is not mentioned in ENVIRONMENT.
Look at its function definition. */
if (EQ (def, Qunbound) || !CONSP (def))
- /* Not defined or definition not suitable */
+ /* Not defined or definition not suitable. */
break;
if (EQ (XCAR (def), Qautoload))
{
byte_stack_list = catch->byte_stack;
gcprolist = catch->gcpro;
#ifdef DEBUG_GCPRO
- if (gcprolist != 0)
- gcpro_level = gcprolist->level + 1;
- else
- gcpro_level = 0;
+ gcpro_level = gcprolist ? gcprolist->level + 1 : gcpro_level = 0;
#endif
backtrace_list = catch->backlist;
lisp_eval_depth = catch->lisp_eval_depth;
? debug_on_quit
: wants_debugger (Vdebug_on_error, conditions))
&& ! skip_debugger (conditions, combined_data)
- /* rms: what's this for? */
+ /* RMS: What's this for? */
&& when_entered_debugger < num_nonmacro_input_events)
{
call_debugger (Fcons (Qerror, Fcons (combined_data, Qnil)));
}
-/* dump an error message; called like vprintf */
+/* Dump an error message; called like vprintf. */
void
verror (const char *m, va_list ap)
{
}
-/* dump an error message; called like printf */
+/* Dump an error message; called like printf. */
/* VARARGS 1 */
void
CHECK_SYMBOL (function);
CHECK_STRING (file);
- /* If function is defined and not as an autoload, don't override */
+ /* If function is defined and not as an autoload, don't override. */
if (!EQ (XSYMBOL (function)->function, Qunbound)
&& !(CONSP (XSYMBOL (function)->function)
&& EQ (XCAR (XSYMBOL (function)->function), Qautoload)))
backtrace.next = backtrace_list;
backtrace_list = &backtrace;
- backtrace.function = &original_fun; /* This also protects them from gc */
+ backtrace.function = &original_fun; /* This also protects them from gc. */
backtrace.args = &original_args;
backtrace.nargs = UNEVALLED;
backtrace.evalargs = 1;
do_debug_on_call (Qt);
/* At this point, only original_fun and original_args
- have values that will be used below */
+ have values that will be used below. */
retry:
/* Optimize for no indirection. */
CHECK_CONS_LIST ();
- if (XINT (numargs) < XSUBR (fun)->min_args ||
- (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args < XINT (numargs)))
+ if (XINT (numargs) < XSUBR (fun)->min_args
+ || (XSUBR (fun)->max_args >= 0
+ && XSUBR (fun)->max_args < XINT (numargs)))
xsignal2 (Qwrong_number_of_arguments, original_fun, numargs);
else if (XSUBR (fun)->max_args == UNEVALLED)
}
else if (XSUBR (fun)->max_args == MANY)
{
- /* Pass a vector of evaluated arguments */
+ /* Pass a vector of evaluated arguments. */
Lisp_Object *vals;
register int argnum = 0;
USE_SAFE_ALLOCA;
fun = indirect_function (fun);
if (EQ (fun, Qunbound))
{
- /* Let funcall get the error */
+ /* Let funcall get the error. */
fun = args[0];
goto funcall;
}
{
if (numargs < XSUBR (fun)->min_args
|| (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args < numargs))
- goto funcall; /* Let funcall get the error */
+ goto funcall; /* Let funcall get the error. */
else if (XSUBR (fun)->max_args > numargs)
{
/* Avoid making funcall cons up a yet another new vector of arguments
- by explicitly supplying nil's for optional values */
+ by explicitly supplying nil's for optional values. */
SAFE_ALLOCA_LISP (funcall_args, 1 + XSUBR (fun)->max_args);
for (i = numargs; i < XSUBR (fun)->max_args;)
funcall_args[++i] = Qnil;
\f
/* Run hook variables in various ways. */
-enum run_hooks_condition {to_completion, until_success, until_failure};
-static Lisp_Object run_hook_with_args (int, Lisp_Object *,
- enum run_hooks_condition);
+Lisp_Object run_hook_with_args (int, Lisp_Object *,
+ Lisp_Object (*funcall)
+ (int nargs, Lisp_Object *args));
+
+static Lisp_Object
+funcall_nil (int nargs, Lisp_Object *args)
+{
+ Ffuncall (nargs, args);
+ return Qnil;
+}
DEFUN ("run-hooks", Frun_hooks, Srun_hooks, 0, MANY, 0,
doc: /* Run each hook in HOOKS.
for (i = 0; i < nargs; i++)
{
hook[0] = args[i];
- run_hook_with_args (1, hook, to_completion);
+ run_hook_with_args (1, hook, funcall_nil);
}
return Qnil;
usage: (run-hook-with-args HOOK &rest ARGS) */)
(int nargs, Lisp_Object *args)
{
- return run_hook_with_args (nargs, args, to_completion);
+ return run_hook_with_args (nargs, args, funcall_nil);
}
DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success,
usage: (run-hook-with-args-until-success HOOK &rest ARGS) */)
(int nargs, Lisp_Object *args)
{
- return run_hook_with_args (nargs, args, until_success);
+ return run_hook_with_args (nargs, args, Ffuncall);
+}
+
+static Lisp_Object
+funcall_not (int nargs, Lisp_Object *args)
+{
+ return NILP (Ffuncall (nargs, args)) ? Qt : Qnil;
}
DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure,
usage: (run-hook-with-args-until-failure HOOK &rest ARGS) */)
(int nargs, Lisp_Object *args)
{
- return run_hook_with_args (nargs, args, until_failure);
+ return NILP (run_hook_with_args (nargs, args, funcall_not)) ? Qt : Qnil;
}
+static Lisp_Object
+run_hook_wrapped_funcall (int nargs, Lisp_Object *args)
+{
+ Lisp_Object tmp = args[0], ret;
+ args[0] = args[1];
+ args[1] = tmp;
+ ret = Ffuncall (nargs, args);
+ args[1] = args[0];
+ args[0] = tmp;
+ return ret;
+}
+
+DEFUN ("run-hook-wrapped", Frun_hook_wrapped, Srun_hook_wrapped, 2, MANY, 0,
+ doc: /* Run HOOK, passing each function through WRAP-FUNCTION.
+I.e. instead of calling each function FUN directly with arguments ARGS,
+it calls WRAP-FUNCTION with arguments FUN and ARGS.
+As soon as a call to WRAP-FUNCTION returns non-nil, `run-hook-wrapped'
+aborts and returns that value.
+usage: (run-hook-wrapped HOOK WRAP-FUNCTION &rest ARGS) */)
+ (int nargs, Lisp_Object *args)
+{
+ return run_hook_with_args (nargs, args, run_hook_wrapped_funcall);
+}
+
/* ARGS[0] should be a hook symbol.
Call each of the functions in the hook value, passing each of them
as arguments all the rest of ARGS (all NARGS - 1 elements).
- COND specifies a condition to test after each call
- to decide whether to stop.
+ FUNCALL specifies how to call each function on the hook.
The caller (or its caller, etc) must gcpro all of ARGS,
except that it isn't necessary to gcpro ARGS[0]. */
-static Lisp_Object
-run_hook_with_args (int nargs, Lisp_Object *args, enum run_hooks_condition cond)
+Lisp_Object
+run_hook_with_args (int nargs, Lisp_Object *args,
+ Lisp_Object (*funcall) (int nargs, Lisp_Object *args))
{
- Lisp_Object sym, val, ret;
+ Lisp_Object sym, val, ret = Qnil;
struct gcpro gcpro1, gcpro2, gcpro3;
/* If we are dying or still initializing,
sym = args[0];
val = find_symbol_value (sym);
- ret = (cond == until_failure ? Qt : Qnil);
if (EQ (val, Qunbound) || NILP (val))
return ret;
else if (!CONSP (val) || EQ (XCAR (val), Qlambda))
{
args[0] = val;
- return Ffuncall (nargs, args);
+ return funcall (nargs, args);
}
else
{
GCPRO3 (sym, val, global_vals);
for (;
- CONSP (val) && ((cond == to_completion)
- || (cond == until_success ? NILP (ret)
- : !NILP (ret)));
+ CONSP (val) && NILP (ret);
val = XCDR (val))
{
if (EQ (XCAR (val), Qt))
if (!CONSP (global_vals) || EQ (XCAR (global_vals), Qlambda))
{
args[0] = global_vals;
- ret = Ffuncall (nargs, args);
+ ret = funcall (nargs, args);
}
else
{
for (;
- (CONSP (global_vals)
- && (cond == to_completion
- || (cond == until_success
- ? NILP (ret)
- : !NILP (ret))));
+ CONSP (global_vals) && NILP (ret);
global_vals = XCDR (global_vals))
{
args[0] = XCAR (global_vals);
/* In a global value, t should not occur. If it does, we
must ignore it to avoid an endless loop. */
if (!EQ (args[0], Qt))
- ret = Ffuncall (nargs, args);
+ ret = funcall (nargs, args);
}
}
}
else
{
args[0] = XCAR (val);
- ret = Ffuncall (nargs, args);
+ ret = funcall (nargs, args);
}
}
Frun_hook_with_args (3, temp);
}
\f
-/* Apply fn to arg */
+/* Apply fn to arg. */
Lisp_Object
apply1 (Lisp_Object fn, Lisp_Object arg)
{
}
}
-/* Call function fn on no arguments */
+/* Call function fn on no arguments. */
Lisp_Object
call0 (Lisp_Object fn)
{
RETURN_UNGCPRO (Ffuncall (1, &fn));
}
-/* Call function fn with 1 argument arg1 */
+/* Call function fn with 1 argument arg1. */
/* ARGSUSED */
Lisp_Object
call1 (Lisp_Object fn, Lisp_Object arg1)
RETURN_UNGCPRO (Ffuncall (2, args));
}
-/* Call function fn with 2 arguments arg1, arg2 */
+/* Call function fn with 2 arguments arg1, arg2. */
/* ARGSUSED */
Lisp_Object
call2 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2)
RETURN_UNGCPRO (Ffuncall (3, args));
}
-/* Call function fn with 3 arguments arg1, arg2, arg3 */
+/* Call function fn with 3 arguments arg1, arg2, arg3. */
/* ARGSUSED */
Lisp_Object
call3 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3)
RETURN_UNGCPRO (Ffuncall (4, args));
}
-/* Call function fn with 4 arguments arg1, arg2, arg3, arg4 */
+/* Call function fn with 4 arguments arg1, arg2, arg3, arg4. */
/* ARGSUSED */
Lisp_Object
call4 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
RETURN_UNGCPRO (Ffuncall (5, args));
}
-/* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5 */
+/* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5. */
/* ARGSUSED */
Lisp_Object
call5 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
RETURN_UNGCPRO (Ffuncall (6, args));
}
-/* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6 */
+/* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6. */
/* ARGSUSED */
Lisp_Object
call6 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
RETURN_UNGCPRO (Ffuncall (7, args));
}
-/* Call function fn with 7 arguments arg1, arg2, arg3, arg4, arg5, arg6, arg7 */
+/* Call function fn with 7 arguments arg1, arg2, arg3, arg4, arg5, arg6, arg7. */
/* ARGSUSED */
Lisp_Object
call7 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
specpdl_ptr = specpdl + count;
}
-/* specpdl_ptr->symbol is a field which describes which variable is
+/* `specpdl_ptr->symbol' is a field which describes which variable is
let-bound, so it can be properly undone when we unbind_to.
It can have the following two shapes:
- SYMBOL : if it's a plain symbol, it means that we have let-bound
else
{
tem = *backlist->function;
- Fprin1 (tem, Qnil); /* This can QUIT */
+ Fprin1 (tem, Qnil); /* This can QUIT. */
write_string ("(", -1);
if (backlist->nargs == MANY)
{
defsubr (&Srun_hook_with_args);
defsubr (&Srun_hook_with_args_until_success);
defsubr (&Srun_hook_with_args_until_failure);
+ defsubr (&Srun_hook_wrapped);
defsubr (&Sfetch_bytecode);
defsubr (&Sbacktrace_debug);
defsubr (&Sbacktrace);
/* Hooks to run before and after each command. */
Lisp_Object Qpre_command_hook;
Lisp_Object Qpost_command_hook;
-Lisp_Object Qcommand_hook_internal;
Lisp_Object Qdeferred_action_function;
static Lisp_Object
safe_run_hooks_1 (void)
{
- return Frun_hooks (1, &Vinhibit_quit);
+ eassert (CONSP (Vinhibit_quit));
+ return call0 (XCDR (Vinhibit_quit));
}
-/* Subroutine for safe_run_hooks: handle an error by clearing out the hook. */
+/* Subroutine for safe_run_hooks: handle an error by clearing out the function
+ from the hook. */
static Lisp_Object
-safe_run_hooks_error (Lisp_Object data)
+safe_run_hooks_error (Lisp_Object error_data)
+{
+ Lisp_Object hook
+ = CONSP (Vinhibit_quit) ? XCAR (Vinhibit_quit) : Vinhibit_quit;
+ Lisp_Object fun = CONSP (Vinhibit_quit) ? XCDR (Vinhibit_quit) : Qnil;
+ Lisp_Object args[4];
+ args[0] = build_string ("Error in %s (%s): %s");
+ args[1] = hook;
+ args[2] = fun;
+ args[3] = error_data;
+ Fmessage (4, args);
+ if (SYMBOLP (hook))
+ {
+ Lisp_Object val;
+ int found = 0;
+ Lisp_Object newval = Qnil;
+ for (val = find_symbol_value (hook); CONSP (val); val = XCDR (val))
+ if (EQ (fun, XCAR (val)))
+ found = 1;
+ else
+ newval = Fcons (XCAR (val), newval);
+ if (found)
+ return Fset (hook, Fnreverse (newval));
+ /* Not found in the local part of the hook. Let's look at the global
+ part. */
+ newval = Qnil;
+ for (val = (NILP (Fdefault_boundp (hook)) ? Qnil
+ : Fdefault_value (hook));
+ CONSP (val); val = XCDR (val))
+ if (EQ (fun, XCAR (val)))
+ found = 1;
+ else
+ newval = Fcons (XCAR (val), newval);
+ if (found)
+ return Fset_default (hook, Fnreverse (newval));
+ }
+ return Qnil;
+}
+
+static Lisp_Object
+safe_run_hook_funcall (int nargs, Lisp_Object *args)
{
- Lisp_Object args[3];
- args[0] = build_string ("Error in %s: %s");
- args[1] = Vinhibit_quit;
- args[2] = data;
- Fmessage (3, args);
- return Fset (Vinhibit_quit, Qnil);
+ eassert (nargs == 1);
+ if (CONSP (Vinhibit_quit))
+ XSETCDR (Vinhibit_quit, args[0]);
+ else
+ Vinhibit_quit = Fcons (Vinhibit_quit, args[0]);
+
+ return internal_condition_case (safe_run_hooks_1, Qt, safe_run_hooks_error);
}
/* If we get an error while running the hook, cause the hook variable
void
safe_run_hooks (Lisp_Object hook)
{
+ /* FIXME: our `internal_condition_case' does not provide any way to pass data
+ to its body or to its handlers other than via globals such as
+ dynamically-bound variables ;-) */
int count = SPECPDL_INDEX ();
specbind (Qinhibit_quit, hook);
- internal_condition_case (safe_run_hooks_1, Qt, safe_run_hooks_error);
+ run_hook_with_args (1, &hook, safe_run_hook_funcall);
unbind_to (count, Qnil);
}
Qdeferred_action_function = intern_c_string ("deferred-action-function");
staticpro (&Qdeferred_action_function);
- Qcommand_hook_internal = intern_c_string ("command-hook-internal");
- staticpro (&Qcommand_hook_internal);
-
Qfunction_key = intern_c_string ("function-key");
staticpro (&Qfunction_key);
Qmouse_click = intern_c_string ("mouse-click");
Qdeactivate_mark = intern_c_string ("deactivate-mark");
staticpro (&Qdeactivate_mark);
- DEFVAR_LISP ("command-hook-internal", Vcommand_hook_internal,
- doc: /* Temporary storage of `pre-command-hook' or `post-command-hook'. */);
- Vcommand_hook_internal = Qnil;
-
DEFVAR_LISP ("pre-command-hook", Vpre_command_hook,
doc: /* Normal hook run before each command is executed.
If an unhandled error happens in running this hook,
-the hook value is set to nil, since otherwise the error
-might happen repeatedly and make Emacs nonfunctional. */);
+the function in which the error occurred is unconditionally removed, since
+otherwise the error might happen repeatedly and make Emacs nonfunctional. */);
Vpre_command_hook = Qnil;
DEFVAR_LISP ("post-command-hook", Vpost_command_hook,
doc: /* Normal hook run after each command is executed.
If an unhandled error happens in running this hook,
-the hook value is set to nil, since otherwise the error
-might happen repeatedly and make Emacs nonfunctional. */);
+the function in which the error occurred is unconditionally removed, since
+otherwise the error might happen repeatedly and make Emacs nonfunctional. */);
Vpost_command_hook = Qnil;
#if 0
HCoop / bpt / emacs.git / commitdiff