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 */ } }