Commit 36db3ac8 authored by Radford Neal's avatar Radford Neal

First version released on github

parent 204b861f
......@@ -280,7 +280,8 @@ users, such as cleanups of source code.
48)
49)
49) The evalListKeepMissing function in eval.c now just calls evalList, with
an indicative argument, eliminating code duplication.
50)
......
......@@ -169,11 +169,22 @@
\item **41
\item **42
\item **43
\item **44
\item Many unary and binary primitive functions are now usually
called using a faster internal interface that does not allocate
nodes for a pairlist of evaluated arguments. This change
substantially speeds up some programs.
\item **45
\item The \code{any} and \code{all} primitives have been substantially
speeded up for large vectors.
\item **47
speeded up for large vectors. Also, expressions such as
\code{all(v>0)} and \code{any(is.na(v))} where \code{v} is a
real vector avoid computing and storing a logical vector,
instead computing the result of \code{any} or \code{all}
without this intermediate, looking at only as much of \code{v}
as is needed to determine the result.
\item When \code{sum} is applied to many mathematical functions
of one vector argument, for example \code{sum(log(v))}, the
sum is performed as the function is computed, without a
vector being allocated to hold the function values.
\item **48
\item **49
\item **50
......@@ -404,11 +415,26 @@
\item **9
\item **10
\item **11
\item **12
\item **13
\item **14
\item Fixed a minor error-reporting bug with
\code{(1:2):integer(0)} and similar expressions.
\item Fixed a bug that could lead to mis-identification of the
direction of stack growth on a non-Windows system, causing
stack overflow to not be detected, and a segmentation fault
to occur. (I also reported this bug and how to fix it to the
R Core Team, who included a fix in R-2.15.2.)
\item Fixed a bug where, for example, \code{log(base=4)} returned
the natural log of 4, rather than signalling an error.
\item **15
\item **16
\item Fixed a bug in \code{sum}, where overflow is allowed (and not
detected) where overflow can actually be avoided. For example:
\preformatted{
> v<-c(3L,1000000000L:1010000000L,-(1000000000L:1010000000L))
> sum(v)
[1] 4629
}
Also fixed a related bug in \code{mean}, applied to an integer
vector, which would arise only on a system where a long double
is no bigger than a double.
\item **17
\item Fixed a bug where more than six warning messages at startup
would overwrite random memory, causing garbage output
......
......@@ -1162,6 +1162,24 @@ example, from an ``if'' statement to the evaluation of the chosen
branch, or from a function call to the evaluation of the body of the
function --- with any variant result propagated back.
Primitive functions (objects of type BUILTINSXP and SPECIALSXP) are
implemented using C functions that by convention have names of the
form @code{do_XXX}. These functions are associated with symbols by a
table in @file{names.c}. This table also has other information, such
as whether the primitive is BUILTIN or SPECIAL, and whether the
variant argument of evalv is passed on to the @code{do_XXX} function.
Arguments are passed to the @code{do_XXX} function as a pairlist.
This is inefficient, since it requires that a CONS be allocated for
every argument passed to a primitive. In @pqR{}, a faster interface
is provided for simple cases of unary or binary primitives, in which
the arguments are unnamed, and are not S3 or S4 objects. This
interface is enabled by setting up a @code{do_fast_XXX} function to
handle such simple cases, which receives the arguments of the
primitive directly as C arguments. For details, see the documentation
in the code for @code{evalv}, and the definitions for PRIMFUN_FAST and
related macros in @file{Rinternals.h}.
@comment Just here to help with merging new section later...
@node The write barrier, Serialization Formats, The eval function, R Internal Structures
......
This mod combines several changes, loosely related by their all
reducing interpretive overhead or speeding up primitive functions.
The largest change is that a new scheme is used for quick dispatch of
some unary and binary primitive functions, as described in the
documentation in R-ints.texi. In particular, this mod includes "fast"
versions of the functions implementing the following primitives
(called do_fast_XXX):
arith (+, -, *, /, ^, %%, %/%)
math1 (exp, sin, etc.)
trunc
abs
length
dim
is (is.null, is.integer, etc.)
isna
isnan
isfinite
isinfinite
cmathfuns (Re, Im, etc.)
logic3 (any, all)
colon
seq_len
sum
prod
But note that not all calls of such primitives will use the fast
dispatch mechanism.
The evalListKeepMissing function in eval.c now just calls evalList,
with an indicative argument, eliminating code duplication.
Calls of the R_CheckStack procedure in evalv and other places were
replaced with a macro R_CHECKSTACK, which is faster.
The LOCAL_COPY macro is used in several places to (hopefully) speed up
references to R_NilValue.
Evaluation of .Internal calls now pass on the "variant" desired.
Expressions such as \code{all(v>0)} and \code{any(is.na(v))} where
\code{v} is a real vector now avoid computing and storing a logical
vector, instead computing the result of \code{any} or \code{all}
without this intermediate, looking at only as much of \code{v} as is
needed to determine the result. This is done using the "variant
result" framework.
Similarly, when \code{sum} is applied to many mathematical functions
of one vector argument, for example \code{sum(log(v))}, the sum is
performed as the function is computed, without a vector being
allocated to hold the function values.
Several bugs were fixed, as described in NEWS items. In particular,
int_fast64_t variables are now used to accumulate integer sums for
"sum" and "mean" in order to avoid overflow.
......@@ -852,6 +852,7 @@
do_math4
do_matprod
do_matrix
do_mean
do_memCompress
do_memDecompress
do_memlimits
......
......@@ -690,6 +690,7 @@ void R_SetWin32(Rstart Rp)
/* printf("stackbase %lx, size %lx\n", top, top-bottom); */
R_CStackStart = top;
R_CStackLimit = top - bottom;
R_CStackThreshold = top - (uintptr_t)(0.95*R_CStackLimit);
}
R_CStackDir = 1;
......
......@@ -426,8 +426,25 @@ typedef struct {
#define PPINFO(x) (R_FunTab[PRIMOFFSET(x)].gram)
#define PRIMFUN_FAST(x) ((x)->u.primsxp.primsxp_fast_cfun)
#define SET_PRIMFUN_FAST(x,f) \
((x)->u.primsxp.primsxp_fast_cfun = (f))
#define PRIMFUN_DSPTCH1(x) ((x)->u.primsxp.primsxp_dsptch1)
#define PRIMFUN_DSPTCH2(x) ((x)->u.primsxp.primsxp_dsptch2)
#define PRIMFUN_ARG1VAR(x) ((x)->sxpinfo.gp2 & 0x3fff)
#define PRIMFUN_ARG2VAR(x) ((x)->sxpinfo.gp2 >> 14)
#define PRIMFUN_UNI_TOO(x) ((x)->u.primsxp.primsxp_uni_too)
#define SET_PRIMFUN_FAST_UNARY(x,f,dsptch1,var1) do { \
(x)->u.primsxp.primsxp_fast_cfun = (f); \
(x)->u.primsxp.primsxp_dsptch1 = (dsptch1); \
(x)->sxpinfo.gp2 = (var1); \
} while (0)
#define SET_PRIMFUN_FAST_BINARY(x,f,dsptch1,dsptch2,var1,var2,uni_too) do { \
(x)->u.primsxp.primsxp_fast_cfun = (f); \
(x)->u.primsxp.primsxp_dsptch1 = (dsptch1); \
(x)->u.primsxp.primsxp_dsptch2 = (dsptch2); \
(x)->u.primsxp.primsxp_uni_too = (uni_too); \
(x)->sxpinfo.gp2 = (var1) + ((var2)<<14); \
} while (0)
/* Symbols for eval variants. Return of a variant result is indicated by
the attribute field being R_VariantResult. */
......@@ -678,9 +695,10 @@ extern0 int R_Expressions_keep INI_as(5000); /* options(expressions) */
extern0 Rboolean R_KeepSource INI_as(FALSE); /* options(keep.source) */
extern0 int R_WarnLength INI_as(1000); /* Error/warning max length */
extern0 int R_nwarnings INI_as(50);
extern uintptr_t R_CStackLimit INI_as((uintptr_t)-1); /* C stack limit */
extern uintptr_t R_CStackStart INI_as((uintptr_t)-1); /* Initial stack address */
extern0 uintptr_t R_CStackLimit INI_as((uintptr_t)-1); /* C stack limit */
extern0 uintptr_t R_CStackStart INI_as((uintptr_t)-1); /* Initial stack address */
extern0 int R_CStackDir INI_as(1); /* C stack direction */
extern0 uintptr_t R_CStackThreshold; /* Threshold for overflow detection */
#ifdef R_USE_SIGNALS
extern0 struct RPRSTACK *R_PendingPromises INI_as(NULL); /* Pending promise stack */
......@@ -1059,7 +1077,7 @@ SEXP duplicated3(SEXP, SEXP, Rboolean);
int any_duplicated(SEXP, Rboolean);
int any_duplicated3(SEXP, SEXP, Rboolean);
int envlength(SEXP);
SEXP evalList(SEXP, SEXP, SEXP, int);
SEXP evalList(SEXP, SEXP, SEXP);
SEXP evalListKeepMissing(SEXP, SEXP);
int factorsConform(SEXP, SEXP);
void findcontext(int, SEXP, SEXP);
......@@ -1336,6 +1354,16 @@ extern void *alloca(size_t);
#endif
/* Macro for fast stack checking */
#define R_CHECKSTACK() do { \
int dummy; \
if (R_CStackDir > 0 ? (uintptr_t)&dummy < R_CStackThreshold \
: (uintptr_t)&dummy > R_CStackThreshold) \
R_CheckStack(); \
} while (0)
/* Enable this by defining USE_FAST_PROTECT_MACROS before including Defn.h.
Redefines PROTECT, UNPROTECT, PROTECT_WITH_INDEX, and REPROTECT for speed,
......
......@@ -282,7 +282,7 @@ SEXP do_inherits(SEXP, SEXP, SEXP, SEXP);
SEXP do_inspect(SEXP, SEXP, SEXP, SEXP);
SEXP do_intToUtf8(SEXP, SEXP, SEXP, SEXP);
SEXP do_interactive(SEXP, SEXP, SEXP, SEXP);
SEXP do_internal(SEXP, SEXP, SEXP, SEXP);
SEXP do_internal(SEXP, SEXP, SEXP, SEXP, int);
SEXP do_interruptsSuspended(SEXP, SEXP, SEXP, SEXP);
SEXP do_intToBits(SEXP, SEXP, SEXP, SEXP);
SEXP do_invisible(SEXP, SEXP, SEXP, SEXP);
......@@ -312,7 +312,7 @@ SEXP do_loadFromConn2(SEXP, SEXP, SEXP, SEXP);
SEXP do_loadhistory(SEXP, SEXP, SEXP, SEXP);
SEXP do_localeconv(SEXP, SEXP, SEXP, SEXP);
SEXP do_locator(SEXP, SEXP, SEXP, SEXP);
SEXP do_log(SEXP, SEXP, SEXP, SEXP);
SEXP do_log(SEXP, SEXP, SEXP, SEXP, int);
SEXP do_log1arg(SEXP, SEXP, SEXP, SEXP);
SEXP do_logic(SEXP, SEXP, SEXP, SEXP);
SEXP do_logic2(SEXP, SEXP, SEXP, SEXP);
......@@ -330,6 +330,7 @@ SEXP do_matchcall(SEXP, SEXP, SEXP, SEXP);
SEXP do_matprod(SEXP, SEXP, SEXP, SEXP);
SEXP do_Math2(SEXP, SEXP, SEXP, SEXP);
SEXP do_matrix(SEXP, SEXP, SEXP, SEXP);
SEXP do_mean(SEXP, SEXP, SEXP, SEXP);
SEXP do_memlimits(SEXP, SEXP, SEXP, SEXP);
SEXP do_memoryprofile(SEXP, SEXP, SEXP, SEXP);
SEXP do_menu(SEXP, SEXP, SEXP, SEXP);
......@@ -418,7 +419,7 @@ SEXP do_regexec(SEXP, SEXP, SEXP, SEXP);
SEXP do_regexpr(SEXP, SEXP, SEXP, SEXP);
SEXP do_regFinaliz(SEXP, SEXP, SEXP, SEXP);
SEXP do_relop(SEXP, SEXP, SEXP, SEXP);
SEXP do_relop_dflt(SEXP, SEXP, SEXP, SEXP);
SEXP do_fast_relop(SEXP, SEXP, SEXP, SEXP, SEXP, int);
SEXP do_remove(SEXP, SEXP, SEXP, SEXP);
SEXP do_rep(SEXP, SEXP, SEXP, SEXP);
SEXP do_rep_int(SEXP, SEXP, SEXP, SEXP);
......
......@@ -158,6 +158,10 @@ struct primsxp_struct { /* table offset of this and other info is in gp */
unsigned int primsxp_variant:1; /* pass variant to cfun, from table */
unsigned int primsxp_internal:1;/* call with .Internal flag, from table */
unsigned int primsxp_foreign:1; /* primitive to call C/Fortran function */
/* bits below only for when fast_cfun!=NULL (last 2 only when arity==2) */
unsigned int primsxp_dsptch1:1; /* might dispatch on 1st argument */
unsigned int primsxp_dsptch2:1; /* might dispatch on 2nd argument */
unsigned int primsxp_uni_too:1; /* can be unary as well as binary */
};
struct symsxp_struct {
......
This diff is collapsed.
......@@ -359,20 +359,27 @@ SEXP attribute_hidden do_drop(SEXP call, SEXP op, SEXP args, SEXP rho)
/* Length of Primitive Objects */
static SEXP do_fast_length (SEXP call, SEXP op, SEXP arg, SEXP rho,
int variant)
{
R_len_t len = length(arg);
return ScalarInteger (len <= INT_MAX ? len : NA_INTEGER);
}
SEXP attribute_hidden do_length(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans;
R_len_t len;
checkArity(op, args);
checkArity (op, args);
check1arg_x (args, call);
if(isObject(CAR(args)) && DispatchOrEval(call, op, "length", args,
rho, &ans, 0, 1))
return(ans);
if (DispatchOrEval (call, op, "length", args, rho, &ans, 0, 1))
return(ans);
if (PRIMFUN_FAST(op)==0)
SET_PRIMFUN_FAST_UNARY (op, do_fast_length, 1, 0);
len = length(CAR(args));
return ScalarInteger((len <= INT_MAX) ? len : NA_INTEGER);
return do_fast_length (call, op, CAR(args), rho, 0);
}
......
......@@ -1022,22 +1022,32 @@ SEXP attribute_hidden do_dimnames(SEXP call, SEXP op, SEXP args, SEXP env)
return ans;
}
static SEXP do_fast_dim (SEXP call, SEXP op, SEXP arg, SEXP env, int variant)
{
return getAttrib (arg, R_DimSymbol);
}
SEXP attribute_hidden do_dim(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP ans;
checkArity(op, args);
check1arg_x (args, call);
if (DispatchOrEval(call, op, "dim", args, env, &ans, 0, 1))
return(ans);
PROTECT(args = ans);
ans = getAttrib(CAR(args), R_DimSymbol);
UNPROTECT(1);
return ans;
if (PRIMFUN_FAST(op)==0)
SET_PRIMFUN_FAST_UNARY (op, do_fast_dim, 1, 0);
return do_fast_dim (call, op, CAR(args), env, 0);
}
SEXP attribute_hidden do_dimgets(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP ans, x;
LOCAL_COPY(R_NilValue);
checkArity(op, args);
if (DispatchOrEval(call, op, "dim<-", args, env, &ans, 0, 1))
return(ans);
......@@ -1094,6 +1104,7 @@ SEXP dimgets(SEXP vec, SEXP val)
SEXP attribute_hidden do_attributes(SEXP call, SEXP op, SEXP args, SEXP env)
{
LOCAL_COPY(R_NilValue);
SEXP attrs, names, namesattr, value;
int nvalues;
......@@ -1168,6 +1179,7 @@ SEXP attribute_hidden do_attributesgets(SEXP call, SEXP op, SEXP args, SEXP env)
/* brought to the front of the list. This ensures that when both */
/* "dim" and "dimnames" are set that the "dim" is attached first. */
LOCAL_COPY(R_NilValue);
SEXP object, attrs, names = R_NilValue /* -Wall */;
int i, i0 = -1, nattrs;
......@@ -1270,6 +1282,7 @@ fairly minor. LT */
SEXP attribute_hidden do_attr(SEXP call, SEXP op, SEXP args, SEXP env)
{
LOCAL_COPY(R_NilValue);
SEXP argList, s, t, tag = R_NilValue, alist, ans;
const char *str;
size_t n;
......
This diff is collapsed.
......@@ -288,17 +288,12 @@ SEXP attribute_hidden complex_binary(ARITHOP_TYPE code, SEXP s1, SEXP s2)
return ans;
}
SEXP attribute_hidden do_cmathfuns(SEXP call, SEXP op, SEXP args, SEXP env)
static SEXP do_fast_cmathfuns (SEXP call, SEXP op, SEXP x, SEXP env,
int variant)
{
SEXP x, y = R_NilValue; /* -Wall*/
SEXP y = R_NilValue; /* -Wall*/
int i, n;
checkArity(op, args);
check1arg(args, call, "z");
if (DispatchGroup("Complex", call, op, args, env, &x))
return x;
x = CAR(args);
if (isComplex(x)) {
n = LENGTH(x);
switch(PRIMVAL(op)) {
......@@ -385,6 +380,22 @@ SEXP attribute_hidden do_cmathfuns(SEXP call, SEXP op, SEXP args, SEXP env)
return y;
}
SEXP attribute_hidden do_cmathfuns(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP ans;
checkArity(op, args);
check1arg(args, call, "z");
if (DispatchGroup("Complex", call, op, args, env, &ans))
return ans;
if (PRIMFUN_FAST(op)==0)
SET_PRIMFUN_FAST_UNARY (op, do_fast_cmathfuns, 1, 0);
return do_fast_cmathfuns (call, op, CAR(args), env, 0);
}
/* used in format.c and printutils.c */
#define MAX_DIGITS 22
void attribute_hidden z_prec_r(Rcomplex *r, Rcomplex *x, double digits)
......@@ -641,7 +652,6 @@ SEXP attribute_hidden complex_math1(SEXP call, SEXP op, SEXP args, SEXP env)
PROTECT(y = allocVector(CPLXSXP, n));
switch (PRIMVAL(op)) {
case 10003: naflag = cmath1(clog, COMPLEX(x), COMPLEX(y), n); break;
case 3: naflag = cmath1(csqrt, COMPLEX(x), COMPLEX(y), n); break;
case 10: naflag = cmath1(cexp, COMPLEX(x), COMPLEX(y), n); break;
case 20: naflag = cmath1(ccos, COMPLEX(x), COMPLEX(y), n); break;
......@@ -658,6 +668,12 @@ SEXP attribute_hidden complex_math1(SEXP call, SEXP op, SEXP args, SEXP env)
case 35: naflag = cmath1(z_atanh, COMPLEX(x), COMPLEX(y), n); break;
default:
/* log put here in case the compiler handles a sparse switch poorly */
if (PRIMVAL(op) == 10003) {
naflag = cmath1(clog, COMPLEX(x), COMPLEX(y), n);
break;
}
/* such as sign, gamma */
errorcall(call, _("unimplemented complex function"));
}
......
......@@ -564,7 +564,7 @@ static Rboolean file_open(Rconnection con)
if(con->enc == CE_UTF8) {
int n = strlen(name);
wchar_t wname[2 * (n+1)], wmode[10];
R_CheckStack();
R_CHECKSTACK();
Rf_utf8towcs(wname, name, n+1);
mbstowcs(wmode, con->mode, 10);
fp = _wfopen(wname, wmode);
......@@ -1046,7 +1046,7 @@ static Rboolean pipe_open(Rconnection con)
if(con->enc == CE_UTF8) {
int n = strlen(con->description);
wchar_t wname[2 * (n+1)], wmode[10];
R_CheckStack();
R_CHECKSTACK();
Rf_utf8towcs(wname, con->description, n+1);
mbstowcs(wmode, con->mode, 10);
fp = _wpopen(wname, wmode);
......
......@@ -149,9 +149,9 @@ please bug.report() [R_run_onexits]"));
we need to make sure there is enough room on the
evaluation stack in case the jump is from handling a
stack overflow. To be safe it is good to also call
R_CheckStack. LT */
R_CHECKSTACK. LT */
R_Expressions = R_Expressions_keep + 500;
R_CheckStack();
R_CHECKSTACK();
eval(s, c->cloenv);
UNPROTECT(1);
}
......
......@@ -2011,7 +2011,7 @@ R_isMissing(SEXP symbol, SEXP rho)
return 1;
/* check for infinite recursion */
R_CheckStack();
R_CHECKSTACK();
if (DDVAL(symbol)) {
s = R_DotsSymbol;
......
......@@ -75,27 +75,41 @@ static char * R_ConciseTraceback(SEXP call, int skip);
static void reset_stack_limit(void *data)
{
unsigned int *limit = (unsigned int *) data;
R_CStackLimit = *limit;
uintptr_t *limit = (uintptr_t *) data;
R_CStackLimit = limit[0];
R_CStackThreshold = limit[1];
}
void R_CheckStack(void)
{
if (R_CStackLimit == -1)
return;
int dummy;
intptr_t usage = R_CStackDir * (R_CStackStart - (uintptr_t)&dummy);
uintptr_t usage = R_CStackDir > 0 ? R_CStackStart - (uintptr_t)&dummy
: (uintptr_t)&dummy - R_CStackStart;
/* printf("usage %ld\n", usage); */
if(R_CStackLimit != -1 && usage > 0.95 * R_CStackLimit) {
if (usage > 0.95 * R_CStackLimit) {
#if 0 /* enable for debugging */
printf ("stack usage limit reached: %lu, dummy %lx, threshold %lx\n",
usage, (uintptr_t)&dummy, R_CStackThreshold);
#endif
/* We do need some stack space to process error recovery,
so temporarily raise the limit.
*/
RCNTXT cntxt;
unsigned int stacklimit = R_CStackLimit;
uintptr_t stacklimit[2];
stacklimit[0] = R_CStackLimit;
stacklimit[1] = R_CStackThreshold;
R_CStackLimit += 0.05*R_CStackLimit;
if (R_CStackDir < 0)
R_CStackThreshold += (uintptr_t) (0.05*R_CStackLimit);
else
R_CStackThreshold -= (uintptr_t) (0.05*R_CStackLimit);
begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_BaseEnv, R_BaseEnv,
R_NilValue, R_NilValue);
cntxt.cend = &reset_stack_limit;
cntxt.cenddata = &stacklimit;
cntxt.cenddata = stacklimit;
errorcall(R_NilValue, "C stack usage is too close to the limit");
/* Do not translate this, to save stack space */
......@@ -104,7 +118,7 @@ void R_CheckStack(void)
void R_CheckUserInterrupt(void)
{
R_CheckStack();
R_CHECKSTACK();
/* Don't do any processing of interrupts, timing limits, or other
asynchronous events if interrupts are suspended. */
......@@ -879,7 +893,7 @@ SEXP attribute_hidden do_gettext(SEXP call, SEXP op, SEXP args, SEXP rho)
}
if(strlen(domain)) {
buf = (char *) alloca(strlen(domain)+3);
R_CheckStack();
R_CHECKSTACK();
sprintf(buf, "R-%s", domain);
domain = buf;
}
......@@ -894,7 +908,7 @@ SEXP attribute_hidden do_gettext(SEXP call, SEXP op, SEXP args, SEXP rho)
const char * This = translateChar(STRING_ELT(string, i));
char *tmp, *head = NULL, *tail = NULL, *p, *tr;
tmp = (char *) alloca(strlen(This) + 1);
R_CheckStack();
R_CHECKSTACK();
strcpy(tmp, This);
/* strip leading and trailing white spaces and
add back after translation */
......@@ -903,7 +917,7 @@ SEXP attribute_hidden do_gettext(SEXP call, SEXP op, SEXP args, SEXP rho)
p++, ihead++) ;
if(ihead > 0) {
head = (char *) alloca(ihead + 1);
R_CheckStack();
R_CHECKSTACK();
strncpy(head, tmp, ihead);
head[ihead] = '\0';
tmp += ihead;
......@@ -914,7 +928,7 @@ SEXP attribute_hidden do_gettext(SEXP call, SEXP op, SEXP args, SEXP rho)
p--, itail++) ;
if(itail > 0) {
tail = (char *) alloca(itail + 1);
R_CheckStack();
R_CHECKSTACK();
strcpy(tail, tmp+strlen(tmp)-itail);
tmp[strlen(tmp)-itail] = '\0';
}
......@@ -924,7 +938,7 @@ SEXP attribute_hidden do_gettext(SEXP call, SEXP op, SEXP args, SEXP rho)
#endif
tr = dgettext(domain, tmp);
tmp = (char *) alloca(strlen(tr) + ihead + itail + 1);
R_CheckStack();
R_CHECKSTACK();
tmp[0] ='\0';
if(ihead > 0) strcat(tmp, head);
strcat(tmp, tr);
......@@ -980,7 +994,7 @@ SEXP attribute_hidden do_ngettext(SEXP call, SEXP op, SEXP args, SEXP rho)
}
if(strlen(domain)) {
buf = (char *) alloca(strlen(domain)+3);
R_CheckStack();
R_CHECKSTACK();
sprintf(buf, "R-%s", domain);
domain = buf;
}
......
This diff is collapsed.
......@@ -4401,7 +4401,7 @@ static SEXP mkStringUTF8(const ucs_t *wcs, int cnt)
nb = cnt*6;
#endif
char s[nb];
R_CheckStack();
R_CHECKSTACK();
memset(s, 0, nb); /* safety */
#ifdef WC_NOT_UNICODE
{
......
......@@ -103,11 +103,11 @@ static SEXP mkCharWLen(const wchar_t *wc, int nc)
{
int nb; char *xi; wchar_t *wt;
wt = (wchar_t *) alloca((nc+1)*sizeof(wchar_t));
R_CheckStack();
R_CHECKSTACK();
wcsncpy(wt, wc, nc); wt[nc] = 0;
nb = wcstoutf8(NULL, wt, nc);
xi = (char *) alloca((nb+1)*sizeof(char));
R_CheckStack();
R_CHECKSTACK();
wcstoutf8(xi, wt, nb + 1);
return mkCharLenCE(xi, nb, CE_UTF8);
}
......@@ -1370,13 +1370,13 @@ char *pcre_string_adj(char *target, const char *orig, const char *repl,
char *xi, *p;
wchar_t *wc;
p = xi = (char *) alloca((nb+1)*sizeof(char));
R_CheckStack();
R_CHECKSTACK();
for (j = 0; j < nb; j++) *p++ = orig[ovec[2*k]+j];
*p = '\0';
nc = utf8towcs(NULL, xi, 0);
if (nc >= 0) {
wc = (wchar_t *) alloca((nc+1)*sizeof(wchar_t));
R_CheckStack();
R_CHECKSTACK();
utf8towcs(wc, xi, nc + 1);
for (j = 0; j < nc; j++) wc[j] = towctrans(wc[j], tr);
nb = wcstoutf8(NULL, wc, 0);
......@@ -1884,7 +1884,7 @@ SEXP attribute_hidden do_gsub(SEXP call, SEXP op, SEXP args, SEXP env)
static int getNc(const char *s, int st)
{
char *buf = alloca(st+1);
R_CheckStack();
R_CHECKSTACK();
memcpy(buf, s, st);
buf[st] = '\0';
return utf8towcs(NULL, buf, 0);
......
......@@ -32,38 +32,45 @@
#include "Defn.h"
static SEXP lunary(SEXP, SEXP, SEXP);
static SEXP lbinary(SEXP, SEXP, SEXP);
static SEXP lunary (SEXP, SEXP, SEXP, SEXP, int);
static SEXP lbinary (SEXP, SEXP, SEXP, SEXP, SEXP, int);
static SEXP binaryLogic(int code, SEXP s1, SEXP s2);
static SEXP binaryLogic2(int code, SEXP s1, SEXP s2);
/* & | ! */
SEXP attribute_hidden do_logic(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP ans;
if (DispatchGroup("Ops",call, op, args, env, &ans))
return ans;
if (PRIMFUN_FAST(op)==0) {
if (PRIMARITY(op) == 1) /* ! */
SET_PRIMFUN_FAST_UNARY (op, lunary, 1, 0);
else /* & and | */
SET_PRIMFUN_FAST_BINARY (op, lbinary, 1, 1, 0, 0, 0);
}
switch (length(args)) {
case 1:
return lunary(call, op, CAR(args));
return lunary(call, op, CAR(args), env, 0);
case 2:
return lbinary(call, op, args);
return lbinary(call, op, CAR(args), CADR(args), env, 0);
default:
error(_("binary operations require two arguments"));
return R_NilValue; /* for -Wall */
}
}
static SEXP lbinary(SEXP call, SEXP op, SEXP args)
static SEXP lbinary(SEXP call, SEXP op, SEXP x, SEXP y, SEXP env, int variant)
{
/* logical binary : "&" or "|" */
SEXP x, y, dims, tsp, klass, xnames, ynames;
SEXP dims, tsp, klass, xnames, ynames;
int mismatch, nx, ny, xarray, yarray, xts, yts;
mismatch = 0;
x = CAR(args);
y = CADR(args);
if (isRaw(x) && isRaw(y)) {
}
else if (!isNumber(x) || !isNumber(y))
......@@ -125,18 +132,21 @@ static SEXP lbinary(SEXP call, SEXP op, SEXP args)
warningcall(call,
_("longer object length is not a multiple of shorter object length"));
if (isRaw(x) && isRaw(y)) {
if (isLogical(x) && isLogical(y))
PROTECT(x = binaryLogic(PRIMVAL(op), x, y));
else if (isRaw(x) && isRaw(y))
PROTECT(x = binaryLogic2(PRIMVAL(op), x, y));
} else {
else {
if (!isNumber(x) || !isNumber(y))
errorcall(call,