diff --git a/doc/NEWS.Rd b/doc/NEWS.Rd index 9bbd5041e77..e83271677e8 100644 --- a/doc/NEWS.Rd +++ b/doc/NEWS.Rd @@ -20,6 +20,10 @@ \subsection{NEW FEATURES}{ \itemize{ + + \item The \code{@} operator now an S3 generic. + Contributed by Tomasz Kalinowski. + \item The included BLAS sources have been updated to those shipped with LAPACK version 3.10.1. (This caused some platform-dependent changes to package check output.) And then to the sources from diff --git a/src/library/base/man/InternalMethods.Rd b/src/library/base/man/InternalMethods.Rd index 3cbe9375c58..7c6be53c138 100644 --- a/src/library/base/man/InternalMethods.Rd +++ b/src/library/base/man/InternalMethods.Rd @@ -53,6 +53,8 @@ \code{\link{names<-}},% % do_namesgets() [attrib.c] % DispatchOrEval internal generic: levels<- \code{\link{levels<-}},% % do_levelsgets() [attrib.c] + % DispatchOrEval internal generic: @ + \code{\link{@}},% % do_AT() [attrib.c] % DispatchOrEval internal generic: @<- \code{\link{@<-}},% % do_attrgets() [attrib.c] diff --git a/src/library/base/man/slotOp.Rd b/src/library/base/man/slotOp.Rd index 5a2f8fb646e..24af0a0c73c 100644 --- a/src/library/base/man/slotOp.Rd +++ b/src/library/base/man/slotOp.Rd @@ -8,34 +8,34 @@ \alias{@} \alias{@<-} \description{ - Extract or replace the contents of a slot in a object with a - formal (S4) class structure. + Extract or replace the contents of a slot or property of an object. } \usage{ object@name object@name <- value } \arguments{ - \item{object}{An object from a formally defined (S4) class.} - \item{name}{The character-string name of the slot, quoted or - not. Must be the name of a slot in the definition of the class - of \code{object}.} - \item{value}{A replacement value for the slot, which must be from a - class compatible with the class defined for this slot in the - definition of the class of \code{object}.} + \item{object}{An object from a formally defined (S4) class, or + otherwise an class object with an `@` or `@<-` S3 or S7 method.} + \item{name}{The name of the slot, supplied as a character string or + unquoted symbol. If \code{object} is S4, \code{name} must be the + name of a slot in the definition of the class of \code{object}.} + \item{value}{A suitable replacement value for the slot or property. } \details{ - These operators support the formal classes of package \pkg{methods}, - and are enabled only when package \pkg{methods} is loaded (as per - default). See \code{\link{slot}} for further details, in particular - for the differences between \code{slot()} and the \code{@} operator. - - It is checked that \code{object} is an S4 object (see - \code{\link{isS4}}), and it is an error to attempt to use \code{@} on - any other object. (There is an exception for name \code{.Data} for - internal use only.) The replacement operator checks that the slot + + if \code{object} is S4, these operators are for slot access, and + are enabled only when package \pkg{methods} is loaded (as per default). + The slot must be formally defined. (There is an exception + for name \code{.Data}, intended for internal use only.) + The replacement operator checks that the slot already exists on the object (which it should if the object is really from the class it claims to be). + See \code{\link{slot}} for further details, in particular + for the differences between \code{slot()} and the \code{@} operator. + + If \code{object} is not S4, a suitable S3 method for `@` or `@<-` is + searched for. If no method is found, an error is signaled. These are internal generic operators: see \link{InternalMethods}. } diff --git a/src/main/attrib.c b/src/main/attrib.c index 6c4b9ba08a4..3f4646c3d06 100644 --- a/src/main/attrib.c +++ b/src/main/attrib.c @@ -1862,34 +1862,89 @@ SEXP R_do_slot_assign(SEXP obj, SEXP name, SEXP value) { attribute_hidden SEXP do_AT(SEXP call, SEXP op, SEXP args, SEXP env) { - SEXP nlist, object, ans, klass; - + SEXP nlist, nlist_str, object, object_prom, ans, args2; checkArity(op, args); - if(!isMethodsDispatchOn()) - error(_("formal classes cannot be used without the 'methods' package")); + + object = PROTECT(eval(CAR(args), env)); nlist = CADR(args); - /* Do some checks here -- repeated in R_do_slot, but on repeat the - * test expression should kick out on the first element. */ - if(!(isSymbol(nlist) || (isString(nlist) && LENGTH(nlist) == 1))) - error(_("invalid type or length for slot name")); - if(isString(nlist)) nlist = installTrChar(STRING_ELT(nlist, 0)); - PROTECT(object = eval(CAR(args), env)); - if(!s_dot_Data) init_slot_handling(); - if(nlist != s_dot_Data && !IS_S4_OBJECT(object)) { - klass = getAttrib(object, R_ClassSymbol); - if(length(klass) == 0) - error(_("trying to get slot \"%s\" from an object of a basic class (\"%s\") with no slots"), - CHAR(PRINTNAME(nlist)), - CHAR(STRING_ELT(R_data_class(object, FALSE), 0))); - else - error(_("trying to get slot \"%s\" from an object (class \"%s\") that is not an S4 object "), - CHAR(PRINTNAME(nlist)), - translateChar(STRING_ELT(klass, 0))); + + // Don't dispatch on S4 objects, S4 objects are handled by R_do_slot() + if (IS_S4_OBJECT(object)) { + if (!s_dot_Data) init_slot_handling(); + if (!isMethodsDispatchOn()) { + UNPROTECT(1); // object + error(_("formal classes cannot be used without the 'methods' package")); + } + + // ensure nlist is a symbol, like R_do_slot() and getAttrib() want. + if (isString(nlist)) { + if (LENGTH(nlist) != 1) { + UNPROTECT(1); // object + error(_("invalid length for slot name")); + } + nlist = installTrChar(STRING_ELT(nlist, 0)); + } + else if (!isSymbol(nlist)) { + UNPROTECT(1); // object + error(_("invalid type for slot name")); + } + + ans = R_do_slot(object, nlist); + UNPROTECT(1); // object + return ans; + } + + // Try dispatch on S3 objects + + // First prepare the second argument for DispatchOrEval(), so + // methods get the name as a string, not as a symbol. + PROTECT(nlist_str = allocVector(STRSXP, 1)); + if (isSymbol(nlist)) { + SET_STRING_ELT(nlist_str, 0, PRINTNAME(nlist)); + } + else if(isString(nlist)) { + if (LENGTH(nlist) != 1) { + UNPROTECT(2); // nlist_str, object + error(_("invalid length for property name")); + } + SET_STRING_ELT(nlist_str, 0, STRING_ELT(nlist, 0)); + } + else { + UNPROTECT(2); // nlist_str, object + error(_("invalid type '%s' for property name"), + type2char(TYPEOF(nlist))); + return R_NilValue; /*-Wall*/ } - ans = R_do_slot(object, nlist); - UNPROTECT(1); - return ans; + // Create a promise for the first argument, so that substitute(x) works in @ methods + INCREMENT_LINKS(object); + object_prom = R_mkEVPROMISE_NR(CAR(args), object); + args2 = PROTECT(list2(object_prom, nlist_str)); + + /* DispatchOrEval internal generic: @ */ + int disp = DispatchOrEval(call, op, "@", args2, env, &ans, 0, 0); + DECREMENT_LINKS(object); + UNPROTECT(2); // args2, nlist_str + if(disp) { + UNPROTECT(1); // object + return(ans); + } + + // not S4, S3 dispatch failed + // for backcompat, invoke the S4 pathway if nlist is '.Data' + if (!s_dot_Data) init_slot_handling(); + if (nlist == s_dot_Data) { + ans = R_do_slot(object, nlist); + UNPROTECT(1); // object + return ans; + } + + // not S4, S3 dispatch failed, nlist != '.Data' + // so error (could alternatively fallback to getAttrib()) + UNPROTECT(1); // object + error(_("trying to access `@` on an object with no `@` method.")); + return R_NilValue; /*-Wall*/ + } /* Return a suitable S3 object (OK, the name of the routine comes from diff --git a/src/main/subassign.c b/src/main/subassign.c index 449d8d88012..b613565d2c8 100644 --- a/src/main/subassign.c +++ b/src/main/subassign.c @@ -1520,7 +1520,7 @@ static R_INLINE int SubAssignArgs(SEXP args, SEXP *x, SEXP *s, SEXP *y) } /* Version of DispatchOrEval for "[" and friends that speeds up simple cases. - Also defined in subset.c */ + Also defined in subset.c */ static R_INLINE int R_DispatchOrEvalSP(SEXP call, SEXP op, const char *generic, SEXP args, SEXP rho, SEXP *ans) diff --git a/tests/method-dispatch.R b/tests/method-dispatch.R index 567ecb75ac5..c2bca0517fd 100644 --- a/tests/method-dispatch.R +++ b/tests/method-dispatch.R @@ -1,5 +1,5 @@ #### Testing UseMethod() and even more NextMethod() -#### -------------------- +#### -------------------- #### i.e., S3 methods *only*. For S4, see reg-S4.R ## ~~~~~~~~ @@ -60,3 +60,60 @@ abc(e0) abc(e1) abc(e0[[1]]) abc(e1[[1]]) + + +## Some tests for `@` dispatching +## make sure that +## - `@` evals the first args only once, +## - doesn't dispatch for S4 +## - works on `.Data` even for nonS4 objects + +x <- structure(list(), class = "foo", prop1 = 'prop1val') +registerS3method("@", "foo", + function(x, name) { + stopifnot(typeof(name) == "character", length(name) == 1L) + cat(sprintf("called `@.foo`(x = %s, name = '%s')\n", + deparse1(substitute(x), "\n"), name)) + attr(x, name, TRUE) + } +) +x@prop1 + +abc <- x +abc@prop1 + +{ + cat("new x\n") + structure(list(), class = "foo", prop1 = 'prop1val') +}@prop1 + +makeActiveBinding("ax", function(x) { + cat("evaluating ax\n") + get("x", envir = parent.frame()) +}, environment()) + +ax@prop1 + +stopifnot(exprs = { + identical( x@prop1, "prop1val") + identical(ax@prop1, "prop1val") + + identical(letters@.Data, letters) +}) + +try(letters@foo) # error + +# doesn't dispatch for S4 +setClass("Person", + slots = c( + name = "character", + age = "numeric" + ) +) + +`@.Person` <- function(x, name) { + stop("called @.Person()\n") +} + +p <- new("Person", name = "Who", age = -1) +stopifnot(p@name == "Who") diff --git a/tests/method-dispatch.Rout.save b/tests/method-dispatch.Rout.save index 7dfc21a9a86..88390b4e8dd 100644 --- a/tests/method-dispatch.Rout.save +++ b/tests/method-dispatch.Rout.save @@ -1,6 +1,6 @@ -R Under development (unstable) (2022-03-19 r81942) -- "Unsuffered Consequences" -Copyright (C) 2022 The R Foundation for Statistical Computing +R Under development (unstable) (2023-03-15 r83984) -- "Unsuffered Consequences" +Copyright (C) 2023 The R Foundation for Statistical Computing Platform: x86_64-pc-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. @@ -105,3 +105,78 @@ abc: Before dispatching; x has class `(': language, mode "(": (x) abc: Before dispatching; x has class `call': language sin(x) abc.default(e1[[1]]) > +> +> ## Some tests for `@` dispatching +> ## make sure that +> ## - `@` evals the first args only once, +> ## - doesn't dispatch for S4 +> ## - works on `.Data` even for nonS4 objects +> +> x <- structure(list(), class = "foo", prop1 = 'prop1val') +> registerS3method("@", "foo", ++ function(x, name) { ++ stopifnot(typeof(name) == "character", length(name) == 1L) ++ cat(sprintf("called `@.foo`(x = %s, name = '%s')\n", ++ deparse1(substitute(x), "\n"), name)) ++ attr(x, name, TRUE) ++ } ++ ) +> x@prop1 +called `@.foo`(x = x, name = 'prop1') +[1] "prop1val" +> +> abc <- x +> abc@prop1 +called `@.foo`(x = abc, name = 'prop1') +[1] "prop1val" +> +> { ++ cat("new x\n") ++ structure(list(), class = "foo", prop1 = 'prop1val') ++ }@prop1 +new x +called `@.foo`(x = { + cat("new x\n") + structure(list(), class = "foo", prop1 = "prop1val") +}, name = 'prop1') +[1] "prop1val" +> +> makeActiveBinding("ax", function(x) { ++ cat("evaluating ax\n") ++ get("x", envir = parent.frame()) ++ }, environment()) +> +> ax@prop1 +evaluating ax +called `@.foo`(x = ax, name = 'prop1') +[1] "prop1val" +> +> stopifnot(exprs = { ++ identical( x@prop1, "prop1val") ++ identical(ax@prop1, "prop1val") ++ ++ identical(letters@.Data, letters) ++ }) +called `@.foo`(x = x, name = 'prop1') +evaluating ax +called `@.foo`(x = ax, name = 'prop1') +> +> try(letters@foo) # error +Error in try(letters@foo) : + trying to access `@` on an object with no `@` method. +> +> # doesn't dispatch for S4 +> setClass("Person", ++ slots = c( ++ name = "character", ++ age = "numeric" ++ ) ++ ) +> +> `@.Person` <- function(x, name) { ++ stop("called @.Person()\n") ++ } +> +> p <- new("Person", name = "Who", age = -1) +> stopifnot(p@name == "Who") +>