...
 
Commits (5)
......@@ -1899,6 +1899,8 @@ static inline SEXP SKIP_USING_SYMBITS (SEXP rho, SEXP symbol)
defined. There arguments should be simple variables - avoid calling
anything, and avoid any side effects.
UNPROTECT_PROTECT(x) is the same as UNPROTECT(1); PROTECT(x), but faster.
Defining USE_FAST_PROTECT_MACROS in source files outside src/main may
cause problems at link time.
......@@ -1946,6 +1948,9 @@ extern R_NORETURN void Rf_unprotect_error (void);
#define UNPROTECT(n) ((void) (R_PPStackTop -= (n)))
#endif
#undef UNPROTECT_PROTECT
#define UNPROTECT_PROTECT(s) (R_PPStack[R_PPStackTop] = (s))
#undef PROTECT_WITH_INDEX
#define PROTECT_WITH_INDEX(x,i) \
( (*(i) = R_PPStackTop), PROTECT(x) )
......
# File src/library/base/R/sample.R
# Part of the R package, http://www.R-project.org
# Modifications for pqR Copyright (c) 2018 Radford M. Neal.
# Modifications for pqR Copyright (c) 2018, 2019 Radford M. Neal.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
......@@ -18,9 +18,10 @@
sample <- function(x, size, replace=FALSE, prob=NULL)
if (length(x) == 1L && is.numeric(x) && x >= 1)
.Internal (sample (x, if (missing(size)) x else size, replace, prob))
else if (missing(size)) # check missing outside [], which may be nonstandard
x [.Internal (sample (length(x), length(x), replace, prob)) ]
else
x [.Internal (sample (length(x),
if (missing(size)) length(x) else size, replace, prob)) ]
x [.Internal (sample (length(x), size, replace, prob)) ]
sample.int <- function(n, size=n, replace=FALSE, prob=NULL)
.Internal (sample (n, size, replace, prob))
......@@ -1072,15 +1072,13 @@ SEXP namesgets(SEXP vec, SEXP val)
val = rval;
}
} else val = coerceVector(val, STRSXP);
UNPROTECT(1);
PROTECT(val);
UNPROTECT_PROTECT(val);
/* Check that the lengths and types are compatible */
if (length(val) < length(vec)) {
val = lengthgets(val, length(vec));
UNPROTECT(1);
PROTECT(val);
UNPROTECT_PROTECT(val);
}
checkNames(vec, val);
......@@ -1216,13 +1214,11 @@ SEXP dimnamesgets(SEXP vec, SEXP val)
SET_VECTOR_ELT(newval, i, CAR(val));
val = CDR(val);
}
UNPROTECT(1);
PROTECT(val = newval);
UNPROTECT_PROTECT(val = newval);
}
if (length(val) > 0 && length(val) < k) {
newval = lengthgets(val, k);
UNPROTECT(1);
PROTECT(val = newval);
UNPROTECT_PROTECT(val = newval);
}
if (k != length(val))
error(_("length of 'dimnames' [%d] must match that of 'dims' [%d]"),
......@@ -1316,8 +1312,7 @@ SEXP dimgets(SEXP vec, SEXP val)
if (!isVector(val) && !isList(val))
error(_("invalid second argument"));
val = coerceVector(val, INTSXP);
UNPROTECT(1);
PROTECT(val);
UNPROTECT_PROTECT(val);
len = length(vec);
ndim = length(val);
......@@ -1991,8 +1986,7 @@ SEXP R_do_slot_assign(SEXP obj, SEXP name, SEXP value)
if (FALSE && /* disabled */ NAMEDCNT_GT_1(obj)) {
obj = dup_top_level(obj);
UNPROTECT(1); /* old obj */
PROTECT(obj);
UNPROTECT_PROTECT(obj);
}
if(!s_dot_Data) /* initialize */
......
......@@ -95,8 +95,7 @@ SEXP attribute_hidden Rf_builtin_op (SEXP op, SEXP e, SEXP rho, int variant)
R_variant_result &= ~VARIANT_UNCLASS_FLAG;
}
else {
UNPROTECT(1);
PROTECT(args = CONS(arg1,R_NilValue));
UNPROTECT_PROTECT(args = CONS(arg1,R_NilValue));
goto not_fast;
}
}
......
......@@ -154,8 +154,7 @@ static SEXP do_eval (SEXP call, SEXP op, SEXP args, SEXP rho, int variant)
if ( ! (variant & VARIANT_PENDING_OK))
WAIT_UNTIL_COMPUTED(R_ReturnedValue);
}
UNPROTECT(1);
PROTECT(expr);
UNPROTECT_PROTECT(expr);
endcontext(&cntxt);
}
else if (TYPEOF(expr) == EXPRSXP) {
......@@ -184,8 +183,7 @@ static SEXP do_eval (SEXP call, SEXP op, SEXP args, SEXP rho, int variant)
if ( ! (variant & VARIANT_PENDING_OK))
WAIT_UNTIL_COMPUTED(R_ReturnedValue);
}
UNPROTECT(1);
PROTECT(tmp);
UNPROTECT_PROTECT(tmp);
R_Srcref = savedsrcref;
endcontext(&cntxt);
expr = tmp;
......@@ -1010,8 +1008,7 @@ static SEXP attribute_noinline Rf_builtin_op_no_cntxt(SEXP op, SEXP e, SEXP rho,
R_variant_result &= ~VARIANT_UNCLASS_FLAG;
}
else {
UNPROTECT(1);
PROTECT(args = CONS(arg1,R_NilValue));
UNPROTECT_PROTECT(args = CONS(arg1,R_NilValue));
goto not_fast;
}
}
......@@ -1498,8 +1495,7 @@ static SEXP do_for (SEXP call, SEXP op, SEXP args, SEXP rho, int variant)
if (inherits_CHAR (val, R_factor_CHARSXP)) {
val = asCharacterFactor(val);
UNPROTECT(1);
PROTECT(val);
UNPROTECT_PROTECT(val);
}
n = length(val);
......@@ -3391,7 +3387,54 @@ static SEXP do_function(SEXP call, SEXP op, SEXP args, SEXP rho, int variant)
Note that if there are less than two arguments, the missing ones will
appear here to be R_NilValue (since CAR(R_NilValue) is R_NilValue).
The args and env arguments must be protected by the caller. */
The args and env arguments must be protected by the caller.
Two non-inlined routines below are used for the uncommon cases where
operands are objects. */
static attribute_noinline SEXP scalar_stack_eval2_xobj
(SEXP x, SEXP args, SEXP env) /* x protect at start, unprotected here */
{
/* If first argument is an object, we evaluate the rest of the
arguments (actually, at most one) normally. */
SEXP argsevald;
INC_NAMEDCNT(x);
argsevald = evalList (CDR(args), env);
argsevald = cons_with_tag (x, argsevald, TAG(args));
DEC_NAMEDCNT(x);
UNPROTECT(1); /* x */
WAIT_UNTIL_COMPUTED(x);
return argsevald;
}
static attribute_noinline SEXP scalar_stack_eval2_yobj
(SEXP x, SEXP y, SEXP args, SEXP env) /* x protect at start, unprotected here*/
{
/* If the second argument is an object, we have to duplicate the
first arg if it is on the scalar stack, or an unclassed object,
and create the list of evaluated arguments. */
if (ON_SCALAR_STACK(x) || isObject(x)) /* can't be both */ {
UNPROTECT_PROTECT(y); /* unprotects x */
if (ON_SCALAR_STACK(x)) {
POP_SCALAR_STACK(x);
x = duplicate(x);
}
else { /* isObject(x) */
x = Rf_makeUnclassed(x);
}
UNPROTECT_PROTECT(x); /* unprotects y */
}
/* should not be any more arguments */
SEXP argsevald;
argsevald = cons_with_tag (y, R_NilValue, TAG(CDR(args)));
argsevald = cons_with_tag (x, argsevald, TAG(args));
UNPROTECT(1); /* x */
WAIT_UNTIL_COMPUTED_2(x,y);
return argsevald;
}
static inline SEXP scalar_stack_eval2 (SEXP args, SEXP *arg1, SEXP *arg2,
int *obj, SEXP env)
......@@ -3423,21 +3466,11 @@ static inline SEXP scalar_stack_eval2 (SEXP args, SEXP *arg1, SEXP *arg2,
VARIANT_SCALAR_STACK_OK | VARIANT_UNCLASS | VARIANT_PENDING_OK));
if (isObject(x)) {
if (! (R_variant_result & VARIANT_UNCLASS_FLAG)) {
/* If first argument is an object, we evaluate the rest of
the arguments (actually, at most one) normally. */
argsevald = scalar_stack_eval2_xobj (x, args, env);
y = CADR(argsevald);
ob = 1; /* x is an object, not unclassed */
INC_NAMEDCNT(x);
argsevald = evalList (CDR(args), env);
DEC_NAMEDCNT(x);
y = CAR(argsevald);
if (isObject(y)) ob |= 2;
argsevald = cons_with_tag (x, argsevald, TAG(args));
UNPROTECT(1); /* x */
WAIT_UNTIL_COMPUTED(x);
goto rtrn;
}
}
......@@ -3465,35 +3498,11 @@ static inline SEXP scalar_stack_eval2 (SEXP args, SEXP *arg1, SEXP *arg2,
}
if (isObject(y)) {
if (! (R_variant_result & VARIANT_UNCLASS_FLAG)) {
/* If the second argument is an object, we have to
duplicate the first arg if it is on the scalar stack,
or an unclassed object, and create the list of
evaluated arguments. */
argsevald = scalar_stack_eval2_yobj (x, y, args, env);
x = CAR(argsevald);
y = CADR(argsevald);
ob = 2; /* y is an object, not unclassed */
if (ON_SCALAR_STACK(x) || isObject(x)) /* can't be both */ {
UNPROTECT(1); /* x */
PROTECT(y);
if (ON_SCALAR_STACK(x)) {
POP_SCALAR_STACK(x);
x = duplicate(x);
}
else { /* isObject(x) */
x = Rf_makeUnclassed(x);
}
PROTECT(x);
}
else
PROTECT(y);
/* should not be any more arguments */
argsevald = cons_with_tag (y, R_NilValue, TAG(CDR(args)));
argsevald = cons_with_tag (x, argsevald, TAG(args));
UNPROTECT(2); /* x & y */
WAIT_UNTIL_COMPUTED_2(x,y);
goto rtrn;
}
}
......@@ -4908,8 +4917,7 @@ static SEXP do_subset2(SEXP call, SEXP op, SEXP args, SEXP rho, int variant)
/* Method dispatch has failed, we now */
/* run the generic internal code. */
UNPROTECT(1);
PROTECT(ans);
UNPROTECT_PROTECT(ans);
SEXP x = CAR(ans);
args = CDR(ans);
......
......@@ -711,8 +711,7 @@ static SEXP do_nextmethod (SEXP call, SEXP op, SEXP args, SEXP env,
if (t != R_NilValue && t != R_MissingArg) {
SET_TYPEOF(t, LISTSXP); /* a safe mutation */
s = matchmethargs(matchedarg, t);
UNPROTECT(1);
PROTECT(matchedarg = s);
UNPROTECT_PROTECT(matchedarg = s);
newcall = fixcall(newcall, matchedarg);
}
}
......