isoreg(c(0,Inf)) now gives error instead of seg.fault

git-svn-id: https://svn.r-project.org/R/trunk@85229 00db46b3-68df-0310-9c12-caf00c1e9a41
r-devel · Sep 29, 2023 · 25319a5 · 25319a5
1 parent 8e8f1b5
commit 25319a5
Show file tree

Hide file tree

Showing 3 changed files with 23 additions and 12 deletions.
diff --git a/doc/NEWS.Rd b/doc/NEWS.Rd
@@ -465,6 +465,9 @@
 
       \item \code{postscript()} refused to accept a \code{title} comment
       containing the letter \dQuote{W} (\PR{18599}).
+
+      \item \code{isoreg(c(1,Inf))} signals an error instead of
+      segfaulting, fixing \PR{18603}.
     }
   }
 }

diff --git a/src/library/stats/src/isoreg.c b/src/library/stats/src/isoreg.c
@@ -3,7 +3,8 @@
  * Copyright (C) 1995  Brian Ripley
  * ---
  *  R : A Computer Language for Statistical Data Analysis
- *  Copyright (C) 2003	The R Foundation
+ *  Copyright (C) 2003-2023	The R Core Team
+ *  Copyright (C) 2003-2023	The R Foundation
  *
  *  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
@@ -24,13 +25,10 @@
 
 SEXP isoreg(SEXP y)
 {
-    int n = LENGTH(y), i, ip, known, n_ip;
-    double tmp, slope;
+    R_xlen_t n = XLENGTH(y), i;
     SEXP yc, yf, iKnots, ans;
     const char *anms[] = {"y", "yc", "yf", "iKnots", ""};
 
-    /* unneeded: y = coerceVector(y, REALSXP); */
-
     PROTECT(ans = mkNamed(VECSXP, anms));
 
     SET_VECTOR_ELT(ans, 0, y);
@@ -43,16 +41,19 @@ SEXP isoreg(SEXP y)
 	return ans; /* avoid segfault below */
     }
 
+    /* unneeded: y = coerceVector(y, REALSXP); */
     /* yc := cumsum(0,y) */
     REAL(yc)[0] = 0.;
-    tmp = 0.;
+    double tmp = 0.;
     for (i = 0; i < n; i++) {
 	tmp += REAL(y)[i];
 	REAL(yc)[i + 1] = tmp;
     }
-    known = 0; ip = 0, n_ip = 0;
+    if(!R_FINITE(REAL(yc)[n]))
+	 error(_("non-finite sum(y) == %g is not allowed"), REAL(yc)[n]);
+    R_xlen_t known = 0, ip = 0, n_ip = 0;
     do {
-	slope = R_PosInf;/*1e+200*/
+	double slope = R_PosInf;/*1e+200*/
 	for (i = known + 1; i <= n; i++) {
 	    tmp = (REAL(yc)[i] - REAL(yc)[known]) / (i - known);
 	    if (tmp < slope) {

diff --git a/tests/reg-tests-1e.R b/tests/reg-tests-1e.R
@@ -818,14 +818,14 @@ kz2La
 all.equal(0.058131632, (rcTm <- rcond(zm, triangular=TRUE          )), tol=0) # 3.178e-9
 all.equal(0.047891278, (rcTL <- rcond(zm, triangular=TRUE, uplo="L")), tol=0) # 4.191e-9
 ## New: can use norm "M" or "F" for exact=TRUE:
-(kz <- kappa(zm, norm="M", exact = TRUE)) # 2.440468 
-(kF <- kappa(zm, norm="F", exact = TRUE)) # 6.448678 
+(kz <- kappa(zm, norm="M", exact = TRUE)) # 2.440468
+(kF <- kappa(zm, norm="F", exact = TRUE)) # 6.448678
 stopifnot(exprs = {
     all.equal(7.8370264, kz1d) # was wrong {wrongly using .kappa_tri()}
     all.equal(6.6194289, kz1)  # {always ok}
     all.equal(0.058131632, rcTm) #  "
     all.equal(0.047891278, rcTL)
-    all.equal(6.82135883, kzqr2)    
+    all.equal(6.82135883, kzqr2)
     all.equal(2.44046765, kz, tol = 1e-9) # 1.8844e-10
     all.equal(6.44867822, kF, tol = 4e-9) # 4.4193e-10
 })
@@ -853,17 +853,24 @@ stopifnot(exprs = {
 ## in all three cases, "A-1" inadvertently became "A.1" in R < 4.4.0
 
 
-## byte compiled sqrt() was not warling about creating NaNs for
+## byte compiled sqrt() was not warning about creating NaNs for
 ## negative integer scalars
 tools::assertWarning(compiler::cmpfun(function(x) sqrt(x))(-1L))
 
+
 ## is.atomic(NULL) is no longer true
 if(is.atomic(NULL)) stop("Should no longer happen: 'NULL' is not atomic")
 ## untested previously
 stopifnot(is.null(sort(NULL)), is.null(sort.int(NULL)))
 ## failed in first version of `R-is` branch
 
 
+## isoreg() seg.faulted with Inf - PR#18603 - in R <= 4.3.1
+assertErrV(isoreg(Inf))
+assertErrV(isoreg(c(0,Inf)))
+assertErrV(isoreg(rep(1e307, 20))) # no Inf in 'y'
+## ==> Asserted error: non-finite sum(y) == inf is not allowed
+
 
 ## keep at end
 rbind(last =  proc.time() - .pt,