in source/src/main/subassign.c [222:406]
static int SubassignTypeFix(SEXP *x, SEXP *y, R_xlen_t stretch, int level,
SEXP call, SEXP rho)
{
/* A rather pointless optimization, but level 2 used to be handled
differently */
Rboolean redo_which = TRUE;
int which = 100 * TYPEOF(*x) + TYPEOF(*y);
/* coercion can lose the object bit */
Rboolean x_is_object = OBJECT(*x);
switch (which) {
case 1000: /* logical <- null */
case 1300: /* integer <- null */
case 1400: /* real <- null */
case 1500: /* complex <- null */
case 1600: /* character <- null */
case 1900: /* vector <- null */
case 2000: /* expression <- null */
case 2400: /* raw <- null */
case 1010: /* logical <- logical */
case 1310: /* integer <- logical */
case 1410: /* real <- logical */
case 1510: /* complex <- logical */
case 1313: /* integer <- integer */
case 1413: /* real <- integer */
case 1513: /* complex <- integer */
case 1414: /* real <- real */
case 1514: /* complex <- real */
case 1515: /* complex <- complex */
case 1616: /* character <- character */
case 1919: /* vector <- vector */
case 2020: /* expression <- expression */
case 2424: /* raw <- raw */
redo_which = FALSE;
break;
case 1013: /* logical <- integer */
*x = coerceVector(*x, INTSXP);
break;
case 1014: /* logical <- real */
case 1314: /* integer <- real */
*x = coerceVector(*x, REALSXP);
break;
case 1015: /* logical <- complex */
case 1315: /* integer <- complex */
case 1415: /* real <- complex */
*x = coerceVector(*x, CPLXSXP);
break;
case 1610: /* character <- logical */
case 1613: /* character <- integer */
case 1614: /* character <- real */
case 1615: /* character <- complex */
*y = coerceVector(*y, STRSXP);
break;
case 1016: /* logical <- character */
case 1316: /* integer <- character */
case 1416: /* real <- character */
case 1516: /* complex <- character */
*x = coerceVector(*x, STRSXP);
break;
case 1901: /* vector <- symbol */
case 1902: /* vector <- pairlist */
case 1904: /* vector <- environment */
case 1905: /* vector <- promise */
case 1906: /* vector <- language */
case 1910: /* vector <- logical */
case 1913: /* vector <- integer */
case 1914: /* vector <- real */
case 1915: /* vector <- complex */
case 1916: /* vector <- character */
case 1920: /* vector <- expression */
case 1921: /* vector <- bytecode */
case 1922: /* vector <- external pointer */
case 1923: /* vector <- weak reference */
case 1924: /* vector <- raw */
case 1903: case 1907: case 1908: case 1999: /* functions */
if (level == 1) {
/* Coerce the RHS into a list */
*y = coerceVector(*y, VECSXP);
} else {
/* Nothing to do here: duplicate when used (if needed) */
redo_which = FALSE;
}
break;
case 1925: /* vector <- S4 */
if (level == 1) {
/* Embed the RHS into a list */
*y = embedInVector(*y, call);
} else {
/* Nothing to do here: duplicate when used (if needed) */
redo_which = FALSE;
}
break;
case 1019: /* logical <- vector */
case 1319: /* integer <- vector */
case 1419: /* real <- vector */
case 1519: /* complex <- vector */
case 1619: /* character <- vector */
case 2419: /* raw <- vector */
*x = coerceVector(*x, VECSXP);
break;
case 1020: /* logical <- expression */
case 1320: /* integer <- expression */
case 1420: /* real <- expression */
case 1520: /* complex <- expression */
case 1620: /* character <- expression */
case 2420: /* raw <- expression */
*x = coerceVector(*x, EXPRSXP);
break;
case 2001: /* expression <- symbol */
case 2002: /* expression <- pairlist */
case 2006: /* expression <- language */
case 2010: /* expression <- logical */
case 2013: /* expression <- integer */
case 2014: /* expression <- real */
case 2015: /* expression <- complex */
case 2016: /* expression <- character */
case 2019: /* expression <- vector */
if (level == 1) {
/* Coerce the RHS into a list */
*y = coerceVector(*y, VECSXP);
} else {
/* Note : No coercion is needed here. */
/* We just insert the RHS into the LHS. */
redo_which = FALSE;
}
break;
case 2025: /* expression <- S4 */
if (level == 1) {
/* Embed the RHS into a list */
*y = embedInVector(*y, call);
} else {
/* Nothing to do here: duplicate when used (if needed) */
redo_which = FALSE;
}
break;
case 1025: /* logical <- S4 */
case 1325: /* integer <- S4 */
case 1425: /* real <- S4 */
case 1525: /* complex <- S4 */
case 1625: /* character <- S4 */
case 2425: /* raw <- S4 */
if (dispatch_asvector(y, call, rho)) {
return SubassignTypeFix(x, y, stretch, level, call, rho);
}
default:
error(_("incompatible types (from %s to %s) in subassignment type fix"),
type2char(which%100), type2char(which/100));
}
if (stretch) {
PROTECT(*y);
*x = EnlargeVector(*x, stretch);
UNPROTECT(1);
}
SET_OBJECT(*x, x_is_object);
if(redo_which)
return(100 * TYPEOF(*x) + TYPEOF(*y));
else
return(which);
}