Update environment binding API with planned ctors and accessors

R/env-binding.R

@@ -630,25 +630,26 @@ 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)
+  # Match both delayed (3L) and forced (4L) promises
+  env_binding_are_type(env, nms, c(3L, 4L))
 }
 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/env-binding.c

@@ -314,7 +314,7 @@ void env_poke_lazy(r_obj* env, r_obj* sym, r_obj* expr, r_obj* eval_env) {
   }
   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/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;

src/rlang/decl/env-decl.h

@@ -19,13 +19,6 @@ r_obj* exists_call;
 static
 r_obj* remove_call;
 
-static
-r_obj* poke_lazy_call;
-
-static
-r_obj* poke_lazy_value_node;
-
-
 static
 r_obj* env2list_call;
 

src/rlang/env-binding.c

@@ -1,5 +1,9 @@
 #include "rlang.h"
 #include "env.h"
+#include "decl/env-binding-decl.h"
+
+// https://bugs.r-project.org/show_bug.cgi?id=18928
+#define RLANG_HAS_R_BINDING_API 0
 
 
 bool r_env_binding_is_promise(r_obj* env, r_obj* sym) {
@@ -27,7 +31,7 @@ static enum r_env_binding_type which_env_binding(r_obj* env, r_obj* sym) {
   }
 
   if (r_env_binding_is_promise(env, sym)) {
-    return R_ENV_BINDING_TYPE_promise;
+    return R_ENV_BINDING_TYPE_delayed;
   }
 
   return R_ENV_BINDING_TYPE_value;
@@ -95,3 +99,194 @@ r_obj* r_env_binding_types(r_obj* env, r_obj* bindings) {
   FREE(1);
   return types;
 }
+
+// This does an extra alloc, see https://bugs.r-project.org/show_bug.cgi?id=18928#c2
+r_obj* r_env_syms(r_obj* env) {
+  r_obj* nms = KEEP(r_env_names(env));
+  r_ssize n = r_length(nms);
+
+  r_obj* out = KEEP(r_alloc_list(n));
+  r_obj* const * v_nms = r_chr_cbegin(nms);
+
+  for (r_ssize i = 0; i < n; ++i) {
+    r_list_poke(out, i, r_str_as_symbol(v_nms[i]));
+  }
+
+  FREE(2);
+  return out;
+}
+
+
+// Binding type API
+// Implements future R API from https://bugs.r-project.org/show_bug.cgi?id=18928
+
+enum r_env_binding_type r_env_binding_type(r_obj* env, r_obj* sym) {
+#if RLANG_HAS_R_BINDING_API
+  switch (R_GetBindingType(sym, env)) {
+  case R_BindingTypeUnbound: return R_ENV_BINDING_TYPE_unbound;
+  case R_BindingTypeValue:   return R_ENV_BINDING_TYPE_value;
+  case R_BindingTypeMissing: return R_ENV_BINDING_TYPE_missing;
+  case R_BindingTypeDelayed: return R_ENV_BINDING_TYPE_delayed;
+  case R_BindingTypeForced:  return R_ENV_BINDING_TYPE_forced;
+  case R_BindingTypeActive:  return R_ENV_BINDING_TYPE_active;
+  }
+  r_stop_unreachable();
+#else
+  // Active binding check must come first since `r_env_find()` triggers them
+  if (R_BindingIsActive(sym, env)) {
+    return R_ENV_BINDING_TYPE_active;
+  }
+
+  r_obj* value = r_env_find(env, sym);
+
+  if (value == r_syms.unbound) {
+    return R_ENV_BINDING_TYPE_unbound;
+  }
+
+  if (value == r_missing_arg) {
+    return R_ENV_BINDING_TYPE_missing;
+  }
+
+  if (r_typeof(value) == R_TYPE_promise) {
+    if (PRVALUE(value) == r_syms.unbound) {
+      return R_ENV_BINDING_TYPE_delayed;
+    } else {
+      return R_ENV_BINDING_TYPE_forced;
+    }
+  }
+
+  return R_ENV_BINDING_TYPE_value;
+#endif
+}
+
+
+// Binding constructors
+
+void r_env_bind_active(r_obj* env, r_obj* sym, r_obj* fn) {
+  KEEP(fn);
+  r_env_unbind(env, sym);
+  R_MakeActiveBinding(sym, fn, env);
+  FREE(1);
+}
+
+void r_env_bind_delayed(r_obj* env, r_obj* sym, r_obj* expr, r_obj* eval_env) {
+#if RLANG_HAS_R_BINDING_API
+  R_MakeDelayedBinding(sym, expr, eval_env, env);
+#else
+  KEEP(expr);
+  r_obj* name = KEEP(r_sym_as_utf8_character(sym));
+
+  r_node_poke_car(bind_delayed_value_node, expr);
+  r_eval_with_xyz(bind_delayed_call, name, env, eval_env, rlang_ns_env);
+  r_node_poke_car(bind_delayed_value_node, r_null);
+
+  FREE(2);
+#endif
+}
+
+void r_env_bind_forced(r_obj* env, r_obj* sym, r_obj* expr, r_obj* value) {
+#if RLANG_HAS_R_BINDING_API
+  R_MakeForcedBinding(sym, expr, value, env);
+#else
+  // Creating an evaluated promise requires internal R API (`R_mkEVPROMISE`).
+  // Create a delayed binding and force it manually.
+  r_env_bind_delayed(env, sym, expr, r_envs.empty);
+
+  r_obj* promise = r_env_find(env, sym);
+  SET_PRVALUE(promise, value);
+  SET_PRENV(promise, r_null);
+#endif
+}
+
+void r_env_bind_missing(r_obj* env, r_obj* sym) {
+#if RLANG_HAS_R_BINDING_API
+  R_MakeMissingBinding(sym, env);
+#else
+  Rf_defineVar(sym, r_missing_arg, env);
+#endif
+}
+
+
+// Delayed binding accessors
+
+r_obj* r_env_binding_delayed_expr(r_obj* env, r_obj* sym) {
+#if RLANG_HAS_R_BINDING_API
+  return R_DelayedBindingExpression(sym, env);
+#else
+  r_obj* value = r_env_find(env, sym);
+
+  if (r_typeof(value) != R_TYPE_promise) {
+    r_abort("Not a promise binding.");
+  }
+  if (PRVALUE(value) != r_syms.unbound) {
+    r_abort("Not a delayed binding.");
+  }
+
+  return R_PromiseExpr(value);
+#endif
+}
+
+r_obj* r_env_binding_delayed_env(r_obj* env, r_obj* sym) {
+#if RLANG_HAS_R_BINDING_API
+  return R_DelayedBindingEnvironment(sym, env);
+#else
+  r_obj* value = r_env_find(env, sym);
+
+  if (r_typeof(value) != R_TYPE_promise) {
+    r_abort("Not a promise binding.");
+  }
+  if (PRVALUE(value) != r_syms.unbound) {
+    r_abort("Not a delayed binding.");
+  }
+
+  return PRENV(value);
+#endif
+}
+
+
+// Forced binding accessors
+
+r_obj* r_env_binding_forced_expr(r_obj* env, r_obj* sym) {
+#if RLANG_HAS_R_BINDING_API
+  return R_ForcedBindingExpression(sym, env);
+#else
+  r_obj* value = r_env_find(env, sym);
+
+  if (r_typeof(value) != R_TYPE_promise) {
+    r_abort("Not a promise binding.");
+  }
+  if (PRVALUE(value) == r_syms.unbound) {
+    r_abort("Not a forced binding.");
+  }
+
+  return R_PromiseExpr(value);
+#endif
+}
+
+r_obj* r_env_binding_forced_value(r_obj* env, r_obj* sym) {
+  r_obj* value = r_env_find(env, sym);
+
+  if (r_typeof(value) != R_TYPE_promise) {
+    r_abort("Not a promise binding.");
+  }
+  if (PRVALUE(value) == r_syms.unbound) {
+    r_abort("Not a forced binding.");
+  }
+
+  return PRVALUE(value);
+}
+
+
+// Active binding accessors
+
+r_obj* r_env_binding_active_fn(r_obj* env, r_obj* sym) {
+  return R_ActiveBindingFunction(sym, env);
+}
+
+
+void r_init_library_env_binding(void) {
+  bind_delayed_call = r_parse("delayedAssign(x, value = NULL, assign.env = y, eval.env = z)");
+  r_preserve(bind_delayed_call);
+
+  bind_delayed_value_node = r_node_cddr(bind_delayed_call);
+}

src/rlang/env-binding.h

@@ -6,14 +6,52 @@
 #include "rlang-types.h"
 
 enum r_env_binding_type {
-  R_ENV_BINDING_TYPE_value = 0,
-  R_ENV_BINDING_TYPE_promise,
-  R_ENV_BINDING_TYPE_active
+  R_ENV_BINDING_TYPE_unbound = 0,
+  R_ENV_BINDING_TYPE_value = 1,
+  R_ENV_BINDING_TYPE_missing = 2,
+  R_ENV_BINDING_TYPE_delayed = 3,
+  R_ENV_BINDING_TYPE_forced = 4,
+  R_ENV_BINDING_TYPE_active = 5
 };
 
+enum r_env_binding_type r_env_binding_type(r_obj* env, r_obj* sym);
+
 bool r_env_binding_is_promise(r_obj* env, r_obj* sym);
 bool r_env_binding_is_active(r_obj* env, r_obj* sym);
 r_obj* r_env_binding_types(r_obj* env, r_obj* bindings);
 
+r_obj* r_env_syms(r_obj* env);
+
+// Binding constructors
+static inline
+void r_env_bind(r_obj* env, r_obj* sym, r_obj* value) {
+  KEEP(value);
+  Rf_defineVar(sym, value, env);
+  FREE(1);
+}
+
+static inline
+void r_env_poke(r_obj* env, r_obj* sym, r_obj* value) {
+  r_env_bind(env, sym, value);
+}
+
+void r_env_bind_active(r_obj* env, r_obj* sym, r_obj* fn);
+void r_env_bind_delayed(r_obj* env, r_obj* sym, r_obj* expr, r_obj* eval_env);
+void r_env_bind_forced(r_obj* env, r_obj* sym, r_obj* expr, r_obj* value);
+void r_env_bind_missing(r_obj* env, r_obj* sym);
+
+// Delayed binding accessors
+r_obj* r_env_binding_delayed_expr(r_obj* env, r_obj* sym);
+r_obj* r_env_binding_delayed_env(r_obj* env, r_obj* sym);
+
+// Forced binding accessors
+r_obj* r_env_binding_forced_expr(r_obj* env, r_obj* sym);
+r_obj* r_env_binding_forced_value(r_obj* env, r_obj* sym);
+
+// Active binding accessors
+r_obj* r_env_binding_active_fn(r_obj* env, r_obj* sym);
+
+void r_init_library_env_binding(void);
+
 
 #endif