/* Initialize R, that is start an embedded R.
Parameters are found in the global 'initargv'.
Return 0 on success, -1 on failure.
*/
int
EmbeddedR_init(void) {
if (RINTERF_ISREADY()) {
printf("R is already ready.\n");
return -1;
}
RStatus ^= RINTERF_IDLE;
if (! RINTERF_HASARGSSET()) {
/* Initialization arguments must be set and
R can only be initialized once */
printf("Initialization parameters must be set first.\n");
RStatus ^= RINTERF_IDLE;
return -1;
}
if (! initargv) {
printf("No initialisation argument. This should have been caught earlier.\n");
RStatus ^= RINTERF_IDLE;
return -1;
}
int status = Rf_initEmbeddedR(initargv->argc, initargv->argv);
if (status < 0) {
printf("R initialization failed.\n");
RStatus ^= RINTERF_IDLE;
return -1;
}
/* R_Interactive = TRUE; */
/* #ifdef RIF_HAS_RSIGHAND */
/* R_SignalHandlers = 0; */
/* #endif */
/* #ifdef CSTACK_DEFNS */
/* /\* Taken from JRI: */
/* * disable stack checking, because threads will thow it off *\/ */
/* R_CStackStart = (uintptr_t) -1; */
/* R_CStackLimit = (uintptr_t) -1; */
/* /\* --- *\/ */
/* #endif */
//setup_Rmainloop();
/*FIXME: setting readline variables so R's oddly static declarations
become harmless*/
#ifdef HAS_READLINE
char *rl_completer, *rl_basic;
rl_completer = strndup(rl_completer_word_break_characters, 200);
rl_completer_word_break_characters = rl_completer;
rl_basic = strndup(rl_basic_word_break_characters, 200);
rl_basic_word_break_characters = rl_basic;
#endif
/* */
errMessage_SEXP = findVar(install("geterrmessage"),
R_BaseNamespace);
RStatus |= (RINTERF_INITIALIZED);
RStatus ^= RINTERF_IDLE;
return 0;
}
static void checkHandler(const char * name, SEXP eventEnv)
{
SEXP handler = findVar(install(name), eventEnv);
if (TYPEOF(handler) == CLOSXP)
warning(_("'%s' events not supported in this device"), name);
}
SEXP
do_getGraphicsEvent(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP result = R_NilValue, prompt;
pDevDesc dd;
pGEDevDesc gd;
int i, count=0, devNum;
checkArity(op, args);
prompt = CAR(args);
if (!isString(prompt) || !length(prompt)) error(_("invalid prompt"));
/* NB: cleanup of event handlers must be done by driver in onExit handler */
if (!NoDevices()) {
/* Initialize all devices */
i = 1;
devNum = curDevice();
while (i++ < NumDevices()) {
gd = GEgetDevice(devNum);
dd = gd->dev;
if (dd->gettingEvent)
error(_("recursive use of 'getGraphicsEvent' not supported"));
if (dd->eventEnv != R_NilValue) {
if (dd->eventHelper) dd->eventHelper(dd, 1);
dd->gettingEvent = TRUE;
defineVar(install("result"), R_NilValue, dd->eventEnv);
count++;
}
devNum = nextDevice(devNum);
}
if (!count)
error(_("no graphics event handlers set"));
Rprintf("%s\n", CHAR(asChar(prompt)));
R_FlushConsole();
/* Poll them */
while (result == R_NilValue) {
/* make sure we still have at least one device listening for events, and throw an error if not*/
if(!haveListeningDev())
return R_NilValue;
#ifdef Win32
R_WaitEvent();
#endif
R_ProcessEvents();
R_CheckUserInterrupt();
i = 1;
devNum = curDevice();
while (i++ < NumDevices()) {
gd = GEgetDevice(devNum);
dd = gd->dev;
if (dd->eventEnv != R_NilValue) {
if (dd->eventHelper) dd->eventHelper(dd, 2);
result = findVar(install("result"), dd->eventEnv);
if (result != R_NilValue && result != R_UnboundValue) {
break;
}
}
devNum = nextDevice(devNum);
}
}
/* clean up */
i = 1;
devNum = curDevice();
while (i++ < NumDevices()) {
gd = GEgetDevice(devNum);
dd = gd->dev;
if (dd->eventEnv != R_NilValue) {
if (dd->eventHelper) dd->eventHelper(dd, 0);
dd->gettingEvent = FALSE;
}
devNum = nextDevice(devNum);
}
}
return(result);
}
SEXP R_initMethodDispatch(SEXP envir)
{
if(envir && !isNull(envir))
Methods_Namespace = envir;
if(!Methods_Namespace)
Methods_Namespace = R_GlobalEnv;
if(initialized)
return(envir);
s_dot_Methods = install(".Methods");
s_skeleton = install("skeleton");
s_expression = install("expression");
s_function = install("function");
s_getAllMethods = install("getAllMethods");
s_objectsEnv = install("objectsEnv");
s_MethodsListSelect = install("MethodsListSelect");
s_sys_dot_frame = install("sys.frame");
s_sys_dot_call = install("sys.call");
s_sys_dot_function = install("sys.function");
s_generic = install("generic");
s_generic_dot_skeleton = install("generic.skeleton");
s_subset_gets = install("[<-");
s_element_gets = install("[[<-");
s_argument = install("argument");
s_allMethods = install("allMethods");
R_FALSE = ScalarLogical(FALSE);
R_PreserveObject(R_FALSE);
R_TRUE = ScalarLogical(TRUE);
R_PreserveObject(R_TRUE);
/* some strings (NOT symbols) */
s_missing = mkString("missing");
setAttrib(s_missing, R_PackageSymbol, mkString("methods"));
R_PreserveObject(s_missing);
s_base = mkString("base");
R_PreserveObject(s_base);
/* Initialize method dispatch, using the static */
R_set_standardGeneric_ptr(
(table_dispatch_on ? R_dispatchGeneric : R_standardGeneric)
, Methods_Namespace);
R_set_quick_method_check(
(table_dispatch_on ? R_quick_dispatch : R_quick_method_check));
/* Some special lists of primitive skeleton calls.
These will be promises under lazy-loading.
*/
PROTECT(R_short_skeletons =
findVar(install(".ShortPrimitiveSkeletons"),
Methods_Namespace));
if(TYPEOF(R_short_skeletons) == PROMSXP)
R_short_skeletons = eval(R_short_skeletons, Methods_Namespace);
R_PreserveObject(R_short_skeletons);
UNPROTECT(1);
PROTECT(R_empty_skeletons =
findVar(install(".EmptyPrimitiveSkeletons"),
Methods_Namespace));
if(TYPEOF(R_empty_skeletons) == PROMSXP)
R_empty_skeletons = eval(R_empty_skeletons, Methods_Namespace);
R_PreserveObject(R_empty_skeletons);
UNPROTECT(1);
if(R_short_skeletons == R_UnboundValue ||
R_empty_skeletons == R_UnboundValue)
error(_("could not find the skeleton calls for 'methods' (package detached?): expect very bad things to happen"));
f_x_i_skeleton = VECTOR_ELT(R_short_skeletons, 0);
fgets_x_i_skeleton = VECTOR_ELT(R_short_skeletons, 1);
f_x_skeleton = VECTOR_ELT(R_empty_skeletons, 0);
fgets_x_skeleton = VECTOR_ELT(R_empty_skeletons, 1);
init_loadMethod();
initialized = 1;
return(envir);
}
/******************************************************************************
* *
* execExp/1 *
* *
* This routine attempts to evaulate the string expression as if it was *
* an IF-THEN-FI execS expression. Take expression and generate an *
* if ( expression ) then $i=0 endif, give it to the parser , then use *
* execR() to evaluate it. *
* For single variable expressions *
* if not present, expression is false *
* if real variable & inactive, expression is false *
* if string & null string value, expression is false *
* For Multiple variable expressions *
* if a variable is not present, Error is reported & error returned *
* Parser errors return -1 *
* *
* Author: Greg Brissey 5/31/90 *
******************************************************************************/
int execExp(const char *buffer)
{
char *expbuf;
int explen;
char *prevTempID;
const char *oldbp;
int oldFromFile;
int oldFromString;
node *oldcodeTree;
int returnCode=0;
int gocheckit;
LPRINT0(1,"execExp: starting...\n");
LPRINT1(1,"execExp: expression ='%s'\n",buffer);
if ( (explen = strlen(buffer)) > 0)
{
expbuf = allocateWithId( (explen + 35) * sizeof(char), "execExp");
if (expbuf == NULL)
{
Werrprintf("cannot allocate memory for expression string");
ABORT;
}
/* for parser: 'if ( expression ) then statement endif' */
strcpy(expbuf,"if ( ");
strcat(expbuf,buffer);
strcat(expbuf," ) then $i=0 endif \n");
LPRINT1(1,"execExp: parser expression ='%s'\n",expbuf);
oldFromFile = fromFile; /* push existing file info */
oldFromString = fromString;
oldbp = bp;
oldcodeTree = codeTree;
fromFile = 0;
fromString = 1;
bp = expbuf;
codeTree = NULL;
prevTempID = tempID; tempID = newTempName("tmpExecExpID");
/* parse expression IF-THEN-FI */
switch (yyparse())
{ case 0:
LPRINT0(1,"execExp: ...parser gives code 0, go do it!\n");
#ifdef DEBUG
if ( 1 < Lflag)
{
showTree(0,"execExp: ",codeTree);
showFlavour(stderr,codeTree);
}
#endif
switch(codeTree->flavour)
{
case THEN: /* It has to be this or something is real wrong. */
{
char *name;
int shouldFree;
varInfo *v;
pair p;
/* was it a single variable expression ?*/
/* if not flavour, will be an operator not ID or LB */
gocheckit = 0;
v = NULL;
if ((codeTree->Lson->flavour == ID) ||
(codeTree->Lson->flavour == LB) )
{
if ( (name=execN(codeTree->Lson->Lson,&shouldFree,NULL)) )
{
if ( (v=findVar(name)) )
{
gocheckit = 2; /* variable present, check active */
}
else
{
gocheckit = 0; /* variable not present */
}
}
if (shouldFree)
{
LPRINT1(3,"execExp: ...releasing name %s\n",name);
release(name);
}
}
else
gocheckit = 1; /* two variable expression */
if (gocheckit)
{
if (execR(codeTree->Lson,&p, NULL))
{
if((gocheckit > 1) && (p.T.basicType == T_REAL) )
{
if (!v->active)
{
returnCode = 0;
cleanPair(&p);
break;
}
}
if((gocheckit > 1) && (p.T.basicType == T_STRING) )
{
if (strcmp(p.R->v.s,"n") == 0)
{
returnCode = 0;
cleanPair(&p);
break;
}
}
if (isTrue(&p))
{
LPRINT0(1,"execExp: IF-THEN-FI exp is true\n");
returnCode = 1;
}
else
{
LPRINT0(1,"execExp: IF-THEN-FI exp is false\n");
returnCode = 0;
}
}
else
{
LPRINT0(1,"execExp: IF-THEN-FI exp failed\n");
returnCode = -1;
}
cleanPair(&p);
}
else
returnCode = 0; /* variable not present */
}
break;
default:
WerrprintfWithPos(
"BUG! execExp has a bad flavour (=%d)",codeTree->flavour);
returnCode = -1;
break;
}
break;
case 1:
LPRINT0(1,"execExp: ...parser gives code 1, drop everything!\n");
ignoreEOL = 0; /* had a syntax error, drop it */
returnCode = -1;
break;
case 2:
LPRINT0(1,"execExp: ...parser gives code 2, incomplete expression, abort\n");
ignoreEOL = 0; /* had a syntax error, drop it */
returnCode = -1;
break;
}
codeTree = NULL;
releaseWithId(tempID); free(tempID); tempID = prevTempID;
fromFile = oldFromFile; /* restore old file/kbd/string state*/
fromString = oldFromString;
bp = oldbp;
codeTree = oldcodeTree;
releaseAllWithId("execExp");
LPRINT0(1,"execExp: finishing...\n");
}
else
{ fprintf(stderr,"execExp: string (=\"%s\") is null.\n",buffer);
returnCode = -1;
}
return(returnCode);
}
/******************************************************************************
* *
* evalName/3 *
* *
* var - variable, strval - buffer to return string value, *
* maxlen - length of buffer *
* This routine obtains the value of string variable *
* If variable does not exit, null string returned. *
* If variable is not a string, null string returned. *
* If string value length is greater than maxlen then only maxlen-1 char *
* are returned. *
* *
* an IF-THEN-FI execS expression. Take expression and generate an *
* if ( expression ) then $i=0 endif, give it to the parser , then use *
* execN() to obtain value. *
* *
* Author: Greg Brissey 6/6/90 *
******************************************************************************/
int execName(const char *var, char *strval, int maxlen)
{
char *expbuf;
int explen;
char *prevTempID;
const char *oldbp;
int oldFromFile;
int oldFromString;
node *oldcodeTree;
int returnCode=0;
LPRINT0(1,"execName: starting...\n");
LPRINT1(1,"execName: expression ='%s'\n",var);
if ( (explen = strlen(var)) > 0)
{
expbuf = (char *)allocateWithId( (explen + 35) * sizeof(char), "execName");
if (expbuf == NULL)
{
Werrprintf("cannot allocate memory for expression string");
ABORT;
}
/* for parser: 'if ( expression ) then statement endif' */
strcpy(expbuf,"if ( ");
strcat(expbuf,var);
strcat(expbuf," ) then $i=0 endif \n");
LPRINT1(1,"execName: parser expression ='%s'\n",expbuf);
oldFromFile = fromFile; /* push existing file info */
oldFromString = fromString;
oldbp = bp;
oldcodeTree = codeTree;
fromFile = 0;
fromString = 1;
bp = expbuf;
codeTree = NULL;
prevTempID = tempID; tempID = newTempName("tmpExecExpID");
/* parse expression IF-THEN-FI */
switch (yyparse())
{ case 0:
LPRINT0(1,"execName: ...parser gives code 0, go do it!\n");
#ifdef DEBUG
if ( 1 < Lflag)
{
showTree(0,"execName: ",codeTree);
showFlavour(stderr,codeTree);
}
#endif
switch(codeTree->flavour)
{
case THEN: /* It has to be this or something is real wrong. */
{
char *name;
int shouldFree;
varInfo *v;
pair p;
if ( (name=execN(codeTree->Lson->Lson,&shouldFree, NULL)) )
{
if ( (v=findVar(name)) ) /* does variable exist? */
{
if (execR(codeTree->Lson,&p, NULL)) /* obtain value info */
{
if (p.T.basicType == T_STRING)
{
if ( (int) strlen(p.R->v.s) >= maxlen)
{
strncpy(strval,p.R->v.s,maxlen-1);
strval[maxlen-1]=0; /* Null terminate string */
}
else
{
strcpy(strval,p.R->v.s);
}
}
else
*strval = 0;
}
else
*strval = 0;
cleanPair(&p);
}
else
{
*strval = 0; /* return null string */
}
}
if (shouldFree)
{
LPRINT1(3,"execName: ...releasing name %s\n",name);
release(name);
}
returnCode = strlen(strval);
}
break;
default:
WerrprintfWithPos(
"BUG! execName has a bad flavour (=%d)",codeTree->flavour);
returnCode = -1;
break;
}
break;
case 1:
LPRINT0(1,"execName: ...parser gives code 1, drop everything!\n");
ignoreEOL = 0; /* had a syntax error, drop it */
returnCode = -1;
break;
case 2:
LPRINT0(1,
"execName: ...parser gives code 2, incomplete expression, abort\n");
ignoreEOL = 0; /* had a syntax error, drop it */
returnCode = -1;
break;
}
codeTree = NULL;
releaseWithId(tempID); free(tempID); tempID = prevTempID;
fromFile = oldFromFile; /* restore old file/kbd/string state*/
fromString = oldFromString;
bp = oldbp;
codeTree = oldcodeTree;
releaseAllWithId("execName");
LPRINT0(1,"execName: finishing...\n");
}
else
{ fprintf(stderr,"execName: string (=\"%s\") is null.\n",var);
returnCode = -1;
}
return(returnCode);
}