Give up on substitute() for dispatch args

Author: hadley

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).

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;
 }

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)