/*
 *  R : A Computer Language for Statistical Data Analysis
 *  Copyright (C) 1997--2017  The R Core Team
 *  Copyright (C) 2002--2017  The R Foundation
 *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
 *
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2, or (at your option)
 *  any later version.
 *
 *  This program is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU General Public License for more details.
 *
 *  You should have received a copy of the GNU General Public License
 *  along with this program; if not, a copy is available at
 *  https://www.R-project.org/Licenses/
 */

/* Code to handle list / vector switch */

#ifdef HAVE_CONFIG_H
# include <config.h>
#endif

#include <Defn.h>
#include <Internal.h>
#include <R_ext/PrtUtil.h> // for IndexWidth
#include <R_ext/Itermacros.h>
#define imax2(x, y) ((x < y) ? y : x)

#include "RBufferUtils.h"
static R_StringBuffer cbuff = {NULL, 0, MAXELTSIZE};

#include "duplicate.h"

#define LIST_ASSIGN(x) {SET_VECTOR_ELT(data->ans_ptr, data->ans_length, x); data->ans_length++;}

static SEXP cbind(SEXP, SEXP, SEXPTYPE, SEXP, int);
static SEXP rbind(SEXP, SEXP, SEXPTYPE, SEXP, int);

/* The following code establishes the return type for the */
/* functions  unlist, c, cbind, and rbind and also determines */
/* whether the returned object is to have a names attribute. */

struct BindData {
 int  ans_flags;
 SEXP ans_ptr;
 R_xlen_t ans_length;
 SEXP ans_names;
 R_xlen_t  ans_nnames;
/* int  deparse_level; Initialize to 1. */
};

static int HasNames(SEXP x)
{
    if(isVector(x)) {
	if (!isNull(getAttrib(x, R_NamesSymbol)))
	    return 1;
    }
    else if(isList(x)) {
	while (!isNull(x)) {
	    if (!isNull(TAG(x))) return 1;
	    x = CDR(x);
	}
    }
    return 0;
}

static void
AnswerType(SEXP x, Rboolean recurse, Rboolean usenames, struct BindData *data, SEXP call)
{
    switch (TYPEOF(x)) {
    case NILSXP:
	break;
    case RAWSXP:
	data->ans_flags |= 1;
	data->ans_length += XLENGTH(x);
	break;
    case LGLSXP:
	data->ans_flags |= 2;
	data->ans_length += XLENGTH(x);
	break;
    case INTSXP:
	data->ans_flags |= 16;
	data->ans_length += XLENGTH(x);
	break;
    case REALSXP:
	data->ans_flags |= 32;
	data->ans_length += XLENGTH(x);
	break;
    case CPLXSXP:
	data->ans_flags |= 64;
	data->ans_length += XLENGTH(x);
	break;
    case STRSXP:
	data->ans_flags |= 128;
	data->ans_length += XLENGTH(x);
	break;

#ifdef DO_C_Symbol
/* new case : */
    case SYMSXP:
    case LANGSXP:
	data->ans_flags |= 512; /* as.expression() implicitly */
	data->ans_length += 1;
	break;
#endif
    case VECSXP:
    case EXPRSXP:
	if (recurse) {
	    R_xlen_t i, n = XLENGTH(x);
	    if (usenames && !data->ans_nnames &&
		!isNull(getAttrib(x, R_NamesSymbol)))
		data->ans_nnames = 1;
	    for (i = 0; i < n; i++) {
		if (usenames && !data->ans_nnames)
		    data->ans_nnames = HasNames(VECTOR_ELT(x, i));
		AnswerType(VECTOR_ELT(x, i), recurse, usenames, data, call);
	    }
	}
	else {
	    if (TYPEOF(x) == EXPRSXP)
		data->ans_flags |= 512;
	    else
		data->ans_flags |= 256;
	    data->ans_length += XLENGTH(x);
	}
	break;
    case LISTSXP:
	if (recurse) {
	    while (x != R_NilValue) {
		if (usenames && !data->ans_nnames) {
		    if (!isNull(TAG(x))) data->ans_nnames = 1;
		    else data->ans_nnames = HasNames(CAR(x));
		}
		AnswerType(CAR(x), recurse, usenames, data, call);
		x = CDR(x);
	    }
	}
	else {
	    data->ans_flags |= 256;
	    data->ans_length += length(x);
	}
	break;
    default:
	data->ans_flags |= 256;
	data->ans_length += 1;
	break;
    }

    /* check for overflow in ans_length. Objects are added one at a
       time for each call to AnswerType so it is safe to check here.
       Since sizes are signed, positive numbers, the overflow will
       manifest itself as a negative result (both numbers will be
       31-bit so we cannot overflow across the 32-bit boundary). If
       our assumption (all lengths are signed) is violated, this won't
       work so check when switching length types! */

#ifndef LONG_VECTOR_SUPPORT
    if (data->ans_length < 0)
	errorcall(call, _("resulting vector exceeds vector length limit in '%s'"), "AnswerType");
#endif
}


/* The following functions are used to coerce arguments to the
 * appropriate type for inclusion in the returned value. */

static void
ListAnswer(SEXP x, int recurse, struct BindData *data, SEXP call)
{
    R_xlen_t i;

    switch(TYPEOF(x)) {
    case NILSXP:
	break;
    case LGLSXP:
	for (i = 0; i < XLENGTH(x); i++)
	    LIST_ASSIGN(ScalarLogical(LOGICAL(x)[i]));
	break;
    case RAWSXP:
	for (i = 0; i < XLENGTH(x); i++)
	    LIST_ASSIGN(ScalarRaw(RAW(x)[i]));
	break;
    case INTSXP:
	for (i = 0; i < XLENGTH(x); i++)
	    LIST_ASSIGN(ScalarInteger(INTEGER(x)[i]));
	break;
    case REALSXP:
	for (i = 0; i < XLENGTH(x); i++)
	    LIST_ASSIGN(ScalarReal(REAL(x)[i]));
	break;
    case CPLXSXP:
	for (i = 0; i < XLENGTH(x); i++)
	    LIST_ASSIGN(ScalarComplex(COMPLEX(x)[i]));
	break;
    case STRSXP:
	for (i = 0; i < XLENGTH(x); i++)
	    LIST_ASSIGN(ScalarString(STRING_ELT(x, i)));
	break;
    case VECSXP:
    case EXPRSXP:
	if (recurse) {
	    for (i = 0; i < XLENGTH(x); i++)
		ListAnswer(VECTOR_ELT(x, i), recurse, data, call);
	}
	else {
	    for (i = 0; i < XLENGTH(x); i++)
		LIST_ASSIGN(lazy_duplicate(VECTOR_ELT(x, i)));
	}
	break;
    case LISTSXP:
	if (recurse) {
	    while (x != R_NilValue) {
		ListAnswer(CAR(x), recurse, data, call);
		x = CDR(x);
	    }
	}
	else
	    while (x != R_NilValue) {
		LIST_ASSIGN(lazy_duplicate(CAR(x)));
		x = CDR(x);
	    }
	break;
    default:
	LIST_ASSIGN(lazy_duplicate(x));
	break;
    }
}

static void
StringAnswer(SEXP x, struct BindData *data, SEXP call)
{
    R_xlen_t i;
    switch(TYPEOF(x)) {
    case NILSXP:
	break;
    case LISTSXP:
	while (x != R_NilValue) {
	    StringAnswer(CAR(x), data, call);
	    x = CDR(x);
	}
	break;
    case EXPRSXP:
    case VECSXP:
	for (i = 0; i < XLENGTH(x); i++)
	    StringAnswer(VECTOR_ELT(x, i), data, call);
	break;
    default:
	PROTECT(x = coerceVector(x, STRSXP));
	for (i = 0; i < XLENGTH(x); i++)
	    SET_STRING_ELT(data->ans_ptr, data->ans_length++, STRING_ELT(x, i));
	UNPROTECT(1);
	break;
    }
}

