return pdl->let.old_value;
}
+static void
+set_specpdl_old_value (union specbinding *pdl, Lisp_Object val)
+{
+ eassert (pdl->kind >= SPECPDL_LET);
+ pdl->let.old_value = val;
+}
+
static Lisp_Object
specpdl_where (union specbinding *pdl)
{
return pdl->unwind.arg;
}
-static specbinding_func
-specpdl_func (union specbinding *pdl)
-{
- eassert (pdl->kind == SPECPDL_UNWIND);
- return pdl->unwind.func;
-}
-
Lisp_Object
backtrace_function (union specbinding *pdl)
{
/* Unwind-protect function used by call_debugger. */
-static Lisp_Object
+static void
restore_stack_limits (Lisp_Object data)
{
max_specpdl_size = XINT (XCAR (data));
max_lisp_eval_depth = XINT (XCDR (data));
- return Qnil;
}
/* Call the Lisp debugger, giving it argument ARG. */
usage: (if COND THEN ELSE...) */)
(Lisp_Object args)
{
- register Lisp_Object cond;
+ Lisp_Object cond;
struct gcpro gcpro1;
GCPRO1 (args);
- cond = eval_sub (Fcar (args));
+ cond = eval_sub (XCAR (args));
UNGCPRO;
if (!NILP (cond))
- return eval_sub (Fcar (Fcdr (args)));
- return Fprogn (Fcdr (Fcdr (args)));
+ return eval_sub (Fcar (XCDR (args)));
+ return Fprogn (XCDR (XCDR (args)));
}
DEFUN ("cond", Fcond, Scond, 0, UNEVALLED, 0,
usage: (cond CLAUSES...) */)
(Lisp_Object args)
{
- register Lisp_Object clause, val;
+ Lisp_Object val = args;
struct gcpro gcpro1;
- val = Qnil;
GCPRO1 (args);
- while (!NILP (args))
+ while (CONSP (args))
{
- clause = Fcar (args);
+ Lisp_Object clause = XCAR (args);
val = eval_sub (Fcar (clause));
if (!NILP (val))
{
- if (!EQ (XCDR (clause), Qnil))
+ if (!NILP (XCDR (clause)))
val = Fprogn (XCDR (clause));
break;
}
DEFUN ("progn", Fprogn, Sprogn, 0, UNEVALLED, 0,
doc: /* Eval BODY forms sequentially and return value of last one.
usage: (progn BODY...) */)
- (Lisp_Object args)
+ (Lisp_Object body)
{
- register Lisp_Object val = Qnil;
+ Lisp_Object val = Qnil;
struct gcpro gcpro1;
- GCPRO1 (args);
+ GCPRO1 (body);
- while (CONSP (args))
+ while (CONSP (body))
{
- val = eval_sub (XCAR (args));
- args = XCDR (args);
+ val = eval_sub (XCAR (body));
+ body = XCDR (body);
}
UNGCPRO;
return val;
}
+/* Evaluate BODY sequentially, discarding its value. Suitable for
+ record_unwind_protect. */
+
+void
+unwind_body (Lisp_Object body)
+{
+ Fprogn (body);
+}
+
DEFUN ("prog1", Fprog1, Sprog1, 1, UNEVALLED, 0,
doc: /* Eval FIRST and BODY sequentially; return value from FIRST.
The value of FIRST is saved during the evaluation of the remaining args,
(Lisp_Object args)
{
Lisp_Object val;
- register Lisp_Object args_left;
+ Lisp_Object args_left;
struct gcpro gcpro1, gcpro2;
args_left = args;
- val = Qnil;
+ val = args;
GCPRO2 (args, val);
val = eval_sub (XCAR (args_left));
usage: (setq [SYM VAL]...) */)
(Lisp_Object args)
{
- register Lisp_Object args_left;
- register Lisp_Object val, sym, lex_binding;
- struct gcpro gcpro1;
+ Lisp_Object val, sym, lex_binding;
- if (NILP (args))
- return Qnil;
-
- args_left = args;
- GCPRO1 (args);
-
- do
+ val = args;
+ if (CONSP (args))
{
- val = eval_sub (Fcar (Fcdr (args_left)));
- sym = Fcar (args_left);
+ Lisp_Object args_left = args;
+ struct gcpro gcpro1;
+ GCPRO1 (args);
- /* Like for eval_sub, we do not check declared_special here since
- it's been done when let-binding. */
- if (!NILP (Vinternal_interpreter_environment) /* Mere optimization! */
- && SYMBOLP (sym)
- && !NILP (lex_binding
- = Fassq (sym, Vinternal_interpreter_environment)))
- XSETCDR (lex_binding, val); /* SYM is lexically bound. */
- else
- Fset (sym, val); /* SYM is dynamically bound. */
+ do
+ {
+ val = eval_sub (Fcar (XCDR (args_left)));
+ sym = XCAR (args_left);
+
+ /* Like for eval_sub, we do not check declared_special here since
+ it's been done when let-binding. */
+ if (!NILP (Vinternal_interpreter_environment) /* Mere optimization! */
+ && SYMBOLP (sym)
+ && !NILP (lex_binding
+ = Fassq (sym, Vinternal_interpreter_environment)))
+ XSETCDR (lex_binding, val); /* SYM is lexically bound. */
+ else
+ Fset (sym, val); /* SYM is dynamically bound. */
+
+ args_left = Fcdr (XCDR (args_left));
+ }
+ while (CONSP (args_left));
- args_left = Fcdr (Fcdr (args_left));
+ UNGCPRO;
}
- while (!NILP (args_left));
- UNGCPRO;
return val;
}
usage: (quote ARG) */)
(Lisp_Object args)
{
- if (!NILP (Fcdr (args)))
+ if (CONSP (XCDR (args)))
xsignal2 (Qwrong_number_of_arguments, Qquote, Flength (args));
- return Fcar (args);
+ return XCAR (args);
}
DEFUN ("function", Ffunction, Sfunction, 1, UNEVALLED, 0,
{
Lisp_Object quoted = XCAR (args);
- if (!NILP (Fcdr (args)))
+ if (CONSP (XCDR (args)))
xsignal2 (Qwrong_number_of_arguments, Qfunction, Flength (args));
if (!NILP (Vinternal_interpreter_environment)
return base_variable;
}
+static union specbinding *
+default_toplevel_binding (Lisp_Object symbol)
+{
+ union specbinding *binding = NULL;
+ union specbinding *pdl = specpdl_ptr;
+ while (pdl > specpdl)
+ {
+ switch ((--pdl)->kind)
+ {
+ case SPECPDL_LET_DEFAULT:
+ case SPECPDL_LET:
+ if (EQ (specpdl_symbol (pdl), symbol))
+ binding = pdl;
+ break;
+ }
+ }
+ return binding;
+}
+
+DEFUN ("default-toplevel-value", Fdefault_toplevel_value, Sdefault_toplevel_value, 1, 1, 0,
+ doc: /* Return SYMBOL's toplevel default value.
+"Toplevel" means outside of any let binding. */)
+ (Lisp_Object symbol)
+{
+ union specbinding *binding = default_toplevel_binding (symbol);
+ Lisp_Object value
+ = binding ? specpdl_old_value (binding) : Fdefault_value (symbol);
+ if (!EQ (value, Qunbound))
+ return value;
+ xsignal1 (Qvoid_variable, symbol);
+}
+
+DEFUN ("set-default-toplevel-value", Fset_default_toplevel_value,
+ Sset_default_toplevel_value, 2, 2, 0,
+ doc: /* Set SYMBOL's toplevel default value to VALUE.
+"Toplevel" means outside of any let binding. */)
+ (Lisp_Object symbol, Lisp_Object value)
+{
+ union specbinding *binding = default_toplevel_binding (symbol);
+ if (binding)
+ set_specpdl_old_value (binding, value);
+ else
+ Fset_default (symbol, value);
+ return Qnil;
+}
DEFUN ("defvar", Fdefvar, Sdefvar, 1, UNEVALLED, 0,
doc: /* Define SYMBOL as a variable, and return SYMBOL.
usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
(Lisp_Object args)
{
- register Lisp_Object sym, tem, tail;
+ Lisp_Object sym, tem, tail;
- sym = Fcar (args);
- tail = Fcdr (args);
- if (!NILP (Fcdr (Fcdr (tail))))
- error ("Too many arguments");
+ sym = XCAR (args);
+ tail = XCDR (args);
- tem = Fdefault_boundp (sym);
- if (!NILP (tail))
+ if (CONSP (tail))
{
+ if (CONSP (XCDR (tail)) && CONSP (XCDR (XCDR (tail))))
+ error ("Too many arguments");
+
+ tem = Fdefault_boundp (sym);
+
/* Do it before evaluating the initial value, for self-references. */
XSYMBOL (sym)->declared_special = 1;
if (NILP (tem))
- Fset_default (sym, eval_sub (Fcar (tail)));
+ Fset_default (sym, eval_sub (XCAR (tail)));
else
{ /* Check if there is really a global binding rather than just a let
binding that shadows the global unboundness of the var. */
- union specbinding *pdl = specpdl_ptr;
- while (pdl > specpdl)
+ union specbinding *binding = default_toplevel_binding (sym);
+ if (binding && EQ (specpdl_old_value (binding), Qunbound))
{
- if ((--pdl)->kind >= SPECPDL_LET
- && EQ (specpdl_symbol (pdl), sym)
- && EQ (specpdl_old_value (pdl), Qunbound))
- {
- message_with_string
- ("Warning: defvar ignored because %s is let-bound",
- SYMBOL_NAME (sym), 1);
- break;
- }
+ set_specpdl_old_value (binding, eval_sub (XCAR (tail)));
}
}
- tail = Fcdr (tail);
+ tail = XCDR (tail);
tem = Fcar (tail);
if (!NILP (tem))
{
usage: (defconst SYMBOL INITVALUE [DOCSTRING]) */)
(Lisp_Object args)
{
- register Lisp_Object sym, tem;
+ Lisp_Object sym, tem;
- sym = Fcar (args);
- if (!NILP (Fcdr (Fcdr (Fcdr (args)))))
+ sym = XCAR (args);
+ if (CONSP (Fcdr (XCDR (XCDR (args)))))
error ("Too many arguments");
- tem = eval_sub (Fcar (Fcdr (args)));
+ tem = eval_sub (Fcar (XCDR (args)));
if (!NILP (Vpurify_flag))
tem = Fpurecopy (tem);
Fset_default (sym, tem);
XSYMBOL (sym)->declared_special = 1;
- tem = Fcar (Fcdr (Fcdr (args)));
+ tem = Fcar (XCDR (XCDR (args)));
if (!NILP (tem))
{
if (!NILP (Vpurify_flag))
lexenv = Vinternal_interpreter_environment;
- varlist = Fcar (args);
+ varlist = XCAR (args);
while (CONSP (varlist))
{
QUIT;
varlist = XCDR (varlist);
}
UNGCPRO;
- val = Fprogn (Fcdr (args));
+ val = Fprogn (XCDR (args));
return unbind_to (count, val);
}
struct gcpro gcpro1, gcpro2;
USE_SAFE_ALLOCA;
- varlist = Fcar (args);
+ varlist = XCAR (args);
/* Make space to hold the values to give the bound variables. */
elt = Flength (varlist);
lexenv = Vinternal_interpreter_environment;
- varlist = Fcar (args);
+ varlist = XCAR (args);
for (argnum = 0; CONSP (varlist); varlist = XCDR (varlist))
{
Lisp_Object var;
/* Instantiate a new lexical environment. */
specbind (Qinternal_interpreter_environment, lexenv);
- elt = Fprogn (Fcdr (args));
+ elt = Fprogn (XCDR (args));
SAFE_FREE ();
return unbind_to (count, elt);
}
GCPRO2 (test, body);
- test = Fcar (args);
- body = Fcdr (args);
+ test = XCAR (args);
+ body = XCDR (args);
while (!NILP (eval_sub (test)))
{
QUIT;
struct gcpro gcpro1;
GCPRO1 (args);
- tag = eval_sub (Fcar (args));
+ tag = eval_sub (XCAR (args));
UNGCPRO;
- return internal_catch (tag, Fprogn, Fcdr (args));
+ return internal_catch (tag, Fprogn, XCDR (args));
}
/* Set up a catch, then call C function FUNC on argument ARG.
Lisp_Object val;
ptrdiff_t count = SPECPDL_INDEX ();
- record_unwind_protect (Fprogn, Fcdr (args));
- val = eval_sub (Fcar (args));
+ record_unwind_protect (unwind_body, XCDR (args));
+ val = eval_sub (XCAR (args));
return unbind_to (count, val);
}
\f
usage: (condition-case VAR BODYFORM &rest HANDLERS) */)
(Lisp_Object args)
{
- Lisp_Object var = Fcar (args);
- Lisp_Object bodyform = Fcar (Fcdr (args));
- Lisp_Object handlers = Fcdr (Fcdr (args));
+ Lisp_Object var = XCAR (args);
+ Lisp_Object bodyform = XCAR (XCDR (args));
+ Lisp_Object handlers = XCDR (XCDR (args));
return internal_lisp_condition_case (var, bodyform, handlers);
}
Qnil);
}
-Lisp_Object
+void
un_autoload (Lisp_Object oldqueue)
{
- register Lisp_Object queue, first, second;
+ Lisp_Object queue, first, second;
/* Queue to unwind is current value of Vautoload_queue.
oldqueue is the shadowed value to leave in Vautoload_queue. */
Ffset (first, second);
queue = XCDR (queue);
}
- return Qnil;
}
/* Load an autoloaded function.
\f
DEFUN ("eval", Feval, Seval, 1, 2, 0,
doc: /* Evaluate FORM and return its value.
-If LEXICAL is t, evaluate using lexical scoping. */)
+If LEXICAL is t, evaluate using lexical scoping.
+LEXICAL can also be an actual lexical environment, in the form of an
+alist mapping symbols to their value. */)
(Lisp_Object form, Lisp_Object lexical)
{
ptrdiff_t count = SPECPDL_INDEX ();
/* Optimize for no indirection. */
fun = original_fun;
- if (SYMBOLP (fun) && !NILP (fun)
- && (fun = XSYMBOL (fun)->function, SYMBOLP (fun)))
+ if (!SYMBOLP (fun))
+ fun = Ffunction (Fcons (fun, Qnil));
+ else if (!NILP (fun) && (fun = XSYMBOL (fun)->function, SYMBOLP (fun)))
fun = indirect_function (fun);
if (SUBRP (fun))
return 0;
}
-/* `specpdl_ptr->symbol' is a field which describes which variable is
+/* `specpdl_ptr' 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
- a symbol that is not buffer-local (at least at the time
- the let binding started). Note also that it should not be
+ It can be either a plain SPECPDL_LET or a SPECPDL_LET_LOCAL/DEFAULT.
+ - SYMBOL is the variable being bound. Note that it should not be
aliased (i.e. when let-binding V1 that's aliased to V2, we want
to record V2 here).
- - (SYMBOL WHERE . BUFFER) : this means that it is a let-binding for
- variable SYMBOL which can be buffer-local. WHERE tells us
- which buffer is affected (or nil if the let-binding affects the
- global value of the variable) and BUFFER tells us which buffer was
- current (i.e. if WHERE is non-nil, then BUFFER==WHERE, otherwise
- BUFFER did not yet have a buffer-local value). */
+ - WHERE tells us in which buffer the binding took place.
+ This is used for SPECPDL_LET_LOCAL bindings (i.e. bindings to a
+ buffer-local variable) as well as for SPECPDL_LET_DEFAULT bindings,
+ i.e. bindings to the default value of a variable which can be
+ buffer-local. */
void
specbind (Lisp_Object symbol, Lisp_Object value)
}
}
+/* Push unwind-protect entries of various types. */
+
void
-record_unwind_protect (Lisp_Object (*function) (Lisp_Object), Lisp_Object arg)
+record_unwind_protect (void (*function) (Lisp_Object), Lisp_Object arg)
{
specpdl_ptr->unwind.kind = SPECPDL_UNWIND;
specpdl_ptr->unwind.func = function;
grow_specpdl ();
}
+void
+record_unwind_protect_ptr (void (*function) (void *), void *arg)
+{
+ specpdl_ptr->unwind_ptr.kind = SPECPDL_UNWIND_PTR;
+ specpdl_ptr->unwind_ptr.func = function;
+ specpdl_ptr->unwind_ptr.arg = arg;
+ grow_specpdl ();
+}
+
+void
+record_unwind_protect_int (void (*function) (int), int arg)
+{
+ specpdl_ptr->unwind_int.kind = SPECPDL_UNWIND_INT;
+ specpdl_ptr->unwind_int.func = function;
+ specpdl_ptr->unwind_int.arg = arg;
+ grow_specpdl ();
+}
+
+void
+record_unwind_protect_void (void (*function) (void))
+{
+ specpdl_ptr->unwind_void.kind = SPECPDL_UNWIND_VOID;
+ specpdl_ptr->unwind_void.func = function;
+ grow_specpdl ();
+}
+
+static void
+do_nothing (void)
+{}
+
+/* Push an unwind-protect entry that does nothing, so that
+ set_unwind_protect_ptr can overwrite it later. */
+
+void
+record_unwind_protect_nothing (void)
+{
+ record_unwind_protect_void (do_nothing);
+}
+
+/* Clear the unwind-protect entry COUNT, so that it does nothing.
+ It need not be at the top of the stack. */
+
+void
+clear_unwind_protect (ptrdiff_t count)
+{
+ union specbinding *p = specpdl + count;
+ p->unwind_void.kind = SPECPDL_UNWIND_VOID;
+ p->unwind_void.func = do_nothing;
+}
+
+/* Set the unwind-protect entry COUNT so that it invokes FUNC (ARG).
+ It need not be at the top of the stack. Discard the entry's
+ previous value without invoking it. */
+
+void
+set_unwind_protect (ptrdiff_t count, void (*func) (Lisp_Object),
+ Lisp_Object arg)
+{
+ union specbinding *p = specpdl + count;
+ p->unwind.kind = SPECPDL_UNWIND;
+ p->unwind.func = func;
+ p->unwind.arg = arg;
+}
+
+void
+set_unwind_protect_ptr (ptrdiff_t count, void (*func) (void *), void *arg)
+{
+ union specbinding *p = specpdl + count;
+ p->unwind_ptr.kind = SPECPDL_UNWIND_PTR;
+ p->unwind_ptr.func = func;
+ p->unwind_ptr.arg = arg;
+}
+
+/* Pop and execute entries from the unwind-protect stack until the
+ depth COUNT is reached. Return VALUE. */
+
Lisp_Object
unbind_to (ptrdiff_t count, Lisp_Object value)
{
switch (specpdl_ptr->kind)
{
case SPECPDL_UNWIND:
- specpdl_func (specpdl_ptr) (specpdl_arg (specpdl_ptr));
+ specpdl_ptr->unwind.func (specpdl_ptr->unwind.arg);
break;
- case SPECPDL_LET:
- /* If variable has a trivial value (no forwarding), we can
- just set it. No need to check for constant symbols here,
- since that was already done by specbind. */
- if (XSYMBOL (specpdl_symbol (specpdl_ptr))->redirect
- == SYMBOL_PLAINVAL)
- SET_SYMBOL_VAL (XSYMBOL (specpdl_symbol (specpdl_ptr)),
- specpdl_old_value (specpdl_ptr));
- else
- /* NOTE: we only ever come here if make_local_foo was used for
- the first time on this var within this let. */
- Fset_default (specpdl_symbol (specpdl_ptr),
- specpdl_old_value (specpdl_ptr));
+ case SPECPDL_UNWIND_PTR:
+ specpdl_ptr->unwind_ptr.func (specpdl_ptr->unwind_ptr.arg);
+ break;
+ case SPECPDL_UNWIND_INT:
+ specpdl_ptr->unwind_int.func (specpdl_ptr->unwind_int.arg);
+ break;
+ case SPECPDL_UNWIND_VOID:
+ specpdl_ptr->unwind_void.func ();
break;
case SPECPDL_BACKTRACE:
break;
- case SPECPDL_LET_LOCAL:
+ case SPECPDL_LET:
+ { /* If variable has a trivial value (no forwarding), we can
+ just set it. No need to check for constant symbols here,
+ since that was already done by specbind. */
+ struct Lisp_Symbol *sym = XSYMBOL (specpdl_symbol (specpdl_ptr));
+ if (sym->redirect == SYMBOL_PLAINVAL)
+ {
+ SET_SYMBOL_VAL (sym, specpdl_old_value (specpdl_ptr));
+ break;
+ }
+ else
+ { /* FALLTHROUGH!!
+ NOTE: we only ever come here if make_local_foo was used for
+ the first time on this var within this let. */
+ }
+ }
case SPECPDL_LET_DEFAULT:
- { /* If the symbol is a list, it is really (SYMBOL WHERE
- . CURRENT-BUFFER) where WHERE is either nil, a buffer, or a
- frame. If WHERE is a buffer or frame, this indicates we
- bound a variable that had a buffer-local or frame-local
- binding. WHERE nil means that the variable had the default
- value when it was bound. CURRENT-BUFFER is the buffer that
- was current when the variable was bound. */
+ Fset_default (specpdl_symbol (specpdl_ptr),
+ specpdl_old_value (specpdl_ptr));
+ break;
+ case SPECPDL_LET_LOCAL:
+ {
Lisp_Object symbol = specpdl_symbol (specpdl_ptr);
Lisp_Object where = specpdl_where (specpdl_ptr);
Lisp_Object old_value = specpdl_old_value (specpdl_ptr);
eassert (BUFFERP (where));
- if (specpdl_ptr->kind == SPECPDL_LET_DEFAULT)
- Fset_default (symbol, old_value);
/* If this was a local binding, reset the value in the appropriate
buffer, but only if that buffer's binding still exists. */
- else if (!NILP (Flocal_variable_p (symbol, where)))
+ if (!NILP (Flocal_variable_p (symbol, where)))
set_internal (symbol, old_value, where, 1);
}
break;
return Qnil;
}
-DEFUN ("backtrace-frame", Fbacktrace_frame, Sbacktrace_frame, 1, 1, NULL,
+static union specbinding *
+get_backtrace_frame (Lisp_Object nframes, Lisp_Object base)
+{
+ union specbinding *pdl = backtrace_top ();
+ register EMACS_INT i;
+
+ CHECK_NATNUM (nframes);
+
+ if (!NILP (base))
+ { /* Skip up to `base'. */
+ base = Findirect_function (base, Qt);
+ while (backtrace_p (pdl)
+ && !EQ (base, Findirect_function (backtrace_function (pdl), Qt)))
+ pdl = backtrace_next (pdl);
+ }
+
+ /* Find the frame requested. */
+ for (i = XFASTINT (nframes); i > 0 && backtrace_p (pdl); i--)
+ pdl = backtrace_next (pdl);
+
+ return pdl;
+}
+
+DEFUN ("backtrace-frame", Fbacktrace_frame, Sbacktrace_frame, 1, 2, NULL,
doc: /* 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...).
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 NFRAMES is more than the number of frames, the value is nil. */)
- (Lisp_Object nframes)
+If NFRAMES is more than the number of frames, the value is nil.
+If BASE is non-nil, it should be a function and NFRAMES counts from its
+nearest activation frame. */)
+ (Lisp_Object nframes, Lisp_Object base)
{
- union specbinding *pdl = backtrace_top ();
- register EMACS_INT i;
-
- CHECK_NATNUM (nframes);
-
- /* Find the frame requested. */
- for (i = 0; backtrace_p (pdl) && i < XFASTINT (nframes); i++)
- pdl = backtrace_next (pdl);
+ union specbinding *pdl = get_backtrace_frame (nframes, base);
if (!backtrace_p (pdl))
return Qnil;
}
}
+/* For backtrace-eval, we want to temporarily unwind the last few elements of
+ the specpdl stack, and then rewind them. We store the pre-unwind values
+ directly in the pre-existing specpdl elements (i.e. we swap the current
+ value and the old value stored in the specpdl), kind of like the inplace
+ pointer-reversal trick. As it turns out, the rewind does the same as the
+ unwind, except it starts from the other end of the specpdl stack, so we use
+ the same function for both unwind and rewind. */
+static void
+backtrace_eval_unrewind (int distance)
+{
+ union specbinding *tmp = specpdl_ptr;
+ int step = -1;
+ if (distance < 0)
+ { /* It's a rewind rather than unwind. */
+ tmp += distance - 1;
+ step = 1;
+ distance = -distance;
+ }
+
+ for (; distance > 0; distance--)
+ {
+ tmp += step;
+ /* */
+ switch (tmp->kind)
+ {
+ /* FIXME: Ideally we'd like to "temporarily unwind" (some of) those
+ unwind_protect, but the problem is that we don't know how to
+ rewind them afterwards. */
+ case SPECPDL_UNWIND:
+ case SPECPDL_UNWIND_PTR:
+ case SPECPDL_UNWIND_INT:
+ case SPECPDL_UNWIND_VOID:
+ case SPECPDL_BACKTRACE:
+ break;
+ case SPECPDL_LET:
+ { /* If variable has a trivial value (no forwarding), we can
+ just set it. No need to check for constant symbols here,
+ since that was already done by specbind. */
+ struct Lisp_Symbol *sym = XSYMBOL (specpdl_symbol (tmp));
+ if (sym->redirect == SYMBOL_PLAINVAL)
+ {
+ Lisp_Object old_value = specpdl_old_value (tmp);
+ set_specpdl_old_value (tmp, SYMBOL_VAL (sym));
+ SET_SYMBOL_VAL (sym, old_value);
+ break;
+ }
+ else
+ { /* FALLTHROUGH!!
+ NOTE: we only ever come here if make_local_foo was used for
+ the first time on this var within this let. */
+ }
+ }
+ case SPECPDL_LET_DEFAULT:
+ {
+ Lisp_Object sym = specpdl_symbol (tmp);
+ Lisp_Object old_value = specpdl_old_value (tmp);
+ set_specpdl_old_value (tmp, Fdefault_value (sym));
+ Fset_default (sym, old_value);
+ }
+ break;
+ case SPECPDL_LET_LOCAL:
+ {
+ Lisp_Object symbol = specpdl_symbol (tmp);
+ Lisp_Object where = specpdl_where (tmp);
+ Lisp_Object old_value = specpdl_old_value (tmp);
+ eassert (BUFFERP (where));
+
+ /* If this was a local binding, reset the value in the appropriate
+ buffer, but only if that buffer's binding still exists. */
+ if (!NILP (Flocal_variable_p (symbol, where)))
+ {
+ set_specpdl_old_value
+ (tmp, Fbuffer_local_value (symbol, where));
+ set_internal (symbol, old_value, where, 1);
+ }
+ }
+ break;
+ }
+ }
+}
+
+DEFUN ("backtrace-eval", Fbacktrace_eval, Sbacktrace_eval, 2, 3, NULL,
+ doc: /* Evaluate EXP in the context of some activation frame.
+NFRAMES and BASE specify the activation frame to use, as in `backtrace-frame'. */)
+ (Lisp_Object exp, Lisp_Object nframes, Lisp_Object base)
+{
+ union specbinding *pdl = get_backtrace_frame (nframes, base);
+ ptrdiff_t count = SPECPDL_INDEX ();
+ ptrdiff_t distance = specpdl_ptr - pdl;
+ eassert (distance >= 0);
+
+ if (!backtrace_p (pdl))
+ error ("Activation frame not found!");
+
+ backtrace_eval_unrewind (distance);
+ record_unwind_protect_int (backtrace_eval_unrewind, -distance);
+
+ /* Use eval_sub rather than Feval since the main motivation behind
+ backtrace-eval is to be able to get/set the value of lexical variables
+ from the debugger. */
+ return unbind_to (count, eval_sub (exp));
+}
\f
void
mark_specpdl (void)
defsubr (&Ssetq);
defsubr (&Squote);
defsubr (&Sfunction);
+ defsubr (&Sdefault_toplevel_value);
+ defsubr (&Sset_default_toplevel_value);
defsubr (&Sdefvar);
defsubr (&Sdefvaralias);
defsubr (&Sdefconst);
defsubr (&Sbacktrace_debug);
defsubr (&Sbacktrace);
defsubr (&Sbacktrace_frame);
+ defsubr (&Sbacktrace_eval);
defsubr (&Sspecial_variable_p);
defsubr (&Sfunctionp);
}
HCoop / bpt / emacs.git / blobdiff