Skip to content

Feature: permit (most) reserved attributes names as property names #582

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
dgkf wants to merge 2 commits into
base: main
Choose a base branch
from
Open

Feature: permit (most) reserved attributes names as property names #582

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
b9f6cb8
feat: perrmit (most) reserved attributes names as property names
dgkf Nov 26, 2025
a156fc6
fix: rebuilding tests-class snapshots
dgkf Nov 26, 2025
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
99 changes: 74 additions & 25 deletions R/class.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -95,14 +95,14 @@
#' r <- Range(start = 10, end = 20)
#' try(r@start <- 25)
new_class <- function(
name,
parent = S7_object,
package = topNamespaceName(parent.frame()),
properties = list(),
abstract = FALSE,
constructor = NULL,
validator = NULL) {

name,
parent = S7_object,
package = topNamespaceName(parent.frame()),
properties = list(),
abstract = FALSE,
constructor = NULL,
validator = NULL
) {
check_name(name)

parent <- as_class(parent)
Expand All @@ -119,7 +119,10 @@ new_class <- function(
if (!is.null(validator)) {
check_function(validator, alist(self = ))
}
if (abstract && (!is_class(parent) || !(parent@abstract || parent@name == "S7_object"))) {
if (
abstract &&
(!is_class(parent) || !(parent@abstract || parent@name == "S7_object"))
) {
stop("Abstract classes must have abstract parents")
}
}
Expand All @@ -128,12 +131,16 @@ new_class <- function(
all_props <- attr(parent, "properties", exact = TRUE) %||% list()
new_props <- as_properties(properties)
check_prop_names(new_props)

all_props[names(new_props)] <- new_props

if (is.null(constructor)) {
constructor <- new_constructor(parent, all_props,
envir = parent.frame(),
package = package)
constructor <- new_constructor(
parent,
all_props,
envir = parent.frame(),
package = package
)
}

object <- constructor
Expand All @@ -150,7 +157,15 @@ new_class <- function(
global_variables(names(all_props))
object
}
globalVariables(c("name", "parent", "package", "properties", "abstract", "constructor", "validator"))
globalVariables(c(
"name",
"parent",
"package",
"properties",
"abstract",
"constructor",
"validator"
))

#' @rawNamespace if (getRversion() >= "4.3.0") S3method(nameOfClass, S7_class, S7_class_name)
S7_class_name <- function(x) {
Expand Down Expand Up @@ -203,7 +218,12 @@ print.S7_class <- function(x, ...) {
#' @export
str.S7_class <- function(object, ..., nest.lev = 0) {
cat(if (nest.lev > 0) " ")
cat("<", paste0(class_dispatch(object), collapse = "/"), "> constructor", sep = "")
cat(
"<",
paste0(class_dispatch(object), collapse = "/"),
"> constructor",
sep = ""
)
cat("\n")

if (nest.lev == 0) {
Expand Down Expand Up @@ -248,7 +268,10 @@ new_object <- function(.parent, ...) {
stop("`new_object()` must be called from within a constructor")
}
if (class@abstract) {
msg <- sprintf("Can't construct an object from abstract class <%s>", class@name)
msg <- sprintf(
"Can't construct an object from abstract class <%s>",
class@name
)
stop(msg)
}

Expand All @@ -265,20 +288,22 @@ new_object <- function(.parent, ...) {

attrs <- c(
list(class = class_dispatch(class), S7_class = class),
args[!has_setter],
with_remap_reserved_names(args[!has_setter]),
attributes(object)
)
attrs <- attrs[!duplicated(names(attrs))]
attributes(object) <- attrs
Comment on lines 289 to 295
Copy link
Contributor Author

@dgkf dgkf Nov 26, 2025

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

When arguments are passed through new_object() they are assigned to attribute values directly, so they go through the same remapping for reserved names here.


# invoke custom property setters
prop_setter_vals <- args[has_setter]
for (name in names(prop_setter_vals))
for (name in names(prop_setter_vals)) {
prop(object, name, check = FALSE) <- prop_setter_vals[[name]]
}

# Don't need to validate if parent class already validated,
# i.e. it's a non-abstract S7 class
parent_validated <- inherits(class@parent, "S7_object") && !class@parent@abstract
parent_validated <- inherits(class@parent, "S7_object") &&
!class@parent@abstract
validate(object, recursive = !parent_validated)

object
Expand All @@ -295,8 +320,9 @@ str.S7_object <- function(object, ..., nest.lev = 0) {
cat(obj_desc(object))

if (!is_S7_type(object)) {
if (!typeof(object) %in% c("numeric", "integer", "character", "double"))
if (!typeof(object) %in% c("numeric", "integer", "character", "double")) {
cat(" ")
}

attrs <- attributes(object)
if (is.environment(object)) {
Expand Down Expand Up @@ -328,15 +354,38 @@ S7_class <- function(object) {
attr(object, "S7_class", exact = TRUE)
}


check_prop_names <- function(properties, error_call = sys.call(-1L)) {
# these attributes have special C handlers in base R
forbidden <- c("names", "dim", "dimnames", "class",
"tsp", "comment", "row.names", "...")
forbidden <- c("...")
forbidden <- intersect(forbidden, names(properties))
if (length(forbidden)) {
msg <- paste0("property can't be named: ",
paste0(forbidden, collapse = ", "))
msg <- paste0(
"property can't be named: ",
paste0("'", forbidden, "'", collapse = ", ")
)
stop(simpleError(msg, error_call))
}
}

remap_reserved_names <- function(names) {
# these attributes have special C handlers in base R
forbidden <- c(
"names",
"dim",
"dimnames",
"class",
"tsp",
"comment",
"row.names",
"..."
)

is_forbidden <- names %in% forbidden
names[is_forbidden] <- paste0(".__S7_prop__", names[is_forbidden], "__")

names
}

with_remap_reserved_names <- function(x) {
names(x) <- remap_reserved_names(names(x))
x
}
60 changes: 40 additions & 20 deletions R/property.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -40,7 +40,7 @@
#' function promise in the default constructor, evaluated at the time the
#' object is constructed.
#' @param name Property name, primarily used for error messages. Generally
#' don't need to set this here, as it's more convenient to supply as
#' don't need to set this here, as it's more convenient to supply as
#' the element name when defining a list of properties. If both `name`
#' and a list-name are supplied, the list-name will be used.
#' @returns An S7 property, i.e. a list with class `S7_property`.
Expand Down Expand Up @@ -72,12 +72,14 @@
#' # argument to the default constructor
#' try(Clock(now = 10))
#' args(Clock)
new_property <- function(class = class_any,
getter = NULL,
setter = NULL,
validator = NULL,
default = NULL,
name = NULL) {
new_property <- function(
class = class_any,
getter = NULL,
setter = NULL,
validator = NULL,
default = NULL,
name = NULL
) {
class <- as_class(class)
check_prop_default(default, class)

Expand Down Expand Up @@ -119,7 +121,7 @@ check_prop_default <- function(default, class, error_call = sys.call(-1)) {
# The meaning of a `...` prop default needs discussion
stop(simpleError("`default` cannot be `...`", error_call))
}
if (identical(default, quote(expr =))) {
if (identical(default, quote(expr = ))) {
# The meaning of a missing prop default needs discussion
stop(simpleError("`default` cannot be missing", error_call))
}
Expand All @@ -128,11 +130,15 @@ check_prop_default <- function(default, class, error_call = sys.call(-1)) {
return()
}

if (class_inherits(default, class))
if (class_inherits(default, class)) {
return()
}

msg <- sprintf("`default` must be an instance of %s, not a %s",
class_desc(class), obj_desc(default))
msg <- sprintf(
"`default` must be an instance of %s, not a %s",
class_desc(class),
obj_desc(default)
)

stop(simpleError(msg, error_call))
}
Expand Down Expand Up @@ -188,7 +194,8 @@ prop_default <- function(prop, envir, package) {
#' lexington@height <- 14
#' prop(lexington, "height") <- 15
prop <- function(object, name) {
.Call(prop_, object, name)
attr_name <- remap_reserved_names(name)
.Call(prop_, object, name, attr_name)
}
Comment on lines 196 to 199
Copy link
Contributor Author

@dgkf dgkf Nov 26, 2025

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This is the primary change. attr_name was added as an additional parameter to prop_ (and prop_set_).

It only differs from name in cases when there's a clash with a reserved name, in which case it gets mangled, such as .__S7_prop_names__.

Attributes get remapped at this point so that they keep their user-facing name for all other purposes.


propr <- function(object, name) {
Expand Down Expand Up @@ -229,11 +236,12 @@ 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)
attr_name <- remap_reserved_names(name)
.Call(prop_set_, object, name, attr_name, check, value)
}

`propr<-` <- local({
# reference implementation of `prop<-()` implemented in R
# 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

Expand All @@ -246,7 +254,11 @@ prop_obj <- function(object, name) {
}

if (!is.null(prop$getter) && is.null(prop$setter)) {
msg <- sprintf("Can't set read-only property %s@%s", obj_desc(object), name)
msg <- sprintf(
"Can't set read-only property %s@%s",
obj_desc(object),
name
)
stop(msg, call. = FALSE)
}

Expand Down Expand Up @@ -293,7 +305,8 @@ 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)) {
return(sprintf("%s must be %s, not %s",
return(sprintf(
"%s must be %s, not %s",
prop_label(object, prop$name),
class_desc(prop$class),
obj_desc(value)
Expand All @@ -319,7 +332,8 @@ prop_validate <- function(prop, value, object = NULL) {

stop(sprintf(
"%s validator must return NULL or a character, not <%s>.",
prop_label(object, prop$name), typeof(val)
prop_label(object, prop$name),
typeof(val)
))
}

Expand Down Expand Up @@ -363,7 +377,15 @@ prop_names <- function(object) {

if (inherits(object, "S7_class")) {
# S7_class isn't a S7_class (somewhat obviously) so we fake the property names
c("name", "parent", "package", "properties", "abstract", "constructor", "validator")
c(
"name",
"parent",
"package",
"properties",
"abstract",
"constructor",
"validator"
)
} else {
class <- S7_class(object)
props <- attr(class, "properties", exact = TRUE)
Expand Down Expand Up @@ -473,7 +495,6 @@ as_properties <- function(x) {
}

as_property <- function(x, name, i) {

if (is_property(x)) {
if (name == "") {
if (is.null(x$name)) {
Expand Down Expand Up @@ -502,4 +523,3 @@ prop_is_read_only <- function(prop) {
prop_has_setter <- function(prop) is.function(prop$setter)

prop_is_dynamic <- function(prop) is.function(prop$getter)

8 changes: 4 additions & 4 deletions src/init.c
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -9,16 +9,16 @@ extern SEXP method_call_(SEXP, SEXP, SEXP, SEXP);
extern SEXP test_call_(SEXP, 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);
extern SEXP prop_(SEXP, SEXP, SEXP);
extern SEXP prop_set_(SEXP, SEXP, SEXP, SEXP, SEXP);

#define CALLDEF(name, n) {#name, (DL_FUNC) &name, n}

static const R_CallMethodDef CallEntries[] = {
CALLDEF(method_, 4),
CALLDEF(S7_object_, 0),
CALLDEF(prop_, 2),
CALLDEF(prop_set_, 4),
CALLDEF(prop_, 3),
CALLDEF(prop_set_, 5),
{NULL, NULL, 0}
};

Expand Down
Loading