Make vec_ptype_common() use list2()

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,

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},

src/ptype-common.c

@@ -5,38 +5,38 @@
 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;
 }
 
 // [[ register(external = TRUE) ]]
 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;
 }
 

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")))