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



 * Note that NA_STRING is not handled separately here.  This is
 *  deliberate -- see ?paste -- and implicitly coerces it to "NA"
 */
 
    SEXP collapse, sep;
    bool recycle_0;
 
/* We need to be careful here.  For example currently Windows 4.1
 * packages are links to 4.0, 4.0.0 uses only 3 args for paste and
 * 4.0.x (x >= 1) use 3 unless recycle0 is true.  So 4.1 needs to
 * accept 3-arg form, silently.

 
#ifdef future_R_4_1_or_newer
    checkArity(op, args);
#else
    int nargs = length(args);
    bool correct_nargs = (PRIMARITY(op) == nargs);
    if(!correct_nargs) { // we allow one less for capture from earlier versions
	if(PRIMARITY(op) == nargs + 1) {
	    recycle_0 = false;
#if 0
	    REprintf("%d arguments passed to .Internal(%s) which requires %d;\n an S4 method"
		     " may need to be redefined, typically by re-installing a package\n",
		     nargs, PRIMNAME(op), PRIMARITY(op));
#endif

	error(_("invalid first argument"));
    R_xlen_t nx = xlength(x);
 
    const char *csep = NULL;
    int sepw, u_sepw;
    bool sepASCII = true, sepUTF8 = false, sepBytes = false,
	sepKnown = false, use_sep = (PRIMVAL(op) == 0);
    if(use_sep) { /* paste(..., sep, .) */
	sep = CADR(args);
	if (!isString(sep) || LENGTH(sep) <= 0 || STRING_ELT(sep, 0) == NA_STRING)
	    error(_("invalid separator"));
	sep = STRING_ELT(sep, 0);

	sepKnown = ENC_KNOWN(sep) > 0;
	sepUTF8 = IS_UTF8(sep);
	sepBytes = IS_BYTES(sep);
	collapse = CADDR(args);
	if(correct_nargs)
	    recycle_0 = asBool2(CADDDR(args), call);
    } else { /* paste0(..., .) */
	u_sepw = sepw = 0; sep = R_NilValue;/* -Wall */
	collapse = CADR(args);
	if(correct_nargs)
	    recycle_0 = asBool2(CADDR(args), call);
    }
    bool do_collapse = (collapse != R_NilValue); // == !isNull(collapse)
    if (do_collapse)
	if(!isString(collapse) || LENGTH(collapse) <= 0 ||
	   STRING_ELT(collapse, 0) == NA_STRING)
	    error(_("invalid '%s' argument"), "collapse");
 

	zero_return;
 
    /* Maximum argument length, coerce if needed */
 
    R_xlen_t maxlen = 0;
    bool has_0_len = false;
    for (R_xlen_t j = 0; j < nx; j++) {
	if (!isString(VECTOR_ELT(x, j))) {
	    /* formerly in R code: moved to C for speed */
	    SEXP call, xj = VECTOR_ELT(x, j);
	    if(OBJECT(xj)) { /* method dispatch */

 
	    if (!isString(VECTOR_ELT(x, j)))
		error(_("non-string argument to .Internal(%s)"), PRIMNAME(op));
	}
	if(recycle_0 && !has_0_len && XLENGTH(VECTOR_ELT(x, j)) == 0) {
	    has_0_len = true;
	    break;
	}
	else if(maxlen < XLENGTH(VECTOR_ELT(x, j)))
	        maxlen = XLENGTH(VECTOR_ELT(x, j));
    }

    if(maxlen == 0) // all of the arguments where (equivalent to)  character(0)
	zero_return;
 
    SEXP ans = PROTECT( allocVector(STRSXP, maxlen));
 
    bool allKnown, anyKnown, use_UTF8, use_Bytes;
 
    for (R_xlen_t i = 0; i < maxlen; i++) {
	/* Strategy for marking the encoding: if all inputs (including
	 * the separator) are ASCII, so is the output and we don't
	 * need to mark.  Otherwise if all non-ASCII inputs are of
	 * declared encoding, we should mark.
	 * Need to be careful only to include separator if it is used.
	 */
	anyKnown = false; allKnown = true; use_UTF8 = false; use_Bytes = false;
	if(nx > 1) {
	    allKnown = sepKnown || sepASCII;
	    anyKnown = sepKnown;
	    use_UTF8 = sepUTF8;
	    use_Bytes = sepBytes;

 
	for (R_xlen_t j = 0; j < nx; j++) {
	    R_xlen_t k = XLENGTH(VECTOR_ELT(x, j));
	    if (k > 0) {
		SEXP cs = STRING_ELT(VECTOR_ELT(x, j), i % k);
		if(IS_UTF8(cs)) use_UTF8 = true;
		if(IS_BYTES(cs)) use_Bytes = true;
	    }
	}
	if (use_Bytes) use_UTF8 = false;
	R_xlen_t pwidth = 0;
	const void *vmax = vmaxget();
	for (R_xlen_t j = 0; j < nx; j++) {
	    R_xlen_t k = XLENGTH(VECTOR_ELT(x, j));
	    if (k > 0) {

    if(do_collapse && (nx = XLENGTH(ans)) > 0) {
	sep = STRING_ELT(collapse, 0);
	use_UTF8 = IS_UTF8(sep);
	use_Bytes = IS_BYTES(sep);
	for (R_xlen_t i = 0; i < nx; i++) {
	    if(!use_UTF8  && IS_UTF8 (STRING_ELT(ans, i))) use_UTF8  = true;
	    if(!use_Bytes && IS_BYTES(STRING_ELT(ans, i))) use_Bytes = true;
	}
	if(use_Bytes) {
	    csep = CHAR(sep);
	    use_UTF8 = false;
	} else if(use_UTF8)
	    csep = translateCharUTF8(sep);
	else
	    csep = translateChar(sep);
	sepw = (int) strlen(csep);

	}
    }
    SEXP ans = PROTECT(allocVector(STRSXP, maxlen));
 
    for (int i = 0; i < maxlen; i++) {
	bool use_UTF8;
	if (utf8locale)
	    use_UTF8 = true;
	else {
	    use_UTF8 = false;
	    for (int j = 0; j < nx; j++) {
		int k = LENGTH(VECTOR_ELT(x, j));
		SEXP cs = STRING_ELT(VECTOR_ELT(x, j), i % k);
		if(IS_UTF8(cs)) {use_UTF8 = true; break;}
		if(!latin1locale && IS_LATIN1(cs)) {use_UTF8 = true; break;}
	    }
	}
	int pwidth = 0;
	for (int j = 0; j < nx; j++) {
	    int k = LENGTH(VECTOR_ELT(x, j));

Rev 87815	Rev 87863
Line 60...	Line 60...
60	`* Note that NA_STRING is not handled separately here. This is`	60	`* Note that NA_STRING is not handled separately here. This is`
61	`* deliberate -- see ?paste -- and implicitly coerces it to "NA"`	61	`* deliberate -- see ?paste -- and implicitly coerces it to "NA"`
62	`*/`	62	`*/`
63		63
64	`SEXP collapse, sep;`	64	`SEXP collapse, sep;`
65	`Rboolean recycle_0;`	65	`bool recycle_0;`
66		66
67	`/* We need to be careful here. For example currently Windows 4.1`	67	`/* We need to be careful here. For example currently Windows 4.1`
68	`* packages are links to 4.0, 4.0.0 uses only 3 args for paste and`	68	`* packages are links to 4.0, 4.0.0 uses only 3 args for paste and`
69	`* 4.0.x (x >= 1) use 3 unless recycle0 is true. So 4.1 needs to`	69	`* 4.0.x (x >= 1) use 3 unless recycle0 is true. So 4.1 needs to`
70	`* accept 3-arg form, silently.`	70	`* accept 3-arg form, silently.`
Line 72...	Line 72...
72		72
73	`#ifdef future_R_4_1_or_newer`	73	`#ifdef future_R_4_1_or_newer`
74	`checkArity(op, args);`	74	`checkArity(op, args);`
75	`#else`	75	`#else`
76	`int nargs = length(args);`	76	`int nargs = length(args);`
77	`Rboolean correct_nargs = (PRIMARITY(op) == nargs);`	77	`bool correct_nargs = (PRIMARITY(op) == nargs);`
78	`if(!correct_nargs) { // we allow one less for capture from earlier versions`	78	`if(!correct_nargs) { // we allow one less for capture from earlier versions`
79	`if(PRIMARITY(op) == nargs + 1) {`	79	`if(PRIMARITY(op) == nargs + 1) {`
80	`recycle_0 = FALSE;`	80	`recycle_0 = false;`
81	`#if 0`	81	`#if 0`
82	`REprintf("%d arguments passed to .Internal(%s) which requires %d;\n an S4 method"`	82	`REprintf("%d arguments passed to .Internal(%s) which requires %d;\n an S4 method"`
83	`" may need to be redefined, typically by re-installing a package\n",`	83	`" may need to be redefined, typically by re-installing a package\n",`
84	`nargs, PRIMNAME(op), PRIMARITY(op));`	84	`nargs, PRIMNAME(op), PRIMARITY(op));`
85	`#endif`	85	`#endif`
Line 103...	Line 103...
103	`error(_("invalid first argument"));`	103	`error(_("invalid first argument"));`
104	`R_xlen_t nx = xlength(x);`	104	`R_xlen_t nx = xlength(x);`
105		105
106	`const char *csep = NULL;`	106	`const char *csep = NULL;`
107	`int sepw, u_sepw;`	107	`int sepw, u_sepw;`
108	`Rboolean sepASCII = TRUE, sepUTF8 = FALSE, sepBytes = FALSE,`	108	`bool sepASCII = true, sepUTF8 = false, sepBytes = false,`
109	`sepKnown = FALSE, use_sep = (PRIMVAL(op) == 0);`	109	`sepKnown = false, use_sep = (PRIMVAL(op) == 0);`
110	`if(use_sep) { /* paste(..., sep, .) */`	110	`if(use_sep) { /* paste(..., sep, .) */`
111	`sep = CADR(args);`	111	`sep = CADR(args);`
112	`if (!isString(sep) \|\| LENGTH(sep) <= 0 \|\| STRING_ELT(sep, 0) == NA_STRING)`	112	`if (!isString(sep) \|\| LENGTH(sep) <= 0 \|\| STRING_ELT(sep, 0) == NA_STRING)`
113	`error(_("invalid separator"));`	113	`error(_("invalid separator"));`
114	`sep = STRING_ELT(sep, 0);`	114	`sep = STRING_ELT(sep, 0);`
Line 118...	Line 118...
118	`sepKnown = ENC_KNOWN(sep) > 0;`	118	`sepKnown = ENC_KNOWN(sep) > 0;`
119	`sepUTF8 = IS_UTF8(sep);`	119	`sepUTF8 = IS_UTF8(sep);`
120	`sepBytes = IS_BYTES(sep);`	120	`sepBytes = IS_BYTES(sep);`
121	`collapse = CADDR(args);`	121	`collapse = CADDR(args);`
122	`if(correct_nargs)`	122	`if(correct_nargs)`
123	`recycle_0 = asRbool(CADDDR(args), call);`	123	`recycle_0 = asBool2(CADDDR(args), call);`
124	`} else { /* paste0(..., .) */`	124	`} else { /* paste0(..., .) */`
125	`u_sepw = sepw = 0; sep = R_NilValue;/* -Wall */`	125	`u_sepw = sepw = 0; sep = R_NilValue;/* -Wall */`
126	`collapse = CADR(args);`	126	`collapse = CADR(args);`
127	`if(correct_nargs)`	127	`if(correct_nargs)`
128	`recycle_0 = asRbool(CADDR(args), call);`	128	`recycle_0 = asBool2(CADDR(args), call);`
129	`}`	129	`}`
130	`Rboolean do_collapse = (collapse != R_NilValue); // == !isNull(collapse)`	130	`bool do_collapse = (collapse != R_NilValue); // == !isNull(collapse)`
131	`if (do_collapse)`	131	`if (do_collapse)`
132	`if(!isString(collapse) \|\| LENGTH(collapse) <= 0 \|\|`	132	`if(!isString(collapse) \|\| LENGTH(collapse) <= 0 \|\|`
133	`STRING_ELT(collapse, 0) == NA_STRING)`	133	`STRING_ELT(collapse, 0) == NA_STRING)`
134	`error(_("invalid '%s' argument"), "collapse");`	134	`error(_("invalid '%s' argument"), "collapse");`
135		135
Line 140...	Line 140...
140	`zero_return;`	140	`zero_return;`
141		141
142	`/* Maximum argument length, coerce if needed */`	142	`/* Maximum argument length, coerce if needed */`
143		143
144	`R_xlen_t maxlen = 0;`	144	`R_xlen_t maxlen = 0;`
145	`Rboolean has_0_len = FALSE;`	145	`bool has_0_len = false;`
146	`for (R_xlen_t j = 0; j < nx; j++) {`	146	`for (R_xlen_t j = 0; j < nx; j++) {`
147	`if (!isString(VECTOR_ELT(x, j))) {`	147	`if (!isString(VECTOR_ELT(x, j))) {`
148	`/* formerly in R code: moved to C for speed */`	148	`/* formerly in R code: moved to C for speed */`
149	`SEXP call, xj = VECTOR_ELT(x, j);`	149	`SEXP call, xj = VECTOR_ELT(x, j);`
150	`if(OBJECT(xj)) { /* method dispatch */`	150	`if(OBJECT(xj)) { /* method dispatch */`
Line 158...	Line 158...
158		158
159	`if (!isString(VECTOR_ELT(x, j)))`	159	`if (!isString(VECTOR_ELT(x, j)))`
160	`error(_("non-string argument to .Internal(%s)"), PRIMNAME(op));`	160	`error(_("non-string argument to .Internal(%s)"), PRIMNAME(op));`
161	`}`	161	`}`
162	`if(recycle_0 && !has_0_len && XLENGTH(VECTOR_ELT(x, j)) == 0) {`	162	`if(recycle_0 && !has_0_len && XLENGTH(VECTOR_ELT(x, j)) == 0) {`
163	`has_0_len = TRUE;`	163	`has_0_len = true;`
164	`break;`	164	`break;`
165	`}`	165	`}`
166	`else if(maxlen < XLENGTH(VECTOR_ELT(x, j)))`	166	`else if(maxlen < XLENGTH(VECTOR_ELT(x, j)))`
167	`maxlen = XLENGTH(VECTOR_ELT(x, j));`	167	`maxlen = XLENGTH(VECTOR_ELT(x, j));`
168	`}`	168	`}`
Line 171...	Line 171...
171	`if(maxlen == 0) // all of the arguments where (equivalent to) character(0)`	171	`if(maxlen == 0) // all of the arguments where (equivalent to) character(0)`
172	`zero_return;`	172	`zero_return;`
173		173
174	`SEXP ans = PROTECT( allocVector(STRSXP, maxlen));`	174	`SEXP ans = PROTECT( allocVector(STRSXP, maxlen));`
175		175
176	`Rboolean allKnown, anyKnown, use_UTF8, use_Bytes;`	176	`bool allKnown, anyKnown, use_UTF8, use_Bytes;`
177		177
178	`for (R_xlen_t i = 0; i < maxlen; i++) {`	178	`for (R_xlen_t i = 0; i < maxlen; i++) {`
179	`/* Strategy for marking the encoding: if all inputs (including`	179	`/* Strategy for marking the encoding: if all inputs (including`
180	`* the separator) are ASCII, so is the output and we don't`	180	`* the separator) are ASCII, so is the output and we don't`
181	`* need to mark. Otherwise if all non-ASCII inputs are of`	181	`* need to mark. Otherwise if all non-ASCII inputs are of`
182	`* declared encoding, we should mark.`	182	`* declared encoding, we should mark.`
183	`* Need to be careful only to include separator if it is used.`	183	`* Need to be careful only to include separator if it is used.`
184	`*/`	184	`*/`
185	`anyKnown = FALSE; allKnown = TRUE; use_UTF8 = FALSE; use_Bytes = FALSE;`	185	`anyKnown = false; allKnown = true; use_UTF8 = false; use_Bytes = false;`
186	`if(nx > 1) {`	186	`if(nx > 1) {`
187	`allKnown = sepKnown \|\| sepASCII;`	187	`allKnown = sepKnown \|\| sepASCII;`
188	`anyKnown = sepKnown;`	188	`anyKnown = sepKnown;`
189	`use_UTF8 = sepUTF8;`	189	`use_UTF8 = sepUTF8;`
190	`use_Bytes = sepBytes;`	190	`use_Bytes = sepBytes;`
Line 192...	Line 192...
192		192
193	`for (R_xlen_t j = 0; j < nx; j++) {`	193	`for (R_xlen_t j = 0; j < nx; j++) {`
194	`R_xlen_t k = XLENGTH(VECTOR_ELT(x, j));`	194	`R_xlen_t k = XLENGTH(VECTOR_ELT(x, j));`
195	`if (k > 0) {`	195	`if (k > 0) {`
196	`SEXP cs = STRING_ELT(VECTOR_ELT(x, j), i % k);`	196	`SEXP cs = STRING_ELT(VECTOR_ELT(x, j), i % k);`
197	`if(IS_UTF8(cs)) use_UTF8 = TRUE;`	197	`if(IS_UTF8(cs)) use_UTF8 = true;`
198	`if(IS_BYTES(cs)) use_Bytes = TRUE;`	198	`if(IS_BYTES(cs)) use_Bytes = true;`
199	`}`	199	`}`
200	`}`	200	`}`
201	`if (use_Bytes) use_UTF8 = FALSE;`	201	`if (use_Bytes) use_UTF8 = false;`
202	`R_xlen_t pwidth = 0;`	202	`R_xlen_t pwidth = 0;`
203	`const void *vmax = vmaxget();`	203	`const void *vmax = vmaxget();`
204	`for (R_xlen_t j = 0; j < nx; j++) {`	204	`for (R_xlen_t j = 0; j < nx; j++) {`
205	`R_xlen_t k = XLENGTH(VECTOR_ELT(x, j));`	205	`R_xlen_t k = XLENGTH(VECTOR_ELT(x, j));`
206	`if (k > 0) {`	206	`if (k > 0) {`
Line 266...	Line 266...
266	`if(do_collapse && (nx = XLENGTH(ans)) > 0) {`	266	`if(do_collapse && (nx = XLENGTH(ans)) > 0) {`
267	`sep = STRING_ELT(collapse, 0);`	267	`sep = STRING_ELT(collapse, 0);`
268	`use_UTF8 = IS_UTF8(sep);`	268	`use_UTF8 = IS_UTF8(sep);`
269	`use_Bytes = IS_BYTES(sep);`	269	`use_Bytes = IS_BYTES(sep);`
270	`for (R_xlen_t i = 0; i < nx; i++) {`	270	`for (R_xlen_t i = 0; i < nx; i++) {`
271	`if(!use_UTF8 && IS_UTF8 (STRING_ELT(ans, i))) use_UTF8 = TRUE;`	271	`if(!use_UTF8 && IS_UTF8 (STRING_ELT(ans, i))) use_UTF8 = true;`
272	`if(!use_Bytes && IS_BYTES(STRING_ELT(ans, i))) use_Bytes = TRUE;`	272	`if(!use_Bytes && IS_BYTES(STRING_ELT(ans, i))) use_Bytes = true;`
273	`}`	273	`}`
274	`if(use_Bytes) {`	274	`if(use_Bytes) {`
275	`csep = CHAR(sep);`	275	`csep = CHAR(sep);`
276	`use_UTF8 = FALSE;`	276	`use_UTF8 = false;`
277	`} else if(use_UTF8)`	277	`} else if(use_UTF8)`
278	`csep = translateCharUTF8(sep);`	278	`csep = translateCharUTF8(sep);`
279	`else`	279	`else`
280	`csep = translateChar(sep);`	280	`csep = translateChar(sep);`
281	`sepw = (int) strlen(csep);`	281	`sepw = (int) strlen(csep);`
Line 385...	Line 385...
385	`}`	385	`}`
386	`}`	386	`}`
387	`SEXP ans = PROTECT(allocVector(STRSXP, maxlen));`	387	`SEXP ans = PROTECT(allocVector(STRSXP, maxlen));`
388		388
389	`for (int i = 0; i < maxlen; i++) {`	389	`for (int i = 0; i < maxlen; i++) {`
390	`Rboolean use_UTF8;`	390	`bool use_UTF8;`
391	`if (utf8locale)`	391	`if (utf8locale)`
392	`use_UTF8 = TRUE;`	392	`use_UTF8 = true;`
393	`else {`	393	`else {`
394	`use_UTF8 = FALSE;`	394	`use_UTF8 = false;`
395	`for (int j = 0; j < nx; j++) {`	395	`for (int j = 0; j < nx; j++) {`
396	`int k = LENGTH(VECTOR_ELT(x, j));`	396	`int k = LENGTH(VECTOR_ELT(x, j));`
397	`SEXP cs = STRING_ELT(VECTOR_ELT(x, j), i % k);`	397	`SEXP cs = STRING_ELT(VECTOR_ELT(x, j), i % k);`
398	`if(IS_UTF8(cs)) {use_UTF8 = TRUE; break;}`	398	`if(IS_UTF8(cs)) {use_UTF8 = true; break;}`
399	`if(!latin1locale && IS_LATIN1(cs)) {use_UTF8 = TRUE; break;}`	399	`if(!latin1locale && IS_LATIN1(cs)) {use_UTF8 = true; break;}`
400	`}`	400	`}`
401	`}`	401	`}`
402	`int pwidth = 0;`	402	`int pwidth = 0;`
403	`for (int j = 0; j < nx; j++) {`	403	`for (int j = 0; j < nx; j++) {`
404	`int k = LENGTH(VECTOR_ELT(x, j));`	404	`int k = LENGTH(VECTOR_ELT(x, j));`

The R Project SVN R

(root)/trunk/src/main/paste.c @ 36498 – Rev 87815 → 87863