From beebb94e76a76c596b74bac3aa920b794b94173c Mon Sep 17 00:00:00 2001
From: Tomasz Kalinowski <tomasz@posit.co>
Date: Mon, 11 Dec 2023 11:20:09 -0500
Subject: [PATCH 01/19] rewrite `prop()` in C

---
 R/property.R          | 10 +++----
 src/init.c            |  2 ++
 src/method-dispatch.c | 68 +++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 75 insertions(+), 5 deletions(-)

diff --git a/R/property.R b/R/property.R
index a7852deb..99334c45 100644
--- a/R/property.R
+++ b/R/property.R
@@ -163,13 +163,13 @@ prop_default <- function(prop) {
 #' lexington@height <- 14
 #' prop(lexington, "height") <- 15
 prop <- function(object, name) {
-  check_is_S7(object)
+  .Call(prop_, object, name)
+}
 
-  if (!prop_exists(object, name)) {
+validate_prop_access <- function(object, name) {
+  check_is_S7(object)
+  if (!prop_exists(object, name))
     stop(prop_error_unknown(object, name), call. = FALSE)
-  } else {
-    prop_val(object, name)
-  }
 }
 
 # Internal helper that assumes the property exists
diff --git a/src/init.c b/src/init.c
index 26e2c603..37d96bd0 100644
--- a/src/init.c
+++ b/src/init.c
@@ -8,11 +8,13 @@ extern SEXP method_(SEXP, SEXP, SEXP, SEXP);
 extern SEXP method_call_(SEXP, SEXP, SEXP);
 extern SEXP S7_class_(SEXP, SEXP);
 extern SEXP S7_object_(void);
+extern SEXP prop_(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},
     {NULL, NULL, 0}
 };
 
diff --git a/src/method-dispatch.c b/src/method-dispatch.c
index 9334a01e..6a160c36 100644
--- a/src/method-dispatch.c
+++ b/src/method-dispatch.c
@@ -200,3 +200,71 @@ SEXP method_call_(SEXP call, SEXP generic, SEXP envir) {
   UNPROTECT(n_protect);
   return mcall;
 }
+
+static inline
+SEXP extract_name(SEXP list, const char* name) {
+  SEXP names = Rf_getAttrib(list, R_NamesSymbol);
+
+  for (int i = 0; i < Rf_length(list); i++)
+    if (strcmp(CHAR(STRING_ELT(names, i)), name) == 0)
+      return VECTOR_ELT(list, i);
+  return R_NilValue;
+}
+
+#define early_return_if_null(obj) \
+  if (obj == R_NilValue)          \
+  {                               \
+    *validate = TRUE;             \
+    return value;                 \
+  }
+
+SEXP prop_val_(SEXP object, SEXP name, Rboolean *validate) {
+  SEXP value = Rf_getAttrib(object, name);
+  if (value != R_NilValue) {
+    // value was accessed as an attr, need to validate to make sure
+    // the attr is actually a known class property
+    *validate = TRUE;
+    return value;
+  }
+
+  SEXP S7_class_obj = Rf_getAttrib(object, Rf_install("S7_class"));
+  early_return_if_null(S7_class_obj);
+
+  SEXP properties = Rf_getAttrib(S7_class_obj, Rf_install("properties"));
+  early_return_if_null(properties);
+
+  SEXP S7_property_obj = extract_name(properties, CHAR(STRING_ELT(name, 0)));
+  early_return_if_null(S7_property_obj);
+
+  SEXP getter = extract_name(S7_property_obj, "getter");
+  early_return_if_null(getter);
+
+  if (TYPEOF(getter) == CLOSXP)
+    value = Rf_eval(Rf_lang2(getter, object), R_GlobalEnv);
+  else
+    *validate = TRUE;
+
+  return value;
+}
+#undef early_return_if_null
+
+SEXP prop_(SEXP object, SEXP name) {
+  Rboolean validate = FALSE;
+  SEXP value = prop_val_(object, name, &validate);
+  if (validate == FALSE)
+    return value;
+
+  PROTECT(value);
+  static SEXP ns = NULL;
+  if(ns == NULL)
+    ns = Rf_findVarInFrame(R_NamespaceRegistry, Rf_install("S7"));
+
+  static SEXP validate_prop_access = NULL;
+  if(validate_prop_access == NULL)
+    validate_prop_access = Rf_findVarInFrame(ns, Rf_install("validate_prop_access"));
+
+
+  Rf_eval(Rf_lang3(validate_prop_access, object, name), ns);
+  UNPROTECT(1);
+  return value;
+}

From b8422a10fb1457faa6c1a7fec73f1dd26e2849af Mon Sep 17 00:00:00 2001
From: Tomasz Kalinowski <tomasz@posit.co>
Date: Sun, 17 Dec 2023 09:26:06 -0500
Subject: [PATCH 02/19] implement `prop()` validation in C also

---
 R/property.R          |  13 ++++-
 src/init.c            |  30 ++++++++++
 src/method-dispatch.c |  68 ----------------------
 src/prop.c            | 128 ++++++++++++++++++++++++++++++++++++++++++
 4 files changed, 169 insertions(+), 70 deletions(-)
 create mode 100644 src/prop.c

diff --git a/R/property.R b/R/property.R
index 99334c45..361a577c 100644
--- a/R/property.R
+++ b/R/property.R
@@ -166,10 +166,19 @@ prop <- function(object, name) {
   .Call(prop_, object, name)
 }
 
