The R Project SVN R

Rev

Rev 87904 | Details | Compare with Previous | Last modification | View Log | RSS feed

Rev Author Line No. Line
2 r 1 
/*
1160 maechler 2 
 *  R : A Computer Language for Statistical Data Analysis
87783 ripley 3 
 *  Copyright (C) 1997--2025  The R Core Team
79095 maechler 4 
 *  Copyright (C) 2002--2020  The R Foundation
2 r 5 
 *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
6 
 *
7 
 *  This program is free software; you can redistribute it and/or modify
8 
 *  it under the terms of the GNU General Public License as published by
21364 maechler 9 
 *  the Free Software Foundation; either version 2, or (at your option)
10 
 *  any later version.
2 r 11 
 *
12 
 *  This program is distributed in the hope that it will be useful,
13 
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
14 
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15 
 *  GNU General Public License for more details.
16 
 *
42307 ripley 17 
 *  You should have received a copy of the GNU General Public License
18 
 *  along with this program; if not, a copy is available at
68947 ripley 19 
 *  https://www.R-project.org/Licenses/
2 r 20 
 */
21 
 
1820 ihaka 22 
/* Code to handle list / vector switch */
23 
 
5187 hornik 24 
#ifdef HAVE_CONFIG_H
24632 hornik 25 
# include <config.h>
5187 hornik 26 
#endif
11499 ripley 27 
#include <Defn.h>
60667 ripley 28 
#include <Internal.h>
89100 luke 29 
#include <PrtUtil.h> // for IndexWidth
68663 luke 30 
#include <R_ext/Itermacros.h>
41631 ripley 31 
#define imax2(x, y) ((x < y) ? y : x)
1839 ihaka 32 
 
41899 ripley 33 
#include "RBufferUtils.h"
34 
static R_StringBuffer cbuff = {NULL, 0, MAXELTSIZE};
35 
 
68663 luke 36 
#include "duplicate.h"
37 
 
13997 duncan 38 
#define LIST_ASSIGN(x) {SET_VECTOR_ELT(data->ans_ptr, data->ans_length, x); data->ans_length++;}
1820 ihaka 39 
 
35504 maechler 40 
static SEXP cbind(SEXP, SEXP, SEXPTYPE, SEXP, int);
41 
static SEXP rbind(SEXP, SEXP, SEXPTYPE, SEXP, int);
2 r 42 
 
1820 ihaka 43 
/* The following code establishes the return type for the */
44 
/* functions  unlist, c, cbind, and rbind and also determines */
45 
/* whether the returned object is to have a names attribute. */
2 r 46 
 
13997 duncan 47 
struct BindData {
48 
 int  ans_flags;
49 
 SEXP ans_ptr;
60241 ripley 50 
 R_xlen_t ans_length;
13997 duncan 51 
 SEXP ans_names;
72950 maechler 52 
 R_xlen_t  ans_nnames;
35576 ripley 53 
/* int  deparse_level; Initialize to 1. */
13997 duncan 54 
};
2 r 55 
 
56 
static int HasNames(SEXP x)
57 
{
1820 ihaka 58 
    if(isVector(x)) {
59 
	if (!isNull(getAttrib(x, R_NamesSymbol)))
60 
	    return 1;
61 
    }
62 
    else if(isList(x)) {
1881 ihaka 63 
	while (!isNull(x)) {
1839 ihaka 64 
	    if (!isNull(TAG(x))) return 1;
1820 ihaka 65 
	    x = CDR(x);
2 r 66 
	}
1820 ihaka 67 
    }
68 
    return 0;
2 r 69 
}
70 
 
79095 maechler 71 
// Determine result type of unlist() or c();  called from  do_c()  and  do_unlist()
45446 ripley 72 
static void
87863 ripley 73 
AnswerType(SEXP x, bool recurse, bool usenames, struct BindData *data, SEXP call)
2 r 74 
{
1820 ihaka 75 
    switch (TYPEOF(x)) {
79095 maechler 76 
    case NILSXP: // NULL entries are dropped
1820 ihaka 77 
	break;
29902 ripley 78 
    case RAWSXP:
13997 duncan 79 
	data->ans_flags |= 1;
59052 ripley 80 
	data->ans_length += XLENGTH(x);
1820 ihaka 81 
	break;
29902 ripley 82 
    case LGLSXP:
83 
	data->ans_flags |= 2;
59052 ripley 84 
	data->ans_length += XLENGTH(x);
29902 ripley 85 
	break;
1820 ihaka 86 
    case INTSXP:
29902 ripley 87 
	data->ans_flags |= 16;
59052 ripley 88 
	data->ans_length += XLENGTH(x);
1820 ihaka 89 
	break;
90 
    case REALSXP:
29902 ripley 91 
	data->ans_flags |= 32;
59052 ripley 92 
	data->ans_length += XLENGTH(x);
1820 ihaka 93 
	break;
94 
    case CPLXSXP:
29902 ripley 95 
	data->ans_flags |= 64;
59052 ripley 96 
	data->ans_length += XLENGTH(x);
1820 ihaka 97 
	break;
98 
    case STRSXP:
29902 ripley 99 
	data->ans_flags |= 128;
59052 ripley 100 
	data->ans_length += XLENGTH(x);
1820 ihaka 101 
	break;
62995 maechler 102 
 
103 
#ifdef DO_C_Symbol
104 
/* new case : */
105 
    case SYMSXP:
106 
    case LANGSXP:
107 
	data->ans_flags |= 512; /* as.expression() implicitly */
108 
	data->ans_length += 1;
109 
	break;
110 
#endif
1820 ihaka 111 
    case VECSXP:
1839 ihaka 112 
    case EXPRSXP:
113 
	if (recurse) {
68586 ripley 114 
	    R_xlen_t i, n = XLENGTH(x);
45446 ripley 115 
	    if (usenames && !data->ans_nnames &&
38627 ripley 116 
		!isNull(getAttrib(x, R_NamesSymbol)))
13997 duncan 117 
		data->ans_nnames = 1;
1839 ihaka 118 
	    for (i = 0; i < n; i++) {
13997 duncan 119 
		if (usenames && !data->ans_nnames)
120 
		    data->ans_nnames = HasNames(VECTOR_ELT(x, i));
55747 urbaneks 121 
		AnswerType(VECTOR_ELT(x, i), recurse, usenames, data, call);
1820 ihaka 122 
	    }
123 
	}
124 
	else {
1839 ihaka 125 
	    if (TYPEOF(x) == EXPRSXP)
29902 ripley 126 
		data->ans_flags |= 512;
127 
	    else
13997 duncan 128 
		data->ans_flags |= 256;
68586 ripley 129 
	    data->ans_length += XLENGTH(x);
1820 ihaka 130 
	}
131 
	break;
132 
    case LISTSXP:
1839 ihaka 133 
	if (recurse) {
1881 ihaka 134 
	    while (x != R_NilValue) {
13997 duncan 135 
		if (usenames && !data->ans_nnames) {
136 
		    if (!isNull(TAG(x))) data->ans_nnames = 1;
137 
		    else data->ans_nnames = HasNames(CAR(x));
2 r 138 
		}
55747 urbaneks 139 
		AnswerType(CAR(x), recurse, usenames, data, call);
1820 ihaka 140 
		x = CDR(x);
141 
	    }
142 
	}
143 
	else {
29902 ripley 144 
	    data->ans_flags |= 256;
13997 duncan 145 
	    data->ans_length += length(x);
1820 ihaka 146 
	}
147 
	break;
148 
    default:
29902 ripley 149 
	data->ans_flags |= 256;
13997 duncan 150 
	data->ans_length += 1;
1820 ihaka 151 
	break;
152 
    }
55747 urbaneks 153 
 
154 
    /* check for overflow in ans_length. Objects are added one at a
155 
       time for each call to AnswerType so it is safe to check here.
156 
       Since sizes are signed, positive numbers, the overflow will
157 
       manifest itself as a negative result (both numbers will be
158 
       31-bit so we cannot overflow across the 32-bit boundary). If
159 
       our assumption (all lengths are signed) is violated, this won't
160 
       work so check when switching length types! */
59052 ripley 161 
 
162 
#ifndef LONG_VECTOR_SUPPORT
55747 urbaneks 163 
    if (data->ans_length < 0)
164 
	errorcall(call, _("resulting vector exceeds vector length limit in '%s'"), "AnswerType");
59052 ripley 165 
#endif
1820 ihaka 166 
}
1026 ihaka 167 
 
2 r 168 
 
65178 ripley 169 
/* The following functions are used to coerce arguments to the
170 
 * appropriate type for inclusion in the returned value. */
1820 ihaka 171 
 
38627 ripley 172 
static void
41712 ripley 173 
ListAnswer(SEXP x, int recurse, struct BindData *data, SEXP call)
2 r 174 
{
60241 ripley 175 
    R_xlen_t i;
2 r 176 
 
1820 ihaka 177 
    switch(TYPEOF(x)) {
79095 maechler 178 
    case NILSXP: // NULL entries are dropped
1820 ihaka 179 
	break;
180 
    case LGLSXP:
59052 ripley 181 
	for (i = 0; i < XLENGTH(x); i++)
1820 ihaka 182 
	    LIST_ASSIGN(ScalarLogical(LOGICAL(x)[i]));
183 
	break;
29902 ripley 184 
    case RAWSXP:
59052 ripley 185 
	for (i = 0; i < XLENGTH(x); i++)
29902 ripley 186 
	    LIST_ASSIGN(ScalarRaw(RAW(x)[i]));
187 
	break;
1820 ihaka 188 
    case INTSXP:
59052 ripley 189 
	for (i = 0; i < XLENGTH(x); i++)
1820 ihaka 190 
	    LIST_ASSIGN(ScalarInteger(INTEGER(x)[i]));
191 
	break;
192 
    case REALSXP:
59052 ripley 193 
	for (i = 0; i < XLENGTH(x); i++)
1820 ihaka 194 
	    LIST_ASSIGN(ScalarReal(REAL(x)[i]));
195 
	break;
196 
    case CPLXSXP:
59052 ripley 197 
	for (i = 0; i < XLENGTH(x); i++)
1820 ihaka 198 
	    LIST_ASSIGN(ScalarComplex(COMPLEX(x)[i]));
199 
	break;
200 
    case STRSXP:
59052 ripley 201 
	for (i = 0; i < XLENGTH(x); i++)
10172 luke 202 
	    LIST_ASSIGN(ScalarString(STRING_ELT(x, i)));
1820 ihaka 203 
	break;
204 
    case VECSXP:
1839 ihaka 205 
    case EXPRSXP:
1820 ihaka 206 
	if (recurse) {
59052 ripley 207 
	    for (i = 0; i < XLENGTH(x); i++)
41712 ripley 208 
		ListAnswer(VECTOR_ELT(x, i), recurse, data, call);
2 r 209 
	}
1820 ihaka 210 
	else {
59052 ripley 211 
	    for (i = 0; i < XLENGTH(x); i++)
64973 luke 212 
		LIST_ASSIGN(lazy_duplicate(VECTOR_ELT(x, i)));
1820 ihaka 213 
	}
214 
	break;
215 
    case LISTSXP:
1839 ihaka 216 
	if (recurse) {
1881 ihaka 217 
	    while (x != R_NilValue) {
41712 ripley 218 
		ListAnswer(CAR(x), recurse, data, call);
1820 ihaka 219 
		x = CDR(x);
220 
	    }
221 
	}
1889 ihaka 222 
	else
1881 ihaka 223 
	    while (x != R_NilValue) {
64973 luke 224 
		LIST_ASSIGN(lazy_duplicate(CAR(x)));
1820 ihaka 225 
		x = CDR(x);
226 
	    }
227 
	break;
228 
    default:
64973 luke 229 
	LIST_ASSIGN(lazy_duplicate(x));
1820 ihaka 230 
	break;
231 
    }
2 r 232 
}
233 
 
