static SEXP matchPar_int(const char *tag, SEXP *list, Rboolean exact)
{
if (*list == R_NilValue)
return R_MissingArg;
else if (TAG(*list) != R_NilValue &&
psmatch(tag, CHAR(PRINTNAME(TAG(*list))), exact)) {
SEXP s = *list;
*list = CDR(*list);
return CAR(s);
}
else {
SEXP last = *list;
SEXP next = CDR(*list);
while (next != R_NilValue) {
if (TAG(next) != R_NilValue &&
psmatch(tag, CHAR(PRINTNAME(TAG(next))), exact)) {
SETCDR(last, CDR(next));
return CAR(next);
}
else {
last = next;
next = CDR(next);
}
}
return R_MissingArg;
}
}
SEXP dot_external_access_args(SEXP args) {
args = CDR(args);
int index = 0;
for (; args != R_NilValue; args = CDR(args)) {
index++;
SEXP tag = TAG(args);
const char *name = isNull(tag) ? "" : CHAR(PRINTNAME(tag));
SEXP value = CAR(args);
if (length(value) == 0) {
Rprintf("%d: '%s' length 0\n", index, name);
continue;
}
switch (TYPEOF(value)) {
case LGLSXP:
case INTSXP:
Rprintf("%d: '%s' %d\n", index, name, INTEGER(value)[0]);
break;
case REALSXP:
Rprintf("%d: '%s' %f\n", index, name, REAL(value)[0]);
break;
case CPLXSXP: {
Rcomplex complexValue = COMPLEX(value)[0];
Rprintf("%d: '%s' %f+%fi\n", index, name, complexValue.r,
complexValue.i);
break;
}
case STRSXP:
Rprintf("%d: '%s' %s\n", index, name, CHAR(STRING_ELT(value, 0)));
break;
default:
Rprintf("%d: %s other\n", index, name);
}
}
return R_NilValue;
}
void *
R_getNativeReference(SEXP arg, const char *type, const char *tag)
{
SEXP el = GET_SLOT(arg, Rf_install("ref"));
void *ans;
if(R_ExternalPtrTag(el) != Rf_install(tag)) {
/* So not a direct match. Now see if it is from a derived class
by comparing the value in the object to the name of each of the
ancestor classes.
*/
SEXP ancestors = GET_SLOT(arg, Rf_install("classes"));
int n, i;
n = Rf_length(ancestors);
for(i = 0; i < n ; i ++) {
if(strcmp(CHAR(STRING_ELT(ancestors, i)), tag) == 0)
break;
}
if(i == n) {
PROBLEM "Looking for %s, got %s",
type, CHAR(PRINTNAME(R_ExternalPtrTag(el)))
ERROR;
}
}
ans = R_ExternalPtrAddr(el);
if(!ans) {
PROBLEM "NULL value passed to R_getNativeReference. This may not be an error, but it could be very serious!"
ERROR;
}
return(ans);
}
SEXP attribute_hidden do_makelist(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP list, names, next;
int i, n, havenames;
/* compute number of args and check for names */
for (next = args, n = 0, havenames = FALSE;
next != R_NilValue;
next = CDR(next)) {
if (TAG(next) != R_NilValue)
havenames = TRUE;
n++;
}
PROTECT(list = allocVector(VECSXP, n));
PROTECT(names = havenames ? allocVector(STRSXP, n) : R_NilValue);
for (i = 0; i < n; i++) {
if (havenames) {
if (TAG(args) != R_NilValue)
SET_STRING_ELT(names, i, PRINTNAME(TAG(args)));
else
SET_STRING_ELT(names, i, R_BlankString);
}
if (NAMED(CAR(args)))
INCREMENT_NAMED(CAR(args));
SET_VECTOR_ELT(list, i, CAR(args));
args = CDR(args);
}
if (havenames) {
setAttrib(list, R_NamesSymbol, names);
}
UNPROTECT(2);
return list;
}
/* Convert a DOTSXP into a list of raw promise objects. */
SEXP _dotslist_to_list(SEXP x) {
int i;
SEXP output, names;
int len = length(x);
PROTECT(output = allocVector(VECSXP, len));
PROTECT(names = allocVector(STRSXP, len));
if (len > 0) {
if (TYPEOF(x) != DOTSXP)
error("Expected a ..., got %s", type2char(TYPEOF(x)));
}
for (i = 0; i < len; x=CDR(x), i++) {
if (CAR(x) == R_MissingArg) {
SET_VECTOR_ELT(output, i, emptypromise());
} else {
SET_VECTOR_ELT(output, i, CAR(x));
}
SET_STRING_ELT(names, i, isNull(TAG(x)) ? R_BlankString : PRINTNAME(TAG(x)));
}
if (len > 0) {
setAttrib(output, R_NamesSymbol, names);
}
UNPROTECT(2);
return output;
}
SEXP _dots_names(SEXP dots) {
SEXP names, s;
int i, length;
if ((TYPEOF(dots) == VECSXP) && (LENGTH(dots) == 0))
return R_NilValue;
else if ((TYPEOF(dots) != DOTSXP) && (TYPEOF(dots) != LISTSXP))
error("Expected dotlist or pairlist, got %d", TYPEOF(dots));
length = _dots_length(dots);
int made = 0;
names = R_NilValue;
PROTECT(names = allocVector(STRSXP, length));
for (s = dots, i = 0; i < length; s = CDR(s), i++) {
if (isNull(TAG(s))) {
SET_STRING_ELT(names, i, R_BlankString);
} else {
made = 1;
SET_STRING_ELT(names, i, PRINTNAME(TAG(s)));
}
}
UNPROTECT(1);
return(made ? names : R_NilValue);
}
void *
R_getExternalRef(SEXP obj, const char *className)
{
SEXP ref = GET_SLOT(obj, Rf_install("ref"));
void *ans;
if(TYPEOF(ref) != EXTPTRSXP) {
PROBLEM "Expected external pointer object"
ERROR;
}
if(className && R_ExternalPtrTag(ref) != Rf_install(className)) {
PROBLEM "Expected external pointer to have internal tag %s, got %s",
className, CHAR(PRINTNAME(R_ExternalPtrTag(ref)))
ERROR;
}
ans = R_ExternalPtrAddr(ref);
if(!ans) {
PROBLEM "Got NULL value in reference for %s", className
ERROR;
}
return(ans);
}
/* Returns: */
static
enum pmatch
pstrmatch(SEXP target, SEXP input, size_t slen)
{
const char *st = "";
const void *vmax = vmaxget();
if(target == R_NilValue)
return NO_MATCH;
switch (TYPEOF(target)) {
case SYMSXP:
st = CHAR(PRINTNAME(target));
break;
case CHARSXP:
st = translateChar(target);
break;
}
if(strncmp(st, translateChar(input), slen) == 0) {
vmaxset(vmax);
return (strlen(st) == slen) ? EXACT_MATCH : PARTIAL_MATCH;
} else {
vmaxset(vmax);
return NO_MATCH;
}
}
SEXP showArgs(SEXP args)
{
args = CDR(args); /* skip 'name' */
for(int i = 0; args != R_NilValue; i++, args = CDR(args)) {
const char *name =
isNull(TAG(args)) ? "" : CHAR(PRINTNAME(TAG(args)));
SEXP el = CAR(args);
if (length(el) == 0) {
Rprintf("[%d] '%s' R type, length 0\n", i+1, name);
continue;
}
switch(TYPEOF(el)) {
case REALSXP:
Rprintf("[%d] '%s' %f\n", i+1, name, REAL(el)[0]);
break;
case LGLSXP:
case INTSXP:
Rprintf("[%d] '%s' %d\n", i+1, name, INTEGER(el)[0]);
break;
case CPLXSXP:
{
Rcomplex cpl = COMPLEX(el)[0];
Rprintf("[%d] '%s' %f + %fi\n", i+1, name, cpl.r, cpl.i);
}
break;
case STRSXP:
Rprintf("[%d] '%s' %s\n", i+1, name,
CHAR(STRING_ELT(el, 0)));
break;
default:
Rprintf("[%d] '%s' R type\n", i+1, name);
}
}
return(R_NilValue);
}
SEXP list_as_chr(SEXP x) {
int n = Rf_length(x);
CharacterVector chr(n);
for (int i = 0; i != n; ++i) {
SEXP elt = VECTOR_ELT(x, i);
switch (TYPEOF(elt)) {
case STRSXP:
if (Rf_length(chr) == 1) {
chr[i] = elt;
continue;
}
break;
case SYMSXP:
chr[i] = PRINTNAME(elt);
continue;
default:
break;
}
stop("corrupt grouped data frame");
}
return chr;
}
/* This is a primitive SPECIALSXP */
SEXP attribute_hidden do_expression(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP a, ans, nms;
int i, n, named;
named = 0;
n = length(args);
PROTECT(ans = allocVector(EXPRSXP, n));
a = args;
for (i = 0; i < n; i++) {
if(MAYBE_REFERENCED(CAR(a)))
SET_VECTOR_ELT(ans, i, duplicate(CAR(a)));
else
SET_VECTOR_ELT(ans, i, CAR(a));
if (TAG(a) != R_NilValue) named = 1;
a = CDR(a);
}
if (named) {
PROTECT(nms = allocVector(STRSXP, n));
a = args;
for (i = 0; i < n; i++) {
if (TAG(a) != R_NilValue)
SET_STRING_ELT(nms, i, PRINTNAME(TAG(a)));
else
SET_STRING_ELT(nms, i, R_BlankString);
a = CDR(a);
}
setAttrib(ans, R_NamesSymbol, nms);
UNPROTECT(1);
}
UNPROTECT(1);
return ans;
}
SEXP showArgs(SEXP args)
{
int i, nargs;
Rcomplex cpl;
char *name;
if((nargs = length(args) - 1) > 0) {
for(i = 0; i < nargs; i++) {
args = CDR(args);
name = CHAR(PRINTNAME(TAG(args)));
switch(TYPEOF(CAR(args))) {
case REALSXP:
Rprintf("[%d] '%s' %f\n", i+1, name, REAL(CAR(args))[0]);
break;
case LGLSXP:
case INTSXP:
Rprintf("[%d] '%s' %d\n", i+1, name, INTEGER(CAR(args))[0]);
break;
case CPLXSXP:
cpl = COMPLEX(CAR(args))[0];
Rprintf("[%d] '%s' %f + %fi\n", i+1, name, cpl.r, cpl.i);
break;
case STRSXP:
Rprintf("[%d] '%s' %s\n", i+1, name,
CHAR(STRING_ELT(CAR(args), 0)));
break;
default:
Rprintf("[%d] '%s' R type\n", i+1, name);
}
}
}
return(R_NilValue);
}
Result* get_handler(SEXP call, const ILazySubsets& subsets, const Environment& env) {
LOG_INFO << "Looking up hybrid handler for call of type " << type2name(call);
if (TYPEOF(call) == LANGSXP) {
int depth = Rf_length(call);
HybridHandlerMap& handlers = get_handlers();
SEXP fun_symbol = CAR(call);
if (TYPEOF(fun_symbol) != SYMSXP) {
LOG_VERBOSE << "Not a function: " << type2name(fun_symbol);
return 0;
}
LOG_VERBOSE << "Searching hybrid handler for function " << CHAR(PRINTNAME(fun_symbol));
HybridHandlerMap::const_iterator it = handlers.find(fun_symbol);
if (it == handlers.end()) {
LOG_VERBOSE << "Not found";
return 0;
}
LOG_INFO << "Using hybrid handler for " << CHAR(PRINTNAME(fun_symbol));
return it->second(call, subsets, depth - 1);
} else if (TYPEOF(call) == SYMSXP) {
SymbolString name = SymbolString(Symbol(call));
LOG_VERBOSE << "Searching hybrid handler for symbol " << name.get_cstring();
if (subsets.count(name)) {
LOG_VERBOSE << "Using hybrid variable handler";
return variable_handler(subsets, name);
}
else {
SEXP data = env.find(name.get_string());
// Constants of length != 1 are handled via regular evaluation
if (Rf_length(data) == 1) {
LOG_VERBOSE << "Using hybrid constant handler";
return constant_handler(data);
}
}
} else {
// TODO: perhaps deal with SYMSXP separately
if (Rf_length(call) == 1) return constant_handler(call);
}
return 0;
}
Symbol extract_column( SEXP arg, const Environment& env ){
RObject value ;
if( TYPEOF(arg) == LANGSXP && CAR(arg) == Rf_install("~") ){
if( Rf_length(arg) != 2 || TYPEOF(CADR(arg)) != SYMSXP )
stop( "unhandled formula in column" ) ;
value = CharacterVector::create( PRINTNAME(CADR(arg)) ) ;
} else {
value = Rcpp_eval(arg, env) ;
}
if( is<Symbol>(value) ){
value = CharacterVector::create(PRINTNAME(value)) ;
}
if( !is<String>(value) ){
stop("column must return a single string") ;
}
Symbol res(STRING_ELT(value,0)) ;
return res ;
}
INLINE_FUN Rboolean isUserBinop(SEXP s)
{
if (TYPEOF(s) == SYMSXP) {
const char *str = CHAR(PRINTNAME(s));
if (strlen(str) >= 2 && str[0] == '%' && str[strlen(str)-1] == '%')
return TRUE;
}
return FALSE;
}
static int ParseBrowser(SEXP CExpr, SEXP rho)
{
int rval = 0;
if (isSymbol(CExpr)) {
const char *expr = CHAR(PRINTNAME(CExpr));
if (!strcmp(expr, "c") || !strcmp(expr, "cont")) {
rval = 1;
SET_RDEBUG(rho, 0);
} else if (!strcmp(expr, "f")) {
rval = 1;
RCNTXT *cntxt = R_GlobalContext;
while (cntxt != R_ToplevelContext
&& !(cntxt->callflag & (CTXT_RETURN | CTXT_LOOP))) {
cntxt = cntxt->nextcontext;
}
cntxt->browserfinish = 1;
SET_RDEBUG(rho, 1);
R_BrowserLastCommand = 'f';
} else if (!strcmp(expr, "help")) {
rval = 2;
printBrowserHelp();
} else if (!strcmp(expr, "n")) {
rval = 1;
SET_RDEBUG(rho, 1);
R_BrowserLastCommand = 'n';
} else if (!strcmp(expr, "Q")) {
/* Run onexit/cend code for everything above the target.
The browser context is still on the stack, so any error
will drop us back to the current browser. Not clear
this is a good thing. Also not clear this should still
be here now that jump_to_toplevel is used for the
jump. */
R_run_onexits(R_ToplevelContext);
/* this is really dynamic state that should be managed as such */
SET_RDEBUG(rho, 0); /*PR#1721*/
jump_to_toplevel();
} else if (!strcmp(expr, "s")) {
rval = 1;
SET_RDEBUG(rho, 1);
R_BrowserLastCommand = 's';
} else if (!strcmp(expr, "where")) {
rval = 2;
printwhere();
/* SET_RDEBUG(rho, 1); */
}
}
return rval;
}
/* Are these are always native charset? */
Rboolean pmatch(SEXP formal, SEXP tag, Rboolean exact)
{
const char *f, *t;
const void *vmax = vmaxget();
switch (TYPEOF(formal)) {
case SYMSXP:
f = CHAR(PRINTNAME(formal));
break;
case CHARSXP:
f = CHAR(formal);
break;
case STRSXP:
f = translateChar(STRING_ELT(formal, 0));
break;
default:
goto fail;
}
switch(TYPEOF(tag)) {
case SYMSXP:
t = CHAR(PRINTNAME(tag));
break;
case CHARSXP:
t = CHAR(tag);
break;
case STRSXP:
t = translateChar(STRING_ELT(tag, 0));
break;
default:
goto fail;
}
Rboolean res = psmatch(f, t, exact);
vmaxset(vmax);
return res;
fail:
error(_("invalid partial string match"));
return FALSE;/* for -Wall */
}
void *
R_getNativeReference(SEXP arg, const char *type, const char *tag)
{
SEXP el, elTag;
void *ans;
el = GET_SLOT(arg, Rf_install("ref"));
if(R_isVariableReference(arg)) {
void *tmp;
tmp = getVariableReference(arg, el, type, tag);
if(!tmp) {
PROBLEM "Got null value for variable reference %s", type
ERROR;
}
return(tmp);
}
/* XXX added allow through if the TAG is null on the object. Just for now. */
if(tag && tag[0] && (elTag = R_ExternalPtrTag(el)) && elTag != Rf_install(tag)) {
/* So not a direct match. Now see if it is from a derived class
by comparing the value in the object to the name of each of the
ancestor classes.
*/
SEXP ancestors = GET_SLOT(arg, Rf_install("classes"));
int n, i;
n = Rf_length(ancestors);
for(i = 0; i < n ; i ++) {
if(strcmp(CHAR(STRING_ELT(ancestors, i)), tag) == 0)
break;
}
#ifndef R_REF_NO_CLASS_MATCH_ERROR
if(i == n) {
PROBLEM "Looking for %s, got %s",
tag, elTag != R_NilValue ? CHAR(PRINTNAME(elTag)) : "NULL"
ERROR;
}
#endif
}
ans = R_ExternalPtrAddr(el);
if(!ans) {
PROBLEM "NULL value passed to R_getNativeReference. This may not be an error, but it could be.\n Have you loaded an object from a previous R session?"
ERROR;
}
return(ans);
}
/* character elements corresponding to the syntactic types in the
grammar */
static SEXP lang2str(SEXP obj, SEXPTYPE t)
{
SEXP symb = CAR(obj);
static SEXP if_sym = 0, while_sym, for_sym, eq_sym, gets_sym,
lpar_sym, lbrace_sym, call_sym;
if(!if_sym) {
/* initialize: another place for a hash table */
if_sym = install("if");
while_sym = install("while");
for_sym = install("for");
eq_sym = install("=");
gets_sym = install("<-");
lpar_sym = install("(");
lbrace_sym = install("{");
call_sym = install("call");
}
if(isSymbol(symb)) {
if(symb == if_sym || symb == for_sym || symb == while_sym ||
symb == lpar_sym || symb == lbrace_sym ||
symb == eq_sym || symb == gets_sym)
return PRINTNAME(symb);
}
return PRINTNAME(call_sym);
}
static void memtrace_stack_dump(void)
{
RCNTXT *cptr;
for (cptr = R_GlobalContext; cptr; cptr = cptr->nextcontext) {
if ((cptr->callflag & (CTXT_FUNCTION | CTXT_BUILTIN))
&& TYPEOF(cptr->call) == LANGSXP) {
SEXP fun = CAR(cptr->call);
Rprintf("%s ",
TYPEOF(fun) == SYMSXP ? translateChar(PRINTNAME(fun)) :
"<Anonymous>");
}
}
Rprintf("\n");
}
/* The $ subset operator.
We need to be sure to only evaluate the first argument.
The second will be a symbol that needs to be matched, not evaluated.
*/
SEXP attribute_hidden do_subset3(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP input, nlist, ans;
checkArity(op, args);
/* first translate CADR of args into a string so that we can
pass it down to DispatchorEval and have it behave correctly */
input = PROTECT(allocVector(STRSXP, 1));
nlist = CADR(args);
if (TYPEOF(nlist) == PROMSXP)
nlist = eval(nlist, env);
if(isSymbol(nlist) )
SET_STRING_ELT(input, 0, PRINTNAME(nlist));
else if(isString(nlist) )
SET_STRING_ELT(input, 0, STRING_ELT(nlist, 0));
else {
errorcall(call,_("invalid subscript type '%s'"),
type2char(TYPEOF(nlist)));
}
/* replace the second argument with a string */
/* Previously this was SETCADR(args, input); */
/* which could cause problems when nlist was */
/* ..., as in PR#8718 */
PROTECT(args = CONS(CAR(args), CONS(input, R_NilValue)));
/* If the first argument is an object and there is */
/* an approriate method, we dispatch to that method, */
/* otherwise we evaluate the arguments and fall */
/* through to the generic code below. Note that */
/* evaluation retains any missing argument indicators. */
if(R_DispatchOrEvalSP(call, op, "$", args, env, &ans)) {
UNPROTECT(2); /* input, args */
if (NAMED(ans))
SET_NAMED(ans, 2);
return(ans);
}
UNPROTECT(2); /* input, args */
return R_subset3_dflt(CAR(ans), STRING_ELT(input, 0), call);
}
/*
#define xts_IndexSymbol install("index")
#define xts_ClassSymbol install(".CLASS")
#define xts_IndexFormatSymbol install(".indexFORMAT")
#define xts_IndexClassSymbol install(".indexCLASS")
#define xts_ATTRIB(x) coerceVector(do_xtsAttributes(x),LISTSXP)
*/
SEXP do_xtsAttributes(SEXP x)
{
SEXP a, values, names;
int i=0, P=0;
a = ATTRIB(x);
if(length(a) <= 0)
return R_NilValue;
PROTECT(a); P++; /* all attributes */
PROTECT(values = allocVector(VECSXP, length(a))); P++;
PROTECT(names = allocVector(STRSXP, length(a))); P++;
/*
CAR gets the first element of the dotted pair list
CDR gets the rest of the dotted pair list
TAG gets the symbol/name of the first element of dotted pair list
*/
for( /* a=ATTRIB(a) */; a != R_NilValue; a = CDR(a) ) {
if(TAG(a) != xts_IndexSymbol &&
TAG(a) != xts_ClassSymbol &&
TAG(a) != xts_IndexFormatSymbol &&
TAG(a) != xts_IndexClassSymbol &&
TAG(a) != xts_IndexTZSymbol &&
TAG(a) != R_ClassSymbol &&
TAG(a) != R_DimSymbol &&
TAG(a) != R_DimNamesSymbol &&
TAG(a) != R_NamesSymbol)
{
SET_VECTOR_ELT(values, i, CAR(a));
SET_STRING_ELT(names, i, PRINTNAME(TAG(a)));
i++;
}
}
if(i == 0) {
UNPROTECT(P);
return R_NilValue;
}
/* truncate list back to i-size */
PROTECT(values = lengthgets(values, i)); P++;
PROTECT(names = lengthgets(names, i)); P++;
setAttrib(values, R_NamesSymbol, names);
UNPROTECT(P);
return values;
}
static void callback_closure(char * buf, int buflen, SEXP closure)
{
static char tmp[21];
SEXP formals;
formals = FORMALS(closure);
snprintf(buf, buflen, "R_call %p", (void *) closure);
while ( formals != R_NilValue )
{
if (TAG(formals) == R_DotsSymbol) break;
snprintf(tmp, 20, " %%%s", CHAR(PRINTNAME(TAG(formals))));
tmp[20] = '\0';
if (strlen(buf) + strlen(tmp) >= buflen)
error(_("argument list is too long in tcltk internal function 'callback_closure'"));
strcat(buf, tmp);
formals = CDR(formals);
}
}
SEXP rpy_list_attr(SEXP sexp)
{
SEXP attrs, res;
int nvalues, attr_i;
attrs = ATTRIB(sexp);
nvalues = GET_LENGTH(attrs);
PROTECT(res = allocVector(STRSXP, nvalues));
attr_i = 0;
while (attrs != R_NilValue) {
if (TAG(attrs) == R_NilValue)
SET_STRING_ELT(res, attr_i, R_BlankString);
else
SET_STRING_ELT(res, attr_i, PRINTNAME(TAG(attrs)));
attrs = CDR(attrs);
attr_i++;
}
UNPROTECT(1);
return res;
}
/*
Utility function to make a wrap sexp like `names(call)` when none exists
already; uses the symbol if it is one known to have an accessor function,
otherwise `attr(call, "x")`.
*/
SEXP ALIKEC_attr_wrap(SEXP tag, SEXP call) {
if(TYPEOF(tag) != SYMSXP) error("attr_wrap only valid with tags");
SEXP wrap = PROTECT(allocVector(VECSXP, 2));
// Tags with accessor functions
if(
tag == R_NamesSymbol || tag == R_ClassSymbol || tag == R_TspSymbol ||
tag == R_RowNamesSymbol || tag == R_DimNamesSymbol || tag == R_DimSymbol ||
tag == R_LevelsSymbol
) {
SET_VECTOR_ELT(wrap, 0, lang2(tag, call));
} else {
SEXP tag_name = PROTECT(allocVector(STRSXP, 1));
SET_STRING_ELT(tag_name, 0, PRINTNAME(tag));
SET_VECTOR_ELT(wrap, 0, lang3(ALIKEC_SYM_attr, call, tag_name));
UNPROTECT(1);
}
SET_VECTOR_ELT(wrap, 1, CDR(VECTOR_ELT(wrap, 0)));
UNPROTECT(1);
return wrap;
}
static void namewalk(SEXP s, NameWalkData *d)
{
SEXP name;
switch(TYPEOF(s)) {
case SYMSXP:
name = PRINTNAME(s);
/* skip blank symbols */
if(CHAR(name)[0] == '\0') goto ignore;
if(d->ItemCounts < d->MaxCount) {
if(d->StoreValues) {
if(d->UniqueNames) {
for(int j = 0 ; j < d->ItemCounts ; j++) {
if(STRING_ELT(d->ans, j) == name)
goto ignore;
}
}
SET_STRING_ELT(d->ans, d->ItemCounts, name);
}
d->ItemCounts++;
}
ignore:
break;
case LANGSXP:
if(!d->IncludeFunctions) s = CDR(s);
while(s != R_NilValue) {
namewalk(CAR(s), d);
s = CDR(s);
}
break;
case EXPRSXP:
for(R_xlen_t i = 0 ; i < XLENGTH(s) ; i++)
namewalk(XVECTOR_ELT(s, i), d);
break;
default:
/* it seems the intention is to do nothing here! */
break;
}
}
// Collect vectors in an argList, unfolding the first level of data.frames
// 1 PROTECT
void argsColCollect(SEXP args, int colCount, SEXP** colSexp, SEXP* colNames) {
int j = 0;
SEXP column;
SEXP subNames;
(*colSexp) = Calloc(colCount, SEXP);
PROTECT((*colNames) = allocVector(STRSXP, colCount));
for(; args != R_NilValue; args = CDR(args)) {
column = CAR(args);
switch(TYPEOF(column)) {
case INTSXP: case REALSXP: case LGLSXP: case STRSXP:
// Individual vectors
(*colSexp)[j] = column;
if(isNull(TAG(args))) {
SET_STRING_ELT((*colNames), j, mkChar("<unknown>"));
} else {
SET_STRING_ELT((*colNames), j, PRINTNAME(TAG(args)));
}
j++;
break;
case VECSXP:
// List
subNames = getAttrib(column, R_NamesSymbol);
for(R_len_t i = 0; i < length(column); i++) {
switch(TYPEOF(VECTOR_ELT(column, i))) {
case INTSXP: case REALSXP: case LGLSXP: case STRSXP:
(*colSexp)[j] = VECTOR_ELT(column, i);
SET_STRING_ELT((*colNames), j, STRING_ELT(subNames, i));
j++;
break;
default:
error("Unhandled column type (sub level)");
}
}
break;
default:
error("Unhandled column type (top level)");
}
}
}
void* checkExternalPointer(SEXP xp_, const char* valid_tag) {
if(xp_ == R_NilValue) {
throw std::logic_error("External pointer is NULL.");
}
if(TYPEOF(xp_) != EXTPTRSXP) {
throw std::logic_error("Not an external pointer.");
}
if(R_ExternalPtrTag(xp_)==R_NilValue) {
throw std::logic_error("External pointer tag is NULL.");
}
const char* xp_tag = CHAR(PRINTNAME(R_ExternalPtrTag(xp_)));
if(!xp_tag) {
throw std::logic_error("External pointer tag is blank.");
}
if(strcmp(xp_tag,valid_tag) != 0) {
throw std::logic_error("External pointer tag does not match.");
}
if(R_ExternalPtrAddr(xp_)==NULL) {
throw std::logic_error("External pointer address is null.");
}
return R_ExternalPtrAddr(xp_);
}
/* used in eval.c */
SEXP attribute_hidden R_subset3_dflt(SEXP x, SEXP input, SEXP call)
{
SEXP y, nlist;
size_t slen;
PROTECT(input);
PROTECT(x);
/* Optimisation to prevent repeated recalculation */
slen = strlen(translateChar(input));
/* The mechanism to allow a class extending "environment" */
if( IS_S4_OBJECT(x) && TYPEOF(x) == S4SXP ){
x = R_getS4DataSlot(x, ANYSXP);
if(x == R_NilValue)
errorcall(call, "$ operator not defined for this S4 class");
}
UNPROTECT(1); /* x */
PROTECT(x);
/* If this is not a list object we return NULL. */
if (isPairList(x)) {
SEXP xmatch = R_NilValue;
int havematch;
UNPROTECT(2); /* input, x */
havematch = 0;
for (y = x ; y != R_NilValue ; y = CDR(y)) {
switch(pstrmatch(TAG(y), input, slen)) {
case EXACT_MATCH:
y = CAR(y);
if (NAMED(x) > NAMED(y)) SET_NAMED(y, NAMED(x));
return y;
case PARTIAL_MATCH:
havematch++;
xmatch = y;
break;
case NO_MATCH:
break;
}
}
if (havematch == 1) { /* unique partial match */
if(R_warn_partial_match_dollar) {
const char *st = "";
SEXP target = TAG(xmatch);
switch (TYPEOF(target)) {
case SYMSXP:
st = CHAR(PRINTNAME(target));
break;
case CHARSXP:
st = translateChar(target);
break;
}
warningcall(call, _("partial match of '%s' to '%s'"),
translateChar(input), st);
}
y = CAR(xmatch);
if (NAMED(x) > NAMED(y)) SET_NAMED(y, NAMED(x));
return y;
}
return R_NilValue;
}
else if (isVectorList(x)) {
R_xlen_t i, n, imatch = -1;
int havematch;
nlist = getAttrib(x, R_NamesSymbol);
UNPROTECT(2); /* input, x */
n = xlength(nlist);
havematch = 0;
for (i = 0 ; i < n ; i = i + 1) {
switch(pstrmatch(STRING_ELT(nlist, i), input, slen)) {
case EXACT_MATCH:
y = VECTOR_ELT(x, i);
if (NAMED(x) > NAMED(y))
SET_NAMED(y, NAMED(x));
return y;
case PARTIAL_MATCH:
havematch++;
if (havematch == 1) {
/* partial matches can cause aliasing in eval.c:evalseq
This is overkill, but alternative ways to prevent
the aliasing appear to be even worse */
y = VECTOR_ELT(x,i);
SET_NAMED(y,2);
SET_VECTOR_ELT(x,i,y);
}
imatch = i;
break;
case NO_MATCH:
break;
}
}
if(havematch == 1) { /* unique partial match */
if(R_warn_partial_match_dollar) {
const char *st = "";
SEXP target = STRING_ELT(nlist, imatch);
switch (TYPEOF(target)) {
case SYMSXP:
st = CHAR(PRINTNAME(target));
break;
case CHARSXP:
st = translateChar(target);
break;
}
warningcall(call, _("partial match of '%s' to '%s'"),
translateChar(input), st);
}
y = VECTOR_ELT(x, imatch);
if (NAMED(x) > NAMED(y)) SET_NAMED(y, NAMED(x));
return y;
}
return R_NilValue;
}
else if( isEnvironment(x) ){
y = findVarInFrame(x, installTrChar(input));
if( TYPEOF(y) == PROMSXP ) {
PROTECT(y);
y = eval(y, R_GlobalEnv);
UNPROTECT(1); /* y */
}
UNPROTECT(2); /* input, x */
if( y != R_UnboundValue ) {
if (NAMED(y))
SET_NAMED(y, 2);
else if (NAMED(x) > NAMED(y))
SET_NAMED(y, NAMED(x));
return(y);
}
return R_NilValue;
}
else if( isVectorAtomic(x) ){
errorcall(call, "$ operator is invalid for atomic vectors");
}
else /* e.g. a function */
errorcall(call, R_MSG_ob_nonsub, type2char(TYPEOF(x)));
UNPROTECT(2); /* input, x */
return R_NilValue;
}
void print(std::ostream& out, bool) {
out << CHAR(PRINTNAME(name)) << "@";
env->printRef(out);
}
