Remove SET_BODY() usage (#1845)

* Remove `SET_BODY()` usage

* Explicitly `r_clone()` when we zap `srcref`

Author: DavisVaughan

src/internal/attr.c

@@ -205,13 +205,30 @@ r_obj* zap_srcref(r_obj* x) {
 
 static
 r_obj* fn_zap_srcref(r_obj* x) {
-  x = KEEP(r_clone(x));
+  r_obj* formals = r_fn_formals(x);
+  r_obj* body = r_fn_body(x);
+  r_obj* env = r_fn_env(x);
 
-  r_fn_poke_body(x, zap_srcref(r_fn_body(x)));
-  r_attrib_poke(x, r_syms.srcref, r_null);
+  body = KEEP(zap_srcref(body));
 
-  FREE(1);
-  return x;
+  r_obj* out = KEEP(r_new_function(formals, body, env));
+
+  // Copy over attributes, but zap any `srcref` attribute
+  if (r_attrib_get(x, r_syms.srcref) == r_null) {
+    // Nothing to zap
+    r_obj* attrib = r_attrib(x);
+    r_poke_attrib(out, attrib);
+  } else {
+    // Clone so we can zap `srcref`
+    r_obj* attrib = r_attrib(x);
+    attrib = KEEP(r_clone(attrib));
+    r_poke_attrib(out, attrib);
+    FREE(1);
+    r_attrib_poke(out, r_syms.srcref, r_null);
+  }
+
+  FREE(2);
+  return out;
 }
 
 static

src/rlang/fn.h

@@ -37,12 +37,6 @@ 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)

tests/testthat/test-attr.R

@@ -134,6 +134,10 @@ test_that("zap_srcref() preserves attributes", {
   out <- zap_srcref(fn)
   expect_equal(attributes(out), list(bar = TRUE))
   expect_null(attributes(body(out)))
+
+  # `fn` attributes are not mutated
+  expect_equal(attr(fn, "bar"), TRUE)
+  expect_s3_class(attr(fn, "srcref"), "srcref")
 })
 
 test_that("can zap_srcref() on functions with `[[` methods", {