Commit 9ea54f65 authored by Radford Neal's avatar Radford Neal

Merge branch '02-promiseWith' into 03

parents 041cf871 2419cbe3
......@@ -58,9 +58,56 @@ users, such as cleanups of source code.
9)
10)
11)
o Created a promiseArgsWithValues function that calls promiseArgs
and then sets the values of the promises created, and a
promiseArgsWith1Value function that does the same except setting
only the value for the first promise. Code to do these things
appears in several places, so creating these functions cleans
things up (and is needed for later mods).
The promiseArgsWithValues and promiseArgsWith1Value functions are
not entirely equivalent to the previous code, which set the
values of what it took to be promises without checking that they
actually were promises. Since promiseArgs doesn't always create
a promise for every argument (it doesn't when the argument is
R_MissingArg), this doesn't seem safe, though I haven't found an
example where a bug actually arises. The promiseArgsWithValues
and promiseArgsWith1Value silently skip setting the value for
arguments that aren't promises, as will be necessary when missing
arguments do arise.
o Fixed a problem with the DispatchOrEval function in eval.c.
Without this fix, some subtle things go wrong with existing
features in 2.15.0, and more serious things go wrong with some of
other mods in pqR.
The issue is that if DispatchOrEval is called with argsevald set
to 1 (indicating that arguments have already been evaluated), if
DispatchOrEval dispatches to a method for an object, it passes on
these argument values without putting them in promises along with
the unevaluated arguments. Because of this, a method that
attempts to deparse an argument will not work correctly. It
seems possible that there might also be some other bad effects of
not having these promises.
Here is an illustration:
> a <- 0
> class(a) <- "fred"
> seq.fred <- function (x, y) deparse(substitute(y))
> seq(a,1+2)
[1] "1 + 2"
> seq.int(a,1+2)
[1] "3"
Both "seq" and "seq.int" dispatch to seq.fred, but seq.int calls
DispatchOrEval, which doesn't pass on a promise with the
unevaluated argument. After the fix, seq.int does the same as seq.
This example is now tested in tests/eval-etc.R.
Also fixed some formatting in DispatchOrEval, and improved the
documentation for R_possible_dispatch to explain its features
used in this fix.
12)
......
Two related changes.
Created a promiseArgsWithValues function that calls promiseArgs and
then sets the values of the promises created, and a promiseArgsWith1Value
function that does the same except setting only the value for the
first promise. Code to do these things appears in several places, so
creating these functions cleans things up (and is needed for later
mods).
The promiseArgsWithValues and promiseArgsWith1Value functions are not
entirely equivalent to the previous code, which set the values of what
it took to be promises without checking that they actually were
promises. Since promiseArgs doesn't always create a promise for every
argument (it doesn't when the argument is R_MissingArg), this doesn't
seem safe, though there seem to be no examples where a bug actually
arises. The promiseArgsWithValues and promiseArgsWith1Value silently
skip setting the value for arguments that aren't promises, as will be
necessary when missing arguments do arise.
Also, a problem is fixed with the DispatchOrEval function in eval.c.
Without this fix, some subtle things go wrong with existing features
in 2.15.0, and more serious things go wrong with some later pqR mods.
The issue is that if DispatchOrEval is called with argsevald set to 1
(which indicates that arguments have already been evaluated), if
DispatchOrEval dispatches to a method for an object, it passes on
these argument values without putting them in promises along with the
unevaluated arguments. Because of this, a method that attempts to
deparse an argument will not work correctly. It seems possible that
there might also be some other bad effects of not having these
promises.
Here is an illustration:
> a <- 0
> class(a) <- "fred"
> seq.fred <- function (x, y) deparse(substitute(y))
> seq(a,1+2)
[1] "1 + 2"
> seq.int(a,1+2)
[1] "3"
Both "seq" and "seq.int" dispatch to seq.fred, but seq.int calls
DispatchOrEval, which doesn't pass on a promise with the unevaluated
argument. After the fix, seq.int does the same as seq. This example
is now tested in tests/eval-etc.R.
Also fixed some formatting in DispatchOrEval, and improved the
documentation for R_possible_dispatch to explain its features used in
this fix.
......@@ -910,6 +910,8 @@ extern0 Rboolean known_to_be_utf8 INI_as(FALSE);
# define PrintVersionString Rf_PrintVersionString
# define PrintWarnings Rf_PrintWarnings
# define promiseArgs Rf_promiseArgs
# define promiseArgsWithValues Rf_promiseArgsWithValues
# define promiseArgsWith1Value Rf_promiseArgsWith1Value
# define RealFromComplex Rf_RealFromComplex
# define RealFromInteger Rf_RealFromInteger
# define RealFromLogical Rf_RealFromLogical
......@@ -1101,6 +1103,8 @@ void process_site_Renviron(void);
void process_system_Renviron(void);
void process_user_Renviron(void);
SEXP promiseArgs(SEXP, SEXP);
SEXP promiseArgsWithValues(SEXP, SEXP, SEXP);
SEXP promiseArgsWith1Value(SEXP, SEXP, SEXP);
void Rcons_vprintf(const char *, va_list);
SEXP R_data_class(SEXP , Rboolean);
SEXP R_data_class2(SEXP);
......
......@@ -1976,6 +1976,36 @@ SEXP attribute_hidden promiseArgs(SEXP el, SEXP rho)
UNPROTECT(1);
return CDR(ans);
}
/* Create promises for arguments, with values for promises filled in.
Values for arguments that don't become promises are silently ignored.
This is used in method dispatch, hence the text of the error message
(which should never occur). */
SEXP attribute_hidden promiseArgsWithValues(SEXP el, SEXP rho, SEXP values)
{
SEXP s, a, b;
PROTECT(s = promiseArgs(el, rho));
if (length(s) != length(values)) error(_("dispatch error"));
for (a = values, b = s; a != R_NilValue; a = CDR(a), b = CDR(b))
if (TYPEOF(CAR(b)) == PROMSXP)
SET_PRVALUE(CAR(b), CAR(a));
UNPROTECT(1);
return s;
}
/* Like promiseArgsWithValues except it sets only the first value. */
SEXP attribute_hidden promiseArgsWith1Value(SEXP el, SEXP rho, SEXP value)
{
SEXP s, a, b;
PROTECT(s = promiseArgs(el, rho));
if (s == R_NilValue) error(_("dispatch error"));
if (TYPEOF(CAR(s)) == PROMSXP)
SET_PRVALUE(CAR(s), value);
UNPROTECT(1);
return s;
}
/* Check that each formal is a symbol */
......@@ -2250,9 +2280,13 @@ int DispatchAnyOrEval(SEXP call, SEXP op, const char *generic, SEXP args,
/* DispatchOrEval is used in internal functions which dispatch to
* object methods (e.g. "[" or "[["). The code either builds promises
* and dispatches to the appropriate method, or it evaluates the
* (unevaluated) arguments it comes in with and returns them so that
* the generic built-in C code can continue.
* arguments it comes in with (if argsevald is 0) and returns them so that
* the generic built-in C code can continue. Note that CDR(call) is
* used to obtain the unevaluated arguments when creating promises, even
* when argsevald is 1 (so args is the evaluated arguments). Note also
* that args must be protected before the call if argsevald is 0, but not
* if argsevald is 1.
*
* To call this an ugly hack would be to insult all existing ugly hacks
* at large in the world.
*/
......@@ -2272,8 +2306,9 @@ int DispatchOrEval(SEXP call, SEXP op, const char *generic, SEXP args,
SEXP x = R_NilValue;
int dots = FALSE, nprotect = 0;;
if( argsevald )
{PROTECT(x = CAR(args)); nprotect++;}
if (argsevald) {
PROTECT(x = CAR(args)); nprotect++;
}
else {
/* Find the object to dispatch on, dropping any leading
... arguments with missing or empty values. If there are no
......@@ -2291,15 +2326,15 @@ int DispatchOrEval(SEXP call, SEXP op, const char *generic, SEXP args,
#endif
dots = TRUE;
x = eval(CAR(h), rho);
break;
break;
}
else if (h != R_NilValue && h != R_MissingArg)
error(_("'...' used in an incorrect context"));
}
else {
dots = FALSE;
x = eval(CAR(args), rho);
break;
dots = FALSE;
x = eval(CAR(args), rho);
break;
}
}
PROTECT(x); nprotect++;
......@@ -2311,13 +2346,13 @@ int DispatchOrEval(SEXP call, SEXP op, const char *generic, SEXP args,
if(IS_S4_OBJECT(x) && R_has_methods(op)) {
SEXP value, argValue;
/* create a promise to pass down to applyClosure */
if(!argsevald) {
argValue = promiseArgs(args, rho);
SET_PRVALUE(CAR(argValue), x);
} else argValue = args;
if(!argsevald)
argValue = promiseArgsWith1Value(args, rho, x);
else
argValue = args;
PROTECT(argValue); nprotect++;
/* This means S4 dispatch */
value = R_possible_dispatch(call, op, argValue, rho, TRUE);
value = R_possible_dispatch(call, op, argValue, rho, !argsevald);
if(value) {
*ans = value;
UNPROTECT(nprotect);
......@@ -2352,7 +2387,15 @@ int DispatchOrEval(SEXP call, SEXP op, const char *generic, SEXP args,
if (pt == NULL || strcmp(pt,".default")) {
RCNTXT cntxt;
SEXP pargs, rho1;
PROTECT(pargs = promiseArgs(args, rho)); nprotect++;
if (argsevald) { /* handle as in R_possible_dispatch */
PROTECT(args); nprotect++;
pargs = promiseArgsWithValues(CDR(call), rho, args);
}
else
pargs = promiseArgsWith1Value(args, rho, x);
PROTECT(pargs); nprotect++;
/* The context set up here is needed because of the way
usemethod() is written. DispatchGroup() repeats some
internal usemethod() code and avoids the need for a
......@@ -2369,7 +2412,6 @@ int DispatchOrEval(SEXP call, SEXP op, const char *generic, SEXP args,
Hence here and in the other usemethod() uses below a
new environment rho1 is created and used. LT */
PROTECT(rho1 = NewEnvironment(R_NilValue, R_NilValue, rho)); nprotect++;
SET_PRVALUE(CAR(pargs), x);
begincontext(&cntxt, CTXT_RETURN, call, rho1, rho, pargs, op);
if(usemethod(generic, x, call, pargs, rho1, rho, R_BaseEnv, ans))
{
......@@ -2622,13 +2664,11 @@ int DispatchGroup(const char* group, SEXP call, SEXP op, SEXP args, SEXP rho,
/* out to a closure we need to wrap them in promises so that */
/* they get duplicated and things like missing/substitute work. */
PROTECT(s = promiseArgs(CDR(call), rho));
if (length(s) != length(args))
error(_("dispatch error in group dispatch"));
for (m = s ; m != R_NilValue ; m = CDR(m), args = CDR(args) ) {
SET_PRVALUE(CAR(m), CAR(args));
/* ensure positional matching for operators */
if(isOps) SET_TAG(m, R_NilValue);
PROTECT(s = promiseArgsWithValues(CDR(call), rho, args));
if (isOps) {
/* ensure positional matching for operators */
for (m = s; m != R_NilValue; m = CDR(m))
SET_TAG(m, R_NilValue);
}
*ans = applyClosure_v(t, lsxp, s, rho, newrho, 0);
......@@ -3488,8 +3528,7 @@ static int tryDispatch(char *generic, SEXP call, SEXP x, SEXP rho, SEXP *pv)
int dispatched = FALSE;
SEXP op = SYMVALUE(install(generic)); /**** avoid this */
PROTECT(pargs = promiseArgs(CDR(call), rho));
SET_PRVALUE(CAR(pargs), x);
PROTECT(pargs = promiseArgsWith1Value(CDR(call), rho, x));
/**** Minimal hack to try to handle the S4 case. If we do the check
and do not dispatch then some arguments beyond the first might
......
......@@ -1390,16 +1390,16 @@ void R_set_quick_method_check(R_stdGen_ptr_t value)
the methods be set up to return a special object rather than trying
to evaluate the default (which would get us into a loop). */
/* called from DispatchOrEval, DispatchGroup, do_matprod
When called from the first the arguments have been enclosed in
promises, but not from the other two: there all the arguments have
already been evaluated.
*/
/* The promisedArgs argument should be 1 if args is a list of promises, and
0 if not, in which case this function will create a list of promises to
pass to the method, using CDR(call) for the unevaluated arguments, and
args for their values. */
SEXP attribute_hidden
R_possible_dispatch(SEXP call, SEXP op, SEXP args, SEXP rho,
Rboolean promisedArgs)
{
SEXP fundef, value, mlist=R_NilValue, s, a, b;
SEXP fundef, value, mlist=R_NilValue, s;
int offset;
prim_methods_t current;
offset = PRIMOFFSET(op);
......@@ -1429,10 +1429,7 @@ R_possible_dispatch(SEXP call, SEXP op, SEXP args, SEXP rho,
if(isFunction(value)) {
/* found a method, call it with promised args */
if(!promisedArgs) {
PROTECT(s = promiseArgs(CDR(call), rho));
if (length(s) != length(args)) error(_("dispatch error"));
for (a = args, b = s; a != R_NilValue; a = CDR(a), b = CDR(b))
SET_PRVALUE(CAR(b), CAR(a));
PROTECT(s = promiseArgsWithValues(CDR(call), rho, args));
value = applyClosure(call, value, s, rho, R_BaseEnv);
UNPROTECT(1);
return value;
......@@ -1448,10 +1445,7 @@ R_possible_dispatch(SEXP call, SEXP op, SEXP args, SEXP rho,
/* To do: arrange for the setting to be restored in case of an
error in method search */
if(!promisedArgs) {
PROTECT(s = promiseArgs(CDR(call), rho));
if (length(s) != length(args)) error(_("dispatch error"));
for (a = args, b = s; a != R_NilValue; a = CDR(a), b = CDR(b))
SET_PRVALUE(CAR(b), CAR(a));
PROTECT(s = promiseArgsWithValues(CDR(call), rho, args));
value = applyClosure(call, fundef, s, rho, R_BaseEnv);
UNPROTECT(1);
} else
......
......@@ -1033,8 +1033,7 @@ SEXP attribute_hidden do_xtfrm(SEXP call, SEXP op, SEXP args, SEXP rho)
if(DispatchOrEval(call, op, "xtfrm", args, rho, &ans, 0, 1)) return ans;
/* otherwise dispatch the default method */
PROTECT(fn = findFun(install("xtfrm.default"), rho));
PROTECT(prargs = promiseArgs(args, R_GlobalEnv));
SET_PRVALUE(CAR(prargs), CAR(args));
PROTECT(prargs = promiseArgsWithValues(CDR(call), R_GlobalEnv, args));
ans = applyClosure(call, fn, prargs, rho, R_NilValue);
UNPROTECT(2);
return ans;
......
......@@ -708,9 +708,9 @@ SEXP attribute_hidden do_range(SEXP call, SEXP op, SEXP args, SEXP env)
UNPROTECT(1);
PROTECT(op = findFun(install("range.default"), env));
PROTECT(prargs = promiseArgs(args, R_GlobalEnv));
for (a = args, b = prargs; a != R_NilValue; a = CDR(a), b = CDR(b))
SET_PRVALUE(CAR(b), CAR(a));
/* Below should really use CDR(call) for the unevaluated expressions,
but it can't because args has been fiddled with by fixup_NaRm. */
PROTECT(prargs = promiseArgsWithValues(args, R_GlobalEnv, args));
ans = applyClosure(call, op, prargs, env, R_BaseEnv);
UNPROTECT(3);
return(ans);
......
......@@ -116,3 +116,12 @@ callme()
callme(mm="B")
mycaller <- function(x = 1, callme = pi) { callme(x) }
mycaller()## wrongly gave `mm = NULL' now = "Abc"
## Test pqR fix to DispatchOrEval.
a <- 0
class(a) <- "fred"
seq.fred <- function (x, y) deparse(substitute(y))
seq(a,1+2) # should both be "1 + 2"
seq.int(a,1+2) # ... but this one used to be "3"
R version 2.15.0 alpha (2012-03-02 r58556)
Copyright (C) 2012 The R Foundation for Statistical Computing
pqR version 2.15.10 (2013-01-01), based on R 2.15.0 (2012-03-30)
R is Copyright (C) 2012 The R Foundation for Statistical Computing
ISBN 3-900051-07-0
Modifications to R in pqR are Copyright (C) 2013 Radford M. Neal
Platform: x86_64-unknown-linux-gnu (64-bit)
R is free software and comes with ABSOLUTELY NO WARRANTY.
......@@ -172,3 +176,14 @@ mm = chr "Bde"
> mycaller()## wrongly gave `mm = NULL' now = "Abc"
mm = chr "Abc"
>
>
> ## Test pqR fix to DispatchOrEval.
>
> a <- 0
> class(a) <- "fred"
> seq.fred <- function (x, y) deparse(substitute(y))
> seq(a,1+2) # should both be "1 + 2"
[1] "1 + 2"
> seq.int(a,1+2) # ... but this one used to be "3"
[1] "1 + 2"
>
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment