static int R_call_lang(ClientData clientData,
Tcl_Interp *interp,
int argc,
const char *argv[])
{
void *expr, *env;
SEXP ans;
sscanf(argv[1], "%p", &expr);
sscanf(argv[2], "%p", &env);
SEXP s_try = install("try");
expr = LCONS(s_try, CONS(expr, R_NilValue));
PROTECT((SEXP)expr);
R_Busy(1);
PROTECT(ans = eval((SEXP)expr, (SEXP)env));
R_Busy(0);
/* 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;
}
static int R_call(ClientData clientData,
Tcl_Interp *interp,
int argc,
const char *argv[])
{
int i;
SEXP expr, alist, ans;
void *fun;
SEXP s_try = install("try");
alist = R_NilValue;
for (i = argc - 1 ; i > 1 ; i--){
PROTECT(alist);
alist = CONS(mkString(argv[i]), alist);
UNPROTECT(1);
}
sscanf(argv[1], "%p", &fun);
expr = LCONS( (SEXP)fun, alist);
PROTECT(expr = LCONS(s_try, LCONS(expr, R_NilValue)));
R_Busy(1);
PROTECT(ans = eval(expr, R_GlobalEnv));
R_Busy(0);
/* 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;
}
SEXP do_system(SEXP call, SEXP op, SEXP args, SEXP rho)
{
FILE *fp;
char *x = "r", buf[INTERN_BUFSIZE];
int read=0, i, j;
SEXP tlist = R_NilValue, tchar, rval;
checkArity(op, args);
if (!isValidStringF(CAR(args)))
errorcall(call, _("non-empty character argument expected"));
if (isLogical(CADR(args)))
read = INTEGER(CADR(args))[0];
if (read) {
#ifdef HAVE_POPEN
PROTECT(tlist);
fp = R_popen(CHAR(STRING_ELT(CAR(args), 0)), x);
for (i = 0; fgets(buf, INTERN_BUFSIZE, fp); i++) {
read = strlen(buf);
if (read > 0 && buf[read-1] == '\n')
buf[read - 1] = '\0'; /* chop final CR */
tchar = mkChar(buf);
UNPROTECT(1);
PROTECT(tlist = CONS(tchar, tlist));
}
pclose(fp);
rval = allocVector(STRSXP, i);;
for (j = (i - 1); j >= 0; j--) {
SET_STRING_ELT(rval, j, CAR(tlist));
tlist = CDR(tlist);
}
UNPROTECT(1);
return (rval);
#else /* not HAVE_POPEN */
errorcall(call, _("intern=TRUE is not implemented on this platform"));
return R_NilValue;
#endif /* not HAVE_POPEN */
}
else {
#ifdef HAVE_AQUA
R_Busy(1);
#endif
tlist = allocVector(INTSXP, 1);
fflush(stdout);
INTEGER(tlist)[0] = R_system(CHAR(STRING_ELT(CAR(args), 0)));
#ifdef HAVE_AQUA
R_Busy(0);
#endif
R_Visible = 0;
return tlist;
}
}
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) */
{
R_Busy(1);
int n = length(expr);
for(i = 0 ; i < n ; i++)
ans = eval(VECTOR_ELT(expr, i), R_GlobalEnv);
PROTECT(ans);
R_Busy(0);
}
/* If return value is of class tclObj, use as Tcl result */
if (inherits(ans, "tclObj"))
Tcl_SetObjResult(interp, (Tcl_Obj*) R_ExternalPtrAddr(ans));
UNPROTECT(3);
return TCL_OK;
}
SEXP attribute_hidden do_system(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP tlist = R_NilValue;
int intern = 0;
checkArity(op, args);
if (!isValidStringF(CAR(args)))
error(_("non-empty character argument expected"));
intern = asLogical(CADR(args));
if (intern == NA_INTEGER)
error(_("'intern' must be logical and not NA"));
if (intern) { /* intern = TRUE */
FILE *fp;
char *x = "r", buf[INTERN_BUFSIZE];
const char *cmd;
int i, j, res;
SEXP tchar, rval;
PROTECT(tlist);
cmd = translateChar(STRING_ELT(CAR(args), 0));
errno = 0; /* precaution */
if(!(fp = R_popen(cmd, x)))
error(_("cannot popen '%s', probable reason '%s'"),
cmd, strerror(errno));
for (i = 0; fgets(buf, INTERN_BUFSIZE, fp); i++) {
size_t read = strlen(buf);
if(read >= INTERN_BUFSIZE - 1)
warning(_("line %d may be truncated in call to system(, intern = TRUE)"), i + 1);
if (read > 0 && buf[read-1] == '\n')
buf[read - 1] = '\0'; /* chop final CR */
tchar = mkChar(buf);
UNPROTECT(1);
PROTECT(tlist = CONS(tchar, tlist));
}
res = pclose(fp);
#ifdef HAVE_SYS_WAIT_H
if (WIFEXITED(res)) res = WEXITSTATUS(res);
else res = 0;
#else
/* assume that this is shifted if a multiple of 256 */
if ((res % 256) == 0) res = res/256;
#endif
if ((res & 0xff) == 127) {/* 127, aka -1 */
if (errno)
error(_("error in running command: '%s'"), strerror(errno));
else
error(_("error in running command"));
} else if (res) {
if (errno)
warningcall(R_NilValue,
_("running command '%s' had status %d and error message '%s'"),
cmd, res,
strerror(errno));
else
warningcall(R_NilValue,
_("running command '%s' had status %d"),
cmd, res);
}
rval = PROTECT(allocVector(STRSXP, i));
for (j = (i - 1); j >= 0; j--) {
SET_STRING_ELT(rval, j, CAR(tlist));
tlist = CDR(tlist);
}
if(res) {
SEXP lsym = install("status");
setAttrib(rval, lsym, ScalarInteger(res));
if(errno) {
lsym = install("errmsg");
setAttrib(rval, lsym, mkString(strerror(errno)));
}
}
UNPROTECT(2);
return rval;
}
else { /* intern = FALSE */
#ifdef HAVE_AQUA
R_Busy(1);
#endif
tlist = PROTECT(allocVector(INTSXP, 1));
fflush(stdout);
INTEGER(tlist)[0] = R_system(translateChar(STRING_ELT(CAR(args), 0)));
#ifdef HAVE_AQUA
R_Busy(0);
#endif
UNPROTECT(1);
R_Visible = 0;
return tlist;
}
}
/* FIXME: this should be re-written to use Rf_ReplIteration
since it gets out of sync with it over time */
int R_ReplDLLdo1(void)
{
int c;
ParseStatus status;
SEXP rho = R_GlobalEnv, lastExpr;
Rboolean wasDisplayed = FALSE;
if(!*DLLbufp) {
R_Busy(0);
if (R_ReadConsole(R_PromptString(0, prompt_type), DLLbuf,
CONSOLE_BUFFER_SIZE, 1) == 0)
return -1;
DLLbufp = DLLbuf;
}
while((c = *DLLbufp++)) {
R_IoBufferPutc(c, &R_ConsoleIob);
if(c == ';' || c == '\n') break;
}
R_PPStackTop = 0;
R_CurrentExpr = R_Parse1Buffer(&R_ConsoleIob, 0, &status);
switch(status) {
case PARSE_NULL:
R_IoBufferWriteReset(&R_ConsoleIob);
prompt_type = 1;
break;
case PARSE_OK:
R_IoBufferReadReset(&R_ConsoleIob);
R_CurrentExpr = R_Parse1Buffer(&R_ConsoleIob, 1, &status);
R_Visible = FALSE;
R_EvalDepth = 0;
resetTimeLimits();
PROTECT(R_CurrentExpr);
R_Busy(1);
lastExpr = R_CurrentExpr;
R_CurrentExpr = eval(R_CurrentExpr, rho);
SET_SYMVALUE(R_LastvalueSymbol, R_CurrentExpr);
wasDisplayed = R_Visible;
if (R_Visible)
PrintValueEnv(R_CurrentExpr, rho);
if (R_CollectWarnings)
PrintWarnings();
Rf_callToplevelHandlers(lastExpr, R_CurrentExpr, TRUE, wasDisplayed);
UNPROTECT(1);
R_IoBufferWriteReset(&R_ConsoleIob);
R_Busy(0);
prompt_type = 1;
break;
case PARSE_ERROR:
parseError(R_NilValue, 0);
R_IoBufferWriteReset(&R_ConsoleIob);
prompt_type = 1;
break;
case PARSE_INCOMPLETE:
R_IoBufferReadReset(&R_ConsoleIob);
prompt_type = 2;
break;
case PARSE_EOF:
return -1;
break;
}
return prompt_type;
}
/**
This is the body of the REPL.
It attempts to parse the first line or expression of its input,
and optionally request input from the user if none is available.
If the input can be parsed correctly,
i) the resulting expression is evaluated,
ii) the result assigned to .Last.Value,
iii) top-level task handlers are invoked.
If the input cannot be parsed, i.e. there is a syntax error,
it is incomplete, or we encounter an end-of-file, then we
change the prompt accordingly.
The "cursor" for the input buffer is moved to the next starting
point, i.e. the end of the first line or after the first ;.
*/
int
Rf_ReplIteration(SEXP rho, int savestack, int browselevel, R_ReplState *state)
{
int c, browsevalue;
SEXP value, thisExpr;
Rboolean wasDisplayed = FALSE;
if(!*state->bufp) {
R_Busy(0);
if (R_ReadConsole(R_PromptString(browselevel, state->prompt_type),
state->buf, CONSOLE_BUFFER_SIZE, 1) == 0)
return(-1);
state->bufp = state->buf;
}
#ifdef SHELL_ESCAPE /* not default */
if (*state->bufp == '!') {
R_system(&(state->buf[1]));
state->buf[0] = '\0';
return(0);
}
#endif /* SHELL_ESCAPE */
while((c = *state->bufp++)) {
R_IoBufferPutc(c, &R_ConsoleIob);
if(c == ';' || c == '\n') break;
}
R_PPStackTop = savestack;
R_CurrentExpr = R_Parse1Buffer(&R_ConsoleIob, 0, &state->status);
switch(state->status) {
case PARSE_NULL:
/* The intention here is to break on CR but not on other
null statements: see PR#9063 */
if (browselevel && !R_DisableNLinBrowser
&& !strcmp((char *) state->buf, "\n")) return -1;
R_IoBufferWriteReset(&R_ConsoleIob);
state->prompt_type = 1;
return 1;
case PARSE_OK:
R_IoBufferReadReset(&R_ConsoleIob);
R_CurrentExpr = R_Parse1Buffer(&R_ConsoleIob, 1, &state->status);
if (browselevel) {
browsevalue = ParseBrowser(R_CurrentExpr, rho);
if(browsevalue == 1) return -1;
if(browsevalue == 2) {
R_IoBufferWriteReset(&R_ConsoleIob);
return 0;
}
/* PR#15770 We don't want to step into expressions entered at the debug prompt.
The 'S' will be changed back to 's' after the next eval. */
if (R_BrowserLastCommand == 's') R_BrowserLastCommand = 'S';
}
R_Visible = FALSE;
R_EvalDepth = 0;
resetTimeLimits();
PROTECT(thisExpr = R_CurrentExpr);
R_Busy(1);
value = eval(thisExpr, rho);
SET_SYMVALUE(R_LastvalueSymbol, value);
wasDisplayed = R_Visible;
if (R_Visible)
PrintValueEnv(value, rho);
if (R_CollectWarnings)
PrintWarnings();
Rf_callToplevelHandlers(thisExpr, value, TRUE, wasDisplayed);
R_CurrentExpr = value; /* Necessary? Doubt it. */
UNPROTECT(1);
if (R_BrowserLastCommand == 'S') R_BrowserLastCommand = 's';
R_IoBufferWriteReset(&R_ConsoleIob);
state->prompt_type = 1;
return(1);
case PARSE_ERROR:
state->prompt_type = 1;
parseError(R_NilValue, 0);
R_IoBufferWriteReset(&R_ConsoleIob);
return(1);
case PARSE_INCOMPLETE:
R_IoBufferReadReset(&R_ConsoleIob);
state->prompt_type = 2;
return(2);
case PARSE_EOF:
return(-1);
break;
}
return(0);
}
