diff --git a/.github/docker/r-ci/Dockerfile b/.github/docker/r-ci/Dockerfile index 3df0380..d6c858c 100644 --- a/.github/docker/r-ci/Dockerfile +++ b/.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 diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 1f94b48..c23eb65 100644 --- a/.github/workflows/test.yml +++ b/.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 }} diff --git a/.gitignore b/.gitignore index 4e480d4..2c25eaf 100644 --- a/.gitignore +++ b/.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/ diff --git a/src/blacklist.c b/src/blacklist.c index 5175816..6a35245 100644 --- a/src/blacklist.c +++ b/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 { diff --git a/src/imputesrcref.h b/src/imputesrcref.h index 526c283..da5759e 100644 --- a/src/imputesrcref.h +++ b/src/imputesrcref.h @@ -4,8 +4,21 @@ #define R_NO_REMAP #include #include +#include #include +/* 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; diff --git a/src/source_impute.c b/src/source_impute.c index a9bdfc2..8a8ebed 100644 --- a/src/source_impute.c +++ b/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")); diff --git a/src/srcref_sites.c b/src/srcref_sites.c index fd96510..db2276e 100644 --- a/src/srcref_sites.c +++ b/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) { diff --git a/src/transform.c b/src/transform.c index 2f5d1c6..b8b8c71 100644 --- a/src/transform.c +++ b/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;