The R Project SVN R

Rev

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