45446 ripley 234 
static void
41712 ripley 235 
StringAnswer(SEXP x, struct BindData *data, SEXP call)
2 r 236 
{
60241 ripley 237 
    R_xlen_t i;
1820 ihaka 238 
    switch(TYPEOF(x)) {
239 
    case NILSXP:
240 
	break;
241 
    case LISTSXP:
1881 ihaka 242 
	while (x != R_NilValue) {
41712 ripley 243 
	    StringAnswer(CAR(x), data, call);
1820 ihaka 244 
	    x = CDR(x);
2 r 245 
	}
1820 ihaka 246 
	break;
28798 tlumley 247 
    case EXPRSXP:
1820 ihaka 248 
    case VECSXP:
60241 ripley 249 
	for (i = 0; i < XLENGTH(x); i++)
41712 ripley 250 
	    StringAnswer(VECTOR_ELT(x, i), data, call);
1820 ihaka 251 
	break;
252 
    default:
253 
	PROTECT(x = coerceVector(x, STRSXP));
60241 ripley 254 
	for (i = 0; i < XLENGTH(x); i++)
13997 duncan 255 
	    SET_STRING_ELT(data->ans_ptr, data->ans_length++, STRING_ELT(x, i));
1820 ihaka 256 
	UNPROTECT(1);
257 
	break;
258 
    }
2 r 259 
}
260 
 
45446 ripley 261 
static void
41712 ripley 262 
LogicalAnswer(SEXP x, struct BindData *data, SEXP call)
2 r 263 
{
60241 ripley 264 
    R_xlen_t i;
1820 ihaka 265 
    switch(TYPEOF(x)) {
266 
    case NILSXP:
267 
	break;
268 
    case LISTSXP:
1881 ihaka 269 
	while (x != R_NilValue) {
41712 ripley 270 
	    LogicalAnswer(CAR(x), data, call);
38627 ripley 271 
	    x = CDR(x);
272 
	}
273 
	break;
274 
    case EXPRSXP:
275 
    case VECSXP:
60241 ripley 276 
	for (i = 0; i < XLENGTH(x); i++)
41712 ripley 277 
	    LogicalAnswer(VECTOR_ELT(x, i), data, call);
38627 ripley 278 
	break;
279 
    case LGLSXP:
60241 ripley 280 
	for (i = 0; i < XLENGTH(x); i++)
45446 ripley 281 
	    LOGICAL(data->ans_ptr)[data->ans_length++] = LOGICAL(x)[i];
282 
	break;
38627 ripley 283 
    case INTSXP:
64212 murdoch 284 
	for (i = 0; i < XLENGTH(x); i++) {
285 
	    int v = INTEGER(x)[i];
286 
	    LOGICAL(data->ans_ptr)[data->ans_length++] = (v == NA_INTEGER) ? NA_LOGICAL : ( v != 0 );
287 
	}
38627 ripley 288 
	break;
48257 maechler 289 
    case RAWSXP:
60241 ripley 290 
	for (i = 0; i < XLENGTH(x); i++)
64212 murdoch 291 
	    LOGICAL(data->ans_ptr)[data->ans_length++] = (int)RAW(x)[i] != 0;
48257 maechler 292 
	break;
38627 ripley 293 
    default:
45446 ripley 294 
	errorcall(call, _("type '%s' is unimplemented in '%s'"),
85146 luke 295 
		  R_typeToChar(x), "LogicalAnswer");
38627 ripley 296 
    }
297 
}
298 
 
45446 ripley 299 
static void
41712 ripley 300 
IntegerAnswer(SEXP x, struct BindData *data, SEXP call)
38627 ripley 301 
{
60241 ripley 302 
    R_xlen_t i;
38627 ripley 303 
    switch(TYPEOF(x)) {
304 
    case NILSXP:
305 
	break;
306 
    case LISTSXP:
307 
	while (x != R_NilValue) {
41712 ripley 308 
	    IntegerAnswer(CAR(x), data, call);
1820 ihaka 309 
	    x = CDR(x);
2 r 310 
	}
1820 ihaka 311 
	break;
28798 tlumley 312 
    case EXPRSXP:
1820 ihaka 313 
    case VECSXP:
60241 ripley 314 
	for (i = 0; i < XLENGTH(x); i++)
41712 ripley 315 
	    IntegerAnswer(VECTOR_ELT(x, i), data, call);
1820 ihaka 316 
	break;
38546 ripley 317 
    case LGLSXP:
60241 ripley 318 
	for (i = 0; i < XLENGTH(x); i++)
45446 ripley 319 
	    INTEGER(data->ans_ptr)[data->ans_length++] = LOGICAL(x)[i];
320 
	break;
38627 ripley 321 
    case INTSXP:
60241 ripley 322 
	for (i = 0; i < XLENGTH(x); i++)
13997 duncan 323 
	    INTEGER(data->ans_ptr)[data->ans_length++] = INTEGER(x)[i];
1820 ihaka 324 
	break;
48257 maechler 325 
    case RAWSXP:
60241 ripley 326 
	for (i = 0; i < XLENGTH(x); i++)
48257 maechler 327 
	    INTEGER(data->ans_ptr)[data->ans_length++] = (int)RAW(x)[i];
328 
	break;
38627 ripley 329 
    default:
45446 ripley 330 
	errorcall(call, _("type '%s' is unimplemented in '%s'"),
85146 luke 331 
		  R_typeToChar(x), "IntegerAnswer");
1820 ihaka 332 
    }
2 r 333 
}
334 
 
38627 ripley 335 
static void
41712 ripley 336 
RealAnswer(SEXP x, struct BindData *data, SEXP call)
2 r 337 
{
60241 ripley 338 
    R_xlen_t i;
59052 ripley 339 
    int xi;
1820 ihaka 340 
    switch(TYPEOF(x)) {
341 
    case NILSXP:
342 
	break;
343 
    case LISTSXP:
1881 ihaka 344 
	while (x != R_NilValue) {
41712 ripley 345 
	    RealAnswer(CAR(x), data, call);
1820 ihaka 346 
	    x = CDR(x);
2 r 347 
	}
1820 ihaka 348 
	break;
349 
    case VECSXP:
28798 tlumley 350 
    case EXPRSXP:
60241 ripley 351 
	for (i = 0; i < XLENGTH(x); i++)
41712 ripley 352 
	    RealAnswer(VECTOR_ELT(x, i), data, call);
1820 ihaka 353 
	break;
354 
    case REALSXP:
60241 ripley 355 
	for (i = 0; i < XLENGTH(x); i++)
13997 duncan 356 
	    REAL(data->ans_ptr)[data->ans_length++] = REAL(x)[i];
1820 ihaka 357 
	break;
38627 ripley 358 
    case LGLSXP:
60241 ripley 359 
	for (i = 0; i < XLENGTH(x); i++) {
38627 ripley 360 
	    xi = LOGICAL(x)[i];
361 
	    if (xi == NA_LOGICAL)
362 
		REAL(data->ans_ptr)[data->ans_length++] = NA_REAL;
363 
	    else REAL(data->ans_ptr)[data->ans_length++] = xi;
364 
	}
365 
	break;
366 
    case INTSXP:
60241 ripley 367 
	for (i = 0; i < XLENGTH(x); i++) {
1820 ihaka 368 
	    xi = INTEGER(x)[i];
1839 ihaka 369 
	    if (xi == NA_INTEGER)
13997 duncan 370 
		REAL(data->ans_ptr)[data->ans_length++] = NA_REAL;
371 
	    else REAL(data->ans_ptr)[data->ans_length++] = xi;
1820 ihaka 372 
	}
373 
	break;
48257 maechler 374 
    case RAWSXP:
60241 ripley 375 
	for (i = 0; i < XLENGTH(x); i++)
48257 maechler 376 
	    REAL(data->ans_ptr)[data->ans_length++] = (int)RAW(x)[i];
377 
	break;
38627 ripley 378 
    default:
45446 ripley 379 
	errorcall(call, _("type '%s' is unimplemented in '%s'"),
85146 luke 380 
		  R_typeToChar(x), "RealAnswer");
1820 ihaka 381 
    }
2 r 382 
}
383 
 
45446 ripley 384 
static void
41712 ripley 385 
ComplexAnswer(SEXP x, struct BindData *data, SEXP call)
2 r 386 
{
62995 maechler 387 
    R_xlen_t i;
59052 ripley 388 
    int xi;
1820 ihaka 389 
    switch(TYPEOF(x)) {
390 
    case NILSXP:
391 
	break;
392 
    case LISTSXP:
1881 ihaka 393 
	while (x != R_NilValue) {
41712 ripley 394 
	    ComplexAnswer(CAR(x), data, call);
1820 ihaka 395 
	    x = CDR(x);
2 r 396 
	}
1820 ihaka 397 
	break;
28798 tlumley 398 
    case EXPRSXP:
1820 ihaka 399 
    case VECSXP:
60241 ripley 400 
	for (i = 0; i < XLENGTH(x); i++)
41712 ripley 401 
	    ComplexAnswer(VECTOR_ELT(x, i), data, call);
1820 ihaka 402 
	break;
403 
    case REALSXP:
60241 ripley 404 
	for (i = 0; i < XLENGTH(x); i++) {
13997 duncan 405 
	    COMPLEX(data->ans_ptr)[data->ans_length].r = REAL(x)[i];
406 
	    COMPLEX(data->ans_ptr)[data->ans_length].i = 0.0;
407 
	    data->ans_length++;
1820 ihaka 408 
	}
409 
	break;
410 
    case CPLXSXP:
60241 ripley 411 
	for (i = 0; i < XLENGTH(x); i++)
13997 duncan 412 
	    COMPLEX(data->ans_ptr)[data->ans_length++] = COMPLEX(x)[i];
1820 ihaka 413 
	break;
38627 ripley 414 
    case LGLSXP:
60241 ripley 415 
	for (i = 0; i < XLENGTH(x); i++) {
38627 ripley 416 
	    xi = LOGICAL(x)[i];
417 
	    if (xi == NA_LOGICAL) {
418 
		COMPLEX(data->ans_ptr)[data->ans_length].r = NA_REAL;
85525 maechler 419 
#ifdef NA_TO_COMPLEX_NA
38627 ripley 420 
		COMPLEX(data->ans_ptr)[data->ans_length].i = NA_REAL;
85525 maechler 421 
#else
422 
		COMPLEX(data->ans_ptr)[data->ans_length].i = 0.0;
423 
#endif
38627 ripley 424 
	    }
425 
	    else {
426 
		COMPLEX(data->ans_ptr)[data->ans_length].r = xi;
427 
		COMPLEX(data->ans_ptr)[data->ans_length].i = 0.0;
428 
	    }
429 
	    data->ans_length++;
430 
	}
38629 ripley 431 
	break;
38627 ripley 432 
    case INTSXP:
60241 ripley 433 
	for (i = 0; i < XLENGTH(x); i++) {
1820 ihaka 434 
	    xi = INTEGER(x)[i];
21364 maechler 435 
	    if (xi == NA_INTEGER) {
436 
		COMPLEX(data->ans_ptr)[data->ans_length].r = NA_REAL;
85525 maechler 437 
#ifdef NA_TO_COMPLEX_NA
21364 maechler 438 
		COMPLEX(data->ans_ptr)[data->ans_length].i = NA_REAL;
85525 maechler 439 
#else
440 
		COMPLEX(data->ans_ptr)[data->ans_length].i = 0.0;
441 
#endif
21364 maechler 442 
	    }
443 
	    else {
444 
		COMPLEX(data->ans_ptr)[data->ans_length].r = xi;
445 
		COMPLEX(data->ans_ptr)[data->ans_length].i = 0.0;
446 
	    }
447 
	    data->ans_length++;
1820 ihaka 448 
	}
38629 ripley 449 
	break;
48257 maechler 450 
 
451 
    case RAWSXP:
60241 ripley 452 
	for (i = 0; i < XLENGTH(x); i++) {
48257 maechler 453 
	    COMPLEX(data->ans_ptr)[data->ans_length].r = (int)RAW(x)[i];
454 
	    COMPLEX(data->ans_ptr)[data->ans_length].i = 0.0;
455 
	    data->ans_length++;
456 
	}
457 
	break;
458 
 
38627 ripley 459 
    default:
45446 ripley 460 
	errorcall(call, _("type '%s' is unimplemented in '%s'"),
85146 luke 461 
		  R_typeToChar(x), "ComplexAnswer");
1820 ihaka 462 
    }
2 r 463 
}
464 
 
