Esempio n. 1
0
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;
}
Esempio n. 2
0
// 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;
}
Esempio n. 3
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;
}
Esempio n. 4
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;
}
Esempio n. 5
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;
}
Esempio n. 6
0
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;
}
Esempio n. 7
0
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;
}
Esempio n. 8
0
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); 

}
Esempio n. 9
0
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;
}
Esempio n. 10
0
/* 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;
}
Esempio n. 11
0
File: muste.c Progetto: rforge/muste
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;
}
Esempio n. 12
0
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;
}
Esempio n. 13
0
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;
}
Esempio n. 14
0
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;
}
Esempio n. 15
0
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;
}
Esempio n. 16
0
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);
}
Esempio n. 17
0
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);
}
Esempio n. 18
0
/* "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;
}