static void
LogicalAnswer(SEXP x, struct BindData *data, SEXP call)
{
    R_xlen_t i;
    switch(TYPEOF(x)) {
    case NILSXP:
	break;
    case LISTSXP:
	while (x != R_NilValue) {
	    LogicalAnswer(CAR(x), data, call);
	    x = CDR(x);
	}
	break;
    case EXPRSXP:
    case VECSXP:
	for (i = 0; i < XLENGTH(x); i++)
	    LogicalAnswer(VECTOR_ELT(x, i), data, call);
	break;
    case LGLSXP:
	for (i = 0; i < XLENGTH(x); i++)
	    LOGICAL(data->ans_ptr)[data->ans_length++] = LOGICAL(x)[i];
	break;
    case INTSXP:
	for (i = 0; i < XLENGTH(x); i++) {
	    int v = INTEGER(x)[i];
	    LOGICAL(data->ans_ptr)[data->ans_length++] = (v == NA_INTEGER) ? NA_LOGICAL : ( v != 0 );
	}
	break;
    case RAWSXP:
	for (i = 0; i < XLENGTH(x); i++)
	    LOGICAL(data->ans_ptr)[data->ans_length++] = (int)RAW(x)[i] != 0;
	break;
    default:
	errorcall(call, _("type '%s' is unimplemented in '%s'"),
		  type2char(TYPEOF(x)), "LogicalAnswer");
    }
}

static void
IntegerAnswer(SEXP x, struct BindData *data, SEXP call)
{
    R_xlen_t i;
    switch(TYPEOF(x)) {
    case NILSXP:
	break;
    case LISTSXP:
	while (x != R_NilValue) {
	    IntegerAnswer(CAR(x), data, call);
	    x = CDR(x);
	}
	break;
    case EXPRSXP:
    case VECSXP:
	for (i = 0; i < XLENGTH(x); i++)
	    IntegerAnswer(VECTOR_ELT(x, i), data, call);
	break;
    case LGLSXP:
	for (i = 0; i < XLENGTH(x); i++)
	    INTEGER(data->ans_ptr)[data->ans_length++] = LOGICAL(x)[i];
	break;
    case INTSXP:
	for (i = 0; i < XLENGTH(x); i++)
	    INTEGER(data->ans_ptr)[data->ans_length++] = INTEGER(x)[i];
	break;
    case RAWSXP:
	for (i = 0; i < XLENGTH(x); i++)
	    INTEGER(data->ans_ptr)[data->ans_length++] = (int)RAW(x)[i];
	break;
    default:
	errorcall(call, _("type '%s' is unimplemented in '%s'"),
		  type2char(TYPEOF(x)), "IntegerAnswer");
    }
}

static void
RealAnswer(SEXP x, struct BindData *data, SEXP call)
{
    R_xlen_t i;
    int xi;
    switch(TYPEOF(x)) {
    case NILSXP:
	break;
    case LISTSXP:
	while (x != R_NilValue) {
	    RealAnswer(CAR(x), data, call);
	    x = CDR(x);
	}
	break;
    case VECSXP:
    case EXPRSXP:
	for (i = 0; i < XLENGTH(x); i++)
	    RealAnswer(VECTOR_ELT(x, i), data, call);
	break;
    case REALSXP:
	for (i = 0; i < XLENGTH(x); i++)
	    REAL(data->ans_ptr)[data->ans_length++] = REAL(x)[i];
	break;
    case LGLSXP:
	for (i = 0; i < XLENGTH(x); i++) {
	    xi = LOGICAL(x)[i];
	    if (xi == NA_LOGICAL)
		REAL(data->ans_ptr)[data->ans_length++] = NA_REAL;
	    else REAL(data->ans_ptr)[data->ans_length++] = xi;
	}
	break;
    case INTSXP:
	for (i = 0; i < XLENGTH(x); i++) {
	    xi = INTEGER(x)[i];
	    if (xi == NA_INTEGER)
		REAL(data->ans_ptr)[data->ans_length++] = NA_REAL;
	    else REAL(data->ans_ptr)[data->ans_length++] = xi;
	}
	break;
    case RAWSXP:
	for (i = 0; i < XLENGTH(x); i++)
	    REAL(data->ans_ptr)[data->ans_length++] = (int)RAW(x)[i];
	break;
    default:
	errorcall(call, _("type '%s' is unimplemented in '%s'"),
		  type2char(TYPEOF(x)), "RealAnswer");
    }
}

static void
ComplexAnswer(SEXP x, struct BindData *data, SEXP call)
{
    R_xlen_t i;
    int xi;
    switch(TYPEOF(x)) {
    case NILSXP:
	break;
    case LISTSXP:
	while (x != R_NilValue) {
	    ComplexAnswer(CAR(x), data, call);
	    x = CDR(x);
	}
	break;
    case EXPRSXP:
    case VECSXP:
	for (i = 0; i < XLENGTH(x); i++)
	    ComplexAnswer(VECTOR_ELT(x, i), data, call);
	break;
    case REALSXP:
	for (i = 0; i < XLENGTH(x); i++) {
	    COMPLEX(data->ans_ptr)[data->ans_length].r = REAL(x)[i];
	    COMPLEX(data->ans_ptr)[data->ans_length].i = 0.0;
	    data->ans_length++;
	}
	break;
    case CPLXSXP:
	for (i = 0; i < XLENGTH(x); i++)
	    COMPLEX(data->ans_ptr)[data->ans_length++] = COMPLEX(x)[i];
	break;
    case LGLSXP:
	for (i = 0; i < XLENGTH(x); i++) {
	    xi = LOGICAL(x)[i];
	    if (xi == NA_LOGICAL) {
		COMPLEX(data->ans_ptr)[data->ans_length].r = NA_REAL;
		COMPLEX(data->ans_ptr)[data->ans_length].i = NA_REAL;
	    }
	    else {
		COMPLEX(data->ans_ptr)[data->ans_length].r = xi;
		COMPLEX(data->ans_ptr)[data->ans_length].i = 0.0;
	    }
	    data->ans_length++;
	}
	break;
    case INTSXP:
	for (i = 0; i < XLENGTH(x); i++) {
	    xi = INTEGER(x)[i];
	    if (xi == NA_INTEGER) {
		COMPLEX(data->ans_ptr)[data->ans_length].r = NA_REAL;
		COMPLEX(data->ans_ptr)[data->ans_length].i = NA_REAL;
	    }
	    else {
		COMPLEX(data->ans_ptr)[data->ans_length].r = xi;
		COMPLEX(data->ans_ptr)[data->ans_length].i = 0.0;
	    }
	    data->ans_length++;
	}
	break;

    case RAWSXP:
	for (i = 0; i < XLENGTH(x); i++) {
	    COMPLEX(data->ans_ptr)[data->ans_length].r = (int)RAW(x)[i];
	    COMPLEX(data->ans_ptr)[data->ans_length].i = 0.0;
	    data->ans_length++;
	}
	break;

    default:
	errorcall(call, _("type '%s' is unimplemented in '%s'"),
		  type2char(TYPEOF(x)), "ComplexAnswer");
    }
}

