static SEXP
Rf_getCallingDLL(void)
{
SEXP e, ans;
SEXP rho = R_NilValue;
Rboolean found = FALSE;
/* First find the environment of the caller.
Testing shows this is the right caller, despite the .C/.Call ...
*/
{
ClosureContext* cptr = ClosureContext::innermost();
if (cptr)
rho = cptr->workingEnvironment();
}
/* Then search up until we hit a namespace or globalenv.
The idea is that we will not find a namespace unless the caller
was defined in one. */
while(rho != R_NilValue) {
if (rho == R_GlobalEnv) break;
else if (R_IsNamespaceEnv(rho)) {
found = TRUE;
break;
}
rho = ENCLOS(rho);
}
if(!found) return R_NilValue;
PROTECT(e = lang2(install("getCallingDLLe"), rho));
ans = eval(e, R_GlobalEnv);
UNPROTECT(1);
return(ans);
}
static ClosureContext* findClosureWithWorkingEnvironment(
const Environment* env,
ClosureContext* start = ClosureContext::innermost())
{
ClosureContext* context = start;
while (context && context->workingEnvironment() != env) {
context = ClosureContext::innermost(context->nextOut());
}
return context;
}
SEXP attribute_hidden do_sysbrowser(/*const*/ Expression* call, const BuiltInFunction* op, RObject* n_)
{
int n;
n = asInteger(n_);
if(n < 1 ) error(_("number of contexts must be positive"));
switch (op->variant()) {
case 1: /* text */
case 2: /* condition */
{
if (n > int(Browser::numberActive())) {
if (n == 1)
Rf_error(_("no browser context to query"));
else Rf_error(_("not that many calls to browser are active"));
}
Browser* browser
= Browser::fromOutermost(Browser::numberActive() - n);
return op->variant() == 1 ? browser->text() : browser->condition();
}
break;
case 3: /* turn on debugging n levels up */
{
if (Browser::numberActive() == 0)
Rf_error(_("no browser context to query"));
Browser* browser
= Browser::fromOutermost(Browser::numberActive() - 1);
ClosureContext* cptr = ClosureContext::innermost(browser->context());
while (cptr && n > 1) {
n--;
cptr = ClosureContext::innermost(cptr->nextOut());
}
if (!cptr)
error(_("not that many functions on the call stack"));
else {
SET_RDEBUG(cptr->workingEnvironment(), TRUE);
}
}
break;
}
return nullptr;
}
SEXP attribute_hidden do_parentframe(/*const*/ Expression* call, const BuiltInFunction* op, RObject* n_)
{
ClosureContext *cptr;
int n = asInteger(n_);
if(n == NA_INTEGER || n < 1 )
error(_("invalid '%s' value"), "n");
cptr = ClosureContext::innermost();
SEXP t = cptr->callEnvironment();
while (cptr){
if (cptr->workingEnvironment() == t)
{
if (n == 1)
return cptr->callEnvironment();
n--;
t = cptr->callEnvironment();
}
cptr = ClosureContext::innermost(cptr->nextOut());
}
return R_GlobalEnv;
}
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 */
}
}
