Make r_env_poke_parent() use parent.env<- and make it internal (#1847)

Author: DavisVaughan

src/internal/decl/env-binding-decl.h

@@ -0,0 +1,6 @@
+static
+r_obj* env_get_sym(r_obj* env,
+                   r_obj* sym,
+                   bool inherit,
+                   r_obj* last,
+                   r_obj* closure_env);

src/internal/decl/env-decl.h

@@ -1,6 +1 @@
-static
-r_obj* env_get_sym(r_obj* env,
-                   r_obj* sym,
-                   bool inherit,
-                   r_obj* last,
-                   r_obj* closure_env);
+static r_obj* env_poke_parent_call;

src/internal/env-binding.c

@@ -3,7 +3,7 @@
 #include "env.h"
 #include "quo.h"
 
-#include "decl/env-decl.h"
+#include "decl/env-binding-decl.h"
 
 
 r_obj* ffi_env_get(r_obj* env,

src/internal/env.c

@@ -1,5 +1,7 @@
 #include <rlang.h>
 
+#include "decl/env-decl.h"
+
 void r_env_unbind_anywhere(r_obj* env, r_obj* sym) {
   while (env != r_envs.empty) {
     if (r_env_has(env, sym)) {
@@ -58,7 +60,18 @@ void r_env_unbind_anywhere_c_string(r_obj* env, const char* name) {
   r_env_unbind_anywhere_c_strings(env, names, 1);
 }
 
+void r_env_poke_parent(r_obj* env, r_obj* new_parent) {
+  r_eval_with_xy(env_poke_parent_call, env, new_parent, r_envs.base);
+}
+
 r_obj* ffi_env_coalesce(r_obj* env, r_obj* from) {
   r_env_coalesce(env, from);
   return r_null;
 }
+
+void rlang_init_env(void) {
+  env_poke_parent_call = r_parse("`parent.env<-`(x, y)");
+  r_preserve(env_poke_parent_call);
+}
+
+static r_obj* env_poke_parent_call = NULL;

src/internal/env.h

@@ -13,5 +13,8 @@ void r_env_unbind_names(r_obj* env, r_obj* names);
 void r_env_unbind_c_string(r_obj* env, const char* name);
 void r_env_unbind_c_strings(r_obj* env, const char** strings, r_ssize n);
 
+// Not part of the rlang C API.
+// Maybe one day we will get a blessed C API for `SET_ENCLOS()`.
+void r_env_poke_parent(r_obj* env, r_obj* new_parent);
 
 #endif

src/internal/exported.c

@@ -1,4 +1,5 @@
 #include <rlang.h>
+#include "env.h"
 #include "internal.h"
 #include "utils.h"
 #include "vec.h"
@@ -453,6 +454,9 @@ r_obj* ffi_lof_arr_push_back(r_obj* lof, r_obj* i, r_obj* value) {
 // env.c
 
 r_obj* ffi_env_poke_parent(r_obj* env, r_obj* new_parent) {
+  // For the R level API, we do our own checks on top of
+  // what `r_env_poke_parent()` (really `base::parent.env<-`)
+  // does to throw better user facing error messages
   if (R_IsNamespaceEnv(env)) {
     r_abort("Can't change the parent of a namespace environment");
   }

src/internal/internal.c

@@ -56,6 +56,7 @@ void rlang_init_internal(r_obj* ns) {
   rlang_init_cnd(ns);
   rlang_init_cnd_handlers(ns);
   rlang_init_dots(ns);
+  rlang_init_env();
   rlang_init_expr_interp();
   rlang_init_eval_tidy();
   rlang_init_fn();

src/rlang/env.h

@@ -41,12 +41,6 @@ r_obj* r_env_parent(r_obj* env) {
 #endif
 }
 
-// TODO: C API compliance
-static inline
-void r_env_poke_parent(r_obj* env, r_obj* new_parent) {
-  SET_ENCLOS(env, new_parent);
-}
-
 static inline
 bool r_is_environment(r_obj* x) {
   return TYPEOF(x) == ENVSXP;