Consider constructor hot paths

R/class-spec.R

@@ -59,30 +59,15 @@ is_foundation_class <- function(x) {
 }
 
 class_type <- function(x) {
-  if (is.null(x)) {
-    "NULL"
-  } else if (is_class_missing(x)) {
-    "missing"
-  } else if (is_class_any(x)) {
-    "any"
-  } else if (is_base_class(x)) {
-    "S7_base"
-  } else if (is_class(x)) {
-    "S7"
-  } else if (is_union(x)) {
-    "S7_union"
-  } else if (is_S3_class(x)) {
-    "S7_S3"
-  } else if (is_external_class(x)) {
-    "S7_external"
-  } else if (is_S4_class(x)) {
-    "S4"
-  } else {
-    stop2("`x` is not a standard S7 class.", call = NULL)
-  }
+  .Call(class_type_, x)
 }
 
 class_properties <- function(x) {
+  # Needed to bootstrap S7 before DLL registered
+  if (is.null(x)) {
+    return(list())
+  }
+
   switch(
     class_type(x),
     S7 = attr(x, "properties", exact = TRUE) %||% list(),
@@ -288,11 +273,12 @@ class_dispatch <- function(x) {
     missing = "MISSING",
     any = character(),
     S4 = S4_class_dispatch(methods::extends(x)),
-    S7 = c(
-      S7_class_name(x),
-      class_dispatch(x@parent),
-      if (is_S4_class(x@parent)) "S7_object"
-    ),
+    S7 = attr(x, "_S7_dispatch", exact = TRUE) %||%
+      c(
+        S7_class_name(x),
+        class_dispatch(x@parent),
+        if (is_S4_class(x@parent)) "S7_object"
+      ),
     S7_base = c(x$class, "S7_object"),
     S7_S3 = c(x$class, "S7_object"),
     S7_external = class_dispatch(resolve_external_class_req(x)),
@@ -342,13 +328,26 @@ class_deparse <- function(x) {
 }
 
 class_inherits <- function(x, what) {
+  if (is_class(what)) {
+    if (!has_S7_class(x)) {
+      return(FALSE)
+    } else {
+      dispatch <- attr(what, "_S7_dispatch", exact = TRUE)
+      class_name <- if (is.null(dispatch)) {
+        S7_class_name(what)
+      } else {
+        dispatch[[1]]
+      }
+      return(inherits(x, class_name))
+    }
+  }
+
   switch(
     class_type(what),
     "NULL" = is.null(x),
     missing = FALSE,
     any = TRUE,
     S4 = methods::is(x, what),
-    S7 = has_S7_class(x) && inherits(x, S7_class_name(what)),
     S7_base = what$class == base_class(x),
     S7_union = some(what$classes, class_inherits, x = x),
     S7_S3 = !isS4(x) && class_dispatch_extends(what$class, class(x)),

R/class.R

@@ -174,6 +174,16 @@ new_class <- function(
   attr(object, "constructor") <- constructor
   attr(object, "validator") <- validator
   class(object) <- c("S7_class", "S7_object")
+  if (identical(name, "S7_object")) {
+    dispatch <- "S7_object"
+  } else {
+    dispatch <- c(
+      paste(c(package, name), collapse = "::"),
+      class_dispatch(parent),
+      if (is_S4_class(parent)) "S7_object"
+    )
+  }
+  attr(object, "_S7_dispatch") <- dispatch
 
   if (S7_extends_S4(object)) {
     S4_register_subclass(object, env = parent.frame())

src/class-type.c

@@ -0,0 +1,91 @@
+#include "compat.h"
+
+static SEXP type_NULL;
+static SEXP type_missing;
+static SEXP type_any;
+static SEXP type_S7_base;
+static SEXP type_S7;
+static SEXP type_S7_union;
+static SEXP type_S7_S3;
+static SEXP type_S7_external;
+static SEXP type_S4;
+
+static SEXP class_missing;
+static SEXP class_any;
+static SEXP class_S7_base;
+static SEXP class_S7;
+static SEXP class_S7_union;
+static SEXP class_S7_S3;
+static SEXP class_S7_external;
+static SEXP class_S4;
+
+static SEXP preserve_string(const char* x) {
+  SEXP out = Rf_mkString(x);
+  R_PreserveObject(out);
+  return out;
+}
+
+void class_type_init(void) {
+  type_NULL = preserve_string("NULL");
+  type_missing = preserve_string("missing");
+  type_any = preserve_string("any");
+  type_S7_base = preserve_string("S7_base");
+  type_S7 = preserve_string("S7");
+  type_S7_union = preserve_string("S7_union");
+  type_S7_S3 = preserve_string("S7_S3");
+  type_S7_external = preserve_string("S7_external");
+  type_S4 = preserve_string("S4");
+
+  class_missing = PRINTNAME(Rf_install("S7_missing"));
+  class_any = PRINTNAME(Rf_install("S7_any"));
+  class_S7_base = PRINTNAME(Rf_install("S7_base_class"));
+  class_S7 = PRINTNAME(Rf_install("S7_class"));
+  class_S7_union = PRINTNAME(Rf_install("S7_union"));
+  class_S7_S3 = PRINTNAME(Rf_install("S7_S3_class"));
+  class_S7_external = PRINTNAME(Rf_install("S7_external_class"));
+  class_S4 = PRINTNAME(Rf_install("classRepresentation"));
+}
+
+SEXP class_type_(SEXP x) {
+  if (x == R_NilValue)
+    return type_NULL;
+
+  SEXP classes = Rf_getAttrib(x, R_ClassSymbol);
+  int type = 9;
+
+  if (TYPEOF(classes) == STRSXP) {
+    for (R_xlen_t i = 0; i < Rf_xlength(classes); ++i) {
+      SEXP cls = STRING_ELT(classes, i);
+
+      if (type > 1 && cls == class_missing)
+        type = 1;
+      else if (type > 2 && cls == class_any)
+        type = 2;
+      else if (type > 3 && cls == class_S7_base)
+        type = 3;
+      else if (type > 4 && cls == class_S7)
+        type = 4;
+      else if (type > 5 && cls == class_S7_union)
+        type = 5;
+      else if (type > 6 && cls == class_S7_S3)
+        type = 6;
+      else if (type > 7 && cls == class_S7_external)
+        type = 7;
+      else if (type > 8 && cls == class_S4)
+        type = 8;
+    }
+  }
+
+  switch (type) {
+  case 1: return type_missing;
+  case 2: return type_any;
+  case 3: return type_S7_base;
+  case 4: return type_S7;
+  case 5: return type_S7_union;
+  case 6: return type_S7_S3;
+  case 7: return type_S7_external;
+  case 8: return type_S4;
+  }
+
+  Rf_error("`x` is not a standard S7 class.");
+}

src/init.c

@@ -12,7 +12,9 @@ extern SEXP prop_(SEXP, SEXP);
 extern SEXP prop_set_(SEXP, SEXP, SEXP, SEXP);
 extern SEXP prop_storage_rename_(SEXP);
 extern SEXP S7_eval_bare_(SEXP, SEXP);
+extern SEXP class_type_(SEXP);
 extern void prop_init(void);
+extern void class_type_init(void);
 
 #define CALLDEF(name, n)  {#name, (DL_FUNC) &name, n}
 
@@ -24,6 +26,7 @@ static const R_CallMethodDef CallEntries[] = {
     CALLDEF(prop_set_, 4),
     CALLDEF(prop_storage_rename_, 1),
     CALLDEF(S7_eval_bare_, 2),
+    CALLDEF(class_type_, 1),
     {NULL, NULL, 0}
 };
 
@@ -133,6 +136,7 @@ void R_init_S7(DllInfo *dll)
     R_PreserveObject(R_TRUE = Rf_ScalarLogical(1));
     R_PreserveObject(R_FALSE = Rf_ScalarLogical(0));
     prop_init();
+    class_type_init();
     R_PreserveObject(s7_proto_object = make_s7_proto_object());
     R_PreserveObject(missing_call = Rf_lang2(fn_base_missing, R_NilValue));
 }

tests/testthat/_snaps/class-spec.md

@@ -1,3 +1,11 @@
+# class_type() recognizes special class specifications
+
+    Code
+      class_type(1)
+    Condition
+      Error in `class_type()`:
+      ! `x` is not a standard S7 class.
+
 # S7_class_desc() formats every supported class spec
 
     Code

tests/testthat/_snaps/class.md

@@ -304,3 +304,4 @@
     Condition
       Error:
       ! No S7 class for base type <pairlist>.
+

tests/testthat/test-class-spec.R

@@ -34,6 +34,54 @@ test_that("can work with S7 classes in packages", {
   expect_equal(class_inherits(obj, klass), TRUE)
 })
 
+test_that("S7 class dispatch is cached", {
+  parent := new_class(package = "pkg")
+  child := new_class(parent = parent, package = "pkg")
+  obj <- child()
+
+  expect_identical(
+    attr(child, "_S7_dispatch", exact = TRUE),
+    c("pkg::child", "pkg::parent", "S7_object")
+  )
+
+  local_mocked_bindings(
+    S7_class_name = function(...) stop("Recomputed class name")
+  )
+  expect_equal(class_inherits(obj, parent), TRUE)
+})
+
+test_that("S7 class dispatch supports classes without a cache", {
+  parent := new_class(package = "pkg")
+  child := new_class(parent = parent, package = "pkg")
+  obj <- child()
+
+  # Classes created by older versions of S7 don't have a cache
+  attr(child, "_S7_dispatch") <- NULL
+  expect_identical(
+    class_dispatch(child),
+    c("pkg::child", "pkg::parent", "S7_object")
+  )
+  expect_equal(class_inherits(obj, child), TRUE)
+})
+
+test_that("class_inherits() handles special S7 objects", {
+  Child := new_class(package = NULL)
+
+  expect_equal(class_inherits(S7_object(), S7_object), TRUE)
+  expect_equal(class_inherits(Child, S7_object), TRUE)
+  expect_equal(class_inherits(structure(1, class = "Child"), Child), FALSE)
+})
+
+test_that("class_type() recognizes special class specifications", {
+  expect_identical(class_type(class_missing), "missing")
+  expect_identical(class_type(class_any), "any")
+  expect_identical(
+    class_type(structure(list(), class = c("S7_external_class", "S7_any"))),
+    "any"
+  )
+  expect_snapshot(class_type(1), error = TRUE)
+})
+
 test_that("can work with unions", {
   text := new_class(class_character, package = NULL)
   number := new_class(class_double, package = NULL)

tests/testthat/test-class.R

@@ -1,7 +1,10 @@
 test_that("S7 classes possess expected properties", {
   foo := new_class(package = "S7", validator = function(self) NULL)
 
-  expect_equal(prop_names(foo), setdiff(names(attributes(foo)), "class"))
+  expect_equal(
+    prop_names(foo),
+    setdiff(names(attributes(foo)), c("class", "_S7_dispatch"))
+  )
   expect_type(foo@name, "character")
   expect_equal(foo@parent, S7_object)
   expect_type(foo@constructor, "closure")
@@ -369,6 +372,18 @@ test_that("new_object() errors if `_parent` doesn't inherit from the parent clas
   })
 })
 
+test_that("new_object() accepts an instance of a subclass of the parent", {
+  Parent := new_class(package = NULL)
+  Sibling := new_class(parent = Parent, package = NULL)
+  Child := new_class(
+    parent = Parent,
+    package = NULL,
+    constructor = function(parent) new_object(parent)
+  )
+
+  expect_identical(S7_class(Child(Sibling())), Child)
+})
+
 test_that("new_object() allows S7_object placeholder for abstract parents", {
   Abstract := new_class(
     package = NULL,