diff --git a/src/internal/attr.c b/src/internal/attr.c index 1ac2d20ae..8b195f38f 100644 --- a/src/internal/attr.c +++ b/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 diff --git a/src/rlang/fn.h b/src/rlang/fn.h index 2023c4e8c..ea83e658c 100644 --- a/src/rlang/fn.h +++ b/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) diff --git a/tests/testthat/test-attr.R b/tests/testthat/test-attr.R index 01aeaa877..a5aa44591 100644 --- a/tests/testthat/test-attr.R +++ b/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", {