The R Project SVN R

Rev

Rev 5730 | Rev 6098 | Go to most recent revision | Show entire file | Ignore whitespace | Details | Blame | Last modification | View Log | RSS feed

Rev 5730 Rev 5769
Line 51... Line 51...
51 
*/
 51 
*/
52 
 
 52 
 
53 
static void *RObjToCPtr(SEXP s, int naok, int dup, int narg, int Fort)
 53 
static void *RObjToCPtr(SEXP s, int naok, int dup, int narg, int Fort)
54 
{
 54 
{
55 
    int *iptr;
 55 
    int *iptr;
- 
 
 56 
    float *sptr;
56 
    double *rptr;
 57 
    double *rptr;
57 
    char **cptr, *fptr;
 58 
    char **cptr, *fptr;
58 
    complex *zptr;
 59 
    complex *zptr;
59 
    SEXP *lptr;
 60 
    SEXP *lptr, CSingSymbol=install("Csingle");
60 
    int i, l, n;
 61 
    int i, l, n;
- 
 
 62
61 
    switch(TYPEOF(s)) {
 63 
    switch(TYPEOF(s)) {
62 
    case LGLSXP:
 64 
    case LGLSXP:
63 
    case INTSXP:
 65 
    case INTSXP:
64 
	n = LENGTH(s);
 66 
	n = LENGTH(s);
65 
	iptr = INTEGER(s);
 67 
	iptr = INTEGER(s);
Line 80... Line 82...
80 
	for (i = 0 ; i < n ; i++) {
 82 
	for (i = 0 ; i < n ; i++) {
81 
	    if(!naok && !R_FINITE(rptr[i]))
 83 
	    if(!naok && !R_FINITE(rptr[i]))
82 
		error("NA/NaN/Inf in foreign function call (arg %d)", narg);
 84 
		error("NA/NaN/Inf in foreign function call (arg %d)", narg);
83 
	}
 85 
	}
84 
	if (dup) {
 86 
	if (dup) {
- 
 
 87 
	    if(asLogical(getAttrib(s, CSingSymbol)) == 1) {
- 
 
 88 
		sptr = (float*)R_alloc(n, sizeof(float));
- 
 
 89 
		for (i = 0 ; i < n ; i++)
- 
 
 90 
		    sptr[i] = (float) REAL(s)[i];
- 
 
 91 
		return (void*)sptr;
- 
 
 92 
	    } else {
85 
	    rptr = (double*)R_alloc(n, sizeof(double));
 93 
		rptr = (double*)R_alloc(n, sizeof(double));
86 
	    for (i = 0 ; i < n ; i++)
 94 
		for (i = 0 ; i < n ; i++)
87 
		rptr[i] = REAL(s)[i];
 95 
		    rptr[i] = REAL(s)[i];
- 
 
 96 
		return (void*)rptr;
88 
	}
 97 
	    }
- 
 
 98 
	} else
89 
	return (void*)rptr;
 99 
	    return (void*)rptr;
90 
	break;
 100 
	break;
91 
    case CPLXSXP:
 101 
    case CPLXSXP:
92 
	n = LENGTH(s);
 102 
	n = LENGTH(s);
93 
	zptr = COMPLEX(s);
 103 
	zptr = COMPLEX(s);
94 
	for (i = 0 ; i < n ; i++) {
 104 
	for (i = 0 ; i < n ; i++) {
Line 147... Line 157...
147 
	if(Fort) error("invalid mode to pass to Fortran (arg %d)", narg);
 157 
	if(Fort) error("invalid mode to pass to Fortran (arg %d)", narg);
148 
	return (void*)s;
 158 
	return (void*)s;
149 
    }
 159 
    }
150 
}
 160 
}
151 
 
 161 
 
152 
static SEXP CPtrToRObj(void *p, int n, SEXPTYPE type, int Fort)
 162 
static SEXP CPtrToRObj(void *p, SEXP arg, int Fort)
153 
{
 163 
{
- 
 
 164 
    int *iptr, n=length(arg);
154 
    int *iptr;
 165 
    float *sptr;
155 
    double *rptr;
 166 
    double *rptr;
156 
    char **cptr, buf[256];
 167 
    char **cptr, buf[256];
157 
    complex *zptr;
 168 
    complex *zptr;
158 
    SEXP *lptr;
 169 
    SEXP *lptr, CSingSymbol = install("Csingle");
159 
    int i;
 170 
    int i;
160 
    SEXP s, t;
 171 
    SEXP s, t;
- 
 
 172 
    SEXPTYPE type =TYPEOF(arg);
- 
 
 173
161 
    switch(type) {
 174 
    switch(type) {
162 
    case LGLSXP:
 175 
    case LGLSXP:
163 
    case INTSXP:
 176 
    case INTSXP:
164 
	s = allocVector(type, n);
 177 
	s = allocVector(type, n);
165 
	iptr = (int*)p;
 178 
	iptr = (int*)p;
Line 167... Line 180...
167 
	    INTEGER(s)[i] = iptr[i];
 180 
	    INTEGER(s)[i] = iptr[i];
168 
	}
 181 
	}
169 
	break;
 182 
	break;
170 
    case REALSXP:
 183 
    case REALSXP:
171 
	s = allocVector(type, n);
 184 
	s = allocVector(type, n);
- 
 
 185 
	if(asLogical(getAttrib(arg, CSingSymbol)) == 1) {
172 
	rptr = (double*)p;
 186 
	    sptr = (float*) p;
- 
 
 187 
	    for(i=0 ; i<n ; i++) REAL(s)[i] = (double) sptr[i];
- 
 
 188 
	} else {
173 
	for(i=0 ; i<n ; i++) {
 189 
	    rptr = (double*) p;
174 
	    REAL(s)[i] = rptr[i];
 190 
	    for(i=0 ; i<n ; i++) REAL(s)[i] = rptr[i];
175 
	}
 191 
	}
176 
	break;
 192 
	break;
177 
    case CPLXSXP:
 193 
    case CPLXSXP:
178 
	s = allocVector(type, n);
 194 
	s = allocVector(type, n);
179 
	zptr = (complex*)p;
 195 
	zptr = (complex*)p;
Line 293... Line 309...
293 
/*   code by Jean Meloche <jean@stat.ubc.ca> */
 309 
/*   code by Jean Meloche <jean@stat.ubc.ca> */
294 
 
 310 
 
295 
SEXP do_External(SEXP call, SEXP op, SEXP args, SEXP env)
 311 
SEXP do_External(SEXP call, SEXP op, SEXP args, SEXP env)
296 
{
 312 
{
297 
      DL_FUNC fun;
 313 
      DL_FUNC fun;
298 
      /*      char buf[128], *p, *q;  */
 - 
 
299 
      SEXP retval;
 314 
      SEXP retval;
300 
 
 - 
 
301 
      /* I don't like this messing with vmax <TSL> */
 315 
      /* I don't like this messing with vmax <TSL> */
- 
 
 316 
      /* But it is needed for clearing R_alloc and to be like .Call <BDR>*/
302 
      /* vmax = vmaxget(); */
 317 
      char *vmax = vmaxget();
- 
 
 318 
 
303 
      op = CAR(args);
 319 
      op = CAR(args);
304 
      if (!isString(op))
 320 
      if (!isString(op))
305 
	  errorcall(call,"function name must be a string");
 321 
	  errorcall(call,"function name must be a string");
306 
 
 - 
 
307 
      /* make up load symbol & look it up */
 - 
 
308 
      /*      p = CHAR(STRING(op)[0]);
 - 
 
309 
      q = buf; while ((*q = *p) != '\0') { p++; q++; }
 - 
 
310 
 
 - 
 
311 
      if (!(fun=R_FindSymbol(buf))) */
 - 
 
312 
      if (!(fun=R_FindSymbol(CHAR(STRING(op)[0]))))
 322 
      if (!(fun=R_FindSymbol(CHAR(STRING(op)[0]))))
313 
	  errorcall(call, "C-R function not in load table");
 323 
	  errorcall(call, "C-R function not in load table");
314 
 
 324 
 
315 
      retval = (SEXP)fun(args);
 325 
      retval = (SEXP)fun(args);
316 
 
 - 
 
317 
      /* vmaxset(vmax); */
 326 
      vmaxset(vmax);
318 
      return retval;
 327 
      return retval;
319 
}
 328 
}
320 
 
 329 
 
321 
SEXP do_dotcall(SEXP call, SEXP op, SEXP args, SEXP env)
 330 
SEXP do_dotcall(SEXP call, SEXP op, SEXP args, SEXP env)
322 
{
 331 
{
Line 1012... Line 1021...
1012 
    op = CAR(args);
 1021 
    op = CAR(args);
1013 
    if (!isString(op))
 1022 
    if (!isString(op))
1014 
	errorcall(call, "function name must be a string");
 1023 
	errorcall(call, "function name must be a string");
1015 
 
 1024 
 
1016 
    /* The following code modifies the argument list */
 1025 
    /* The following code modifies the argument list */
1017 
    /* We know this is ok because do_dotcode is entered */
 1026 
    /* We know this is ok because do_dotCode is entered */
1018 
    /* with its arguments evaluated. */
 1027 
    /* with its arguments evaluated. */
1019 
 
 1028 
 
1020 
    args = naoktrim(CDR(args), &nargs, &naok, &dup);
 1029 
    args = naoktrim(CDR(args), &nargs, &naok, &dup);
1021 
    if(naok == NA_LOGICAL)
 1030 
    if(naok == NA_LOGICAL)
1022 
	errorcall(call, "invalid naok value");
 1031 
	errorcall(call, "invalid naok value");
Line 1648... Line 1657...
1648 
    PROTECT(ans = allocVector(VECSXP, nargs));
 1657 
    PROTECT(ans = allocVector(VECSXP, nargs));
1649 
    havenames = 0;
 1658 
    havenames = 0;
1650 
    if (dup) {
 1659 
    if (dup) {
1651 
	nargs = 0;
 1660 
	nargs = 0;
1652 
	for (pargs = args ; pargs != R_NilValue ; pargs = CDR(pargs)) {
 1661 
	for (pargs = args ; pargs != R_NilValue ; pargs = CDR(pargs)) {
1653 
	    PROTECT(s = CPtrToRObj(cargs[nargs], LENGTH(CAR(pargs)),
 1662 
	    PROTECT(s = CPtrToRObj(cargs[nargs], CAR(pargs), which));
1654 
				   TYPEOF(CAR(pargs)), which));
 - 
 
1655 
	    ATTRIB(s) = duplicate(ATTRIB(CAR(pargs)));
 1663 
	    ATTRIB(s) = duplicate(ATTRIB(CAR(pargs)));
1656 
	    if (TAG(pargs) != R_NilValue)
 1664 
	    if (TAG(pargs) != R_NilValue)
1657 
		havenames = 1;
 1665 
		havenames = 1;
1658 
	    VECTOR(ans)[nargs] = s;
 1666 
	    VECTOR(ans)[nargs] = s;
1659 
	    nargs++;
 1667 
	    nargs++;