The R Project SVN R

Rev

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

Rev 20110 Rev 22284
Line 50... Line 50...
50
/* Convert an R object to a non-moveable C/Fortran object and return
50
/* Convert an R object to a non-moveable C/Fortran object and return
51
   a pointer to it.  This leaves pointers for anything other
51
   a pointer to it.  This leaves pointers for anything other
52
   than vectors and lists unaltered.
52
   than vectors and lists unaltered.
53
*/
53
*/
54
 
54
 
-
 
55
static Rboolean
-
 
56
checkNativeType(int targetType, int actualType)
-
 
57
{
-
 
58
   if(targetType > 0) {
-
 
59
      if(targetType == INTSXP || targetType == LGLSXP) {
-
 
60
	  return(actualType == INTSXP || actualType == LGLSXP);
-
 
61
      }
-
 
62
      return(targetType == actualType);
-
 
63
   }
-
 
64
 
-
 
65
  return(TRUE);
-
 
66
}
-
 
67
 
-
 
68
 
-
 
69
 
55
static void *RObjToCPtr(SEXP s, int naok, int dup, int narg, int Fort, const char *name, R_toCConverter **converter,
70
static void *RObjToCPtr(SEXP s, int naok, int dup, int narg, int Fort, const char *name, R_toCConverter **converter,
56
                          int targetType)
71
                          int targetType)
57
{
72
{
58
    int *iptr;
73
    int *iptr;
59
    float *sptr;
74
    float *sptr;
Line 80... Line 95...
80
	ans = Rf_convertToC(s, &info, &success, converter);
95
	ans = Rf_convertToC(s, &info, &success, converter);
81
	if(success)
96
	if(success)
82
	    return(ans);
97
	    return(ans);
83
    }
98
    }
84
 
99
 
85
    if(targetType > 0 && targetType != TYPEOF(s)) {
100
    if(checkNativeType(targetType, TYPEOF(s)) == FALSE) {
86
     if(!dup) {
101
     if(!dup) {
87
       error("expliciti request not to duplicate arguments in call to %s, but argument %d is of the wrong type", 
102
       error("explicit request not to duplicate arguments in call to %s, but argument %d is of the wrong type (%d != %d)", 
88
	     name, narg + 1);
103
	     name, narg + 1, targetType, TYPEOF(s));
89
     } 
104
     } 
90
 
105
 
91
     if(targetType != SINGLESXP) 
106
     if(targetType != SINGLESXP) 
92
        s = coerceVector(s, targetType);
107
        s = coerceVector(s, targetType);
93
    }
108
    }
Line 270... Line 285...
270
 
285
 
271
#ifdef THROW_REGISTRATION_TYPE_ERROR
286
#ifdef THROW_REGISTRATION_TYPE_ERROR
272
static Rboolean
287
static Rboolean
273
comparePrimitiveTypes(R_NativePrimitiveArgType type, SEXP s, Rboolean dup)
288
comparePrimitiveTypes(R_NativePrimitiveArgType type, SEXP s, Rboolean dup)
274
{
289
{
275
   if(TYPEOF(s) == type)
290
   if(type == ANYSXP || TYPEOF(s) == type)
276
      return(TRUE);
291
      return(TRUE);
277
 
292
 
278
   if(dup && type == SINGLESXP)
293
   if(dup && type == SINGLESXP)
279
      return(asLogical(getAttrib(s, install("Csingle"))) == TRUE);
294
      return(asLogical(getAttrib(s, install("Csingle"))) == TRUE);
280
 
295
 
Line 1241... Line 1256...
1241
    q = buf;
1256
    q = buf;
1242
    while ((*q = *p) != '\0') {
1257
    while ((*q = *p) != '\0') {
1243
	p++;
1258
	p++;
1244
	q++;
1259
	q++;
1245
    }
1260
    }
1246
#ifdef HAVE_F77_UNDERSCORE
-
 
1247
    if (which)
-
 
1248
	*q++ = '_';
-
 
1249
    *q = '\0';
-
 
1250
#endif
1261
 
1251
#ifdef Macintosh
1262
#ifdef Macintosh
1252
    if (!(fun = R_FindSymbol(buf, "", &symbol)))
1263
    if (!(fun = R_FindSymbol(buf, "", &symbol)))
1253
#else
1264
#else
1254
    if (!(fun = R_FindSymbol(buf, DLLname, &symbol)))
1265
    if (!(fun = R_FindSymbol(buf, DLLname, &symbol)))
1255
#endif /* Macintosh */
1266
#endif /* Macintosh */