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