static void
RawAnswer(SEXP x, struct BindData *data, SEXP call)
{
    R_xlen_t i;
    switch(TYPEOF(x)) {
    case NILSXP:
	break;
    case LISTSXP:
	while (x != R_NilValue) {
	    RawAnswer(CAR(x), data, call);
	    x = CDR(x);
	}
	break;
    case EXPRSXP:
    case VECSXP:
	for (i = 0; i < XLENGTH(x); i++)
	    RawAnswer(VECTOR_ELT(x, i), data, call);
	break;
    case RAWSXP:
	for (i = 0; i < XLENGTH(x); i++)
	    RAW(data->ans_ptr)[data->ans_length++] = RAW(x)[i];
	break;
    default:
	errorcall(call, _("type '%s' is unimplemented in '%s'"),
		  type2char(TYPEOF(x)), "RawAnswer");
    }
}

static SEXP NewBase(SEXP base, SEXP tag)
{
    SEXP ans;
    char *cbuf;
    base = EnsureString(base);
    tag = EnsureString(tag);
    if (*CHAR(base) && *CHAR(tag)) { /* test of length */
	const void *vmax = vmaxget();
	const char *sb = translateCharUTF8(base), *st = translateCharUTF8(tag);
	cbuf = R_AllocStringBuffer(strlen(st) + strlen(sb) + 1, &cbuff);
	sprintf(cbuf, "%s.%s", sb, st);
	/* This isn't strictly correct as we do not know that all the
	   components of the name were correctly translated. */
	ans = mkCharCE(cbuf, CE_UTF8);
	vmaxset(vmax);
    }
    else if (*CHAR(tag)) {
	ans = tag;
    }
    else if (*CHAR(base)) {
	ans = base;
    }
    else ans = R_BlankString;
    return ans;
}

static SEXP NewName(SEXP base, SEXP tag, R_xlen_t seqno, int count)
{
/* Construct a new Name/Tag, using
 *	base.tag
 *	base
 *	base<seqno>	or
 *	tag
 *
 */
    SEXP ans;
    base = EnsureString(base);
    tag = EnsureString(tag);
    if (*CHAR(base)) {
	if (*CHAR(tag)) {
	    const void *vmax = vmaxget();
	    const char
		*sb = translateCharUTF8(base),
		*st = translateCharUTF8(tag);
	    char *cbuf = R_AllocStringBuffer(strlen(sb) + strlen(st) + 1, &cbuff);
	    sprintf(cbuf, "%s.%s", sb, st);
	    ans = mkCharCE(cbuf, CE_UTF8);
	    vmaxset(vmax);
	}
	else if (count == 1)
	    ans = base;
	else {
	    const void *vmax = vmaxget();
	    const char *sb = translateCharUTF8(base);
	    char *cbuf;
	    cbuf = R_AllocStringBuffer(strlen(sb) + (size_t) IndexWidth(seqno),
				       &cbuff);
#ifdef LONG_VECTOR_SUPPORT
	    if (seqno > INT_MAX)
		sprintf(cbuf, "%s%.0f", sb, (double) seqno);
	    else
#endif
		sprintf(cbuf, "%s%d", sb, (int) seqno);
	    ans = mkCharCE(cbuf, CE_UTF8);
	    vmaxset(vmax);
	}
    }
    else if (*CHAR(tag)) {
	ans = tag;
    } else
	ans = R_BlankString;
    return ans;
}

/* also used in coerce.c */
SEXP attribute_hidden ItemName(SEXP names, R_xlen_t i)
{
  /* return  names[i]  if it is a character (>= 1 char), or NULL otherwise */
    if (names != R_NilValue &&
	STRING_ELT(names, i) != R_NilValue &&
	CHAR(STRING_ELT(names, i))[0] != '\0') /* length test */
	return STRING_ELT(names, i);
    else
	return R_NilValue;
}

/* NewExtractNames(v, base, tag, recurse):  For c() and	 unlist().
 * On entry, "base" is the naming component we have acquired by
 * recursing down from above.
 *	If we have a list and we are recursing, we append a new tag component
 * to the base tag (either by using the list tags, or their offsets),
 * and then we do the recursion.
 *	If we have a vector, we just create the tags for each element. */

struct NameData {
 int count;
 R_xlen_t seqno;
 // int firstpos;
};


// count names in (branch) v, recursively if(recurse) :
static void namesCount(SEXP v, int recurse, struct NameData *nameData)
{
    R_xlen_t i, n = xlength(v);
    SEXP names = PROTECT(getAttrib(v, R_NamesSymbol)), namei;

    /* The  "<= 1"  in every for() loop, i.e., for all "vector" cases,
       makes this much faster for large vector 'v'
       _and_ prevents ("almost surely") overflow of nameData->count.
       -->  PR#17284 and PR#17292, with thanks to Suharto Anggono.
    */
    switch(TYPEOF(v)) {
    case NILSXP:
	break;
    case LISTSXP:
	if (recurse) {
	    for (i = 0; i < n && nameData->count <= 1; i++) {
		PROTECT(namei = ItemName(names, i));
		if (namei == R_NilValue)
		    namesCount(CAR(v), recurse, nameData);
		v = CDR(v);
		UNPROTECT(1); /*namei*/
	    }
	    break;
	} /* else fall through */
    case VECSXP:
    case EXPRSXP:
	if (recurse) {
	    for (i = 0; i < n && nameData->count <= 1; i++) {
		namei = ItemName(names, i);
		if (namei == R_NilValue)
		    namesCount(VECTOR_ELT(v, i), recurse, nameData);
	    }
	    break;
	} /* else fall through */
    case LGLSXP:
    case INTSXP:
    case REALSXP:
    case CPLXSXP:
    case STRSXP:
    case RAWSXP:
	for (i = 0; i < n && nameData->count <= 1; i++)
	    nameData->count++;
	break;
    default:
	nameData->count++;
    }
    UNPROTECT(1); /*names*/
}

static void NewExtractNames(SEXP v, SEXP base, SEXP tag, int recurse,
			     struct BindData *data, struct NameData *nameData)
{
    SEXP names, namei;
    R_xlen_t i, n;
    int savecount=0;
    R_xlen_t saveseqno;

    /* If we have a new tag, we reset the index
     * sequence and create the new basename string : */
    if (tag != R_NilValue) {
	PROTECT(base = NewBase(base, tag));
	saveseqno = nameData->seqno;
	savecount = nameData->count;
	nameData->count = 0;
	namesCount(v, recurse, nameData);
	nameData->seqno = 0;
    }
    else saveseqno = 0;

    n = xlength(v);
    PROTECT(names = getAttrib(v, R_NamesSymbol));

    switch(TYPEOF(v)) {
    case NILSXP:
	break;
    case LISTSXP:
	for (i = 0; i < n; i++) {
	    PROTECT(namei = ItemName(names, i));
	    if (recurse) {
		NewExtractNames(CAR(v), base, namei, recurse, data, nameData);
	    }
	    else {
		namei = NewName(base, namei, ++(nameData->seqno), nameData->count);
		SET_STRING_ELT(data->ans_names, (data->ans_nnames)++, namei);
	    }
	    v = CDR(v);
	    UNPROTECT(1); /*namei*/
	}
	break;
    case VECSXP:
    case EXPRSXP:
	for (i = 0; i < n; i++) {
	    namei = ItemName(names, i);
	    if (recurse) {
		NewExtractNames(VECTOR_ELT(v, i), base, namei, recurse, data, nameData);
	    }
	    else {
		namei = NewName(base, namei, ++(nameData->seqno), nameData->count);
		SET_STRING_ELT(data->ans_names, (data->ans_nnames)++, namei);
	    }
	}
	break;
    case LGLSXP:
    case INTSXP:
    case REALSXP:
    case CPLXSXP:
    case STRSXP:
    case RAWSXP:
	for (i = 0; i < n; i++) {
	    namei = ItemName(names, i);
	    namei = NewName(base, namei, ++(nameData->seqno), nameData->count);
	    SET_STRING_ELT(data->ans_names, (data->ans_nnames)++, namei);
	}
	break;
    default:
	namei = NewName(base, R_NilValue, ++(nameData->seqno), nameData->count);
	SET_STRING_ELT(data->ans_names, (data->ans_nnames)++, namei);
    }
    if (tag != R_NilValue) {
	nameData->count = savecount;
	UNPROTECT(1);
    }
    UNPROTECT(1); /*names*/
    nameData->seqno = nameData->seqno + saveseqno;
}

