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--2001 Thomas Baier
 *
 *  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., 59 Temple Place - Suite 330, Boston,
 *  MA 02111-1307, USA
 *
 *  $Id: rproxy_impl.c,v 1.24 2004/06/09 13:35:32 ripley Exp $
 */
 
#define NONAMELESSUNION
#include <windows.h>
#include <assert.h>
#include <stdio.h>
#include <stdlib.h>
/*#include "globalvar.h"
#undef CharacterMode
#undef R_Interactive*/
#include <config.h>
#include <Rversion.h>
#include <Startup.h>
#include "bdx.h"
#include "SC_proxy.h"
#include "rproxy_impl.h"
#include <IOStuff.h>
#include <Parse.h>
#include <Graphics.h>
 
struct _R_Proxy_init_parameters
{
  int vsize;
  int vsize_valid;
  int nsize;
  int nsize_valid;
};
 
/* 01-12-07 | baier | no more extern for exported variables (crashes!) */
/*#define R_GlobalEnv (*__imp_R_GlobalEnv)
#define R_Visible (*__imp_R_Visible)
#define R_EvalDepth (*__imp_R_EvalDepth)
#define R_DimSymbol (*__imp_R_DimSymbol)*/
 
/*
extern SEXP R_GlobalEnv;
extern int R_Visible;
extern int R_EvalDepth;
extern SEXP R_DimSymbol;
*/
 
/* calls into the R DLL */
extern char *getDLLVersion();
extern void R_DefParams(Rstart);
extern void R_SetParams(Rstart);
extern void setup_term_ui(void);
extern char *getRHOME();
extern void end_Rmainloop(), R_ReplDLLinit();
extern void askok(char *);
 
int R_Proxy_Graphics_Driver (NewDevDesc* pDD,
			     char* pDisplay,
			     double pWidth,
			     double pHeight,
			     double pPointSize);
 
extern SC_CharacterDevice* __output_device;
 
/* trace to DebugView */
int RPROXYTRACE(char const* pFormat,...);
 
int RPROXYTRACE(char const* pFormat,...)
{
  static char __tracebuf[2048];
 
  va_list lArgs;
  va_start(lArgs,pFormat);
  vsprintf(__tracebuf,pFormat,lArgs);
  OutputDebugString(__tracebuf);
  return 0;
}
 
static int s_EvalInProgress = 0;
 
void R_Proxy_askok (char* pMsg)
{
  askok(pMsg);
  return;
}
 
int R_Proxy_askyesnocancel (char* pMsg)
{
  return 1;
}
 
int R_Proxy_ReadConsole(char *prompt, char *buf, int len, int addtohistory)
{
  return 0;
}
 
void R_Proxy_WriteConsole(char *buf, int len)
{
  if (__output_device)
    {
      __output_device->vtbl->write_string (__output_device,buf);
    }
}
 
void R_Proxy_CallBack()
{
    /* called during i/o, eval, graphics in ProcessEvents */
}
 
void R_Proxy_Busy(int which)
{
    /* set a busy cursor ... in which = 1, unset if which = 0 */
}
 
 
int SEXP2BDX_Data (SEXP pExpression,BDX_Data** pData)
{
  BDX_Data* lData = 0;
 
  /* allocate buffer */
  lData = (BDX_Data*) malloc (sizeof (BDX_Data));
  *pData = lData;
  assert (*pData != NULL);
 
  /*
   * we support the following types at the moment
   *
   *  integer (scalar, vectors and arrays)
   *  real (scalars, vectors and arrays)
   *  logical (scalars, vectors and arrays)
   *  string (scalars, vectors and arrays)
   *  null
   *
   * we should support soon
   *
   *  complex vectors
   *  generic vectors
   */
  switch (TYPEOF (pExpression))
    {
    case NILSXP	 :
      lData->type = BDX_NULL;
 
      /* dimensions: 1 */
      lData->dim_count = 1;
      lData->dimensions =
	(BDX_Dimension*) malloc (sizeof (BDX_Dimension));
      lData->dimensions[0] = 0;
 
      /* data: empty (just a dummy data record) */
      lData->raw_data =
	(BDX_RawData*) malloc (sizeof (BDX_RawData));
 
      /*      UNPROTECT (1); */
 
      return SC_PROXY_OK;
 
      break;
    case LGLSXP	 :
      lData->type = BDX_BOOL;
      break;
    case INTSXP	 :
      lData->type = BDX_INT;
      break;
    case REALSXP	 :
      lData->type = BDX_DOUBLE;
      break;
    case STRSXP	 :
      lData->type = BDX_STRING;
      break;
      /*
       case VECSXP	 : printf ("type: generic vectors\n");
       break;
       case CPLXSXP	 : printf ("type: complex variables\n");
       break;
      */
    default:
      /*      UNPROTECT (1); */
      free (lData);
      *pData = NULL;
      return SC_PROXY_ERR_UNSUPPORTEDTYPE;
    }
 
  /* the type is set now. NULL values have already returned */
 
  /* is it a scalar, a vector or an array? */
 
  /* bug: no dimensions stored */
  if (LENGTH (pExpression) == 0)
    {
      free (lData);
      *pData = NULL;
      return SC_PROXY_ERR_UNKNOWN;
    }
 
  /* scalar: length 1 */
  if (LENGTH (pExpression) == 1)
    {
      lData->type |= BDX_SCALAR;
      lData->dim_count = 1;
      lData->dimensions =
	(BDX_Dimension*) malloc (sizeof (BDX_Dimension));
      lData->dimensions[0] = 1;
      lData->raw_data =
	(BDX_RawData*) malloc (sizeof (BDX_RawData));
      switch (lData->type & BDX_SMASK)
	{
	case BDX_BOOL:
	  lData->raw_data[0].bool_value = LOGICAL (pExpression)[0];
	  break;
	case BDX_INT:
	  lData->raw_data[0].int_value = INTEGER (pExpression)[0];
	  break;
	case BDX_DOUBLE:
	  lData->raw_data[0].double_value = REAL (pExpression)[0];
	  break;
	case BDX_STRING:
	  lData->raw_data[0].string_value = strdup (CHAR (STRING_ELT(pExpression, 0)));
	  break;
	}
    }
  else
    {
      /* is it a vector or an array? */
      SEXP lDimension;
 
      lDimension = getAttrib (pExpression,R_DimSymbol);
 
      PROTECT (lDimension);
 
      if (TYPEOF (lDimension) == NILSXP)
	{
	  /* vector */
	  int i;
 
	  lData->type |= BDX_VECTOR;
	  lData->dim_count = 1;
	  lData->dimensions =
	    (BDX_Dimension*) malloc (sizeof (BDX_Dimension));
	  lData->dimensions[0] = LENGTH (pExpression);
	  lData->raw_data =
	    (BDX_RawData*) malloc (sizeof (BDX_RawData)
				   * lData->dimensions[0]);
 
	  /* copy the data */
	  for (i = 0; i < lData->dimensions[0];i++)
	    {
	      switch (lData->type & BDX_SMASK)
		{
		case BDX_BOOL:
		  lData->raw_data[i].bool_value = LOGICAL (pExpression)[i];
		  break;
		case BDX_INT:
		  lData->raw_data[i].int_value = INTEGER (pExpression)[i];
		  break;
		case BDX_DOUBLE:
		  lData->raw_data[i].double_value = REAL (pExpression)[i];
		  break;
		case BDX_STRING:
		  lData->raw_data[i].string_value = strdup (CHAR (STRING_ELT(pExpression, i)));
		  break;
		}
	    }
 
	  UNPROTECT (1); /* dimension */
 
	  return SC_PROXY_OK;
	}
      else
	{
	  /* array with LENGTH(lDimension) dimensions */
	  if (TYPEOF (lDimension) == INTSXP)
	    {
	      int i;
	      int lTotalSize = 1;
 
	      lData->type |= BDX_ARRAY;
	      lData->dim_count = LENGTH (lDimension);
 
	      lData->dimensions =
		(BDX_Dimension*) malloc (sizeof (BDX_Dimension)
					 * lData->dim_count);
 
	      /* compute the total number of data elements */
	      for (i = 0;i < lData->dim_count;i++)
		{
		  lData->dimensions[i] = INTEGER (lDimension)[i];
		  lTotalSize *= lData->dimensions[i];
		}
 
	      lData->raw_data =
		(BDX_RawData*) malloc (sizeof (BDX_RawData)
				       * lTotalSize);
 
	      /* copy the data */
	      for (i = 0; i < lTotalSize;i++)
		{
		  switch (lData->type & BDX_SMASK)
		    {
		    case BDX_BOOL:
		      lData->raw_data[i].bool_value = LOGICAL (pExpression)[i];
		      break;
		    case BDX_INT:
		      lData->raw_data[i].int_value = INTEGER (pExpression)[i];
		      break;
		    case BDX_DOUBLE:
		      lData->raw_data[i].double_value = REAL (pExpression)[i];
		      break;
		    case BDX_STRING:
		      lData->raw_data[i].string_value = strdup (CHAR (STRING_ELT(pExpression, i)));
		      break;
		    }
		}
 
	      UNPROTECT (1); /* dimension */
 
	      return SC_PROXY_OK;
	    }
	  else
	    {
	      /* unknown error */
	      free (lData);
	      *pData = NULL;
 
	      UNPROTECT (1); /* dimension */
 
	      return SC_PROXY_ERR_UNKNOWN;
	    }
	}
    }
 
  return SC_PROXY_OK;
}
 
