More C API compliance work

NEWS.md

@@ -1,5 +1,7 @@
 # rlang (development version)
 
+* Progress towards making rlang conformant with the public C API of R.
+
 * R >=4.0.0 is now required. This is still more permissive than the general tidyverse policy of supporting the [5 most recent versions of R](https://www.tidyverse.org/blog/2019/04/r-version-support/).
 
 * `list2()` is now a little faster (#1837).

R/obj.R

@@ -31,21 +31,13 @@ sexp_address <- obj_address
 
 # nocov start - These functions are mostly for interactive experimentation
 
-poke_type <- function(x, type) {
-  invisible(.Call(ffi_poke_type, x, type))
-}
-
 mark_object <- function(x) {
   invisible(.Call(ffi_mark_object, x))
 }
 unmark_object <- function(x) {
   invisible(.Call(ffi_unmark_object, x))
 }
 
-true_length <- function(x) {
-  .Call(ffi_true_length, x)
-}
-
 promise_expr <- function(name, env = caller_env()) {
   .Call(ffi_promise_expr, name, env)
 }

src/internal/exported.c

@@ -472,7 +472,7 @@ r_obj* ffi_env_poke_parent(r_obj* env, r_obj* new_parent) {
     r_abort("Can't change the parent of the empty environment");
   }
 
-  SET_ENCLOS(env, new_parent);
+  r_env_poke_parent(env, new_parent);
   return env;
 }
 
@@ -700,9 +700,6 @@ r_obj* ffi_quo_is_null(r_obj* quo) {
 r_obj* ffi_length(r_obj* x) {
   return r_int(r_length(x));
 }
-r_obj* ffi_true_length(r_obj* x) {
-  return r_int(XTRUELENGTH(x));
-}
 
 r_obj* ffi_is_reference(r_obj* x, r_obj* y) {
   return r_lgl(x == y);
@@ -724,11 +721,6 @@ r_obj* ffi_obj_address(r_obj* x) {
   return r_str_as_character(r_obj_address(x));
 }
 
-r_obj* ffi_poke_type(r_obj* x, r_obj* type) {
-  SET_TYPEOF(x, Rf_str2type(r_chr_get_c_string(type, 0)));
-  return x;
-}
-
 r_obj* ffi_mark_object(r_obj* x) {
   SET_OBJECT(x, 1);
   return x;

src/internal/internal.c

@@ -267,7 +267,6 @@ static const R_CallMethodDef r_callables[] = {
   {"ffi_pairlist_rev",                 (DL_FUNC) &r_pairlist_rev, 1},
   {"ffi_peek_srcref",                  (DL_FUNC) &ffi_peek_srcref, 0},
   {"ffi_poke_attrib",                  (DL_FUNC) &r_poke_attrib, 2},
-  {"ffi_poke_type",                    (DL_FUNC) &ffi_poke_type, 2},
   {"ffi_precious_dict",                (DL_FUNC) &ffi_precious_dict, 0},
   {"ffi_preserve",                     (DL_FUNC) &ffi_preserve, 1},
   {"ffi_promise_env",                  (DL_FUNC) &ffi_promise_env, 2},
@@ -316,7 +315,6 @@ static const R_CallMethodDef r_callables[] = {
   {"ffi_test_stop_internal",           (DL_FUNC) &ffi_test_stop_internal, 1},
   {"ffi_test_sys_call",                (DL_FUNC) &ffi_test_sys_call, 1},
   {"ffi_test_sys_frame",               (DL_FUNC) &ffi_test_sys_frame, 1},
-  {"ffi_true_length",                  (DL_FUNC) &ffi_true_length, 1},
   {"ffi_unescape_character",           (DL_FUNC) &ffi_unescape_character, 1},
   {"ffi_unmark_object",                (DL_FUNC) &ffi_unmark_object, 1},
   {"ffi_unpreserve",                   (DL_FUNC) &ffi_unpreserve, 1},

src/rlang/env.h

@@ -34,8 +34,14 @@ r_obj* r_env_parent(r_obj* env) {
   if (env == r_envs.empty) {
     r_stop_internal("Can't take the parent of the empty environment.");
   }
+#if R_VERSION >= R_Version(4, 5, 0)
+  return R_ParentEnv(env);
+#else
   return ENCLOS(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);
@@ -142,9 +148,15 @@ static inline
 r_obj* r_alloc_empty_environment(r_obj* parent) {
   // Non-hashed environment.
   // Very fast and useful when you aren't getting/setting from the result.
+#if R_VERSION >= R_Version(4, 1, 0)
+  const int hash = 0;
+  const int size = 0; // Not used when `hash = 0`
+  return R_NewEnv(parent, hash, size);
+#else
   r_obj* env = Rf_allocSExp(R_TYPE_environment);
-  r_env_poke_parent(env, parent);
+  SET_ENCLOS(env, parent);
   return env;
+#endif
 }
 
 r_obj* r_env_as_list(r_obj* x);

src/rlang/fn.h

@@ -7,30 +7,53 @@
 #include "obj.h"
 
 static inline
-r_obj* r_fn_body(r_obj* fn) {
-  return BODY_EXPR(fn);
+r_obj* r_fn_formals(r_obj* fn) {
+#if R_VERSION >= R_Version(4, 5, 0)
+  return R_ClosureFormals(fn);
+#else
+  return FORMALS(fn);
+#endif
 }
+
+// Identical to `R_BytecodeExpr(R_ClosureBody(fn))`, which we always want
+// since it matches the R level `body()`
 static inline
-void r_fn_poke_body(r_obj* fn, r_obj* body) {
-  SET_BODY(fn, body);
+r_obj* r_fn_body(r_obj* fn) {
+  return R_ClosureExpr(fn);
 }
 
 static inline
 r_obj* r_fn_env(r_obj* fn) {
+#if R_VERSION >= R_Version(4, 5, 0)
+  return R_ClosureEnv(fn);
+#else
   return CLOENV(fn);
+#endif
 }
+
+// TODO: C API compliance
 static inline
 void r_fn_poke_env(r_obj* fn, r_obj* env) {
   SET_CLOENV(fn, env);
 }
 
+// TODO: C API compliance
+static inline
+void r_fn_poke_body(r_obj* fn, r_obj* body) {
+  SET_BODY(fn, body);
+}
+
 static inline
 r_obj* r_new_function(r_obj* formals, r_obj* body, r_obj* env) {
+#if R_VERSION >= R_Version(4, 5, 0)
+  return R_mkClosure(formals, body, env);
+#else
   SEXP fn = Rf_allocSExp(R_TYPE_closure);
   SET_FORMALS(fn, formals);
   SET_BODY(fn, body);
   SET_CLOENV(fn, env);
   return fn;
+#endif
 }
 
 r_obj* r_as_function(r_obj* x, const char* arg);

src/rlang/obj.h

@@ -65,7 +65,7 @@ void r_unmark_object(r_obj* x) {
 }
 static inline
 bool r_is_object(r_obj* x) {
-  return OBJECT(x);
+  return Rf_isObject(x);
 }
 
 static inline
@@ -90,12 +90,6 @@ r_obj* r_clone_shared(r_obj* x) {
 r_obj* r_vec_clone(r_obj* x);
 r_obj* r_vec_clone_shared(r_obj* x);
 
-static inline
-r_obj* r_poke_type(r_obj* x, enum r_type type) {
-  SET_TYPEOF(x, type);
-  return x;
-}
-
 static inline
 r_obj* r_type_as_string(enum r_type type) {
   return Rf_type2str(type);

src/rlang/walk.c

@@ -314,7 +314,7 @@ r_obj* sexp_node_car(enum r_type type,
                      r_obj* x,
                      enum r_sexp_it_relation* p_rel) {
   switch (type) {
-  case R_TYPE_closure:     *p_rel = R_SEXP_IT_RELATION_function_fmls; return FORMALS(x);
+  case R_TYPE_closure:     *p_rel = R_SEXP_IT_RELATION_function_fmls; return r_fn_formals(x);
   case R_TYPE_environment: *p_rel = R_SEXP_IT_RELATION_environment_frame; return FRAME(x);
   case R_TYPE_promise:     *p_rel = R_SEXP_IT_RELATION_promise_value; return PRVALUE(x);
   case R_TYPE_pairlist:
@@ -329,8 +329,8 @@ r_obj* sexp_node_cdr(enum r_type type,
                      r_obj* x,
                      enum r_sexp_it_relation* p_rel) {
   switch (type) {
-  case R_TYPE_closure:     *p_rel = R_SEXP_IT_RELATION_function_body; return BODY(x);
-  case R_TYPE_environment: *p_rel = R_SEXP_IT_RELATION_environment_enclos; return ENCLOS(x);
+  case R_TYPE_closure:     *p_rel = R_SEXP_IT_RELATION_function_body; return r_fn_body(x);
+  case R_TYPE_environment: *p_rel = R_SEXP_IT_RELATION_environment_enclos; return r_env_parent(x);
   case R_TYPE_promise:     *p_rel = R_SEXP_IT_RELATION_promise_expr; return PREXPR(x);
   case R_TYPE_pointer:     *p_rel = R_SEXP_IT_RELATION_pointer_prot; return EXTPTR_PROT(x);
   case R_TYPE_pairlist:
@@ -344,7 +344,7 @@ r_obj* sexp_node_tag(enum r_type type,
                      r_obj* x,
                      enum r_sexp_it_relation* p_rel) {
   switch (type) {
-  case R_TYPE_closure:     *p_rel = R_SEXP_IT_RELATION_function_env; return CLOENV(x);
+  case R_TYPE_closure:     *p_rel = R_SEXP_IT_RELATION_function_env; return r_fn_env(x);
   case R_TYPE_environment: *p_rel = R_SEXP_IT_RELATION_environment_hashtab; return HASHTAB(x);
   case R_TYPE_promise:     *p_rel = R_SEXP_IT_RELATION_promise_env; return PRENV(x);
   case R_TYPE_pointer:     *p_rel = R_SEXP_IT_RELATION_pointer_tag; return EXTPTR_TAG(x);

tests/testthat/test-obj.R

@@ -1,11 +1,3 @@
-test_that("poke_type() changes object type", {
-  x <- new_node(quote(foo), NULL)
-  out <- withVisible(poke_type(x, "language"))
-  expect_false(out$visible)
-  expect_identical(out$value, x)
-  expect_identical(typeof(x), "language")
-})
-
 test_that("can access promise properties", {
   fn <- function(...) {
     list(node_car(get("...")))