38627 ripley 465 
static void
41712 ripley 466 
RawAnswer(SEXP x, struct BindData *data, SEXP call)
29902 ripley 467 
{
60241 ripley 468 
    R_xlen_t i;
29902 ripley 469 
    switch(TYPEOF(x)) {
470 
    case NILSXP:
471 
	break;
472 
    case LISTSXP:
473 
	while (x != R_NilValue) {
41712 ripley 474 
	    RawAnswer(CAR(x), data, call);
29902 ripley 475 
	    x = CDR(x);
476 
	}
477 
	break;
478 
    case EXPRSXP:
479 
    case VECSXP:
60241 ripley 480 
	for (i = 0; i < XLENGTH(x); i++)
41712 ripley 481 
	    RawAnswer(VECTOR_ELT(x, i), data, call);
29902 ripley 482 
	break;
38627 ripley 483 
    case RAWSXP:
60241 ripley 484 
	for (i = 0; i < XLENGTH(x); i++)
29902 ripley 485 
	    RAW(data->ans_ptr)[data->ans_length++] = RAW(x)[i];
486 
	break;
38627 ripley 487 
    default:
45446 ripley 488 
	errorcall(call, _("type '%s' is unimplemented in '%s'"),
85146 luke 489 
		  R_typeToChar(x), "RawAnswer");
29902 ripley 490 
    }
491 
}
492 
 
1869 ihaka 493 
static SEXP NewBase(SEXP base, SEXP tag)
494 
{
495 
    SEXP ans;
41495 rgentlem 496 
    char *cbuf;
1869 ihaka 497 
    base = EnsureString(base);
498 
    tag = EnsureString(tag);
40705 ripley 499 
    if (*CHAR(base) && *CHAR(tag)) { /* test of length */
63181 ripley 500 
	const void *vmax = vmaxget();
53353 ripley 501 
	const char *sb = translateCharUTF8(base), *st = translateCharUTF8(tag);
83458 ripley 502 
	size_t sz = strlen(st) + strlen(sb) + 1;
503 
	cbuf = R_AllocStringBuffer(sz, &cbuff);
504 
	snprintf(cbuf, sz + 1, "%s.%s", sb, st);
53352 ripley 505 
	/* This isn't strictly correct as we do not know that all the
506 
	   components of the name were correctly translated. */
53353 ripley 507 
	ans = mkCharCE(cbuf, CE_UTF8);
63181 ripley 508 
	vmaxset(vmax);
1820 ihaka 509 
    }
1869 ihaka 510 
    else if (*CHAR(tag)) {
511 
	ans = tag;
1820 ihaka 512 
    }
1869 ihaka 513 
    else if (*CHAR(base)) {
514 
	ans = base;
1820 ihaka 515 
    }
1869 ihaka 516 
    else ans = R_BlankString;
1820 ihaka 517 
    return ans;
2 r 518 
}
519 
 
72950 maechler 520 
static SEXP NewName(SEXP base, SEXP tag, R_xlen_t seqno, int count)
1667 pd 521 
{
2810 maechler 522 
/* Construct a new Name/Tag, using
523 
 *	base.tag
72928 maechler 524 
 *	base
2810 maechler 525 
 *	base<seqno>	or
526 
 *	tag
527 
 *
53352 ripley 528 
 */
1869 ihaka 529 
    SEXP ans;
530 
    base = EnsureString(base);
531 
    tag = EnsureString(tag);
72950 maechler 532 
    if (*CHAR(base)) {
533 
	if (*CHAR(tag)) {
534 
	    const void *vmax = vmaxget();
535 
	    const char
536 
		*sb = translateCharUTF8(base),
537 
		*st = translateCharUTF8(tag);
83458 ripley 538 
	    size_t sz = strlen(sb) + strlen(st) + 1;
539 
	    char *cbuf = R_AllocStringBuffer(sz, &cbuff);
540 
	    snprintf(cbuf, sz + 1, "%s.%s", sb, st);
72950 maechler 541 
	    ans = mkCharCE(cbuf, CE_UTF8);
542 
	    vmaxset(vmax);
543 
	}
544 
	else if (count == 1)
545 
	    ans = base;
546 
	else {
547 
	    const void *vmax = vmaxget();
548 
	    const char *sb = translateCharUTF8(base);
549 
	    char *cbuf;
83458 ripley 550 
	    size_t sz = strlen(sb) + (size_t) IndexWidth(seqno) + 1;
551 
	    cbuf = R_AllocStringBuffer(sz, &cbuff);
72950 maechler 552 
#ifdef LONG_VECTOR_SUPPORT
553 
	    if (seqno > INT_MAX)
83458 ripley 554 
		snprintf(cbuf, sz + 1, "%s%.0f", sb, (double) seqno);
72950 maechler 555 
	    else
556 
#endif
83458 ripley 557 
		snprintf(cbuf, sz + 1, "%s%d", sb, (int) seqno);
72950 maechler 558 
	    ans = mkCharCE(cbuf, CE_UTF8);
559 
	    vmaxset(vmax);
560 
	}
1820 ihaka 561 
    }
1869 ihaka 562 
    else if (*CHAR(tag)) {
72787 kalibera 563 
	ans = tag;
72950 maechler 564 
    } else
565 
	ans = R_BlankString;
1869 ihaka 566 
    return ans;
1667 pd 567 
}
568 
 
38957 ripley 569 
/* also used in coerce.c */
83446 ripley 570 
attribute_hidden SEXP ItemName(SEXP names, R_xlen_t i)
2 r 571 
{
22270 ripley 572 
  /* return  names[i]  if it is a character (>= 1 char), or NULL otherwise */
1869 ihaka 573 
    if (names != R_NilValue &&
10172 luke 574 
	STRING_ELT(names, i) != R_NilValue &&
40705 ripley 575 
	CHAR(STRING_ELT(names, i))[0] != '\0') /* length test */
10172 luke 576 
	return STRING_ELT(names, i);
1820 ihaka 577 
    else
1869 ihaka 578 
	return R_NilValue;
2 r 579 
}
580 
 
2810 maechler 581 
/* NewExtractNames(v, base, tag, recurse):  For c() and	 unlist().
582 
 * On entry, "base" is the naming component we have acquired by
583 
 * recursing down from above.
584 
 *	If we have a list and we are recursing, we append a new tag component
585 
 * to the base tag (either by using the list tags, or their offsets),
586 
 * and then we do the recursion.
587 
 *	If we have a vector, we just create the tags for each element. */
1864 ihaka 588 
 
13997 duncan 589 
struct NameData {
590 
 int count;
72950 maechler 591 
 R_xlen_t seqno;
592 
 // int firstpos;
20809 ripley 593 
};
1869 ihaka 594 
 
13997 duncan 595 
 
72928 maechler 596 
// count names in (branch) v, recursively if(recurse) :
597 
static void namesCount(SEXP v, int recurse, struct NameData *nameData)
598 
{
599 
    R_xlen_t i, n = xlength(v);
600 
    SEXP names = PROTECT(getAttrib(v, R_NamesSymbol)), namei;
601 
 
602 
    /* The  "<= 1"  in every for() loop, i.e., for all "vector" cases,
603 
       makes this much faster for large vector 'v'
604 
       _and_ prevents ("almost surely") overflow of nameData->count.
605 
       -->  PR#17284 and PR#17292, with thanks to Suharto Anggono.
606 
    */
607 
    switch(TYPEOF(v)) {
608 
    case NILSXP:
609 
	break;
610 
    case LISTSXP:
611 
	if (recurse) {
612 
	    for (i = 0; i < n && nameData->count <= 1; i++) {
613 
		PROTECT(namei = ItemName(names, i));
614 
		if (namei == R_NilValue)
615 
		    namesCount(CAR(v), recurse, nameData);
616 
		v = CDR(v);
617 
		UNPROTECT(1); /*namei*/
618 
	    }
619 
	    break;
620 
	} /* else fall through */
621 
    case VECSXP:
622 
    case EXPRSXP:
623 
	if (recurse) {
624 
	    for (i = 0; i < n && nameData->count <= 1; i++) {
625 
		namei = ItemName(names, i);
626 
		if (namei == R_NilValue)
627 
		    namesCount(VECTOR_ELT(v, i), recurse, nameData);
628 
	    }
629 
	    break;
630 
	} /* else fall through */
631 
    case LGLSXP:
632 
    case INTSXP:
633 
    case REALSXP:
634 
    case CPLXSXP:
635 
    case STRSXP:
636 
    case RAWSXP:
637 
	for (i = 0; i < n && nameData->count <= 1; i++)
638 
	    nameData->count++;
639 
	break;
640 
    default:
641 
	nameData->count++;
642 
    }
643 
    UNPROTECT(1); /*names*/
644 
}
645 
 
20809 ripley 646 
static void NewExtractNames(SEXP v, SEXP base, SEXP tag, int recurse,
21364 maechler 647 
			     struct BindData *data, struct NameData *nameData)
1864 ihaka 648 
{
1869 ihaka 649 
    SEXP names, namei;
60241 ripley 650 
    R_xlen_t i, n;
72950 maechler 651 
    int savecount=0;
652 
    R_xlen_t saveseqno;
1869 ihaka 653 
 
72928 maechler 654 
    /* If we have a new tag, we reset the index
655 
     * sequence and create the new basename string : */
1869 ihaka 656 
    if (tag != R_NilValue) {
4562 pd 657 
	PROTECT(base = NewBase(base, tag));
13997 duncan 658 
	saveseqno = nameData->seqno;
659 
	savecount = nameData->count;
660 
	nameData->count = 0;
72928 maechler 661 
	namesCount(v, recurse, nameData);
13997 duncan 662 
	nameData->seqno = 0;
1864 ihaka 663 
    }
1869 ihaka 664 
    else saveseqno = 0;
1864 ihaka 665 
 
60241 ripley 666 
    n = xlength(v);
17402 tlumley 667 
    PROTECT(names = getAttrib(v, R_NamesSymbol));
1869 ihaka 668 
 
1864 ihaka 669 
    switch(TYPEOF(v)) {
670 
    case NILSXP:
671 
	break;
672 
    case LISTSXP:
673 
	for (i = 0; i < n; i++) {
17402 tlumley 674 
	    PROTECT(namei = ItemName(names, i));
1869 ihaka 675 
	    if (recurse) {
13997 duncan 676 
		NewExtractNames(CAR(v), base, namei, recurse, data, nameData);
1869 ihaka 677 
	    }
678 
	    else {
72928 maechler 679 
		namei = NewName(base, namei, ++(nameData->seqno), nameData->count);
13997 duncan 680 
		SET_STRING_ELT(data->ans_names, (data->ans_nnames)++, namei);
1869 ihaka 681 
	    }
1864 ihaka 682 
	    v = CDR(v);
17402 tlumley 683 
	    UNPROTECT(1); /*namei*/
1864 ihaka 684 
	}
685 
	break;
686 
    case VECSXP:
687 
    case EXPRSXP:
688 
	for (i = 0; i < n; i++) {
1869 ihaka 689 
	    namei = ItemName(names, i);
690 
	    if (recurse) {
13997 duncan 691 
		NewExtractNames(VECTOR_ELT(v, i), base, namei, recurse, data, nameData);
1869 ihaka 692 
	    }
693 
	    else {
72928 maechler 694 
		namei = NewName(base, namei, ++(nameData->seqno), nameData->count);
13997 duncan 695 
		SET_STRING_ELT(data->ans_names, (data->ans_nnames)++, namei);
1869 ihaka 696 
	    }
1864 ihaka 697 
	}
698 
	break;
699 
    case LGLSXP:
700 
    case INTSXP:
701 
    case REALSXP:
702 
    case CPLXSXP:
703 
    case STRSXP:
29902 ripley 704 
    case RAWSXP:
1864 ihaka 705 
	for (i = 0; i < n; i++) {
1869 ihaka 706 
	    namei = ItemName(names, i);
72928 maechler 707 
	    namei = NewName(base, namei, ++(nameData->seqno), nameData->count);
13997 duncan 708 
	    SET_STRING_ELT(data->ans_names, (data->ans_nnames)++, namei);
1864 ihaka 709 
	}
710 
	break;
711 
    default:
72928 maechler 712 
	namei = NewName(base, R_NilValue, ++(nameData->seqno), nameData->count);
19229 pd 713 
	SET_STRING_ELT(data->ans_names, (data->ans_nnames)++, namei);
1864 ihaka 714 
    }
1869 ihaka 715 
    if (tag != R_NilValue) {
13997 duncan 716 
	nameData->count = savecount;
4562 pd 717 
	UNPROTECT(1);
1869 ihaka 718 
    }
17402 tlumley 719 
    UNPROTECT(1); /*names*/
13997 duncan 720 
    nameData->seqno = nameData->seqno + saveseqno;
1864 ihaka 721 
}
722 
 