/* 00-02-18 | baier | parse parameter string and fill parameter structure */
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):
   *
   *   NSIZE ... number of cons cells, (unsigned int) parameter
   *   VSIZE ... size of vector heap, (unsigned int) parameter
   */
  int lDone = 0;
#if 0
  char const* lParameterStart = pParameterString;
  int lIndexOfSemicolon = 0;
  char* lTmpBuffer = NULL;
  char* lPosOfSemicolon = NULL;
#endif
 
  while (!lDone)
    {
#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;
	    }
	}
      else
#endif
	{
	  lDone = 1;
	}
    }
 
  return 0;
}
 
#include "../shext.h" /* for ShellGetPersonalDirectory */
 
/* 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% */
int R_Proxy_init (char const* pParameterString)
{
  structRstart rp;
  Rstart Rp = &rp;
  char Rversion[25];
  static char RUser[MAX_PATH], RHome[MAX_PATH];
  char *p, *q;
 
  sprintf(Rversion, "%s.%s", R_MAJOR, R_MINOR);
  if(strcmp(getDLLVersion(), Rversion) != 0) {
    fprintf(stderr, "Error: R.DLL version does not match\n");
    return SC_PROXY_ERR_UNKNOWN;
  }
 
  R_DefParams(Rp);
 
  /* 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];
    sprintf(buf,"PATH=%s\\bin;%s",RHome,getenv("PATH"));
    putenv(buf);
  }
 
  Rp->rhome = RHome;
/*
 * try R_USER then HOME then Windows homes then working directory
 */
 
    if ((p = getenv("R_USER"))) {
	if(strlen(p) >= MAX_PATH) R_Suicide("Invalid R_USER");
	strcpy(RUser, p);
    } else if ((p = getenv("HOME"))) {
	if(strlen(p) >= MAX_PATH) R_Suicide("Invalid HOME");
	strcpy(RUser, p);
    } else if (ShellGetPersonalDirectory(RUser)) {
	/* nothing to do */;
    } else if ((p = getenv("HOMEDRIVE")) && (q = getenv("HOMEPATH"))) {
	if(strlen(p) >= MAX_PATH) R_Suicide("Invalid HOMEDRIVE");
	strcpy(RUser, p);
	if(strlen(RUser) + strlen(q) >= MAX_PATH)
	    R_Suicide("Invalid HOMEDRIVE+HOMEPATH");
	strcat(RUser, q);
    } else {
	GetCurrentDirectory(MAX_PATH, RUser);
    }
 
  p = RUser + (strlen(RUser) - 1);
 
  if (*p == '/' || *p == '\\') *p = '\0';
  Rp->home = RUser;
  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;
#if 1
  /* run as "interactive", so server won't be killed after an error */
  Rp->R_Slave = Rp->R_Verbose = 0;
  Rp->R_Interactive = 1;
#else
  Rp->R_Slave = Rp->R_Interactive = Rp->R_Verbose = 0;
#endif
  Rp->RestoreAction = 0; /* no restore */
  Rp->SaveAction = 2;    /* no save */
 
/*  Rp->nsize = 300000;
    Rp->vsize = 6e6;*/
  R_SetParams(Rp); /* so R_ShowMessage is set */
  R_SizeFromEnv(Rp);
  R_set_command_line_arguments(0, NULL);
 
  /* parse parameters */
#if 0
  {
    struct _R_Proxy_init_parameters lParameterStruct =
    {
      0,0,0,0
    };
 
    R_Proxy_parse_parameters (pParameterString,&lParameterStruct);
 
    if (lParameterStruct.nsize_valid)
      {
	Rp->nsize = lParameterStruct.nsize;
      }
    if (lParameterStruct.vsize_valid)
      {
	Rp->vsize = lParameterStruct.vsize;
      }
  }
#endif
 
  R_SetParams(Rp);
 
  setup_term_ui();
  setup_Rmainloop();
  R_ReplDLLinit();
 
  return SC_PROXY_OK;
}
 
/* 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 */
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);
 
  /* don't generate code, just a try */
  R_IoBufferReadReset (&lBuffer);
  lSexp = R_Parse1Buffer (&lBuffer,0,&lStatus);
 
  switch (lStatus)
    {
    case PARSE_NULL:
      /* we forget the IoBuffer "lBuffer", so don't do anything here */
      lRc = SC_PROXY_ERR_PARSE_INVALID;
      break;
    case PARSE_OK:
      /* now generate code */
      R_IoBufferReadReset (&lBuffer);
      lSexp = R_Parse1Buffer (&lBuffer,1,&lStatus);
      R_Visible = 0;
      R_EvalDepth = 0;
      PROTECT(lSexp);
      {
	SETJMP (R_Toplevel.cjmpbuf);
	R_GlobalContext = R_ToplevelContext = &R_Toplevel;
 
	if (!s_EvalInProgress)
	  {
	    s_EvalInProgress = 1;
	    lResult = eval (lSexp,rho);
	    s_EvalInProgress = 0;
	  }
	else
	  {
	    return SC_PROXY_ERR_EVALUATE_STOP;
	  }
      }
      lRc = SEXP2BDX_Data (lResult,pData);
      /* no last value */
      UNPROTECT(1);
      break;
    case PARSE_ERROR:
      lRc = SC_PROXY_ERR_PARSE_INVALID;
      break;
    case PARSE_INCOMPLETE:
      lRc = SC_PROXY_ERR_PARSE_INCOMPLETE;
      break;
    case PARSE_EOF:
      lRc = SC_PROXY_ERR_PARSE_INVALID;
      break;
    default:
      /* never reached */
      lRc = SC_PROXY_ERR_UNKNOWN;
      break;
    }
 
  return lRc;
}
 
