The R Project SVN – R – Diff – /branches/R-GenGC/src/main/dotcode.c



	if(!dup)
	    error("character variables must be duplicated in .C/.Fortran");
	n = LENGTH(s);
	if(Fort) {
	    if(n > 1) warning("only first string in char vector used in .Fortran");
	    l = strlen(CHAR(STRING_ELT(s, 0)));
	    fptr = (char*)R_alloc(max(255, l) + 1, sizeof(char));
	    strcpy(fptr, CHAR(STRING_ELT(s, 0)));
	    return (void*)fptr;
	} else {
	    cptr = (char**)R_alloc(n, sizeof(char*));
	    for (i = 0 ; i < n ; i++) {
		l = strlen(CHAR(STRING_ELT(s, i)));
		cptr[i] = (char*)R_alloc(l + 1, sizeof(char));
		strcpy(cptr[i], CHAR(STRING_ELT(s, i)));
	    }
	    return (void*)cptr;
	}
	break;
    case VECSXP:
	if (!dup) return (void*)VECTOR_PTR(s); /***** Dangerous to GC!!! */
	n = length(s);
	lptr = (SEXP*)R_alloc(n, sizeof(SEXP));
	for (i = 0 ; i < n ; i++) {
	    lptr[i] = VECTOR_ELT(s, i);
	}
	return (void*)lptr;
	break;
    case LISTSXP:
	if(Fort) error("invalid mode to pass to Fortran (arg %d)", narg);

	if(Fort) {
	    /* only return one string: warned on the R -> Fortran step */
	    strncpy(buf, (char*)p, 255);
	    buf[256] = '\0';
	    PROTECT(s = allocVector(type, 1));
	    SET_STRING_ELT(s, 0, mkChar(buf));
	    UNPROTECT(1);
	} else {
	    PROTECT(s = allocVector(type, n));
	    cptr = (char**)p;
	    for(i = 0 ; i < n ; i++) {
		SET_STRING_ELT(s, i, mkChar(cptr[i]));
	    }
	    UNPROTECT(1);
	}
	break;
    case VECSXP:
	PROTECT(s = allocVector(VECSXP, n));
	lptr = (SEXP*)p;
	for (i = 0 ; i < n ; i++) {
	    SET_VECTOR_ELT(s, i, lptr[i]);
	}
	UNPROTECT(1);
	break;
    case LISTSXP:
	PROTECT(t = s = allocList(n));
	lptr = (SEXP*)p;
	for(i=0 ; i<n ; i++) {
	    SETCAR(t, lptr[i]);
	    t = CDR(t);
	}
	UNPROTECT(1);
    default:
	s = (SEXP)p;

	*dup = asLogical(CAR(s));
	(*len)++;
    }
    else if(TAG(s) == PkgSymbol) {
	value = naoktrim(CDR(s), len, naok, dup);
	strcpy(DLLname, CHAR(STRING_ELT(CAR(s), 0)));
	return value;
    }
    else {
	CDR(s) = naoktrim(CDR(s), len, naok, dup);
	(*len)++;

	   this is the last one (which will only happen for one arg),
	   and remove it */
	ss = CDR(s);
	if(ss == R_NilValue && TAG(s) == PkgSymbol) {
	    if(pkgused++ == 1) warning("PACKAGE used more than once");
	    strcpy(DLLname, CHAR(STRING_ELT(CAR(s), 0)));
	    return R_NilValue;
	}
	if(TAG(ss) == PkgSymbol) {
	    if(pkgused++ == 1) warning("PACKAGE used more than once");
	    strcpy(DLLname, CHAR(STRING_ELT(CAR(ss), 0)));
	    SETCDR(s, CDR(ss)); /* delete this arg, which is the next one */
	}
	nargs++;
	s = CDR(s);
    }
    *len = nargs;

	/* 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("PACKAGE used more than once");
	    strcpy(DLLname, CHAR(STRING_ELT(CAR(s), 0)));
	    return R_NilValue;
	}
	if(TAG(ss) == PkgSymbol) {
	    if(pkgused++ == 1) warning("PACKAGE used more than once");
	    strcpy(DLLname, CHAR(STRING_ELT(CAR(ss), 0)));
	    SETCDR(s, CDR(ss));
	}
	s = CDR(s);
    }
    return args;
}

{
    char buf[128], *p, *q;
    checkArity(op, args);
    if(!isValidString(CAR(args)))
	errorcall(call, R_MSG_IA);
    p = CHAR(STRING_ELT(CAR(args), 0));
    q = buf;
    while ((*q = *p) != '\0') {
	p++;
	q++;
    }

    char *sym;
    int val;
    checkArity(op, args);
    if(!isValidString(CAR(args)))
	errorcall(call, R_MSG_IA);
    sym = CHAR(STRING_ELT(CAR(args), 0));
    val = 1;
    if (!(fun = R_FindSymbol(sym, "")))
	val = 0;
    ans = allocVector(LGLSXP, 1);
    LOGICAL(ans)[0] = val;

	errorcall(call, "function name must be a string (of length 1)");
    if (PkgSymbol == NULL) PkgSymbol = install("PACKAGE");
    strcpy(DLLname, "");
    args = pkgtrim(args);
 
    if (!(fun=R_FindSymbol(CHAR(STRING_ELT(op, 0)), DLLname)))
	errorcall(call, "C function name not in load table");
 
    retval = (SEXP)fun(args);
    vmaxset(vmax);
    return retval;

 
    if (PkgSymbol == NULL) PkgSymbol = install("PACKAGE");
    strcpy(DLLname, "");
    args = pkgtrim(args);
 
    if (!(fun=R_FindSymbol(CHAR(STRING_ELT(op, 0)), DLLname)))
        errorcall(call, "C function name not in load table");
    args = CDR(args);
 
    for(nargs = 0, pargs = args ; pargs != R_NilValue; pargs = CDR(pargs)) {
        if (nargs == MAX_ARGS)

	nargs++;
    }
 
    /* Make up the load symbol and look it up. */
 
    p = CHAR(STRING_ELT(op, 0));
    q = buf;
    while ((*q = *p) != '\0') {
	p++;
	q++;
    }

    havenames = 0;
    if (dup) {
	nargs = 0;
	for (pargs = args ; pargs != R_NilValue ; pargs = CDR(pargs)) {
	    PROTECT(s = CPtrToRObj(cargs[nargs], CAR(pargs), which));
	    SET_ATTRIB(s, duplicate(ATTRIB(CAR(pargs))));
	    if (TAG(pargs) != R_NilValue)
		havenames = 1;
	    SET_VECTOR_ELT(ans, nargs, s);
	    nargs++;
	    UNPROTECT(1);
	}
    }
    else {
	nargs = 0;
	for (pargs = args ; pargs != R_NilValue ; pargs = CDR(pargs)) {
	    if (TAG(pargs) != R_NilValue)
		havenames = 1;
	    SET_VECTOR_ELT(ans, nargs, CAR(pargs));
	    nargs++;
	}
    }
    if (havenames) {
	SEXP names;
	PROTECT(names = allocVector(STRSXP, nargs));
	nargs = 0;
	for (pargs = args ; pargs != R_NilValue ; pargs = CDR(pargs)) {
	    if (TAG(pargs) == R_NilValue)
		SET_STRING_ELT(names, nargs++, R_BlankString);
	    else
		SET_STRING_ELT(names, nargs++, PRINTNAME(TAG(pargs)));
        }
	setAttrib(ans, R_NamesSymbol, names);
	UNPROTECT(1);
    }
    UNPROTECT(1);

	    long *lengths, char **names, long nres, char **results)
{
    SEXP call, pcall, s;
    SEXPTYPE type;
    int i, j, n;
 
 
    if (!isFunction((SEXP)func))
	error("invalid function in call_R");
    if (nargs < 0)
	error("invalid argument count in call_R");
    if (nres < 0)
	error("invalid return value count in call_R");
    PROTECT(pcall = call = allocList(nargs + 1));
    SET_TYPEOF(call, LANGSXP);
    SETCAR(pcall, (SEXP)func);
    s = R_NilValue;		/* -Wall */
    for (i = 0 ; i < nargs ; i++) {
	pcall = CDR(pcall);
	type = string2type(modes[i]);
	switch(type) {
	case LGLSXP:
	case INTSXP:
	    n = lengths[i];
	    SETCAR(pcall, allocVector(type, n));
	    memcpy(INTEGER(CAR(pcall)), arguments[i], n * sizeof(int));
	    break;
	case REALSXP:
	    n = lengths[i];
	    SETCAR(pcall, allocVector(REALSXP, n));
	    memcpy(REAL(CAR(pcall)), arguments[i], n * sizeof(double));
	    break;
	case CPLXSXP:
	    n = lengths[i];
	    SETCAR(pcall, allocVector(CPLXSXP, n));
	    memcpy(REAL(CAR(pcall)), arguments[i], n * sizeof(Rcomplex));
	    break;
	case STRSXP:
	    n = lengths[i];
	    SETCAR(pcall, allocVector(STRSXP, n));
	    for (j = 0 ; j < n ; j++) {
		char *str = (char*)(arguments[i]);
		s = allocString(strlen(str));
		SET_STRING_ELT(CAR(pcall), i, s);
		strcpy(CHAR(s), str);
 	    }
 
	    break;
	    /* FIXME : This copy is unnecessary! */
	    /* FIXME : This is obviously incorrect so disable
	case VECSXP:
	    n = lengths[i];
	    SETCAR(pcall, allocVector(VECSXP, n));
	    for (j = 0 ; j < n ; j++) {
		SET_VECTOR_ELT(s, i, (SEXP)(arguments[i]));
	    }
	    break; */
	default:
	    error("Mode `%s' is not supported in call_R", modes[i]);
	}
	if(names && names[i])
	    SET_TAG(pcall, install(names[i]));
	SET_NAMED(CAR(pcall), 2);
    }
    PROTECT(s = eval(call, R_GlobalEnv));
    switch(TYPEOF(s)) {
    case LGLSXP:
    case INTSXP:

	break;
    case VECSXP:
	n = length(s);
	if (nres < n) n = nres;
	for (i = 0 ; i < n ; i++) {
	    results[i] = RObjToCPtr(VECTOR_ELT(s, i), 1, 1, 0, 0);
	}
	break;
    case LISTSXP:
	n = length(s);
	if(nres < n) n = nres;

Rev 9615	Rev 9642
Line 118...	Line 118...
118	`if(!dup)`	118	`if(!dup)`
119	`error("character variables must be duplicated in .C/.Fortran");`	119	`error("character variables must be duplicated in .C/.Fortran");`
120	`n = LENGTH(s);`	120	`n = LENGTH(s);`
121	`if(Fort) {`	121	`if(Fort) {`
122	`if(n > 1) warning("only first string in char vector used in .Fortran");`	122	`if(n > 1) warning("only first string in char vector used in .Fortran");`
123	`l = strlen(CHAR(STRING(s)[0]));`	123	`l = strlen(CHAR(STRING_ELT(s, 0)));`
124	`fptr = (char*)R_alloc(max(255, l) + 1, sizeof(char));`	124	`fptr = (char*)R_alloc(max(255, l) + 1, sizeof(char));`
125	`strcpy(fptr, CHAR(STRING(s)[0]));`	125	`strcpy(fptr, CHAR(STRING_ELT(s, 0)));`
126	`return (void*)fptr;`	126	`return (void*)fptr;`
127	`} else {`	127	`} else {`
128	`cptr = (char*)R_alloc(n, sizeof(char));`	128	`cptr = (char*)R_alloc(n, sizeof(char));`
129	`for (i = 0 ; i < n ; i++) {`	129	`for (i = 0 ; i < n ; i++) {`
130	`l = strlen(CHAR(STRING(s)[i]));`	130	`l = strlen(CHAR(STRING_ELT(s, i)));`
131	`cptr[i] = (char*)R_alloc(l + 1, sizeof(char));`	131	`cptr[i] = (char*)R_alloc(l + 1, sizeof(char));`
132	`strcpy(cptr[i], CHAR(STRING(s)[i]));`	132	`strcpy(cptr[i], CHAR(STRING_ELT(s, i)));`
133	`}`	133	`}`
134	`return (void*)cptr;`	134	`return (void*)cptr;`
135	`}`	135	`}`
136	`break;`	136	`break;`
137	`case VECSXP:`	137	`case VECSXP:`
138	`if (!dup) return (void*)VECTOR(s);`	138	`if (!dup) return (void)VECTOR_PTR(s); /**** Dangerous to GC!!! */`
139	`n = length(s);`	139	`n = length(s);`
140	`lptr = (SEXP*)R_alloc(n, sizeof(SEXP));`	140	`lptr = (SEXP*)R_alloc(n, sizeof(SEXP));`
141	`for (i = 0 ; i < n ; i++) {`	141	`for (i = 0 ; i < n ; i++) {`
142	`lptr[i] = VECTOR(s)[i];`	142	`lptr[i] = VECTOR_ELT(s, i);`
143	`}`	143	`}`
144	`return (void*)lptr;`	144	`return (void*)lptr;`
145	`break;`	145	`break;`
146	`case LISTSXP:`	146	`case LISTSXP:`
147	`if(Fort) error("invalid mode to pass to Fortran (arg %d)", narg);`	147	`if(Fort) error("invalid mode to pass to Fortran (arg %d)", narg);`
Line 203...	Line 203...
203	`if(Fort) {`	203	`if(Fort) {`
204	`/* only return one string: warned on the R -> Fortran step */`	204	`/* only return one string: warned on the R -> Fortran step */`
205	`strncpy(buf, (char*)p, 255);`	205	`strncpy(buf, (char*)p, 255);`
206	`buf[256] = '\0';`	206	`buf[256] = '\0';`
207	`PROTECT(s = allocVector(type, 1));`	207	`PROTECT(s = allocVector(type, 1));`
208	`STRING(s)[0] = mkChar(buf);`	208	`SET_STRING_ELT(s, 0, mkChar(buf));`
209	`UNPROTECT(1);`	209	`UNPROTECT(1);`
210	`} else {`	210	`} else {`
211	`PROTECT(s = allocVector(type, n));`	211	`PROTECT(s = allocVector(type, n));`
212	`cptr = (char**)p;`	212	`cptr = (char**)p;`
213	`for(i = 0 ; i < n ; i++) {`	213	`for(i = 0 ; i < n ; i++) {`
214	`STRING(s)[i] = mkChar(cptr[i]);`	214	`SET_STRING_ELT(s, i, mkChar(cptr[i]));`
215	`}`	215	`}`
216	`UNPROTECT(1);`	216	`UNPROTECT(1);`
217	`}`	217	`}`
218	`break;`	218	`break;`
219	`case VECSXP:`	219	`case VECSXP:`
220	`PROTECT(s = allocVector(VECSXP, n));`	220	`PROTECT(s = allocVector(VECSXP, n));`
221	`lptr = (SEXP*)p;`	221	`lptr = (SEXP*)p;`
222	`for (i = 0 ; i < n ; i++) {`	222	`for (i = 0 ; i < n ; i++) {`
223	`VECTOR(s)[i] = lptr[i];`	223	`SET_VECTOR_ELT(s, i, lptr[i]);`
224	`}`	224	`}`
225	`UNPROTECT(1);`	225	`UNPROTECT(1);`
226	`break;`	226	`break;`
227	`case LISTSXP:`	227	`case LISTSXP:`
228	`PROTECT(t = s = allocList(n));`	228	`PROTECT(t = s = allocList(n));`
229	`lptr = (SEXP*)p;`	229	`lptr = (SEXP*)p;`
230	`for(i=0 ; i<n ; i++) {`	230	`for(i=0 ; i<n ; i++) {`
231	`CAR(t) = lptr[i];`	231	`SETCAR(t, lptr[i]);`
232	`t = CDR(t);`	232	`t = CDR(t);`
233	`}`	233	`}`
234	`UNPROTECT(1);`	234	`UNPROTECT(1);`
235	`default:`	235	`default:`
236	`s = (SEXP)p;`	236	`s = (SEXP)p;`
Line 263...	Line 263...
263	`*dup = asLogical(CAR(s));`	263	`*dup = asLogical(CAR(s));`
264	`(*len)++;`	264	`(*len)++;`
265	`}`	265	`}`
266	`else if(TAG(s) == PkgSymbol) {`	266	`else if(TAG(s) == PkgSymbol) {`
267	`value = naoktrim(CDR(s), len, naok, dup);`	267	`value = naoktrim(CDR(s), len, naok, dup);`
268	`strcpy(DLLname, CHAR(STRING(CAR(s))[0]));`	268	`strcpy(DLLname, CHAR(STRING_ELT(CAR(s), 0)));`
269	`return value;`	269	`return value;`
270	`}`	270	`}`
271	`else {`	271	`else {`
272	`CDR(s) = naoktrim(CDR(s), len, naok, dup);`	272	`CDR(s) = naoktrim(CDR(s), len, naok, dup);`
273	`(*len)++;`	273	`(*len)++;`
Line 297...	Line 297...
297	`this is the last one (which will only happen for one arg),`	297	`this is the last one (which will only happen for one arg),`
298	`and remove it */`	298	`and remove it */`
299	`ss = CDR(s);`	299	`ss = CDR(s);`
300	`if(ss == R_NilValue && TAG(s) == PkgSymbol) {`	300	`if(ss == R_NilValue && TAG(s) == PkgSymbol) {`
301	`if(pkgused++ == 1) warning("PACKAGE used more than once");`	301	`if(pkgused++ == 1) warning("PACKAGE used more than once");`
302	`strcpy(DLLname, CHAR(STRING(CAR(s))[0]));`	302	`strcpy(DLLname, CHAR(STRING_ELT(CAR(s), 0)));`
303	`return R_NilValue;`	303	`return R_NilValue;`
304	`}`	304	`}`
305	`if(TAG(ss) == PkgSymbol) {`	305	`if(TAG(ss) == PkgSymbol) {`
306	`if(pkgused++ == 1) warning("PACKAGE used more than once");`	306	`if(pkgused++ == 1) warning("PACKAGE used more than once");`
307	`strcpy(DLLname, CHAR(STRING(CAR(ss))[0]));`	307	`strcpy(DLLname, CHAR(STRING_ELT(CAR(ss), 0)));`
308	`CDR(s) = CDR(ss); /* delete this arg, which is the next one */`	308	`SETCDR(s, CDR(ss)); /* delete this arg, which is the next one */`
309	`}`	309	`}`
310	`nargs++;`	310	`nargs++;`
311	`s = CDR(s);`	311	`s = CDR(s);`
312	`}`	312	`}`
313	`*len = nargs;`	313	`*len = nargs;`
Line 324...	Line 324...
324	`/* Look for PACKAGE=. We look at the next arg, unless`	324	`/* Look for PACKAGE=. We look at the next arg, unless`
325	`this is the last one (which will only happen for one arg),`	325	`this is the last one (which will only happen for one arg),`
326	`and remove it */`	326	`and remove it */`
327	`if(ss == R_NilValue && TAG(s) == PkgSymbol) {`	327	`if(ss == R_NilValue && TAG(s) == PkgSymbol) {`
328	`if(pkgused++ == 1) warning("PACKAGE used more than once");`	328	`if(pkgused++ == 1) warning("PACKAGE used more than once");`
329	`strcpy(DLLname, CHAR(STRING(CAR(s))[0]));`	329	`strcpy(DLLname, CHAR(STRING_ELT(CAR(s), 0)));`
330	`return R_NilValue;`	330	`return R_NilValue;`
331	`}`	331	`}`
332	`if(TAG(ss) == PkgSymbol) {`	332	`if(TAG(ss) == PkgSymbol) {`
333	`if(pkgused++ == 1) warning("PACKAGE used more than once");`	333	`if(pkgused++ == 1) warning("PACKAGE used more than once");`
334	`strcpy(DLLname, CHAR(STRING(CAR(ss))[0]));`	334	`strcpy(DLLname, CHAR(STRING_ELT(CAR(ss), 0)));`
335	`CDR(s) = CDR(ss);`	335	`SETCDR(s, CDR(ss));`
336	`}`	336	`}`
337	`s = CDR(s);`	337	`s = CDR(s);`
338	`}`	338	`}`
339	`return args;`	339	`return args;`
340	`}`	340	`}`
Line 345...	Line 345...
345	`{`	345	`{`
346	`char buf[128], p, q;`	346	`char buf[128], p, q;`
347	`checkArity(op, args);`	347	`checkArity(op, args);`
348	`if(!isValidString(CAR(args)))`	348	`if(!isValidString(CAR(args)))`
349	`errorcall(call, R_MSG_IA);`	349	`errorcall(call, R_MSG_IA);`
350	`p = CHAR(STRING(CAR(args))[0]);`	350	`p = CHAR(STRING_ELT(CAR(args), 0));`
351	`q = buf;`	351	`q = buf;`
352	`while ((q = p) != '\0') {`	352	`while ((q = p) != '\0') {`
353	`p++;`	353	`p++;`
354	`q++;`	354	`q++;`
355	`}`	355	`}`
Line 369...	Line 369...
369	`char *sym;`	369	`char *sym;`
370	`int val;`	370	`int val;`
371	`checkArity(op, args);`	371	`checkArity(op, args);`
372	`if(!isValidString(CAR(args)))`	372	`if(!isValidString(CAR(args)))`
373	`errorcall(call, R_MSG_IA);`	373	`errorcall(call, R_MSG_IA);`
374	`sym = CHAR(STRING(CAR(args))[0]);`	374	`sym = CHAR(STRING_ELT(CAR(args), 0));`
375	`val = 1;`	375	`val = 1;`
376	`if (!(fun = R_FindSymbol(sym, "")))`	376	`if (!(fun = R_FindSymbol(sym, "")))`
377	`val = 0;`	377	`val = 0;`
378	`ans = allocVector(LGLSXP, 1);`	378	`ans = allocVector(LGLSXP, 1);`
379	`LOGICAL(ans)[0] = val;`	379	`LOGICAL(ans)[0] = val;`
Line 396...	Line 396...
396	`errorcall(call, "function name must be a string (of length 1)");`	396	`errorcall(call, "function name must be a string (of length 1)");`
397	`if (PkgSymbol == NULL) PkgSymbol = install("PACKAGE");`	397	`if (PkgSymbol == NULL) PkgSymbol = install("PACKAGE");`
398	`strcpy(DLLname, "");`	398	`strcpy(DLLname, "");`
399	`args = pkgtrim(args);`	399	`args = pkgtrim(args);`
400		400
401	`if (!(fun=R_FindSymbol(CHAR(STRING(op)[0]), DLLname)))`	401	`if (!(fun=R_FindSymbol(CHAR(STRING_ELT(op, 0)), DLLname)))`
402	`errorcall(call, "C function name not in load table");`	402	`errorcall(call, "C function name not in load table");`
403		403
404	`retval = (SEXP)fun(args);`	404	`retval = (SEXP)fun(args);`
405	`vmaxset(vmax);`	405	`vmaxset(vmax);`
406	`return retval;`	406	`return retval;`
Line 419...	Line 419...
419		419
420	`if (PkgSymbol == NULL) PkgSymbol = install("PACKAGE");`	420	`if (PkgSymbol == NULL) PkgSymbol = install("PACKAGE");`
421	`strcpy(DLLname, "");`	421	`strcpy(DLLname, "");`
422	`args = pkgtrim(args);`	422	`args = pkgtrim(args);`
423		423
424	`if (!(fun=R_FindSymbol(CHAR(STRING(op)[0]), DLLname)))`	424	`if (!(fun=R_FindSymbol(CHAR(STRING_ELT(op, 0)), DLLname)))`
425	`errorcall(call, "C function name not in load table");`	425	`errorcall(call, "C function name not in load table");`
426	`args = CDR(args);`	426	`args = CDR(args);`
427		427
428	`for(nargs = 0, pargs = args ; pargs != R_NilValue; pargs = CDR(pargs)) {`	428	`for(nargs = 0, pargs = args ; pargs != R_NilValue; pargs = CDR(pargs)) {`
429	`if (nargs == MAX_ARGS)`	429	`if (nargs == MAX_ARGS)`
Line 1132...	Line 1132...
1132	`nargs++;`	1132	`nargs++;`
1133	`}`	1133	`}`
1134		1134
1135	`/* Make up the load symbol and look it up. */`	1135	`/* Make up the load symbol and look it up. */`
1136		1136
1137	`p = CHAR(STRING(op)[0]);`	1137	`p = CHAR(STRING_ELT(op, 0));`
1138	`q = buf;`	1138	`q = buf;`
1139	`while ((q = p) != '\0') {`	1139	`while ((q = p) != '\0') {`
1140	`p++;`	1140	`p++;`
1141	`q++;`	1141	`q++;`
1142	`}`	1142	`}`
Line 1746...	Line 1746...
1746	`havenames = 0;`	1746	`havenames = 0;`
1747	`if (dup) {`	1747	`if (dup) {`
1748	`nargs = 0;`	1748	`nargs = 0;`
1749	`for (pargs = args ; pargs != R_NilValue ; pargs = CDR(pargs)) {`	1749	`for (pargs = args ; pargs != R_NilValue ; pargs = CDR(pargs)) {`
1750	`PROTECT(s = CPtrToRObj(cargs[nargs], CAR(pargs), which));`	1750	`PROTECT(s = CPtrToRObj(cargs[nargs], CAR(pargs), which));`
1751	`ATTRIB(s) = duplicate(ATTRIB(CAR(pargs)));`	1751	`SET_ATTRIB(s, duplicate(ATTRIB(CAR(pargs))));`
1752	`if (TAG(pargs) != R_NilValue)`	1752	`if (TAG(pargs) != R_NilValue)`
1753	`havenames = 1;`	1753	`havenames = 1;`
1754	`VECTOR(ans)[nargs] = s;`	1754	`SET_VECTOR_ELT(ans, nargs, s);`
1755	`nargs++;`	1755	`nargs++;`
1756	`UNPROTECT(1);`	1756	`UNPROTECT(1);`
1757	`}`	1757	`}`
1758	`}`	1758	`}`
1759	`else {`	1759	`else {`
1760	`nargs = 0;`	1760	`nargs = 0;`
1761	`for (pargs = args ; pargs != R_NilValue ; pargs = CDR(pargs)) {`	1761	`for (pargs = args ; pargs != R_NilValue ; pargs = CDR(pargs)) {`
1762	`if (TAG(pargs) != R_NilValue)`	1762	`if (TAG(pargs) != R_NilValue)`
1763	`havenames = 1;`	1763	`havenames = 1;`
1764	`VECTOR(ans)[nargs] = CAR(pargs);`	1764	`SET_VECTOR_ELT(ans, nargs, CAR(pargs));`
1765	`nargs++;`	1765	`nargs++;`
1766	`}`	1766	`}`
1767	`}`	1767	`}`
1768	`if (havenames) {`	1768	`if (havenames) {`
1769	`SEXP names;`	1769	`SEXP names;`
1770	`PROTECT(names = allocVector(STRSXP, nargs));`	1770	`PROTECT(names = allocVector(STRSXP, nargs));`
1771	`nargs = 0;`	1771	`nargs = 0;`
1772	`for (pargs = args ; pargs != R_NilValue ; pargs = CDR(pargs)) {`	1772	`for (pargs = args ; pargs != R_NilValue ; pargs = CDR(pargs)) {`
1773	`if (TAG(pargs) == R_NilValue)`	1773	`if (TAG(pargs) == R_NilValue)`
1774	`STRING(names)[nargs++] = R_BlankString;`	1774	`SET_STRING_ELT(names, nargs++, R_BlankString);`
1775	`else`	1775	`else`
1776	`STRING(names)[nargs++] = PRINTNAME(TAG(pargs));`	1776	`SET_STRING_ELT(names, nargs++, PRINTNAME(TAG(pargs)));`
1777	`}`	1777	`}`
1778	`setAttrib(ans, R_NamesSymbol, names);`	1778	`setAttrib(ans, R_NamesSymbol, names);`
1779	`UNPROTECT(1);`	1779	`UNPROTECT(1);`
1780	`}`	1780	`}`
1781	`UNPROTECT(1);`	1781	`UNPROTECT(1);`
Line 1816...	Line 1816...
1816	`long lengths, char names, long nres, char *results)`	1816	`long lengths, char names, long nres, char *results)`
1817	`{`	1817	`{`
1818	`SEXP call, pcall, s;`	1818	`SEXP call, pcall, s;`
1819	`SEXPTYPE type;`	1819	`SEXPTYPE type;`
1820	`int i, j, n;`	1820	`int i, j, n;`
1821	`char **cptr;`	-
1822		1821
1823	`if (!isFunction((SEXP)func))`	1822	`if (!isFunction((SEXP)func))`
1824	`error("invalid function in call_R");`	1823	`error("invalid function in call_R");`
1825	`if (nargs < 0)`	1824	`if (nargs < 0)`
1826	`error("invalid argument count in call_R");`	1825	`error("invalid argument count in call_R");`
1827	`if (nres < 0)`	1826	`if (nres < 0)`
1828	`error("invalid return value count in call_R");`	1827	`error("invalid return value count in call_R");`
1829	`PROTECT(pcall = call = allocList(nargs + 1));`	1828	`PROTECT(pcall = call = allocList(nargs + 1));`
1830	`TYPEOF(call) = LANGSXP;`	1829	`SET_TYPEOF(call, LANGSXP);`
1831	`CAR(pcall) = (SEXP)func;`	1830	`SETCAR(pcall, (SEXP)func);`
1832	`s = R_NilValue; /* -Wall */`	1831	`s = R_NilValue; /* -Wall */`
1833	`for (i = 0 ; i < nargs ; i++) {`	1832	`for (i = 0 ; i < nargs ; i++) {`
1834	`pcall = CDR(pcall);`	1833	`pcall = CDR(pcall);`
1835	`type = string2type(modes[i]);`	1834	`type = string2type(modes[i]);`
1836	`switch(type) {`	1835	`switch(type) {`
1837	`case LGLSXP:`	1836	`case LGLSXP:`
1838	`case INTSXP:`	1837	`case INTSXP:`
1839	`CAR(pcall) = allocSExp(type);`	1838	`n = lengths[i];`
1840	`INTEGER(CAR(pcall)) = (int*)(arguments[i]);`	1839	`SETCAR(pcall, allocVector(type, n));`
1841	`LENGTH(CAR(pcall)) = lengths[i];`	1840	`memcpy(INTEGER(CAR(pcall)), arguments[i], n * sizeof(int));`
1842	`break;`	1841	`break;`
1843	`case REALSXP:`	1842	`case REALSXP:`
1844	`CAR(pcall) = allocSExp(REALSXP);`	1843	`n = lengths[i];`
1845	`REAL(CAR(pcall)) = (double*)(arguments[i]);`	1844	`SETCAR(pcall, allocVector(REALSXP, n));`
1846	`LENGTH(CAR(pcall)) = lengths[i];`	1845	`memcpy(REAL(CAR(pcall)), arguments[i], n * sizeof(double));`
1847	`break;`	1846	`break;`
1848	`case CPLXSXP:`	1847	`case CPLXSXP:`
1849	`CAR(pcall) = allocSExp(CPLXSXP);`	1848	`n = lengths[i];`
1850	`COMPLEX(CAR(pcall)) = (Rcomplex*)(arguments[i]);`	1849	`SETCAR(pcall, allocVector(CPLXSXP, n));`
1851	`LENGTH(CAR(pcall)) = lengths[i];`	1850	`memcpy(REAL(CAR(pcall)), arguments[i], n * sizeof(Rcomplex));`
1852	`break;`	1851	`break;`
1853	`case STRSXP:`	1852	`case STRSXP:`
1854	`n = lengths[i];`	1853	`n = lengths[i];`
1855	`CAR(pcall) = allocVector(STRSXP, n);`	1854	`SETCAR(pcall, allocVector(STRSXP, n));`
-		1855	`for (j = 0 ; j < n ; j++) {`
1856	`cptr = (char**)arguments[i];`	1856	`char str = (char)(arguments[i]);`
1857	`for (j = 0 ; j < n ; j++) {`	1857	`s = allocString(strlen(str));`
1858	`STRING(CAR(pcall))[j] = mkChar(cptr[j]);`	1858	`SET_STRING_ELT(CAR(pcall), i, s);`
-		1859	`strcpy(CHAR(s), str);`
1859	`}`	1860	`}`
1860	`LENGTH(CAR(pcall)) = n;`	-
1861	`break;`	1861	`break;`
1862	`/* FIXME : This copy is unnecessary! */`	1862	`/* FIXME : This copy is unnecessary! */`
1863	`/* FIXME : This is obviously incorrect so disable`	1863	`/* FIXME : This is obviously incorrect so disable`
1864	`case VECSXP:`	1864	`case VECSXP:`
1865	`n = lengths[i];`	1865	`n = lengths[i];`
1866	`CAR(pcall) = allocVector(VECSXP, n);`	1866	`SETCAR(pcall, allocVector(VECSXP, n));`
1867	`for (j = 0 ; j < n ; j++) {`	1867	`for (j = 0 ; j < n ; j++) {`
1868	`VECTOR(s)[i] = (SEXP)(arguments[i]);`	1868	`SET_VECTOR_ELT(s, i, (SEXP)(arguments[i]));`
1869	`}`	1869	`}`
1870	`break; */`	1870	`break; */`
1871	`default:`	1871	`default:`
1872	error("Mode `%s' is not supported in call_R", modes[i]);	1872	error("Mode `%s' is not supported in call_R", modes[i]);
1873	`}`	1873	`}`
1874	`if(names && names[i])`	1874	`if(names && names[i])`
1875	`TAG(pcall) = install(names[i]);`	1875	`SET_TAG(pcall, install(names[i]));`
1876	`NAMED(CAR(pcall)) = 2;`	1876	`SET_NAMED(CAR(pcall), 2);`
1877	`}`	1877	`}`
1878	`PROTECT(s = eval(call, R_GlobalEnv));`	1878	`PROTECT(s = eval(call, R_GlobalEnv));`
1879	`switch(TYPEOF(s)) {`	1879	`switch(TYPEOF(s)) {`
1880	`case LGLSXP:`	1880	`case LGLSXP:`
1881	`case INTSXP:`	1881	`case INTSXP:`
Line 1887...	Line 1887...
1887	`break;`	1887	`break;`
1888	`case VECSXP:`	1888	`case VECSXP:`
1889	`n = length(s);`	1889	`n = length(s);`
1890	`if (nres < n) n = nres;`	1890	`if (nres < n) n = nres;`
1891	`for (i = 0 ; i < n ; i++) {`	1891	`for (i = 0 ; i < n ; i++) {`
1892	`results[i] = RObjToCPtr(VECTOR(s)[i], 1, 1, 0, 0);`	1892	`results[i] = RObjToCPtr(VECTOR_ELT(s, i), 1, 1, 0, 0);`
1893	`}`	1893	`}`
1894	`break;`	1894	`break;`
1895	`case LISTSXP:`	1895	`case LISTSXP:`
1896	`n = length(s);`	1896	`n = length(s);`
1897	`if(nres < n) n = nres;`	1897	`if(nres < n) n = nres;`

The R Project SVN R

(root)/branches/R-GenGC/src/main/dotcode.c – Rev 9615 → 9642