1889 ihaka 723 
/* Code to extract the optional arguments to c().  We do it this */
23669 hornik 724 
/* way, rather than having an interpreted front-end do the job, */
1889 ihaka 725 
/* because we want to avoid duplication at the top level. */
726 
/* FIXME : is there another possibility? */
87863 ripley 727 
static SEXP c_Extract_opt(SEXP ans, bool *recurse, bool *usenames,
71322 maechler 728 
			  SEXP call)
2 r 729 
{
10767 luke 730 
    SEXP a, n, last = NULL, next = NULL;
24632 hornik 731 
    int v, n_recurse = 0, n_usenames = 0;
10767 luke 732 
 
733 
    for (a = ans; a != R_NilValue; a = next) {
734 
	n = TAG(a);
735 
	next = CDR(a);
10765 luke 736 
	if (n != R_NilValue && pmatch(R_RecursiveSymbol, n, 1)) {
24632 hornik 737 
	    if (n_recurse++ == 1)
41712 ripley 738 
		errorcall(call, _("repeated formal argument 'recursive'"));
10767 luke 739 
	    if ((v = asLogical(CAR(a))) != NA_INTEGER) {
87863 ripley 740 
		*recurse = (bool) v;
1820 ihaka 741 
	    }
10767 luke 742 
	    if (last == NULL)
24845 hornik 743 
		ans = next;
10767 luke 744 
	    else
21364 maechler 745 
		SETCDR(last, next);
2 r 746 
	}
24632 hornik 747 
	else if (n != R_NilValue && pmatch(R_UseNamesSymbol, n, 1)) {
748 
	    if (n_usenames++ == 1)
41712 ripley 749 
		errorcall(call, _("repeated formal argument 'use.names'"));
10767 luke 750 
	    if ((v = asLogical(CAR(a))) != NA_INTEGER) {
87863 ripley 751 
		*usenames = (bool) v;
1820 ihaka 752 
	    }
10767 luke 753 
	    if (last == NULL)
24845 hornik 754 
		ans = next;
10767 luke 755 
	    else
21364 maechler 756 
		SETCDR(last, next);
1820 ihaka 757 
	}
10767 luke 758 
	else last = a;
1820 ihaka 759 
    }
10767 luke 760 
    return ans;
2 r 761 
}
762 
 
763 
 
24845 hornik 764 
/* The change to lists based on dotted pairs has meant that it was
765 
   necessary to separate the internal code for "c" and "unlist".
766 
   Although the functions are quite similar, they operate on very
767 
   different data structures.
768 
*/
1820 ihaka 769 
 
24845 hornik 770 
/* The major difference between the two functions is that the value of
771 
   the "recursive" argument is FALSE by default for "c" and TRUE for
772 
   "unlist".  In addition, "c" takes ... while "unlist" takes a single
773 
   argument.
774 
*/
1820 ihaka 775 
 
51245 ripley 776 
/* This is a primitive SPECIALSXP */
83446 ripley 777 
attribute_hidden SEXP do_c(SEXP call, SEXP op, SEXP args, SEXP env)
2 r 778 
{
10773 luke 779 
    SEXP ans;
2 r 780 
 
1820 ihaka 781 
    checkArity(op, args);
2 r 782 
 
79095 maechler 783 
    /* Remove any NULL elements before dispatch so
784 
       they never influence the method implementation. */
79130 maechler 785 
    args = R_listCompact(args, /* keep_first */ TRUE);
79095 maechler 786 
 
1820 ihaka 787 
    /* Attempt method dispatch. */
788 
 
77888 hornik 789 
    /* DispatchOrEval internal generic: c */
71322 maechler 790 
    if (DispatchAnyOrEval(call, op, "c", args, env, &ans, 1, 1))
791 
	//      ^^^ "Any" => all args are eval()ed and checked => correct multi-arg dispatch
1820 ihaka 792 
	return(ans);
68572 luke 793 
    PROTECT(ans);
794 
    SEXP res = do_c_dflt(call, op, ans, env);
795 
    UNPROTECT(1);
796 
    return res;
10773 luke 797 
}
798 
 
83446 ripley 799 
attribute_hidden SEXP do_c_dflt(SEXP call, SEXP op, SEXP args, SEXP env)
10773 luke 800 
{
1820 ihaka 801 
    /* Method dispatch has failed; run the default code. */
802 
    /* By default we do not recurse, but this can be over-ridden */
803 
    /* by an optional "recursive" argument. */
2 r 804 
 
87863 ripley 805 
    bool
806 
	usenames = true,
807 
	recurse = false;
19045 ripley 808 
    /* this was only done for length(args) > 1 prior to 1.5.0,
809 
       _but_ `recursive' might be the only argument */
71322 maechler 810 
    PROTECT(args = c_Extract_opt(args, &recurse, &usenames, call));
2 r 811 
 
1820 ihaka 812 
    /* Determine the type of the returned value. */
813 
    /* The strategy here is appropriate because the */
814 
    /* object being operated on is a pair based list. */
2 r 815 
 
71322 maechler 816 
    struct BindData data;
817 
/*    data.deparse_level = 1;  Initialize this early. */
13997 duncan 818 
    data.ans_flags  = 0;
819 
    data.ans_length = 0;
820 
    data.ans_nnames = 0;
2 r 821 
 
72928 maechler 822 
    SEXP t, ans;
1839 ihaka 823 
    for (t = args; t != R_NilValue; t = CDR(t)) {
13997 duncan 824 
	if (usenames && !data.ans_nnames) {
825 
	    if (!isNull(TAG(t))) data.ans_nnames = 1;
826 
	    else data.ans_nnames = HasNames(CAR(t));
1820 ihaka 827 
	}
55747 urbaneks 828 
	AnswerType(CAR(t), recurse, usenames, &data, call);
1820 ihaka 829 
    }
2 r 830 
 
1820 ihaka 831 
    /* If a non-vector argument was encountered (perhaps a list if */
2417 maechler 832 
    /* recursive is FALSE) then we must return a list.	Otherwise, */
1820 ihaka 833 
    /* we use the natural coercion for vector types. */
834 
 
71322 maechler 835 
    int mode = NILSXP;
66468 maechler 836 
    if      (data.ans_flags & 512) mode = EXPRSXP;
29902 ripley 837 
    else if (data.ans_flags & 256) mode = VECSXP;
838 
    else if (data.ans_flags & 128) mode = STRSXP;
839 
    else if (data.ans_flags &  64) mode = CPLXSXP;
840 
    else if (data.ans_flags &  32) mode = REALSXP;
841 
    else if (data.ans_flags &  16) mode = INTSXP;
842 
    else if (data.ans_flags &	2) mode = LGLSXP;
843 
    else if (data.ans_flags &	1) mode = RAWSXP;
1820 ihaka 844 
 
845 
    /* Allocate the return value and set up to pass through */
846 
    /* the arguments filling in values of the returned object. */
847 
 
72928 maechler 848 
    PROTECT(ans = allocVector(mode, data.ans_length));
13997 duncan 849 
    data.ans_ptr = ans;
850 
    data.ans_length = 0;
1820 ihaka 851 
    t = args;
852 
 
1839 ihaka 853 
    if (mode == VECSXP || mode == EXPRSXP) {
854 
	if (!recurse) {
1881 ihaka 855 
	    while (args != R_NilValue) {
41712 ripley 856 
		ListAnswer(CAR(args), 0, &data, call);
1820 ihaka 857 
		args = CDR(args);
858 
	    }
2 r 859 
	}
41712 ripley 860 
	else ListAnswer(args, recurse, &data, call);
59052 ripley 861 
	data.ans_length = xlength(ans);
1820 ihaka 862 
    }
1839 ihaka 863 
    else if (mode == STRSXP)
41712 ripley 864 
	StringAnswer(args, &data, call);
1839 ihaka 865 
    else if (mode == CPLXSXP)
41712 ripley 866 
	ComplexAnswer(args, &data, call);
1839 ihaka 867 
    else if (mode == REALSXP)
41712 ripley 868 
	RealAnswer(args, &data, call);
29902 ripley 869 
    else if (mode == RAWSXP)
41712 ripley 870 
	RawAnswer(args, &data, call);
38627 ripley 871 
    else if (mode == LGLSXP)
41712 ripley 872 
	LogicalAnswer(args, &data, call);
38627 ripley 873 
    else /* integer */
41712 ripley 874 
	IntegerAnswer(args, &data, call);
1820 ihaka 875 
    args = t;
2 r 876 
 
1820 ihaka 877 
    /* Build and attach the names attribute for the returned object. */
878 
 
13997 duncan 879 
    if (data.ans_nnames && data.ans_length > 0) {
880 
	PROTECT(data.ans_names = allocVector(STRSXP, data.ans_length));
881 
	data.ans_nnames = 0;
47460 ripley 882 
	while (args != R_NilValue) {
71322 maechler 883 
	    struct NameData nameData;
13997 duncan 884 
	    nameData.seqno = 0;
885 
	    nameData.count = 0;
47460 ripley 886 
	    NewExtractNames(CAR(args), R_NilValue, TAG(args), recurse, &data, &nameData);
887 
	    args = CDR(args);
1869 ihaka 888 
	}
13997 duncan 889 
	setAttrib(ans, R_NamesSymbol, data.ans_names);
1869 ihaka 890 
	UNPROTECT(1);
1820 ihaka 891 
    }
892 
    UNPROTECT(2);
41899 ripley 893 
    R_FreeStringBufferL(&cbuff);
1820 ihaka 894 
    return ans;
4041 maechler 895 
} /* do_c */
2 r 896 
 
897 
 
