/*******************************************************************************
* RProxy: Connector implementation between application and R language
* Copyright (C) 1999--2006 Thomas Baier
* Copyright 2006 R Development Core Team
*
* R_Proxy_init based on rtest.c, Copyright (C) 1998--2000
* R Development Core Team
*
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Library General Public
* License as published by the Free Software Foundation; either
* version 2 of the License, or (at your option) any later version.
*
* This library is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Library General Public License for more details.
*
* You should have received a copy of the GNU Library General Public
* License along with this library; if not, write to the Free
* Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
* MA 02110-1301, USA.
*
******************************************************************************/
#include <windows.h>
#include <stdio.h>
#include <stdlib.h>
#define NEW
#include <config.h>
#ifdef NEW
# include <Rinternals.h>
#else
# include <Defn.h>
#endif
#include <Rversion.h>
#include <Rembedded.h>
#include <R_ext/RStartup.h>
#include <R_ext/GraphicsDevice.h>
#include <graphapp.h>
#include "bdx_SEXP.h"
#include "bdx_util.h"
#include "SC_proxy.h"
#include "rproxy.h"
#include "rproxy_impl.h"
#ifdef NEW
# include <R_ext/Parse.h>
#else
/* <FIXME> Thees are private header files */
# include <IOStuff.h>
# include <Parse.h>
#endif
#define TRCBUFSIZE 2048
struct _R_Proxy_init_parameters g_R_Proxy_init_parameters = { 0 };
/* calls into the R DLL */
extern char *getRHOME();
int R_Proxy_Graphics_Driver (NewDevDesc* pDD,
char* pDisplay,
double pWidth,
double pHeight,
double pPointSize);
extern SC_CharacterDevice* __output_device;
/* trace to DebugView */
int R_Proxy_printf(char const* pFormat,...)
{
static char __tracebuf[TRCBUFSIZE];
va_list lArgs;
va_start(lArgs, pFormat);
vsnprintf(__tracebuf,TRCBUFSIZE, pFormat, lArgs);
OutputDebugString(__tracebuf);
return 0;
}
#ifndef NEW
static int s_EvalInProgress = 0;
#endif
static void R_Proxy_askok (char* pMsg)
{
askok(pMsg);
return;
}
static int R_Proxy_askyesnocancel (char* pMsg)
{
return YES;
}
static int
R_Proxy_ReadConsole(char *prompt, char *buf, int len, int addtohistory)
{
return 0;
}
static void R_Proxy_WriteConsole(char *buf, int len)
{
if (__output_device) {
__output_device->vtbl->write_string (__output_device,buf);
}
}
static void R_Proxy_CallBack()
{
/* called during i/o, eval, graphics in ProcessEvents */
}
static void R_Proxy_Busy(int which)
{
/* set a busy cursor ... in which = 1, unset if which = 0 */
}
/* 00-02-18 | baier | parse parameter string and fill parameter structure */
/* 06-06-18 | baier | parse parameter "dm" */
int R_Proxy_parse_parameters (char const* pParameterString,
struct _R_Proxy_init_parameters* pParameterStruct)
{
/*
* parameter string is of the form name1=value1;name2=value2;...
*
* currently recognized parameter names (case-sensitive):
*
* (obsolete) NSIZE ... number of cons cells, (unsigned int) parameter
* (obsolete) VSIZE ... size of vector heap, (unsigned int) parameter
* dm ...... data mode (unsigned long, see below)
*/
int lDone = 0;
char const* lParameterStart = pParameterString;
int lIndexOfSemicolon = 0;
char* lTmpBuffer = NULL;
char* lPosOfSemicolon = NULL;
RPROXY_TRACE(printf("R_Proxy_parse_parameters(\"%s\")\n",pParameterString));
while (!lDone) {
/*
* dm: data mode?
* --------------
*
* 0 ... default data transfer mode
* 1 ... read +Inf and -Inf in double representation
*/
if(strncmp (lParameterStart,"dm=",3) == 0) {
RPROXY_TRACE(printf("param dm found, parsing\n"));
lParameterStart += 3;
lPosOfSemicolon = strchr (lParameterStart,';');
lIndexOfSemicolon = lPosOfSemicolon - lParameterStart;
if (lPosOfSemicolon) {
lTmpBuffer = malloc (lIndexOfSemicolon + 1); /* to catch NSIZE=; */
strncpy (lTmpBuffer,lParameterStart,lIndexOfSemicolon);
*(lTmpBuffer + lIndexOfSemicolon) = 0x0;
bdx_set_datamode(atol(lTmpBuffer));
if(pParameterStruct) {
pParameterStruct->dm = atol (lTmpBuffer);
}
free (lTmpBuffer);
lParameterStart += lIndexOfSemicolon + 1;
} else {
bdx_set_datamode(atol(lParameterStart));
if(pParameterStruct) {
pParameterStruct->dm = atol(lParameterStart);
}
lDone = 1;
}
} else if (strncmp (lParameterStart,"REUSER",6) == 0) {
if(pParameterStruct) {
pParameterStruct->reuseR = 1;
}
lParameterStart = lParameterStart + 6;
if(*lParameterStart == ';') {
lParameterStart++;
}
RPROXY_TRACE(printf("param REUSER, rest is \"%s\"\n",
lParameterStart));
} else {
lDone = 1;
}
}
#if 0
/* NSIZE? */
if (strncmp (lParameterStart,"NSIZE=",6) == 0)
{
lParameterStart += 6;
lPosOfSemicolon = strchr (lParameterStart,';');
lIndexOfSemicolon = lPosOfSemicolon - lParameterStart;
if (lPosOfSemicolon)
{
lTmpBuffer = malloc (lIndexOfSemicolon + 1); /* to catch NSIZE=; */
strncpy (lTmpBuffer,lParameterStart,lIndexOfSemicolon);
*(lTmpBuffer + lIndexOfSemicolon) = 0x0;
pParameterStruct->nsize_valid = 1;
pParameterStruct->nsize = atoi(lTmpBuffer);
free (lTmpBuffer);
lParameterStart += lIndexOfSemicolon + 1;
}
else
{
pParameterStruct->nsize_valid = 1;
pParameterStruct->nsize = atoi(lParameterStart);
lDone = 1;
}
}
else if (strncmp (lParameterStart,"VSIZE=",6) == 0)
{
lParameterStart += 6;
lPosOfSemicolon = strchr (lParameterStart,';');
lIndexOfSemicolon = lPosOfSemicolon - lParameterStart;
if (lPosOfSemicolon)
{
lTmpBuffer = malloc (lIndexOfSemicolon + 1); /* to catch VSIZE=; */
strncpy (lTmpBuffer,lParameterStart,lIndexOfSemicolon);
*(lTmpBuffer + lIndexOfSemicolon) = 0x0;
pParameterStruct->vsize_valid = 1;
pParameterStruct->vsize = atoi (lTmpBuffer);
free (lTmpBuffer);
lParameterStart += lIndexOfSemicolon + 1;
}
else
{
pParameterStruct->vsize_valid = 1;
pParameterStruct->vsize = atoi (lParameterStart);
lDone = 1;
}
}
#endif
return 0;
}
/* 00-02-18 | baier | R_Proxy_init() now takes parameter string, parse it */
/* 03-06-01 | baier | now we add %R_HOME%\bin to %PATH% */
/* 06-06-18 | baier | parameter parsing enabled in parent function */
int R_Proxy_init (char const* pParameterString)
{
structRstart rp;
Rstart Rp = &rp;
char Rversion[25];
static char RHome[MAX_PATH];
snprintf(Rversion, 25, "%s.%s", R_MAJOR, R_MINOR);
if(strncmp(getDLLVersion(), Rversion, 25) != 0) {
fprintf(stderr, "Error: R.DLL version does not match\n");
return SC_PROXY_ERR_UNKNOWN;
}
R_DefParams(Rp);
/* <FIXME> the documented interface is get_R_HOME() */
/* first, try process-local environment space (CRT) */
if (getenv("R_HOME")) {
strcpy(RHome, getenv("R_HOME"));
} else {
/* get variable from process-local environment space (Windows API) */
if (GetEnvironmentVariable ("R_HOME", RHome, sizeof (RHome)) == 0) {
/* not found, fall back to getRHOME() */
strcpy(RHome, getRHOME());
}
}
/* now we add %R_HOME%\bin to %PATH% (for dynamically loaded modules there) */
{
char buf[2048];
snprintf(buf, 2048, "PATH=%s\\bin;%s",RHome,getenv("PATH"));
putenv(buf);
}
Rp->rhome = RHome;
Rp->home = getRUser();
Rp->CharacterMode = LinkDLL;
Rp->ReadConsole = R_Proxy_ReadConsole;
Rp->WriteConsole = R_Proxy_WriteConsole;
Rp->CallBack = R_Proxy_CallBack;
Rp->ShowMessage = R_Proxy_askok;
Rp->YesNoCancel = R_Proxy_askyesnocancel;
Rp->Busy = R_Proxy_Busy;
Rp->R_Quiet = 1;
Rp->RestoreAction = SA_NORESTORE;
Rp->SaveAction = SA_NOSAVE; /* had 2, with comment 'no save' which is 3 */
R_SetParams(Rp);
R_set_command_line_arguments(0, NULL);
GA_initapp(0, 0);
readconsolecfg();
setup_Rmainloop();
R_ReplDLLinit();
return SC_PROXY_OK;
}
#ifdef NEW
int R_Proxy_evaluate (char const* pCmd, BDX_Data** pData)
{
SEXP lSexp;
int lRc = SC_PROXY_OK, evalError = 0;
ParseStatus lStatus;
SEXP lResult;
lSexp = R_ParseVector(mkString(pCmd), 1, &lStatus);
/* This is an EXPRSXP: we assume just one expression */
switch (lStatus) {
case PARSE_OK:
PROTECT(lSexp);
lResult = R_tryEval(VECTOR_ELT(lSexp, 0), R_GlobalEnv, &evalError);
UNPROTECT(1);
if(evalError) lRc = SC_PROXY_ERR_EVALUATE_STOP;
else lRc = SEXP2BDX(lResult, pData);
break;
case PARSE_INCOMPLETE:
lRc = SC_PROXY_ERR_PARSE_INCOMPLETE;
break;
default:
lRc = SC_PROXY_ERR_PARSE_INVALID;
break;
}
return lRc;
}
#else
/* 01-06-05 | baier | SETJMP and fatal error handling around eval() */
/* 04-08-01 | baier | ref-counting in case of error */
/* 04-10-11 | baier | restore original ref-counting */
/* 05-05-15 | baier | rework SETJMP code (store/restore jmp_buf) */
int R_Proxy_evaluate (char const* pCmd, BDX_Data** pData)
{
SEXP rho = R_GlobalEnv;
IoBuffer lBuffer;
SEXP lSexp;
int lRc;
ParseStatus lStatus;
SEXP lResult;
/* for SETJMP/LONGJMP */
s_EvalInProgress = 0;
R_IoBufferInit (&lBuffer);
R_IoBufferPuts ((char*) pCmd, &lBuffer);
R_IoBufferPuts ("\n", &lBuffer);
R_IoBufferReadReset (&lBuffer);
lSexp = R_Parse1Buffer (&lBuffer, 1, &lStatus);
PrintValue(lSexp);
switch (lStatus)
{
case PARSE_OK:
R_Visible = 0; /* Not printing, so not used */
R_EvalDepth = 0;
PROTECT(lSexp);
{
JMP_BUF lJmpBuf;
memcpy(lJmpBuf, R_Toplevel.cjmpbuf, sizeof(lJmpBuf));
SETJMP (R_Toplevel.cjmpbuf);
R_GlobalContext = R_ToplevelContext = &R_Toplevel;
if (!s_EvalInProgress)
{
/* <FIXME> This does not set .Last.value, does not
print result and does not print warnings */
s_EvalInProgress = 1;
lResult = eval (lSexp, rho);
memcpy(R_Toplevel.cjmpbuf, lJmpBuf, sizeof(lJmpBuf));
s_EvalInProgress = 0;
}
else
{
memcpy(R_Toplevel. cjmpbuf,lJmpBuf, sizeof(lJmpBuf));
return SC_PROXY_ERR_EVALUATE_STOP;
}
}
lRc = SEXP2BDX(lResult, pData);
/* no last value */
UNPROTECT(1);
break;
case PARSE_INCOMPLETE:
lRc = SC_PROXY_ERR_PARSE_INCOMPLETE;
break;
default:
lRc = SC_PROXY_ERR_PARSE_INVALID;
break;
}
return lRc;
}
#endif
#ifdef NEW
int R_Proxy_evaluate_noreturn (char const* pCmd)
{
SEXP lSexp;
int lRc = SC_PROXY_OK, evalError = 0;
ParseStatus lStatus;
SEXP lResult;
lSexp = R_ParseVector(mkString(pCmd), 1, &lStatus);
/* It would make sense to allow multiple expressions here */
switch (lStatus) {
case PARSE_OK:
PROTECT(lSexp);
lResult = R_tryEval(VECTOR_ELT(lSexp, 0), R_GlobalEnv, &evalError);
UNPROTECT(1);
if(evalError) lRc = SC_PROXY_ERR_EVALUATE_STOP;
else lRc = SC_PROXY_OK;
break;
case PARSE_INCOMPLETE:
lRc = SC_PROXY_ERR_PARSE_INCOMPLETE;
break;
default:
lRc = SC_PROXY_ERR_PARSE_INVALID;
break;
}
return lRc;
}
#else
/* 01-06-05 | baier | SETJMP and fatal error handling around eval() */
/* 04-08-01 | baier | ref-counting in case of error */
/* 04-10-11 | baier | restore original ref-counting */
/* 05-05-15 | baier | rework SETJMP code (store/restore jmp_buf) */
int R_Proxy_evaluate_noreturn (char const* pCmd)
{
SEXP rho = R_GlobalEnv;
IoBuffer lBuffer;
SEXP lSexp;
int lRc;
ParseStatus lStatus;
/* for SETJMP/LONGJMP */
s_EvalInProgress = 0;
R_IoBufferInit (&lBuffer);
R_IoBufferPuts ((char*) pCmd, &lBuffer);
R_IoBufferPuts ("\n", &lBuffer);
R_IoBufferReadReset (&lBuffer);
lSexp = R_Parse1Buffer (&lBuffer, 1, &lStatus);
PrintValue(lSexp);
switch (lStatus)
{
case PARSE_OK:
R_Visible = 0;
R_EvalDepth = 0;
PROTECT(lSexp);
{
JMP_BUF lJmpBuf;
memcpy(lJmpBuf, R_Toplevel.cjmpbuf, sizeof(lJmpBuf));
SETJMP (R_Toplevel.cjmpbuf);
R_GlobalContext = R_ToplevelContext = &R_Toplevel;
if (!s_EvalInProgress)
{
s_EvalInProgress = 1;
eval (lSexp, rho);
memcpy(R_Toplevel.cjmpbuf, lJmpBuf, sizeof(lJmpBuf));
s_EvalInProgress = 0;
}
else
{
memcpy(R_Toplevel.cjmpbuf, lJmpBuf, sizeof(lJmpBuf));
return SC_PROXY_ERR_EVALUATE_STOP;
}
}
/* no last value */
UNPROTECT(1);
lRc = SC_PROXY_OK;
break;
case PARSE_INCOMPLETE:
lRc = SC_PROXY_ERR_PARSE_INCOMPLETE;
break;
default:
lRc = SC_PROXY_ERR_PARSE_INVALID;
break;
}
return lRc;
}
#endif
#ifdef NEW
int R_Proxy_get_symbol (char const* pSymbol, BDX_Data** pData)
{
SEXP lVar = findVar (install((char*) pSymbol), R_GlobalEnv);
if (lVar == R_UnboundValue) {
RPROXY_TRACE(printf(">> %s is an unbound value\n", pSymbol));
return SC_PROXY_ERR_INVALIDSYMBOL;
} else if(SEXP2BDX(lVar, pData) == 0)
return SC_PROXY_OK;
else
return SC_PROXY_ERR_UNSUPPORTEDTYPE;
}
#else
int R_Proxy_get_symbol (char const* pSymbol, BDX_Data** pData)
{
IoBuffer lBuffer;
SEXP lSexp;
SEXP lVar;
ParseStatus lStatus;
R_IoBufferInit (&lBuffer);
R_IoBufferPuts ((char*) pSymbol, &lBuffer);
R_IoBufferPuts ("\n", &lBuffer);
/* don't generate code, just a try */
R_IoBufferReadReset (&lBuffer);
lSexp = R_Parse1Buffer (&lBuffer, 0, &lStatus);
if (lStatus == PARSE_OK)
{
/* now generate code */
R_IoBufferReadReset (&lBuffer);
lSexp = R_Parse1Buffer (&lBuffer, 1, &lStatus);
R_Visible = 0;
R_EvalDepth = 0;
PROTECT(lSexp);
/* check for valid symbol... */
if (TYPEOF (lSexp) != SYMSXP)
{
RPROXY_TRACE(printf(">> %s is not a symbol\n", pSymbol));
UNPROTECT (1);
return SC_PROXY_ERR_INVALIDSYMBOL;
}
lVar = findVar (lSexp, R_GlobalEnv);
if (lVar == R_UnboundValue)
{
RPROXY_TRACE(printf(">> %s is an unbound value\n", pSymbol));
UNPROTECT (1);
return SC_PROXY_ERR_INVALIDSYMBOL;
}
{
int lRc = SEXP2BDX(lVar, pData);
UNPROTECT (1);
if(lRc == 0) {
return SC_PROXY_OK;
} else {
return SC_PROXY_ERR_UNSUPPORTEDTYPE;
}
}
}
return SC_PROXY_OK; /* Really? - gets here on invalid input! */
}
#endif
/* 04-02-19 | baier | don't PROTECT strings in a vector, new data structs */
/* 04-03-02 | baier | removed traces */
/* 04-10-15 | baier | no more BDX_VECTOR (only BDX_ARRAY) */
/* 05-05-16 | baier | use BDX2SEXP, clean-up */
int R_Proxy_set_symbol (char const* pSymbol, BDX_Data const* pData)
{
SEXP lSymbol = 0;
SEXP lData = 0;
if(BDX2SEXP(pData,&lData) != 0) {
return SC_PROXY_ERR_UNSUPPORTEDTYPE;
}
/* RPROXY_TRACE(printf("ok BDX2SEXP\n")); */
/* install a new symbol or get the existing symbol */
lSymbol = install ((char*) pSymbol);
/* and set the data to the symbol */
setVar(lSymbol, lData, R_GlobalEnv);
return SC_PROXY_OK;
}
int R_Proxy_term ()
{
/* end_Rmainloop(); note, this never returns */
Rf_endEmbeddedR(0);
return SC_PROXY_OK;
}
syntax highlighted by Code2HTML, v. 0.9.1