SEXP attribute_hidden do_islistfactor(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP X;
Rboolean lans = TRUE, recursive;
int i, n;
checkArity(op, args);
X = CAR(args);
recursive = CXXRCONSTRUCT(Rboolean, asLogical(CADR(args)));
n = length(X);
if(n == 0 || !isVectorList(X)) {
lans = FALSE;
goto do_ans;
}
if(!recursive) {
for(i = 0; i < LENGTH(X); i++)
if(!isFactor(VECTOR_ELT(X, i))) {
lans = FALSE;
break;
}
} else {
switch(TYPEOF(X)) {
case VECSXP:
for(i = 0; i < LENGTH(X); i++)
if(!islistfactor(VECTOR_ELT(X, i))) {
lans = FALSE;
break;
}
break;
case EXPRSXP:
for(i = 0; i < LENGTH(X); i++)
if(!islistfactor(XVECTOR_ELT(X, i))) {
lans = FALSE;
break;
}
break;
default:
break;
}
}
do_ans:
return ScalarLogical(lans);
}
static Rboolean islistfactor(SEXP X)
{
int i, n = length(X);
if(n == 0) return FALSE;
switch(TYPEOF(X)) {
case VECSXP:
for(i = 0; i < LENGTH(X); i++)
if(!islistfactor(VECTOR_ELT(X, i))) return FALSE;
return TRUE;
break;
case EXPRSXP:
for(i = 0; i < LENGTH(X); i++)
if(!islistfactor(XVECTOR_ELT(X, i))) return FALSE;
return TRUE;
break;
default: // -Wswitch
break;
}
return isFactor(X);
}
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;
}
}
SEXP do_edit(SEXP call, SEXP op, SEXP args, SEXP rho)
{
int i, rc;
ParseStatus status;
SEXP x, fn, envir, ed, src, srcfile, Rfn;
char *filename, *editcmd;
const char *cmd;
const void *vmaxsave;
FILE *fp;
#ifdef Win32
SEXP ti;
char *title;
#endif
checkArity(op, args);
vmaxsave = vmaxget();
x = CAR(args); args = CDR(args);
if (TYPEOF(x) == CLOSXP) envir = CLOENV(x);
else envir = R_NilValue;
PROTECT(envir);
fn = CAR(args); args = CDR(args);
if (!isString(fn))
error(_("invalid argument to edit()"));
if (LENGTH(STRING_ELT(fn, 0)) > 0) {
const char *ss = translateChar(STRING_ELT(fn, 0));
filename = R_alloc(strlen(ss), sizeof(char));
strcpy(filename, ss);
}
else filename = DefaultFileName;
if (x != R_NilValue) {
if((fp=R_fopen(R_ExpandFileName(filename), "w")) == NULL)
errorcall(call, _("unable to open file"));
if (LENGTH(STRING_ELT(fn, 0)) == 0) EdFileUsed++;
if (TYPEOF(x) != CLOSXP || isNull(src = getAttrib(x, R_SourceSymbol)))
src = deparse1(x, CXXRFALSE, FORSOURCING); /* deparse for sourcing, not for display */
for (i = 0; i < LENGTH(src); i++)
fprintf(fp, "%s\n", translateChar(STRING_ELT(src, i)));
fclose(fp);
}
#ifdef Win32
ti = CAR(args);
#endif
args = CDR(args);
ed = CAR(args);
if (!isString(ed)) errorcall(call, _("argument 'editor' type not valid"));
cmd = translateChar(STRING_ELT(ed, 0));
if (strlen(cmd) == 0) errorcall(call, _("argument 'editor' is not set"));
editcmd = R_alloc(strlen(cmd) + strlen(filename) + 6, sizeof(char));
#ifdef Win32
if (!strcmp(cmd,"internal")) {
if (!isString(ti))
error(_("'title' must be a string"));
if (LENGTH(STRING_ELT(ti, 0)) > 0) {
title = R_alloc(strlen(CHAR(STRING_ELT(ti, 0)))+1, sizeof(char));
strcpy(title, CHAR(STRING_ELT(ti, 0)));
} else {
title = R_alloc(strlen(filename)+1, sizeof(char));
strcpy(title, filename);
}
Rgui_Edit(filename, CE_NATIVE, title, 1);
}
else {
/* Quote path if necessary */
if(cmd[0] != '"' && Rf_strchr(cmd, ' '))
sprintf(editcmd, "\"%s\" \"%s\"", cmd, filename);
else
sprintf(editcmd, "%s \"%s\"", cmd, filename);
rc = runcmd(editcmd, CE_NATIVE, 1, 1, NULL, NULL, NULL);
if (rc == NOLAUNCH)
errorcall(call, _("unable to run editor '%s'"), cmd);
if (rc != 0)
warningcall(call, _("editor ran but returned error status"));
}
#else
if (ptr_R_EditFile)
rc = ptr_R_EditFile(filename);
else {
sprintf(editcmd, "'%s' '%s'", cmd, filename); // allow for spaces
rc = R_system(editcmd);
}
if (rc != 0)
errorcall(call, _("problem with running editor %s"), cmd);
#endif
if (asLogical(GetOption1(install("keep.source")))) {
PROTECT(Rfn = findFun(install("readLines"), R_BaseEnv));
PROTECT(src = lang2(Rfn, ScalarString(mkChar(R_ExpandFileName(filename)))));
PROTECT(src = eval(src, R_BaseEnv));
PROTECT(Rfn = findFun(install("srcfilecopy"), R_BaseEnv));
PROTECT(srcfile = lang3(Rfn, ScalarString(mkChar("<tmp>")), src));
srcfile = eval(srcfile, R_BaseEnv);
UNPROTECT(5);
} else
srcfile = R_NilValue;
PROTECT(srcfile);
/* <FIXME> setup a context to close the file, and parse and eval
line by line */
if((fp = R_fopen(R_ExpandFileName(filename), "r")) == NULL)
errorcall(call, _("unable to open file to read"));
x = PROTECT(R_ParseFile(fp, -1, &status, srcfile));
fclose(fp);
if (status != PARSE_OK)
errorcall(call,
_("%s occurred on line %d\n use a command like\n x <- edit()\n to recover"), R_ParseErrorMsg, R_ParseError);
R_ResetConsole();
{ /* can't just eval(x) here */
int j, n;
SEXP tmp = R_NilValue;
n = LENGTH(x);
for (j = 0 ; j < n ; j++)
tmp = eval(XVECTOR_ELT(x, j), R_GlobalEnv);
x = tmp;
}
if (TYPEOF(x) == CLOSXP && envir != R_NilValue)
SET_CLOENV(x, envir);
UNPROTECT(3);
vmaxset(vmaxsave);
return x;
}
static void initialize_rlcompletion(void)
{
if(rcompgen_active >= 0) return;
/* Find if package utils is around */
if(rcompgen_active < 0) {
char *p = getenv("R_COMPLETION");
if(p && streql(p, "FALSE")) {
rcompgen_active = 0;
return;
}
/* First check if namespace is loaded */
if(findVarInFrame(R_NamespaceRegistry, install("utils"))
!= R_UnboundValue) rcompgen_active = 1;
else { /* Then try to load it */
SEXP cmdSexp, cmdexpr;
ParseStatus status;
int i;
char *p = "try(loadNamespace('rcompgen'), silent=TRUE)";
PROTECT(cmdSexp = mkString(p));
cmdexpr = PROTECT(R_ParseVector(cmdSexp, -1, &status, R_NilValue));
if(status == PARSE_OK) {
for(i = 0; i < length(cmdexpr); i++)
eval(XVECTOR_ELT(cmdexpr, i), R_GlobalEnv);
}
UNPROTECT(2);
if(findVarInFrame(R_NamespaceRegistry, install("utils"))
!= R_UnboundValue) rcompgen_active = 1;
else {
rcompgen_active = 0;
return;
}
}
}
rcompgen_rho = R_FindNamespace(mkString("utils"));
RComp_assignBufferSym = install(".assignLinebuffer");
RComp_assignStartSym = install(".assignStart");
RComp_assignEndSym = install(".assignEnd");
RComp_assignTokenSym = install(".assignToken");
RComp_completeTokenSym = install(".completeToken");
RComp_getFileCompSym = install(".getFileComp");
RComp_retrieveCompsSym = install(".retrieveCompletions");
/* Tell the completer that we want a crack first. */
rl_attempted_completion_function = R_custom_completion;
/* Disable sorting of possible completions; only readline >= 6 */
#if RL_READLINE_VERSION >= 0x0600
/* if (rl_readline_version >= 0x0600) */
rl_sort_completion_matches = 0;
#endif
/* token boundaries. Includes *,+ etc, but not $,@ because those
are easier to handle at the R level if the whole thing is
available. However, this breaks filename completion if partial
filenames contain things like $, % etc. Might be possible to
associate a M-/ override like bash does. One compromise is that
we exclude / from the breakers because that is frequently found
in filenames even though it is also an operator. This can be
handled in R code (although it shouldn't be necessary if users
surround operators with spaces, as they should). */
/* FIXME: quotes currently lead to filename completion without any
further ado. This is not necessarily the best we can do, since
quotes after a [, $, [[, etc should be treated differently. I'm
not testing this now, but this should be doable by removing quote
characters from the strings below and handle it with other things
in 'specialCompletions()' in R. The problem with that approach
is that file name completion will probably have to be done
manually in R, which is not trivial. One way to go might be to
forego file name completion altogether when TAB completing, and
associate M-/ or something to filename completion (a startup
message might say so, to remind users)
All that might not be worth the pain though (vector names would
be practically impossible, to begin with) */
return;
}