83446 ripley 898 
attribute_hidden SEXP do_unlist(SEXP call, SEXP op, SEXP args, SEXP env)
1820 ihaka 899 
{
900 
    SEXP ans, t;
60241 ripley 901 
    R_xlen_t i, n = 0;
13997 duncan 902 
    struct BindData data;
35504 maechler 903 
 
904 
/*    data.deparse_level = 1; */
1820 ihaka 905 
    checkArity(op, args);
906 
 
907 
    /* Attempt method dispatch. */
908 
 
77888 hornik 909 
    /* DispatchOrEval internal generic: unlist */
40236 ripley 910 
    if (DispatchOrEval(call, op, "unlist", args, env, &ans, 0, 1))
1820 ihaka 911 
	return(ans);
912 
 
913 
    /* Method dispatch has failed; run the default code. */
914 
    /* By default we recurse, but this can be over-ridden */
915 
    /* by an optional "recursive" argument. */
916 
 
1864 ihaka 917 
    PROTECT(args = CAR(ans));
87863 ripley 918 
    bool recurse = asBool2(CADR(ans), call);
919 
    bool usenames = asBool2(CADDR(ans), call);
920 
    bool lenient = true; // was (implicitly!) FALSE  up to R 3.0.1
2417 maechler 921 
 
1820 ihaka 922 
    /* Determine the type of the returned value. */
923 
    /* The strategy here is appropriate because the */
924 
    /* object being operated on is a generic vector. */
925 
 
13997 duncan 926 
    data.ans_flags  = 0;
927 
    data.ans_length = 0;
928 
    data.ans_nnames = 0;
1820 ihaka 929 
 
1839 ihaka 930 
    if (isNewList(args)) {
60241 ripley 931 
	n = xlength(args);
1820 ihaka 932 
	if (usenames && getAttrib(args, R_NamesSymbol) != R_NilValue)
13997 duncan 933 
	    data.ans_nnames = 1;
1839 ihaka 934 
	for (i = 0; i < n; i++) {
13997 duncan 935 
	    if (usenames && !data.ans_nnames)
936 
		data.ans_nnames = HasNames(VECTOR_ELT(args, i));
55747 urbaneks 937 
	    AnswerType(VECTOR_ELT(args, i), recurse, usenames, &data, call);
2 r 938 
	}
1820 ihaka 939 
    }
1869 ihaka 940 
    else if (isList(args)) {
1839 ihaka 941 
	for (t = args; t != R_NilValue; t = CDR(t)) {
13997 duncan 942 
	    if (usenames && !data.ans_nnames) {
943 
		if (!isNull(TAG(t))) data.ans_nnames = 1;
944 
		else data.ans_nnames = HasNames(CAR(t));
1820 ihaka 945 
	    }
55747 urbaneks 946 
	    AnswerType(CAR(t), recurse, usenames, &data, call);
1820 ihaka 947 
	}
948 
    }
949 
    else {
950 
	UNPROTECT(1);
62995 maechler 951 
	if (lenient || isVector(args)) return args;
41686 ripley 952 
	else error(_("argument not a list"));
1820 ihaka 953 
    }
2 r 954 
 
1820 ihaka 955 
    /* If a non-vector argument was encountered (perhaps a list if */
72928 maechler 956 
    /* recursive is FALSE) then we must return a list.  Otherwise, */
957 
    /* we use the natural coercion for vector types. */
1820 ihaka 958 
 
71322 maechler 959 
    int mode = NILSXP;
35504 maechler 960 
    if      (data.ans_flags & 512) mode = EXPRSXP;
29902 ripley 961 
    else if (data.ans_flags & 256) mode = VECSXP;
962 
    else if (data.ans_flags & 128) mode = STRSXP;
963 
    else if (data.ans_flags &  64) mode = CPLXSXP;
964 
    else if (data.ans_flags &  32) mode = REALSXP;
965 
    else if (data.ans_flags &  16) mode = INTSXP;
966 
    else if (data.ans_flags &	2) mode = LGLSXP;
967 
    else if (data.ans_flags &	1) mode = RAWSXP;
1820 ihaka 968 
 
969 
    /* Allocate the return value and set up to pass through */
970 
    /* the arguments filling in values of the returned object. */
971 
 
13997 duncan 972 
    PROTECT(ans = allocVector(mode, data.ans_length));
973 
    data.ans_ptr = ans;
974 
    data.ans_length = 0;
1820 ihaka 975 
    t = args;
976 
 
28798 tlumley 977 
    if (mode == VECSXP || mode == EXPRSXP) {
1839 ihaka 978 
	if (!recurse) {
79357 maechler 979 
	    if (TYPEOF(args) == VECSXP)
980 
		for (i = 0; i < n; i++)
981 
		    ListAnswer(VECTOR_ELT(args, i), 0, &data, call);
982 
	    else if (TYPEOF(args) == LISTSXP)
983 
		for ( ; args != R_NilValue; args = CDR(args))
984 
		    ListAnswer(CAR(args), 0, &data, call);
2 r 985 
	}
41712 ripley 986 
	else ListAnswer(args, recurse, &data, call);
59052 ripley 987 
	data.ans_length = xlength(ans);
1820 ihaka 988 
    }
1839 ihaka 989 
    else if (mode == STRSXP)
41712 ripley 990 
	StringAnswer(args, &data, call);
1839 ihaka 991 
    else if (mode == CPLXSXP)
41712 ripley 992 
	ComplexAnswer(args, &data, call);
1839 ihaka 993 
    else if (mode == REALSXP)
41712 ripley 994 
	RealAnswer(args, &data, call);
29902 ripley 995 
    else if (mode == RAWSXP)
41712 ripley 996 
	RawAnswer(args, &data, call);
38627 ripley 997 
    else if (mode == LGLSXP)
41712 ripley 998 
	LogicalAnswer(args, &data, call);
38627 ripley 999 
    else /* integer */
41712 ripley 1000 
	IntegerAnswer(args, &data, call);
1820 ihaka 1001 
    args = t;
1002 
 
1003 
    /* Build and attach the names attribute for the returned object. */
1004 
 
13997 duncan 1005 
    if (data.ans_nnames && data.ans_length > 0) {
71322 maechler 1006 
	struct NameData nameData;
13997 duncan 1007 
	PROTECT(data.ans_names = allocVector(STRSXP, data.ans_length));
1869 ihaka 1008 
	if (!recurse) {
1881 ihaka 1009 
	    if (TYPEOF(args) == VECSXP) {
1869 ihaka 1010 
		SEXP names = getAttrib(args, R_NamesSymbol);
13997 duncan 1011 
		data.ans_nnames = 0;
1012 
		nameData.seqno = 0;
1013 
		nameData.count = 0;
1869 ihaka 1014 
		for (i = 0; i < n; i++) {
10172 luke 1015 
		    NewExtractNames(VECTOR_ELT(args, i), R_NilValue,
13997 duncan 1016 
				    ItemName(names, i), recurse, &data, &nameData);
1869 ihaka 1017 
		}
1018 
	    }
1881 ihaka 1019 
	    else if (TYPEOF(args) == LISTSXP) {
13997 duncan 1020 
		data.ans_nnames = 0;
1021 
		nameData.seqno = 0;
1022 
		nameData.count = 0;
1881 ihaka 1023 
		while (args != R_NilValue) {
1869 ihaka 1024 
		    NewExtractNames(CAR(args), R_NilValue,
13997 duncan 1025 
				    TAG(args), recurse, &data, &nameData);
1869 ihaka 1026 
		    args = CDR(args);
1027 
		}
1028 
	    }
1029 
	}
1030 
	else {
13997 duncan 1031 
	    data.ans_nnames = 0;
1032 
	    nameData.seqno = 0;
1033 
	    nameData.count = 0;
1034 
	    NewExtractNames(args, R_NilValue, R_NilValue, recurse, &data, &nameData);
1869 ihaka 1035 
	}
13997 duncan 1036 
	setAttrib(ans, R_NamesSymbol, data.ans_names);
1820 ihaka 1037 
	UNPROTECT(1);
1038 
    }
1039 
    UNPROTECT(2);
41899 ripley 1040 
    R_FreeStringBufferL(&cbuff);
1820 ihaka 1041 
    return ans;
4041 maechler 1042 
} /* do_unlist */
2 r 1043 
 
1820 ihaka 1044 
 
35504 maechler 1045 
/* cbind(deparse.level, ...) and rbind(deparse.level, ...) : */
51245 ripley 1046 
/* This is a special .Internal */
83446 ripley 1047 
attribute_hidden SEXP do_bind(SEXP call, SEXP op, SEXP args, SEXP env)
2 r 1048 
{
85314 maechler 1049 
    // missing(deparse.level) :
87863 ripley 1050 
    bool missingDL = (isSymbol(CAR(args)) && R_missing(CAR(args), env));
35504 maechler 1051 
    /* since R 2.2.0: first argument "deparse.level" */
85314 maechler 1052 
    int deparse_level = asInteger(eval(CAR(args), env));
87863 ripley 1053 
    bool tryS4 = deparse_level >= 0;
67852 maechler 1054 
    /* NB: negative deparse_level should otherwise be equivalent to deparse_level == 0,
1055 
     * --  as cbind(), rbind() below only check for '== 1' and '== 2'
1056 
     * {FIXME: methods should do same} */
35504 maechler 1057 
 
5439 ihaka 1058 
    /* Lazy evaluation and method dispatch based on argument types are
1059 
     * fundamentally incompatible notions.  The results here are
1060 
     * ghastly.
5434 ihaka 1061 
     *
5439 ihaka 1062 
     * We build promises to evaluate the arguments and then force the
67852 maechler 1063 
     * promises so that if we dispatch to a closure below, the closure
5439 ihaka 1064 
     * is still in a position to use "substitute" to get the actual
1065 
     * expressions which generated the argument (for naming purposes).
5434 ihaka 1066 
     *
6194 maechler 1067 
     * The dispatch rule here is as follows:
5439 ihaka 1068 
     *
1069 
     * 1) For each argument we get the list of possible class
21364 maechler 1070 
     *	  memberships from the class attribute.
5439 ihaka 1071 
     *
1072 
     * 2) We inspect each class in turn to see if there is an
46140 maechler 1073 
     *	  applicable method.
5439 ihaka 1074 
     *
77317 hornik 1075 
     * 3) If we find a method, we use it.  Otherwise, if there was an S4
1076 
     *    object among the arguments, we try S4 dispatch; otherwise, we
1077 
     *    use the default code.
1078 
     *
1079 
     * In versions of R up to 3.6.x, we used the following rule instead:
1080 
     *
5439 ihaka 1081 
     * 3) If we find an applicable method we make sure that it is
21364 maechler 1082 
     *	  identical to any method determined for prior arguments.
1083 
     *	  If it is identical, we proceed, otherwise we immediately
1084 
     *	  drop through to the default code.
5434 ihaka 1085 
     */
1086 
 
5439 ihaka 1087 
    PROTECT(args = promiseArgs(args, env));
35504 maechler 1088 
 
67852 maechler 1089 
    const char *generic = ((PRIMVAL(op) == 1) ? "cbind" : "rbind");
85314 maechler 1090 
    SEXP method = R_NilValue, a;
87863 ripley 1091 
    bool anyS4 = false;
85314 maechler 1092 
    char buf[512];
1093 
 
77317 hornik 1094 
    for (a = CDR(args); a != R_NilValue && method == R_NilValue; a = CDR(a)) {
85314 maechler 1095 
	SEXP obj = PROTECT(eval(CAR(a), env));
87863 ripley 1096 
	if (tryS4 && !anyS4 && isS4(obj)) anyS4 = true;
77317 hornik 1097 
	if (isObject(obj)) {
67852 maechler 1098 
	    SEXP classlist = PROTECT(R_data_class2(obj));
1099 
	    for (int i = 0; i < length(classlist); i++) {
1100 
		const char *s = translateChar(STRING_ELT(classlist, i));
40705 ripley 1101 
		if(strlen(generic) + strlen(s) + 2 > 512)
38956 ripley 1102 
		    error(_("class name too long in '%s'"), generic);
83458 ripley 1103 
		snprintf(buf, 512, "%s.%s", generic, s);
67699 lawrence 1104 
		SEXP classmethod = R_LookupMethod(install(buf), env, env,
68923 ripley 1105 
						  R_BaseNamespace);
38956 ripley 1106 
		if (classmethod != R_UnboundValue) {
77317 hornik 1107 
		    method = classmethod;
1108 
		    break;
5439 ihaka 1109 
		}
1110 
	    }
68923 ripley 1111 
	    UNPROTECT(1);
5439 ihaka 1112 
	}
22881 luke 1113 
	UNPROTECT(1);
1820 ihaka 1114 
    }
67852 maechler 1115 
 
77317 hornik 1116 
    tryS4 = anyS4 && (method == R_NilValue);
67852 maechler 1117 
    if (tryS4) {
85314 maechler 1118 
	/* use methods:::cbind / rbind */
68923 ripley 1119 
	method = findFun(install(generic), R_MethodsNamespace);
85314 maechler 1120 
    }
67852 maechler 1121 
    if (method != R_NilValue) { // found an S3 or S4 method
86699 kalibera 1122 
	PROTECT(method);
85314 maechler 1123 
	if (missingDL)
1124 
	    args = CDR(args); /* discard 'deparse.level' */
1125 
	else
1126 
	    SET_TAG(args, install("deparse.level")); /* tag 'deparse.level' */
1127 
	SEXP ans = applyClosure(call, method, args, env, R_NilValue, TRUE);
5439 ihaka 1128 
	UNPROTECT(2);
67699 lawrence 1129 
	return ans;
85314 maechler 1130 
    } else
1131 
	args = CDR(args); /* discard 'deparse.level' */
67852 maechler 1132 
 
13997 duncan 1133 
    /* Dispatch based on class membership has failed. */
5439 ihaka 1134 
    /* The default code for rbind/cbind.default follows */
1135 
    /* First, extract the evaluated arguments. */
85314 maechler 1136 
    SEXP rho = env;
1137 
    struct BindData data;
13997 duncan 1138 
    data.ans_flags = 0;
1139 
    data.ans_length = 0;
1140 
    data.ans_nnames = 0;
85314 maechler 1141 
    for (SEXP t = args; t != R_NilValue; t = CDR(t))
55747 urbaneks 1142 
	AnswerType(PRVALUE(CAR(t)), 0, 0, &data, call);
1872 ihaka 1143 
 
21364 maechler 1144 
    /* zero-extent matrices shouldn't give NULL, but cbind(NULL) should: */
1145 
    if (!data.ans_flags && !data.ans_length) {
1146 
	UNPROTECT(1);
1147 
	return R_NilValue;
1148 
    }
1149 
 
85314 maechler 1150 
    int mode = NILSXP;
66468 maechler 1151 
    if      (data.ans_flags & 512) mode = EXPRSXP;
29902 ripley 1152 
    else if (data.ans_flags & 256) mode = VECSXP;
1153 
    else if (data.ans_flags & 128) mode = STRSXP;
1154 
    else if (data.ans_flags &  64) mode = CPLXSXP;
1155 
    else if (data.ans_flags &  32) mode = REALSXP;
1156 
    else if (data.ans_flags &  16) mode = INTSXP;
1157 
    else if (data.ans_flags &	2) mode = LGLSXP;
1158 
    else if (data.ans_flags &	1) mode = RAWSXP;
2 r 1159 
 
1820 ihaka 1160 
    switch(mode) {
1161 
    case NILSXP:
1162 
    case LGLSXP:
1163 
    case INTSXP:
1164 
    case REALSXP:
1165 
    case CPLXSXP:
1166 
    case STRSXP:
28870 ripley 1167 
    case VECSXP:
37192 ripley 1168 
    case RAWSXP:
45446 ripley 1169 
	break;
35504 maechler 1170 
	/* we don't handle expressions: we could, but coercion of a matrix
62995 maechler 1171 
	   to an expression is not ideal.
1172 
	   FIXME?  had  cbind(y ~ x, 1) work using lists, before */
1820 ihaka 1173 
    default:
62995 maechler 1174 
	error(_("cannot create a matrix from type '%s'"),
85463 luke 1175 
	      type2char(mode)); /* mode can only be EXPRSXP here */
1820 ihaka 1176 
    }
1016 maechler 1177 
 
2417 maechler 1178 
    if (PRIMVAL(op) == 1)
35504 maechler 1179 
	a = cbind(call, args, mode, rho, deparse_level);
1820 ihaka 1180 
    else
35504 maechler 1181 
	a = rbind(call, args, mode, rho, deparse_level);
5439 ihaka 1182 
    UNPROTECT(1);
1820 ihaka 1183 
    return a;
2 r 1184 
}
1185 
 
