The R Project SVN – R – Diff – /trunk/src/main/dotcode.c



    SEXP op;
    const char *p; char *q;
    DllReference dll;
    /* This is used as shorthand for 'all' in R_FindSymbol, but
       should never be supplied */
    strcpy(dll.DLLname, "");
    dll.dll = NULL; dll.obj = NULL; dll.type = NOT_DEFINED;
 
    op = CAR(args);  // value of .NAME =
    /* NB, this sets fun, symbol and buf and is not just a check! */
    checkValidSymbolId(op, call, fun, symbol, buf);
 
    /* The following code modifies the argument list */

 
#ifdef CHECK_CROSS_USAGE
    if (dll.type == FILENAME && strcmp(dll.DLLname, "base")) {
	if(strlen(ns) && strcmp(dll.DLLname, ns) &&
	   !(streql(dll.DLLname, "BioC_graph") && streql(ns, "graph")))
	    warningcall(call,
			"using PACKAGE = \"%s\" from namespace '%s'",
			dll.DLLname, ns);
    }
#endif
 

    if(dll.type != FILENAME && strlen(ns)) {
	/* no PACKAGE= arg, so see if we can identify a DLL
	   from the namespace defining the function */
	*fun = R_FindNativeSymbolFromDLL(buf, &dll, symbol, env2);
	if (*fun) return args;
	errorcall(call, "\"%s\" not resolved from current namespace (%s)",
		  buf, ns);
    }
 
    /* NB: the actual conversion to the symbol is done in
       R_dlsym in Rdynload.c.  That prepends an underscore (usually),

	} else if(TAG(s) == DupSymbol) {
	    *dup = asLogical(CAR(s));
	    /* SETCDR(prev, s = CDR(s)); */
	    if(dupused++ == 1) warning(_("'%s' used more than once"), "DUP");
	} else if(TAG(s) == PkgSymbol) {
	    dll->obj = CAR(s);  // really?
	    if(TYPEOF(CAR(s)) == STRSXP) {
		p = translateChar(STRING_ELT(CAR(s), 0));
		if(strlen(p) > PATH_MAX - 1)
		    error(_("DLL name is too long"));
		dll->type = FILENAME;
		strcpy(dll->DLLname, p);
		if(pkgused++ > 1)
		    warning(_("'%s' used more than once"), "PACKAGE");
		/* More generally, this should allow us to process
		   any additional arguments and not insist that PACKAGE
		   be the last argument.
		*/

		    dll->type = R_OBJECT;
		    dll->obj = s;
		    strcpy(dll->DLLname,
			   translateChar(STRING_ELT(VECTOR_ELT(CAR(s), 1), 0)));
		    dll->dll = (HINSTANCE) R_ExternalPtrAddr(VECTOR_ELT(s, 4));
		} else
		    error("incorrect type (%s) of PACKAGE argument\n",
			  type2char(TYPEOF(CAR(s))));
	    }
	} else {
	    nargs++;

	ss = CDR(s);
	/* Look for PACKAGE=. We look at the next arg, unless
	   this is the last one (which will only happen for one arg),
	   and remove it */
	if(ss == R_NilValue && TAG(s) == PkgSymbol) {
	    if(pkgused++ == 1)
		warning(_("'%s' used more than once"), "PACKAGE");
	    setDLLname(s, dll->DLLname);
	    dll->type = FILENAME;
	    return R_NilValue;
	}
	if(TAG(ss) == PkgSymbol) {
	    if(pkgused++ == 1)
		warning(_("'%s' used more than once"), "PACKAGE");
	    setDLLname(ss, dll->DLLname);
	    dll->type = FILENAME;
	    SETCDR(s, CDR(ss));
	}

 
  1) dll.obj is a DLLInfo object