/* 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 */
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);
 
  /* don't generate code, just a try */
  R_IoBufferReadReset (&lBuffer);
  lSexp = R_Parse1Buffer (&lBuffer,0,&lStatus);
 
  switch (lStatus)
    {
    case PARSE_NULL:
      /* we forget the IoBuffer "lBuffer", so don't do anything here */
      lRc = SC_PROXY_ERR_PARSE_INVALID;
      break;
    case PARSE_OK:
      /* now generate code */
      R_IoBufferReadReset (&lBuffer);
      lSexp = R_Parse1Buffer (&lBuffer,1,&lStatus);
      R_Visible = 0;
      R_EvalDepth = 0;
      PROTECT(lSexp);
      /* at the moment, discard the result of the eval */
      {
	SETJMP (R_Toplevel.cjmpbuf);
	R_GlobalContext = R_ToplevelContext = &R_Toplevel;
 
	if (!s_EvalInProgress)
	  {
	    s_EvalInProgress = 1;
	    eval (lSexp,rho);
	    s_EvalInProgress = 0;
	  }
	else
	  {
	    return SC_PROXY_ERR_EVALUATE_STOP;
	  }
      }
      /* no last value */
      UNPROTECT(1);
      lRc = SC_PROXY_OK;
      break;
    case PARSE_ERROR:
      lRc = SC_PROXY_ERR_PARSE_INVALID;
      break;
    case PARSE_INCOMPLETE:
      lRc = SC_PROXY_ERR_PARSE_INCOMPLETE;
      break;
    case PARSE_EOF:
      lRc = SC_PROXY_ERR_PARSE_INVALID;
      break;
    default:
      /* never reached */
      lRc = SC_PROXY_ERR_UNKNOWN;
      break;
    }
 
  return lRc;
}
 
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)
	{
	  printf (">> %s is not a symbol\n",pSymbol);
	  UNPROTECT (1);
	  return SC_PROXY_ERR_INVALIDSYMBOL;
	}
 
      lVar = findVar (lSexp,R_GlobalEnv);
 
      if (lVar == R_UnboundValue)
	{
	  printf (">> %s is an unbound value\n",pSymbol);
	  UNPROTECT (1);
	  return SC_PROXY_ERR_INVALIDSYMBOL;
	}
 
      {
	int lRc = SEXP2BDX_Data (lVar,pData);
	UNPROTECT (1);
 
	return lRc;
      }
    }
 
  return SC_PROXY_OK;
}
 