1186 
 
1839 ihaka 1187 
static void SetRowNames(SEXP dimnames, SEXP x)
1188 
{
1189 
    if (TYPEOF(dimnames) == VECSXP)
10172 luke 1190 
	SET_VECTOR_ELT(dimnames, 0, x);
1839 ihaka 1191 
    else if (TYPEOF(dimnames) == LISTSXP)
10172 luke 1192 
	SETCAR(dimnames, x);
1839 ihaka 1193 
}
1194 
 
2417 maechler 1195 
static void SetColNames(SEXP dimnames, SEXP x)
1839 ihaka 1196 
{
1197 
    if (TYPEOF(dimnames) == VECSXP)
10172 luke 1198 
	SET_VECTOR_ELT(dimnames, 1, x);
1839 ihaka 1199 
    else if (TYPEOF(dimnames) == LISTSXP)
10172 luke 1200 
	SETCADR(dimnames, x);
1839 ihaka 1201 
}
1202 
 
23264 ripley 1203 
/*
1204 
 * Apparently i % 0 could occur here (PR#2541).  But it should not,
1205 
 * as zero-length vectors are ignored and
1206 
 * zero-length matrices must have zero columns,
1207 
 * unless the result has zero rows, hence is of length zero and no
1208 
 * copying will be done.
1209 
 */
35504 maechler 1210 
static SEXP cbind(SEXP call, SEXP args, SEXPTYPE mode, SEXP rho,
1211 
		  int deparse_level)
