diff --git a/R/class.R b/R/class.R index 281b8e24..0f8eb198 100644 --- a/R/class.R +++ b/R/class.R @@ -252,7 +252,7 @@ new_object <- function(.parent, ...) { stop(msg) } - args <- list(...) + args <- list2(...) if ("" %in% names2(args)) { stop("All arguments to `...` must be named") } diff --git a/R/constructor.R b/R/constructor.R index 63df1e78..834e7140 100644 --- a/R/constructor.R +++ b/R/constructor.R @@ -9,7 +9,8 @@ new_constructor <- function(parent, properties) { body = as.call(c(quote(`{`), # Force all promises here so that any errors are signaled from # the constructor() call instead of the new_object() call. - unname(self_args), + # allow missing. + lapply(unname(self_args), \(sym) bquote(if(!missing(.(sym))) .(sym))), new_call("new_object", c(list(quote(S7_object())), self_args)) )), env = asNamespace("S7") diff --git a/R/property.R b/R/property.R index 688a977a..a97c906a 100644 --- a/R/property.R +++ b/R/property.R @@ -115,14 +115,6 @@ check_prop_default <- function(default, class, error_call = sys.call(-1)) { } if (is.symbol(default)) { - if (identical(default, quote(...))) { - # The meaning of a `...` prop default needs discussion - stop(simpleError("`default` cannot be `...`", error_call)) - } - if (identical(default, quote(expr =))) { - # The meaning of a missing prop default needs discussion - stop(simpleError("`default` cannot be missing", error_call)) - } # other symbols are treated as promises return() diff --git a/R/utils.R b/R/utils.R index e04ec31b..d5f52e4f 100644 --- a/R/utils.R +++ b/R/utils.R @@ -144,6 +144,9 @@ modify_list <- function (x, new_vals) { x } +list2 <- function(...) + .Call(collect_dots_skip_missing_, environment(), substitute(list(...))) + # For older versions of R ---------------------------------------------------- deparse1 <- function(expr, collapse = " ", width.cutoff = 500L, ...) { diff --git a/src/init.c b/src/init.c index 11568282..b3cbbfa3 100644 --- a/src/init.c +++ b/src/init.c @@ -10,6 +10,7 @@ extern SEXP S7_class_(SEXP, SEXP); extern SEXP S7_object_(void); extern SEXP prop_(SEXP, SEXP); extern SEXP prop_set_(SEXP, SEXP, SEXP, SEXP); +extern SEXP collect_dots_skip_missing_(SEXP, SEXP); static const R_CallMethodDef CallEntries[] = { {"method_", (DL_FUNC) &method_, 4}, @@ -17,6 +18,7 @@ static const R_CallMethodDef CallEntries[] = { {"S7_object_", (DL_FUNC) &S7_object_, 0}, {"prop_", (DL_FUNC) &prop_, 2}, {"prop_set_", (DL_FUNC) &prop_set_, 4}, + {"collect_dots_skip_missing_", (DL_FUNC) &collect_dots_skip_missing_, 2}, {NULL, NULL, 0} }; diff --git a/src/object.c b/src/object.c new file mode 100644 index 00000000..6c121022 --- /dev/null +++ b/src/object.c @@ -0,0 +1,80 @@ +#define R_NO_REMAP +#include +#include + +SEXP collect_dots_skip_missing_(SEXP env, SEXP list_dddExprs_call) { + // This function is equivalent to `base::list(...)`, except it + // silently skips missing arguments, and auto-names elements + // that are unnamed and supplied in the call as a symbol. I.e., + // f(a, , b+1) becomes f(a = a, b+1) + // + // Implementation note: ideally we could iterate + // over the DOTSXP list of promises directly, but there is currently + // no non-"non-API" way to do this. Approved API promise accessors are + // pending. So, in the interim, we use `base::missing(..i)` to + // test for missingness, and use `substitute(list(...))` to get the + // promise expressions. + // + // This same C function can be use to add "skip-missing" and "auto-name" to + // any function that takes dots. E.g.: + // + // list2 <- function(...) .Call(collect_dots_skip_missing_, substitute(list(...))) + // c2 <- function(...) .Call(collect_dots_skip_missing_, substitute(c(...))) + // pairlist2 <- function(...) .Call(collect_dots_skip_missing_, substitute(pairlist(...))) + static SEXP missing_call = NULL; + if (missing_call == NULL) { + SEXP missing_fun = Rf_eval(Rf_install("missing"), R_BaseEnv); + missing_call = Rf_lang2(missing_fun, R_NilValue); + R_PreserveObject(missing_call); + } + + static char ddi_buf[14] = ".."; + static char *i_buf = ddi_buf + 2; + + PROTECT_INDEX pi; + PROTECT_WITH_INDEX(R_NilValue, &pi); + + { + unsigned int i = 1; + SEXP prev_node = list_dddExprs_call; + SEXP ddExpr_node = CDR(list_dddExprs_call); + for (; ddExpr_node != R_NilValue; i++) { + { + int ret = snprintf(i_buf, sizeof(ddi_buf) - 2, "%u", i); + if (ret < 0) + Rf_error("unknown snprintf error"); + if (ret >= (int)(sizeof(ddi_buf) - 3)) + Rf_error("snprintf truncated output, too many args in `...`"); + ddi_buf[sizeof(ddi_buf) - 1] = '\0'; // just in case + } + + SEXP ddSym = Rf_install(ddi_buf); + + SETCADR(missing_call, ddSym); + SEXP is_missing = Rf_eval(missing_call, env); + REPROTECT(is_missing, pi); + + if (Rf_asLogical(is_missing)) { + // splice out the node from the exprs list. + ddExpr_node = CDR(ddExpr_node); + SETCDR(prev_node, ddExpr_node); + } else { + // maybe auto-name if unnamed and expr is a symbol. + if (TAG(ddExpr_node) == R_NilValue) { + SEXP val_expr = CAR(ddExpr_node); + if (TYPEOF(val_expr) == SYMSXP) { + SET_TAG(ddExpr_node, val_expr); + } + } + // replace the node expr with `..i` + SETCAR(ddExpr_node, ddSym); + // advance to the next node. + prev_node = ddExpr_node; + ddExpr_node = CDR(ddExpr_node); + } + } + } + + UNPROTECT(1); // is_missing + return Rf_eval(list_dddExprs_call, env); +} diff --git a/tests/testthat/_snaps/constructor.md b/tests/testthat/_snaps/constructor.md index a86c4857..2c1c8062 100644 --- a/tests/testthat/_snaps/constructor.md +++ b/tests/testthat/_snaps/constructor.md @@ -13,8 +13,10 @@ Output function (x = integer(0), y = integer(0)) { - x - y + if (!missing(x)) + x + if (!missing(y)) + y new_object(S7_object(), x = x, y = y) } @@ -66,7 +68,8 @@ Output function (y = numeric(0)) { - y + if (!missing(y)) + y new_object(S7_object(), y = y) } diff --git a/tests/testthat/test-constructor.R b/tests/testthat/test-constructor.R index aa5eb75e..7680124b 100644 --- a/tests/testthat/test-constructor.R +++ b/tests/testthat/test-constructor.R @@ -102,14 +102,17 @@ test_that("can create constructors with missing or lazy defaults", { name = "Person", properties = list( # non-dynamic, default error call (required constructor arg) - first_name = new_property(class_character, default = quote(stop( - 'argument "first_name" is missing, with no default'))), + first_name = new_property( + class_character, + default = quote(stop('argument "first_name" is missing, with no default')) + ), # non-dynamic, static default (optional constructor arg) middle_name = new_property(class_character, default = ""), # non-dynamic, nullable character - last_name = new_property(NULL | class_character), + last_name = new_property(NULL | class_character, + default = quote(expr =)), # non-dynamic, but defaults to the value of another property nick_name = new_property(class_character, default = quote(first_name)), @@ -136,7 +139,7 @@ test_that("can create constructors with missing or lazy defaults", { expect_equal(formals(Person), as.pairlist(alist( first_name = stop('argument "first_name" is missing, with no default'), middle_name = "", - last_name = NULL, + last_name = , nick_name = first_name, birthdate = Sys.Date() ))) # no age diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R new file mode 100644 index 00000000..308599a8 --- /dev/null +++ b/tests/testthat/test-utils.R @@ -0,0 +1,38 @@ +test_that("list2() works", { + # list2() is equivalent to base::list(), with the following differences: + # - A missing arg value is silently ignored instead of signaling an error. + # - An argument is automatically named if it is unnamed and the value expression is a symbol. + + expect_identical(list2(), list()) + expect_identical(list2(a = 1), list(a = 1)) + expect_identical(list2(a = 1, b = ), list(a = 1)) + expect_identical(list2(a = 1, b = , , ), list(a = 1)) + expect_identical(list2(, a = 1, b = , , ), list(a = 1)) + a <- 1 + expect_identical(list2(a), list(a = 1)) + expect_identical(list2(a, b = ), list(a = 1)) + expect_identical(list2(a, b = , a, ), list(a = 1, a = 1)) + expect_identical(list2(a = identity(a)), list(a = 1)) + + expect_identical(list2((a)), list(1)) + expect_identical(list2(identity(a)), list(1)) + + # make sure all this works if values in `...` are nested promises + f1 <- function(...) list2(...) + f2 <- function(..., b) f1(..., b) + f3 <- function(..., c) f2(..., c) + f4 <- function(..., d) f3(..., d) + + a <- 1; b <- 2 + for (f in list(f1, f2, f3, f4, list2)) { + expect_identical(f(), list()) + expect_mapequal(f(a = 1), list(a = 1)) + expect_mapequal(f(a = 1, b =), list(a = 1)) + expect_mapequal(f(a = 1, b = 2), list(a = 1, b = 2)) + expect_mapequal(f(a, b), list(a = 1, b = 2)) + } + + expect_identical(list2(a, b, a + b), list(a = 1, b = 2, 3)) + expect_identical(list2(a, b, c = a + b), list(a = 1, b = 2, c = 3)) + expect_identical(list2((a), b, c = a + b), list( 1, b = 2, c = 3)) +})