rewrite prop<-() in C

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

src/prop.c

@@ -14,6 +14,52 @@ extern SEXP sym_validator;
 
 extern SEXP ns_S7;
 
+extern SEXP sym_dot_should_validate;
+extern SEXP sym_dot_setting_prop;
+
+
+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
+  Rf_eval(Rf_lang2(check_is_S7, object), ns_S7);
+  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"));
+
+  Rf_eval(Rf_lang4(signal_prop_error, Rf_mkString(fmt), object, name), ns_S7);
+  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"));
+
+  Rf_eval(Rf_lang2(signal_error, errmsg), ns_S7);
+  while(1);
+}
+
 static inline
 int name_idx(SEXP list, const char* name) {
   SEXP names = Rf_getAttrib(list, R_NamesSymbol);
@@ -33,7 +79,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 +96,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 +127,16 @@ 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()
+        return Rf_eval(Rf_lang2(getter, object), ns_S7);
+  }
 
-  if(has_name(properties, name_char))
+  if (has_name(properties, name_char))
     return value;
 
   if (S7_class == R_NilValue &&
@@ -117,12 +147,148 @@ 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_warning("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) {
+
+    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 = Rf_eval(Rf_lang4(prop_validate, property, value, object), ns_S7);
+  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"));
+
+  Rf_eval(Rf_lang4(validate, object,
+                   /* recursive = */ Rf_ScalarLogical(TRUE),
+                   /* properties = */ Rf_ScalarLogical(FALSE)),
+                   ns_S7);
+}
+
+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 ipx;
+  object = Rf_shallow_duplicate(object);
+  PROTECT_WITH_INDEX(object, &ipx);
+
+  if (setter_callable_no_recurse(setter, object, name_sym, &should_validate_obj)) {
+    // use setter()
+    object = Rf_eval(Rf_lang3(setter, object, value), ns_S7);
+    REPROTECT(object, ipx);
+    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;
+}