/*
* R : A Computer Language for Statistical Data Analysis
* Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka
* Copyright (C) 1999-2006 The R Development Core Team.
*
* 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
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU Lesser General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
*/
/* this header is always to be included from others.
It is only called if COMPILING_R is defined (in util.c) or
from GNU C systems.
There are different comventions for inlining across compilation units.
We pro tem only use the GCC one. See
http://www.greenend.org.uk/rjk/2003/03/inline.html
*/
#ifndef R_INLINES_H_
#define R_INLINES_H_
#ifndef COMPILING_R /* defined only in util.c */
# define INLINE_FUN extern R_INLINE
#else
# define INLINE_FUN
#endif
/* define inline-able functions */
/* from dstruct.c */
/* mkChar - make a character (CHARSXP) variable */
INLINE_FUN SEXP mkChar(const char *name)
{
SEXP c = allocString(strlen(name));
strcpy(CHAR(c), name);
return c;
}
/* length - length of objects */
int Rf_envlength(SEXP rho);
INLINE_FUN R_len_t length(SEXP s)
{
int i;
switch (TYPEOF(s)) {
case NILSXP:
return 0;
case LGLSXP:
case INTSXP:
case REALSXP:
case CPLXSXP:
case STRSXP:
case CHARSXP:
case VECSXP:
case EXPRSXP:
case RAWSXP:
return LENGTH(s);
case LISTSXP:
case LANGSXP:
case DOTSXP:
i = 0;
while (s != NULL && s != R_NilValue) {
i++;
s = CDR(s);
}
return i;
case ENVSXP:
return Rf_envlength(s);
default:
return 1;
}
}
/* from list.c */
/* Return a dotted pair with the given CAR and CDR. */
/* The (R) TAG slot on the cell is set to NULL. */
/* Get the i-th element of a list */
INLINE_FUN SEXP elt(SEXP list, int i)
{
int j;
SEXP result = list;
if ((i < 0) || (i > length(list)))
return R_NilValue;
else
for (j = 0; j < i; j++)
result = CDR(result);
return CAR(result);
}
/* Return the last element of a list */
INLINE_FUN SEXP lastElt(SEXP list)
{
SEXP result = R_NilValue;
while (list != R_NilValue) {
result = list;
list = CDR(list);
}
return result;
}
/* Shorthands for creating small lists */
INLINE_FUN SEXP list1(SEXP s)
{
return CONS(s, R_NilValue);
}
INLINE_FUN SEXP list2(SEXP s, SEXP t)
{
PROTECT(s);
s = CONS(s, list1(t));
UNPROTECT(1);
return s;
}
INLINE_FUN SEXP list3(SEXP s, SEXP t, SEXP u)
{
PROTECT(s);
s = CONS(s, list2(t, u));
UNPROTECT(1);
return s;
}
INLINE_FUN SEXP list4(SEXP s, SEXP t, SEXP u, SEXP v)
{
PROTECT(s);
s = CONS(s, list3(t, u, v));
UNPROTECT(1);
return s;
}
/* Destructive list append : See also ``append'' */
INLINE_FUN SEXP listAppend(SEXP s, SEXP t)
{
SEXP r;
if (s == R_NilValue)
return t;
r = s;
while (CDR(r) != R_NilValue)
r = CDR(r);
SETCDR(r, t);
return s;
}
/* Language based list constructs. These are identical to the list */
/* constructs, but the results can be evaluated. */
/* Return a (language) dotted pair with the given car and cdr */
INLINE_FUN SEXP lcons(SEXP car, SEXP cdr)
{
SEXP e = cons(car, cdr);
SET_TYPEOF(e, LANGSXP);
return e;
}
INLINE_FUN SEXP lang1(SEXP s)
{
return LCONS(s, R_NilValue);
}
INLINE_FUN SEXP lang2(SEXP s, SEXP t)
{
PROTECT(s);
s = LCONS(s, list1(t));
UNPROTECT(1);
return s;
}
INLINE_FUN SEXP lang3(SEXP s, SEXP t, SEXP u)
{
PROTECT(s);
s = LCONS(s, list2(t, u));
UNPROTECT(1);
return s;
}
INLINE_FUN SEXP lang4(SEXP s, SEXP t, SEXP u, SEXP v)
{
PROTECT(s);
s = LCONS(s, list3(t, u, v));
UNPROTECT(1);
return s;
}
/* from util.c */
/* Check to see if the arrays "x" and "y" have the identical extents */
INLINE_FUN Rboolean conformable(SEXP x, SEXP y)
{
int i, n;
PROTECT(x = getAttrib(x, R_DimSymbol));
y = getAttrib(y, R_DimSymbol);
UNPROTECT(1);
if ((n = length(x)) != length(y))
return FALSE;
for (i = 0; i < n; i++)
if (INTEGER(x)[i] != INTEGER(y)[i])
return FALSE;
return TRUE;
}
INLINE_FUN Rboolean isString(SEXP s)
{
return (TYPEOF(s) == STRSXP);
}
INLINE_FUN Rboolean isNull(SEXP s)
{
return (s == R_NilValue);
}
INLINE_FUN Rboolean isObject(SEXP s)
{
return OBJECT(s);/* really '1-bit unsigned int' */
}
/* The following should work but as of 06/09/04 it generates warnings about
undeclared IS_S4_OBJECT, in spite of being apparently identical to the handling
of isObject() above ------
INLINE_FUN Rboolean isS4(SEXP s)
{
return IS_S4_OBJECT(s);
}
INLINE_FUN SEXP asS4(SEXP s, Rboolean flag)
{
if(flag == IS_S4_OBJECT(s))
return s;
if(NAMED(s) == 2)
s = duplicate(s);
if(flag) SET_S4_OBJECT(s);
else UNSET_S4_OBJECT(s);
return s;
}
*/
INLINE_FUN Rboolean inherits(SEXP s, char *name)
{
SEXP class;
int i, nclass;
if (isObject(s)) {
class = getAttrib(s, R_ClassSymbol);
nclass = length(class);
for (i = 0; i < nclass; i++) {
if (!strcmp(CHAR(STRING_ELT(class, i)), name))
return TRUE;
}
}
return FALSE;
}
INLINE_FUN Rboolean isValidString(SEXP x)
{
return isString(x) && LENGTH(x) > 0 && !isNull(STRING_ELT(x, 0));
}
/* non-empty ("") valid string :*/
INLINE_FUN Rboolean isValidStringF(SEXP x)
{
return isValidString(x) && CHAR(STRING_ELT(x, 0))[0];
}
INLINE_FUN Rboolean isSymbol(SEXP s)
{
return TYPEOF(s) == SYMSXP;
}
INLINE_FUN Rboolean isUserBinop(SEXP s)
{
if (isSymbol(s)) {
char *str = CHAR(PRINTNAME(s));
if (strlen(str) >= 2 && str[0] == '%' && str[strlen(str)-1] == '%')
return TRUE;
}
return FALSE;
}
INLINE_FUN Rboolean isFunction(SEXP s)
{
return (TYPEOF(s) == CLOSXP ||
TYPEOF(s) == BUILTINSXP ||
TYPEOF(s) == SPECIALSXP);
}
INLINE_FUN Rboolean isPrimitive(SEXP s)
{
return (TYPEOF(s) == BUILTINSXP ||
TYPEOF(s) == SPECIALSXP);
}
INLINE_FUN Rboolean isList(SEXP s)
{
return (s == R_NilValue || TYPEOF(s) == LISTSXP);
}
INLINE_FUN Rboolean isNewList(SEXP s)
{
return (s == R_NilValue || TYPEOF(s) == VECSXP);
}
INLINE_FUN Rboolean isPairList(SEXP s)
{
switch (TYPEOF(s)) {
case NILSXP:
case LISTSXP:
case LANGSXP:
return TRUE;
default:
return FALSE;
}
}
INLINE_FUN Rboolean isVectorList(SEXP s)
{
switch (TYPEOF(s)) {
case VECSXP:
case EXPRSXP:
return TRUE;
default:
return FALSE;
}
}
INLINE_FUN Rboolean isVectorAtomic(SEXP s)
{
switch (TYPEOF(s)) {
case LGLSXP:
case INTSXP:
case REALSXP:
case CPLXSXP:
case STRSXP:
case RAWSXP:
return TRUE;
default: /* including NULL */
return FALSE;
}
}
INLINE_FUN Rboolean isVector(SEXP s)/* === isVectorList() or isVectorAtomic() */
{
switch(TYPEOF(s)) {
case LGLSXP:
case INTSXP:
case REALSXP:
case CPLXSXP:
case STRSXP:
case RAWSXP:
case VECSXP:
case EXPRSXP:
return TRUE;
default:
return FALSE;
}
}
INLINE_FUN Rboolean isFrame(SEXP s)
{
SEXP class;
int i;
if (isObject(s)) {
class = getAttrib(s, R_ClassSymbol);
for (i = 0; i < length(class); i++)
if (!strcmp(CHAR(STRING_ELT(class, i)), "data.frame")) return TRUE;
}
return FALSE;
}
INLINE_FUN Rboolean isExpression(SEXP s)
{
return TYPEOF(s) == EXPRSXP;
}
INLINE_FUN Rboolean isLanguage(SEXP s)
{
return (s == R_NilValue || TYPEOF(s) == LANGSXP);
}
INLINE_FUN Rboolean isMatrix(SEXP s)
{
SEXP t;
if (isVector(s)) {
t = getAttrib(s, R_DimSymbol);
if (TYPEOF(t) == INTSXP && LENGTH(t) == 2)
return TRUE;
}
return FALSE;
}
INLINE_FUN Rboolean isArray(SEXP s)
{
SEXP t;
if (isVector(s)) {
t = getAttrib(s, R_DimSymbol);
if (TYPEOF(t) == INTSXP && LENGTH(t) > 0)
return TRUE;
}
return FALSE;
}
INLINE_FUN Rboolean isTs(SEXP s)
{
return (isVector(s) && getAttrib(s, R_TspSymbol) != R_NilValue);
}
INLINE_FUN Rboolean isLogical(SEXP s)
{
return (TYPEOF(s) == LGLSXP);
}
INLINE_FUN Rboolean isInteger(SEXP s)
{
return (TYPEOF(s) == INTSXP && !inherits(s, "factor"));
}
INLINE_FUN Rboolean isReal(SEXP s)
{
return (TYPEOF(s) == REALSXP);
}
INLINE_FUN Rboolean isComplex(SEXP s)
{
return (TYPEOF(s) == CPLXSXP);
}
INLINE_FUN Rboolean isUnordered(SEXP s)
{
return (TYPEOF(s) == INTSXP
&& inherits(s, "factor")
&& !inherits(s, "ordered"));
}
INLINE_FUN Rboolean isOrdered(SEXP s)
{
return (TYPEOF(s) == INTSXP
&& inherits(s, "factor")
&& inherits(s, "ordered"));
}
INLINE_FUN Rboolean isFactor(SEXP s)
{
return (TYPEOF(s) == INTSXP && inherits(s, "factor"));
}
INLINE_FUN Rboolean isEnvironment(SEXP s)
{
return (TYPEOF(s) == ENVSXP);
}
INLINE_FUN int nlevels(SEXP f)
{
if (!isFactor(f))
return 0;
return LENGTH(getAttrib(f, R_LevelsSymbol));
}
/* Is an object of numeric type. */
/* FIXME: the LGLSXP case should be excluded here
* (really? in many places we affirm they are treated like INTs)*/
INLINE_FUN Rboolean isNumeric(SEXP s)
{
switch(TYPEOF(s)) {
case INTSXP:
if (inherits(s,"factor")) return FALSE;
case LGLSXP:
case REALSXP:
return TRUE;
default:
return FALSE;
}
}
/* As from R 2.4.0 we check that the value is allowed. */
INLINE_FUN SEXP ScalarLogical(int x)
{
SEXP ans = allocVector(LGLSXP, 1);
if (x == NA_LOGICAL) LOGICAL(ans)[0] = NA_LOGICAL;
else LOGICAL(ans)[0] = (x != 0);
return ans;
}
INLINE_FUN SEXP ScalarInteger(int x)
{
SEXP ans = allocVector(INTSXP, 1);
INTEGER(ans)[0] = x;
return ans;
}
INLINE_FUN SEXP ScalarReal(double x)
{
SEXP ans = allocVector(REALSXP, 1);
REAL(ans)[0] = x;
return ans;
}
INLINE_FUN SEXP ScalarComplex(Rcomplex x)
{
SEXP ans = allocVector(CPLXSXP, 1);
COMPLEX(ans)[0] = x;
return ans;
}
INLINE_FUN SEXP ScalarString(SEXP x)
{
SEXP ans;
PROTECT(x);
ans = allocVector(STRSXP, 1);
SET_STRING_ELT(ans, 0, x);
UNPROTECT(1);
return ans;
}
INLINE_FUN SEXP ScalarRaw(Rbyte x)
{
SEXP ans = allocVector(RAWSXP, 1);
RAW(ans)[0] = x;
return ans;
}
/* Check to see if a list can be made into a vector. */
/* it must have every element being a vector of length 1. */
/* BUT it does not exclude 0! */
INLINE_FUN Rboolean isVectorizable(SEXP s)
{
if (isNull(s)) return TRUE;
else if (isNewList(s)) {
int i, n;
n = LENGTH(s);
for (i = 0 ; i < n; i++)
if (!isVector(VECTOR_ELT(s, i)) || LENGTH(VECTOR_ELT(s, i)) > 1)
return FALSE;
return TRUE;
}
else if (isList(s)) {
for ( ; s != R_NilValue; s = CDR(s))
if (!isVector(CAR(s)) || LENGTH(CAR(s)) > 1) return FALSE;
return TRUE;
}
else return FALSE;
}
/* from gram.y */
INLINE_FUN SEXP mkString(const char *s)
{
SEXP t;
PROTECT(t = allocVector(STRSXP, 1));
SET_STRING_ELT(t, 0, mkChar(s));
UNPROTECT(1);
return t;
}
/* from Rmath */
#define Rf_fmin2(x, y) fmin2_int(x, y)
#define Rf_fmax2(x, y) fmax2_int(x, y)
#define Rf_imin2(x, y) imin2_int(x, y)
#define Rf_imax2(x, y) imax2_int(x, y)
#define Rf_fsign(x, y) fsign_int(x, y)
INLINE_FUN double fmin2_int(double x, double y)
{
if (ISNAN(x) || ISNAN(y))
return x + y;
return (x < y) ? x : y;
}
INLINE_FUN double fmax2_int(double x, double y)
{
if (ISNAN(x) || ISNAN(y))
return x + y;
return (x < y) ? y : x;
}
INLINE_FUN int imin2_int(int x, int y)
{
return (x < y) ? x : y;
}
INLINE_FUN int imax2_int(int x, int y)
{
return (x < y) ? y : x;
}
INLINE_FUN double fsign_int(double x, double y)
{
if (ISNAN(x) || ISNAN(y))
return x + y;
return ((y >= 0) ? fabs(x) : -fabs(x));
}
#endif /* R_INLINES_H_ */
syntax highlighted by Code2HTML, v. 0.9.1