*/
static DL_FUNC
R_FindNativeSymbolFromDLL(char *name, DllReference *dll,
			  R_RegisteredNativeSymbol *symbol,
			  SEXP env)
{
    int numProtects = 0;
    DllInfo *info;
    DL_FUNC fun = NULL;

 
	   We do not need to copy if the inputs have no references */
 
#ifdef LONG_VECTOR_SUPPORT
	if (isVector(s) && IS_LONG_VEC(s))
	    error(_("long vectors (argument %d) are not supported in %s"),
		  na + 1, Fort ? ".C" : ".Fortran");
#endif
	SEXPTYPE t = TYPEOF(s);
	switch(t) {
	case RAWSXP:

	    break;
	case CLOSXP:
	case BUILTINSXP:
	case SPECIALSXP:
	case ENVSXP:
	    if (Fort) error(_("invalid mode (%s) to pass to Fortran (arg %d)"),
			    type2char(t), na + 1);
	    cargs[na] =  (void*) s;
	    break;
	case NILSXP:
	    error(_("invalid mode (%s) to pass to C or Fortran (arg %d)"),
		  type2char(t), na + 1);
	    cargs[na] =  (void*) s;
	    break;
	default:
	    /* Includes pairlists from R 2.15.0 */
	    if (Fort) error(_("invalid mode (%s) to pass to Fortran (arg %d)"),
			    type2char(t), na + 1);
	    warning("passing an object of type '%s' to .C (arg %d) is deprecated",
		    type2char(t), na + 1);
	    if (t == LISTSXP)
		warning(_("pairlists are passed as SEXP as from R 2.15.0"));
	    cargs[na] =  (void*) s;
	    continue;

			unsigned char *ptr = (unsigned char *) p;
			memcpy(RAW(s), ptr, n * sizeof(Rbyte));
			ptr += n * sizeof(Rbyte);
			for (int i = 0; i < NG; i++)
			    if(*ptr++ != FILL)
				error("array over-run in %s(\"%s\") in %s argument %d\n",
				      Fort ? ".Fortran" : ".C",
				      symName, type2char(type), na+1);
			ptr = (unsigned char *) p;
			for (int i = 0; i < NG; i++)
			    if(*--ptr != FILL)
				error("array under-run in %s(\"%s\") in %s argument %d\n",
				      Fort ? ".Fortran" : ".C",
				      symName, type2char(type), na+1);
		    }
		    break;
		case INTSXP:

			unsigned char *ptr = (unsigned char *) p;
			memcpy(INTEGER(s), ptr, n * sizeof(int));
			ptr += n * sizeof(int);
			for (int i = 0; i < NG; i++)
			    if(*ptr++ != FILL)
				error("array over-run in %s(\"%s\") in %s argument %d\n",
				      Fort ? ".Fortran" : ".C",
				      symName, type2char(type), na+1);
			ptr = (unsigned char *) p;
			for (int i = 0; i < NG; i++)
			    if(*--ptr != FILL)
				error("array under-run in %s(\"%s\") in %s argument %d\n",
				      Fort ? ".Fortran" : ".C",
				      symName, type2char(type), na+1);
		    }
		    break;
		case LGLSXP:

			    LOGICAL(s)[i] = (tmp == NA_INTEGER || tmp == 0) ? tmp : 1;
			}
			ptr += n * sizeof(int);
			for (int i = 0; i < NG;  i++)
			    if(*ptr++ != FILL)
				error("array over-run in %s(\"%s\") in %s argument %d\n",
				      Fort ? ".Fortran" : ".C",
				      symName, type2char(type), na+1);
			ptr = (unsigned char *) p;
			for (int i = 0; i < NG; i++)
			    if(*--ptr != FILL)
				error("array under-run in %s(\"%s\") in %s argument %d\n",
				      Fort ? ".Fortran" : ".C",
				      symName, type2char(type), na+1);
		    } else {
			int *iptr = INTEGER(arg), tmp;
			for (R_xlen_t i = 0 ; i < n ; i++) {

		case SINGLESXP:
		    if (copy) {
			s = allocVector(REALSXP, n);
			if (type == SINGLESXP || asLogical(getAttrib(arg, CSingSymbol)) == 1) {
			    float *sptr = (float*) p;
			    for(R_xlen_t i = 0 ; i < n ; i++)
				REAL(s)[i] = (double) sptr[i];
			} else {
			    unsigned char *ptr = (unsigned char *) p;
			    memcpy(REAL(s), ptr, n * sizeof(double));
			    ptr += n * sizeof(double);
			    for (int i = 0; i < NG; i++)
				if(*ptr++ != FILL)
				    error("array over-run in %s(\"%s\") in %s argument %d\n",
					  Fort ? ".Fortran" : ".C",
					  symName, type2char(type), na+1);
			    ptr = (unsigned char *) p;
			    for (int i = 0; i < NG; i++)
				if(*--ptr != FILL)
				    error("array under-run in %s(\"%s\") in %s argument %d\n",
					  Fort ? ".Fortran" : ".C",
					  symName, type2char(type), na+1);
			}
		    } else {
			if (type == SINGLESXP || asLogical(getAttrib(arg, CSingSymbol)) == 1) {
			    s = allocVector(REALSXP, n);
			    float *sptr = (float*) p;
			    for(int i = 0 ; i < n ; i++)
				REAL(s)[i] = (double) sptr[i];
			}
		    }
		    break;
		case CPLXSXP:
		    if (copy) {
			s = allocVector(type, n);
			unsigned char *ptr = (unsigned char *) p;
			memcpy(COMPLEX(s), p, n * sizeof(Rcomplex));
			ptr += n * sizeof(Rcomplex);
			for (int i = 0; i < NG;  i++)
			    if(*ptr++ != FILL)
				error("array over-run in %s(\"%s\") in %s argument %d\n",
				      Fort ? ".Fortran" : ".C",
				      symName, type2char(type), na+1);
			ptr = (unsigned char *) p;
			for (int i = 0; i < NG; i++)
			    if(*--ptr != FILL)
				error("array under-run in %s(\"%s\") in %s argument %d\n",
				      Fort ? ".Fortran" : ".C",
				      symName, type2char(type), na+1);
		    }
		    break;
		case STRSXP:

			    SET_STRING_ELT(s, i, mkChar(cptr[i]));
			    if (cptr[i] == cptr0[i]) {
				    const char *z = translateChar(STRING_ELT(ss, i));
				for (int j = 0; j < NG; j++)
				    if(*--ptr != FILL)
					error("array under-run in .C(\"%s\") in character argument %d, element %d",
					      symName, na+1, (int)(i+1));
				ptr = (unsigned char *) cptr[i];
				ptr += strlen(z) + 1;
				for (int j = 0; j < NG;  j++)
				    if(*ptr++ != FILL) {
					 // force termination
					unsigned char *p = ptr;
					for (int k = 1; k < NG - j; k++, p++)
					    if (*p == FILL) *p = '\0';
					error("array over-run in .C(\"%s\") in character argument %d, element %d\n'%s'->'%s'\n",
					      symName, na+1, (int)(i+1),
					      z, cptr[i]);
				    }
			    }
			}
			UNPROTECT(1);

    error(_("type \"%s\" not supported in interlanguage calls"), s);
    return 1; /* for -Wall */
}
 
