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) );
}
SEXP SmokeObject::createSexp(SEXP parentEnv) {
SEXP env;
PROTECT(env = allocSExp(ENVSXP));
SET_ENCLOS(env, parentEnv);
castSexp(env);
UNPROTECT(1);
return env;
}
SEXP SmokeObject::fieldEnv() const {
if (!_fieldEnv) {
_fieldEnv = allocSExp(ENVSXP);
SET_ENCLOS(_fieldEnv, R_EmptyEnv);
SET_FRAME(_fieldEnv, R_NilValue);
R_PreserveObject(_fieldEnv);
}
return _fieldEnv;
}
SEXP
newRClosureTable(SEXP handlers)
{
R_ObjectTable *tb;
SEXP val, klass, env;
tb = (R_ObjectTable *) malloc(sizeof(R_ObjectTable));
if(!tb)
error("cannot allocate space for an internal R object table");
tb->type = 15;
tb->cachedNames = NULL;
tb->active = TRUE;
R_PreserveObject(handlers);
tb->privateData = handlers;
tb->exists = RClosureTable_exists;
tb->get = RClosureTable_get;
tb->remove = RClosureTable_remove;
tb->assign = RClosureTable_assign;
tb->objects = RClosureTable_objects;
tb->canCache = RClosureTable_canCache;
tb->onAttach = NULL;
tb->onDetach = NULL;
PROTECT(val = R_MakeExternalPtr(tb, Rf_install("UserDefinedDatabase"), R_NilValue));
PROTECT(klass = NEW_CHARACTER(1));
SET_STRING_ELT(klass, 0, COPY_TO_USER_STRING("UserDefinedDatabase"));
SET_CLASS(val, klass);
env = allocSExp(ENVSXP);
SET_HASHTAB(env, val);
SET_ENCLOS(env, R_GlobalEnv);
setAttrib(env, R_ClassSymbol, getAttrib(HASHTAB(env), R_ClassSymbol));
UNPROTECT(2);
return(env);
}
