diff --git a/NEWS.md b/NEWS.md index 0ecdb446..ec6781f2 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,10 @@ # S7 (development version) +* Propert setting (via `prop<-` and `@<-`) rewritten in C for performance (#396). + +* Fixed a regression where `validate()` would not be called after a custom + property setter was invoked (reported in #393, fixed in #396). + * When a method is not found, the error now has class `S7_error_method_not_found`. * The `Ops` generic now falls back to base Ops behaviour when one of the diff --git a/R/inherits.R b/R/inherits.R index ccfc22db..0da413e4 100644 --- a/R/inherits.R +++ b/R/inherits.R @@ -32,6 +32,7 @@ S7_inherits <- function(x, class = NULL) { #' @export #' @rdname S7_inherits +# called from src/prop.c check_is_S7 <- function(x, class = NULL, arg = deparse(substitute(x))) { if (S7_inherits(x, class)) { return(invisible()) diff --git a/R/property.R b/R/property.R index 361a577c..f337f810 100644 --- a/R/property.R +++ b/R/property.R @@ -203,7 +203,12 @@ prop_obj <- function(object, name) { #' @param check If `TRUE`, check that `value` is of the correct type and run #' [validate()] on the object before returning. #' @export -`prop<-` <- local({ +`prop<-` <- function(object, name, check = TRUE, value) { + .Call(prop_set_, object, name, check, value) +} + +`propr<-` <- local({ + # reference implementation of `prop<-()` implemented in R # This flag is used to avoid infinite loops if you are assigning a property from a setter function setter_property <- NULL @@ -243,10 +248,24 @@ prop_obj <- function(object, name) { } }) +# called from src/prop.c +signal_prop_error <- function(fmt, object, name) { + msg <- sprintf(fmt, obj_desc(object), name) + stop(msg, call. = FALSE) +} + +# called from src/prop.c +signal_error <- function(msg) { + stop(msg, call. = FALSE) +} + + prop_error_unknown <- function(object, prop_name) { sprintf("Can't find property %s@%s", obj_desc(object), prop_name) } + +# called from src/prop.c prop_validate <- function(prop, value, object = NULL) { if (!class_inherits(value, prop$class)) { sprintf("%s must be %s, not %s", diff --git a/src/init.c b/src/init.c index ca1669e1..39f780ec 100644 --- a/src/init.c +++ b/src/init.c @@ -9,12 +9,14 @@ extern SEXP method_call_(SEXP, SEXP, SEXP); extern SEXP S7_class_(SEXP, SEXP); extern SEXP S7_object_(void); extern SEXP prop_(SEXP, SEXP); +extern SEXP prop_set_(SEXP, SEXP, SEXP, SEXP); static const R_CallMethodDef CallEntries[] = { {"method_", (DL_FUNC) &method_, 4}, {"method_call_", (DL_FUNC) &method_call_, 3}, {"S7_object_", (DL_FUNC) &S7_object_, 0}, {"prop_", (DL_FUNC) &prop_, 2}, + {"prop_set_", (DL_FUNC) &prop_set_, 4}, {NULL, NULL, 0} }; @@ -30,6 +32,9 @@ SEXP sym_constructor; SEXP sym_validator; SEXP sym_getter; +SEXP sym_dot_should_validate; +SEXP sym_dot_setting_prop; + SEXP ns_S7; @@ -48,11 +53,8 @@ void R_init_S7(DllInfo *dll) sym_constructor = Rf_install("constructor"); sym_validator = Rf_install("validator"); sym_getter = Rf_install("getter"); + sym_dot_should_validate = Rf_install(".should_validate"); + sym_dot_setting_prop = Rf_install(".setting_prop"); ns_S7 = Rf_findVarInFrame(R_NamespaceRegistry, Rf_install("S7")); - } - - - - diff --git a/src/prop.c b/src/prop.c index cc61a50a..e393e46d 100644 --- a/src/prop.c +++ b/src/prop.c @@ -14,6 +14,59 @@ extern SEXP sym_validator; extern SEXP ns_S7; +extern SEXP sym_dot_should_validate; +extern SEXP sym_dot_setting_prop; + +static inline +SEXP eval_here(SEXP lang) { + PROTECT(lang); + SEXP ans = Rf_eval(lang, ns_S7); + UNPROTECT(1); + return ans; +} + +static __attribute__((noreturn)) +void signal_is_not_S7(SEXP object) { + static SEXP check_is_S7 = NULL; + if (check_is_S7 == NULL) + check_is_S7 = Rf_findVarInFrame(ns_S7, Rf_install("check_is_S7")); + + // will signal error + eval_here(Rf_lang2(check_is_S7, object)); + while(1); +} + + +static __attribute__((noreturn)) +void signal_prop_error(const char* fmt, SEXP object, SEXP name) { + static SEXP signal_prop_error = NULL; + if (signal_prop_error == NULL) + signal_prop_error = Rf_findVarInFrame(ns_S7, Rf_install("signal_prop_error")); + + eval_here(Rf_lang4(signal_prop_error, Rf_mkString(fmt), object, name)); + while(1); +} + +static __attribute__((noreturn)) +void signal_prop_error_unknown(SEXP object, SEXP name) { + signal_prop_error("Can't find property %s@%s", object, name); +} + +static __attribute__((noreturn)) +void signal_error(SEXP errmsg) { + PROTECT(errmsg); + if(TYPEOF(errmsg) == STRSXP && Rf_length(errmsg) == 1) + Rf_errorcall(R_NilValue, "%s", CHAR(STRING_ELT(errmsg, 0))); + + // fallback to calling base::stop(errmsg) + static SEXP signal_error = NULL; + if (signal_error == NULL) + signal_error = Rf_findVarInFrame(ns_S7, Rf_install("signal_error")); + + eval_here(Rf_lang2(signal_error, errmsg)); + while(1); +} + static inline int name_idx(SEXP list, const char* name) { SEXP names = Rf_getAttrib(list, R_NamesSymbol); @@ -22,7 +75,7 @@ int name_idx(SEXP list, const char* name) { for (int i = 0, n = Rf_length(names); i < n; i++) if (strcmp(CHAR(STRING_ELT(names, i)), name) == 0) return i; - return -1; + return -1; } static inline @@ -33,7 +86,7 @@ SEXP extract_name(SEXP list, const char* name) { static inline Rboolean has_name(SEXP list, const char* name) { - return (Rboolean) name_idx(list, name) != -1; + return (Rboolean) (name_idx(list, name) != -1); } static inline @@ -50,32 +103,26 @@ Rboolean inherits2(SEXP object, const char* name) { return FALSE; } -inline static +static inline Rboolean is_s7_object(SEXP object) { return inherits2(object, "S7_object"); } -inline static +static inline Rboolean is_s7_class(SEXP object) { return inherits2(object, "S7_class"); } -static -__attribute__ ((noreturn)) -void signal_prop_error_unknown_(SEXP object, SEXP name) { - static SEXP signal_prop_error_unknown = NULL; - if (signal_prop_error_unknown == NULL) - signal_prop_error_unknown = - Rf_findVarInFrame(ns_S7, Rf_install("signal_prop_error_unknown")); - - Rf_eval(Rf_lang3(signal_prop_error_unknown, object, name), ns_S7); - while(1); +static inline +void check_is_S7(SEXP object) { + if (is_s7_object(object)) + return; + signal_is_not_S7(object); } -SEXP prop_(SEXP object, SEXP name) { - if (!is_s7_object(object)) - goto error; +SEXP prop_(SEXP object, SEXP name) { + check_is_S7(object); SEXP name_rchar = STRING_ELT(name, 0); const char* name_char = CHAR(name_rchar); @@ -87,26 +134,17 @@ SEXP prop_(SEXP object, SEXP name) { // if value was accessed as an attr, we still need to validate to make sure // the attr is actually a known class property - if (value != R_NilValue) - goto validate; - - // property not in attrs, try to get value using the getter() - if (properties == R_NilValue) goto validate; - - SEXP property = extract_name(properties, name_char); - if (property == R_NilValue) goto validate; - - SEXP getter = extract_name(property, "getter"); - if (getter == R_NilValue) goto validate; - - if (TYPEOF(getter) == CLOSXP) - // we validated property is in properties list when accessing getter() - return Rf_eval(Rf_lang2(getter, object), ns_S7); - - - validate: + if (value == R_NilValue) { + // property not in attrs, try to get value using the getter() + SEXP property = extract_name(properties, name_char); + SEXP getter = extract_name(property, "getter"); + if (TYPEOF(getter) == CLOSXP) + // we validated property is in properties list when accessing getter() + // TODO: mark/check object for getter non-recursion. https://github.com/RConsortium/S7/issues/403 + return eval_here(Rf_lang2(getter, object)); + } - if(has_name(properties, name_char)) + if (has_name(properties, name_char)) return value; if (S7_class == R_NilValue && @@ -117,12 +155,150 @@ SEXP prop_(SEXP object, SEXP name) { name_sym == sym_properties || name_sym == sym_abstract || name_sym == sym_constructor || - name_sym == sym_validator - )) + name_sym == sym_validator)) return value; - error: + // Should the constructor always set default prop values on a object instance? + // Maybe, instead, we can fallback here to checking for a default value from the + // properties list. - signal_prop_error_unknown_(object, name); + signal_prop_error_unknown(object, name); return R_NilValue; // unreachable, for compiler } + + +static inline +Rboolean pairlist_contains(SEXP list, SEXP elem) { + for (SEXP c = list; c != R_NilValue; c = CDR(c)) + if (CAR(c) == elem) + return TRUE; + return FALSE; +} + +static inline +SEXP pairlist_remove(SEXP list, SEXP elem) { + SEXP c0 = NULL, head = list; + for (SEXP c = list; c != R_NilValue; c0 = c, c = CDR(c)) + if (CAR(c) == elem) + { + if (c0 == NULL) + return CDR(c); + else + { + SETCDR(c0, CDR(c)); + return head; + } + } + + Rf_error("Tried to remove non-existent element from pairlist"); + return R_NilValue; +} + +static inline +Rboolean setter_callable_no_recurse(SEXP setter, SEXP object, SEXP name_sym, + Rboolean* should_validate_obj) { + // Check if we should call `setter` and if so, prepare `setter` for calling. + + SEXP no_recurse_list = Rf_getAttrib(object, sym_dot_setting_prop); + if (TYPEOF(no_recurse_list) == LISTSXP) { + // if there is a 'no_recurse' list, then this is not the top-most prop<- + // call for this object, i.e, we're currently evaluating a `prop<-` call + // called from within a custom property setter. We should only call + // validate(object) once from the top-most prop<- call, after the last + // custom setter() has returned. + *should_validate_obj = FALSE; + if (pairlist_contains(no_recurse_list, name_sym)) + return FALSE; + } + + if (TYPEOF(setter) != CLOSXP) + return FALSE; // setter not callable + + Rf_setAttrib(object, sym_dot_setting_prop, + Rf_cons(name_sym, no_recurse_list)); + return TRUE; // setter now marked non-recursive, safe to call + + // optimization opportunity: combine the actions of getAttrib()/setAttrib() + // into one loop, so we can avoid iterating over ATTRIB(object) twice. +} + +static inline +void setter_no_recurse_clear(SEXP object, SEXP name_sym) { + SEXP list = Rf_getAttrib(object, sym_dot_setting_prop); + list = pairlist_remove(list, name_sym); + Rf_setAttrib(object, sym_dot_setting_prop, list); + + // optimization opportunity: same as setter_callable_no_recurse +} + +static inline +void prop_validate(SEXP property, SEXP value, SEXP object) { + + static SEXP prop_validate = NULL; + if (prop_validate == NULL) + prop_validate = Rf_findVarInFrame(ns_S7, Rf_install("prop_validate")); + + SEXP errmsg = eval_here(Rf_lang4(prop_validate, property, value, object)); + if (errmsg != R_NilValue) signal_error(errmsg); +} + +static inline +void obj_validate(SEXP object) { + static SEXP validate = NULL; + if (validate == NULL) + validate = Rf_findVarInFrame(ns_S7, Rf_install("validate")); + + eval_here(Rf_lang4( + validate, object, + /* recursive = */ Rf_ScalarLogical(TRUE), + /* properties = */ Rf_ScalarLogical(FALSE))); +} + +SEXP prop_set_(SEXP object, SEXP name, SEXP check_sexp, SEXP value) { + + check_is_S7(object); + + SEXP name_rchar = STRING_ELT(name, 0); + const char *name_char = CHAR(name_rchar); + SEXP name_sym = Rf_installTrChar(name_rchar); + + Rboolean check = Rf_asLogical(check_sexp); + Rboolean should_validate_obj = check; + Rboolean should_validate_prop = check; + + SEXP S7_class = Rf_getAttrib(object, sym_S7_class); + SEXP properties = Rf_getAttrib(S7_class, sym_properties); + SEXP property = extract_name(properties, name_char); + + if (property == R_NilValue) + signal_prop_error_unknown(object, name); + + SEXP setter = extract_name(property, "setter"); + SEXP getter = extract_name(property, "getter"); + + if (getter != R_NilValue && setter == R_NilValue) + signal_prop_error("Can't set read-only property %s@%s", object, name); + + PROTECT_INDEX object_pi; + // maybe use R_shallow_duplicate_attr() here instead + // once it becomes API or S7 becomes part of R + object = Rf_shallow_duplicate(object); + PROTECT_WITH_INDEX(object, &object_pi); + + if (setter_callable_no_recurse(setter, object, name_sym, &should_validate_obj)) { + // use setter() + REPROTECT(object = eval_here(Rf_lang3(setter, object, value)), object_pi); + setter_no_recurse_clear(object, name_sym); + } else { + // don't use setter() + if (should_validate_prop) + prop_validate(property, value, object); + Rf_setAttrib(object, name_sym, value); + } + + if (should_validate_obj) + obj_validate(object); + + UNPROTECT(1); + return object; +} diff --git a/tests/testthat/_snaps/property.md b/tests/testthat/_snaps/property.md index 4f5ea5e7..6ebc6052 100644 --- a/tests/testthat/_snaps/property.md +++ b/tests/testthat/_snaps/property.md @@ -45,6 +45,8 @@ [1] "validating" Code obj@x <- "456" + Output + [1] "validating" # prop setting: validates once with recursive property setters @@ -192,3 +194,65 @@ ! object properties are invalid: - @x must be length 1 +# prop<- won't infinitly recurse on a custom setter + + Code + obj <- foo() + Output + Starting syncup with value: + setting @a <- "a_" + setting @b <- "b_" + Starting syncup with value: b_ + setting @a <- "a_b_" + setting @b <- "b_b_" + Starting syncup with value: + setting @a <- "a_" + Starting syncup with value: a_ + setting @a <- "a_a_" + setting @b <- "b_a_" + setting @b <- "b_" + Code + obj@a <- "val" + Output + Starting syncup with value: val + setting @a <- "a_val" + setting @b <- "b_val" + Starting syncup with value: b_val + setting @a <- "a_b_val" + setting @b <- "b_b_val" + +# custom setters can invoke setters on non-self objects + + Code + receiver <- Receiver() + Output + [rx] receiving: + [rx] finished receiving. + Code + transmitter <- Transmitter() + Output + [tx] sending: + [rx] receiving: + [rx] finished receiving. + [tx] saving last sent message. + [tx] finished transmitting. + Code + transmitter@message <- "hello" + Output + [tx] sending: hello + [rx] receiving: hello + [rx] finished receiving. + [tx] saving last sent message. + [tx] finished transmitting. + Code + expect_equal(receiver@message, "hello") + transmitter@message <- "goodbye" + Output + [tx] sending: goodbye + [rx] receiving: goodbye + [rx] finished receiving. + [tx] saving last sent message. + [tx] finished transmitting. + Code + expect_equal(receiver@message, "goodbye") + diff --git a/tests/testthat/test-property.R b/tests/testthat/test-property.R index 94bc983e..f6420fc3 100644 --- a/tests/testthat/test-property.R +++ b/tests/testthat/test-property.R @@ -324,3 +324,64 @@ test_that("can validate with custom validator", { foo(x = 1:2) }) }) + +test_that("prop<- won't infinitly recurse on a custom setter", { + chattily_sync_ab <- function(self, value) { + cat("Starting syncup with value:", value, "\n") + a_value <- paste0("a_", value) + b_value <- paste0("b_", value) + + cat(sprintf('setting @a <- "%s"\n', a_value)) + self@a <- a_value + + cat(sprintf('setting @b <- "%s"\n', b_value)) + self@b <- b_value + + self + } + + foo <- new_class("foo", properties = list( + a = new_property(setter = chattily_sync_ab), + b = new_property(setter = chattily_sync_ab) + )) + + expect_snapshot({ + obj <- foo() + obj@a <- "val" + }) +}) + +test_that("custom setters can invoke setters on non-self objects", { + + Transmitter <- new_class("Transmitter", properties = list( + message = new_property(setter = function(self, value) { + cat("[tx] sending: ", value, "\n") + receiver@message <<- value + cat("[tx] saving last sent message.\n") + self@message <- value + cat("[tx] finished transmitting.\n") + self + }) + )) + + Receiver <- new_class("Receiver", properties = list( + message = new_property(setter = function(self, value) { + cat("[rx] receiving: ", value, "\n") + self@message <- value + cat("[rx] finished receiving.\n") + self + }) + )) + + expect_snapshot({ + receiver <- Receiver() + transmitter <- Transmitter() + + transmitter@message <- "hello" + expect_equal(receiver@message, "hello") + + transmitter@message <- "goodbye" + expect_equal(receiver@message, "goodbye") + }) + +})