diff --git a/NEWS.md b/NEWS.md index ef02db4d..0e6f4024 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,6 @@ # S7 (development version) +* Calling `substitute()` on a dispatched argument inside a method now returns the argument's value rather than its original expression, since dispatched arguments are evaluated before the method is called. `substitute()` continues to return the original expression for non-dispatched arguments. * Errors thrown by S7 now report the function where they occurred, making it easier to track down the source of a problem (#646). * `class_POSIXct` uses the `tzone` attribute (not `tz`), and allows it to be absent (#401). * Base type wrappers like `class_integer` now define their constructor and validator in the S7 namespace. (#553). diff --git a/src/method-dispatch.c b/src/method-dispatch.c index d572fafd..02a48ec2 100644 --- a/src/method-dispatch.c +++ b/src/method-dispatch.c @@ -178,8 +178,7 @@ SEXP method_call_(SEXP call_, SEXP op_, SEXP args_, SEXP env_) { SEXP mcall = PROTECT(Rf_lcons(R_NilValue, R_NilValue)); SEXP mcall_tail = mcall; - PROTECT_INDEX arg_pi, val_pi; - PROTECT_WITH_INDEX(R_NilValue, &arg_pi); // unnecessary, for rchk only + PROTECT_INDEX val_pi; PROTECT_WITH_INDEX(R_NilValue, &val_pi); // unnecessary, for rchk only // For each of the arguments to the generic @@ -189,8 +188,6 @@ SEXP method_call_(SEXP call_, SEXP op_, SEXP args_, SEXP env_) { if (i < n_dispatch) { - SEXP arg = Rf_findVarInFrame(envir, name); - SETCADR(missing_call, name); int is_missing = Rf_asLogical(Rf_eval(missing_call, envir)); @@ -201,37 +198,25 @@ SEXP method_call_(SEXP call_, SEXP op_, SEXP args_, SEXP env_) { } else { // arg not missing, is a PROMSXP - // Force the promise so we can look up its class. - // However, we preserve and pass along the promise itself so that - // methods can still call substitute() - // Instead of Rf_eval(arg, R_EmptyEnv), we do Rf_eval(name, envir), so that - // - if TYPEOF(arg) == LANGSXP or SYMSXP, arg doesn't need to be enquoted and - // - if TYPEOF(arg) == PROMSXP, arg is updated in place. - REPROTECT(arg, arg_pi); // unnecessary, for rchk only + // Force the promise so we can look up its class, then pass along the + // forced value (enquoted if necessary so it isn't re-evaluated). We + // don't pass along the promise itself, so substitute() in a method + // sees the value of a dispatched argument, not its original call. SEXP val = Rf_eval(name, envir); REPROTECT(val, val_pi); // unnecessary, for rchk only if (Rf_inherits(val, "S7_super")) { - // Put the super() stored value into the method call. - // Note: This means we don't pass along the arg PROMSXP, meaning that - // substitute() in methods does not retrieve the `super()` call. - // If we wanted substitute() to work here too, we could do: - // if (TYPEOF(arg) == PROMSXP) { SET_PRVALUE(arg, true_val); } else { arg = true_val; } - SEXP arg = VECTOR_ELT(val, 0); // true_val used for dispatch - APPEND_NODE(mcall_tail, name, arg); + SEXP true_val = VECTOR_ELT(val, 0); // true_val used for dispatch + APPEND_NODE(mcall_tail, name, maybe_enquote(true_val)); // Put the super() stored class dispatch vector into dispatch_classes SET_VECTOR_ELT(dispatch_classes, i, VECTOR_ELT(val, 1)); } else { // val is not a S7_super, a regular value - // The PROMSXP arg will have been updated in place by Rf_eval() above. - // Add to arguments of method call - APPEND_NODE(mcall_tail, name, arg); - - // Determine class string to use for method look up + APPEND_NODE(mcall_tail, name, maybe_enquote(val)); SET_VECTOR_ELT(dispatch_classes, i, S7_obj_dispatch(val)); } } @@ -268,6 +253,6 @@ SEXP method_call_(SEXP call_, SEXP op_, SEXP args_, SEXP env_) { SETCAR(mcall, method_name); SEXP out = Rf_eval(mcall, envir); - UNPROTECT(4); + UNPROTECT(3); return out; } diff --git a/tests/testthat/test-method-dispatch.R b/tests/testthat/test-method-dispatch.R index 4724bdf6..034b3dd7 100644 --- a/tests/testthat/test-method-dispatch.R +++ b/tests/testthat/test-method-dispatch.R @@ -62,10 +62,13 @@ describe("multiple dispatch", { }) -test_that("can substitute() args", { +test_that("can substitute() non-dispatch args", { foo <- new_generic("foo", "x", function(x, ..., z = 1) S7_dispatch()) + + # Dispatched args are forced before the method is called, so substitute() + # sees their value rather than the original expression. method(foo, class_character) <- function(x, ..., z = 1) substitute(x) - expect_equal(foo(letters), quote(letters)) + expect_equal(foo(letters), letters) suppressMessages( method(foo, class_character) <- function(x, ..., z = 1, y) substitute(y)