The R Project SVN – R – Diff – /trunk/src/gnuwin32/front-ends/rproxy_impl.c


/*******************************************************************************
 *  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, a copy is available at
 
 *  http://www.r-project.org/Licenses/
 *
 ******************************************************************************/
 
#include <windows.h>
#include <stdio.h>
#include <stdlib.h>
 
#include <config.h>
 
# include <Rinternals.h>
#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"
 
# include <R_ext/Parse.h>
 
#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;
}
 
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;
}
 
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, R_NilValue);
    /* 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;
}
 
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, R_NilValue);
    /* 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;
}
 
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;
}
 
/* 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;
}
 

Rev 39999	Rev 42306
1	`/*******************************************************************************`	1	`/*******************************************************************************`
2	`* RProxy: Connector implementation between application and R language`	2	`* RProxy: Connector implementation between application and R language`
3	`* Copyright (C) 1999--2006 Thomas Baier`	3	`* Copyright (C) 1999--2006 Thomas Baier`
4	`* Copyright 2006 R Development Core Team`	4	`* Copyright 2006 R Development Core Team`
5	`*`	5	`*`
6	`* R_Proxy_init based on rtest.c, Copyright (C) 1998--2000`	6	`* R_Proxy_init based on rtest.c, Copyright (C) 1998--2000`
7	`* R Development Core Team`	7	`* R Development Core Team`
8	`*`	8	`*`
9	`*`	9	`*`
10	`* This library is free software; you can redistribute it and/or`	10	`* This library is free software; you can redistribute it and/or`
11	`* modify it under the terms of the GNU Library General Public`	11	`* modify it under the terms of the GNU Library General Public`
12	`* License as published by the Free Software Foundation; either`	12	`* License as published by the Free Software Foundation; either`
13	`* version 2 of the License, or (at your option) any later version.`	13	`* version 2 of the License, or (at your option) any later version.`
14	`*`	14	`*`
15	`* This library is distributed in the hope that it will be useful,`	15	`* This library is distributed in the hope that it will be useful,`
16	`* but WITHOUT ANY WARRANTY; without even the implied warranty of`	16	`* but WITHOUT ANY WARRANTY; without even the implied warranty of`
17	`* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU`	17	`* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU`
18	`* Library General Public License for more details.`	18	`* Library General Public License for more details.`
19	`*`	19	`*`
20	`* You should have received a copy of the GNU Library General Public`	20	`* You should have received a copy of the GNU Library General Public`
21	`* License along with this library; if not, write to the Free`	21	`* License along with this library; if not, a copy is available at`
22	`* Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,`	-
23	`* MA 02110-1301, USA.`	22	`* http://www.r-project.org/Licenses/`
24	`*`	23	`*`
25	`******************************************************************************/`	24	`******************************************************************************/`
26		25
27	`#include <windows.h>`	26	`#include <windows.h>`
28	`#include <stdio.h>`	27	`#include <stdio.h>`
29	`#include <stdlib.h>`	28	`#include <stdlib.h>`
30		29
31	`#include <config.h>`	30	`#include <config.h>`
32		31
33	`# include <Rinternals.h>`	32	`# include <Rinternals.h>`
34	`#include <Rversion.h>`	33	`#include <Rversion.h>`
35	`#include <Rembedded.h>`	34	`#include <Rembedded.h>`
36	`#include <R_ext/RStartup.h>`	35	`#include <R_ext/RStartup.h>`
37	`#include <R_ext/GraphicsDevice.h>`	36	`#include <R_ext/GraphicsDevice.h>`
38	`#include <graphapp.h>`	37	`#include <graphapp.h>`
39		38
40	`#include "bdx_SEXP.h"`	39	`#include "bdx_SEXP.h"`
41	`#include "bdx_util.h"`	40	`#include "bdx_util.h"`
42	`#include "SC_proxy.h"`	41	`#include "SC_proxy.h"`
43	`#include "rproxy.h"`	42	`#include "rproxy.h"`
44	`#include "rproxy_impl.h"`	43	`#include "rproxy_impl.h"`
45		44
46	`# include <R_ext/Parse.h>`	45	`# include <R_ext/Parse.h>`
47		46
48	`#define TRCBUFSIZE 2048`	47	`#define TRCBUFSIZE 2048`
49		48
50	`struct _R_Proxy_init_parameters g_R_Proxy_init_parameters = { 0 };`	49	`struct _R_Proxy_init_parameters g_R_Proxy_init_parameters = { 0 };`
51		50
52	`/* calls into the R DLL */`	51	`/* calls into the R DLL */`
53	`extern char *getRHOME();`	52	`extern char *getRHOME();`
54		53
55	`int R_Proxy_Graphics_Driver (NewDevDesc* pDD,`	54	`int R_Proxy_Graphics_Driver (NewDevDesc* pDD,`
56	`char* pDisplay,`	55	`char* pDisplay,`
57	`double pWidth,`	56	`double pWidth,`
58	`double pHeight,`	57	`double pHeight,`
59	`double pPointSize);`	58	`double pPointSize);`
60		59
61	`extern SC_CharacterDevice* __output_device;`	60	`extern SC_CharacterDevice* __output_device;`
62		61
63	`/* trace to DebugView */`	62	`/* trace to DebugView */`
64	`int R_Proxy_printf(char const* pFormat,...)`	63	`int R_Proxy_printf(char const* pFormat,...)`
65	`{`	64	`{`
66	`static char __tracebuf[TRCBUFSIZE];`	65	`static char __tracebuf[TRCBUFSIZE];`
67		66
68	`va_list lArgs;`	67	`va_list lArgs;`
69	`va_start(lArgs, pFormat);`	68	`va_start(lArgs, pFormat);`
70	`vsnprintf(__tracebuf,TRCBUFSIZE, pFormat, lArgs);`	69	`vsnprintf(__tracebuf,TRCBUFSIZE, pFormat, lArgs);`
71	`OutputDebugString(__tracebuf);`	70	`OutputDebugString(__tracebuf);`
72	`return 0;`	71	`return 0;`
73	`}`	72	`}`
74		73
75	`static void R_Proxy_askok (char* pMsg)`	74	`static void R_Proxy_askok (char* pMsg)`
76	`{`	75	`{`
77	`askok(pMsg);`	76	`askok(pMsg);`
78	`return;`	77	`return;`
79	`}`	78	`}`
80		79
81	`static int R_Proxy_askyesnocancel (char* pMsg)`	80	`static int R_Proxy_askyesnocancel (char* pMsg)`
82	`{`	81	`{`
83	`return YES;`	82	`return YES;`
84	`}`	83	`}`
85		84
86	`static int`	85	`static int`
87	`R_Proxy_ReadConsole(char prompt, char buf, int len, int addtohistory)`	86	`R_Proxy_ReadConsole(char prompt, char buf, int len, int addtohistory)`
88	`{`	87	`{`
89	`return 0;`	88	`return 0;`
90	`}`	89	`}`
91		90
92	`static void R_Proxy_WriteConsole(char *buf, int len)`	91	`static void R_Proxy_WriteConsole(char *buf, int len)`
93	`{`	92	`{`
94	`if (__output_device) {`	93	`if (__output_device) {`
95	`__output_device->vtbl->write_string (__output_device,buf);`	94	`__output_device->vtbl->write_string (__output_device,buf);`
96	`}`	95	`}`
97	`}`	96	`}`
98		97
99	`static void R_Proxy_CallBack()`	98	`static void R_Proxy_CallBack()`
100	`{`	99	`{`
101	`/* called during i/o, eval, graphics in ProcessEvents */`	100	`/* called during i/o, eval, graphics in ProcessEvents */`
102	`}`	101	`}`
103		102
104	`static void R_Proxy_Busy(int which)`	103	`static void R_Proxy_Busy(int which)`
105	`{`	104	`{`
106	`/* set a busy cursor ... in which = 1, unset if which = 0 */`	105	`/* set a busy cursor ... in which = 1, unset if which = 0 */`
107	`}`	106	`}`
108		107
109	`/* 00-02-18 \| baier \| parse parameter string and fill parameter structure */`	108	`/* 00-02-18 \| baier \| parse parameter string and fill parameter structure */`
110	`/* 06-06-18 \| baier \| parse parameter "dm" */`	109	`/* 06-06-18 \| baier \| parse parameter "dm" */`
111	`int R_Proxy_parse_parameters (char const* pParameterString,`	110	`int R_Proxy_parse_parameters (char const* pParameterString,`
112	`struct _R_Proxy_init_parameters* pParameterStruct)`	111	`struct _R_Proxy_init_parameters* pParameterStruct)`
113	`{`	112	`{`
114	`/*`	113	`/*`
115	`* parameter string is of the form name1=value1;name2=value2;...`	114	`* parameter string is of the form name1=value1;name2=value2;...`
116	`*`	115	`*`
117	`* currently recognized parameter names (case-sensitive):`	116	`* currently recognized parameter names (case-sensitive):`
118	`*`	117	`*`
119	`* (obsolete) NSIZE ... number of cons cells, (unsigned int) parameter`	118	`* (obsolete) NSIZE ... number of cons cells, (unsigned int) parameter`
120	`* (obsolete) VSIZE ... size of vector heap, (unsigned int) parameter`	119	`* (obsolete) VSIZE ... size of vector heap, (unsigned int) parameter`
121	`* dm ...... data mode (unsigned long, see below)`	120	`* dm ...... data mode (unsigned long, see below)`
122	`*/`	121	`*/`
123	`int lDone = 0;`	122	`int lDone = 0;`
124	`char const* lParameterStart = pParameterString;`	123	`char const* lParameterStart = pParameterString;`
125	`int lIndexOfSemicolon = 0;`	124	`int lIndexOfSemicolon = 0;`
126	`char* lTmpBuffer = NULL;`	125	`char* lTmpBuffer = NULL;`
127	`char* lPosOfSemicolon = NULL;`	126	`char* lPosOfSemicolon = NULL;`
128		127
129	`RPROXY_TRACE(printf("R_Proxy_parse_parameters(\"%s\")\n",pParameterString));`	128	`RPROXY_TRACE(printf("R_Proxy_parse_parameters(\"%s\")\n",pParameterString));`
130		129
131	`while (!lDone) {`	130	`while (!lDone) {`
132	`/*`	131	`/*`
133	`* dm: data mode?`	132	`* dm: data mode?`
134	`* --------------`	133	`* --------------`
135	`*`	134	`*`
136	`* 0 ... default data transfer mode`	135	`* 0 ... default data transfer mode`
137	`* 1 ... read +Inf and -Inf in double representation`	136	`* 1 ... read +Inf and -Inf in double representation`
138	`*/`	137	`*/`
139	`if(strncmp (lParameterStart,"dm=",3) == 0) {`	138	`if(strncmp (lParameterStart,"dm=",3) == 0) {`
140	`RPROXY_TRACE(printf("param dm found, parsing\n"));`	139	`RPROXY_TRACE(printf("param dm found, parsing\n"));`
141	`lParameterStart += 3;`	140	`lParameterStart += 3;`
142		141
143	`lPosOfSemicolon = strchr (lParameterStart,';');`	142	`lPosOfSemicolon = strchr (lParameterStart,';');`
144	`lIndexOfSemicolon = lPosOfSemicolon - lParameterStart;`	143	`lIndexOfSemicolon = lPosOfSemicolon - lParameterStart;`
145		144
146	`if (lPosOfSemicolon) {`	145	`if (lPosOfSemicolon) {`
147	`lTmpBuffer = malloc (lIndexOfSemicolon + 1); /* to catch NSIZE=; */`	146	`lTmpBuffer = malloc (lIndexOfSemicolon + 1); /* to catch NSIZE=; */`
148	`strncpy (lTmpBuffer,lParameterStart,lIndexOfSemicolon);`	147	`strncpy (lTmpBuffer,lParameterStart,lIndexOfSemicolon);`
149	`*(lTmpBuffer + lIndexOfSemicolon) = 0x0;`	148	`*(lTmpBuffer + lIndexOfSemicolon) = 0x0;`
150	`bdx_set_datamode(atol(lTmpBuffer));`	149	`bdx_set_datamode(atol(lTmpBuffer));`
151	`if(pParameterStruct) {`	150	`if(pParameterStruct) {`
152	`pParameterStruct->dm = atol (lTmpBuffer);`	151	`pParameterStruct->dm = atol (lTmpBuffer);`
153	`}`	152	`}`
154	`free (lTmpBuffer);`	153	`free (lTmpBuffer);`
155	`lParameterStart += lIndexOfSemicolon + 1;`	154	`lParameterStart += lIndexOfSemicolon + 1;`
156	`} else {`	155	`} else {`
157	`bdx_set_datamode(atol(lParameterStart));`	156	`bdx_set_datamode(atol(lParameterStart));`
158	`if(pParameterStruct) {`	157	`if(pParameterStruct) {`
159	`pParameterStruct->dm = atol(lParameterStart);`	158	`pParameterStruct->dm = atol(lParameterStart);`
160	`}`	159	`}`
161	`lDone = 1;`	160	`lDone = 1;`
162	`}`	161	`}`
163	`} else if (strncmp (lParameterStart,"REUSER",6) == 0) {`	162	`} else if (strncmp (lParameterStart,"REUSER",6) == 0) {`
164	`if(pParameterStruct) {`	163	`if(pParameterStruct) {`
165	`pParameterStruct->reuseR = 1;`	164	`pParameterStruct->reuseR = 1;`
166	`}`	165	`}`
167	`lParameterStart = lParameterStart + 6;`	166	`lParameterStart = lParameterStart + 6;`
168	`if(*lParameterStart == ';') {`	167	`if(*lParameterStart == ';') {`
169	`lParameterStart++;`	168	`lParameterStart++;`
170	`}`	169	`}`
171	`RPROXY_TRACE(printf("param REUSER, rest is \"%s\"\n",`	170	`RPROXY_TRACE(printf("param REUSER, rest is \"%s\"\n",`
172	`lParameterStart));`	171	`lParameterStart));`
173	`} else {`	172	`} else {`
174	`lDone = 1;`	173	`lDone = 1;`
175	`}`	174	`}`
176	`}`	175	`}`
177		176
178	`#if 0`	177	`#if 0`
179	`/* NSIZE? */`	178	`/* NSIZE? */`
180	`if (strncmp (lParameterStart,"NSIZE=",6) == 0)`	179	`if (strncmp (lParameterStart,"NSIZE=",6) == 0)`
181	`{`	180	`{`
182	`lParameterStart += 6;`	181	`lParameterStart += 6;`
183		182
184	`lPosOfSemicolon = strchr (lParameterStart,';');`	183	`lPosOfSemicolon = strchr (lParameterStart,';');`
185	`lIndexOfSemicolon = lPosOfSemicolon - lParameterStart;`	184	`lIndexOfSemicolon = lPosOfSemicolon - lParameterStart;`
186		185
187	`if (lPosOfSemicolon)`	186	`if (lPosOfSemicolon)`
188	`{`	187	`{`
189	`lTmpBuffer = malloc (lIndexOfSemicolon + 1); /* to catch NSIZE=; */`	188	`lTmpBuffer = malloc (lIndexOfSemicolon + 1); /* to catch NSIZE=; */`
190	`strncpy (lTmpBuffer,lParameterStart,lIndexOfSemicolon);`	189	`strncpy (lTmpBuffer,lParameterStart,lIndexOfSemicolon);`
191	`*(lTmpBuffer + lIndexOfSemicolon) = 0x0;`	190	`*(lTmpBuffer + lIndexOfSemicolon) = 0x0;`
192	`pParameterStruct->nsize_valid = 1;`	191	`pParameterStruct->nsize_valid = 1;`
193	`pParameterStruct->nsize = atoi(lTmpBuffer);`	192	`pParameterStruct->nsize = atoi(lTmpBuffer);`
194	`free (lTmpBuffer);`	193	`free (lTmpBuffer);`
195	`lParameterStart += lIndexOfSemicolon + 1;`	194	`lParameterStart += lIndexOfSemicolon + 1;`
196	`}`	195	`}`
197	`else`	196	`else`
198	`{`	197	`{`
199	`pParameterStruct->nsize_valid = 1;`	198	`pParameterStruct->nsize_valid = 1;`
200	`pParameterStruct->nsize = atoi(lParameterStart);`	199	`pParameterStruct->nsize = atoi(lParameterStart);`
201	`lDone = 1;`	200	`lDone = 1;`
202	`}`	201	`}`
203	`}`	202	`}`
204	`else if (strncmp (lParameterStart,"VSIZE=",6) == 0)`	203	`else if (strncmp (lParameterStart,"VSIZE=",6) == 0)`
205	`{`	204	`{`
206	`lParameterStart += 6;`	205	`lParameterStart += 6;`
207		206
208	`lPosOfSemicolon = strchr (lParameterStart,';');`	207	`lPosOfSemicolon = strchr (lParameterStart,';');`
209	`lIndexOfSemicolon = lPosOfSemicolon - lParameterStart;`	208	`lIndexOfSemicolon = lPosOfSemicolon - lParameterStart;`
210		209
211	`if (lPosOfSemicolon)`	210	`if (lPosOfSemicolon)`
212	`{`	211	`{`
213	`lTmpBuffer = malloc (lIndexOfSemicolon + 1); /* to catch VSIZE=; */`	212	`lTmpBuffer = malloc (lIndexOfSemicolon + 1); /* to catch VSIZE=; */`
214	`strncpy (lTmpBuffer,lParameterStart,lIndexOfSemicolon);`	213	`strncpy (lTmpBuffer,lParameterStart,lIndexOfSemicolon);`
215	`*(lTmpBuffer + lIndexOfSemicolon) = 0x0;`	214	`*(lTmpBuffer + lIndexOfSemicolon) = 0x0;`
216	`pParameterStruct->vsize_valid = 1;`	215	`pParameterStruct->vsize_valid = 1;`
217	`pParameterStruct->vsize = atoi (lTmpBuffer);`	216	`pParameterStruct->vsize = atoi (lTmpBuffer);`
218	`free (lTmpBuffer);`	217	`free (lTmpBuffer);`
219	`lParameterStart += lIndexOfSemicolon + 1;`	218	`lParameterStart += lIndexOfSemicolon + 1;`
220	`}`	219	`}`
221	`else`	220	`else`
222	`{`	221	`{`
223	`pParameterStruct->vsize_valid = 1;`	222	`pParameterStruct->vsize_valid = 1;`
224	`pParameterStruct->vsize = atoi (lParameterStart);`	223	`pParameterStruct->vsize = atoi (lParameterStart);`
225	`lDone = 1;`	224	`lDone = 1;`
226	`}`	225	`}`
227	`}`	226	`}`
228	`#endif`	227	`#endif`
229		228
230	`return 0;`	229	`return 0;`
231	`}`	230	`}`
232		231
233	`/* 00-02-18 \| baier \| R_Proxy_init() now takes parameter string, parse it */`	232	`/* 00-02-18 \| baier \| R_Proxy_init() now takes parameter string, parse it */`
234	`/* 03-06-01 \| baier \| now we add %R_HOME%\bin to %PATH% */`	233	`/* 03-06-01 \| baier \| now we add %R_HOME%\bin to %PATH% */`
235	`/* 06-06-18 \| baier \| parameter parsing enabled in parent function */`	234	`/* 06-06-18 \| baier \| parameter parsing enabled in parent function */`
236	`int R_Proxy_init (char const* pParameterString)`	235	`int R_Proxy_init (char const* pParameterString)`
237	`{`	236	`{`
238	`structRstart rp;`	237	`structRstart rp;`
239	`Rstart Rp = &rp;`	238	`Rstart Rp = &rp;`
240	`char Rversion[25];`	239	`char Rversion[25];`
241	`static char RHome[MAX_PATH];`	240	`static char RHome[MAX_PATH];`
242		241
243	`snprintf(Rversion, 25, "%s.%s", R_MAJOR, R_MINOR);`	242	`snprintf(Rversion, 25, "%s.%s", R_MAJOR, R_MINOR);`
244	`if(strncmp(getDLLVersion(), Rversion, 25) != 0) {`	243	`if(strncmp(getDLLVersion(), Rversion, 25) != 0) {`
245	`fprintf(stderr, "Error: R.DLL version does not match\n");`	244	`fprintf(stderr, "Error: R.DLL version does not match\n");`
246	`return SC_PROXY_ERR_UNKNOWN;`	245	`return SC_PROXY_ERR_UNKNOWN;`
247	`}`	246	`}`
248		247
249	`R_DefParams(Rp);`	248	`R_DefParams(Rp);`
250		249
251	`/* <FIXME> the documented interface is get_R_HOME() */`	250	`/* <FIXME> the documented interface is get_R_HOME() */`
252		251
253	`/* first, try process-local environment space (CRT) */`	252	`/* first, try process-local environment space (CRT) */`
254	`if (getenv("R_HOME")) {`	253	`if (getenv("R_HOME")) {`
255	`strcpy(RHome, getenv("R_HOME"));`	254	`strcpy(RHome, getenv("R_HOME"));`
256	`} else {`	255	`} else {`
257	`/* get variable from process-local environment space (Windows API) */`	256	`/* get variable from process-local environment space (Windows API) */`
258	`if (GetEnvironmentVariable ("R_HOME", RHome, sizeof (RHome)) == 0) {`	257	`if (GetEnvironmentVariable ("R_HOME", RHome, sizeof (RHome)) == 0) {`
259	`/* not found, fall back to getRHOME() */`	258	`/* not found, fall back to getRHOME() */`
260	`strcpy(RHome, getRHOME());`	259	`strcpy(RHome, getRHOME());`
261	`}`	260	`}`
262	`}`	261	`}`
263		262
264	`/* now we add %R_HOME%\bin to %PATH% (for dynamically loaded modules there) */`	263	`/* now we add %R_HOME%\bin to %PATH% (for dynamically loaded modules there) */`
265	`{`	264	`{`
266	`char buf[2048];`	265	`char buf[2048];`
267	`snprintf(buf, 2048, "PATH=%s\\bin;%s",RHome,getenv("PATH"));`	266	`snprintf(buf, 2048, "PATH=%s\\bin;%s",RHome,getenv("PATH"));`
268	`putenv(buf);`	267	`putenv(buf);`
269	`}`	268	`}`
270		269
271	`Rp->rhome = RHome;`	270	`Rp->rhome = RHome;`
272	`Rp->home = getRUser();`	271	`Rp->home = getRUser();`
273	`Rp->CharacterMode = LinkDLL;`	272	`Rp->CharacterMode = LinkDLL;`
274	`Rp->ReadConsole = R_Proxy_ReadConsole;`	273	`Rp->ReadConsole = R_Proxy_ReadConsole;`
275	`Rp->WriteConsole = R_Proxy_WriteConsole;`	274	`Rp->WriteConsole = R_Proxy_WriteConsole;`
276	`Rp->CallBack = R_Proxy_CallBack;`	275	`Rp->CallBack = R_Proxy_CallBack;`
277	`Rp->ShowMessage = R_Proxy_askok;`	276	`Rp->ShowMessage = R_Proxy_askok;`
278	`Rp->YesNoCancel = R_Proxy_askyesnocancel;`	277	`Rp->YesNoCancel = R_Proxy_askyesnocancel;`
279	`Rp->Busy = R_Proxy_Busy;`	278	`Rp->Busy = R_Proxy_Busy;`
280	`Rp->R_Quiet = 1;`	279	`Rp->R_Quiet = 1;`
281	`Rp->RestoreAction = SA_NORESTORE;`	280	`Rp->RestoreAction = SA_NORESTORE;`
282	`Rp->SaveAction = SA_NOSAVE; /* had 2, with comment 'no save' which is 3 */`	281	`Rp->SaveAction = SA_NOSAVE; /* had 2, with comment 'no save' which is 3 */`
283		282
284	`R_SetParams(Rp);`	283	`R_SetParams(Rp);`
285	`R_set_command_line_arguments(0, NULL);`	284	`R_set_command_line_arguments(0, NULL);`
286		285
287	`GA_initapp(0, 0);`	286	`GA_initapp(0, 0);`
288	`readconsolecfg();`	287	`readconsolecfg();`
289	`setup_Rmainloop();`	288	`setup_Rmainloop();`
290	`R_ReplDLLinit();`	289	`R_ReplDLLinit();`
291		290
292	`return SC_PROXY_OK;`	291	`return SC_PROXY_OK;`
293	`}`	292	`}`
294		293
295	`int R_Proxy_evaluate (char const* pCmd, BDX_Data** pData)`	294	`int R_Proxy_evaluate (char const* pCmd, BDX_Data** pData)`
296	`{`	295	`{`
297	`SEXP lSexp;`	296	`SEXP lSexp;`
298	`int lRc = SC_PROXY_OK, evalError = 0;`	297	`int lRc = SC_PROXY_OK, evalError = 0;`
299	`ParseStatus lStatus;`	298	`ParseStatus lStatus;`
300	`SEXP lResult;`	299	`SEXP lResult;`
301		300
302	`lSexp = R_ParseVector(mkString(pCmd), 1, &lStatus, R_NilValue);`	301	`lSexp = R_ParseVector(mkString(pCmd), 1, &lStatus, R_NilValue);`
303	`/* This is an EXPRSXP: we assume just one expression */`	302	`/* This is an EXPRSXP: we assume just one expression */`
304		303
305	`switch (lStatus) {`	304	`switch (lStatus) {`
306	`case PARSE_OK:`	305	`case PARSE_OK:`
307	`PROTECT(lSexp);`	306	`PROTECT(lSexp);`
308	`lResult = R_tryEval(VECTOR_ELT(lSexp, 0), R_GlobalEnv, &evalError);`	307	`lResult = R_tryEval(VECTOR_ELT(lSexp, 0), R_GlobalEnv, &evalError);`
309	`UNPROTECT(1);`	308	`UNPROTECT(1);`
310	`if(evalError) lRc = SC_PROXY_ERR_EVALUATE_STOP;`	309	`if(evalError) lRc = SC_PROXY_ERR_EVALUATE_STOP;`
311	`else lRc = SEXP2BDX(lResult, pData);`	310	`else lRc = SEXP2BDX(lResult, pData);`
312	`break;`	311	`break;`
313	`case PARSE_INCOMPLETE:`	312	`case PARSE_INCOMPLETE:`
314	`lRc = SC_PROXY_ERR_PARSE_INCOMPLETE;`	313	`lRc = SC_PROXY_ERR_PARSE_INCOMPLETE;`
315	`break;`	314	`break;`
316	`default:`	315	`default:`
317	`lRc = SC_PROXY_ERR_PARSE_INVALID;`	316	`lRc = SC_PROXY_ERR_PARSE_INVALID;`
318	`break;`	317	`break;`
319	`}`	318	`}`
320	`return lRc;`	319	`return lRc;`
321	`}`	320	`}`
322		321
323	`int R_Proxy_evaluate_noreturn (char const* pCmd)`	322	`int R_Proxy_evaluate_noreturn (char const* pCmd)`
324	`{`	323	`{`
325	`SEXP lSexp;`	324	`SEXP lSexp;`
326	`int lRc = SC_PROXY_OK, evalError = 0;`	325	`int lRc = SC_PROXY_OK, evalError = 0;`
327	`ParseStatus lStatus;`	326	`ParseStatus lStatus;`
328	`SEXP lResult;`	327	`SEXP lResult;`
329		328
330	`lSexp = R_ParseVector(mkString(pCmd), 1, &lStatus, R_NilValue);`	329	`lSexp = R_ParseVector(mkString(pCmd), 1, &lStatus, R_NilValue);`
331	`/* It would make sense to allow multiple expressions here */`	330	`/* It would make sense to allow multiple expressions here */`
332		331
333	`switch (lStatus) {`	332	`switch (lStatus) {`
334	`case PARSE_OK:`	333	`case PARSE_OK:`
335	`PROTECT(lSexp);`	334	`PROTECT(lSexp);`
336	`lResult = R_tryEval(VECTOR_ELT(lSexp, 0), R_GlobalEnv, &evalError);`	335	`lResult = R_tryEval(VECTOR_ELT(lSexp, 0), R_GlobalEnv, &evalError);`
337	`UNPROTECT(1);`	336	`UNPROTECT(1);`
338	`if(evalError) lRc = SC_PROXY_ERR_EVALUATE_STOP;`	337	`if(evalError) lRc = SC_PROXY_ERR_EVALUATE_STOP;`
339	`else lRc = SC_PROXY_OK;`	338	`else lRc = SC_PROXY_OK;`
340	`break;`	339	`break;`
341	`case PARSE_INCOMPLETE:`	340	`case PARSE_INCOMPLETE:`
342	`lRc = SC_PROXY_ERR_PARSE_INCOMPLETE;`	341	`lRc = SC_PROXY_ERR_PARSE_INCOMPLETE;`
343	`break;`	342	`break;`
344	`default:`	343	`default:`
345	`lRc = SC_PROXY_ERR_PARSE_INVALID;`	344	`lRc = SC_PROXY_ERR_PARSE_INVALID;`
346	`break;`	345	`break;`
347	`}`	346	`}`
348	`return lRc;`	347	`return lRc;`
349	`}`	348	`}`
350		349
351	`int R_Proxy_get_symbol (char const* pSymbol, BDX_Data** pData)`	350	`int R_Proxy_get_symbol (char const* pSymbol, BDX_Data** pData)`
352	`{`	351	`{`
353	`SEXP lVar = findVar (install((char*) pSymbol), R_GlobalEnv);`	352	`SEXP lVar = findVar (install((char*) pSymbol), R_GlobalEnv);`
354		353
355	`if (lVar == R_UnboundValue) {`	354	`if (lVar == R_UnboundValue) {`
356	`RPROXY_TRACE(printf(">> %s is an unbound value\n", pSymbol));`	355	`RPROXY_TRACE(printf(">> %s is an unbound value\n", pSymbol));`
357	`return SC_PROXY_ERR_INVALIDSYMBOL;`	356	`return SC_PROXY_ERR_INVALIDSYMBOL;`
358	`} else if(SEXP2BDX(lVar, pData) == 0)`	357	`} else if(SEXP2BDX(lVar, pData) == 0)`
359	`return SC_PROXY_OK;`	358	`return SC_PROXY_OK;`
360	`else`	359	`else`
361	`return SC_PROXY_ERR_UNSUPPORTEDTYPE;`	360	`return SC_PROXY_ERR_UNSUPPORTEDTYPE;`
362	`}`	361	`}`
363		362
364	`/* 04-02-19 \| baier \| don't PROTECT strings in a vector, new data structs */`	363	`/* 04-02-19 \| baier \| don't PROTECT strings in a vector, new data structs */`
365	`/* 04-03-02 \| baier \| removed traces */`	364	`/* 04-03-02 \| baier \| removed traces */`
366	`/* 04-10-15 \| baier \| no more BDX_VECTOR (only BDX_ARRAY) */`	365	`/* 04-10-15 \| baier \| no more BDX_VECTOR (only BDX_ARRAY) */`
367	`/* 05-05-16 \| baier \| use BDX2SEXP, clean-up */`	366	`/* 05-05-16 \| baier \| use BDX2SEXP, clean-up */`
368	`int R_Proxy_set_symbol (char const* pSymbol, BDX_Data const* pData)`	367	`int R_Proxy_set_symbol (char const* pSymbol, BDX_Data const* pData)`
369	`{`	368	`{`
370	`SEXP lSymbol = 0;`	369	`SEXP lSymbol = 0;`
371	`SEXP lData = 0;`	370	`SEXP lData = 0;`
372		371
373	`if(BDX2SEXP(pData,&lData) != 0) {`	372	`if(BDX2SEXP(pData,&lData) != 0) {`
374	`return SC_PROXY_ERR_UNSUPPORTEDTYPE;`	373	`return SC_PROXY_ERR_UNSUPPORTEDTYPE;`
375	`}`	374	`}`
376	`/* RPROXY_TRACE(printf("ok BDX2SEXP\n")); */`	375	`/* RPROXY_TRACE(printf("ok BDX2SEXP\n")); */`
377		376
378	`/* install a new symbol or get the existing symbol */`	377	`/* install a new symbol or get the existing symbol */`
379	`lSymbol = install ((char*) pSymbol);`	378	`lSymbol = install ((char*) pSymbol);`
380		379
381	`/* and set the data to the symbol */`	380	`/* and set the data to the symbol */`
382	`setVar(lSymbol, lData, R_GlobalEnv);`	381	`setVar(lSymbol, lData, R_GlobalEnv);`
383		382
384	`return SC_PROXY_OK;`	383	`return SC_PROXY_OK;`
385	`}`	384	`}`
386		385
387	`int R_Proxy_term ()`	386	`int R_Proxy_term ()`
388	`{`	387	`{`
389	`/* end_Rmainloop(); note, this never returns */`	388	`/* end_Rmainloop(); note, this never returns */`
390	`Rf_endEmbeddedR(0);`	389	`Rf_endEmbeddedR(0);`
391		390
392	`return SC_PROXY_OK;`	391	`return SC_PROXY_OK;`
393	`}`	392	`}`
394		393

The R Project SVN R

(root)/trunk/src/gnuwin32/front-ends/rproxy_impl.c @ 42657 – Rev 39999 → 42306