-validate_prop_access <- function(object, name) {
+propr <- function(object, name) {
+  # reference implementation of `prop()` implemented in R
   check_is_S7(object)
-  if (!prop_exists(object, name))
+
+  if (!prop_exists(object, name)) {
     stop(prop_error_unknown(object, name), call. = FALSE)
+  } else {
+    prop_val(object, name)
+  }
+}
+
+signal_prop_error_unknown <- function(object, name) {
+  stop(prop_error_unknown(object, name), call. = FALSE)
 }
 
 # Internal helper that assumes the property exists
diff --git a/src/init.c b/src/init.c
index 37d96bd0..ca1669e1 100644
--- a/src/init.c
+++ b/src/init.c
@@ -19,10 +19,40 @@ static const R_CallMethodDef CallEntries[] = {
 };
 
 SEXP sym_ANY;
+SEXP sym_S7_class;
+
+SEXP sym_name;
+SEXP sym_parent;
+SEXP sym_package;
+SEXP sym_properties;
+SEXP sym_abstract;
+SEXP sym_constructor;
+SEXP sym_validator;
+SEXP sym_getter;
+
+SEXP ns_S7;
+
 
 void R_init_S7(DllInfo *dll)
 {
     R_registerRoutines(dll, NULL, CallEntries, NULL, NULL);
     R_useDynamicSymbols(dll, FALSE);
     sym_ANY = Rf_install("ANY");
+    sym_S7_class = Rf_install("S7_class");
+
+    sym_name = Rf_install("name");
+    sym_parent = Rf_install("parent");
+    sym_package = Rf_install("package");
+    sym_properties = Rf_install("properties");
+    sym_abstract = Rf_install("abstract");
+    sym_constructor = Rf_install("constructor");
+    sym_validator = Rf_install("validator");
+    sym_getter = Rf_install("getter");
+
+    ns_S7 = Rf_findVarInFrame(R_NamespaceRegistry, Rf_install("S7"));
+
 }
+
+
+
+
diff --git a/src/method-dispatch.c b/src/method-dispatch.c
index 6a160c36..9334a01e 100644
--- a/src/method-dispatch.c
+++ b/src/method-dispatch.c
@@ -200,71 +200,3 @@ SEXP method_call_(SEXP call, SEXP generic, SEXP envir) {
   UNPROTECT(n_protect);
   return mcall;
 }
-
-static inline
-SEXP extract_name(SEXP list, const char* name) {
-  SEXP names = Rf_getAttrib(list, R_NamesSymbol);
-
-  for (int i = 0; i < Rf_length(list); i++)
-    if (strcmp(CHAR(STRING_ELT(names, i)), name) == 0)
-      return VECTOR_ELT(list, i);
-  return R_NilValue;
-}
-
-#define early_return_if_null(obj) \
-  if (obj == R_NilValue)          \
-  {                               \
-    *validate = TRUE;             \
-    return value;                 \
-  }
-
-SEXP prop_val_(SEXP object, SEXP name, Rboolean *validate) {
-  SEXP value = Rf_getAttrib(object, name);
-  if (value != R_NilValue) {
-    // value was accessed as an attr, need to validate to make sure
-    // the attr is actually a known class property
-    *validate = TRUE;
-    return value;
-  }
-
-  SEXP S7_class_obj = Rf_getAttrib(object, Rf_install("S7_class"));
-  early_return_if_null(S7_class_obj);
-
-  SEXP properties = Rf_getAttrib(S7_class_obj, Rf_install("properties"));
-  early_return_if_null(properties);
-
-  SEXP S7_property_obj = extract_name(properties, CHAR(STRING_ELT(name, 0)));
-  early_return_if_null(S7_property_obj);
-
-  SEXP getter = extract_name(S7_property_obj, "getter");
-  early_return_if_null(getter);
-
-  if (TYPEOF(getter) == CLOSXP)
-    value = Rf_eval(Rf_lang2(getter, object), R_GlobalEnv);
-  else
-    *validate = TRUE;
-
-  return value;
-}
-#undef early_return_if_null
-
-SEXP prop_(SEXP object, SEXP name) {
-  Rboolean validate = FALSE;
-  SEXP value = prop_val_(object, name, &validate);
-  if (validate == FALSE)
-    return value;
-
-  PROTECT(value);
-  static SEXP ns = NULL;
-  if(ns == NULL)
-    ns = Rf_findVarInFrame(R_NamespaceRegistry, Rf_install("S7"));
-
-  static SEXP validate_prop_access = NULL;
-  if(validate_prop_access == NULL)
-    validate_prop_access = Rf_findVarInFrame(ns, Rf_install("validate_prop_access"));
-
-
-  Rf_eval(Rf_lang3(validate_prop_access, object, name), ns);
-  UNPROTECT(1);
-  return value;
-}
diff --git a/src/prop.c b/src/prop.c
new file mode 100644
index 00000000..cc61a50a
--- /dev/null
+++ b/src/prop.c
@@ -0,0 +1,128 @@
+#define R_NO_REMAP
+#include <R.h>
+#include <Rinternals.h>
+
+extern SEXP sym_S7_class;
+
+extern SEXP sym_name;
+extern SEXP sym_parent;
+extern SEXP sym_package;
+extern SEXP sym_properties;
+extern SEXP sym_abstract;
+extern SEXP sym_constructor;
+extern SEXP sym_validator;
+
+extern SEXP ns_S7;
+
+static inline
+int name_idx(SEXP list, const char* name) {
+  SEXP names = Rf_getAttrib(list, R_NamesSymbol);
+
+  if (TYPEOF(names) == STRSXP)
+    for (int i = 0, n = Rf_length(names); i < n; i++)
+      if (strcmp(CHAR(STRING_ELT(names, i)), name) == 0)
+        return i;
+  return -1;
+}
+
+static inline
+SEXP extract_name(SEXP list, const char* name) {
+  int i = name_idx(list, name);
+  return i == -1 ? R_NilValue : VECTOR_ELT(list, i);
+}
+
+static inline
+Rboolean has_name(SEXP list, const char* name) {
+  return (Rboolean) name_idx(list, name) != -1;
+}
+
+static inline
+Rboolean inherits2(SEXP object, const char* name) {
+  // like inherits in R, but iterates over the class STRSXP vector
+  // in reverse, since S7_* is typically at the tail.
+  SEXP klass = Rf_getAttrib(object, R_ClassSymbol);
+  if (TYPEOF(klass) == STRSXP) {
+    for (int i = Rf_length(klass)-1; i >= 0; i--) {
+      if (strcmp(CHAR(STRING_ELT(klass, i)), name) == 0)
+        return TRUE;
+    }
+  }
+  return FALSE;
+}
+
+inline static
+Rboolean is_s7_object(SEXP object) {
+  return inherits2(object, "S7_object");
+}
+
+inline static
+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);
+}
+
+SEXP prop_(SEXP object, SEXP name) {
+
+  if (!is_s7_object(object))
+    goto error;
+
+  SEXP name_rchar = STRING_ELT(name, 0);
+  const char* name_char = CHAR(name_rchar);
+  SEXP name_sym = Rf_installTrChar(name_rchar);
+
+  SEXP S7_class = Rf_getAttrib(object, sym_S7_class);
+  SEXP properties = Rf_getAttrib(S7_class, sym_properties);
+  SEXP value = Rf_getAttrib(object, name_sym);
+
+  // 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(has_name(properties, name_char))
+    return value;
+
+  if (S7_class == R_NilValue &&
+      is_s7_class(object) && (
+          name_sym == sym_name  ||
+          name_sym == sym_parent  ||
+          name_sym == sym_package  ||
+          name_sym == sym_properties  ||
+          name_sym == sym_abstract  ||
+          name_sym == sym_constructor  ||
+          name_sym == sym_validator
+    ))
+      return value;
+
+  error:
+
+  signal_prop_error_unknown_(object, name);
+  return R_NilValue; // unreachable, for compiler
+}

From 6ade85b8a69bfa5ba851ae301d9874f512fedd36 Mon Sep 17 00:00:00 2001
From: Tomasz Kalinowski <tomasz@posit.co>
Date: Mon, 18 Dec 2023 12:23:25 -0500
Subject: [PATCH 03/19] add failing test for `prop<-` infinite recusion

---
 tests/testthat/_snaps/property.md | 27 +++++++++++++++++++++++++++
 tests/testthat/test-property.R    | 26 ++++++++++++++++++++++++++
 2 files changed, 53 insertions(+)

