fix some problems with [rc]bind, increase test coverage

git-svn-id: https://svn.r-project.org/R/trunk@87390 00db46b3-68df-0310-9c12-caf00c1e9a41

Author: ripley

doc/NEWS.Rd

@@ -389,12 +389,16 @@
 
       \item \code{options(scipen = NULL)} and other invalid values now
       signal an error instead of invalidating ops relying on a finite
-      integer value.  Newly, values outside the range -9 .. 9999 are warned
+      integer value.  Newly values outside the range -9 .. 9999 are warned
       about and set to a respective boundary or to the default \code{0},
       e.g., in case of an \code{NA}.
 
-      \item \code{isGeneric(fdef = print)} now works, fixing \PR{18369} thanks to
-      \I{Mikael Jagan}.
+      \item \code{isGeneric(fdef = print)} now works, fixing \PR{18369}
+      thanks to \I{Mikael Jagan}.
+
+      \item \code{cbind()} could segfault with \code{NULL} inputs.
+      (Seen when \R was built with \command{gcc14}, LTO and C99 inlining
+      semantics.)
     }
   }
 }
@@ -430,7 +434,11 @@
       \item The parser now accepts hexadecimal constants with a decimal
       point without an exponent (taken as \code{p0}) as documented in
       \code{?NumericConstants} (\PR{18819}).
-    }
+
+      \item \code{cbind()} now works correctly when inputs include a raw
+      vector and a logical, integer or double vector: previously the
+      includsion of latter was garbled.
+     }
   }
 }
 

src/main/bind.c

@@ -1366,10 +1366,11 @@ static SEXP cbind(SEXP call, SEXP args, SEXPTYPE mode, SEXP rho,
 	    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) { /* NILSXP or INT or LGL */
+		if (idx > 0 && TYPEOF(u) <= INTSXP) {
+		    /* NILSXP or INT or LGL
 		    /* taking INTERER(NILSXP) should segfault, and
-		     * sometimes does.  But if cbinding a NULL, there
-		     * are zero rows so nothing to do. */
+		     * sometimes does.  But if cbind-ing a NULL, there
+		     * are zero rows and u is not a matrix, so nothing to do. */
 		    if (mode <= INTSXP) {
 			xcopyIntegerWithRecycle(INTEGER(result), INTEGER(u),
 						n, idx, k);
@@ -1618,46 +1619,47 @@ static SEXP rbind(SEXP call, SEXP args, SEXPTYPE mode, SEXP rho,
 	    }
 	}
     }
-    else { /* everything else, currently NILSXP,  REALSXP, INTSXP, LGLSXP */
+    else if (mode == INTSXP) {
 	for (t = args; t != R_NilValue; t = CDR(t)) {
-	    u = PRVALUE(CAR(t)); /* type of u can be any of: RAW, LGL, INT, REAL */
+	    u = PRVALUE(CAR(t));
 	    if (isMatrix(u) || length(u) >= lenmin) {
+		u = coerceVector(u, INTSXP);
 		R_xlen_t k = XLENGTH(u);
 		R_xlen_t idx = (isMatrix(u)) ? nrows(u) : (k > 0);
-		if (TYPEOF(u) <= INTSXP) {
-		    /* taking INTERER(NILSXP) should segfault, and
-		     * sometimes does.  But if rbinding a NULL, there
-		     * are zero cols so nothing to do. */
-		    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 // cbind covers INTSXP and RAWSXP, so this is incomplete
-			FILL_MATRIX_ITERATE(n, rows, idx, cols, k)
-			    INTEGER(result)[didx] = (unsigned char) RAW(u)[sidx];
-		}
+		xfillIntegerMatrixWithRecycle(INTEGER(result), INTEGER(u), n, rows, idx,
+					  cols, k);
+		n += idx;
 	    }
 	}
     }
+     else if (mode == LGLSXP) {
+	for (t = args; t != R_NilValue; t = CDR(t)) {
+	    u = PRVALUE(CAR(t));
+	    if (isMatrix(u) || length(u) >= lenmin) {
+		u = coerceVector(u, LGLSXP);
+		R_xlen_t k = XLENGTH(u);
+		R_xlen_t idx = (isMatrix(u)) ? nrows(u) : (k > 0);
+		xfillLogicalMatrixWithRecycle(LOGICAL(result), LOGICAL(u), n, rows, idx,
+					  cols, k);
+		n += idx;
+	    }
+	}
+     }
+     else if (mode == REALSXP) {
+	 for (t = args; t != R_NilValue; t = CDR(t)) {
+	     u = PRVALUE(CAR(t));
+	     if (isMatrix(u) || length(u) >= lenmin) {
+		 u = coerceVector(u, REALSXP);
+		 R_xlen_t k = XLENGTH(u);
+		 R_xlen_t idx = (isMatrix(u)) ? nrows(u) : (k > 0);
+		 xfillRealMatrixWithRecycle(REAL(result), REAL(u), n, rows, idx,
+					  cols, k);
+		 n += idx;
+	     }
+	 }
+     }
+     else { /* everything else, currently NILSXP so do nothing */
+     }
 
     /* Adjustment of dimnames attributes. */
     if (have_rnames || have_cnames) {

tests/reg-tests-1e.R

@@ -1617,6 +1617,49 @@ stopifnot(!isGeneric(fdef = print), !isGeneric(fdef = c), isGeneric(fdef = show)
 ## gave Error  argument "f" is missing ... in R <= 4.4.2
 
 
+## [cr]bind invoilving raw vectors -- follow up to r57065
+x <- as.raw(1:6)
+stopifnot(
+    identical(cbind(x, c(TRUE,FALSE)), cbind(x=rep(TRUE,6), c(TRUE,FALSE))),
+    identical(cbind(x, 1:6), cbind(x=1:6, 1:6)),
+    identical(cbind(x, pi), cbind(x=1:6, pi)),
+    identical(cbind(x, pi+1i), cbind(x=1:6, pi+1i)),
+
+    # first three were wrong before R 4.4.3
+    identical(rbind(x, c(TRUE,FALSE)), rbind(x=rep(TRUE,6), c(TRUE,FALSE))),
+    identical(rbind(x, 1:6), rbind(x=1:6, 1:6)),
+    identical(rbind(x, pi), rbind(x=1:6, pi)),
+    identical(rbind(x, pi+1i), rbind(x=1:6, pi+1i))
+)
+
+
+## [cr]bind had segfaults when R was bui;t for LTO and C99 inlining sematics
+## The semantics (inherited from S) are that zero-length inputs
+## (including NULL) are ignored unless all inputs are zero-length.
+## next four segafaulted
+cbind(NULL, logical(0))
+cbind(NULL, integer(0))
+rbind(NULL, integer(0))
+rbind(NULL, logical(0))
+## and these could have
+cbind(NULL, double(0))
+cbind(NULL, complex(0))
+rbind(NULL, double(0))
+rbind(NULL, complex(0))
+## and check some other edge cases
+(X <- matrix(integer(0),2,0))
+stopifnot(
+    is.null(cbind(NULL)),
+    is.null(rbind(NULL)),
+    is.null(cbind(NULL, NULL)),
+    is.null(rbind(NULL, NULL)),
+    dim(cbind(NULL, pi)) == c(1L, 1L),
+    dim(rbind(NULL, pi)) == c(1L, 1L),
+    # zero-length inputs are ignored except for zero-length result
+    identical(cbind(X, X), X),
+    identical(cbind(X, 1:2), matrix(1:2))
+)
+
 
 ## keep at end
 rbind(last =  proc.time() - .pt,