diff --git a/R/type.R b/R/type.R index 5e167dd18..f23016fa0 100644 --- a/R/type.R +++ b/R/type.R @@ -114,16 +114,18 @@ vec_ptype_common <- function( .arg = "", .call = caller_env() ) { - .External2(ffi_ptype_common, .ptype) + .External2(ffi_ptype_common, list2(...), .ptype) } + vec_ptype_common_opts <- function( ..., .ptype = NULL, .opts = fallback_opts(), .call = caller_env() ) { - .External2(ffi_ptype_common_opts, .ptype, .opts) + .External2(ffi_ptype_common_opts, list2(...), .ptype, .opts) } + vec_ptype_common_params <- function( ..., .ptype = NULL, @@ -140,6 +142,7 @@ vec_ptype_common_params <- function( .call = .call ) } + vec_ptype_common_fallback <- function( ..., .ptype = NULL, diff --git a/src/init.c b/src/init.c index c131f0f8a..c14873180 100644 --- a/src/init.c +++ b/src/init.c @@ -391,8 +391,8 @@ extern r_obj* ffi_new_data_frame(r_obj*); static const R_ExternalMethodDef ExtEntries[] = { - {"ffi_ptype_common", (DL_FUNC) &ffi_ptype_common, 1}, - {"ffi_ptype_common_opts", (DL_FUNC) &ffi_ptype_common_opts, 2}, + {"ffi_ptype_common", (DL_FUNC) &ffi_ptype_common, 2}, + {"ffi_ptype_common_opts", (DL_FUNC) &ffi_ptype_common_opts, 3}, {"ffi_size_common", (DL_FUNC) &ffi_size_common, 3}, {"ffi_recycle_common", (DL_FUNC) &ffi_recycle_common, 2}, {"ffi_cast_common", (DL_FUNC) &ffi_cast_common, 1}, diff --git a/src/ptype-common.c b/src/ptype-common.c index 24ac0abc9..9c516290e 100644 --- a/src/ptype-common.c +++ b/src/ptype-common.c @@ -5,20 +5,21 @@ r_obj* ffi_ptype_common(r_obj* ffi_call, r_obj* op, r_obj* args, r_obj* env) { args = r_node_cdr(args); - r_obj* types = KEEP(rlang_env_dots_list(env)); - r_obj* ptype = KEEP(r_eval(r_node_car(args), env)); + r_obj* xs = r_node_car(args); args = r_node_cdr(args); + r_obj* ptype = r_node_car(args); struct r_lazy call = { .x = syms.dot_call, .env = env }; - struct r_lazy arg_lazy = { .x = syms.dot_arg, .env = env }; - struct vctrs_arg arg = new_lazy_arg(&arg_lazy); + struct r_lazy xs_arg_lazy = { .x = syms.dot_arg, .env = env }; + struct vctrs_arg xs_arg = new_lazy_arg(&xs_arg_lazy); - r_obj* out = vec_ptype_common_params(types, - ptype, - S3_FALLBACK_false, - &arg, - call); + r_obj* out = vec_ptype_common_params( + xs, + ptype, + S3_FALLBACK_false, + &xs_arg, + call + ); - FREE(2); return out; } @@ -26,17 +27,16 @@ r_obj* ffi_ptype_common(r_obj* ffi_call, r_obj* op, r_obj* args, r_obj* env) { r_obj* ffi_ptype_common_opts(r_obj* call, r_obj* op, r_obj* args, r_obj* env) { args = r_node_cdr(args); - r_obj* types = KEEP(rlang_env_dots_list(env)); - r_obj* ptype = KEEP(r_eval(r_node_car(args), env)); args = r_node_cdr(args); - r_obj* opts = KEEP(r_eval(r_node_car(args), env)); + r_obj* xs = r_node_car(args); args = r_node_cdr(args); + r_obj* ptype = r_node_car(args); args = r_node_cdr(args); + r_obj* opts = r_node_car(args); struct ptype_common_opts ptype_opts = { .call = { .x = syms.dot_call, .env = env }, .fallback = new_fallback_opts(opts) }; - r_obj* out = vec_ptype_common_opts(types, ptype, &ptype_opts); + r_obj* out = vec_ptype_common_opts(xs, ptype, &ptype_opts); - FREE(3); return out; } diff --git a/tests/testthat/test-type.R b/tests/testthat/test-type.R index 35e5f8b8e..1ef1cbb0d 100644 --- a/tests/testthat/test-type.R +++ b/tests/testthat/test-type.R @@ -57,6 +57,12 @@ test_that("vec_ptype_common() handles matrices", { expect_identical(vec_ptype_common(m, m), matrix(int(), ncol = 2)) }) +test_that("vec_ptype_common() doesn't mutate input", { + x <- list(a = 1L, b = 2) + expect_identical(vec_ptype_common(!!!x), numeric()) + expect_identical(x, list(a = 1L, b = 2)) +}) + test_that("vec_ptype_common() includes index in argument tag", { df1 <- tibble(x = tibble(y = tibble(z = 1))) df2 <- tibble(x = tibble(y = tibble(z = "a")))