/* Code to extract the optional arguments to c().  We do it this */
/* way, rather than having an interpreted front-end do the job, */
/* because we want to avoid duplication at the top level. */
/* FIXME : is there another possibility? */
static SEXP c_Extract_opt(SEXP ans, Rboolean *recurse, Rboolean *usenames,
			  SEXP call)
{
    SEXP a, n, last = NULL, next = NULL;
    int v, n_recurse = 0, n_usenames = 0;

    for (a = ans; a != R_NilValue; a = next) {
	n = TAG(a);
	next = CDR(a);
	if (n != R_NilValue && pmatch(R_RecursiveSymbol, n, 1)) {
	    if (n_recurse++ == 1)
		errorcall(call, _("repeated formal argument 'recursive'"));
	    if ((v = asLogical(CAR(a))) != NA_INTEGER) {
		*recurse = v;
	    }
	    if (last == NULL)
		ans = next;
	    else
		SETCDR(last, next);
	}
	else if (n != R_NilValue && pmatch(R_UseNamesSymbol, n, 1)) {
	    if (n_usenames++ == 1)
		errorcall(call, _("repeated formal argument 'use.names'"));
	    if ((v = asLogical(CAR(a))) != NA_INTEGER) {
		*usenames = v;
	    }
	    if (last == NULL)
		ans = next;
	    else
		SETCDR(last, next);
	}
	else last = a;
    }
    return ans;
}


/* The change to lists based on dotted pairs has meant that it was
   necessary to separate the internal code for "c" and "unlist".
   Although the functions are quite similar, they operate on very
   different data structures.
*/

/* The major difference between the two functions is that the value of
   the "recursive" argument is FALSE by default for "c" and TRUE for
   "unlist".  In addition, "c" takes ... while "unlist" takes a single
   argument.
*/

/* This is a primitive SPECIALSXP */
SEXP attribute_hidden do_c(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP ans;

    checkArity(op, args);

    /* Attempt method dispatch. */

    if (DispatchAnyOrEval(call, op, "c", args, env, &ans, 1, 1))
	//      ^^^ "Any" => all args are eval()ed and checked => correct multi-arg dispatch
	return(ans);
    PROTECT(ans);
    SEXP res = do_c_dflt(call, op, ans, env);
    UNPROTECT(1);
    return res;
}

SEXP attribute_hidden do_c_dflt(SEXP call, SEXP op, SEXP args, SEXP env)
{
    /* Method dispatch has failed; run the default code. */
    /* By default we do not recurse, but this can be over-ridden */
    /* by an optional "recursive" argument. */

    Rboolean
	usenames = TRUE,
	recurse = FALSE;
    /* this was only done for length(args) > 1 prior to 1.5.0,
       _but_ `recursive' might be the only argument */
    PROTECT(args = c_Extract_opt(args, &recurse, &usenames, call));

    /* Determine the type of the returned value. */
    /* The strategy here is appropriate because the */
    /* object being operated on is a pair based list. */

    struct BindData data;
/*    data.deparse_level = 1;  Initialize this early. */
    data.ans_flags  = 0;
    data.ans_length = 0;
    data.ans_nnames = 0;

    SEXP t, ans;
    for (t = args; t != R_NilValue; t = CDR(t)) {
	if (usenames && !data.ans_nnames) {
	    if (!isNull(TAG(t))) data.ans_nnames = 1;
	    else data.ans_nnames = HasNames(CAR(t));
	}
	AnswerType(CAR(t), recurse, usenames, &data, call);
    }

    /* If a non-vector argument was encountered (perhaps a list if */
    /* recursive is FALSE) then we must return a list.	Otherwise, */
    /* we use the natural coercion for vector types. */

    int mode = NILSXP;
    if      (data.ans_flags & 512) mode = EXPRSXP;
    else if (data.ans_flags & 256) mode = VECSXP;
    else if (data.ans_flags & 128) mode = STRSXP;
    else if (data.ans_flags &  64) mode = CPLXSXP;
    else if (data.ans_flags &  32) mode = REALSXP;
    else if (data.ans_flags &  16) mode = INTSXP;
    else if (data.ans_flags &	2) mode = LGLSXP;
    else if (data.ans_flags &	1) mode = RAWSXP;

    /* Allocate the return value and set up to pass through */
    /* the arguments filling in values of the returned object. */

    PROTECT(ans = allocVector(mode, data.ans_length));
    data.ans_ptr = ans;
    data.ans_length = 0;
    t = args;

    if (mode == VECSXP || mode == EXPRSXP) {
	if (!recurse) {
	    while (args != R_NilValue) {
		ListAnswer(CAR(args), 0, &data, call);
		args = CDR(args);
	    }
	}
	else ListAnswer(args, recurse, &data, call);
	data.ans_length = xlength(ans);
    }
    else if (mode == STRSXP)
	StringAnswer(args, &data, call);
    else if (mode == CPLXSXP)
	ComplexAnswer(args, &data, call);
    else if (mode == REALSXP)
	RealAnswer(args, &data, call);
    else if (mode == RAWSXP)
	RawAnswer(args, &data, call);
    else if (mode == LGLSXP)
	LogicalAnswer(args, &data, call);
    else /* integer */
	IntegerAnswer(args, &data, call);
    args = t;

    /* Build and attach the names attribute for the returned object. */

    if (data.ans_nnames && data.ans_length > 0) {
	PROTECT(data.ans_names = allocVector(STRSXP, data.ans_length));
	data.ans_nnames = 0;
	while (args != R_NilValue) {
	    struct NameData nameData;
	    nameData.seqno = 0;
	    nameData.count = 0;
	    NewExtractNames(CAR(args), R_NilValue, TAG(args), recurse, &data, &nameData);
	    args = CDR(args);
	}
	setAttrib(ans, R_NamesSymbol, data.ans_names);
	UNPROTECT(1);
    }
    UNPROTECT(2);
    R_FreeStringBufferL(&cbuff);
    return ans;
} /* do_c */


