From 2985a9db3c0a7e6357fb569d382750da191ec6b3 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Mon, 23 Sep 2024 09:44:08 -0400 Subject: [PATCH 1/5] add `collect_dots_skip_missing_` --- R/class.R | 2 +- R/utils.R | 3 +++ src/init.c | 2 ++ src/object.c | 56 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 62 insertions(+), 1 deletion(-) create mode 100644 src/object.c diff --git a/R/class.R b/R/class.R index fe6521fc..7a859c7a 100644 --- a/R/class.R +++ b/R/class.R @@ -252,7 +252,7 @@ new_object <- function(.parent, ...) { stop(msg) } - args <- list(...) + args <- list2(...) nms <- names(args) # TODO: Some type checking on `.parent`? 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..8b66cdc2 --- /dev/null +++ b/src/object.c @@ -0,0 +1,56 @@ +#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. Ideally we could iterate + // over the DOTSXP list of promises directly, but there is currently + // no non-"non-API" way to do this. So we use `base::missing(..i)` to + // test for missingness, and use `substitute(list(...))` to get the + // promise expressions. + 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); + } + // 14 = 2 for ".." + up to 10 digit number + '\0' + 1 extra for safety + static char ddi_buf[14] = ".."; + static char *i_buf = ddi_buf + 2; + ddi_buf[13] = '\0'; // Technically not necessary, but just to be safe + + 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++) { + snprintf(i_buf, sizeof(ddi_buf) - 2, "%u", i); + 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)) { + ddExpr_node = CDR(ddExpr_node); + SETCDR(prev_node, ddExpr_node); + } else { + if (TAG(ddExpr_node) == R_NilValue) { + SEXP val_expr = CAR(ddExpr_node); + if (TYPEOF(val_expr) == SYMSXP) { + SET_TAG(ddExpr_node, val_expr); + } + } + SETCAR(ddExpr_node, ddSym); + prev_node = ddExpr_node; + ddExpr_node = CDR(ddExpr_node); + } + } + } + + UNPROTECT(1); // is_missing + return Rf_eval(list_dddExprs_call, env); +} \ No newline at end of file From 57dabec74a4398cb965502624c97cec994b0563a Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Mon, 23 Sep 2024 09:44:22 -0400 Subject: [PATCH 2/5] update tests --- tests/testthat/test-constructor.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/testthat/test-constructor.R b/tests/testthat/test-constructor.R index 1809a662..9d04a587 100644 --- a/tests/testthat/test-constructor.R +++ b/tests/testthat/test-constructor.R @@ -140,8 +140,8 @@ test_that("can create constructors with missing or lazy defaults", { birthdate = Sys.Date() ))) # no age - expect_error(Person(), 'argument "first_name" is missing, with no default') - expect_error(Person("Alice"), 'argument "last_name" is missing, with no default') + expect_error(Person(), "@first_name") + expect_error(Person("Alice"), "@last_name") p <- Person("Alice", ,"Smith") From 16cb4227c00b19240095ddc5d99e7faa0720e188 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Mon, 23 Sep 2024 10:03:43 -0400 Subject: [PATCH 3/5] Convert to snapshot tests. --- tests/testthat/_snaps/constructor.md | 20 ++++++++++++++++++++ tests/testthat/test-constructor.R | 4 ++-- 2 files changed, 22 insertions(+), 2 deletions(-) diff --git a/tests/testthat/_snaps/constructor.md b/tests/testthat/_snaps/constructor.md index 8c824bb9..7d80f67f 100644 --- a/tests/testthat/_snaps/constructor.md +++ b/tests/testthat/_snaps/constructor.md @@ -69,3 +69,23 @@ new_object(foo(...), y = y) +# can create constructors with missing or lazy defaults + + Code + Person() + Condition + Error: + ! object properties are invalid: + - @first_name must be , not + - @last_name must be or , not + - @nick_name must be , not + +--- + + Code + Person("Alice") + Condition + Error: + ! object properties are invalid: + - @last_name must be or , not + diff --git a/tests/testthat/test-constructor.R b/tests/testthat/test-constructor.R index 9d04a587..761b91d1 100644 --- a/tests/testthat/test-constructor.R +++ b/tests/testthat/test-constructor.R @@ -140,8 +140,8 @@ test_that("can create constructors with missing or lazy defaults", { birthdate = Sys.Date() ))) # no age - expect_error(Person(), "@first_name") - expect_error(Person("Alice"), "@last_name") + expect_snapshot(Person(), error = TRUE) + expect_snapshot(Person("Alice"), error = TRUE) p <- Person("Alice", ,"Smith") From 8bdad50fec5a71635e6566de1f33e223a2668c2b Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Mon, 23 Sep 2024 11:22:01 -0400 Subject: [PATCH 4/5] Add tests for `list2()` --- tests/testthat/test-utils.R | 38 +++++++++++++++++++++++++++++++++++++ 1 file changed, 38 insertions(+) create mode 100644 tests/testthat/test-utils.R 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)) +}) From 438ae21c47961c6b2af78e75cef0d70d653da6eb Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Tue, 1 Oct 2024 10:49:17 -0400 Subject: [PATCH 5/5] Updates after #445 --- R/constructor.R | 3 ++- R/property.R | 8 ------- src/object.c | 36 +++++++++++++++++++++++----- tests/testthat/_snaps/constructor.md | 29 +++++----------------- tests/testthat/test-constructor.R | 11 +++++---- 5 files changed, 45 insertions(+), 42 deletions(-) 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/src/object.c b/src/object.c index 8b66cdc2..6c121022 100644 --- a/src/object.c +++ b/src/object.c @@ -4,21 +4,32 @@ SEXP collect_dots_skip_missing_(SEXP env, SEXP list_dddExprs_call) { // This function is equivalent to `base::list(...)`, except it - // silently skips missing arguments. Ideally we could iterate + // 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. So we use `base::missing(..i)` to + // 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); } - // 14 = 2 for ".." + up to 10 digit number + '\0' + 1 extra for safety + static char ddi_buf[14] = ".."; static char *i_buf = ddi_buf + 2; - ddi_buf[13] = '\0'; // Technically not necessary, but just to be safe PROTECT_INDEX pi; PROTECT_WITH_INDEX(R_NilValue, &pi); @@ -28,23 +39,36 @@ SEXP collect_dots_skip_missing_(SEXP env, SEXP list_dddExprs_call) { SEXP prev_node = list_dddExprs_call; SEXP ddExpr_node = CDR(list_dddExprs_call); for (; ddExpr_node != R_NilValue; i++) { - snprintf(i_buf, sizeof(ddi_buf) - 2, "%u", 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); } @@ -53,4 +77,4 @@ SEXP collect_dots_skip_missing_(SEXP env, SEXP list_dddExprs_call) { UNPROTECT(1); // is_missing return Rf_eval(list_dddExprs_call, env); -} \ No newline at end of file +} diff --git a/tests/testthat/_snaps/constructor.md b/tests/testthat/_snaps/constructor.md index 5420b18c..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) } @@ -80,23 +83,3 @@ new_object(foo(...), y = y) -# can create constructors with missing or lazy defaults - - Code - Person() - Condition - Error: - ! object properties are invalid: - - @first_name must be , not - - @last_name must be or , not - - @nick_name must be , not - ---- - - Code - Person("Alice") - Condition - Error: - ! object properties are invalid: - - @last_name must be or , not - 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