/* This is entirely legacy, with no known users (Mar 2012).
   So we freeze the code involved.
 */
 
static void *RObjToCPtr2(SEXP s)
{
    int n;

Rev 66131	Rev 66468
Line 195...	Line 195...
195	`SEXP op;`	195	`SEXP op;`
196	`const char p; char q;`	196	`const char p; char q;`
197	`DllReference dll;`	197	`DllReference dll;`
198	`/* This is used as shorthand for 'all' in R_FindSymbol, but`	198	`/* This is used as shorthand for 'all' in R_FindSymbol, but`
199	`should never be supplied */`	199	`should never be supplied */`
200	`strcpy(dll.DLLname, "");`	200	`strcpy(dll.DLLname, "");`
201	`dll.dll = NULL; dll.obj = NULL; dll.type = NOT_DEFINED;`	201	`dll.dll = NULL; dll.obj = NULL; dll.type = NOT_DEFINED;`
202		202
203	`op = CAR(args); // value of .NAME =`	203	`op = CAR(args); // value of .NAME =`
204	`/* NB, this sets fun, symbol and buf and is not just a check! */`	204	`/* NB, this sets fun, symbol and buf and is not just a check! */`
205	`checkValidSymbolId(op, call, fun, symbol, buf);`	205	`checkValidSymbolId(op, call, fun, symbol, buf);`
206		206
207	`/* The following code modifies the argument list */`	207	`/* The following code modifies the argument list */`
Line 237...	Line 237...
237		237
238	`#ifdef CHECK_CROSS_USAGE`	238	`#ifdef CHECK_CROSS_USAGE`
239	`if (dll.type == FILENAME && strcmp(dll.DLLname, "base")) {`	239	`if (dll.type == FILENAME && strcmp(dll.DLLname, "base")) {`
240	`if(strlen(ns) && strcmp(dll.DLLname, ns) &&`	240	`if(strlen(ns) && strcmp(dll.DLLname, ns) &&`
241	`!(streql(dll.DLLname, "BioC_graph") && streql(ns, "graph")))`	241	`!(streql(dll.DLLname, "BioC_graph") && streql(ns, "graph")))`
242	`warningcall(call,`	242	`warningcall(call,`
243	`"using PACKAGE = \"%s\" from namespace '%s'",`	243	`"using PACKAGE = \"%s\" from namespace '%s'",`
244	`dll.DLLname, ns);`	244	`dll.DLLname, ns);`
245	`}`	245	`}`
246	`#endif`	246	`#endif`
247		247
Line 263...	Line 263...
263	`if(dll.type != FILENAME && strlen(ns)) {`	263	`if(dll.type != FILENAME && strlen(ns)) {`
264	`/* no PACKAGE= arg, so see if we can identify a DLL`	264	`/* no PACKAGE= arg, so see if we can identify a DLL`
265	`from the namespace defining the function */`	265	`from the namespace defining the function */`
266	`*fun = R_FindNativeSymbolFromDLL(buf, &dll, symbol, env2);`	266	`*fun = R_FindNativeSymbolFromDLL(buf, &dll, symbol, env2);`
267	`if (*fun) return args;`	267	`if (*fun) return args;`
268	`errorcall(call, "\"%s\" not resolved from current namespace (%s)",`	268	`errorcall(call, "\"%s\" not resolved from current namespace (%s)",`
269	`buf, ns);`	269	`buf, ns);`
270	`}`	270	`}`
271		271
272	`/* NB: the actual conversion to the symbol is done in`	272	`/* NB: the actual conversion to the symbol is done in`
273	`R_dlsym in Rdynload.c. That prepends an underscore (usually),`	273	`R_dlsym in Rdynload.c. That prepends an underscore (usually),`
Line 365...	Line 365...
365	`} else if(TAG(s) == DupSymbol) {`	365	`} else if(TAG(s) == DupSymbol) {`
366	`*dup = asLogical(CAR(s));`	366	`*dup = asLogical(CAR(s));`
367	`/* SETCDR(prev, s = CDR(s)); */`	367	`/* SETCDR(prev, s = CDR(s)); */`
368	`if(dupused++ == 1) warning(_("'%s' used more than once"), "DUP");`	368	`if(dupused++ == 1) warning(_("'%s' used more than once"), "DUP");`
369	`} else if(TAG(s) == PkgSymbol) {`	369	`} else if(TAG(s) == PkgSymbol) {`
370	`dll->obj = CAR(s); // really?`	370	`dll->obj = CAR(s); // really?`
371	`if(TYPEOF(CAR(s)) == STRSXP) {`	371	`if(TYPEOF(CAR(s)) == STRSXP) {`
372	`p = translateChar(STRING_ELT(CAR(s), 0));`	372	`p = translateChar(STRING_ELT(CAR(s), 0));`
373	`if(strlen(p) > PATH_MAX - 1)`	373	`if(strlen(p) > PATH_MAX - 1)`
374	`error(_("DLL name is too long"));`	374	`error(_("DLL name is too long"));`
375	`dll->type = FILENAME;`	375	`dll->type = FILENAME;`
376	`strcpy(dll->DLLname, p);`	376	`strcpy(dll->DLLname, p);`
377	`if(pkgused++ > 1)`	377	`if(pkgused++ > 1)`
378	`warning(_("'%s' used more than once"), "PACKAGE");`	378	`warning(_("'%s' used more than once"), "PACKAGE");`
379	`/* More generally, this should allow us to process`	379	`/* More generally, this should allow us to process`
380	`any additional arguments and not insist that PACKAGE`	380	`any additional arguments and not insist that PACKAGE`
381	`be the last argument.`	381	`be the last argument.`
382	`*/`	382	`*/`
Line 389...	Line 389...
389	`dll->type = R_OBJECT;`	389	`dll->type = R_OBJECT;`
390	`dll->obj = s;`	390	`dll->obj = s;`
391	`strcpy(dll->DLLname,`	391	`strcpy(dll->DLLname,`
392	`translateChar(STRING_ELT(VECTOR_ELT(CAR(s), 1), 0)));`	392	`translateChar(STRING_ELT(VECTOR_ELT(CAR(s), 1), 0)));`
393	`dll->dll = (HINSTANCE) R_ExternalPtrAddr(VECTOR_ELT(s, 4));`	393	`dll->dll = (HINSTANCE) R_ExternalPtrAddr(VECTOR_ELT(s, 4));`
394	`} else`	394	`} else`
395	`error("incorrect type (%s) of PACKAGE argument\n",`	395	`error("incorrect type (%s) of PACKAGE argument\n",`
396	`type2char(TYPEOF(CAR(s))));`	396	`type2char(TYPEOF(CAR(s))));`
397	`}`	397	`}`
398	`} else {`	398	`} else {`
399	`nargs++;`	399	`nargs++;`
Line 437...	Line 437...
437	`ss = CDR(s);`	437	`ss = CDR(s);`
438	`/* Look for PACKAGE=. We look at the next arg, unless`	438	`/* Look for PACKAGE=. We look at the next arg, unless`
439	`this is the last one (which will only happen for one arg),`	439	`this is the last one (which will only happen for one arg),`
440	`and remove it */`	440	`and remove it */`
441	`if(ss == R_NilValue && TAG(s) == PkgSymbol) {`	441	`if(ss == R_NilValue && TAG(s) == PkgSymbol) {`
442	`if(pkgused++ == 1)`	442	`if(pkgused++ == 1)`
443	`warning(_("'%s' used more than once"), "PACKAGE");`	443	`warning(_("'%s' used more than once"), "PACKAGE");`
444	`setDLLname(s, dll->DLLname);`	444	`setDLLname(s, dll->DLLname);`
445	`dll->type = FILENAME;`	445	`dll->type = FILENAME;`
446	`return R_NilValue;`	446	`return R_NilValue;`
447	`}`	447	`}`
448	`if(TAG(ss) == PkgSymbol) {`	448	`if(TAG(ss) == PkgSymbol) {`
449	`if(pkgused++ == 1)`	449	`if(pkgused++ == 1)`
450	`warning(_("'%s' used more than once"), "PACKAGE");`	450	`warning(_("'%s' used more than once"), "PACKAGE");`
451	`setDLLname(ss, dll->DLLname);`	451	`setDLLname(ss, dll->DLLname);`
452	`dll->type = FILENAME;`	452	`dll->type = FILENAME;`
453	`SETCDR(s, CDR(ss));`	453	`SETCDR(s, CDR(ss));`
454	`}`	454	`}`
Line 1345...	Line 1345...
1345		1345
1346	`1) dll.obj is a DLLInfo object`	1346	`1) dll.obj is a DLLInfo object`
1347	`*/`	1347	`*/`
1348	`static DL_FUNC`	1348	`static DL_FUNC`
1349	`R_FindNativeSymbolFromDLL(char name, DllReference dll,`	1349	`R_FindNativeSymbolFromDLL(char name, DllReference dll,`
1350	`R_RegisteredNativeSymbol *symbol,`	1350	`R_RegisteredNativeSymbol *symbol,`
1351	`SEXP env)`	1351	`SEXP env)`
1352	`{`	1352	`{`
1353	`int numProtects = 0;`	1353	`int numProtects = 0;`
1354	`DllInfo *info;`	1354	`DllInfo *info;`
1355	`DL_FUNC fun = NULL;`	1355	`DL_FUNC fun = NULL;`
Line 1504...	Line 1504...
1504		1504
1505	`We do not need to copy if the inputs have no references */`	1505	`We do not need to copy if the inputs have no references */`
1506		1506
1507	`#ifdef LONG_VECTOR_SUPPORT`	1507	`#ifdef LONG_VECTOR_SUPPORT`
1508	`if (isVector(s) && IS_LONG_VEC(s))`	1508	`if (isVector(s) && IS_LONG_VEC(s))`
1509	`error(_("long vectors (argument %d) are not supported in %s"),`	1509	`error(_("long vectors (argument %d) are not supported in %s"),`
1510	`na + 1, Fort ? ".C" : ".Fortran");`	1510	`na + 1, Fort ? ".C" : ".Fortran");`
1511	`#endif`	1511	`#endif`
1512	`SEXPTYPE t = TYPEOF(s);`	1512	`SEXPTYPE t = TYPEOF(s);`
1513	`switch(t) {`	1513	`switch(t) {`
1514	`case RAWSXP:`	1514	`case RAWSXP:`
Line 1672...	Line 1672...
1672	`break;`	1672	`break;`
1673	`case CLOSXP:`	1673	`case CLOSXP:`
1674	`case BUILTINSXP:`	1674	`case BUILTINSXP:`
1675	`case SPECIALSXP:`	1675	`case SPECIALSXP:`
1676	`case ENVSXP:`	1676	`case ENVSXP:`
1677	`if (Fort) error(_("invalid mode (%s) to pass to Fortran (arg %d)"),`	1677	`if (Fort) error(_("invalid mode (%s) to pass to Fortran (arg %d)"),`
1678	`type2char(t), na + 1);`	1678	`type2char(t), na + 1);`
1679	`cargs[na] = (void*) s;`	1679	`cargs[na] = (void*) s;`
1680	`break;`	1680	`break;`
1681	`case NILSXP:`	1681	`case NILSXP:`
1682	`error(_("invalid mode (%s) to pass to C or Fortran (arg %d)"),`	1682	`error(_("invalid mode (%s) to pass to C or Fortran (arg %d)"),`
1683	`type2char(t), na + 1);`	1683	`type2char(t), na + 1);`
1684	`cargs[na] = (void*) s;`	1684	`cargs[na] = (void*) s;`
1685	`break;`	1685	`break;`
1686	`default:`	1686	`default:`
1687	`/* Includes pairlists from R 2.15.0 */`	1687	`/* Includes pairlists from R 2.15.0 */`
1688	`if (Fort) error(_("invalid mode (%s) to pass to Fortran (arg %d)"),`	1688	`if (Fort) error(_("invalid mode (%s) to pass to Fortran (arg %d)"),`
1689	`type2char(t), na + 1);`	1689	`type2char(t), na + 1);`
1690	`warning("passing an object of type '%s' to .C (arg %d) is deprecated",`	1690	`warning("passing an object of type '%s' to .C (arg %d) is deprecated",`
1691	`type2char(t), na + 1);`	1691	`type2char(t), na + 1);`
1692	`if (t == LISTSXP)`	1692	`if (t == LISTSXP)`
1693	`warning(_("pairlists are passed as SEXP as from R 2.15.0"));`	1693	`warning(_("pairlists are passed as SEXP as from R 2.15.0"));`
1694	`cargs[na] = (void*) s;`	1694	`cargs[na] = (void*) s;`
1695	`continue;`	1695	`continue;`
Line 2313...	Line 2313...
2313	`unsigned char ptr = (unsigned char ) p;`	2313	`unsigned char ptr = (unsigned char ) p;`
2314	`memcpy(RAW(s), ptr, n * sizeof(Rbyte));`	2314	`memcpy(RAW(s), ptr, n * sizeof(Rbyte));`
2315	`ptr += n * sizeof(Rbyte);`	2315	`ptr += n * sizeof(Rbyte);`
2316	`for (int i = 0; i < NG; i++)`	2316	`for (int i = 0; i < NG; i++)`
2317	`if(*ptr++ != FILL)`	2317	`if(*ptr++ != FILL)`
2318	`error("array over-run in %s(\"%s\") in %s argument %d\n",`	2318	`error("array over-run in %s(\"%s\") in %s argument %d\n",`
2319	`Fort ? ".Fortran" : ".C",`	2319	`Fort ? ".Fortran" : ".C",`
2320	`symName, type2char(type), na+1);`	2320	`symName, type2char(type), na+1);`
2321	`ptr = (unsigned char *) p;`	2321	`ptr = (unsigned char *) p;`
2322	`for (int i = 0; i < NG; i++)`	2322	`for (int i = 0; i < NG; i++)`
2323	`if(*--ptr != FILL)`	2323	`if(*--ptr != FILL)`
2324	`error("array under-run in %s(\"%s\") in %s argument %d\n",`	2324	`error("array under-run in %s(\"%s\") in %s argument %d\n",`
2325	`Fort ? ".Fortran" : ".C",`	2325	`Fort ? ".Fortran" : ".C",`
2326	`symName, type2char(type), na+1);`	2326	`symName, type2char(type), na+1);`
2327	`}`	2327	`}`
2328	`break;`	2328	`break;`
2329	`case INTSXP:`	2329	`case INTSXP:`
Line 2332...	Line 2332...
2332	`unsigned char ptr = (unsigned char ) p;`	2332	`unsigned char ptr = (unsigned char ) p;`
2333	`memcpy(INTEGER(s), ptr, n * sizeof(int));`	2333	`memcpy(INTEGER(s), ptr, n * sizeof(int));`
2334	`ptr += n * sizeof(int);`	2334	`ptr += n * sizeof(int);`
2335	`for (int i = 0; i < NG; i++)`	2335	`for (int i = 0; i < NG; i++)`
2336	`if(*ptr++ != FILL)`	2336	`if(*ptr++ != FILL)`
2337	`error("array over-run in %s(\"%s\") in %s argument %d\n",`	2337	`error("array over-run in %s(\"%s\") in %s argument %d\n",`
2338	`Fort ? ".Fortran" : ".C",`	2338	`Fort ? ".Fortran" : ".C",`
2339	`symName, type2char(type), na+1);`	2339	`symName, type2char(type), na+1);`
2340	`ptr = (unsigned char *) p;`	2340	`ptr = (unsigned char *) p;`
2341	`for (int i = 0; i < NG; i++)`	2341	`for (int i = 0; i < NG; i++)`
2342	`if(*--ptr != FILL)`	2342	`if(*--ptr != FILL)`
2343	`error("array under-run in %s(\"%s\") in %s argument %d\n",`	2343	`error("array under-run in %s(\"%s\") in %s argument %d\n",`
2344	`Fort ? ".Fortran" : ".C",`	2344	`Fort ? ".Fortran" : ".C",`
2345	`symName, type2char(type), na+1);`	2345	`symName, type2char(type), na+1);`
2346	`}`	2346	`}`
2347	`break;`	2347	`break;`
2348	`case LGLSXP:`	2348	`case LGLSXP:`
Line 2355...	Line 2355...
2355	`LOGICAL(s)[i] = (tmp == NA_INTEGER \|\| tmp == 0) ? tmp : 1;`	2355	`LOGICAL(s)[i] = (tmp == NA_INTEGER \|\| tmp == 0) ? tmp : 1;`
2356	`}`	2356	`}`
2357	`ptr += n * sizeof(int);`	2357	`ptr += n * sizeof(int);`
2358	`for (int i = 0; i < NG; i++)`	2358	`for (int i = 0; i < NG; i++)`
2359	`if(*ptr++ != FILL)`	2359	`if(*ptr++ != FILL)`
2360	`error("array over-run in %s(\"%s\") in %s argument %d\n",`	2360	`error("array over-run in %s(\"%s\") in %s argument %d\n",`
2361	`Fort ? ".Fortran" : ".C",`	2361	`Fort ? ".Fortran" : ".C",`
2362	`symName, type2char(type), na+1);`	2362	`symName, type2char(type), na+1);`
2363	`ptr = (unsigned char *) p;`	2363	`ptr = (unsigned char *) p;`
2364	`for (int i = 0; i < NG; i++)`	2364	`for (int i = 0; i < NG; i++)`
2365	`if(*--ptr != FILL)`	2365	`if(*--ptr != FILL)`
2366	`error("array under-run in %s(\"%s\") in %s argument %d\n",`	2366	`error("array under-run in %s(\"%s\") in %s argument %d\n",`
2367	`Fort ? ".Fortran" : ".C",`	2367	`Fort ? ".Fortran" : ".C",`
2368	`symName, type2char(type), na+1);`	2368	`symName, type2char(type), na+1);`
2369	`} else {`	2369	`} else {`
2370	`int *iptr = INTEGER(arg), tmp;`	2370	`int *iptr = INTEGER(arg), tmp;`
2371	`for (R_xlen_t i = 0 ; i < n ; i++) {`	2371	`for (R_xlen_t i = 0 ; i < n ; i++) {`
Line 2378...	Line 2378...
2378	`case SINGLESXP:`	2378	`case SINGLESXP:`
2379	`if (copy) {`	2379	`if (copy) {`
2380	`s = allocVector(REALSXP, n);`	2380	`s = allocVector(REALSXP, n);`
2381	`if (type == SINGLESXP \|\| asLogical(getAttrib(arg, CSingSymbol)) == 1) {`	2381	`if (type == SINGLESXP \|\| asLogical(getAttrib(arg, CSingSymbol)) == 1) {`
2382	`float sptr = (float) p;`	2382	`float sptr = (float) p;`
2383	`for(R_xlen_t i = 0 ; i < n ; i++)`	2383	`for(R_xlen_t i = 0 ; i < n ; i++)`
2384	`REAL(s)[i] = (double) sptr[i];`	2384	`REAL(s)[i] = (double) sptr[i];`
2385	`} else {`	2385	`} else {`
2386	`unsigned char ptr = (unsigned char ) p;`	2386	`unsigned char ptr = (unsigned char ) p;`
2387	`memcpy(REAL(s), ptr, n * sizeof(double));`	2387	`memcpy(REAL(s), ptr, n * sizeof(double));`
2388	`ptr += n * sizeof(double);`	2388	`ptr += n * sizeof(double);`
2389	`for (int i = 0; i < NG; i++)`	2389	`for (int i = 0; i < NG; i++)`
2390	`if(*ptr++ != FILL)`	2390	`if(*ptr++ != FILL)`
2391	`error("array over-run in %s(\"%s\") in %s argument %d\n",`	2391	`error("array over-run in %s(\"%s\") in %s argument %d\n",`
2392	`Fort ? ".Fortran" : ".C",`	2392	`Fort ? ".Fortran" : ".C",`
2393	`symName, type2char(type), na+1);`	2393	`symName, type2char(type), na+1);`
2394	`ptr = (unsigned char *) p;`	2394	`ptr = (unsigned char *) p;`
2395	`for (int i = 0; i < NG; i++)`	2395	`for (int i = 0; i < NG; i++)`
2396	`if(*--ptr != FILL)`	2396	`if(*--ptr != FILL)`
2397	`error("array under-run in %s(\"%s\") in %s argument %d\n",`	2397	`error("array under-run in %s(\"%s\") in %s argument %d\n",`
2398	`Fort ? ".Fortran" : ".C",`	2398	`Fort ? ".Fortran" : ".C",`
2399	`symName, type2char(type), na+1);`	2399	`symName, type2char(type), na+1);`
2400	`}`	2400	`}`
2401	`} else {`	2401	`} else {`
2402	`if (type == SINGLESXP \|\| asLogical(getAttrib(arg, CSingSymbol)) == 1) {`	2402	`if (type == SINGLESXP \|\| asLogical(getAttrib(arg, CSingSymbol)) == 1) {`
2403	`s = allocVector(REALSXP, n);`	2403	`s = allocVector(REALSXP, n);`
2404	`float sptr = (float) p;`	2404	`float sptr = (float) p;`
2405	`for(int i = 0 ; i < n ; i++)`	2405	`for(int i = 0 ; i < n ; i++)`
2406	`REAL(s)[i] = (double) sptr[i];`	2406	`REAL(s)[i] = (double) sptr[i];`
2407	`}`	2407	`}`
2408	`}`	2408	`}`
2409	`break;`	2409	`break;`
2410	`case CPLXSXP:`	2410	`case CPLXSXP:`
2411	`if (copy) {`	2411	`if (copy) {`
2412	`s = allocVector(type, n);`	2412	`s = allocVector(type, n);`
2413	`unsigned char ptr = (unsigned char ) p;`	2413	`unsigned char ptr = (unsigned char ) p;`
2414	`memcpy(COMPLEX(s), p, n * sizeof(Rcomplex));`	2414	`memcpy(COMPLEX(s), p, n * sizeof(Rcomplex));`
2415	`ptr += n * sizeof(Rcomplex);`	2415	`ptr += n * sizeof(Rcomplex);`
2416	`for (int i = 0; i < NG; i++)`	2416	`for (int i = 0; i < NG; i++)`
2417	`if(*ptr++ != FILL)`	2417	`if(*ptr++ != FILL)`
2418	`error("array over-run in %s(\"%s\") in %s argument %d\n",`	2418	`error("array over-run in %s(\"%s\") in %s argument %d\n",`
2419	`Fort ? ".Fortran" : ".C",`	2419	`Fort ? ".Fortran" : ".C",`
2420	`symName, type2char(type), na+1);`	2420	`symName, type2char(type), na+1);`
2421	`ptr = (unsigned char *) p;`	2421	`ptr = (unsigned char *) p;`
2422	`for (int i = 0; i < NG; i++)`	2422	`for (int i = 0; i < NG; i++)`
2423	`if(*--ptr != FILL)`	2423	`if(*--ptr != FILL)`
2424	`error("array under-run in %s(\"%s\") in %s argument %d\n",`	2424	`error("array under-run in %s(\"%s\") in %s argument %d\n",`
2425	`Fort ? ".Fortran" : ".C",`	2425	`Fort ? ".Fortran" : ".C",`
2426	`symName, type2char(type), na+1);`	2426	`symName, type2char(type), na+1);`
2427	`}`	2427	`}`
2428	`break;`	2428	`break;`
2429	`case STRSXP:`	2429	`case STRSXP:`
Line 2444...	Line 2444...
2444	`SET_STRING_ELT(s, i, mkChar(cptr[i]));`	2444	`SET_STRING_ELT(s, i, mkChar(cptr[i]));`
2445	`if (cptr[i] == cptr0[i]) {`	2445	`if (cptr[i] == cptr0[i]) {`
2446	`const char *z = translateChar(STRING_ELT(ss, i));`	2446	`const char *z = translateChar(STRING_ELT(ss, i));`
2447	`for (int j = 0; j < NG; j++)`	2447	`for (int j = 0; j < NG; j++)`
2448	`if(*--ptr != FILL)`	2448	`if(*--ptr != FILL)`
2449	`error("array under-run in .C(\"%s\") in character argument %d, element %d",`	2449	`error("array under-run in .C(\"%s\") in character argument %d, element %d",`
2450	`symName, na+1, (int)(i+1));`	2450	`symName, na+1, (int)(i+1));`
2451	`ptr = (unsigned char *) cptr[i];`	2451	`ptr = (unsigned char *) cptr[i];`
2452	`ptr += strlen(z) + 1;`	2452	`ptr += strlen(z) + 1;`
2453	`for (int j = 0; j < NG; j++)`	2453	`for (int j = 0; j < NG; j++)`
2454	`if(*ptr++ != FILL) {`	2454	`if(*ptr++ != FILL) {`
2455	`// force termination`	2455	`// force termination`
2456	`unsigned char *p = ptr;`	2456	`unsigned char *p = ptr;`
2457	`for (int k = 1; k < NG - j; k++, p++)`	2457	`for (int k = 1; k < NG - j; k++, p++)`
2458	`if (p == FILL) p = '\0';`	2458	`if (p == FILL) p = '\0';`
2459	`error("array over-run in .C(\"%s\") in character argument %d, element %d\n'%s'->'%s'\n",`	2459	`error("array over-run in .C(\"%s\") in character argument %d, element %d\n'%s'->'%s'\n",`
2460	`symName, na+1, (int)(i+1),`	2460	`symName, na+1, (int)(i+1),`
2461	`z, cptr[i]);`	2461	`z, cptr[i]);`
2462	`}`	2462	`}`
2463	`}`	2463	`}`
2464	`}`	2464	`}`
2465	`UNPROTECT(1);`	2465	`UNPROTECT(1);`
Line 2515...	Line 2515...
2515	`error(_("type \"%s\" not supported in interlanguage calls"), s);`	2515	`error(_("type \"%s\" not supported in interlanguage calls"), s);`
2516	`return 1; /* for -Wall */`	2516	`return 1; /* for -Wall */`
2517	`}`	2517	`}`
2518		2518
2519	`/* This is entirely legacy, with no known users (Mar 2012).`	2519	`/* This is entirely legacy, with no known users (Mar 2012).`
2520	`So we freeze the code involved.`	2520	`So we freeze the code involved.`
2521	`*/`	2521	`*/`
2522		2522
2523	`static void *RObjToCPtr2(SEXP s)`	2523	`static void *RObjToCPtr2(SEXP s)`
2524	`{`	2524	`{`
2525	`int n;`	2525	`int n;`

The R Project SVN R

(root)/trunk/src/main/dotcode.c @ 63243 – Rev 66131 → 66468