Merge pull request #1871 from lionel-/feature/c-env-api

Update environment binding API with planned ctors and accessors

Author: lionel-

.Rbuildignore

@@ -25,3 +25,4 @@
 ^compile_commands\.json$
 .*\.clangd$
 ^[\.]?air\.toml$
+^dev-notes$

R/env-binding.R

@@ -630,25 +630,25 @@ env_binding_are_locked <- function(env, nms = NULL) {
 #' @return A logical vector as long as `nms` and named after it.
 #' @export
 env_binding_are_active <- function(env, nms = NULL) {
-  env_binding_are_type(env, nms, 2L)
+  env_binding_are_type(env, nms, 5L)
 }
 #' @rdname env_binding_are_active
 #' @export
 env_binding_are_lazy <- function(env, nms = NULL) {
-  env_binding_are_type(env, nms, 1L)
+  env_binding_are_type(env, nms, 3L)
 }
 env_binding_are_type <- function(env, nms, type, error_call = caller_env()) {
   check_environment(env, call = error_call)
 
   nms <- env_binding_validate_names(env, nms, call = error_call)
-  promise <- env_binding_types(env, nms)
+  types <- env_binding_types(env, nms)
 
-  if (is_null(promise)) {
-    promise <- rep(FALSE, length(nms))
+  if (is_null(types)) {
+    out <- rep(FALSE, length(nms))
   } else {
-    promise <- promise == type
+    out <- types %in% type
   }
-  set_names(promise, nms)
+  set_names(out, nms)
 }
 
 env_binding_validate_names <- function(env, nms, call = caller_env()) {

src/internal/attr.c

@@ -137,8 +137,8 @@ r_obj* eval_fn_dots(r_obj* fn, r_obj* x, r_obj* dots, r_obj* env) {
   // `.x` is the first input, x
   // `.fn` is the function, fn
   // The dots are a pairlist already in the call
-  r_env_poke(env, r_syms.dot_x, x);
-  r_env_poke(env, r_syms.dot_fn, fn);
+  r_env_bind(env, r_syms.dot_x, x);
+  r_env_bind(env, r_syms.dot_fn, fn);
 
   r_obj* out = r_eval(call, env);
 
@@ -148,13 +148,13 @@ r_obj* eval_fn_dots(r_obj* fn, r_obj* x, r_obj* dots, r_obj* env) {
 
 static inline
 r_obj* eval_as_character(r_obj* x, r_obj* env) {
-  r_env_poke(env, r_syms.dot_x, x);
+  r_env_bind(env, r_syms.dot_x, x);
   return r_eval(as_character_call, env);
 }
 
 static inline
 r_obj* names_dispatch(r_obj* x, r_obj* env) {
-  r_env_poke(env, r_syms.dot_x, x);
+  r_env_bind(env, r_syms.dot_x, x);
   return r_eval(names_call, env);
 }
 
@@ -163,14 +163,14 @@ r_obj* names_dispatch(r_obj* x, r_obj* env) {
 // attributes using ALTREP wrappers, which is not in R's public API.
 static inline
 r_obj* set_names_dispatch(r_obj* x, r_obj* nm, r_obj* env) {
-  r_env_poke(env, r_syms.dot_x, x);
-  r_env_poke(env, r_syms.dot_y, nm);
+  r_env_bind(env, r_syms.dot_x, x);
+  r_env_bind(env, r_syms.dot_y, nm);
   return r_eval(set_names_call, env);
 }
 
 static inline
 r_ssize length_dispatch(r_obj* x, r_obj* env) {
-  r_env_poke(env, r_syms.dot_x, x);
+  r_env_bind(env, r_syms.dot_x, x);
   r_obj* n = KEEP(r_eval(length_call, env));
 
   if (r_length(n) != 1) {

src/internal/cnd-handlers.c

@@ -11,7 +11,7 @@ r_obj* ffi_try_fetch(r_obj* try_fetch_args) {
   // on the way out, and we could probably avoid that by switching
   // to or creating another variant that doesn't clone.
   r_obj* handlers = KEEP(rlang_env_dots_list(env));
-  r_env_poke(env, rlang_syms.handlers, handlers);
+  r_env_bind(env, rlang_syms.handlers, handlers);
 
   if (!r_length(handlers)) {
     FREE(1);

src/internal/env-binding.c

@@ -145,7 +145,7 @@ r_obj* ffi_env_has(r_obj* env, r_obj* nms, r_obj* inherit) {
 }
 
 static void env_poke_or_zap(r_obj* env, r_obj* sym, r_obj* value);
-static void env_poke_lazy(r_obj* env, r_obj* sym, r_obj* value, r_obj* eval_env);
+static void env_poke_delayed(r_obj* env, r_obj* sym, r_obj* value, r_obj* eval_env);
 static void env_poke_active(r_obj* env, r_obj* sym, r_obj* fn, r_obj* eval_env);
 static r_obj* env_get(r_obj* env, r_obj* sym);
 
@@ -265,8 +265,8 @@ r_obj* ffi_env_bind(r_obj* env,
       r_env_unbind(env, sym);
     } else {
       switch (c_bind_type) {
-      case BIND_TYPE_value: r_env_poke(env, sym, value); break;
-      case BIND_TYPE_lazy: env_poke_lazy(env, sym, value, eval_env); break;
+      case BIND_TYPE_value: r_env_bind(env, sym, value); break;
+      case BIND_TYPE_lazy: env_poke_delayed(env, sym, value, eval_env); break;
       case BIND_TYPE_active: env_poke_active(env, sym, value, eval_env); break;
       }
     }
@@ -302,19 +302,19 @@ void env_poke_or_zap(r_obj* env, r_obj* sym, r_obj* value) {
   if (value == rlang_zap) {
     r_env_unbind(env, sym);
   } else {
-    r_env_poke(env, sym, value);
+    r_env_bind(env, sym, value);
   }
 }
 static
-void env_poke_lazy(r_obj* env, r_obj* sym, r_obj* expr, r_obj* eval_env) {
+void env_poke_delayed(r_obj* env, r_obj* sym, r_obj* expr, r_obj* eval_env) {
   if (is_quosure(expr)) {
     expr = KEEP(rlang_as_function(expr, eval_env));
     expr = r_new_call(expr, r_null);
     FREE(1);
   }
   KEEP(expr);
 
-  r_env_poke_lazy(env, sym, expr, eval_env);
+  r_env_bind_delayed(env, sym, expr, eval_env);
   FREE(1);
 }
 static
@@ -324,7 +324,7 @@ void env_poke_active(r_obj* env, r_obj* sym, r_obj* fn, r_obj* eval_env) {
   }
   KEEP(fn);
 
-  r_env_poke_active(env, sym, fn);
+  r_env_bind_active(env, sym, fn);
   FREE(1);
 }
 

src/internal/eval-tidy.c

@@ -149,8 +149,8 @@ static r_obj* restore_mask_body = NULL;
 
 static void on_exit_restore_lexical_env(r_obj* mask, r_obj* old, r_obj* frame) {
   r_obj* env = KEEP(r_alloc_environment(2, r_envs.base));
-  r_env_poke(env, mask_sym, mask);
-  r_env_poke(env, old_sym, old);
+  r_env_bind(env, mask_sym, mask);
+  r_env_bind(env, old_sym, old);
 
   r_obj* fn = KEEP(r_new_function(restore_mask_formals, restore_mask_body, env));
 
@@ -185,10 +185,10 @@ r_obj* ffi_new_data_mask(r_obj* bottom, r_obj* top) {
 
   r_obj* ctxt_pronoun = KEEP(rlang_new_ctxt_pronoun(top));
 
-  r_env_poke(data_mask, r_syms.tilde, tilde_fn);
-  r_env_poke(data_mask, data_mask_flag_sym, data_mask);
-  r_env_poke(data_mask, data_mask_env_sym, ctxt_pronoun);
-  r_env_poke(data_mask, data_mask_top_env_sym, top);
+  r_env_bind(data_mask, r_syms.tilde, tilde_fn);
+  r_env_bind(data_mask, data_mask_flag_sym, data_mask);
+  r_env_bind(data_mask, data_mask_env_sym, ctxt_pronoun);
+  r_env_bind(data_mask, data_mask_top_env_sym, top);
 
   FREE(2);
   return data_mask;
@@ -323,7 +323,7 @@ r_obj* ffi_as_data_mask(r_obj* data) {
         // Ignore empty or missing names
         r_obj* nm = p_names[i];
         if (r_str_is_name(nm)) {
-          r_env_poke(bottom, r_str_as_symbol(nm), p_data[i]);
+          r_env_bind(bottom, r_str_as_symbol(nm), p_data[i]);
         }
       }
     }
@@ -338,7 +338,7 @@ r_obj* ffi_as_data_mask(r_obj* data) {
   r_obj* data_mask = KEEP_N(ffi_new_data_mask(bottom, bottom), &n_kept);
 
   r_obj* data_pronoun = KEEP_N(ffi_as_data_pronoun(data_mask), &n_kept);
-  r_env_poke(bottom, data_pronoun_sym, data_pronoun);
+  r_env_bind(bottom, data_pronoun_sym, data_pronoun);
 
   FREE(n_kept);
   return data_mask;
@@ -492,8 +492,8 @@ r_obj* ffi_data_mask_clean(r_obj* mask) {
 
 static r_obj* new_quosure_mask(r_obj* env) {
   r_obj* mask = KEEP(r_alloc_environment(3, env));
-  r_env_poke(mask, r_syms.tilde, tilde_fn);
-  r_env_poke(mask, quo_mask_flag_sym, mask);
+  r_env_bind(mask, r_syms.tilde, tilde_fn);
+  r_env_bind(mask, quo_mask_flag_sym, mask);
   FREE(1);
   return mask;
 }

src/internal/exported.c

@@ -1000,6 +1000,15 @@ r_obj* ffi_list_poke(r_obj* x, r_obj* i, r_obj* value) {
 
 // walk.c
 
+r_obj* ffi_has_private_accessors(void) {
+#ifdef RLANG_USE_PRIVATE_ACCESSORS
+  return r_true;
+#else
+  return r_false;
+#endif
+}
+
+#ifdef RLANG_USE_PRIVATE_ACCESSORS
 static inline
 r_obj* protect_missing(r_obj* x) {
   // FIXME: Include in `exec_` functions?
@@ -1012,16 +1021,6 @@ r_obj* protect_missing(r_obj* x) {
   }
 }
 
-r_obj* ffi_has_private_accessors(void) {
-#ifdef RLANG_USE_PRIVATE_ACCESSORS
-  return r_true;
-#else
-  return r_false;
-#endif
-}
-
-#ifdef RLANG_USE_PRIVATE_ACCESSORS
-
 // [[ register() ]]
 r_obj* ffi_sexp_iterate(r_obj* x, r_obj* fn) {
   struct r_dyn_array* p_out = r_new_dyn_vector(R_TYPE_list, 256);

src/rlang/cnd.c

@@ -43,7 +43,7 @@ void r_abort(const char* fmt, ...) {
   // Evaluate in a mask but forward error call to the current frame
   r_obj* frame = KEEP(r_peek_frame());
   r_obj* mask = KEEP(r_alloc_environment(2, frame));
-  r_env_poke(mask, r_syms.error_call_flag, frame);
+  r_env_bind(mask, r_syms.error_call_flag, frame);
 
   struct r_pair args[] = {
     { r_syms.message, message }

src/rlang/debug.c

@@ -8,7 +8,7 @@ void r_sexp_inspect(r_obj* x) {
 }
 
 void r_browse(r_obj* x) {
-  r_env_poke(r_envs.global, r_sym(".debug"), x);
+  r_env_bind(r_envs.global, r_sym(".debug"), x);
 
   r_printf("Object saved in `.debug`:\n");
   r_obj_print(x);

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

@@ -0,0 +1,4 @@
+extern r_obj* rlang_ns_env;
+
+static r_obj* bind_delayed_call;
+static r_obj* bind_delayed_value_node;