SEXP attribute_hidden do_unlist(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP ans, t;
    R_xlen_t i, n = 0;
    struct BindData data;

/*    data.deparse_level = 1; */
    checkArity(op, args);

    /* Attempt method dispatch. */

    if (DispatchOrEval(call, op, "unlist", args, env, &ans, 0, 1))
	return(ans);

    /* Method dispatch has failed; run the default code. */
    /* By default we recurse, but this can be over-ridden */
    /* by an optional "recursive" argument. */

    PROTECT(args = CAR(ans));
    Rboolean recurse = asLogical(CADR(ans));
    Rboolean usenames = asLogical(CADDR(ans));
    Rboolean lenient = TRUE; // was (implicitly!) FALSE  up to R 3.0.1

    /* Determine the type of the returned value. */
    /* The strategy here is appropriate because the */
    /* object being operated on is a generic vector. */

    data.ans_flags  = 0;
    data.ans_length = 0;
    data.ans_nnames = 0;

    if (isNewList(args)) {
	n = xlength(args);
	if (usenames && getAttrib(args, R_NamesSymbol) != R_NilValue)
	    data.ans_nnames = 1;
	for (i = 0; i < n; i++) {
	    if (usenames && !data.ans_nnames)
		data.ans_nnames = HasNames(VECTOR_ELT(args, i));
	    AnswerType(VECTOR_ELT(args, i), recurse, usenames, &data, call);
	}
    }
    else if (isList(args)) {
	for (t = args; t != R_NilValue; t = CDR(t)) {
	    if (usenames && !data.ans_nnames) {
		if (!isNull(TAG(t))) data.ans_nnames = 1;
		else data.ans_nnames = HasNames(CAR(t));
	    }
	    AnswerType(CAR(t), recurse, usenames, &data, call);
	}
    }
    else {
	UNPROTECT(1);
	if (lenient || isVector(args)) return args;
	else error(_("argument not a list"));
    }

    /* If a non-vector argument was encountered (perhaps a list if */
    /* recursive is FALSE) then we must return a list.  Otherwise, */
    /* we use the natural coercion for vector types. */

    int mode = NILSXP;
    if      (data.ans_flags & 512) mode = EXPRSXP;
    else if (data.ans_flags & 256) mode = VECSXP;
    else if (data.ans_flags & 128) mode = STRSXP;
    else if (data.ans_flags &  64) mode = CPLXSXP;
    else if (data.ans_flags &  32) mode = REALSXP;
    else if (data.ans_flags &  16) mode = INTSXP;
    else if (data.ans_flags &	2) mode = LGLSXP;
    else if (data.ans_flags &	1) mode = RAWSXP;

    /* Allocate the return value and set up to pass through */
    /* the arguments filling in values of the returned object. */

    PROTECT(ans = allocVector(mode, data.ans_length));
    data.ans_ptr = ans;
    data.ans_length = 0;
    t = args;

    if (mode == VECSXP || mode == EXPRSXP) {
	if (!recurse) {
	    for (i = 0; i < n; i++)
		ListAnswer(VECTOR_ELT(args, i), 0, &data, call);
	}
	else ListAnswer(args, recurse, &data, call);
	data.ans_length = xlength(ans);
    }
    else if (mode == STRSXP)
	StringAnswer(args, &data, call);
    else if (mode == CPLXSXP)
	ComplexAnswer(args, &data, call);
    else if (mode == REALSXP)
	RealAnswer(args, &data, call);
    else if (mode == RAWSXP)
	RawAnswer(args, &data, call);
    else if (mode == LGLSXP)
	LogicalAnswer(args, &data, call);
    else /* integer */
	IntegerAnswer(args, &data, call);
    args = t;

    /* Build and attach the names attribute for the returned object. */

    if (data.ans_nnames && data.ans_length > 0) {
	struct NameData nameData;
	PROTECT(data.ans_names = allocVector(STRSXP, data.ans_length));
	if (!recurse) {
	    if (TYPEOF(args) == VECSXP) {
		SEXP names = getAttrib(args, R_NamesSymbol);
		data.ans_nnames = 0;
		nameData.seqno = 0;
		nameData.count = 0;
		for (i = 0; i < n; i++) {
		    NewExtractNames(VECTOR_ELT(args, i), R_NilValue,
				    ItemName(names, i), recurse, &data, &nameData);
		}
	    }
	    else if (TYPEOF(args) == LISTSXP) {
		data.ans_nnames = 0;
		nameData.seqno = 0;
		nameData.count = 0;
		while (args != R_NilValue) {
		    NewExtractNames(CAR(args), R_NilValue,
				    TAG(args), recurse, &data, &nameData);
		    args = CDR(args);
		}
	    }
	}
	else {
	    data.ans_nnames = 0;
	    nameData.seqno = 0;
	    nameData.count = 0;
	    NewExtractNames(args, R_NilValue, R_NilValue, recurse, &data, &nameData);
	}
	setAttrib(ans, R_NamesSymbol, data.ans_names);
	UNPROTECT(1);
    }
    UNPROTECT(2);
    R_FreeStringBufferL(&cbuff);
    return ans;
} /* do_unlist */


/* cbind(deparse.level, ...) and rbind(deparse.level, ...) : */
/* This is a special .Internal */
SEXP attribute_hidden do_bind(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP a, t, obj, method, rho, ans;
    int mode, deparse_level;
    Rboolean compatible = TRUE, anyS4 = FALSE;
    struct BindData data;
    char buf[512];

    /* since R 2.2.0: first argument "deparse.level" */
    deparse_level = asInteger(eval(CAR(args), env));
    Rboolean tryS4 = deparse_level >= 0;
    /* NB: negative deparse_level should otherwise be equivalent to deparse_level == 0,
     * --  as cbind(), rbind() below only check for '== 1' and '== 2'
     * {FIXME: methods should do same} */

    /* Lazy evaluation and method dispatch based on argument types are
     * fundamentally incompatible notions.  The results here are
     * ghastly.
     *
     * We build promises to evaluate the arguments and then force the
     * promises so that if we dispatch to a closure below, the closure
     * is still in a position to use "substitute" to get the actual
     * expressions which generated the argument (for naming purposes).
     *
     * The dispatch rule here is as follows:
     *
     * 1) For each argument we get the list of possible class
     *	  memberships from the class attribute.
     *
     * 2) We inspect each class in turn to see if there is an
     *	  applicable method.
     *
     * 3) If we find an applicable method we make sure that it is
     *	  identical to any method determined for prior arguments.
     *	  If it is identical, we proceed, otherwise we immediately
     *	  drop through to the default code.
     */

    PROTECT(args = promiseArgs(args, env));

    const char *generic = ((PRIMVAL(op) == 1) ? "cbind" : "rbind");
    const char *klass = "";
    method = R_NilValue;
    for (a = CDR(args); a != R_NilValue; a = CDR(a)) {
	PROTECT(obj = eval(CAR(a), env));
	if (tryS4 && !anyS4 && isS4(obj)) anyS4 = TRUE;
	if (compatible && isObject(obj)) {
	    SEXP classlist = PROTECT(R_data_class2(obj));
	    for (int i = 0; i < length(classlist); i++) {
		const char *s = translateChar(STRING_ELT(classlist, i));
		if(strlen(generic) + strlen(s) + 2 > 512)
		    error(_("class name too long in '%s'"), generic);
		sprintf(buf, "%s.%s", generic, s);
		SEXP classmethod = R_LookupMethod(install(buf), env, env,
						  R_BaseNamespace);
		if (classmethod != R_UnboundValue) {
		    if (klass[0] == '\0') {
			/* There is no previous class */
			/* We use this method. */
			klass = s;
			method = classmethod;
		    }
		    else {
			/* Check compatibility with the */
			/* previous class.  If the two are not */
			/* compatible we drop through to the */
			/* default method. */
			if (strcmp(klass, s)) {
			    method = R_NilValue;
			    compatible = FALSE;
			}
		    }
		    break; /* go to next parameter */
		}
	    }
	    UNPROTECT(1);
	}
	UNPROTECT(1);
    }

    tryS4 = anyS4 && (!compatible || method == R_NilValue);
    if (tryS4) {
	// keep 'deparse.level' as first arg and *name* it:
	SET_TAG(args, install("deparse.level"));
	// and use methods:::cbind / rbind
	method = findFun(install(generic), R_MethodsNamespace);
    } else
	args = CDR(args); // keeping deparse.level for S4 dispatch
    if (method != R_NilValue) { // found an S3 or S4 method
	PROTECT(method);
	ans = applyClosure(call, method, args, env, R_NilValue);
	UNPROTECT(2);
	return ans;
    }

    /* Dispatch based on class membership has failed. */
    /* The default code for rbind/cbind.default follows */
    /* First, extract the evaluated arguments. */
    rho = env;
    data.ans_flags = 0;
    data.ans_length = 0;
    data.ans_nnames = 0;
    for (t = args; t != R_NilValue; t = CDR(t))
	AnswerType(PRVALUE(CAR(t)), 0, 0, &data, call);

    /* zero-extent matrices shouldn't give NULL, but cbind(NULL) should: */
    if (!data.ans_flags && !data.ans_length) {
	UNPROTECT(1);
	return R_NilValue;
    }

    mode = NILSXP;
    if      (data.ans_flags & 512) mode = EXPRSXP;
    else if (data.ans_flags & 256) mode = VECSXP;
    else if (data.ans_flags & 128) mode = STRSXP;
    else if (data.ans_flags &  64) mode = CPLXSXP;
    else if (data.ans_flags &  32) mode = REALSXP;
    else if (data.ans_flags &  16) mode = INTSXP;
    else if (data.ans_flags &	2) mode = LGLSXP;
    else if (data.ans_flags &	1) mode = RAWSXP;

    switch(mode) {
    case NILSXP:
    case LGLSXP:
    case INTSXP:
    case REALSXP:
    case CPLXSXP:
    case STRSXP:
    case VECSXP:
    case RAWSXP:
	break;
	/* we don't handle expressions: we could, but coercion of a matrix
	   to an expression is not ideal.
	   FIXME?  had  cbind(y ~ x, 1) work using lists, before */
    default:
	error(_("cannot create a matrix from type '%s'"),
	      type2char(mode));
    }

    if (PRIMVAL(op) == 1)
	a = cbind(call, args, mode, rho, deparse_level);
    else
	a = rbind(call, args, mode, rho, deparse_level);
    UNPROTECT(1);
    return a;
}


