Use public R C APIs for R 4.6 compatibility

.github/docker/r-ci/Dockerfile

@@ -1,4 +1,5 @@
-FROM rocker/r-ver:4.5.2
+ARG R_VERSION=4.5.2
+FROM rocker/r-ver:${R_VERSION}
 
 RUN apt-get update && apt-get install -y --no-install-recommends \
     ca-certificates \
@@ -9,6 +10,7 @@ RUN apt-get update && apt-get install -y --no-install-recommends \
     gfortran \
     libcurl4-openssl-dev \
     libssl-dev \
+    libuv1-dev \
     libxml2-dev \
   && rm -rf /var/lib/apt/lists/*
 
@@ -17,10 +19,10 @@ RUN Rscript -e "options(\
   keep.source.pkgs = TRUE,\
   keep.parse.data.pkgs = TRUE,\
   Ncpus = max(1L, parallel::detectCores() - 1L)\
-); install.packages(\
-  c('ggplot2', 'dplyr', 'stringr', 'testthat'),\
+); pkgs <- c('ggplot2', 'dplyr', 'stringr', 'testthat'); install.packages(\
+  pkgs,\
   dependencies = NA,\
   INSTALL_opts = c('--with-keep.source', '--with-keep.parse.data')\
-)"
+); missing <- pkgs[!vapply(pkgs, requireNamespace, logical(1), quietly = TRUE)]; if (length(missing)) stop('Failed to install package(s): ', paste(missing, collapse = ', '), call. = FALSE)"
 
 WORKDIR /work

.github/workflows/test.yml

@@ -12,13 +12,30 @@ permissions:
   packages: read
 
 jobs:
+  # Resolve the (lowercased) GHCR image repo once so both the matrixed build
+  # and test jobs can reference a deterministic, per-R-version image name in
+  # expression contexts (container.image / tags) without a bash lowercasing step.
+  vars:
+    runs-on: ubuntu-latest
+    outputs:
+      image_repo: ${{ steps.v.outputs.image_repo }}
+    steps:
+      - id: v
+        run: |
+          owner_lc="${GITHUB_REPOSITORY_OWNER,,}"
+          echo "image_repo=ghcr.io/${owner_lc}/impuresrcref-r-ci" >> "$GITHUB_OUTPUT"
+
   build_image:
+    needs: vars
     runs-on: ubuntu-latest
     permissions:
       contents: read
       packages: write
-    outputs:
-      image: ${{ steps.image.outputs.image }}
+    strategy:
+      matrix:
+        # R 4.5 exercises the in-place (SET_TYPEOF/SET_BODY/...) code path;
+        # R 4.6 exercises the public-API (Rf_allocLang/R_mkClosure/...) path.
+        r_version: ["4.5.2", "4.6.1"]
     steps:
       - uses: actions/checkout@v4
 
@@ -30,29 +47,28 @@ jobs:
           username: ${{ github.actor }}
           password: ${{ secrets.GITHUB_TOKEN }}
 
-      - id: image
-        run: |
-          owner_lc="${GITHUB_REPOSITORY_OWNER,,}"
-          image_repo="ghcr.io/${owner_lc}/impuresrcref-r-ci"
-          echo "image=${image_repo}:sha-${GITHUB_SHA}" >> "$GITHUB_OUTPUT"
-          echo "image_repo=${image_repo}" >> "$GITHUB_OUTPUT"
-
       - uses: docker/build-push-action@v6
         with:
           context: .github/docker/r-ci
           file: .github/docker/r-ci/Dockerfile
+          build-args: |
+            R_VERSION=${{ matrix.r_version }}
           push: true
           tags: |
-            ${{ steps.image.outputs.image }}
-            ${{ steps.image.outputs.image_repo }}:latest
-          cache-from: type=gha
-          cache-to: type=gha,mode=max
+            ${{ needs.vars.outputs.image_repo }}:sha-${{ github.sha }}-r${{ matrix.r_version }}
+            ${{ needs.vars.outputs.image_repo }}:latest-r${{ matrix.r_version }}
+          cache-from: type=gha,scope=r${{ matrix.r_version }}
+          cache-to: type=gha,mode=max,scope=r${{ matrix.r_version }}
 
   test:
-    needs: build_image
+    needs: [vars, build_image]
     runs-on: ubuntu-latest
+    strategy:
+      fail-fast: false
+      matrix:
+        r_version: ["4.5.2", "4.6.1"]
     container:
-      image: ${{ needs.build_image.outputs.image }}
+      image: ${{ needs.vars.outputs.image_repo }}:sha-${{ github.sha }}-r${{ matrix.r_version }}
       credentials:
         username: ${{ github.actor }}
         password: ${{ secrets.GITHUB_TOKEN }}

.gitignore

@@ -5,6 +5,10 @@ src/*.dll
 src/*.dylib
 src/symbols.rds
 
+# Coverage / profile-guided-optimization artifacts
+src/*.gcda
+src/*.gcno
+
 # R CMD build / check artifacts
 *.tar.gz
 *.Rcheck/

src/blacklist.c

@@ -19,8 +19,17 @@ static SEXP compute_specialsxp_names(void) {
     for (R_xlen_t i = 0; i < n; i++) {
         const char *nm = CHAR(STRING_ELT(nms, i));
         SEXP sym = Rf_install(nm);
+#if IMPUTESRCREF_R_GE_4_6
+        /* Rf_findVarInFrame is non-API on R >= 4.6. Evaluating the symbol in
+           base env yields the bound value (base has no promises), and the
+           SPECIALSXP check below filters everything else. */
+        int err = 0;
+        SEXP obj = R_tryEvalSilent(sym, R_BaseEnv, &err);
+        if (!err && TYPEOF(obj) == SPECIALSXP) {
+#else
         SEXP obj = Rf_findVarInFrame(R_BaseEnv, sym);
         if (obj != R_UnboundValue && TYPEOF(obj) == SPECIALSXP) {
+#endif
             keep[i] = 1;
             kept++;
         } else {

src/imputesrcref.h

@@ -4,8 +4,21 @@
 #define R_NO_REMAP
 #include <R.h>
 #include <Rinternals.h>
+#include <Rversion.h>
 #include <R_ext/Rdynload.h>
 
+/* R 4.6 removed several long-standing entry points (SET_TYPEOF, SET_BODY,
+   SET_FORMALS, BODY, ATTRIB, Rf_findVarInFrame, ...) from the public C API.
+   On R < 4.6 we keep using the fast in-place mutators; on R >= 4.6 we fall
+   back to the public allocating replacements (Rf_allocLang, R_mkClosure,
+   R_ClosureBody/Formals/Env, attributes(), R_tryEvalSilent). Guard every such
+   site with IMPUTESRCREF_R_GE_4_6 so a single build works on both. */
+#if defined(R_VERSION) && R_VERSION >= R_Version(4, 6, 0)
+#  define IMPUTESRCREF_R_GE_4_6 1
+#else
+#  define IMPUTESRCREF_R_GE_4_6 0
+#endif
+
 typedef struct parse_ctx {
     SEXP pd;
     int nrow;

src/source_impute.c

@@ -118,8 +118,12 @@ static void emit_message(const char *txt) {
 static void sys_source_(SEXP file, SEXP envir, SEXP chdir, SEXP keep_source,
                         SEXP keep_parse_data, SEXP toplevel_env) {
     SEXP fn = PROTECT(base_fun("sys.source"));
+#if IMPUTESRCREF_R_GE_4_6
+    SEXP call = PROTECT(Rf_allocLang(7));
+#else
     SEXP call = PROTECT(Rf_allocList(7));
     SET_TYPEOF(call, LANGSXP);
+#endif
     SETCAR(call, fn);
     SEXP c1 = CDR(call); SETCAR(c1, file); SET_TAG(c1, Rf_install("file"));
     SEXP c2 = CDR(c1);   SETCAR(c2, envir); SET_TAG(c2, Rf_install("envir"));

src/srcref_sites.c

@@ -240,8 +240,12 @@ static SEXP do_strip_transparent_braces(SEXP expr) {
     int n = 0;
     for (SEXP it = expr; it != R_NilValue; it = CDR(it)) n++;
 
+#if IMPUTESRCREF_R_GE_4_6
+    SEXP out = PROTECT(Rf_allocLang(n));
+#else
     SEXP out = PROTECT(Rf_allocList(n));
     SET_TYPEOF(out, LANGSXP);
+#endif
     SEXP src = expr;
     SEXP dst = out;
     while (src != R_NilValue) {

src/transform.c

@@ -597,6 +597,35 @@ static void impute_nested_inplace(SEXP e, SEXP wrap_sxp, SEXP quiet_sxp, int *an
     }
 }
 
+#if IMPUTESRCREF_R_GE_4_6
+/* R >= 4.6: ATTRIB/BODY/SET_BODY/SET_FORMALS are non-API, so instead of
+   duplicating a closure and mutating it in place we rebuild it with the public
+   R_mkClosure() and copy attributes over via R-level attributes(). */
+static SEXP call_attributes(SEXP x) {
+    SEXP f = PROTECT(Rf_findFun(Rf_install("attributes"), R_BaseEnv));
+    SEXP call = PROTECT(Rf_lang2(f, x));
+    SEXP res = Rf_eval(call, R_GlobalEnv);
+    UNPROTECT(2);
+    return res;
+}
+
+/* Copy every attribute of the named list `attrs` (as returned by
+   call_attributes) onto `out`, and restore the S4 object bit from `src`.
+   R_mkClosure produces a bare closure, so this reinstates srcref, class,
+   S4 slots, etc. */
+static void reapply_attributes(SEXP out, SEXP attrs, SEXP src) {
+    if (attrs != R_NilValue) {
+        SEXP names = Rf_getAttrib(attrs, R_NamesSymbol);
+        R_xlen_t n = Rf_xlength(attrs);
+        for (R_xlen_t i = 0; i < n; i++) {
+            SEXP name = Rf_installChar(STRING_ELT(names, i));
+            Rf_setAttrib(out, name, VECTOR_ELT(attrs, i));
+        }
+    }
+    if (Rf_isS4(src)) Rf_asS4(out, TRUE, FALSE);
+}
+#endif
+
 SEXP C_impute_srcrefs(SEXP fn, SEXP wrap_call_args_sxp, SEXP quiet_sxp) {
     if (TYPEOF(fn) != CLOSXP) {
         Rf_error("`fn` must be a function");
@@ -612,7 +641,11 @@ SEXP C_impute_srcrefs(SEXP fn, SEXP wrap_call_args_sxp, SEXP quiet_sxp) {
     int wrap_call_args = LOGICAL(wrap_call_args_sxp)[0];
     int quiet = LOGICAL(quiet_sxp)[0];
 
+#if IMPUTESRCREF_R_GE_4_6
+    SEXP fn_attrs = PROTECT(call_attributes(fn));
+#else
     SEXP fn_attrs = PROTECT(Rf_duplicate(ATTRIB(fn)));
+#endif
 
     /* `quiet` only suppresses the "no srcref" message emitted by
        source_text. OR with the ambient flag so a `quiet = TRUE` call inside an
@@ -629,7 +662,11 @@ SEXP C_impute_srcrefs(SEXP fn, SEXP wrap_call_args_sxp, SEXP quiet_sxp) {
            impute nested closures that carry their own srcref (the S4 `.local`
            wrapper case). If none are found, return the function unchanged. */
         int imputed_any = 0;
+#if IMPUTESRCREF_R_GE_4_6
+        SEXP body_copy = PROTECT(Rf_duplicate(R_ClosureBody(fn)));
+#else
         SEXP body_copy = PROTECT(Rf_duplicate(BODY(fn)));
+#endif
         impute_nested_inplace(body_copy, wrap_call_args_sxp, quiet_sxp, &imputed_any);
         if (!imputed_any) {
             UNPROTECT(3); /* body_copy, src, fn_attrs */
@@ -643,10 +680,18 @@ SEXP C_impute_srcrefs(SEXP fn, SEXP wrap_call_args_sxp, SEXP quiet_sxp) {
             }
             return fn;
         }
+#if IMPUTESRCREF_R_GE_4_6
+        /* No public body setter on R >= 4.6: rebuild the closure with the
+           imputed body, then restore attributes and the S4 object bit that
+           R_mkClosure drops (Rf_duplicate would have preserved them). */
+        SEXP out = PROTECT(R_mkClosure(R_ClosureFormals(fn), body_copy, R_ClosureEnv(fn)));
+        reapply_attributes(out, fn_attrs, fn);
+#else
         /* Rf_duplicate preserves formals, environment, attributes and the S4
            object bit; only the body changes. */
         SEXP out = PROTECT(Rf_duplicate(fn));
         SET_BODY(out, body_copy);
+#endif
         UNPROTECT(4); /* out, body_copy, src, fn_attrs */
         return out;
     }
@@ -746,19 +791,33 @@ SEXP C_impute_srcrefs(SEXP fn, SEXP wrap_call_args_sxp, SEXP quiet_sxp) {
     SEXP fmls = PROTECT(call_formals(fn));
     SEXP bdy = PROTECT(call_body(fn));
     SEXP fnsym = PROTECT(Rf_install("function"));
+#if IMPUTESRCREF_R_GE_4_6
+    SEXP fn_expr = PROTECT(Rf_allocLang(3));
+#else
     SEXP fn_expr = PROTECT(Rf_allocList(3));
     SET_TYPEOF(fn_expr, LANGSXP);
+#endif
     SETCAR(fn_expr, fnsym);
     SETCAR(CDR(fn_expr), fmls);
     SETCAR(CDDR(fn_expr), bdy);
 
     SEXP transformed = PROTECT(imputesrcref_transform_expr(fn_expr, root_id, &ctx));
 
-    /* Apply to fn: out <- fn; formals(out) <- transformed[[2]]; body(out) <- transformed[[3]] */
-    SEXP out = PROTECT(Rf_duplicate(fn));
     SEXP new_formals = CADR(transformed);
     SEXP new_body = CADDR(transformed);
 
+#if IMPUTESRCREF_R_GE_4_6
+    /* No public formals/body setters on R >= 4.6: build a fresh closure with
+       the transformed formals/body and the original environment, then restore
+       attributes and the S4 object bit. */
+    SEXP out = PROTECT(R_mkClosure(new_formals != R_NilValue ? new_formals
+                                                             : R_ClosureFormals(fn),
+                                   new_body, R_ClosureEnv(fn)));
+    reapply_attributes(out, fn_attrs, fn);
+#else
+    /* Apply to fn: out <- fn; formals(out) <- transformed[[2]]; body(out) <- transformed[[3]] */
+    SEXP out = PROTECT(Rf_duplicate(fn));
+
     if (new_formals != R_NilValue) {
         SET_FORMALS(out, new_formals);
     }
@@ -772,6 +831,7 @@ SEXP C_impute_srcrefs(SEXP fn, SEXP wrap_call_args_sxp, SEXP quiet_sxp) {
         Rf_setAttrib(out, tag, val);
         attr_iter = CDR(attr_iter);
     }
+#endif
 
     UNPROTECT(11);
     return out;