static int R_eval(ClientData clientData,
Tcl_Interp *interp,
int argc,
const char *argv[])
{
ParseStatus status;
int i;
SEXP text, expr, ans=R_NilValue /* -Wall */;
text = PROTECT(allocVector(STRSXP, argc - 1));
for (i = 1 ; i < argc ; i++)
SET_STRING_ELT(text, i-1, mkChar(argv[i]));
expr = PROTECT(R_ParseVector(text, -1, &status, R_NilValue));
if (status != PARSE_OK) {
UNPROTECT(2);
Tcl_SetResult(interp, _("parse error in R expression"), TCL_STATIC);
return TCL_ERROR;
}
/* Note that expr becomes an EXPRSXP and hence we need the loop
below (a straight eval(expr, R_GlobalEnv) won't work) */
{
int n = length(expr);
for(i = 0 ; i < n ; i++)
ans = eval(VECTOR_ELT(expr, i), R_GlobalEnv);
}
/* If return value is of class tclObj, use as Tcl result */
if (inherits(ans, "tclObj"))
Tcl_SetObjResult(interp, (Tcl_Obj*) R_ExternalPtrAddr(ans));
UNPROTECT(2);
return TCL_OK;
}
// this is a non-throwing version returning an error code
int REmbed::parseEval(QString line, SEXP & ans) {
ParseStatus status;
SEXP cmdSexp, cmdexpr = R_NilValue;
int i, errorOccurred;
program << line;
PROTECT(cmdSexp = Rf_allocVector(STRSXP, 1));
SET_STRING_ELT(cmdSexp, 0, Rf_mkChar(program.join(" ").toStdString().c_str()));
cmdexpr = PROTECT(R_ParseVector(cmdSexp, -1, &status, R_NilValue));
switch (status){
case PARSE_OK:
// Loop is needed here as EXPSEXP might be of length > 1
for(i = 0; i < Rf_length(cmdexpr); i++){
ans = R_tryEval(VECTOR_ELT(cmdexpr, i), R_GlobalEnv, &errorOccurred);
if (errorOccurred) {
if (verbose) Rf_warning("%s: Error in evaluating R code (%d)\n", name, status);
UNPROTECT(2);
program.clear();
return 1;
}
if (verbose) {
Rf_PrintValue(ans);
}
}
program.clear();
break;
case PARSE_INCOMPLETE:
// need to read another line
break;
case PARSE_NULL:
if (verbose) Rf_warning("%s: ParseStatus is null (%d)\n", name, status);
UNPROTECT(2);
program.clear();
return 1;
break;
case PARSE_ERROR:
if (verbose) Rf_error("Parse Error: \"%s\"\n", line.toStdString().c_str());
UNPROTECT(2);
program.clear();
return 1;
break;
case PARSE_EOF:
if (verbose) Rf_warning("%s: ParseStatus is eof (%d)\n", name, status);
break;
default:
if (verbose) Rf_warning("%s: ParseStatus is not documented %d\n", name, status);
UNPROTECT(2);
program.clear();
return 1;
break;
}
UNPROTECT(2);
return 0;
}
// this is a non-throwing version returning an error code
int RInside::parseEval(const std::string & line, SEXP & ans) {
ParseStatus status;
SEXP cmdSexp, cmdexpr = R_NilValue;
int i, errorOccurred;
mb_m.add((char*)line.c_str());
PROTECT(cmdSexp = Rf_allocVector(STRSXP, 1));
SET_STRING_ELT(cmdSexp, 0, Rf_mkChar(mb_m.getBufPtr()));
cmdexpr = PROTECT(R_ParseVector(cmdSexp, -1, &status, R_NilValue));
switch (status){
case PARSE_OK:
// Loop is needed here as EXPSEXP might be of length > 1
for(i = 0; i < Rf_length(cmdexpr); i++){
ans = R_tryEval(VECTOR_ELT(cmdexpr, i), *global_env_m, &errorOccurred);
if (errorOccurred) {
if (verbose_m) Rf_warning("%s: Error in evaluating R code (%d)\n", programName, status);
UNPROTECT(2);
mb_m.rewind();
return 1;
}
if (verbose_m) {
Rf_PrintValue(ans);
}
}
mb_m.rewind();
break;
case PARSE_INCOMPLETE:
// need to read another line
break;
case PARSE_NULL:
if (verbose_m) Rf_warning("%s: ParseStatus is null (%d)\n", programName, status);
UNPROTECT(2);
mb_m.rewind();
return 1;
break;
case PARSE_ERROR:
if (verbose_m) Rf_warning("Parse Error: \"%s\"\n", line.c_str());
UNPROTECT(2);
mb_m.rewind();
return 1;
break;
case PARSE_EOF:
if (verbose_m) Rf_warning("%s: ParseStatus is eof (%d)\n", programName, status);
break;
default:
if (verbose_m) Rf_warning("%s: ParseStatus is not documented %d\n", programName, status);
UNPROTECT(2);
mb_m.rewind();
return 1;
break;
}
UNPROTECT(2);
return 0;
}
int parse_eval(membuf_t *pmb, char *line, int lineno){
membuf_t mb = *pmb;
ParseStatus status;
SEXP cmdSexp, cmdexpr, ans = R_NilValue;
int i, errorOccurred;
mb = *pmb = add_to_membuf(pmb,line);
PROTECT(cmdSexp = allocVector(STRSXP, 1));
SET_STRING_ELT(cmdSexp, 0, mkChar((char*)mb->buf));
/* R_ParseVector gets a new argument in R 2.5.x */
cmdexpr = PROTECT(R_ParseVector(cmdSexp, -1, &status, R_NilValue));
switch (status){
case PARSE_OK:
/* Loop is needed here as EXPSEXP might be of length > 1 */
for(i = 0; i < length(cmdexpr); i++){
ans = R_tryEval(VECTOR_ELT(cmdexpr, i),NULL, &errorOccurred);
if (errorOccurred) {
UNPROTECT(2);
return 1;
}
if (verbose) {
PrintValue(ans);
}
}
mb = *pmb = rewind_membuf(pmb);
break;
case PARSE_INCOMPLETE:
fprintf(stderr, "%s: Incomplete Line! Need more code! (%d)\n", programName, status);
UNPROTECT(2);
return 1;
break;
case PARSE_NULL:
fprintf(stderr, "%s: ParseStatus is null (%d)\n", programName, status);
UNPROTECT(2);
return 1;
break;
case PARSE_ERROR:
fprintf(stderr,"Parse Error line %d: \"%s\"\n", lineno, line);
UNPROTECT(2);
return 1;
break;
case PARSE_EOF:
fprintf(stderr, "%s: EOF reached (%d)\n", programName, status);
break;
default:
fprintf(stderr, "%s: ParseStatus is not documented %d\n", programName, status);
UNPROTECT(2);
return 1;
break;
}
UNPROTECT(2);
return 0;
}
SEXP rcall_parse(SEXP cmd)
{
SEXP expr;
ParseStatus status;
expr = PROTECT(R_ParseVector(cmd, -1, &status, R_NilValue));
if (status != PARSE_OK)
{
UNPROTECT(1);
jl_error("R parser error.");
return R_NilValue;
}
UNPROTECT(1);
return expr;
}
static char *RAPIinstalladdons(void) {
int evalErr;
ParseStatus status;
char rlibs[FILENAME_MAX];
char rapiinclude[BUFSIZ];
SEXP librisexp;
int len;
// r library folder, create if not exists
len = snprintf(rlibs, sizeof(rlibs), "%s%c%s", GDKgetenv("gdk_dbpath"), DIR_SEP, "rapi_packages");
if (len == -1 || len >= FILENAME_MAX)
return "cannot create rapi_packages directory because the path is too large";
if (mkdir(rlibs, S_IRWXU) != 0 && errno != EEXIST) {
return "cannot create rapi_packages directory";
}
#ifdef _RAPI_DEBUG_
printf("# R libraries installed in %s\n",rlibs);
#endif
PROTECT(librisexp = allocVector(STRSXP, 1));
SET_STRING_ELT(librisexp, 0, mkChar(rlibs));
Rf_defineVar(Rf_install(".rapi.libdir"), librisexp, R_GlobalEnv);
UNPROTECT(1);
// run rapi.R environment setup script
{
char *f = locate_file("rapi", ".R", 0);
snprintf(rapiinclude, sizeof(rapiinclude), "source(\"%s\")", f);
GDKfree(f);
}
#if DIR_SEP != '/'
{
char *p;
for (p = rapiinclude; *p; p++)
if (*p == DIR_SEP)
*p = '/';
}
#endif
R_tryEvalSilent(
VECTOR_ELT(
R_ParseVector(mkString(rapiinclude), 1, &status,
R_NilValue), 0), R_GlobalEnv, &evalErr);
// of course the script may contain errors as well
if (evalErr != FALSE) {
return "failure running R setup script";
}
return NULL;
}
SEXP jr_func(void* p)
{
ParseStatus status;
SEXP s, t, ext;
s = t = PROTECT(R_ParseVector(
Rf_mkString("function(...) {.External(\".RCall\", NULL, ...)}"),
-1, &status, R_NilValue));
ext = PROTECT(R_MakeExternalPtr(p, R_NilValue, R_NilValue));
SETCADDR(CADR(CADDR(VECTOR_ELT(t ,0))), ext);
int errorOccurred = 0;
SEXP ret;
ret = PROTECT(R_tryEval(VECTOR_ELT(s,0), R_GlobalEnv, &errorOccurred));
UNPROTECT(3);
return ret;
}
long r_parse(const char *s){
ParseStatus ps;
SEXP pstr, cv;
PROTECT(cv=allocVector(STRSXP,1));
SET_STRING_ELT(cv, 0, mkChar(s));
UNPROTECT(1);
printf("parsing \"%s\"\n", CHAR(STRING_ELT(cv,0)));
pstr=R_ParseVector(cv, 1, &ps, R_NilValue);
printf("%d\n",TYPEOF(pstr));
printf("parse status=%d, result=%x, type=%d\n", ps, (int) pstr, (pstr!=0)?TYPEOF(pstr):0);
return SEXP2L(pstr);
}
SEXP menu_ttest3()
{
char cmd[256];
SEXP cmdSexp, cmdexpr, ans = R_NilValue;
int i;
ParseStatus status;
done = 0;
create_dialog();
setaction(bCancel, cancel2);
show(win);
for(;;) {
R_WaitEvent();
R_ProcessEvents();
if(done > 0) break;
}
if(done == 1) {
sprintf(cmd, "t.test(x=%s, y=%s, alternative=\"%s\",\n paired=%s, var.equal=%s, conf.level=%s)\n", v[0], v[1],
alts[getlistitem(alt)],
ischecked(paired) ? "TRUE" : "FALSE",
ischecked(varequal) ? "TRUE" : "FALSE",
GA_gettext(lvl));
}
hide(win);
delobj(bApply);
delobj(win);
if(done == 1) {
PROTECT(cmdSexp = allocVector(STRSXP, 1));
SET_STRING_ELT(cmdSexp, 0, mkChar(cmd));
cmdexpr = PROTECT(R_ParseVector(cmdSexp, -1, &status, R_NilValue));
if (status != PARSE_OK) {
UNPROTECT(2);
error("invalid call %s", cmd);
}
/* Loop is needed here as EXPSEXP will be of length > 1 */
for(i = 0; i < length(cmdexpr); i++)
ans = eval(VECTOR_ELT(cmdexpr, i), R_GlobalEnv);
UNPROTECT(2);
}
return ans;
}
/* Parse a string as R code.
Return NULL on error */
SEXP
EmbeddedR_parse(char *string) {
if (! RINTERF_ISREADY()) {
return NULL;
}
RStatus ^= RINTERF_IDLE;
ParseStatus status;
SEXP cmdSexp, cmdExpr;
PROTECT(cmdSexp = allocVector(STRSXP, 1));
SET_STRING_ELT(cmdSexp, 0, mkChar(string));
PROTECT(cmdExpr = R_ParseVector(cmdSexp, -1, &status, R_NilValue));
if (status != PARSE_OK) {
UNPROTECT(2);
RStatus ^= RINTERF_IDLE;
return NULL;
}
R_PreserveObject(cmdExpr);
UNPROTECT(2);
RStatus ^= RINTERF_IDLE;
return cmdExpr;
}
SEXP Muste_EvalRExpr(char *cmd)
{
ParseStatus status;
SEXP cmdsexp, cmdexpr, ans = R_NilValue;
int i;
char *apu,*apu2,*apu3;
muste_removedoublequotes(cmd);
// sprintf(komento,"if (inherits(try(.muste$ans<-%s,silent=TRUE), \"try-error\")) FALSE else TRUE",cmd);
apu=apu2=apu3=NULL;
apu=strchr(cmd,'('); apu2=strchr(cmd,' '); apu3=strchr(cmd,'<');
if ((apu2!=NULL && apu3!=NULL && (apu3-cmd)<(apu2-cmd)) || (apu2==NULL)) apu2=apu3;
if (strncmp(cmd,".muste.",7)==0 &&
(apu!=NULL &&
(apu2==NULL ||
(apu2!=NULL && (apu-cmd)<(apu2-cmd))))
)
{
sprintf(komento,"if (inherits(try(.muste$ans<-muste:::%s,silent=FALSE), \"try-error\")) FALSE else TRUE",cmd);
}
else
{
sprintf(komento,"if (inherits(try(.muste$ans<-%s,silent=FALSE), \"try-error\")) FALSE else TRUE",cmd);
}
//Rprintf("EvalR: %s\n",komento); // RS DEBUG
PROTECT(cmdsexp = allocVector(STRSXP, 1));
SET_STRING_ELT(cmdsexp, 0, mkChar(komento));
cmdexpr = PROTECT(R_ParseVector(cmdsexp, -1, &status, R_NilValue));
if (status != PARSE_OK) {
UNPROTECT(2);
// RS REM error("Invalid call %s",cmd);
Rprintf("\nSyntax error!\n%s",cmd);
return (R_NilValue);
}
for(i=0; i<length(cmdexpr); i++) ans = eval(VECTOR_ELT(cmdexpr,i),R_GlobalEnv);
UNPROTECT(2);
if (INTEGER(ans)[0]==FALSE) return (R_NilValue);
ans = findVar(install(".muste$ans"),R_GlobalEnv);
return ans;
}
static SEXP parse_and_test_callback(SEXP callback) {
ParseStatus parseStatus;
SEXP parsedVector = R_ParseVector(callback, 1, &parseStatus, R_NilValue);
if (parseStatus != PARSE_OK) {
error("Failed to parse \'%s\' as string", CSTRING(callback));
return NULL;
}
SEXP parsedCallback = VECTOR_ELT(parsedVector, 0);
int evalError;
SEXP result = R_tryEval(parsedCallback, R_GlobalEnv, &evalError);
if (evalError) {
error("Failed to eval parsed callback '%s'", CSTRING(callback));
return NULL;
}
if (TYPEOF(result) != INTSXP && TYPEOF(result) != REALSXP) {
error("Result from eval parsed callback '%s' is not integer or real", CSTRING(callback));
return NULL;
}
if (length(result) != 1) {
error("Result from eval parsed callback '%s' is not length 1", CSTRING(callback));
return NULL;
}
if (INTEGER_VALUE(result) == NA_INTEGER) {
// this might be a rare random error but safest to force retry
error("Result from eval parsed callback '%s' was NA", CSTRING(callback));
return NULL;
}
if (verbose) Rprintf("Test random was: %u\n", INTEGER_VALUE(result));
return parsedCallback;
}
char *nvimcom_browser_line(SEXP *x, const char *xname, const char *curenv, const char *prefix, char *p)
{
char xclass[64];
char newenv[512];
char curenvB[512];
char ebuf[64];
char pre[128];
char newpre[128];
int len;
const char *ename;
SEXP listNames, label, lablab, eexp, elmt = R_NilValue;
SEXP cmdSexp, cmdexpr, ans, cmdSexp2, cmdexpr2;
ParseStatus status, status2;
int er = 0;
char buf[128];
if(strlen(xname) > 64)
return p;
if(obbrbufzise < strlen(obbrbuf2) + 1024)
p = nvimcom_grow_obbrbuf();
p = nvimcom_strcat(p, prefix);
if(Rf_isLogical(*x)){
p = nvimcom_strcat(p, "%#");
strcpy(xclass, "logical");
} else if(Rf_isNumeric(*x)){
p = nvimcom_strcat(p, "{#");
strcpy(xclass, "numeric");
} else if(Rf_isFactor(*x)){
p = nvimcom_strcat(p, "'#");
strcpy(xclass, "factor");
} else if(Rf_isValidString(*x)){
p = nvimcom_strcat(p, "\"#");
strcpy(xclass, "character");
} else if(Rf_isFunction(*x)){
p = nvimcom_strcat(p, "(#");
strcpy(xclass, "function");
} else if(Rf_isFrame(*x)){
p = nvimcom_strcat(p, "[#");
strcpy(xclass, "data.frame");
} else if(Rf_isNewList(*x)){
p = nvimcom_strcat(p, "[#");
strcpy(xclass, "list");
} else if(Rf_isS4(*x)){
p = nvimcom_strcat(p, "<#");
strcpy(xclass, "s4");
} else if(TYPEOF(*x) == PROMSXP){
p = nvimcom_strcat(p, "&#");
strcpy(xclass, "lazy");
} else {
p = nvimcom_strcat(p, "=#");
strcpy(xclass, "other");
}
PROTECT(lablab = allocVector(STRSXP, 1));
SET_STRING_ELT(lablab, 0, mkChar("label"));
PROTECT(label = getAttrib(*x, lablab));
p = nvimcom_strcat(p, xname);
p = nvimcom_strcat(p, "\t");
if(length(label) > 0){
if(Rf_isValidString(label)){
snprintf(buf, 127, "%s", CHAR(STRING_ELT(label, 0)));
p = nvimcom_strcat(p, buf);
} else {
if(labelerr)
p = nvimcom_strcat(p, "Error: label isn't \"character\".");
}
}
p = nvimcom_strcat(p, "\n");
UNPROTECT(2);
if(strcmp(xclass, "list") == 0 || strcmp(xclass, "data.frame") == 0 || strcmp(xclass, "s4") == 0){
strncpy(curenvB, curenv, 500);
if(xname[0] == '[' && xname[1] == '['){
curenvB[strlen(curenvB) - 1] = 0;
}
if(strcmp(xclass, "s4") == 0)
snprintf(newenv, 500, "%s%s@", curenvB, xname);
else
snprintf(newenv, 500, "%s%s$", curenvB, xname);
if((nvimcom_get_list_status(newenv, xclass) == 1)){
len = strlen(prefix);
if(nvimcom_is_utf8){
int j = 0, i = 0;
while(i < len){
if(prefix[i] == '\xe2'){
i += 3;
if(prefix[i-1] == '\x80' || prefix[i-1] == '\x94'){
pre[j] = ' '; j++;
} else {
pre[j] = '\xe2'; j++;
pre[j] = '\x94'; j++;
pre[j] = '\x82'; j++;
}
} else {
pre[j] = prefix[i];
i++, j++;
}
}
pre[j] = 0;
} else {
for(int i = 0; i < len; i++){
if(prefix[i] == '-' || prefix[i] == '`')
pre[i] = ' ';
else
pre[i] = prefix[i];
}
pre[len] = 0;
}
sprintf(newpre, "%s%s", pre, strT);
if(strcmp(xclass, "s4") == 0){
snprintf(buf, 127, "slotNames(%s%s)", curenvB, xname);
PROTECT(cmdSexp = allocVector(STRSXP, 1));
SET_STRING_ELT(cmdSexp, 0, mkChar(buf));
PROTECT(cmdexpr = R_ParseVector(cmdSexp, -1, &status, R_NilValue));
if (status != PARSE_OK) {
p = nvimcom_strcat(p, "nvimcom error: invalid value in slotNames(");
p = nvimcom_strcat(p, xname);
p = nvimcom_strcat(p, ")\n");
} else {
PROTECT(ans = R_tryEval(VECTOR_ELT(cmdexpr, 0), R_GlobalEnv, &er));
if(er){
p = nvimcom_strcat(p, "nvimcom error: ");
p = nvimcom_strcat(p, xname);
p = nvimcom_strcat(p, "\n");
} else {
len = length(ans);
if(len > 0){
int len1 = len - 1;
for(int i = 0; i < len; i++){
ename = CHAR(STRING_ELT(ans, i));
snprintf(buf, 127, "%s%s@%s", curenvB, xname, ename);
PROTECT(cmdSexp2 = allocVector(STRSXP, 1));
SET_STRING_ELT(cmdSexp2, 0, mkChar(buf));
PROTECT(cmdexpr2 = R_ParseVector(cmdSexp2, -1, &status2, R_NilValue));
if (status2 != PARSE_OK) {
p = nvimcom_strcat(p, "nvimcom error: invalid code \"");
p = nvimcom_strcat(p, xname);
p = nvimcom_strcat(p, "@");
p = nvimcom_strcat(p, ename);
p = nvimcom_strcat(p, "\"\n");
} else {
PROTECT(elmt = R_tryEval(VECTOR_ELT(cmdexpr2, 0), R_GlobalEnv, &er));
if(i == len1)
sprintf(newpre, "%s%s", pre, strL);
p = nvimcom_browser_line(&elmt, ename, newenv, newpre, p);
UNPROTECT(1);
}
UNPROTECT(2);
}
}
}
UNPROTECT(1);
}
UNPROTECT(2);
} else {
PROTECT(listNames = getAttrib(*x, R_NamesSymbol));
len = length(listNames);
if(len == 0){ /* Empty list? */
int len1 = length(*x);
if(len1 > 0){ /* List without names */
len1 -= 1;
for(int i = 0; i < len1; i++){
sprintf(ebuf, "[[%d]]", i + 1);
elmt = VECTOR_ELT(*x, i);
p = nvimcom_browser_line(&elmt, ebuf, newenv, newpre, p);
}
sprintf(newpre, "%s%s", pre, strL);
sprintf(ebuf, "[[%d]]", len1 + 1);
PROTECT(elmt = VECTOR_ELT(*x, len));
p = nvimcom_browser_line(&elmt, ebuf, newenv, newpre, p);
UNPROTECT(1);
}
} else { /* Named list */
len -= 1;
for(int i = 0; i < len; i++){
PROTECT(eexp = STRING_ELT(listNames, i));
ename = CHAR(eexp);
UNPROTECT(1);
if(ename[0] == 0){
sprintf(ebuf, "[[%d]]", i + 1);
ename = ebuf;
}
PROTECT(elmt = VECTOR_ELT(*x, i));
p = nvimcom_browser_line(&elmt, ename, newenv, newpre, p);
UNPROTECT(1);
}
sprintf(newpre, "%s%s", pre, strL);
ename = CHAR(STRING_ELT(listNames, len));
if(ename[0] == 0){
sprintf(ebuf, "[[%d]]", len + 1);
ename = ebuf;
}
PROTECT(elmt = VECTOR_ELT(*x, len));
p = nvimcom_browser_line(&elmt, ename, newenv, newpre, p);
UNPROTECT(1);
}
UNPROTECT(1); /* listNames */
}
}
}
return p;
}
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(VECTOR_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;
}
str RAPIeval(Client cntxt, MalBlkPtr mb, MalStkPtr stk, InstrPtr pci, bit grouped) {
sql_func * sqlfun = NULL;
str exprStr = *getArgReference_str(stk, pci, pci->retc + 1);
SEXP x, env, retval;
SEXP varname = R_NilValue;
SEXP varvalue = R_NilValue;
ParseStatus status;
int i = 0;
char argbuf[64];
char *argnames = NULL;
size_t argnameslen;
size_t pos;
char* rcall = NULL;
size_t rcalllen;
int ret_cols = 0; /* int because pci->retc is int, too*/
str *args;
int evalErr;
char *msg = MAL_SUCCEED;
BAT *b;
node * argnode;
int seengrp = FALSE;
rapiClient = cntxt;
if (!RAPIEnabled()) {
throw(MAL, "rapi.eval",
"Embedded R has not been enabled. Start server with --set %s=true",
rapi_enableflag);
}
if (!rapiInitialized) {
throw(MAL, "rapi.eval",
"Embedded R initialization has failed");
}
if (!grouped) {
sql_subfunc *sqlmorefun = (*(sql_subfunc**) getArgReference(stk, pci, pci->retc));
if (sqlmorefun) sqlfun = (*(sql_subfunc**) getArgReference(stk, pci, pci->retc))->func;
} else {
sqlfun = *(sql_func**) getArgReference(stk, pci, pci->retc);
}
args = (str*) GDKzalloc(sizeof(str) * pci->argc);
if (args == NULL) {
throw(MAL, "rapi.eval", SQLSTATE(HY001) MAL_MALLOC_FAIL);
}
// get the lock even before initialization of the R interpreter, as this can take a second and must be done only once.
MT_lock_set(&rapiLock);
env = PROTECT(eval(lang1(install("new.env")), R_GlobalEnv));
assert(env != NULL);
// first argument after the return contains the pointer to the sql_func structure
// NEW macro temporarily renamed to MNEW to allow including sql_catalog.h
if (sqlfun != NULL && sqlfun->ops->cnt > 0) {
int carg = pci->retc + 2;
argnode = sqlfun->ops->h;
while (argnode) {
char* argname = ((sql_arg*) argnode->data)->name;
args[carg] = GDKstrdup(argname);
carg++;
argnode = argnode->next;
}
}
// the first unknown argument is the group, we don't really care for the rest.
argnameslen = 2;
for (i = pci->retc + 2; i < pci->argc; i++) {
if (args[i] == NULL) {
if (!seengrp && grouped) {
args[i] = GDKstrdup("aggr_group");
seengrp = TRUE;
} else {
snprintf(argbuf, sizeof(argbuf), "arg%i", i - pci->retc - 1);
args[i] = GDKstrdup(argbuf);
}
}
argnameslen += strlen(args[i]) + 2; /* extra for ", " */
}
// install the MAL variables into the R environment
// we can basically map values to int ("INTEGER") or double ("REAL")
for (i = pci->retc + 2; i < pci->argc; i++) {
int bat_type = getBatType(getArgType(mb,pci,i));
// check for BAT or scalar first, keep code left
if (!isaBatType(getArgType(mb,pci,i))) {
b = COLnew(0, getArgType(mb, pci, i), 0, TRANSIENT);
if (b == NULL) {
msg = createException(MAL, "rapi.eval", SQLSTATE(HY001) MAL_MALLOC_FAIL);
goto wrapup;
}
if ( getArgType(mb,pci,i) == TYPE_str) {
if (BUNappend(b, *getArgReference_str(stk, pci, i), false) != GDK_SUCCEED) {
BBPreclaim(b);
b = NULL;
msg = createException(MAL, "rapi.eval", SQLSTATE(HY001) MAL_MALLOC_FAIL);
goto wrapup;
}
} else {
if (BUNappend(b, getArgReference(stk, pci, i), false) != GDK_SUCCEED) {
BBPreclaim(b);
b = NULL;
msg = createException(MAL, "rapi.eval", SQLSTATE(HY001) MAL_MALLOC_FAIL);
goto wrapup;
}
}
} else {
b = BATdescriptor(*getArgReference_bat(stk, pci, i));
if (b == NULL) {
msg = createException(MAL, "rapi.eval", SQLSTATE(HY001) MAL_MALLOC_FAIL);
goto wrapup;
}
}
// check the BAT count, if it is bigger than RAPI_MAX_TUPLES, fail
if (BATcount(b) > RAPI_MAX_TUPLES) {
msg = createException(MAL, "rapi.eval",
"Got "BUNFMT" rows, but can only handle "LLFMT". Sorry.",
BATcount(b), (lng) RAPI_MAX_TUPLES);
BBPunfix(b->batCacheid);
goto wrapup;
}
varname = PROTECT(Rf_install(args[i]));
varvalue = bat_to_sexp(b, bat_type);
if (varvalue == NULL) {
msg = createException(MAL, "rapi.eval", "unknown argument type ");
goto wrapup;
}
BBPunfix(b->batCacheid);
// install vector into R environment
Rf_defineVar(varname, varvalue, env);
UNPROTECT(2);
}
/* we are going to evaluate the user function within an anonymous function call:
* ret <- (function(arg1){return(arg1*2)})(42)
* the user code is put inside the {}, this keeps our environment clean (TM) and gives
* a clear path for return values, namely using the builtin return() function
* this is also compatible with PL/R
*/
pos = 0;
argnames = malloc(argnameslen);
if (argnames == NULL) {
msg = createException(MAL, "rapi.eval", SQLSTATE(HY001) MAL_MALLOC_FAIL);
goto wrapup;
}
argnames[0] = '\0';
for (i = pci->retc + 2; i < pci->argc; i++) {
pos += snprintf(argnames + pos, argnameslen - pos, "%s%s",
args[i], i < pci->argc - 1 ? ", " : "");
}
rcalllen = 2 * pos + strlen(exprStr) + 100;
rcall = malloc(rcalllen);
if (rcall == NULL) {
msg = createException(MAL, "rapi.eval", SQLSTATE(HY001) MAL_MALLOC_FAIL);
goto wrapup;
}
snprintf(rcall, rcalllen,
"ret <- as.data.frame((function(%s){%s})(%s), nm=NA, stringsAsFactors=F)\n",
argnames, exprStr, argnames);
free(argnames);
argnames = NULL;
#ifdef _RAPI_DEBUG_
printf("# R call %s\n",rcall);
#endif
x = R_ParseVector(mkString(rcall), 1, &status, R_NilValue);
if (LENGTH(x) != 1 || status != PARSE_OK) {
msg = createException(MAL, "rapi.eval",
"Error parsing R expression '%s'. ", exprStr);
goto wrapup;
}
retval = R_tryEval(VECTOR_ELT(x, 0), env, &evalErr);
if (evalErr != FALSE) {
char* errormsg = strdup(R_curErrorBuf());
size_t c;
if (errormsg == NULL) {
msg = createException(MAL, "rapi.eval", "Error running R expression.");
goto wrapup;
}
// remove newlines from error message so it fits into a MAPI error (lol)
for (c = 0; c < strlen(errormsg); c++) {
if (errormsg[c] == '\r' || errormsg[c] == '\n') {
errormsg[c] = ' ';
}
}
msg = createException(MAL, "rapi.eval",
"Error running R expression: %s", errormsg);
free(errormsg);
goto wrapup;
}
// ret should be a data frame with exactly as many columns as we need from retc
ret_cols = LENGTH(retval);
if (ret_cols != pci->retc) {
msg = createException(MAL, "rapi.eval",
"Expected result of %d columns, got %d", pci->retc, ret_cols);
goto wrapup;
}
// collect the return values
for (i = 0; i < pci->retc; i++) {
SEXP ret_col = VECTOR_ELT(retval, i);
int bat_type = getBatType(getArgType(mb,pci,i));
if (bat_type == TYPE_any || bat_type == TYPE_void) {
getArgType(mb,pci,i) = bat_type;
msg = createException(MAL, "rapi.eval",
"Unknown return value, possibly projecting with no parameters.");
goto wrapup;
}
// hand over the vector into a BAT
b = sexp_to_bat(ret_col, bat_type);
if (b == NULL) {
msg = createException(MAL, "rapi.eval",
"Failed to convert column %i", i);
goto wrapup;
}
// bat return
if (isaBatType(getArgType(mb,pci,i))) {
*getArgReference_bat(stk, pci, i) = b->batCacheid;
} else { // single value return, only for non-grouped aggregations
BATiter li = bat_iterator(b);
if (VALinit(&stk->stk[pci->argv[i]], bat_type,
BUNtail(li, 0)) == NULL) { // TODO BUNtail here
msg = createException(MAL, "rapi.eval", SQLSTATE(HY001) MAL_MALLOC_FAIL);
goto wrapup;
}
}
msg = MAL_SUCCEED;
}
/* unprotect environment, so it will be eaten by the GC. */
UNPROTECT(1);
wrapup:
MT_lock_unset(&rapiLock);
if (argnames)
free(argnames);
if (rcall)
free(rcall);
for (i = 0; i < pci->argc; i++)
GDKfree(args[i]);
GDKfree(args);
return msg;
}
static void nvimcom_eval_expr(const char *buf)
{
char fn[512];
snprintf(fn, 510, "%s/eval_reply", tmpdir);
if(verbose > 3)
Rprintf("nvimcom_eval_expr: '%s'\n", buf);
FILE *rep = fopen(fn, "w");
if(rep == NULL){
REprintf("Error: Could not write to '%s'. [nvimcom]\n", fn);
return;
}
#ifdef WIN32
if(tcltkerr){
fprintf(rep, "Error: \"nvimcom\" and \"tcltk\" packages are incompatible!\n");
fclose(rep);
return;
} else {
if(objbr_auto == 0)
nvimcom_checklibs();
if(tcltkerr){
fprintf(rep, "Error: \"nvimcom\" and \"tcltk\" packages are incompatible!\n");
fclose(rep);
return;
}
}
#endif
SEXP cmdSexp, cmdexpr, ans;
ParseStatus status;
int er = 0;
PROTECT(cmdSexp = allocVector(STRSXP, 1));
SET_STRING_ELT(cmdSexp, 0, mkChar(buf));
PROTECT(cmdexpr = R_ParseVector(cmdSexp, -1, &status, R_NilValue));
if (status != PARSE_OK) {
fprintf(rep, "INVALID\n");
} else {
/* Only the first command will be executed if the expression includes
* a semicolon. */
PROTECT(ans = R_tryEval(VECTOR_ELT(cmdexpr, 0), R_GlobalEnv, &er));
if(er){
fprintf(rep, "ERROR\n");
} else {
switch(TYPEOF(ans)) {
case REALSXP:
fprintf(rep, "%f\n", REAL(ans)[0]);
break;
case LGLSXP:
case INTSXP:
fprintf(rep, "%d\n", INTEGER(ans)[0]);
break;
case STRSXP:
if(length(ans) > 0)
fprintf(rep, "%s\n", CHAR(STRING_ELT(ans, 0)));
else
fprintf(rep, "EMPTY\n");
break;
default:
fprintf(rep, "RTYPE\n");
}
}
UNPROTECT(1);
}
UNPROTECT(2);
fclose(rep);
}
SEXP Rhpc_mpi_initialize(void)
{
int *mpi_argc = (int *)&MPI_argc;
char ***mpi_argv= (char ***)MPI_argv;
int mpi_version = 0;
int mpi_subversion = 0;
#if defined(__ELF__)
void *dlh = NULL;
void *dls = NULL;
int failmpilib;
# ifdef HAVE_DLADDR
Dl_info info_MPI_Init;
int rc ;
# endif
#endif
if(finalize){
warning("Rhpc were already finalized.");
return(R_NilValue);
}
if(initialize){
warning("Rhpc were already initialized.");
return(R_NilValue);
}
#if defined(__ELF__)
if ( NULL != (dlh=dlopen(NULL, RTLD_NOW|RTLD_GLOBAL))){
if(NULL != (dls = dlsym( dlh, "MPI_Init")))
failmpilib = 0; /* success loaded MPI library */
else
failmpilib = 1; /* maybe can't loaded MPI library */
dlclose(dlh);
}
if( failmpilib ){
# ifdef HAVE_DLADDR
/* maybe get beter soname */
rc = dladdr((void *)MPI_Init, &info_MPI_Init);
if (rc){
Rprintf("reload mpi library %s\n", info_MPI_Init.dli_fname );
if (!dlopen(info_MPI_Init.dli_fname, RTLD_GLOBAL | RTLD_LAZY)){
Rprintf("%s\n",dlerror());
}
}else{
Rprintf("Can't get Information by dladdr of function MPI_Init,%s\n",
dlerror());
}
# else
Rprintf("Can't get Information by dlsym of function MPI_Init,%s\n",
dlerror());
# endif
}
#endif
MPI_Get_version(&mpi_version, &mpi_subversion);
if ( mpi_version >= 2){
mpi_argc=NULL;
mpi_argv=NULL;
}
_M(MPI_Init(mpi_argc, mpi_argv));
_M(MPI_Comm_set_errhandler(MPI_COMM_WORLD, MPI_ERRORS_RETURN));
_M(MPI_Comm_set_errhandler(MPI_COMM_SELF, MPI_ERRORS_RETURN));
_M(MPI_Comm_rank(MPI_COMM_WORLD, &MPI_rank));
_M(MPI_Comm_size(MPI_COMM_WORLD, &MPI_procs));
DPRINT("Rhpc_initialize : rank:%d size:%d\n", MPI_rank, MPI_procs);
RHPC_Comm = MPI_COMM_WORLD;
Rhpc_set_options( MPI_rank, MPI_procs,RHPC_Comm);
if (MPI_rank == 0){ /* Master : get RhpcSpawn path*/
int errorOccurred=0;
SEXP ret;
SEXP cmdSexp, cmdexpr;
ParseStatus status;
PROTECT(cmdSexp = allocVector(STRSXP, 1));
SET_STRING_ELT(cmdSexp, 0, mkChar("system.file('RhpcSpawn',package='Rhpc')"));
PROTECT( cmdexpr = R_ParseVector(cmdSexp, -1, &status, R_NilValue));
ret=R_tryEval(VECTOR_ELT(cmdexpr,0), R_GlobalEnv, &errorOccurred);
strncpy(RHPC_WORKER_CMD, CHAR(STRING_ELT(ret,0)), sizeof(RHPC_WORKER_CMD));
UNPROTECT(2);
}
initialize = 1;
return(R_NilValue);
}
/* "do_parse" - the user interface input/output to files.
The internal R_Parse.. functions are defined in ./gram.y (-> gram.c)
.Internal( parse(file, n, text, prompt, srcfile, encoding) )
If there is text then that is read and the other arguments are ignored.
*/
SEXP attribute_hidden do_parse(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP text, prompt, s, source;
Rconnection con;
Rboolean wasopen, old_latin1 = known_to_be_latin1,
old_utf8 = known_to_be_utf8, allKnown = TRUE;
int ifile, num, i;
const char *encoding;
ParseStatus status;
checkArity(op, args);
R_ParseError = 0;
R_ParseErrorMsg[0] = '\0';
ifile = asInteger(CAR(args)); args = CDR(args);
con = getConnection(ifile);
wasopen = con->isopen;
num = asInteger(CAR(args)); args = CDR(args);
if (num == 0)
return(allocVector(EXPRSXP, 0));
PROTECT(text = coerceVector(CAR(args), STRSXP));
if(length(CAR(args)) && !length(text))
errorcall(call, _("coercion of 'text' to character was unsuccessful"));
args = CDR(args);
prompt = CAR(args); args = CDR(args);
source = CAR(args); args = CDR(args);
if(!isString(CAR(args)) || LENGTH(CAR(args)) != 1)
error(_("invalid '%s' value"), "encoding");
encoding = CHAR(STRING_ELT(CAR(args), 0)); /* ASCII */
known_to_be_latin1 = known_to_be_utf8 = FALSE;
/* allow 'encoding' to override declaration on 'text'. */
if(streql(encoding, "latin1")) {
known_to_be_latin1 = TRUE;
allKnown = FALSE;
} else if(streql(encoding, "UTF-8")) {
known_to_be_utf8 = TRUE;
allKnown = FALSE;
} else if(!streql(encoding, "unknown") && !streql(encoding, "native.enc"))
warning(_("argument '%s = \"%s\"' will be ignored"), "encoding", encoding);
if (prompt == R_NilValue)
PROTECT(prompt);
else
PROTECT(prompt = coerceVector(prompt, STRSXP));
if (length(text) > 0) {
/* If 'text' has known encoding then we can be sure it will be
correctly re-encoded to the current encoding by
translateChar in the parser and so could mark the result in
a Latin-1 or UTF-8 locale.
A small complication is that different elements could have
different encodings, but all that matters is that all
non-ASCII elements have known encoding.
*/
for(i = 0; i < length(text); i++)
if(!ENC_KNOWN(STRING_ELT(text, i)) &&
!IS_ASCII(STRING_ELT(text, i))) {
allKnown = FALSE;
break;
}
if(allKnown) {
known_to_be_latin1 = old_latin1;
known_to_be_utf8 = old_utf8;
}
if (num == NA_INTEGER) num = -1;
s = R_ParseVector(text, num, &status, source);
if (status != PARSE_OK) parseError(call, R_ParseError);
}
else if (ifile >= 3) {/* file != "" */
if (num == NA_INTEGER) num = -1;
try {
if(!wasopen && !con->open(con))
error(_("cannot open the connection"));
if(!con->canread) error(_("cannot read from this connection"));
s = R_ParseConn(con, num, &status, source);
if(!wasopen) con->close(con);
} catch (...) {
if (!wasopen && con->isopen)
con->close(con);
throw;
}
if (status != PARSE_OK) parseError(call, R_ParseError);
}
else {
if (num == NA_INTEGER) num = 1;
s = R_ParseBuffer(&R_ConsoleIob, num, &status, prompt, source);
if (status != PARSE_OK) parseError(call, R_ParseError);
}
UNPROTECT(2);
known_to_be_latin1 = old_latin1;
known_to_be_utf8 = old_utf8;
return s;
}