2 r 1212 
{
87863 ripley 1213 
    bool have_rnames = false, have_cnames = false, warned = false;
4041 maechler 1214 
    int nnames, mnames;
20809 ripley 1215 
    int rows, cols, mrows, lenmin = 0;
6483 pd 1216 
    SEXP dn, t, u, result, dims, expr;
2 r 1217 
 
4041 maechler 1218 
    nnames = 0;
1219 
    mnames = 0;
1820 ihaka 1220 
    rows = 0;
1221 
    cols = 0;
1222 
    mrows = -1;
2 r 1223 
 
20809 ripley 1224 
    /* check if we are in the zero-row case */
1225 
 
23264 ripley 1226 
    for (t = args; t != R_NilValue; t = CDR(t)) {
1227 
	u = PRVALUE(CAR(t));
1228 
	if((isMatrix(u) ? nrows(u) : length(u)) > 0) {
20809 ripley 1229 
	    lenmin = 1;
1230 
	    break;
1231 
	}
23264 ripley 1232 
    }
20809 ripley 1233 
 
1820 ihaka 1234 
    /* check conformability of matrix arguments */
2 r 1235 
 
60241 ripley 1236 
    int na = 0;
1237 
    for (t = args; t != R_NilValue; t = CDR(t), na++) {
6483 pd 1238 
	u = PRVALUE(CAR(t));
20809 ripley 1239 
	dims = getAttrib(u, R_DimSymbol);
1240 
	if (length(dims) == 2) {
1241 
	    if (mrows == -1)
1242 
		mrows = INTEGER(dims)[0];
1243 
	    else if (mrows != INTEGER(dims)[0])
41686 ripley 1244 
		error(_("number of rows of matrices must match (see arg %d)"),
60241 ripley 1245 
		      na + 1);
20809 ripley 1246 
	    cols += INTEGER(dims)[1];
2 r 1247 
	}
20809 ripley 1248 
	else if (length(u) >= lenmin) {
1249 
	    rows = imax2(rows, length(u));
1250 
	    cols += 1;
1251 
	}
1820 ihaka 1252 
    }
1253 
    if (mrows != -1) rows = mrows;
2 r 1254 
 
4041 maechler 1255 
    /* Check conformability of vector arguments. -- Look for dimnames. */
2 r 1256 
 
60241 ripley 1257 
    for (t = args, na = 0; t != R_NilValue; t = CDR(t), na++) {
6483 pd 1258 
	u = PRVALUE(CAR(t));
20809 ripley 1259 
	dims = getAttrib(u, R_DimSymbol);
1260 
	if (length(dims) == 2) {
1261 
	    dn = getAttrib(u, R_DimNamesSymbol);
1262 
	    if (length(dn) == 2) {
1263 
		if (VECTOR_ELT(dn, 1) != R_NilValue)
87863 ripley 1264 
		    have_cnames = true;
20809 ripley 1265 
		if (VECTOR_ELT(dn, 0) != R_NilValue)
1266 
		    mnames = mrows;
1820 ihaka 1267 
	    }
41996 ripley 1268 
	} else {
67809 ripley 1269 
	    int k = length(u);
41996 ripley 1270 
	    if (!warned && k > 0 && (k > rows || rows % k)) {
87863 ripley 1271 
		warned = true;
60241 ripley 1272 
		warning("number of rows of result is not a multiple of vector length (arg %d)", na + 1);
20809 ripley 1273 
	    }
68092 luke 1274 
	    PROTECT(dn = getAttrib(u, R_NamesSymbol));
20811 ripley 1275 
	    if (k >= lenmin && (TAG(t) != R_NilValue ||
51007 ripley 1276 
				(deparse_level == 2) ||
35504 maechler 1277 
				((deparse_level == 1) &&
1278 
				 isSymbol(substitute(CAR(t),R_NilValue)))))
87863 ripley 1279 
		have_cnames = true;
20809 ripley 1280 
	    nnames = imax2(nnames, length(dn));
68092 luke 1281 
	    UNPROTECT(1); /* dn */
20809 ripley 1282 
	}
1820 ihaka 1283 
    }
4041 maechler 1284 
    if (mnames || nnames == rows)
87863 ripley 1285 
	have_rnames = true;
2 r 1286 
 
1820 ihaka 1287 
    PROTECT(result = allocMatrix(mode, rows, cols));
60241 ripley 1288 
    R_xlen_t n = 0; // index, possibly of long vector
2 r 1289 
 
1820 ihaka 1290 
    if (mode == STRSXP) {
1291 
	for (t = args; t != R_NilValue; t = CDR(t)) {
6483 pd 1292 
	    u = PRVALUE(CAR(t));
23264 ripley 1293 
	    if (isMatrix(u) || length(u) >= lenmin) {
6483 pd 1294 
		u = coerceVector(u, STRSXP);
67809 ripley 1295 
		R_xlen_t k = XLENGTH(u);
1296 
		R_xlen_t idx = (!isMatrix(u)) ? rows : k;
68663 luke 1297 
		xcopyStringWithRecycle(result, u, n, idx, k);
1298 
		n += idx;
1820 ihaka 1299 
	    }
2 r 1300 
	}
1820 ihaka 1301 
    }
28870 ripley 1302 
    else if (mode == VECSXP) {
1303 
	for (t = args; t != R_NilValue; t = CDR(t)) {
1304 
	    u = PRVALUE(CAR(t));
63983 murdoch 1305 
	    int umatrix = isMatrix(u); /* might be lost in coercion to VECSXP */
1306 
	    if (umatrix || length(u) >= lenmin) {
38280 ripley 1307 
		/* we cannot assume here that coercion will work */
1308 
		switch(TYPEOF(u)) {
1309 
		case NILSXP:
1310 
		case LANGSXP:
1311 
		case RAWSXP:
1312 
		case LGLSXP:
1313 
		case INTSXP:
1314 
		case REALSXP:
1315 
		case CPLXSXP:
1316 
		case STRSXP:
1317 
		case VECSXP:
1318 
		case LISTSXP:
42014 ripley 1319 
		    PROTECT(u = coerceVector(u, mode));
67809 ripley 1320 
		    R_xlen_t k = XLENGTH(u);
47664 ripley 1321 
		    if (k > 0) {
67809 ripley 1322 
			R_xlen_t idx = (!umatrix) ? rows : k;
68663 luke 1323 
			R_xlen_t i, i1;
1324 
			MOD_ITERATE1(idx, k, i, i1, {
47664 ripley 1325 
			    SET_VECTOR_ELT(result, n++,
68923 ripley 1326 
				lazy_duplicate(VECTOR_ELT(u, i1)));
68663 luke 1327 
			});
47664 ripley 1328 
		    }
42014 ripley 1329 
		    UNPROTECT(1);
38280 ripley 1330 
		    break;
1331 
		default:
67809 ripley 1332 
		    for (int i = 0; i < rows; i++)
64973 luke 1333 
			SET_VECTOR_ELT(result, n++, lazy_duplicate(u));
38280 ripley 1334 
		}
28870 ripley 1335 
	    }
1336 
	}
1337 
    }
1839 ihaka 1338 
    else if (mode == CPLXSXP) {
1820 ihaka 1339 
	for (t = args; t != R_NilValue; t = CDR(t)) {
6483 pd 1340 
	    u = PRVALUE(CAR(t));
23264 ripley 1341 
	    if (isMatrix(u) || length(u) >= lenmin) {
6483 pd 1342 
		u = coerceVector(u, CPLXSXP);
67809 ripley 1343 
		R_xlen_t k = XLENGTH(u);
1344 
		R_xlen_t idx = (!isMatrix(u)) ? rows : k;
68663 luke 1345 
		xcopyComplexWithRecycle(COMPLEX(result), COMPLEX(u), n, idx, k);
1346 
		n += idx;
1820 ihaka 1347 
	    }
2 r 1348 
	}
1820 ihaka 1349 
    }
37192 ripley 1350 
    else if (mode == RAWSXP) {
1351 
	for (t = args; t != R_NilValue; t = CDR(t)) {
1352 
	    u = PRVALUE(CAR(t));
1353 
	    if (isMatrix(u) || length(u) >= lenmin) {
1354 
		u = coerceVector(u, RAWSXP);
67809 ripley 1355 
		R_xlen_t k = XLENGTH(u);
1356 
		R_xlen_t idx = (!isMatrix(u)) ? rows : k;
68663 luke 1357 
		xcopyRawWithRecycle(RAW(result), RAW(u), n, idx, k);
1358 
		n += idx;
37192 ripley 1359 
	    }
1360 
	}
1361 
    }
87389 ripley 1362 
    else { /* everything else, currently NILSXP, REALSXP, INTSXP, LGLSXP */
1820 ihaka 1363 
	for (t = args; t != R_NilValue; t = CDR(t)) {
71099 luke 1364 
	    u = PRVALUE(CAR(t)); /* type of u can be any of: RAW, LGL, INT, REAL, or NULL */
23264 ripley 1365 
	    if (isMatrix(u) || length(u) >= lenmin) {
71099 luke 1366 
		R_xlen_t k = xlength(u); /* use xlength since u can be NULL */
67809 ripley 1367 
		R_xlen_t idx = (!isMatrix(u)) ? rows : k;
87390 ripley 1368 
		if (idx > 0 && TYPEOF(u) <= INTSXP) {
1369 
		    /* NILSXP or INT or LGL
87392 ripley 1370 
		     * taking INTERER(NILSXP) should segfault, and
87390 ripley 1371 
		     * sometimes does.  But if cbind-ing a NULL, there
1372 
		     * are zero rows and u is not a matrix, so nothing to do. */
1820 ihaka 1373 
		    if (mode <= INTSXP) {
68663 luke 1374 
			xcopyIntegerWithRecycle(INTEGER(result), INTEGER(u),
1375 
						n, idx, k);
1376 
			n += idx;
1820 ihaka 1377 
		    }
1378 
		    else {
68663 luke 1379 
			R_xlen_t i, i1;
1380 
			MOD_ITERATE1(idx, k, i, i1, {
1381 
			    REAL(result)[n++] =
68923 ripley 1382 
				(INTEGER(u)[i1]) == NA_INTEGER ? NA_REAL : INTEGER(u)[i1];
68663 luke 1383 
			});
1820 ihaka 1384 
		    }
2 r 1385 
		}
57065 urbaneks 1386 
		else if (TYPEOF(u) == REALSXP) {
68663 luke 1387 
		    xcopyRealWithRecycle(REAL(result), REAL(u), n, idx, k);
1388 
		    n += idx;
62995 maechler 1389 
		}
87389 ripley 1390 
		else { /* u is a RAWSXP */
57065 urbaneks 1391 
		    /* FIXME: I'm not sure what the author intended when the sequence was
1392 
		       defined as raw < logical -- it is possible to represent logical as
1393 
		       raw losslessly but not vice versa. So due to the way this was
87389 ripley 1394 
		       defined the raw -> logical conversion is bound to be lossy ..
1395 
		       But it is not: logicals include NAs, raws do not.
1396 
*/
68663 luke 1397 
		    if (mode == LGLSXP) {
1398 
			R_xlen_t i, i1;
1399 
			MOD_ITERATE1(idx, k, i, i1, {
1400 
			    LOGICAL(result)[n++] = RAW(u)[i1] ? TRUE : FALSE;
1401 
			});
75360 luke 1402 
		    } else if (mode == INTSXP) {
68663 luke 1403 
			R_xlen_t i, i1;
1404 
			MOD_ITERATE1(idx, k, i, i1, {
1405 
			    INTEGER(result)[n++] = (unsigned char) RAW(u)[i1];
1406 
			});
75360 luke 1407 
		    } else if (mode == REALSXP) {
1408 
			R_xlen_t i, i1;
1409 
			MOD_ITERATE1(idx, k, i, i1, {
1410 
			    REAL(result)[n++] = (unsigned char) RAW(u)[i1];
1411 
			});
1412 
		    } else
1413 
			/* not sure this can be reached, but to be safe: */
85463 luke 1414 
                        /* `mode` is created in do_bind(), it can only
1415 
                         be one of: NILSXP, LGLSXP, INTSXP, REALSXP,
1416 
                         CPLXSXP, STRSXP, VECSXP, RAWSXP */
75360 luke 1417 
			error(_("cannot create a matrix of type '%s'"),
1418 
			      type2char(mode));
1820 ihaka 1419 
		}
1420 
	    }
2 r 1421 
	}
1820 ihaka 1422 
    }
4041 maechler 1423 
 
1839 ihaka 1424 
    /* Adjustment of dimnames attributes. */
35504 maechler 1425 
    if (have_cnames || have_rnames) {
6700 tlumley 1426 
	SEXP nam, tnam,v;
1839 ihaka 1427 
	PROTECT(dn = allocVector(VECSXP, 2));
1428 
	if (have_cnames)
10172 luke 1429 
	    nam = SET_VECTOR_ELT(dn, 1, allocVector(STRSXP, cols));
2458 hornik 1430 
	else
4041 maechler 1431 
	    nam = R_NilValue;	/* -Wall */
67809 ripley 1432 
	int j = 0;
1820 ihaka 1433 
	for (t = args; t != R_NilValue; t = CDR(t)) {
6483 pd 1434 
	    u = PRVALUE(CAR(t));
20809 ripley 1435 
	    if (isMatrix(u)) {
1436 
		v = getAttrib(u, R_DimNamesSymbol);
1839 ihaka 1437 
 
20809 ripley 1438 
		if (have_rnames &&
1439 
		    GetRowNames(dn) == R_NilValue &&
1440 
		    GetRowNames(v) != R_NilValue)
64973 luke 1441 
		    SetRowNames(dn, lazy_duplicate(GetRowNames(v)));
1839 ihaka 1442 
 
20809 ripley 1443 
		/* rbind() does this only  if(have_?names) .. : */
41996 ripley 1444 
		/* but if tnam is non-null, have_cnames = TRUE: see above */
1445 
		tnam = GetColNames(v);
20809 ripley 1446 
		if (tnam != R_NilValue) {
67809 ripley 1447 
		    for (int i = 0; i < length(tnam); i++)
20809 ripley 1448 
			SET_STRING_ELT(nam, j++, STRING_ELT(tnam, i));
2 r 1449 
		}
20809 ripley 1450 
		else if (have_cnames) {
67809 ripley 1451 
		    for (int i = 0; i < ncols(u); i++)
20809 ripley 1452 
			SET_STRING_ELT(nam, j++, R_BlankString);
1453 
		}
41996 ripley 1454 
	    } else if (length(u) >= lenmin) {
20809 ripley 1455 
		u = getAttrib(u, R_NamesSymbol);
1839 ihaka 1456 
 
20809 ripley 1457 
		if (have_rnames && GetRowNames(dn) == R_NilValue
1458 
		    && u != R_NilValue && length(u) == rows)
64973 luke 1459 
		    SetRowNames(dn, lazy_duplicate(u));
1839 ihaka 1460 
 
20809 ripley 1461 
		if (TAG(t) != R_NilValue)
1462 
		    SET_STRING_ELT(nam, j++, PRINTNAME(TAG(t)));
35524 maechler 1463 
		else {
1464 
		    expr = substitute(CAR(t), R_NilValue);
1465 
		    if (deparse_level == 1 && isSymbol(expr))
1466 
			SET_STRING_ELT(nam, j++, PRINTNAME(expr));
68092 luke 1467 
		    else if (deparse_level == 2) {
68923 ripley 1468 
			PROTECT(expr);
35524 maechler 1469 
			SET_STRING_ELT(nam, j++,
87904 ripley 1470 
				       STRING_ELT(deparse1line(expr, true), 0));
68092 luke 1471 
			UNPROTECT(1); /* expr */
1472 
		    } else if (have_cnames)
35524 maechler 1473 
			SET_STRING_ELT(nam, j++, R_BlankString);
1474 
		}
1820 ihaka 1475 
	    }
2 r 1476 
	}
1820 ihaka 1477 
	setAttrib(result, R_DimNamesSymbol, dn);
1864 ihaka 1478 
	UNPROTECT(1);
1820 ihaka 1479 
    }
1480 
    UNPROTECT(1);
1481 
    return result;
4041 maechler 1482 
} /* cbind */
2 r 1483 
 
35504 maechler 1484 
static SEXP rbind(SEXP call, SEXP args, SEXPTYPE mode, SEXP rho,
1485 
		  int deparse_level)