static void SetRowNames(SEXP dimnames, SEXP x)
{
    if (TYPEOF(dimnames) == VECSXP)
	SET_VECTOR_ELT(dimnames, 0, x);
    else if (TYPEOF(dimnames) == LISTSXP)
	SETCAR(dimnames, x);
}

static void SetColNames(SEXP dimnames, SEXP x)
{
    if (TYPEOF(dimnames) == VECSXP)
	SET_VECTOR_ELT(dimnames, 1, x);
    else if (TYPEOF(dimnames) == LISTSXP)
	SETCADR(dimnames, x);
}

/*
 * Apparently i % 0 could occur here (PR#2541).  But it should not,
 * as zero-length vectors are ignored and
 * zero-length matrices must have zero columns,
 * unless the result has zero rows, hence is of length zero and no
 * copying will be done.
 */
static SEXP cbind(SEXP call, SEXP args, SEXPTYPE mode, SEXP rho,
		  int deparse_level)
{
    Rboolean have_rnames = FALSE, have_cnames = FALSE, warned = FALSE;
    int nnames, mnames;
    int rows, cols, mrows, lenmin = 0;
    SEXP dn, t, u, result, dims, expr;

    nnames = 0;
    mnames = 0;
    rows = 0;
    cols = 0;
    mrows = -1;

    /* check if we are in the zero-row case */

    for (t = args; t != R_NilValue; t = CDR(t)) {
	u = PRVALUE(CAR(t));
	if((isMatrix(u) ? nrows(u) : length(u)) > 0) {
	    lenmin = 1;
	    break;
	}
    }

    /* check conformability of matrix arguments */

    int na = 0;
    for (t = args; t != R_NilValue; t = CDR(t), na++) {
	u = PRVALUE(CAR(t));
	dims = getAttrib(u, R_DimSymbol);
	if (length(dims) == 2) {
	    if (mrows == -1)
		mrows = INTEGER(dims)[0];
	    else if (mrows != INTEGER(dims)[0])
		error(_("number of rows of matrices must match (see arg %d)"),
		      na + 1);
	    cols += INTEGER(dims)[1];
	}
	else if (length(u) >= lenmin) {
	    rows = imax2(rows, length(u));
	    cols += 1;
	}
    }
    if (mrows != -1) rows = mrows;

    /* Check conformability of vector arguments. -- Look for dimnames. */

    for (t = args, na = 0; t != R_NilValue; t = CDR(t), na++) {
	u = PRVALUE(CAR(t));
	dims = getAttrib(u, R_DimSymbol);
	if (length(dims) == 2) {
	    dn = getAttrib(u, R_DimNamesSymbol);
	    if (length(dn) == 2) {
		if (VECTOR_ELT(dn, 1) != R_NilValue)
		    have_cnames = TRUE;
		if (VECTOR_ELT(dn, 0) != R_NilValue)
		    mnames = mrows;
	    }
	} else {
	    int k = length(u);
	    if (!warned && k > 0 && (k > rows || rows % k)) {
		warned = TRUE;
		warning("number of rows of result is not a multiple of vector length (arg %d)", na + 1);
	    }
	    PROTECT(dn = getAttrib(u, R_NamesSymbol));
	    if (k >= lenmin && (TAG(t) != R_NilValue ||
				(deparse_level == 2) ||
				((deparse_level == 1) &&
				 isSymbol(substitute(CAR(t),R_NilValue)))))
		have_cnames = TRUE;
	    nnames = imax2(nnames, length(dn));
	    UNPROTECT(1); /* dn */
	}
    }
    if (mnames || nnames == rows)
	have_rnames = TRUE;

    PROTECT(result = allocMatrix(mode, rows, cols));
    R_xlen_t n = 0; // index, possibly of long vector

    if (mode == STRSXP) {
	for (t = args; t != R_NilValue; t = CDR(t)) {
	    u = PRVALUE(CAR(t));
	    if (isMatrix(u) || length(u) >= lenmin) {
		u = coerceVector(u, STRSXP);
		R_xlen_t k = XLENGTH(u);
		R_xlen_t idx = (!isMatrix(u)) ? rows : k;
		xcopyStringWithRecycle(result, u, n, idx, k);
		n += idx;
	    }
	}
    }
    else if (mode == VECSXP) {
	for (t = args; t != R_NilValue; t = CDR(t)) {
	    u = PRVALUE(CAR(t));
	    int umatrix = isMatrix(u); /* might be lost in coercion to VECSXP */
	    if (umatrix || length(u) >= lenmin) {
		/* we cannot assume here that coercion will work */
		switch(TYPEOF(u)) {
		case NILSXP:
		case LANGSXP:
		case RAWSXP:
		case LGLSXP:
		case INTSXP:
		case REALSXP:
		case CPLXSXP:
		case STRSXP:
		case VECSXP:
		case LISTSXP:
		    PROTECT(u = coerceVector(u, mode));
		    R_xlen_t k = XLENGTH(u);
		    if (k > 0) {
			R_xlen_t idx = (!umatrix) ? rows : k;
			R_xlen_t i, i1;
			MOD_ITERATE1(idx, k, i, i1, {
			    SET_VECTOR_ELT(result, n++,
				lazy_duplicate(VECTOR_ELT(u, i1)));
			});
		    }
		    UNPROTECT(1);
		    break;
		default:
		    for (int i = 0; i < rows; i++)
			SET_VECTOR_ELT(result, n++, lazy_duplicate(u));
		}
	    }
	}
    }
    else if (mode == CPLXSXP) {
	for (t = args; t != R_NilValue; t = CDR(t)) {
	    u = PRVALUE(CAR(t));
	    if (isMatrix(u) || length(u) >= lenmin) {
		u = coerceVector(u, CPLXSXP);
		R_xlen_t k = XLENGTH(u);
		R_xlen_t idx = (!isMatrix(u)) ? rows : k;
		xcopyComplexWithRecycle(COMPLEX(result), COMPLEX(u), n, idx, k);
		n += idx;
	    }
	}
    }
    else if (mode == RAWSXP) {
	for (t = args; t != R_NilValue; t = CDR(t)) {
	    u = PRVALUE(CAR(t));
	    if (isMatrix(u) || length(u) >= lenmin) {
		u = coerceVector(u, RAWSXP);
		R_xlen_t k = XLENGTH(u);
		R_xlen_t idx = (!isMatrix(u)) ? rows : k;
		xcopyRawWithRecycle(RAW(result), RAW(u), n, idx, k);
		n += idx;
	    }
	}
    }
    else { /* everything else, currently REALSXP, INTSXP, LGLSXP */
	for (t = args; t != R_NilValue; t = CDR(t)) {
	    u = PRVALUE(CAR(t)); /* type of u can be any of: RAW, LGL, INT, REAL, or NULL */
	    if (isMatrix(u) || length(u) >= lenmin) {
		R_xlen_t k = xlength(u); /* use xlength since u can be NULL */
		R_xlen_t idx = (!isMatrix(u)) ? rows : k;
		if (TYPEOF(u) <= INTSXP) { /* INT or LGL */
		    if (mode <= INTSXP) {
			xcopyIntegerWithRecycle(INTEGER(result), INTEGER(u),
						n, idx, k);
			n += idx;
		    }
		    else {
			R_xlen_t i, i1;
			MOD_ITERATE1(idx, k, i, i1, {
			    REAL(result)[n++] =
				(INTEGER(u)[i1]) == NA_INTEGER ? NA_REAL : INTEGER(u)[i1];
			});
		    }
		}
		else if (TYPEOF(u) == REALSXP) {
		    xcopyRealWithRecycle(REAL(result), REAL(u), n, idx, k);
		    n += idx;
		}
		else { /* RAWSXP */
		    /* FIXME: I'm not sure what the author intended when the sequence was
		       defined as raw < logical -- it is possible to represent logical as
		       raw losslessly but not vice versa. So due to the way this was
		       defined the raw -> logical conversion is bound to be lossy .. */
		    if (mode == LGLSXP) {
			R_xlen_t i, i1;
			MOD_ITERATE1(idx, k, i, i1, {
			    LOGICAL(result)[n++] = RAW(u)[i1] ? TRUE : FALSE;
			});
		    } else if (mode == INTSXP) {
			R_xlen_t i, i1;
			MOD_ITERATE1(idx, k, i, i1, {
			    INTEGER(result)[n++] = (unsigned char) RAW(u)[i1];
			});
		    } else if (mode == REALSXP) {
			R_xlen_t i, i1;
			MOD_ITERATE1(idx, k, i, i1, {
			    REAL(result)[n++] = (unsigned char) RAW(u)[i1];
			});
		    } else
			/* not sure this can be reached, but to be safe: */
			error(_("cannot create a matrix of type '%s'"),
			      type2char(mode));
		}
	    }
	}
    }

    /* Adjustment of dimnames attributes. */
    if (have_cnames || have_rnames) {
	SEXP nam, tnam,v;
	PROTECT(dn = allocVector(VECSXP, 2));
	if (have_cnames)
	    nam = SET_VECTOR_ELT(dn, 1, allocVector(STRSXP, cols));
	else
	    nam = R_NilValue;	/* -Wall */
	int j = 0;
	for (t = args; t != R_NilValue; t = CDR(t)) {
	    u = PRVALUE(CAR(t));
	    if (isMatrix(u)) {
		v = getAttrib(u, R_DimNamesSymbol);

		if (have_rnames &&
		    GetRowNames(dn) == R_NilValue &&
		    GetRowNames(v) != R_NilValue)
		    SetRowNames(dn, lazy_duplicate(GetRowNames(v)));

		/* rbind() does this only  if(have_?names) .. : */
		/* but if tnam is non-null, have_cnames = TRUE: see above */
		tnam = GetColNames(v);
		if (tnam != R_NilValue) {
		    for (int i = 0; i < length(tnam); i++)
			SET_STRING_ELT(nam, j++, STRING_ELT(tnam, i));
		}
		else if (have_cnames) {
		    for (int i = 0; i < ncols(u); i++)
			SET_STRING_ELT(nam, j++, R_BlankString);
		}
	    } else if (length(u) >= lenmin) {
		u = getAttrib(u, R_NamesSymbol);

		if (have_rnames && GetRowNames(dn) == R_NilValue
		    && u != R_NilValue && length(u) == rows)
		    SetRowNames(dn, lazy_duplicate(u));

		if (TAG(t) != R_NilValue)
		    SET_STRING_ELT(nam, j++, PRINTNAME(TAG(t)));
		else {
		    expr = substitute(CAR(t), R_NilValue);
		    if (deparse_level == 1 && isSymbol(expr))
			SET_STRING_ELT(nam, j++, PRINTNAME(expr));
		    else if (deparse_level == 2) {
			PROTECT(expr);
			SET_STRING_ELT(nam, j++,
				       STRING_ELT(deparse1line(expr, TRUE), 0));
			UNPROTECT(1); /* expr */
		    } else if (have_cnames)
			SET_STRING_ELT(nam, j++, R_BlankString);
		}
	    }
	}
	setAttrib(result, R_DimNamesSymbol, dn);
	UNPROTECT(1);
    }
    UNPROTECT(1);
    return result;
} /* cbind */

