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; }