diff --git a/tests/testthat/_snaps/property.md b/tests/testthat/_snaps/property.md
index 4f5ea5e7..198b948d 100644
--- a/tests/testthat/_snaps/property.md
+++ b/tests/testthat/_snaps/property.md
@@ -192,3 +192,30 @@
       ! <foo> 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"
+
diff --git a/tests/testthat/test-property.R b/tests/testthat/test-property.R
index 94bc983e..2c2f1b89 100644
--- a/tests/testthat/test-property.R
+++ b/tests/testthat/test-property.R
@@ -324,3 +324,29 @@ 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"
+  })
+})

From 2e6ca8e283fde2cfe045ac4ddc794e325ebde8af Mon Sep 17 00:00:00 2001
From: Tomasz Kalinowski <tomasz@posit.co>
Date: Mon, 18 Dec 2023 12:26:12 -0500
Subject: [PATCH 04/19] draft impl `prop<-` in C

---
 R/property.R |  13 +++-
 src/init.c   |   7 ++
 src/prop.c   | 194 +++++++++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 213 insertions(+), 1 deletion(-)

diff --git a/R/property.R b/R/property.R
index 361a577c..d24010a5 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, environment())
+}
+
+`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
 
@@ -247,6 +252,12 @@ prop_error_unknown <- function(object, prop_name) {
   sprintf("Can't find property %s@%s", obj_desc(object), prop_name)
 }
 
+signal_prop_error_read_only <- function(object, name) {
+  msg <- sprintf("Can't set read-only property %s@%s", obj_desc(object), name)
+  stop(msg, call. = FALSE)
+}
+
+
 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..009a9f4a 100644
--- a/src/init.c
+++ b/src/init.c
@@ -9,12 +9,16 @@ 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);
+extern SEXP prop_setters_stack_pop_();
 
 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_, 5},
+    {"prop_setters_stack_pop_", (DL_FUNC) &prop_setters_stack_pop_, 0},
     {NULL, NULL, 0}
 };
 
@@ -30,6 +34,8 @@ SEXP sym_constructor;
 SEXP sym_validator;
 SEXP sym_getter;
 
+SEXP sym_dot_should_validate;
+
 SEXP ns_S7;
 
 
@@ -48,6 +54,7 @@ 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");
 
     ns_S7 = Rf_findVarInFrame(R_NamespaceRegistry, Rf_install("S7"));
 
diff --git a/src/prop.c b/src/prop.c
index cc61a50a..e9a30f56 100644
--- a/src/prop.c
+++ b/src/prop.c
@@ -13,6 +13,7 @@ extern SEXP sym_constructor;
 extern SEXP sym_validator;
 
 extern SEXP ns_S7;
+extern SEXP sym_dot_should_validate;
 
 static inline
 int name_idx(SEXP list, const char* name) {
@@ -126,3 +127,196 @@ SEXP prop_(SEXP object, SEXP name) {
   signal_prop_error_unknown_(object, name);
   return R_NilValue; // unreachable, for compiler
 }
+
+static inline
+void check_is_S7_(SEXP object) {
+  if (is_s7_object(object))
+    return;
+
+  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);
+}
+
+__attribute__ ((noreturn))
+void signal_prop_error_read_only(SEXP object, SEXP name) {
+  static SEXP fn = NULL;
+  if (fn == NULL)
+    fn = Rf_findVarInFrame(ns_S7, Rf_install("signal_prop_error_read_only"));
+
+  Rf_eval(Rf_lang3(fn, object, name), ns_S7);
+  while(1);
+}
+
+
+// maintain a stack of property setters being called,
+// to make sure that property setters don't call themselves
+// recursively via `prop<-`().
+static SEXP setters_stack = NULL;
+
+static inline
+void prop_setters_stack_push(SEXP name_sym, SEXP setter) {
+  if (setters_stack == NULL) {
+    setters_stack = Rf_cons(R_NilValue, R_NilValue);
+    R_PreserveObject(setters_stack);
+  }
+
+  // SEXP cell = Rf_cons( R_body_no_src(setter), CDR(setters_stack));
+  SEXP cell = Rf_cons(setter, CDR(setters_stack));
+  SETCDR(setters_stack, cell);
+  SET_TAG(cell, name_sym);
+}
+
+// registered w/ on.exit() on prop<-() eval frame.
+SEXP prop_setters_stack_pop_() {
+  SETCDR(setters_stack, CDDR(setters_stack));
+  return R_NilValue;
+}
+
+static inline
+Rboolean prop_setters_stack_contains(SEXP name_sym, SEXP setter) {
+  if(setters_stack == NULL) return FALSE;
+
+  static int flags = 0 |
+    IDENT_USE_BYTECODE |
+    IDENT_USE_CLOENV |
+    // IDENT_USE_SRCREF |
+    IDENT_ATTR_BY_ORDER ;
+
+  for (SEXP c = CDR(setters_stack); c != R_NilValue; c = CDR(c)) {
+    if (TAG(c) == name_sym &&
+        R_compute_identical(CAR(c), setter, flags)) {
+      return TRUE;
+    }
+  }
+  return FALSE;
+}
+
+
+static inline
+SEXP call_setter(SEXP name_sym, SEXP setter, SEXP object, SEXP value, SEXP frame) {
+  // make sure we don't infinitely recursively call the same setter if `prop<-`()
+  // is called from within a setter.
+  prop_setters_stack_push(name_sym, setter);
+  static SEXP register_on_exit_pop = NULL;
+  if (register_on_exit_pop == NULL) {
+    register_on_exit_pop = R_ParseString(
+      "on.exit(.Call(prop_setters_stack_pop_), add = TRUE)"
+    );
+    R_PreserveObject(register_on_exit_pop);
+  }
+
+  Rf_eval(register_on_exit_pop, frame);
+  return Rf_eval(Rf_lang3(setter, object, value), ns_S7);
+}
+
+static inline
+Rboolean prop_setter_stack_is_empty() {
+  return (Rboolean) (setters_stack == NULL || CDR(setters_stack) == R_NilValue);
+}
+
+SEXP prop_set_(SEXP object, SEXP name, SEXP check_sexp, SEXP value, SEXP frame) {
+
+  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);
+
+  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_read_only(object, name);
+
+  if (TYPEOF(setter) == CLOSXP &&
+      !prop_setters_stack_contains(name_sym, setter)) {
+
+    // // alternative approach: effectively call `validate_eventially()` on custom setters,
+    // // to  avoid validating if we're calling a setter() from a setter().,
+    // // and only run validate() once from the topmost prop<- call
+    // // (this approach, like the current one, doesn't handle the edge case of a setter()
+    // // calling prop(not_self)<- )
+    //
+    // Rboolean is_toplevel_propset_call = prop_setter_stack_is_empty();
+    // SEXP old_dot_should_validate = NULL;
+    // if (is_toplevel_propset_call) {
+    //   old_dot_should_validate = Rf_getAttrib(object, sym_dot_should_validate);
+    //   Rf_setAttrib(object, old_dot_should_validate, Rf_ScalarLogical(FALSE));
+    //   // micro-optimization opportunity: getsetAttrib() that returns the "old" value
+    //   // it is replacing.
+    // } else {
+    //   check = FALSE;
+    // }
+
+    object = call_setter(name_sym, setter, object, value, frame);
+    PROTECT(object);
+    // if (is_toplevel_propset_call) {
+    //    Rf_setAttrib(object, sym_dot_should_validate, old_dot_should_validate);
+    // }
+
+    // Current snapshots / reference R implementation skips validation
+    // if prop<- invokes a custom property setter().
+    // That behavior seems inconsistent with the docs.
+    // Which is correct?
+    // Early return here to match the current reference `prop<-` def.
+    UNPROTECT(1);
+    return object;
+
+    PROTECT(object);
+
+  } else {
+
+    if (check) {
+      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) {
+        if (TYPEOF(errmsg) != STRSXP)
+          Rf_error("prop_validate() returned unknown value");
+        //// Maybe we shouldn't suppress the prop<- call here?
+        // Rf_error(CHAR(STRING_ELT(errmsg, 0)));
+        //// snapshot diff:
+        //// -       Error:
+        //// +       Error in `prop<-`:
+        Rf_errorcall(R_NilValue, CHAR(STRING_ELT(errmsg, 0)));
+      }
+    }
+
+    object = Rf_duplicate(object);
+    PROTECT(object);
+    Rf_setAttrib(object, name_sym, value);
+  }
+
+  // see comment above about validation w/ custom setters()
+  // currently, validation is skipped w/ custom setters().
+  // This line makes the C impl match the current snapshot, but probably
+  // merits some discussion...
+  check = check && prop_setter_stack_is_empty();
+
+  if (check) {
+    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);
+  }
+  UNPROTECT(1);
+  return object;
+}

From 3a658fd7c13aeed876bd9ed164bd049e88455e21 Mon Sep 17 00:00:00 2001
From: Tomasz Kalinowski <tomasz@posit.co>
Date: Mon, 18 Dec 2023 18:03:02 -0500
Subject: [PATCH 05/19] alternate approach to avoid infinite recursion in
 `prop<-`

---
 src/init.c                        |   8 +-
 src/prop.c                        | 129 +++++++-----------------------
 tests/testthat/_snaps/property.md |   2 +
 3 files changed, 34 insertions(+), 105 deletions(-)

diff --git a/src/init.c b/src/init.c
index 009a9f4a..96ca68b1 100644
--- a/src/init.c
+++ b/src/init.c
@@ -18,7 +18,6 @@ static const R_CallMethodDef CallEntries[] = {
     {"S7_object_", (DL_FUNC) &S7_object_, 0},
     {"prop_", (DL_FUNC) &prop_, 2},
     {"prop_set_", (DL_FUNC) &prop_set_, 5},
-    {"prop_setters_stack_pop_", (DL_FUNC) &prop_setters_stack_pop_, 0},
     {NULL, NULL, 0}
 };
 
@@ -35,6 +34,7 @@ SEXP sym_validator;
 SEXP sym_getter;
 
 SEXP sym_dot_should_validate;
+SEXP sym_dot_setting_prop;
 
 SEXP ns_S7;
 
@@ -55,11 +55,7 @@ void R_init_S7(DllInfo *dll)
     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 e9a30f56..17854dae 100644
--- a/src/prop.c
+++ b/src/prop.c
@@ -14,6 +14,7 @@ extern SEXP sym_validator;
 
 extern SEXP ns_S7;
 extern SEXP sym_dot_should_validate;
+extern SEXP sym_dot_setting_prop;
 
 static inline
 int name_idx(SEXP list, const char* name) {
@@ -152,71 +153,41 @@ void signal_prop_error_read_only(SEXP object, SEXP name) {
 }
 
 
-// maintain a stack of property setters being called,
-// to make sure that property setters don't call themselves
-// recursively via `prop<-`().
-static SEXP setters_stack = NULL;
 
 static inline
-void prop_setters_stack_push(SEXP name_sym, SEXP setter) {
-  if (setters_stack == NULL) {
-    setters_stack = Rf_cons(R_NilValue, R_NilValue);
-    R_PreserveObject(setters_stack);
-  }
+SEXP call_setter(SEXP name_sym, SEXP setter, SEXP object, SEXP value, SEXP frame) {
 
-  // SEXP cell = Rf_cons( R_body_no_src(setter), CDR(setters_stack));
-  SEXP cell = Rf_cons(setter, CDR(setters_stack));
-  SETCDR(setters_stack, cell);
-  SET_TAG(cell, name_sym);
-}
+  // micro-optimization opportunity: getsetAttrib() that returns the "old" value
+  // it is replacing.
+  SEXP setting = Rf_getAttrib(object, sym_dot_setting_prop);
+  Rf_setAttrib(object, sym_dot_setting_prop, Rf_cons(name_sym, setting));
 
-// registered w/ on.exit() on prop<-() eval frame.
-SEXP prop_setters_stack_pop_() {
-  SETCDR(setters_stack, CDDR(setters_stack));
-  return R_NilValue;
-}
+  SEXP should_validate = Rf_getAttrib(object, sym_dot_should_validate);
+  Rf_setAttrib(object, sym_dot_should_validate, Rf_ScalarLogical(FALSE));
 
-static inline
-Rboolean prop_setters_stack_contains(SEXP name_sym, SEXP setter) {
-  if(setters_stack == NULL) return FALSE;
-
-  static int flags = 0 |
-    IDENT_USE_BYTECODE |
-    IDENT_USE_CLOENV |
-    // IDENT_USE_SRCREF |
-    IDENT_ATTR_BY_ORDER ;
-
-  for (SEXP c = CDR(setters_stack); c != R_NilValue; c = CDR(c)) {
-    if (TAG(c) == name_sym &&
-        R_compute_identical(CAR(c), setter, flags)) {
-      return TRUE;
-    }
-  }
-  return FALSE;
+  object = Rf_eval(Rf_lang3(setter, object, value), ns_S7);
+  PROTECT(object);
+
+  Rf_setAttrib(object, sym_dot_setting_prop, setting);
+  Rf_setAttrib(object, sym_dot_should_validate, should_validate);
+  UNPROTECT(1);
+  return object;
 }
 
 
 static inline
-SEXP call_setter(SEXP name_sym, SEXP setter, SEXP object, SEXP value, SEXP frame) {
-  // make sure we don't infinitely recursively call the same setter if `prop<-`()
-  // is called from within a setter.
-  prop_setters_stack_push(name_sym, setter);
-  static SEXP register_on_exit_pop = NULL;
-  if (register_on_exit_pop == NULL) {
-    register_on_exit_pop = R_ParseString(
-      "on.exit(.Call(prop_setters_stack_pop_), add = TRUE)"
-    );
-    R_PreserveObject(register_on_exit_pop);
-  }
-
-  Rf_eval(register_on_exit_pop, frame);
-  return Rf_eval(Rf_lang3(setter, object, value), ns_S7);
+Rboolean can_call_setter(SEXP object, SEXP name_sym) {
+  SEXP setting = Rf_getAttrib(object, sym_dot_setting_prop);
+  if (setting == R_NilValue)
+    return TRUE;
+  // if (setting == name_sym)
+  //   return FALSE;
+  for (SEXP c = setting; c != R_NilValue; c = CDR(c))
+    if (CAR(c) == name_sym)
+      return FALSE;
+  return TRUE;
 }
 
-static inline
-Rboolean prop_setter_stack_is_empty() {
-  return (Rboolean) (setters_stack == NULL || CDR(setters_stack) == R_NilValue);
-}
 
 SEXP prop_set_(SEXP object, SEXP name, SEXP check_sexp, SEXP value, SEXP frame) {
 
@@ -241,42 +212,10 @@ SEXP prop_set_(SEXP object, SEXP name, SEXP check_sexp, SEXP value, SEXP frame)
   if(getter != R_NilValue && setter == R_NilValue)
     signal_prop_error_read_only(object, name);
 
-  if (TYPEOF(setter) == CLOSXP &&
-      !prop_setters_stack_contains(name_sym, setter)) {
-
-    // // alternative approach: effectively call `validate_eventially()` on custom setters,
-    // // to  avoid validating if we're calling a setter() from a setter().,
-    // // and only run validate() once from the topmost prop<- call
-    // // (this approach, like the current one, doesn't handle the edge case of a setter()
-    // // calling prop(not_self)<- )
-    //
-    // Rboolean is_toplevel_propset_call = prop_setter_stack_is_empty();
-    // SEXP old_dot_should_validate = NULL;
-    // if (is_toplevel_propset_call) {
-    //   old_dot_should_validate = Rf_getAttrib(object, sym_dot_should_validate);
-    //   Rf_setAttrib(object, old_dot_should_validate, Rf_ScalarLogical(FALSE));
-    //   // micro-optimization opportunity: getsetAttrib() that returns the "old" value
-    //   // it is replacing.
-    // } else {
-    //   check = FALSE;
-    // }
-
+  if (TYPEOF(setter) == CLOSXP && can_call_setter(object, name_sym)) {
     object = call_setter(name_sym, setter, object, value, frame);
+    // return object;
     PROTECT(object);
-    // if (is_toplevel_propset_call) {
-    //    Rf_setAttrib(object, sym_dot_should_validate, old_dot_should_validate);
-    // }
-
-    // Current snapshots / reference R implementation skips validation
-    // if prop<- invokes a custom property setter().
-    // That behavior seems inconsistent with the docs.
-    // Which is correct?
-    // Early return here to match the current reference `prop<-` def.
-    UNPROTECT(1);
-    return object;
-
-    PROTECT(object);
-
   } else {
 
     if (check) {
@@ -285,13 +224,8 @@ SEXP prop_set_(SEXP object, SEXP name, SEXP check_sexp, SEXP value, SEXP frame)
         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) {
-        if (TYPEOF(errmsg) != STRSXP)
+        if (TYPEOF(errmsg) != STRSXP || Rf_length(errmsg) != 1)
           Rf_error("prop_validate() returned unknown value");
-        //// Maybe we shouldn't suppress the prop<- call here?
-        // Rf_error(CHAR(STRING_ELT(errmsg, 0)));
-        //// snapshot diff:
-        //// -       Error:
-        //// +       Error in `prop<-`:
         Rf_errorcall(R_NilValue, CHAR(STRING_ELT(errmsg, 0)));
       }
     }
@@ -301,11 +235,8 @@ SEXP prop_set_(SEXP object, SEXP name, SEXP check_sexp, SEXP value, SEXP frame)
     Rf_setAttrib(object, name_sym, value);
   }
 
-  // see comment above about validation w/ custom setters()
-  // currently, validation is skipped w/ custom setters().
-  // This line makes the C impl match the current snapshot, but probably
-  // merits some discussion...
-  check = check && prop_setter_stack_is_empty();
+  if(Rf_getAttrib(object, sym_dot_should_validate) != R_NilValue)
+    check = FALSE;
 
   if (check) {
     static SEXP validate = NULL;
diff --git a/tests/testthat/_snaps/property.md b/tests/testthat/_snaps/property.md
index 198b948d..327a2014 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
 

From ea9adf9af9cad5454f76f97ebbe18a69c2328864 Mon Sep 17 00:00:00 2001
From: Tomasz Kalinowski <tomasz@posit.co>
Date: Tue, 19 Dec 2023 09:28:03 -0500
Subject: [PATCH 06/19] refactor+tidy C fn prop_set_

---
 R/property.R |  18 +++-
 src/init.c   |   2 +-
 src/prop.c   | 266 +++++++++++++++++++++++++++++----------------------
 3 files changed, 166 insertions(+), 120 deletions(-)

diff --git a/R/property.R b/R/property.R
index d24010a5..4d5b33c2 100644
--- a/R/property.R
+++ b/R/property.R
@@ -204,7 +204,7 @@ prop_obj <- function(object, name) {
 #'   [validate()] on the object before returning.
 #' @export
 `prop<-` <- function(object, name, check = TRUE, value) {
-  .Call(prop_set_, object, name, check, value, environment())
+  .Call(prop_set_, object, name, check, value)
 }
 
 `propr<-` <- local({
@@ -248,16 +248,24 @@ prop_obj <- function(object, name) {
   }
 })
 
-prop_error_unknown <- function(object, prop_name) {
-  sprintf("Can't find property %s@%s", obj_desc(object), prop_name)
+# called from src/prop.c
+signal_prop_error <- function(fmt, object, name) {
+  msg <- sprintf(fmt, obj_desc(object), name)
+  stop(msg, call. = FALSE)
 }
 
-signal_prop_error_read_only <- function(object, name) {
-  msg <- sprintf("Can't set read-only property %s@%s", obj_desc(object), name)
+# 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",
diff --git a/src/init.c b/src/init.c
index c574e867..2e790b33 100644
--- a/src/init.c
+++ b/src/init.c
@@ -16,7 +16,7 @@ static const R_CallMethodDef CallEntries[] = {
     {"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_, 5},
+    {"prop_set_", (DL_FUNC) &prop_set_, 4},
     {NULL, NULL, 0}
 };
 
diff --git a/src/prop.c b/src/prop.c
index 92eb56f2..dad19ae3 100644
--- a/src/prop.c
+++ b/src/prop.c
@@ -36,7 +36,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
@@ -63,25 +63,60 @@ 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"));
+static inline
+void check_is_S7(SEXP object) {
+  if (is_s7_object(object))
+    return;
+
+  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);
+}
+
+__attribute__((noreturn))
+void signal_error(SEXP errmsg) {
+/*  Given a STRSXP, we go back out to an R closure to signal an error. We can't use
+    Rf_error() because, from the compilers perspective, `errmsg` isn't
+    sanitized for '%'--it could be interperted as a format string. Compiler says:
+    warning: format not a string literal and no format arguments [-Wformat-security]
+
+    // Doing something like this segfaults for reasons I don't understand:
+    Rf_eval(Rf_lang2(Rf_findVarInFrame(Rf_install("stop"), R_BaseNamespace),
+                     errmsg), frame);
+*/
+  PROTECT(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);
+}
+
+__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_lang3(signal_prop_error_unknown, object, name), ns_S7);
+  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);
+}
+
 SEXP prop_(SEXP object, SEXP name) {
 
-  if (!is_s7_object(object))
-    goto error;
+  check_is_S7(object);
 
   SEXP name_rchar = STRING_ELT(name, 0);
-  const char* name_char = CHAR(name_rchar);
+  const char *name_char = CHAR(name_rchar);
   SEXP name_sym = Rf_installTrChar(name_rchar);
 
   SEXP S7_class = Rf_getAttrib(object, sym_S7_class);
@@ -90,26 +125,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 &&
@@ -120,135 +145,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
-void check_is_S7_(SEXP object) {
-  if (is_s7_object(object))
-    return;
 
-  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);
+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;
 }
 
-__attribute__ ((noreturn))
-void signal_prop_error_read_only(SEXP object, SEXP name) {
-  static SEXP fn = NULL;
-  if (fn == NULL)
-    fn = Rf_findVarInFrame(ns_S7, Rf_install("signal_prop_error_read_only"));
+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_eval(Rf_lang3(fn, object, name), ns_S7);
-  while(1);
+  Rf_warning("Tried to remove non-existent element from pairlist");
+  return R_NilValue;
 }
 
 
-
 static inline
-SEXP call_setter(SEXP name_sym, SEXP setter, SEXP object, SEXP value, SEXP frame) {
-
-  // micro-optimization opportunity: getsetAttrib() that returns the "old" value
-  // it is replacing.
-  SEXP setting = Rf_getAttrib(object, sym_dot_setting_prop);
-  Rf_setAttrib(object, sym_dot_setting_prop, Rf_cons(name_sym, setting));
+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 custom property
+      // setter. We should only call validate(object) once from the top-most
+      // prop<- call, after the custom setter() has returned.
+      *should_validate_obj = FALSE;
+      if (pairlist_contains(no_recurse_list, name_sym))
+        return FALSE;
+    }
 
-  SEXP should_validate = Rf_getAttrib(object, sym_dot_should_validate);
-  Rf_setAttrib(object, sym_dot_should_validate, Rf_ScalarLogical(FALSE));
+    if (TYPEOF(setter) != CLOSXP)
+      return FALSE; // setter not callable
 
-  object = Rf_eval(Rf_lang3(setter, object, value), ns_S7);
-  PROTECT(object);
+    Rf_setAttrib(object, sym_dot_setting_prop,
+                 Rf_cons(name_sym, no_recurse_list));
+    return TRUE; // setter now marked non-recursive, safe to call
 
-  Rf_setAttrib(object, sym_dot_setting_prop, setting);
-  Rf_setAttrib(object, sym_dot_should_validate, should_validate);
-  UNPROTECT(1);
-  return object;
+  // 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
-Rboolean can_call_setter(SEXP object, SEXP name_sym) {
-  SEXP setting = Rf_getAttrib(object, sym_dot_setting_prop);
-  if (setting == R_NilValue)
-    return TRUE;
-  // if (setting == name_sym)
-  //   return FALSE;
-  for (SEXP c = setting; c != R_NilValue; c = CDR(c))
-    if (CAR(c) == name_sym)
-      return FALSE;
-  return TRUE;
+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, SEXP frame) {
+SEXP prop_set_(SEXP object, SEXP name, SEXP check_sexp, SEXP value) {
 
-  check_is_S7_(object);
+  check_is_S7(object);
 
   SEXP name_rchar = STRING_ELT(name, 0);
-  const char* name_char = CHAR(name_rchar);
+  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);
+    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_read_only(object, name);
+  if (getter != R_NilValue && setter == R_NilValue)
+    signal_prop_error("Can't set read-only property %s@%s", object, name);
 
-  if (TYPEOF(setter) == CLOSXP && can_call_setter(object, name_sym)) {
-    object = call_setter(name_sym, setter, object, value, frame);
-    // return object;
-    PROTECT(object);
-  } else {
-
-    if (check) {
-      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) {
-        if (TYPEOF(errmsg) != STRSXP || Rf_length(errmsg) != 1)
-          Rf_error("prop_validate() returned unknown value");
-        Rf_errorcall(R_NilValue, CHAR(STRING_ELT(errmsg, 0)));
-      }
-    }
+  PROTECT_INDEX ipx;
+  object = Rf_duplicate(object);
+  PROTECT_WITH_INDEX(object, &ipx);
 
-    object = Rf_duplicate(object);
-    PROTECT(object);
+  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(Rf_getAttrib(object, sym_dot_should_validate) != R_NilValue)
-    check = FALSE;
-
-  if (check) {
-    static SEXP validate = NULL;
-    if (validate == NULL)
-      validate = Rf_findVarInFrame(ns_S7, Rf_install("validate"));
+  if (should_validate_obj)
+    obj_validate(object);
 
-    Rf_eval(Rf_lang4(validate, object,
-                     /* recursive = */ Rf_ScalarLogical(TRUE),
-                     /* properties =*/ Rf_ScalarLogical(FALSE)),
-            ns_S7);
-  }
   UNPROTECT(1);
   return object;
 }

From 05838be58d886e5a31e1a7aa5c6a98da82e17b3a Mon Sep 17 00:00:00 2001
From: Tomasz Kalinowski <tomasz@posit.co>
Date: Tue, 19 Dec 2023 09:46:52 -0500
Subject: [PATCH 07/19] use `__attribute__((noreturn))` where appropriate

It has a measurable impact on `prop()` benchmarks.
---
 src/prop.c | 101 ++++++++++++++++++++++++++++-------------------------
 1 file changed, 54 insertions(+), 47 deletions(-)

diff --git a/src/prop.c b/src/prop.c
index dad19ae3..2f09ba10 100644
--- a/src/prop.c
+++ b/src/prop.c
@@ -17,6 +17,55 @@ 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) {
+  /*  Given a STRSXP errmsg, we go back out to an R closure to signal the error.
+   *  We can't use Rf_error() because, from the compilers perspective, `errmsg`
+   *  isn't sanitized for '%'--it could be interpreted as a format string.
+   *  Compiler says:
+   *  warning: format not a string literal and no format arguments [-Wformat-security]
+
+   *  Doing something like this segfaults for reasons I don't understand:
+     Rf_eval(Rf_lang2(Rf_findVarInFrame(Rf_install("stop"), R_BaseNamespace),
+                      errmsg), frame);
+   */
+  PROTECT(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);
@@ -53,12 +102,12 @@ 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");
 }
@@ -67,56 +116,15 @@ static inline
 void check_is_S7(SEXP object) {
   if (is_s7_object(object))
     return;
-
-  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);
+  signal_is_not_S7(object);
 }
 
-__attribute__((noreturn))
-void signal_error(SEXP errmsg) {
-/*  Given a STRSXP, we go back out to an R closure to signal an error. We can't use
-    Rf_error() because, from the compilers perspective, `errmsg` isn't
-    sanitized for '%'--it could be interperted as a format string. Compiler says:
-    warning: format not a string literal and no format arguments [-Wformat-security]
-
-    // Doing something like this segfaults for reasons I don't understand:
-    Rf_eval(Rf_lang2(Rf_findVarInFrame(Rf_install("stop"), R_BaseNamespace),
-                     errmsg), frame);
-*/
-  PROTECT(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);
-}
-
-__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);
-}
 
 SEXP prop_(SEXP object, SEXP name) {
-
   check_is_S7(object);
 
   SEXP name_rchar = STRING_ELT(name, 0);
-  const char *name_char = CHAR(name_rchar);
+  const char* name_char = CHAR(name_rchar);
   SEXP name_sym = Rf_installTrChar(name_rchar);
 
   SEXP S7_class = Rf_getAttrib(object, sym_S7_class);
@@ -184,7 +192,6 @@ SEXP pairlist_remove(SEXP list, SEXP elem) {
   return R_NilValue;
 }
 
-
 static inline
 Rboolean setter_callable_no_recurse(SEXP setter, SEXP object, SEXP name_sym,
                                     Rboolean* should_validate_obj) {
@@ -211,7 +218,7 @@ Rboolean setter_callable_no_recurse(SEXP setter, SEXP object, SEXP name_sym,
   // into one loop, so we can avoid iterating over ATTRIB(object) twice.
 }
 
-// static inline
+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);

From a1df08bc9e0b3ca86bf77d102efabf2d12c8ec5c Mon Sep 17 00:00:00 2001
From: Tomasz Kalinowski <tomasz@posit.co>
Date: Tue, 19 Dec 2023 10:18:43 -0500
Subject: [PATCH 08/19] `prop<-`:  `Rf_shallow_duplicate()` instead of
 `Rf_duplicate()`

---
 src/prop.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/prop.c b/src/prop.c
index 2f09ba10..52de4993 100644
--- a/src/prop.c
+++ b/src/prop.c
@@ -276,7 +276,7 @@ SEXP prop_set_(SEXP object, SEXP name, SEXP check_sexp, SEXP value) {
     signal_prop_error("Can't set read-only property %s@%s", object, name);
 
   PROTECT_INDEX ipx;
-  object = Rf_duplicate(object);
+  object = Rf_shallow_duplicate(object);
   PROTECT_WITH_INDEX(object, &ipx);
 
   if (setter_callable_no_recurse(setter, object, name_sym, &should_validate_obj)) {

From b8f73b3f830c600441b73afdf19e8ef9c7302192 Mon Sep 17 00:00:00 2001
From: Tomasz Kalinowski <tomasz@posit.co>
Date: Tue, 19 Dec 2023 10:51:27 -0500
Subject: [PATCH 09/19] fix compiler warning better

---
 src/prop.c | 14 ++++----------
 1 file changed, 4 insertions(+), 10 deletions(-)

diff --git a/src/prop.c b/src/prop.c
index 52de4993..ce4b9ef4 100644
--- a/src/prop.c
+++ b/src/prop.c
@@ -47,17 +47,11 @@ void signal_prop_error_unknown(SEXP object, SEXP name) {
 
 static __attribute__((noreturn))
 void signal_error(SEXP errmsg) {
-  /*  Given a STRSXP errmsg, we go back out to an R closure to signal the error.
-   *  We can't use Rf_error() because, from the compilers perspective, `errmsg`
-   *  isn't sanitized for '%'--it could be interpreted as a format string.
-   *  Compiler says:
-   *  warning: format not a string literal and no format arguments [-Wformat-security]
-
-   *  Doing something like this segfaults for reasons I don't understand:
-     Rf_eval(Rf_lang2(Rf_findVarInFrame(Rf_install("stop"), R_BaseNamespace),
-                      errmsg), frame);
-   */
   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"));

From f5e297c19774954984b1eed382465057bb6d3c49 Mon Sep 17 00:00:00 2001
From: Tomasz Kalinowski <tomasz@posit.co>
Date: Tue, 19 Dec 2023 11:45:04 -0500
Subject: [PATCH 10/19] add `prop<-` test invoking same-name non-self prop
 setters.

---
 src/prop.c                        |  7 ++++---
 tests/testthat/_snaps/property.md | 35 +++++++++++++++++++++++++++++++
 tests/testthat/test-property.R    | 35 +++++++++++++++++++++++++++++++
 3 files changed, 74 insertions(+), 3 deletions(-)

diff --git a/src/prop.c b/src/prop.c
index ce4b9ef4..1b7b8fa0 100644
--- a/src/prop.c
+++ b/src/prop.c
@@ -193,9 +193,10 @@ Rboolean setter_callable_no_recurse(SEXP setter, SEXP object, SEXP name_sym,
     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 custom property
-      // setter. We should only call validate(object) once from the top-most
-      // prop<- call, after the custom setter() has returned.
+      // 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;
diff --git a/tests/testthat/_snaps/property.md b/tests/testthat/_snaps/property.md
index 327a2014..6ebc6052 100644
--- a/tests/testthat/_snaps/property.md
+++ b/tests/testthat/_snaps/property.md
@@ -221,3 +221,38 @@
       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 2c2f1b89..f6420fc3 100644
--- a/tests/testthat/test-property.R
+++ b/tests/testthat/test-property.R
@@ -350,3 +350,38 @@ test_that("prop<- won't infinitly recurse on a custom setter", {
     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")
+  })
+
+})

From 51a0706efaa559d1e6bef230f885739302e134e3 Mon Sep 17 00:00:00 2001
From: Tomasz Kalinowski <tomasz@posit.co>
Date: Fri, 16 Feb 2024 11:31:27 -0500
Subject: [PATCH 11/19] add `PROTECT()`s

---
 src/prop.c | 87 +++++++++++++++++++++++++++++-------------------------
 1 file changed, 47 insertions(+), 40 deletions(-)

diff --git a/src/prop.c b/src/prop.c
index 1b7b8fa0..6b255a4f 100644
--- a/src/prop.c
+++ b/src/prop.c
@@ -17,48 +17,55 @@ 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
-  Rf_eval(Rf_lang2(check_is_S7, object), ns_S7);
-  while(1);
-}
+  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"));
+  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);
-}
+    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);
-}
+  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);
-}
+  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) {
@@ -68,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
@@ -133,7 +140,7 @@ SEXP prop_(SEXP object, SEXP name) {
     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);
+        return eval_here(Rf_lang2(getter, object));
   }
 
   if (has_name(properties, name_char))
@@ -229,7 +236,7 @@ void prop_validate(SEXP property, SEXP value, SEXP object) {
   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);
+  SEXP errmsg = eval_here(Rf_lang4(prop_validate, property, value, object));
   if (errmsg != R_NilValue) signal_error(errmsg);
 }
 
@@ -239,10 +246,10 @@ void obj_validate(SEXP object) {
   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);
+  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) {
@@ -276,7 +283,7 @@ SEXP prop_set_(SEXP object, SEXP name, SEXP check_sexp, SEXP value) {
 
   if (setter_callable_no_recurse(setter, object, name_sym, &should_validate_obj)) {
     // use setter()
-    object = Rf_eval(Rf_lang3(setter, object, value), ns_S7);
+    object = eval_here(Rf_lang3(setter, object, value));
     REPROTECT(object, ipx);
     setter_no_recurse_clear(object, name_sym);
   } else {

From a7da906d5d281032d2e9a6302ca398ac9e7f5db8 Mon Sep 17 00:00:00 2001
From: Tomasz Kalinowski <tomasz@posit.co>
Date: Fri, 16 Feb 2024 11:50:25 -0500
Subject: [PATCH 12/19] add comments

---
 R/inherits.R | 1 +
 R/property.R | 2 +-
 2 files changed, 2 insertions(+), 1 deletion(-)

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 4d5b33c2..f337f810 100644
--- a/R/property.R
+++ b/R/property.R
@@ -265,7 +265,7 @@ prop_error_unknown <- function(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",

From 5c64ed2d721c31569c4ddcadea6e5b274d082c50 Mon Sep 17 00:00:00 2001
From: Tomasz Kalinowski <tomasz@posit.co>
Date: Fri, 16 Feb 2024 12:01:25 -0500
Subject: [PATCH 13/19] whitespace

---
 src/prop.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/prop.c b/src/prop.c
index 6b255a4f..09591e7c 100644
--- a/src/prop.c
+++ b/src/prop.c
@@ -154,7 +154,7 @@ 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;
 
   // Should the constructor always set default prop values on a object instance?

From e41ddcf2263922f316771447b07c4158ee031192 Mon Sep 17 00:00:00 2001
From: Tomasz Kalinowski <tomasz@posit.co>
Date: Fri, 16 Feb 2024 12:01:57 -0500
Subject: [PATCH 14/19] warning -> error

---
 src/prop.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/prop.c b/src/prop.c
index 09591e7c..da61dc3e 100644
--- a/src/prop.c
+++ b/src/prop.c
@@ -189,7 +189,7 @@ SEXP pairlist_remove(SEXP list, SEXP elem) {
       }
     }
 
-  Rf_warning("Tried to remove non-existent element from pairlist");
+  Rf_error("Tried to remove non-existent element from pairlist");
   return R_NilValue;
 }
 

From e8c77abee33d8bee9099388ca57f3fc9ae152d7d Mon Sep 17 00:00:00 2001
From: Tomasz Kalinowski <tomasz@posit.co>
Date: Fri, 16 Feb 2024 12:08:57 -0500
Subject: [PATCH 15/19] Update src/init.c

Co-authored-by: Davis Vaughan <davis@posit.co>
---
 src/init.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/init.c b/src/init.c
index 2e790b33..39f780ec 100644
--- a/src/init.c
+++ b/src/init.c
@@ -9,7 +9,7 @@ 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);
+extern SEXP prop_set_(SEXP, SEXP, SEXP, SEXP);
 
 static const R_CallMethodDef CallEntries[] = {
     {"method_", (DL_FUNC) &method_, 4},

From 2ed22c155191921f721bf6aa5563ba306d8bd6ae Mon Sep 17 00:00:00 2001
From: Tomasz Kalinowski <tomasz@posit.co>
Date: Fri, 16 Feb 2024 12:09:55 -0500
Subject: [PATCH 16/19] Apply suggestions from code review

Co-authored-by: Davis Vaughan <davis@posit.co>
---
 src/prop.c | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/src/prop.c b/src/prop.c
index da61dc3e..1176a815 100644
--- a/src/prop.c
+++ b/src/prop.c
@@ -277,9 +277,9 @@ SEXP prop_set_(SEXP object, SEXP name, SEXP check_sexp, SEXP value) {
   if (getter != R_NilValue && setter == R_NilValue)
     signal_prop_error("Can't set read-only property %s@%s", object, name);
 
-  PROTECT_INDEX ipx;
+  PROTECT_INDEX object_pi;
   object = Rf_shallow_duplicate(object);
-  PROTECT_WITH_INDEX(object, &ipx);
+  PROTECT_WITH_INDEX(object, &object_pi);
 
   if (setter_callable_no_recurse(setter, object, name_sym, &should_validate_obj)) {
     // use setter()

From 8feb24e9f8b7b7d34b8a296fa71d6f56f4010854 Mon Sep 17 00:00:00 2001
From: Tomasz Kalinowski <tomasz@posit.co>
Date: Fri, 16 Feb 2024 12:15:45 -0500
Subject: [PATCH 17/19] finish stray rename

---
 src/prop.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/prop.c b/src/prop.c
index 1176a815..cd70b808 100644
--- a/src/prop.c
+++ b/src/prop.c
@@ -284,7 +284,7 @@ SEXP prop_set_(SEXP object, SEXP name, SEXP check_sexp, SEXP value) {
   if (setter_callable_no_recurse(setter, object, name_sym, &should_validate_obj)) {
     // use setter()
     object = eval_here(Rf_lang3(setter, object, value));
-    REPROTECT(object, ipx);
+    REPROTECT(object, object_pi);
     setter_no_recurse_clear(object, name_sym);
   } else {
     // don't use setter()

From f6937296e3e57df0ab368856c756e66c77711a8c Mon Sep 17 00:00:00 2001
From: Tomasz Kalinowski <tomasz@posit.co>
Date: Tue, 11 Jun 2024 08:26:24 -0400
Subject: [PATCH 18/19] add comments

---
 src/prop.c | 71 ++++++++++++++++++++++++++++--------------------------
 1 file changed, 37 insertions(+), 34 deletions(-)

diff --git a/src/prop.c b/src/prop.c
index cd70b808..e393e46d 100644
--- a/src/prop.c
+++ b/src/prop.c
@@ -26,46 +26,46 @@ SEXP eval_here(SEXP lang) {
 }
 
 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);
-  }
+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"));
+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);
-  }
+  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);
-  }
+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);
-  }
+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) {
@@ -140,6 +140,7 @@ SEXP prop_(SEXP object, SEXP name) {
     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));
   }
 
@@ -196,6 +197,7 @@ SEXP pairlist_remove(SEXP list, SEXP elem) {
 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) {
@@ -278,13 +280,14 @@ SEXP prop_set_(SEXP object, SEXP name, SEXP check_sexp, SEXP value) {
     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()
-    object = eval_here(Rf_lang3(setter, object, value));
-    REPROTECT(object, object_pi);
+    REPROTECT(object = eval_here(Rf_lang3(setter, object, value)), object_pi);
     setter_no_recurse_clear(object, name_sym);
   } else {
     // don't use setter()

From ad6ab1ad258d3c357f79cfa2cbe3dcd438605c5a Mon Sep 17 00:00:00 2001
From: Tomasz Kalinowski <tomasz@posit.co>
Date: Wed, 12 Jun 2024 16:32:21 -0400
Subject: [PATCH 19/19] Add NEWS

---
 NEWS.md | 5 +++++
 1 file changed, 5 insertions(+)

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