/* 04-02-19 | baier | don't PROTECT strings in a vector */
/* 04-03-02 | baier | removed traces */
int R_Proxy_set_symbol (char const* pSymbol,BDX_Data const* pData)
{
  SEXP lSymbol = 0;
  SEXP lData = 0;
  int lProtectCount = 1;
  int lRet = SC_PROXY_OK;
 
  switch (pData->type & BDX_CMASK)
    {
      /* scalar? */
    case BDX_SCALAR:
      {
	switch (pData->type & BDX_SMASK)
	  {
	  case BDX_BOOL:
	    lData = PROTECT (allocVector (LGLSXP,1));
	    LOGICAL(lData)[0] = pData->raw_data[0].bool_value;
	    break;
	  case BDX_INT:
	    lData = PROTECT (allocVector (INTSXP,1));
	    INTEGER(lData)[0] = pData->raw_data[0].int_value;
	    break;
	  case BDX_DOUBLE:
	    lData = PROTECT (allocVector (REALSXP,1));
	    REAL(lData)[0] = pData->raw_data[0].double_value;
	    break;
	  case BDX_STRING:
	    {
	      SEXP lStringSExp =
		allocString (strlen (pData->raw_data[0].string_value));
	      PROTECT (lStringSExp); lProtectCount++;
	      strcpy (CHAR(lStringSExp),pData->raw_data[0].string_value);
	      lData = PROTECT (allocVector (STRSXP,1));
	      SET_STRING_ELT(lData, 0, lStringSExp);
	    }
	    break;
	  default:
	    lRet = SC_PROXY_ERR_UNSUPPORTEDTYPE;
	  }
      }
 
      break;
      /* vectors or arrays */
    case BDX_VECTOR:
    case BDX_ARRAY:
      {
	/* allocate a dimensions vector */
	SEXP lDimensions;
	unsigned int i;
	unsigned int lTotalSize = 1;
 
	PROTECT (lDimensions = allocVector (INTSXP,pData->dim_count));
	lProtectCount++;
 
	for (i = 0;i < pData->dim_count;i++)
	  {
	    INTEGER (lDimensions)[i] = pData->dimensions[i];
	    lTotalSize *= pData->dimensions[i];
	  }
 
	switch (pData->type & BDX_SMASK)
	  {
	  case BDX_BOOL:
	    lData = PROTECT (allocVector (LGLSXP,lTotalSize));
	    setAttrib (lData,R_DimSymbol,lDimensions);
 
	    for (i = 0;i < lTotalSize;i++)
	      {
		LOGICAL(lData)[i] = pData->raw_data[i].bool_value;
	      }
	    break;
	  case BDX_INT:
	    lData = PROTECT (allocVector (INTSXP,lTotalSize));
	    setAttrib (lData,R_DimSymbol,lDimensions);
 
	    for (i = 0;i < lTotalSize;i++)
	      {
		INTEGER(lData)[i] = pData->raw_data[i].int_value;
	      }
	    break;
	  case BDX_DOUBLE:
	    lData = PROTECT (allocVector (REALSXP,lTotalSize));
	    setAttrib (lData,R_DimSymbol,lDimensions);
 
	    for (i = 0;i < lTotalSize;i++)
	      {
		REAL(lData)[i] = pData->raw_data[i].double_value;
	      }
	    break;
	  case BDX_STRING:
	    {
	      lData = PROTECT (allocVector (STRSXP,lTotalSize));
	      setAttrib (lData,R_DimSymbol,lDimensions);
 
	      for (i = 0;i < lTotalSize;i++)
		{
		  SEXP lStringSExp;
		  lStringSExp =
		    allocString (strlen (pData->raw_data[i].string_value));
		  strcpy (CHAR(lStringSExp),pData->raw_data[i].string_value);
		  SET_STRING_ELT(lData, i, lStringSExp);
		}
	    }
	    break;
	  default:
	    lRet = SC_PROXY_ERR_UNSUPPORTEDTYPE;
	  }
      }
      break;
    default:
      lRet = SC_PROXY_ERR_UNSUPPORTEDTYPE;
    }
 
  if (lRet != SC_PROXY_OK)
    {
      return lRet;
    }
 
  /* 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);
 
  UNPROTECT (lProtectCount);
 
  return SC_PROXY_OK;
}
 
int R_Proxy_term ()
{
  end_Rmainloop();
 
  return SC_PROXY_OK;
}
 

Rev 31421	Rev 31698
1	`/*`	1	`/*`
2	`* RProxy: Connector implementation between application and R language`	2	`* RProxy: Connector implementation between application and R language`
3	`* Copyright (C) 1999--2001 Thomas Baier`	3	`* Copyright (C) 1999--2001 Thomas Baier`
4	`*`	4	`*`
5	`* R_Proxy_init based on rtest.c, Copyright (C) 1998--2000`	5	`* R_Proxy_init based on rtest.c, Copyright (C) 1998--2000`
6	`* R Development Core Team`	6	`* R Development Core Team`
7	`*`	7	`*`
8	`*`	8	`*`
9	`* This library is free software; you can redistribute it and/or`	9	`* This library is free software; you can redistribute it and/or`
10	`* modify it under the terms of the GNU Library General Public`	10	`* modify it under the terms of the GNU Library General Public`
11	`* License as published by the Free Software Foundation; either`	11	`* License as published by the Free Software Foundation; either`
12	`* version 2 of the License, or (at your option) any later version.`	12	`* version 2 of the License, or (at your option) any later version.`
13	`*`	13	`*`
14	`* This library is distributed in the hope that it will be useful,`	14	`* This library is distributed in the hope that it will be useful,`
15	`* but WITHOUT ANY WARRANTY; without even the implied warranty of`	15	`* but WITHOUT ANY WARRANTY; without even the implied warranty of`
16	`* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU`	16	`* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU`
17	`* Library General Public License for more details.`	17	`* Library General Public License for more details.`
18	`*`	18	`*`
19	`* You should have received a copy of the GNU Library General Public`	19	`* You should have received a copy of the GNU Library General Public`
20	`* License along with this library; if not, write to the Free`	20	`* License along with this library; if not, write to the Free`
21	`* Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,`	21	`* Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,`
22	`* MA 02111-1307, USA`	22	`* MA 02111-1307, USA`
23	`*`	23	`*`
24	`* $Id: rproxy_impl.c,v 1.24 2004/06/09 13:35:32 ripley Exp $`	24	`* $Id: rproxy_impl.c,v 1.24 2004/06/09 13:35:32 ripley Exp $`
25	`*/`	25	`*/`
26		26
27	`#define NONAMELESSUNION`	27	`#define NONAMELESSUNION`
28	`#include <windows.h>`	28	`#include <windows.h>`
29	`#include <assert.h>`	29	`#include <assert.h>`
30	`#include <stdio.h>`	30	`#include <stdio.h>`
31	`#include <stdlib.h>`	31	`#include <stdlib.h>`
32	`/*#include "globalvar.h"`	32	`/*#include "globalvar.h"`
33	`#undef CharacterMode`	33	`#undef CharacterMode`
34	`#undef R_Interactive*/`	34	`#undef R_Interactive*/`
35	`#include <config.h>`	35	`#include <config.h>`
36	`#include <Rversion.h>`	36	`#include <Rversion.h>`
37	`#include <Startup.h>`	37	`#include <Startup.h>`
38	`#include "bdx.h"`	38	`#include "bdx.h"`
39	`#include "SC_proxy.h"`	39	`#include "SC_proxy.h"`
40	`#include "rproxy_impl.h"`	40	`#include "rproxy_impl.h"`
41	`#include <IOStuff.h>`	41	`#include <IOStuff.h>`
42	`#include <Parse.h>`	42	`#include <Parse.h>`
43	`#include <Graphics.h>`	43	`#include <Graphics.h>`
44		44
45	`struct _R_Proxy_init_parameters`	45	`struct _R_Proxy_init_parameters`
46	`{`	46	`{`
47	`int vsize;`	47	`int vsize;`
48	`int vsize_valid;`	48	`int vsize_valid;`
49	`int nsize;`	49	`int nsize;`
50	`int nsize_valid;`	50	`int nsize_valid;`
51	`};`	51	`};`
52		52
53	`/* 01-12-07 \| baier \| no more extern for exported variables (crashes!) */`	53	`/* 01-12-07 \| baier \| no more extern for exported variables (crashes!) */`
54	`/#define R_GlobalEnv (__imp_R_GlobalEnv)`	54	`/#define R_GlobalEnv (__imp_R_GlobalEnv)`
55	`#define R_Visible (*__imp_R_Visible)`	55	`#define R_Visible (*__imp_R_Visible)`
56	`#define R_EvalDepth (*__imp_R_EvalDepth)`	56	`#define R_EvalDepth (*__imp_R_EvalDepth)`
57	`#define R_DimSymbol (__imp_R_DimSymbol)/`	57	`#define R_DimSymbol (__imp_R_DimSymbol)/`
58		58
59	`/*`	59	`/*`
60	`extern SEXP R_GlobalEnv;`	60	`extern SEXP R_GlobalEnv;`
61	`extern int R_Visible;`	61	`extern int R_Visible;`
62	`extern int R_EvalDepth;`	62	`extern int R_EvalDepth;`
63	`extern SEXP R_DimSymbol;`	63	`extern SEXP R_DimSymbol;`
64	`*/`	64	`*/`
65		65
66	`/* calls into the R DLL */`	66	`/* calls into the R DLL */`
67	`extern char *getDLLVersion();`	67	`extern char *getDLLVersion();`
68	`extern void R_DefParams(Rstart);`	68	`extern void R_DefParams(Rstart);`
69	`extern void R_SetParams(Rstart);`	69	`extern void R_SetParams(Rstart);`
70	`extern void setup_term_ui(void);`	70	`extern void setup_term_ui(void);`
71	`extern char *getRHOME();`	71	`extern char *getRHOME();`
72	`extern void end_Rmainloop(), R_ReplDLLinit();`	72	`extern void end_Rmainloop(), R_ReplDLLinit();`
73	`extern void askok(char *);`	73	`extern void askok(char *);`
74		74
75	`int R_Proxy_Graphics_Driver (NewDevDesc* pDD,`	75	`int R_Proxy_Graphics_Driver (NewDevDesc* pDD,`
76	`char* pDisplay,`	76	`char* pDisplay,`
77	`double pWidth,`	77	`double pWidth,`
78	`double pHeight,`	78	`double pHeight,`
79	`double pPointSize);`	79	`double pPointSize);`
80		80
81	`extern SC_CharacterDevice* __output_device;`	81	`extern SC_CharacterDevice* __output_device;`
82		82
83	`/* trace to DebugView */`	83	`/* trace to DebugView */`
84	`int RPROXYTRACE(char const* pFormat,...);`	84	`int RPROXYTRACE(char const* pFormat,...);`
85		85
86	`int RPROXYTRACE(char const* pFormat,...)`	86	`int RPROXYTRACE(char const* pFormat,...)`
87	`{`	87	`{`
88	`static char __tracebuf[2048];`	88	`static char __tracebuf[2048];`
89		89
90	`va_list lArgs;`	90	`va_list lArgs;`
91	`va_start(lArgs,pFormat);`	91	`va_start(lArgs,pFormat);`
92	`vsprintf(__tracebuf,pFormat,lArgs);`	92	`vsprintf(__tracebuf,pFormat,lArgs);`
93	`OutputDebugString(__tracebuf);`	93	`OutputDebugString(__tracebuf);`
94	`return 0;`	94	`return 0;`
95	`}`	95	`}`
96		96
97	`static int s_EvalInProgress = 0;`	97	`static int s_EvalInProgress = 0;`
98		98
99	`void R_Proxy_askok (char* pMsg)`	99	`void R_Proxy_askok (char* pMsg)`
100	`{`	100	`{`
101	`askok(pMsg);`	101	`askok(pMsg);`
102	`return;`	102	`return;`
103	`}`	103	`}`
104		104
105	`int R_Proxy_askyesnocancel (char* pMsg)`	105	`int R_Proxy_askyesnocancel (char* pMsg)`
106	`{`	106	`{`
107	`return 1;`	107	`return 1;`
108	`}`	108	`}`
109		109
110	`int R_Proxy_ReadConsole(char prompt, char buf, int len, int addtohistory)`	110	`int R_Proxy_ReadConsole(char prompt, char buf, int len, int addtohistory)`
111	`{`	111	`{`
112	`return 0;`	112	`return 0;`
113	`}`	113	`}`
114		114
115	`void R_Proxy_WriteConsole(char *buf, int len)`	115	`void R_Proxy_WriteConsole(char *buf, int len)`
116	`{`	116	`{`
117	`if (__output_device)`	117	`if (__output_device)`
118	`{`	118	`{`
119	`__output_device->vtbl->write_string (__output_device,buf);`	119	`__output_device->vtbl->write_string (__output_device,buf);`
120	`}`	120	`}`
121	`}`	121	`}`
122		122
123	`void R_Proxy_CallBack()`	123	`void R_Proxy_CallBack()`
124	`{`	124	`{`
125	`/* called during i/o, eval, graphics in ProcessEvents */`	125	`/* called during i/o, eval, graphics in ProcessEvents */`
126	`}`	126	`}`
127		127
128	`void R_Proxy_Busy(int which)`	128	`void R_Proxy_Busy(int which)`
129	`{`	129	`{`
130	`/* set a busy cursor ... in which = 1, unset if which = 0 */`	130	`/* set a busy cursor ... in which = 1, unset if which = 0 */`
131	`}`	131	`}`
132		132
133		133
134	`int SEXP2BDX_Data (SEXP pExpression,BDX_Data** pData)`	134	`int SEXP2BDX_Data (SEXP pExpression,BDX_Data** pData)`
135	`{`	135	`{`
136	`BDX_Data* lData = 0;`	136	`BDX_Data* lData = 0;`
137		137
138	`/* allocate buffer */`	138	`/* allocate buffer */`
139	`lData = (BDX_Data*) malloc (sizeof (BDX_Data));`	139	`lData = (BDX_Data*) malloc (sizeof (BDX_Data));`
140	`*pData = lData;`	140	`*pData = lData;`
141	`assert (*pData != NULL);`	141	`assert (*pData != NULL);`
142		142
143	`/*`	143	`/*`
144	`* we support the following types at the moment`	144	`* we support the following types at the moment`
145	`*`	145	`*`
146	`* integer (scalar, vectors and arrays)`	146	`* integer (scalar, vectors and arrays)`
147	`* real (scalars, vectors and arrays)`	147	`* real (scalars, vectors and arrays)`
148	`* logical (scalars, vectors and arrays)`	148	`* logical (scalars, vectors and arrays)`
149	`* string (scalars, vectors and arrays)`	149	`* string (scalars, vectors and arrays)`
150	`* null`	150	`* null`
151	`*`	151	`*`
152	`* we should support soon`	152	`* we should support soon`
153	`*`	153	`*`
154	`* complex vectors`	154	`* complex vectors`
155	`* generic vectors`	155	`* generic vectors`
156	`*/`	156	`*/`
157	`switch (TYPEOF (pExpression))`	157	`switch (TYPEOF (pExpression))`
158	`{`	158	`{`
159	`case NILSXP :`	159	`case NILSXP :`
160	`lData->type = BDX_NULL;`	160	`lData->type = BDX_NULL;`
161		161
162	`/* dimensions: 1 */`	162	`/* dimensions: 1 */`
163	`lData->dim_count = 1;`	163	`lData->dim_count = 1;`
164	`lData->dimensions =`	164	`lData->dimensions =`
165	`(BDX_Dimension*) malloc (sizeof (BDX_Dimension));`	165	`(BDX_Dimension*) malloc (sizeof (BDX_Dimension));`
166	`lData->dimensions[0] = 0;`	166	`lData->dimensions[0] = 0;`
167		167
168	`/* data: empty (just a dummy data record) */`	168	`/* data: empty (just a dummy data record) */`
169	`lData->raw_data =`	169	`lData->raw_data =`
170	`(BDX_RawData*) malloc (sizeof (BDX_RawData));`	170	`(BDX_RawData*) malloc (sizeof (BDX_RawData));`
171		171
172	`/* UNPROTECT (1); */`	172	`/* UNPROTECT (1); */`
173		173
174	`return SC_PROXY_OK;`	174	`return SC_PROXY_OK;`
175		175
176	`break;`	176	`break;`
177	`case LGLSXP :`	177	`case LGLSXP :`
178	`lData->type = BDX_BOOL;`	178	`lData->type = BDX_BOOL;`
179	`break;`	179	`break;`
180	`case INTSXP :`	180	`case INTSXP :`
181	`lData->type = BDX_INT;`	181	`lData->type = BDX_INT;`
182	`break;`	182	`break;`
183	`case REALSXP :`	183	`case REALSXP :`
184	`lData->type = BDX_DOUBLE;`	184	`lData->type = BDX_DOUBLE;`
185	`break;`	185	`break;`
186	`case STRSXP :`	186	`case STRSXP :`
187	`lData->type = BDX_STRING;`	187	`lData->type = BDX_STRING;`
188	`break;`	188	`break;`
189	`/*`	189	`/*`
190	`case VECSXP : printf ("type: generic vectors\n");`	190	`case VECSXP : printf ("type: generic vectors\n");`
191	`break;`	191	`break;`
192	`case CPLXSXP : printf ("type: complex variables\n");`	192	`case CPLXSXP : printf ("type: complex variables\n");`
193	`break;`	193	`break;`
194	`*/`	194	`*/`
195	`default:`	195	`default:`
196	`/* UNPROTECT (1); */`	196	`/* UNPROTECT (1); */`
197	`free (lData);`	197	`free (lData);`
198	`*pData = NULL;`	198	`*pData = NULL;`
199	`return SC_PROXY_ERR_UNSUPPORTEDTYPE;`	199	`return SC_PROXY_ERR_UNSUPPORTEDTYPE;`
200	`}`	200	`}`
201		201
202	`/* the type is set now. NULL values have already returned */`	202	`/* the type is set now. NULL values have already returned */`
203		203
204	`/* is it a scalar, a vector or an array? */`	204	`/* is it a scalar, a vector or an array? */`
205		205
206	`/* bug: no dimensions stored */`	206	`/* bug: no dimensions stored */`
207	`if (LENGTH (pExpression) == 0)`	207	`if (LENGTH (pExpression) == 0)`
208	`{`	208	`{`
209	`free (lData);`	209	`free (lData);`
210	`*pData = NULL;`	210	`*pData = NULL;`
211	`return SC_PROXY_ERR_UNKNOWN;`	211	`return SC_PROXY_ERR_UNKNOWN;`
212	`}`	212	`}`
213		213
214	`/* scalar: length 1 */`	214	`/* scalar: length 1 */`
215	`if (LENGTH (pExpression) == 1)`	215	`if (LENGTH (pExpression) == 1)`
216	`{`	216	`{`
217	`lData->type \|= BDX_SCALAR;`	217	`lData->type \|= BDX_SCALAR;`
218	`lData->dim_count = 1;`	218	`lData->dim_count = 1;`
219	`lData->dimensions =`	219	`lData->dimensions =`
220	`(BDX_Dimension*) malloc (sizeof (BDX_Dimension));`	220	`(BDX_Dimension*) malloc (sizeof (BDX_Dimension));`
221	`lData->dimensions[0] = 1;`	221	`lData->dimensions[0] = 1;`
222	`lData->raw_data =`	222	`lData->raw_data =`
223	`(BDX_RawData*) malloc (sizeof (BDX_RawData));`	223	`(BDX_RawData*) malloc (sizeof (BDX_RawData));`
224	`switch (lData->type & BDX_SMASK)`	224	`switch (lData->type & BDX_SMASK)`
225	`{`	225	`{`
226	`case BDX_BOOL:`	226	`case BDX_BOOL:`
227	`lData->raw_data[0].bool_value = LOGICAL (pExpression)[0];`	227	`lData->raw_data[0].bool_value = LOGICAL (pExpression)[0];`
228	`break;`	228	`break;`
229	`case BDX_INT:`	229	`case BDX_INT:`
230	`lData->raw_data[0].int_value = INTEGER (pExpression)[0];`	230	`lData->raw_data[0].int_value = INTEGER (pExpression)[0];`
231	`break;`	231	`break;`
232	`case BDX_DOUBLE:`	232	`case BDX_DOUBLE:`
233	`lData->raw_data[0].double_value = REAL (pExpression)[0];`	233	`lData->raw_data[0].double_value = REAL (pExpression)[0];`
234	`break;`	234	`break;`
235	`case BDX_STRING:`	235	`case BDX_STRING:`
236	`lData->raw_data[0].string_value = strdup (CHAR (STRING_ELT(pExpression, 0)));`	236	`lData->raw_data[0].string_value = strdup (CHAR (STRING_ELT(pExpression, 0)));`
237	`break;`	237	`break;`
238	`}`	238	`}`
239	`}`	239	`}`
240	`else`	240	`else`
241	`{`	241	`{`
242	`/* is it a vector or an array? */`	242	`/* is it a vector or an array? */`
243	`SEXP lDimension;`	243	`SEXP lDimension;`
244		244
245	`lDimension = getAttrib (pExpression,R_DimSymbol);`	245	`lDimension = getAttrib (pExpression,R_DimSymbol);`
246		246
247	`PROTECT (lDimension);`	247	`PROTECT (lDimension);`
248		248
249	`if (TYPEOF (lDimension) == NILSXP)`	249	`if (TYPEOF (lDimension) == NILSXP)`
250	`{`	250	`{`
251	`/* vector */`	251	`/* vector */`
252	`int i;`	252	`int i;`
253		253
254	`lData->type \|= BDX_VECTOR;`	254	`lData->type \|= BDX_VECTOR;`
255	`lData->dim_count = 1;`	255	`lData->dim_count = 1;`
256	`lData->dimensions =`	256	`lData->dimensions =`
257	`(BDX_Dimension*) malloc (sizeof (BDX_Dimension));`	257	`(BDX_Dimension*) malloc (sizeof (BDX_Dimension));`
258	`lData->dimensions[0] = LENGTH (pExpression);`	258	`lData->dimensions[0] = LENGTH (pExpression);`
259	`lData->raw_data =`	259	`lData->raw_data =`
260	`(BDX_RawData*) malloc (sizeof (BDX_RawData)`	260	`(BDX_RawData*) malloc (sizeof (BDX_RawData)`
261	`* lData->dimensions[0]);`	261	`* lData->dimensions[0]);`
262		262
263	`/* copy the data */`	263	`/* copy the data */`
264	`for (i = 0; i < lData->dimensions[0];i++)`	264	`for (i = 0; i < lData->dimensions[0];i++)`
265	`{`	265	`{`
266	`switch (lData->type & BDX_SMASK)`	266	`switch (lData->type & BDX_SMASK)`
267	`{`	267	`{`
268	`case BDX_BOOL:`	268	`case BDX_BOOL:`
269	`lData->raw_data[i].bool_value = LOGICAL (pExpression)[i];`	269	`lData->raw_data[i].bool_value = LOGICAL (pExpression)[i];`
270	`break;`	270	`break;`
271	`case BDX_INT:`	271	`case BDX_INT:`
272	`lData->raw_data[i].int_value = INTEGER (pExpression)[i];`	272	`lData->raw_data[i].int_value = INTEGER (pExpression)[i];`
273	`break;`	273	`break;`
274	`case BDX_DOUBLE:`	274	`case BDX_DOUBLE:`
275	`lData->raw_data[i].double_value = REAL (pExpression)[i];`	275	`lData->raw_data[i].double_value = REAL (pExpression)[i];`
276	`break;`	276	`break;`
277	`case BDX_STRING:`	277	`case BDX_STRING:`
278	`lData->raw_data[i].string_value = strdup (CHAR (STRING_ELT(pExpression, i)));`	278	`lData->raw_data[i].string_value = strdup (CHAR (STRING_ELT(pExpression, i)));`
279	`break;`	279	`break;`
280	`}`	280	`}`
281	`}`	281	`}`
282		282
283	`UNPROTECT (1); /* dimension */`	283	`UNPROTECT (1); /* dimension */`
284		284
285	`return SC_PROXY_OK;`	285	`return SC_PROXY_OK;`
286	`}`	286	`}`
287	`else`	287	`else`
288	`{`	288	`{`
289	`/* array with LENGTH(lDimension) dimensions */`	289	`/* array with LENGTH(lDimension) dimensions */`
290	`if (TYPEOF (lDimension) == INTSXP)`	290	`if (TYPEOF (lDimension) == INTSXP)`
291	`{`	291	`{`
292	`int i;`	292	`int i;`
293	`int lTotalSize = 1;`	293	`int lTotalSize = 1;`
294		294
295	`lData->type \|= BDX_ARRAY;`	295	`lData->type \|= BDX_ARRAY;`
296	`lData->dim_count = LENGTH (lDimension);`	296	`lData->dim_count = LENGTH (lDimension);`
297		297
298	`lData->dimensions =`	298	`lData->dimensions =`
299	`(BDX_Dimension*) malloc (sizeof (BDX_Dimension)`	299	`(BDX_Dimension*) malloc (sizeof (BDX_Dimension)`
300	`* lData->dim_count);`	300	`* lData->dim_count);`
301		301
302	`/* compute the total number of data elements */`	302	`/* compute the total number of data elements */`
303	`for (i = 0;i < lData->dim_count;i++)`	303	`for (i = 0;i < lData->dim_count;i++)`
304	`{`	304	`{`
305	`lData->dimensions[i] = INTEGER (lDimension)[i];`	305	`lData->dimensions[i] = INTEGER (lDimension)[i];`
306	`lTotalSize *= lData->dimensions[i];`	306	`lTotalSize *= lData->dimensions[i];`
307	`}`	307	`}`
308		308
309	`lData->raw_data =`	309	`lData->raw_data =`
310	`(BDX_RawData*) malloc (sizeof (BDX_RawData)`	310	`(BDX_RawData*) malloc (sizeof (BDX_RawData)`
311	`* lTotalSize);`	311	`* lTotalSize);`
312		312
313	`/* copy the data */`	313	`/* copy the data */`
314	`for (i = 0; i < lTotalSize;i++)`	314	`for (i = 0; i < lTotalSize;i++)`
315	`{`	315	`{`
316	`switch (lData->type & BDX_SMASK)`	316	`switch (lData->type & BDX_SMASK)`
317	`{`	317	`{`
318	`case BDX_BOOL:`	318	`case BDX_BOOL:`
319	`lData->raw_data[i].bool_value = LOGICAL (pExpression)[i];`	319	`lData->raw_data[i].bool_value = LOGICAL (pExpression)[i];`
320	`break;`	320	`break;`
321	`case BDX_INT:`	321	`case BDX_INT:`
322	`lData->raw_data[i].int_value = INTEGER (pExpression)[i];`	322	`lData->raw_data[i].int_value = INTEGER (pExpression)[i];`
323	`break;`	323	`break;`
324	`case BDX_DOUBLE:`	324	`case BDX_DOUBLE:`
325	`lData->raw_data[i].double_value = REAL (pExpression)[i];`	325	`lData->raw_data[i].double_value = REAL (pExpression)[i];`
326	`break;`	326	`break;`
327	`case BDX_STRING:`	327	`case BDX_STRING:`
328	`lData->raw_data[i].string_value = strdup (CHAR (STRING_ELT(pExpression, i)));`	328	`lData->raw_data[i].string_value = strdup (CHAR (STRING_ELT(pExpression, i)));`
329	`break;`	329	`break;`
330	`}`	330	`}`
331	`}`	331	`}`
332		332
333	`UNPROTECT (1); /* dimension */`	333	`UNPROTECT (1); /* dimension */`
334		334
335	`return SC_PROXY_OK;`	335	`return SC_PROXY_OK;`
336	`}`	336	`}`
337	`else`	337	`else`
338	`{`	338	`{`
339	`/* unknown error */`	339	`/* unknown error */`
340	`free (lData);`	340	`free (lData);`
341	`*pData = NULL;`	341	`*pData = NULL;`
342		342
343	`UNPROTECT (1); /* dimension */`	343	`UNPROTECT (1); /* dimension */`
344		344
345	`return SC_PROXY_ERR_UNKNOWN;`	345	`return SC_PROXY_ERR_UNKNOWN;`
346	`}`	346	`}`
347	`}`	347	`}`
348	`}`	348	`}`
349		349
350	`return SC_PROXY_OK;`	350	`return SC_PROXY_OK;`
351	`}`	351	`}`
352		352
353	`/* 00-02-18 \| baier \| parse parameter string and fill parameter structure */`	353	`/* 00-02-18 \| baier \| parse parameter string and fill parameter structure */`
354	`int R_Proxy_parse_parameters (char const* pParameterString,`	354	`int R_Proxy_parse_parameters (char const* pParameterString,`
355	`struct _R_Proxy_init_parameters* pParameterStruct)`	355	`struct _R_Proxy_init_parameters* pParameterStruct)`
356	`{`	356	`{`
357	`/*`	357	`/*`
358	`* parameter string is of the form name1=value1;name2=value2;...`	358	`* parameter string is of the form name1=value1;name2=value2;...`
359	`*`	359	`*`
360	`* currently recognized parameter names (case-sensitive):`	360	`* currently recognized parameter names (case-sensitive):`
361	`*`	361	`*`
362	`* NSIZE ... number of cons cells, (unsigned int) parameter`	362	`* NSIZE ... number of cons cells, (unsigned int) parameter`
363	`* VSIZE ... size of vector heap, (unsigned int) parameter`	363	`* VSIZE ... size of vector heap, (unsigned int) parameter`
364	`*/`	364	`*/`
365	`int lDone = 0;`	365	`int lDone = 0;`
366	`#if 0`	366	`#if 0`
367	`char const* lParameterStart = pParameterString;`	367	`char const* lParameterStart = pParameterString;`
368	`int lIndexOfSemicolon = 0;`	368	`int lIndexOfSemicolon = 0;`
369	`char* lTmpBuffer = NULL;`	369	`char* lTmpBuffer = NULL;`
370	`char* lPosOfSemicolon = NULL;`	370	`char* lPosOfSemicolon = NULL;`
371	`#endif`	371	`#endif`
372		372
373	`while (!lDone)`	373	`while (!lDone)`
374	`{`	374	`{`
375	`#if 0`	375	`#if 0`
376	`/* NSIZE? */`	376	`/* NSIZE? */`
377	`if (strncmp (lParameterStart,"NSIZE=",6) == 0)`	377	`if (strncmp (lParameterStart,"NSIZE=",6) == 0)`
378	`{`	378	`{`
379	`lParameterStart += 6;`	379	`lParameterStart += 6;`
380		380
381	`lPosOfSemicolon = strchr (lParameterStart,';');`	381	`lPosOfSemicolon = strchr (lParameterStart,';');`
382	`lIndexOfSemicolon = lPosOfSemicolon - lParameterStart;`	382	`lIndexOfSemicolon = lPosOfSemicolon - lParameterStart;`
383		383
384	`if (lPosOfSemicolon)`	384	`if (lPosOfSemicolon)`
385	`{`	385	`{`
386	`lTmpBuffer = malloc (lIndexOfSemicolon + 1); /* to catch NSIZE=; */`	386	`lTmpBuffer = malloc (lIndexOfSemicolon + 1); /* to catch NSIZE=; */`
387	`strncpy (lTmpBuffer,lParameterStart,lIndexOfSemicolon);`	387	`strncpy (lTmpBuffer,lParameterStart,lIndexOfSemicolon);`
388	`*(lTmpBuffer + lIndexOfSemicolon) = 0x0;`	388	`*(lTmpBuffer + lIndexOfSemicolon) = 0x0;`
389	`pParameterStruct->nsize_valid = 1;`	389	`pParameterStruct->nsize_valid = 1;`
390	`pParameterStruct->nsize = atoi (lTmpBuffer);`	390	`pParameterStruct->nsize = atoi (lTmpBuffer);`
391	`free (lTmpBuffer);`	391	`free (lTmpBuffer);`
392	`lParameterStart += lIndexOfSemicolon + 1;`	392	`lParameterStart += lIndexOfSemicolon + 1;`
393	`}`	393	`}`
394	`else`	394	`else`
395	`{`	395	`{`
396	`pParameterStruct->nsize_valid = 1;`	396	`pParameterStruct->nsize_valid = 1;`
397	`pParameterStruct->nsize = atoi (lParameterStart);`	397	`pParameterStruct->nsize = atoi (lParameterStart);`
398	`lDone = 1;`	398	`lDone = 1;`
399	`}`	399	`}`
400	`}`	400	`}`
401	`else if (strncmp (lParameterStart,"VSIZE=",6) == 0)`	401	`else if (strncmp (lParameterStart,"VSIZE=",6) == 0)`
402	`{`	402	`{`
403	`lParameterStart += 6;`	403	`lParameterStart += 6;`
404		404
405	`lPosOfSemicolon = strchr (lParameterStart,';');`	405	`lPosOfSemicolon = strchr (lParameterStart,';');`
406	`lIndexOfSemicolon = lPosOfSemicolon - lParameterStart;`	406	`lIndexOfSemicolon = lPosOfSemicolon - lParameterStart;`
407		407
408	`if (lPosOfSemicolon)`	408	`if (lPosOfSemicolon)`
409	`{`	409	`{`
410	`lTmpBuffer = malloc (lIndexOfSemicolon + 1); /* to catch VSIZE=; */`	410	`lTmpBuffer = malloc (lIndexOfSemicolon + 1); /* to catch VSIZE=; */`
411	`strncpy (lTmpBuffer,lParameterStart,lIndexOfSemicolon);`	411	`strncpy (lTmpBuffer,lParameterStart,lIndexOfSemicolon);`
412	`*(lTmpBuffer + lIndexOfSemicolon) = 0x0;`	412	`*(lTmpBuffer + lIndexOfSemicolon) = 0x0;`
413	`pParameterStruct->vsize_valid = 1;`	413	`pParameterStruct->vsize_valid = 1;`
414	`pParameterStruct->vsize = atoi (lTmpBuffer);`	414	`pParameterStruct->vsize = atoi (lTmpBuffer);`
415	`free (lTmpBuffer);`	415	`free (lTmpBuffer);`
416	`lParameterStart += lIndexOfSemicolon + 1;`	416	`lParameterStart += lIndexOfSemicolon + 1;`
417	`}`	417	`}`
418	`else`	418	`else`
419	`{`	419	`{`
420	`pParameterStruct->vsize_valid = 1;`	420	`pParameterStruct->vsize_valid = 1;`
421	`pParameterStruct->vsize = atoi (lParameterStart);`	421	`pParameterStruct->vsize = atoi (lParameterStart);`
422	`lDone = 1;`	422	`lDone = 1;`
423	`}`	423	`}`
424	`}`	424	`}`
425	`else`	425	`else`
426	`#endif`	426	`#endif`
427	`{`	427	`{`
428	`lDone = 1;`	428	`lDone = 1;`
429	`}`	429	`}`
430	`}`	430	`}`
431		431
432	`return 0;`	432	`return 0;`
433	`}`	433	`}`
434		434
435	`#include "../shext.h" /* for ShellGetPersonalDirectory */`	435	`#include "../shext.h" /* for ShellGetPersonalDirectory */`
436		436
437	`/* 00-02-18 \| baier \| R_Proxy_init() now takes parameter string, parse it */`	437	`/* 00-02-18 \| baier \| R_Proxy_init() now takes parameter string, parse it */`
438	`/* 03-06-01 \| baier \| now we add %R_HOME%\bin to %PATH% */`	438	`/* 03-06-01 \| baier \| now we add %R_HOME%\bin to %PATH% */`
439	`int R_Proxy_init (char const* pParameterString)`	439	`int R_Proxy_init (char const* pParameterString)`
440	`{`	440	`{`
441	`structRstart rp;`	441	`structRstart rp;`
442	`Rstart Rp = &rp;`	442	`Rstart Rp = &rp;`
443	`char Rversion[25];`	443	`char Rversion[25];`
444	`static char RUser[MAX_PATH], RHome[MAX_PATH];`	444	`static char RUser[MAX_PATH], RHome[MAX_PATH];`
445	`char p, q;`	445	`char p, q;`
446		446
447	`sprintf(Rversion, "%s.%s", R_MAJOR, R_MINOR);`	447	`sprintf(Rversion, "%s.%s", R_MAJOR, R_MINOR);`
448	`if(strcmp(getDLLVersion(), Rversion) != 0) {`	448	`if(strcmp(getDLLVersion(), Rversion) != 0) {`
449	`fprintf(stderr, "Error: R.DLL version does not match\n");`	449	`fprintf(stderr, "Error: R.DLL version does not match\n");`
450	`return SC_PROXY_ERR_UNKNOWN;`	450	`return SC_PROXY_ERR_UNKNOWN;`
451	`}`	451	`}`
452		452
453	`R_DefParams(Rp);`	453	`R_DefParams(Rp);`
454		454
455	`/* first, try process-local environment space (CRT) */`	455	`/* first, try process-local environment space (CRT) */`
456	`if (getenv("R_HOME")) {`	456	`if (getenv("R_HOME")) {`
457	`strcpy(RHome, getenv("R_HOME"));`	457	`strcpy(RHome, getenv("R_HOME"));`
458	`} else {`	458	`} else {`
459	`/* get variable from process-local environment space (Windows API) */`	459	`/* get variable from process-local environment space (Windows API) */`
460	`if (GetEnvironmentVariable ("R_HOME", RHome, sizeof (RHome)) == 0) {`	460	`if (GetEnvironmentVariable ("R_HOME", RHome, sizeof (RHome)) == 0) {`
461	`/* not found, fall back to getRHOME() */`	461	`/* not found, fall back to getRHOME() */`
462	`strcpy(RHome, getRHOME());`	462	`strcpy(RHome, getRHOME());`
463	`}`	463	`}`
464	`}`	464	`}`
465		465
466	`/* now we add %R_HOME%\bin to %PATH% (for dynamically loaded modules there) */`	466	`/* now we add %R_HOME%\bin to %PATH% (for dynamically loaded modules there) */`
467	`{`	467	`{`
468	`char buf[2048];`	468	`char buf[2048];`
469	`sprintf(buf,"PATH=%s\\bin;%s",RHome,getenv("PATH"));`	469	`sprintf(buf,"PATH=%s\\bin;%s",RHome,getenv("PATH"));`
470	`putenv(buf);`	470	`putenv(buf);`
471	`}`	471	`}`
472		472
473	`Rp->rhome = RHome;`	473	`Rp->rhome = RHome;`
474	`/*`	474	`/*`
475	`* try R_USER then HOME then Windows homes then working directory`	475	`* try R_USER then HOME then Windows homes then working directory`
476	`*/`	476	`*/`
477		477
478	`if ((p = getenv("R_USER"))) {`	478	`if ((p = getenv("R_USER"))) {`
479	`if(strlen(p) >= MAX_PATH) R_Suicide("Invalid R_USER");`	479	`if(strlen(p) >= MAX_PATH) R_Suicide("Invalid R_USER");`
480	`strcpy(RUser, p);`	480	`strcpy(RUser, p);`
481	`} else if ((p = getenv("HOME"))) {`	481	`} else if ((p = getenv("HOME"))) {`
482	`if(strlen(p) >= MAX_PATH) R_Suicide("Invalid HOME");`	482	`if(strlen(p) >= MAX_PATH) R_Suicide("Invalid HOME");`
483	`strcpy(RUser, p);`	483	`strcpy(RUser, p);`
484	`} else if (ShellGetPersonalDirectory(RUser)) {`	484	`} else if (ShellGetPersonalDirectory(RUser)) {`
485	`/* nothing to do */;`	485	`/* nothing to do */;`
486	`} else if ((p = getenv("HOMEDRIVE")) && (q = getenv("HOMEPATH"))) {`	486	`} else if ((p = getenv("HOMEDRIVE")) && (q = getenv("HOMEPATH"))) {`
487	`if(strlen(p) >= MAX_PATH) R_Suicide("Invalid HOMEDRIVE");`	487	`if(strlen(p) >= MAX_PATH) R_Suicide("Invalid HOMEDRIVE");`
488	`strcpy(RUser, p);`	488	`strcpy(RUser, p);`
489	`if(strlen(RUser) + strlen(q) >= MAX_PATH)`	489	`if(strlen(RUser) + strlen(q) >= MAX_PATH)`
490	`R_Suicide("Invalid HOMEDRIVE+HOMEPATH");`	490	`R_Suicide("Invalid HOMEDRIVE+HOMEPATH");`
491	`strcat(RUser, q);`	491	`strcat(RUser, q);`
492	`} else {`	492	`} else {`
493	`GetCurrentDirectory(MAX_PATH, RUser);`	493	`GetCurrentDirectory(MAX_PATH, RUser);`
494	`}`	494	`}`
495		495
496	`p = RUser + (strlen(RUser) - 1);`	496	`p = RUser + (strlen(RUser) - 1);`
497		497
498	`if (p == '/' \|\| p == '\\') *p = '\0';`	498	`if (p == '/' \|\| p == '\\') *p = '\0';`
499	`Rp->home = RUser;`	499	`Rp->home = RUser;`
500	`Rp->CharacterMode = LinkDLL;`	500	`Rp->CharacterMode = LinkDLL;`

The R Project SVN R

(root)/trunk/src/gnuwin32/front-ends/rproxy_impl.c @ 34412 – Rev 31421 → 31698