Merge pull request #396 from RConsortium/rewrite-prop<--in-c

rewrite `prop<-()` in C

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

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

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

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