2 r 1486 
{
87863 ripley 1487 
    bool have_rnames = false, have_cnames = false, warned = false;
4041 maechler 1488 
    int nnames, mnames;
35504 maechler 1489 
    int rows, cols, mcols, lenmin = 0;
6483 pd 1490 
    SEXP dn, t, u, result, dims, expr;
2 r 1491 
 
4041 maechler 1492 
    nnames = 0;
1493 
    mnames = 0;
1820 ihaka 1494 
    rows = 0;
1495 
    cols = 0;
35504 maechler 1496 
    mcols = -1;
2 r 1497 
 
20812 ripley 1498 
    /* check if we are in the zero-cols case */
1499 
 
23264 ripley 1500 
    for (t = args; t != R_NilValue; t = CDR(t)) {
1501 
	u = PRVALUE(CAR(t));
1502 
	if((isMatrix(u) ? ncols(u) : length(u)) > 0) {
20812 ripley 1503 
	    lenmin = 1;
1504 
	    break;
1505 
	}
23264 ripley 1506 
    }
1507 
 
1820 ihaka 1508 
    /* check conformability of matrix arguments */
2 r 1509 
 
60241 ripley 1510 
    int na = 0;
1511 
    for (t = args; t != R_NilValue; t = CDR(t), na++) {
6483 pd 1512 
	u = PRVALUE(CAR(t));
20812 ripley 1513 
	dims = getAttrib(u, R_DimSymbol);
1514 
	if (length(dims) == 2) {
35504 maechler 1515 
	    if (mcols == -1)
20812 ripley 1516 
		mcols = INTEGER(dims)[1];
1517 
	    else if (mcols != INTEGER(dims)[1])
41686 ripley 1518 
		error(_("number of columns of matrices must match (see arg %d)"),
60241 ripley 1519 
		      na + 1);
20812 ripley 1520 
	    rows += INTEGER(dims)[0];
1160 maechler 1521 
	}
20812 ripley 1522 
	else if (length(u) >= lenmin){
1523 
	    cols = imax2(cols, length(u));
1524 
	    rows += 1;
1525 
	}
1820 ihaka 1526 
    }
35504 maechler 1527 
    if (mcols != -1) cols = mcols;
2 r 1528 
 
4041 maechler 1529 
    /* Check conformability of vector arguments. -- Look for dimnames. */
2 r 1530 
 
60241 ripley 1531 
    na = 0;
1532 
    for (t = args; t != R_NilValue; t = CDR(t), na++) {
6483 pd 1533 
	u = PRVALUE(CAR(t));
20812 ripley 1534 
	dims = getAttrib(u, R_DimSymbol);
1535 
	if (length(dims) == 2) {
1536 
	    dn = getAttrib(u, R_DimNamesSymbol);
1537 
	    if (length(dn) == 2) {
1538 
		if (VECTOR_ELT(dn, 0) != R_NilValue)
87863 ripley 1539 
		    have_rnames = true;
20812 ripley 1540 
		if (VECTOR_ELT(dn, 1) != R_NilValue)
1541 
		    mnames = mcols;
1820 ihaka 1542 
	    }
2 r 1543 
	}
20812 ripley 1544 
	else {
67809 ripley 1545 
	    int k = length(u);
20812 ripley 1546 
	    if (!warned && k>0 && (k > cols || cols % k)) {
87863 ripley 1547 
		warned = true;
60241 ripley 1548 
		warning("number of columns of result is not a multiple of vector length (arg %d)", na + 1);
20812 ripley 1549 
	    }
68092 luke 1550 
	    PROTECT(dn = getAttrib(u, R_NamesSymbol));
20812 ripley 1551 
	    if (k >= lenmin && (TAG(t) != R_NilValue ||
51007 ripley 1552 
				(deparse_level == 2) ||
1553 
				((deparse_level == 1) &&
1554 
				 isSymbol(substitute(CAR(t),R_NilValue)))))
87863 ripley 1555 
		have_rnames = true;
20812 ripley 1556 
	    nnames = imax2(nnames, length(dn));
68092 luke 1557 
	    UNPROTECT(1); /* dn */
20812 ripley 1558 
	}
1820 ihaka 1559 
    }
4041 maechler 1560 
    if (mnames || nnames == cols)
87863 ripley 1561 
	have_cnames = true;
2 r 1562 
 
1820 ihaka 1563 
    PROTECT(result = allocMatrix(mode, rows, cols));
4041 maechler 1564 
 
60241 ripley 1565 
    R_xlen_t n = 0;
1566 
 
1820 ihaka 1567 
    if (mode == STRSXP) {
1568 
	for (t = args; t != R_NilValue; t = CDR(t)) {
6483 pd 1569 
	    u = PRVALUE(CAR(t));
23264 ripley 1570 
	    if (isMatrix(u) || length(u) >= lenmin) {
6483 pd 1571 
		u = coerceVector(u, STRSXP);
67809 ripley 1572 
		R_xlen_t k = XLENGTH(u);
1573 
		R_xlen_t idx = (isMatrix(u)) ? nrows(u) : (k > 0);
68663 luke 1574 
		xfillStringMatrixWithRecycle(result, u, n, rows, idx, cols, k);
35504 maechler 1575 
		n += idx;
1820 ihaka 1576 
	    }
2 r 1577 
	}
1820 ihaka 1578 
    }
28870 ripley 1579 
    else if (mode == VECSXP) {
1580 
	for (t = args; t != R_NilValue; t = CDR(t)) {
1581 
	    u = PRVALUE(CAR(t));
68923 ripley 1582 
	    int umatrix = isMatrix(u), urows = umatrix ? nrows(u) : 1; /* coercing to VECSXP will lose these. PR#15468 */
63983 murdoch 1583 
	    if (umatrix || length(u) >= lenmin) {
42014 ripley 1584 
		PROTECT(u = coerceVector(u, mode));
67809 ripley 1585 
		R_xlen_t k = XLENGTH(u);
1586 
		R_xlen_t idx = umatrix ? urows : (k > 0);
68663 luke 1587 
		FILL_MATRIX_ITERATE(n, rows, idx, cols, k)
1588 
		    SET_VECTOR_ELT(result, didx,
68923 ripley 1589 
			lazy_duplicate(VECTOR_ELT(u, sidx)));
35504 maechler 1590 
		n += idx;
42014 ripley 1591 
		UNPROTECT(1);
28870 ripley 1592 
	    }
1593 
	}
1594 
    }
37196 ripley 1595 
    else if (mode == RAWSXP) {
1596 
	for (t = args; t != R_NilValue; t = CDR(t)) {
1597 
	    u = PRVALUE(CAR(t));
1598 
	    if (isMatrix(u) || length(u) >= lenmin) {
1599 
		u = coerceVector(u, RAWSXP);
67809 ripley 1600 
		R_xlen_t k = XLENGTH(u);
1601 
		R_xlen_t idx = (isMatrix(u)) ? nrows(u) : (k > 0);
68663 luke 1602 
		xfillRawMatrixWithRecycle(RAW(result), RAW(u), n, rows, idx,
1603 
					  cols, k);
37196 ripley 1604 
		n += idx;
1605 
	    }
1606 
	}
1607 
    }
1820 ihaka 1608 
    else if (mode == CPLXSXP) {
1609 
	for (t = args; t != R_NilValue; t = CDR(t)) {
6483 pd 1610 
	    u = PRVALUE(CAR(t));
23264 ripley 1611 
	    if (isMatrix(u) || length(u) >= lenmin) {
6483 pd 1612 
		u = coerceVector(u, CPLXSXP);
67809 ripley 1613 
		R_xlen_t k = XLENGTH(u);
1614 
		R_xlen_t idx = (isMatrix(u)) ? nrows(u) : (k > 0);
68663 luke 1615 
		xfillComplexMatrixWithRecycle(COMPLEX(result), COMPLEX(u), n,
1616 
					      rows, idx, cols, k);
35504 maechler 1617 
		n += idx;
1820 ihaka 1618 
	    }
1619 
	}
1620 
    }
87390 ripley 1621 
    else if (mode == INTSXP) {
4041 maechler 1622 
	for (t = args; t != R_NilValue; t = CDR(t)) {
87390 ripley 1623 
	    u = PRVALUE(CAR(t));
23264 ripley 1624 
	    if (isMatrix(u) || length(u) >= lenmin) {
87390 ripley 1625 
		u = coerceVector(u, INTSXP);
67809 ripley 1626 
		R_xlen_t k = XLENGTH(u);
1627 
		R_xlen_t idx = (isMatrix(u)) ? nrows(u) : (k > 0);
87390 ripley 1628 
		xfillIntegerMatrixWithRecycle(INTEGER(result), INTEGER(u), n, rows, idx,
1629 
					  cols, k);
1630 
		n += idx;
1820 ihaka 1631 
	    }
2 r 1632 
	}
1820 ihaka 1633 
    }
87390 ripley 1634 
     else if (mode == LGLSXP) {
1635 
	for (t = args; t != R_NilValue; t = CDR(t)) {
1636 
	    u = PRVALUE(CAR(t));
1637 
	    if (isMatrix(u) || length(u) >= lenmin) {
1638 
		u = coerceVector(u, LGLSXP);
1639 
		R_xlen_t k = XLENGTH(u);
1640 
		R_xlen_t idx = (isMatrix(u)) ? nrows(u) : (k > 0);
1641 
		xfillLogicalMatrixWithRecycle(LOGICAL(result), LOGICAL(u), n, rows, idx,
1642 
					  cols, k);
1643 
		n += idx;
1644 
	    }
1645 
	}
1646 
     }
1647 
     else if (mode == REALSXP) {
1648 
	 for (t = args; t != R_NilValue; t = CDR(t)) {
1649 
	     u = PRVALUE(CAR(t));
1650 
	     if (isMatrix(u) || length(u) >= lenmin) {
1651 
		 u = coerceVector(u, REALSXP);
1652 
		 R_xlen_t k = XLENGTH(u);
1653 
		 R_xlen_t idx = (isMatrix(u)) ? nrows(u) : (k > 0);
1654 
		 xfillRealMatrixWithRecycle(REAL(result), REAL(u), n, rows, idx,
1655 
					  cols, k);
1656 
		 n += idx;
1657 
	     }
1658 
	 }
1659 
     }
1660 
     else { /* everything else, currently NILSXP so do nothing */
1661 
     }
35504 maechler 1662 
 
4041 maechler 1663 
    /* Adjustment of dimnames attributes. */
35504 maechler 1664 
    if (have_rnames || have_cnames) {
6697 tlumley 1665 
	SEXP nam, tnam,v;
1839 ihaka 1666 
	PROTECT(dn = allocVector(VECSXP, 2));
1667 
	if (have_rnames)
10172 luke 1668 
	    nam = SET_VECTOR_ELT(dn, 0, allocVector(STRSXP, rows));
2458 hornik 1669 
	else
4041 maechler 1670 
	    nam = R_NilValue;	/* -Wall */
67809 ripley 1671 
	int j = 0;
2 r 1672 
	for (t = args; t != R_NilValue; t = CDR(t)) {
6483 pd 1673 
	    u = PRVALUE(CAR(t));
20812 ripley 1674 
	    if (isMatrix(u)) {
1675 
		v = getAttrib(u, R_DimNamesSymbol);
1839 ihaka 1676 
 
35504 maechler 1677 
		if (have_cnames &&
1678 
		    GetColNames(dn) == R_NilValue &&
1679 
		    GetColNames(v) != R_NilValue)
64973 luke 1680 
		    SetColNames(dn, lazy_duplicate(GetColNames(v)));
1839 ihaka 1681 
 
20812 ripley 1682 
		/* cbind() doesn't test have_?names BEFORE tnam!=Nil..:*/
41996 ripley 1683 
		/* but if tnam is non-null, have_rnames = TRUE: see above */
1684 
		tnam = GetRowNames(v);
20812 ripley 1685 
		if (have_rnames) {
1686 
		    if (tnam != R_NilValue) {
67809 ripley 1687 
			for (int i = 0; i < length(tnam); i++)
20812 ripley 1688 
			    SET_STRING_ELT(nam, j++, STRING_ELT(tnam, i));
1689 
		    }
1690 
		    else {
67809 ripley 1691 
			for (int i = 0; i < nrows(u); i++)
10172 luke 1692 
				SET_STRING_ELT(nam, j++, R_BlankString);
1820 ihaka 1693 
		    }
2 r 1694 
		}
20812 ripley 1695 
	    }
1696 
	    else if (length(u) >= lenmin) {
1697 
		u = getAttrib(u, R_NamesSymbol);
1839 ihaka 1698 
 
20812 ripley 1699 
		if (have_cnames && GetColNames(dn) == R_NilValue
1700 
		    && u != R_NilValue && length(u) == cols)
64973 luke 1701 
		    SetColNames(dn, lazy_duplicate(u));
1839 ihaka 1702 
 
20812 ripley 1703 
		if (TAG(t) != R_NilValue)
1704 
		    SET_STRING_ELT(nam, j++, PRINTNAME(TAG(t)));
35524 maechler 1705 
		else {
1706 
		    expr = substitute(CAR(t), R_NilValue);
1707 
		    if (deparse_level == 1 && isSymbol(expr))
1708 
			SET_STRING_ELT(nam, j++, PRINTNAME(expr));
68092 luke 1709 
		    else if (deparse_level == 2) {
68923 ripley 1710 
			PROTECT(expr);
35524 maechler 1711 
			SET_STRING_ELT(nam, j++,
87904 ripley 1712 
				       STRING_ELT(deparse1line(expr, true), 0));
68092 luke 1713 
			UNPROTECT(1); /* expr */
1714 
		    } else if (have_rnames)
35524 maechler 1715 
			SET_STRING_ELT(nam, j++, R_BlankString);
1716 
		}
1820 ihaka 1717 
	    }
2 r 1718 
	}
1820 ihaka 1719 
	setAttrib(result, R_DimNamesSymbol, dn);
1864 ihaka 1720 
	UNPROTECT(1);
1820 ihaka 1721 
    }
1722 
    UNPROTECT(1);
1723 
    return result;
4041 maechler 1724 
} /* rbind */