static SEXP rbind(SEXP call, SEXP args, SEXPTYPE mode, SEXP rho,
		  int deparse_level)
{
    Rboolean have_rnames = FALSE, have_cnames = FALSE, warned = FALSE;
    int nnames, mnames;
    int rows, cols, mcols, lenmin = 0;
    SEXP dn, t, u, result, dims, expr;

    nnames = 0;
    mnames = 0;
    rows = 0;
    cols = 0;
    mcols = -1;

    /* check if we are in the zero-cols case */

    for (t = args; t != R_NilValue; t = CDR(t)) {
	u = PRVALUE(CAR(t));
	if((isMatrix(u) ? ncols(u) : length(u)) > 0) {
	    lenmin = 1;
	    break;
	}
    }

    /* check conformability of matrix arguments */

    int na = 0;
    for (t = args; t != R_NilValue; t = CDR(t), na++) {
	u = PRVALUE(CAR(t));
	dims = getAttrib(u, R_DimSymbol);
	if (length(dims) == 2) {
	    if (mcols == -1)
		mcols = INTEGER(dims)[1];
	    else if (mcols != INTEGER(dims)[1])
		error(_("number of columns of matrices must match (see arg %d)"),
		      na + 1);
	    rows += INTEGER(dims)[0];
	}
	else if (length(u) >= lenmin){
	    cols = imax2(cols, length(u));
	    rows += 1;
	}
    }
    if (mcols != -1) cols = mcols;

    /* Check conformability of vector arguments. -- Look for dimnames. */

    na = 0;
    for (t = args; t != R_NilValue; t = CDR(t), na++) {
	u = PRVALUE(CAR(t));
	dims = getAttrib(u, R_DimSymbol);
	if (length(dims) == 2) {
	    dn = getAttrib(u, R_DimNamesSymbol);
	    if (length(dn) == 2) {
		if (VECTOR_ELT(dn, 0) != R_NilValue)
		    have_rnames = TRUE;
		if (VECTOR_ELT(dn, 1) != R_NilValue)
		    mnames = mcols;
	    }
	}
	else {
	    int k = length(u);
	    if (!warned && k>0 && (k > cols || cols % k)) {
		warned = TRUE;
		warning("number of columns of result is not a multiple of vector length (arg %d)", na + 1);
	    }
	    PROTECT(dn = getAttrib(u, R_NamesSymbol));
	    if (k >= lenmin && (TAG(t) != R_NilValue ||
				(deparse_level == 2) ||
				((deparse_level == 1) &&
				 isSymbol(substitute(CAR(t),R_NilValue)))))
		have_rnames = TRUE;
	    nnames = imax2(nnames, length(dn));
	    UNPROTECT(1); /* dn */
	}
    }
    if (mnames || nnames == cols)
	have_cnames = TRUE;

    PROTECT(result = allocMatrix(mode, rows, cols));

    R_xlen_t n = 0;

    if (mode == STRSXP) {
	for (t = args; t != R_NilValue; t = CDR(t)) {
	    u = PRVALUE(CAR(t));
	    if (isMatrix(u) || length(u) >= lenmin) {
		u = coerceVector(u, STRSXP);
		R_xlen_t k = XLENGTH(u);
		R_xlen_t idx = (isMatrix(u)) ? nrows(u) : (k > 0);
		xfillStringMatrixWithRecycle(result, u, n, rows, idx, cols, k);
		n += idx;
	    }
	}
    }
    else if (mode == VECSXP) {
	for (t = args; t != R_NilValue; t = CDR(t)) {
	    u = PRVALUE(CAR(t));
	    int umatrix = isMatrix(u), urows = umatrix ? nrows(u) : 1; /* coercing to VECSXP will lose these. PR#15468 */
	    if (umatrix || length(u) >= lenmin) {
		PROTECT(u = coerceVector(u, mode));
		R_xlen_t k = XLENGTH(u);
		R_xlen_t idx = umatrix ? urows : (k > 0);
		FILL_MATRIX_ITERATE(n, rows, idx, cols, k)
		    SET_VECTOR_ELT(result, didx,
			lazy_duplicate(VECTOR_ELT(u, sidx)));
		n += idx;
		UNPROTECT(1);
	    }
	}
    }
    else if (mode == RAWSXP) {
	for (t = args; t != R_NilValue; t = CDR(t)) {
	    u = PRVALUE(CAR(t));
	    if (isMatrix(u) || length(u) >= lenmin) {
		u = coerceVector(u, RAWSXP);
		R_xlen_t k = XLENGTH(u);
		R_xlen_t idx = (isMatrix(u)) ? nrows(u) : (k > 0);
		xfillRawMatrixWithRecycle(RAW(result), RAW(u), n, rows, idx,
					  cols, k);
		n += idx;
	    }
	}
    }
    else if (mode == CPLXSXP) {
	for (t = args; t != R_NilValue; t = CDR(t)) {
	    u = PRVALUE(CAR(t));
	    if (isMatrix(u) || length(u) >= lenmin) {
		u = coerceVector(u, CPLXSXP);
		R_xlen_t k = XLENGTH(u);
		R_xlen_t idx = (isMatrix(u)) ? nrows(u) : (k > 0);
		xfillComplexMatrixWithRecycle(COMPLEX(result), COMPLEX(u), n,
					      rows, idx, cols, k);
		n += idx;
	    }
	}
    }
    else { /* everything else, currently REALSXP, INTSXP, LGLSXP */
	for (t = args; t != R_NilValue; t = CDR(t)) {
	    u = PRVALUE(CAR(t)); /* type of u can be any of: RAW, LGL, INT, REAL */
	    if (isMatrix(u) || length(u) >= lenmin) {
		R_xlen_t k = XLENGTH(u);
		R_xlen_t idx = (isMatrix(u)) ? nrows(u) : (k > 0);
		if (TYPEOF(u) <= INTSXP) {
		    if (mode <= INTSXP) {
			xfillIntegerMatrixWithRecycle(INTEGER(result),
						      INTEGER(u), n, rows,
						      idx, cols, k);
			n += idx;
		    }
		    else {
			FILL_MATRIX_ITERATE(n, rows, idx, cols, k)
			    REAL(result)[didx]
				= (INTEGER(u)[sidx]) == NA_INTEGER ? NA_REAL : INTEGER(u)[sidx];
			n += idx;
		    }
		}
		else if (TYPEOF(u) == REALSXP) {
		    xfillRealMatrixWithRecycle(REAL(result), REAL(u), n,
					       rows, idx, cols, k);
		    n += idx;
		}
		else { /* RAWSXP */
		    if (mode == LGLSXP) {
			FILL_MATRIX_ITERATE(n, rows, idx, cols, k)
			    LOGICAL(result)[didx] = RAW(u)[sidx] ? TRUE : FALSE;
		    }
		    else
			FILL_MATRIX_ITERATE(n, rows, idx, cols, k)
			    INTEGER(result)[didx] = (unsigned char) RAW(u)[sidx];
		}
	    }
	}
    }

    /* Adjustment of dimnames attributes. */
    if (have_rnames || have_cnames) {
	SEXP nam, tnam,v;
	PROTECT(dn = allocVector(VECSXP, 2));
	if (have_rnames)
	    nam = SET_VECTOR_ELT(dn, 0, allocVector(STRSXP, rows));
	else
	    nam = R_NilValue;	/* -Wall */
	int j = 0;
	for (t = args; t != R_NilValue; t = CDR(t)) {
	    u = PRVALUE(CAR(t));
	    if (isMatrix(u)) {
		v = getAttrib(u, R_DimNamesSymbol);

		if (have_cnames &&
		    GetColNames(dn) == R_NilValue &&
		    GetColNames(v) != R_NilValue)
		    SetColNames(dn, lazy_duplicate(GetColNames(v)));

		/* cbind() doesn't test have_?names BEFORE tnam!=Nil..:*/
		/* but if tnam is non-null, have_rnames = TRUE: see above */
		tnam = GetRowNames(v);
		if (have_rnames) {
		    if (tnam != R_NilValue) {
			for (int i = 0; i < length(tnam); i++)
			    SET_STRING_ELT(nam, j++, STRING_ELT(tnam, i));
		    }
		    else {
			for (int i = 0; i < nrows(u); i++)
				SET_STRING_ELT(nam, j++, R_BlankString);
		    }
		}
	    }
	    else if (length(u) >= lenmin) {
		u = getAttrib(u, R_NamesSymbol);

		if (have_cnames && GetColNames(dn) == R_NilValue
		    && u != R_NilValue && length(u) == cols)
		    SetColNames(dn, lazy_duplicate(u));

		if (TAG(t) != R_NilValue)
		    SET_STRING_ELT(nam, j++, PRINTNAME(TAG(t)));
		else {
		    expr = substitute(CAR(t), R_NilValue);
		    if (deparse_level == 1 && isSymbol(expr))
			SET_STRING_ELT(nam, j++, PRINTNAME(expr));
		    else if (deparse_level == 2) {
			PROTECT(expr);
			SET_STRING_ELT(nam, j++,
				       STRING_ELT(deparse1line(expr, TRUE), 0));
			UNPROTECT(1); /* expr */
		    } else if (have_rnames)
			SET_STRING_ELT(nam, j++, R_BlankString);
		}
	    }
	}
	setAttrib(result, R_DimNamesSymbol, dn);
	UNPROTECT(1);
    }
    UNPROTECT(1);
    return result;
} /* rbind */