SEXP attribute_hidden do_parentenvgets(SEXP call, SEXP op, SEXP args, SEXP rho) { SEXP env, parent; checkArity(op, args); env = CAR(args); if (isNull(env)) { error(_("use of NULL environment is defunct")); env = R_BaseEnv; } else if( !isEnvironment(env) && !isEnvironment((env = simple_as_environment(env)))) error(_("argument is not an environment")); if( env == R_EmptyEnv ) error(_("can not set parent of the empty environment")); if (R_EnvironmentIsLocked(env) && R_IsNamespaceEnv(env)) error(_("can not set the parent environment of a namespace")); if (R_EnvironmentIsLocked(env) && R_IsImportsEnv(env)) error(_("can not set the parent environment of package imports")); parent = CADR(args); if (isNull(parent)) { error(_("use of NULL environment is defunct")); parent = R_BaseEnv; } else if( !isEnvironment(parent) && !isEnvironment((parent = simple_as_environment(parent)))) error(_("'parent' is not an environment")); SET_ENCLOS(env, parent); return( CAR(args) ); }
/* based on EncodeEnvironment in printutils.c */ static void PrintEnvironment(SEXP x) { const void *vmax = vmaxget(); if (x == R_GlobalEnv) Rprintf("<R_GlobalEnv>"); else if (x == R_BaseEnv) Rprintf("<base>"); else if (x == R_EmptyEnv) Rprintf("<R_EmptyEnv>"); else if (R_IsPackageEnv(x)) Rprintf("<%s>", translateChar(STRING_ELT(R_PackageEnvName(x), 0))); else if (R_IsNamespaceEnv(x)) Rprintf("<namespace:%s>", translateChar(STRING_ELT(R_NamespaceEnvSpec(x), 0))); else Rprintf("<%p>", (void *)x); vmaxset(vmax); }
SEXP attribute_hidden do_envirName(SEXP call, SEXP op, SEXP args, SEXP rho) { SEXP env = CAR(args), ans=mkString(""), res; checkArity(op, args); if (TYPEOF(env) == ENVSXP || TYPEOF((env = simple_as_environment(env))) == ENVSXP) { if (env == R_GlobalEnv) ans = mkString("R_GlobalEnv"); else if (env == R_BaseEnv) ans = mkString("base"); else if (env == R_EmptyEnv) ans = mkString("R_EmptyEnv"); else if (R_IsPackageEnv(env)) ans = ScalarString(STRING_ELT(R_PackageEnvName(env), 0)); else if (R_IsNamespaceEnv(env)) ans = ScalarString(STRING_ELT(R_NamespaceEnvSpec(env), 0)); else if (!isNull(res = getAttrib(env, R_NameSymbol))) ans = res; } return ans; }
const char *EncodeEnvironment(SEXP x) { static char ch[1000]; if (x == R_GlobalEnv) sprintf(ch, "<environment: R_GlobalEnv>"); else if (x == R_BaseEnv) sprintf(ch, "<environment: base>"); else if (x == R_EmptyEnv) sprintf(ch, "<environment: R_EmptyEnv>"); else if (R_IsPackageEnv(x)) snprintf(ch, 1000, "<environment: %s>", translateChar(STRING_ELT(R_PackageEnvName(x), 0))); else if (R_IsNamespaceEnv(x)) snprintf(ch, 1000, "<environment: namespace:%s>", translateChar(STRING_ELT(R_NamespaceEnvSpec(x), 0))); else snprintf(ch, 1000, "<environment: %p>", (void *)x); return ch; }