Merge pull request #1787 from r-lib/feature/api-find-var

Progress towards conformance of environment API

Author: lionel-

R/c-lib.R

@@ -405,5 +405,5 @@ vec_resize <- function(x, n) {
 # walk.c
 
 sexp_iterate <- function(x, fn) {
-  do.call(".Call", list(ffi_sexp_iterate, x, fn))
+  do.call(".Call", list(get("ffi_sexp_iterate"), x, fn))
 }

R/utils.R

@@ -368,3 +368,5 @@ pkg_url_bug <- function(pkg) {
 
   NULL
 }
+
+is_windows <- tolower(.Platform$OS.type) == "windows"

src/internal/dots-ellipsis.c

@@ -6,13 +6,16 @@ r_obj* ffi_ellipsis_find_dots(r_obj* env) {
     r_abort("`env` is a not an environment.");
   }
 
-  r_obj* dots = KEEP(r_env_find(env, r_syms.dots));
-  if (dots == r_syms.unbound) {
+  // `r_env_get()` triggers missing argument errors
+  if (r_env_has_missing(env, r_syms.dots)) {
+    return r_syms.missing;
+  }
+
+  if (!r_env_has(env, r_syms.dots)) {
     r_abort("No `...` found.");
   }
 
-  FREE(1);
-  return dots;
+  return r_env_get(env, r_syms.dots);
 }
 
 r_obj* ffi_ellipsis_dots(r_obj* env) {

src/internal/env-binding.c

@@ -27,6 +27,8 @@ r_obj* ffi_env_get(r_obj* env,
   return env_get_sym(env, sym, c_inherit, last, closure_env);
 }
 
+// This util is a little more complex than it would be by calling `getVar()`
+// directly because it evaluates `default` lazily
 static
 r_obj* env_get_sym(r_obj* env,
                    r_obj* sym,
@@ -37,25 +39,19 @@ r_obj* env_get_sym(r_obj* env,
     r_abort("`last` must be an environment.");
   }
 
-  r_obj* out;
+  bool unbound;
   if (inherit) {
     if (last == r_null) {
-      out = r_env_find_anywhere(env, sym);
+      unbound = !r_env_has_anywhere(env, sym);
     } else {
-      out = r_env_find_until(env, sym, last);
+      unbound = !r_env_has_until(env, sym, last);
     }
   } else {
-    out = r_env_find(env, sym);
+    unbound = !r_env_has(env, sym);
   }
 
-  if (r_typeof(out) == R_TYPE_promise) {
-    KEEP(out);
-    out = r_eval(out, r_envs.empty);
-    FREE(1);
-  }
-
-  if (out == r_syms.unbound) {
-    if (r_env_find(closure_env, r_sym("default")) == r_missing_arg) {
+  if (unbound) {
+    if (r_env_has_missing(closure_env, r_sym("default"))) {
       struct r_pair args[] = {
         { r_sym("nm"), KEEP(r_str_as_character(r_sym_string(sym))) }
       };
@@ -67,10 +63,18 @@ r_obj* env_get_sym(r_obj* env,
       r_stop_unreachable();
     }
 
-    out = r_eval(r_sym("default"), closure_env);
+    return r_eval(r_sym("default"), closure_env);
   }
 
-  return out;
+  if (inherit) {
+    if (last == r_null) {
+      return r_env_get_anywhere(env, sym);
+    } else {
+      return r_env_get_until(env, sym, last);
+    }
+  } else {
+    return r_env_get(env, sym);
+  }
 }
 
 r_obj* ffi_env_get_list(r_obj* env,
@@ -145,42 +149,46 @@ static void env_poke_lazy(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);
 
-r_obj* ffi_env_poke(r_obj* env, r_obj* nm, r_obj* value, r_obj* inherit, r_obj* create) {
+r_obj* ffi_env_poke(r_obj* env, r_obj* nm, r_obj* value, r_obj* ffi_inherit, r_obj* ffi_create) {
   if (r_typeof(env) != R_TYPE_environment) {
     r_abort("`env` must be an environment.");
   }
   if (!r_is_string(nm)) {
     r_abort("`nm` must be a string.");
   }
-  if (!r_is_bool(inherit)) {
+  if (!r_is_bool(ffi_inherit)) {
     r_abort("`inherit` must be a logical value.");
   }
-  if (!r_is_bool(create)) {
+  if (!r_is_bool(ffi_create)) {
     r_abort("`create` must be a logical value.");
   }
 
-  bool c_inherit = r_lgl_get(inherit, 0);
-  bool c_create = r_lgl_get(create, 0);
+  bool inherit = r_lgl_get(ffi_inherit, 0);
+  bool create = r_lgl_get(ffi_create, 0);
   r_obj* sym = r_str_as_symbol(r_chr_get(nm, 0));
 
-  r_obj* old;
-  if (c_inherit) {
-    old = r_env_find_anywhere(env, sym);
+  bool unbound;
+  if (inherit) {
+    unbound = !r_env_has_anywhere(env, sym);
   } else {
-    old = r_env_find(env, sym);
+    unbound = !r_env_has(env, sym);
   }
 
-  bool absent = (old == r_syms.unbound);
-  if (absent) {
-    if (!c_create) {
+  r_obj* old;
+  if (unbound) {
+    if (!create) {
       r_abort("Can't find existing binding in `env` for \"%s\".",
               r_sym_c_string(sym));
     }
     old = rlang_zap;
+  } else if (inherit) {
+    old = r_env_get_anywhere(env, sym);
+  } else {
+    old = r_env_get(env, sym);
   }
   KEEP(old);
 
-  if (c_inherit && !absent) {
+  if (inherit && !unbound) {
     while (env != r_envs.empty) {
       if (r_env_has(env, sym)) {
         break;
@@ -322,17 +330,13 @@ 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) {
-  r_obj* out = r_env_find(env, sym);
-
-  if (out == r_syms.unbound) {
+  if (!r_env_has(env, sym)) {
     return rlang_zap;
   }
 
-  if (r_typeof(out) == R_TYPE_promise) {
-    KEEP(out);
-    out = r_eval(out, r_envs.base);
-    FREE(1);
+  if (r_env_has_missing(env, sym)) {
+    return r_missing_arg;
   }
 
-  return out;
+  return r_env_get(env, sym);
 }

src/rlang/decl/env-decl.h

@@ -32,6 +32,9 @@ r_obj* env2list_call;
 static
 r_obj* list2env_call;
 
+static
+r_obj* missing_prim;
+
 #if R_VERSION < R_Version(4, 0, 0)
 static
 r_obj* env_as_list_compat(r_obj* env, r_obj* out);

src/rlang/env.c

@@ -6,37 +6,19 @@ r_obj* rlang_ns_env;
 
 
 r_obj* r_ns_env(const char* pkg) {
-  r_obj* ns = r_env_find(R_NamespaceRegistry, r_sym(pkg));
-  if (ns == r_syms.unbound) {
+  r_obj* pkg_sym = r_sym(pkg);
+  if (!r_env_has(R_NamespaceRegistry, pkg_sym)) {
     r_abort("Can't find namespace `%s`", pkg);
   }
-  return ns;
-}
-
-static
-r_obj* ns_env_get(r_obj* env, const char* name) {
-  r_obj* obj = KEEP(r_env_find(env, r_sym(name)));
-
-  // Can be a promise to a lazyLoadDBfetch() call
-  if (r_typeof(obj) == R_TYPE_promise) {
-    obj = r_eval(obj, r_envs.empty);
-  }
-  if (obj != r_syms.unbound) {
-    FREE(1);
-    return obj;
-  }
 
-  // Trigger object not found error
-  r_eval(r_sym(name), env);
-  r_stop_unreachable();
+  return r_env_get(R_NamespaceRegistry, pkg_sym);
 }
+
 r_obj* r_base_ns_get(const char* name) {
-  return ns_env_get(r_envs.base, name);
+  return r_env_get(r_envs.base, r_sym(name));
 }
-
-
 r_obj* rlang_ns_get(const char* name) {
-  return ns_env_get(rlang_ns_env, name);
+  return r_env_get(rlang_ns_env, r_sym(name));
 }
 
 
@@ -265,27 +247,50 @@ bool r_env_inherits(r_obj* env, r_obj* ancestor, r_obj* top) {
     if (env == ancestor) {
       return true;
     }
-    env = r_env_parent(env);;
+    env = r_env_parent(env);
   }
 
   return env == ancestor;
 }
 
-r_obj* r_env_find_until(r_obj* env, r_obj* sym, r_obj* last) {
+static
+r_obj* env_until(r_obj* env, r_obj* sym, r_obj* last) {
   r_obj* stop = r_envs.empty;
   if (last != r_envs.empty) {
     stop = r_env_parent(last);
   }
 
-  r_obj* out = r_syms.unbound;
-  while (out == r_syms.unbound && env != r_envs.empty && env != stop) {
-    out = r_env_find(env, sym);
-    env = r_env_parent(env);
+  while (true) {
+    if (env == r_envs.empty || r_env_has(env, sym)) {
+      return env;
+    }
+
+    r_obj* next = r_env_parent(env);
+    if (next == r_envs.empty || next == stop) {
+      return env;
+    }
+
+    env = next;
   }
+}
 
-  return out;
+r_obj* r_env_get_until(r_obj* env, r_obj* sym, r_obj* last) {
+  env = env_until(env, sym, last);
+  return r_env_get(env, sym);
 }
 
+bool r_env_has_until(r_obj* env, r_obj* sym, r_obj* last) {
+  env = env_until(env, sym, last);
+  return r_env_has(env, sym);
+}
+
+bool r_env_has_missing(r_obj* env, r_obj* sym) {
+  // That's a special primitive so no need to protect `sym`
+  r_obj* call = KEEP(r_call2(missing_prim, sym));
+  r_obj* out = r_eval(call, env);
+  FREE(1);
+  return r_as_bool(out);
+}
 
 void r_init_rlang_ns_env(void) {
   rlang_ns_env = r_ns_env("rlang");
@@ -300,6 +305,8 @@ void r_init_library_env(void) {
   new_env__size_node = r_node_cdr(new_env__parent_node);
 #endif
 
+  missing_prim = r_parse_eval("missing", r_envs.base);
+
   env2list_call = r_parse("as.list.environment(x, all.names = TRUE)");
   r_preserve(env2list_call);
 
@@ -351,3 +358,6 @@ r_obj* env2list_call = NULL;
 
 static
 r_obj* list2env_call = NULL;
+
+static
+r_obj* missing_prim = NULL;

src/rlang/env.h

@@ -7,6 +7,10 @@
 #include "cnd.h"
 #include "globals.h"
 #include "obj.h"
+#include "rlang.h"
+#include "sym.h"
+
+#define RLANG_USE_R_EXISTS (R_VERSION < R_Version(4, 2, 0))
 
 
 extern r_obj* r_methods_ns_env;
@@ -54,11 +58,52 @@ static inline
 r_obj* r_env_find_anywhere(r_obj* env, r_obj* sym) {
   return Rf_findVar(sym, env);
 }
-r_obj* r_env_find_until(r_obj* env, r_obj* sym, r_obj* last);
 
+#if 1 || R_VERSION < R_Version(4, 5, 0)
+// We currently can't use `R_getVar()` which:
+// 1. Throws if not found
+// 2. Throws if argument is the missing arg
+// 3. Evaluates promises
+// Our operators have to return missing arguments.
+static inline
+r_obj* r_env_get(r_obj* env, r_obj* sym) {
+  r_obj* out = r_env_find(env, sym);
+
+  if (out == r_syms.unbound) {
+    r_abort("object '%s' not found", r_sym_c_string(sym));
+  }
+
+  if (r_typeof(out) == R_TYPE_promise) {
+    return Rf_eval(out, env);
+  }
 
-// TODO: Enable `R_existsVarInFrame()` when R 4.2 is out
-#define RLANG_USE_R_EXISTS (1 || R_VERSION < R_Version(4, 2, 0))
+  return out;
+}
+
+static inline
+r_obj* r_env_get_anywhere(r_obj* env, r_obj* sym) {
+  r_obj* out = r_env_find_anywhere(env, sym);
+
+  if (out == r_syms.unbound) {
+    r_abort("object '%s' not found", r_sym_c_string(sym));
+  }
+
+  return out;
+}
+#else
+static inline
+r_obj* r_env_get(r_obj* env, r_obj* sym) {
+  return R_getVar(sym, env, FALSE);
+}
+
+static inline
+r_obj* r_env_get_anywhere(r_obj* env, r_obj* sym) {
+  return R_getVar(sym, env, TRUE);
+}
+#endif
+
+r_obj* r_env_get_until(r_obj* env, r_obj* sym, r_obj* last);
+bool r_env_has_until(r_obj* env, r_obj* sym, r_obj* last);
 
 static inline
 bool r_env_has(r_obj* env, r_obj* sym) {
@@ -76,10 +121,18 @@ bool r_env_has_anywhere(r_obj* env, r_obj* sym) {
   bool r__env_has_anywhere(r_obj*, r_obj*);
   return r__env_has_anywhere(env, sym);
 #else
-  return TODO();
+  while (env != r_envs.empty) {
+    if (r_env_has(env, sym)) {
+      return true;
+    }
+    env = r_env_parent(env);
+  }
+  return false;
 #endif
 }
 
+bool r_env_has_missing(r_obj* env, r_obj* sym);
+
 r_obj* r_ns_env(const char* pkg);
 r_obj* r_base_ns_get(const char* name);