static void R_OutputStackTrace(FILE *file)
{
int newline = 0;
Evaluator::Context *cptr;
for (cptr = Evaluator::Context::innermost(); cptr; cptr = cptr->nextOut()) {
Evaluator::Context::Type type = cptr->type();
if (type == Evaluator::Context::FUNCTION
|| type == Evaluator::Context::CLOSURE) {
FunctionContext* fctxt = static_cast<FunctionContext*>(cptr);
SEXP fun = fctxt->call()->car();
if (!newline) newline = 1;
fprintf(file, "\"%s\" ",
TYPEOF(fun) == SYMSXP ? CHAR(PRINTNAME(fun)) :
"<Anonymous>");
}
}
if (newline) fprintf(file, "\n");
}
SEXP attribute_hidden do_sys(/*const*/ Expression* call, const BuiltInFunction* op, Environment* rho, RObject* const* args, int num_args, const PairList* tags)
{
int i, n = -1, nframe;
SEXP rval, t;
ClosureContext *cptr;
/* first find the context that sys.xxx needs to be evaluated in */
cptr = ClosureContext::innermost();
t = cptr->callEnvironment();
while (cptr && cptr->workingEnvironment() != t)
cptr = ClosureContext::innermost(cptr->nextOut());
if (num_args == 1) n = asInteger(args[0]);
switch (op->variant()) {
case 1: /* parent */
if(n == NA_INTEGER)
error(_("invalid '%s' argument"), "n");
i = nframe = framedepth(cptr);
/* This is a pretty awful kludge, but the alternative would be
a major redesign of everything... -pd */
while (n-- > 0)
i = R_sysparent(nframe - i + 1, cptr);
return ScalarInteger(i);
case 2: /* call */
if(n == NA_INTEGER)
error(_("invalid '%s' argument"), "which");
return R_syscall(n, cptr);
case 3: /* frame */
if(n == NA_INTEGER)
error(_("invalid '%s' argument"), "which");
return R_sysframe(n, cptr);
case 4: /* sys.nframe */
return ScalarInteger(framedepth(cptr));
case 5: /* sys.calls */
nframe = framedepth(cptr);
PROTECT(rval = allocList(nframe));
t=rval;
for(i = 1; i <= nframe; i++, t = CDR(t))
SETCAR(t, R_syscall(i, cptr));
UNPROTECT(1);
return rval;
case 6: /* sys.frames */
nframe = framedepth(cptr);
PROTECT(rval = allocList(nframe));
t = rval;
for(i = 1; i <= nframe; i++, t = CDR(t))
SETCAR(t, R_sysframe(i, cptr));
UNPROTECT(1);
return rval;
case 7: /* sys.on.exit */
{
ClosureContext* ctxt = ClosureContext::innermost();
if (ctxt->nextOut()) {
Evaluator::Context* nxt = ctxt->nextOut();
if (nxt->type() == Evaluator::Context::CLOSURE)
return static_cast<ClosureContext*>(nxt)->onExit();
}
return R_NilValue;
}
case 8: /* sys.parents */
nframe = framedepth(cptr);
rval = allocVector(INTSXP, nframe);
for(i = 0; i < nframe; i++)
INTEGER(rval)[i] = R_sysparent(nframe - i, cptr);
return rval;
case 9: /* sys.function */
if(n == NA_INTEGER)
error(_("invalid '%s' value"), "which");
return(R_sysfunction(n, cptr));
default:
error(_("internal error in 'do_sys'"));
return R_NilValue;/* just for -Wall */
}
}