Repent and make overly large integerish

constants non-fatal.  They are now promoted
to NVs, accompanied by an overflow warning that
is by default on.

p4raw-id: //depot/cfgperl@3832

1 files changed, 121 insertions, 52 deletions

diff --git a/util.c b/util.c
index 6fc3d8ff2e..4ef55f207a 100644
--- a/util.c
+++ b/util.c
@@ -2776,24 +2776,23 @@ Perl_same_dirent(pTHX_ char *a, char *b)
 }
 #endif /* !HAS_RENAME */
 
-UV
+NV
 Perl_scan_bin(pTHX_ char *start, I32 len, I32 *retlen)
 {
     register char *s = start;
-    register UV retval = 0;
-    register UV n;
-    register I32 d = 0;
+    register NV rnv = 0.0;
+    register UV ruv = 0;
     register bool seenb = FALSE;
-    register bool overflow = FALSE;
+    register bool overflowed = FALSE;
+    char *nonzero = NULL;
 
     for (; len-- && *s; s++) {
 	if (!(*s == '0' || *s == '1')) {
 	    if (*s == '_')
-		continue;
-	    if (seenb == FALSE && *s == 'b' && retval == 0) {
+		continue; /* Note: does not check for __ and the like. */
+	    if (seenb == FALSE && *s == 'b' && nonzero == NULL) {
 		/* Disallow 0bbb0b0bbb... */
 		seenb = TRUE;
-		d = 0; /* Forget any leading zeros before the 'b'. */
 		continue;
 	    }
 	    else {
@@ -2803,36 +2802,59 @@ Perl_scan_bin(pTHX_ char *start, I32 len, I32 *retlen)
 				"Illegal binary digit '%c' ignored", *s);
 		break;
 	    }
+	} else {
+	    if (nonzero == NULL && *s != '0')
+		nonzero = s;
+	}
+	if (!overflowed) {
+	    register UV xuv = ruv << 1;
+
+	    if ((xuv >> 1) != ruv) {
+		dTHR;
+		overflowed = TRUE;
+		rnv = (NV) ruv;
+		if (ckWARN_d(WARN_UNSAFE))
+		    Perl_warner(aTHX_ WARN_UNSAFE,
+				"Integer overflow in binary number");
+	    } else
+		ruv = xuv | (*s - '0');
+	}
+	if (overflowed) {
+	    rnv *= 2;
+	    /* If an NV has not enough bits in its mantissa to
+	     * represent an UV this summing of small low-order numbers
+	     * is a waste of time (because the NV cannot preserve
+	     * the low-order bits anyway): we could just remember when
+	     * did we overflow and in the end just multiply rnv by the
+	     * right amount of 16-tuples. */
+	    rnv += (*s - '0');
 	}
-	n = retval << 1;
-	overflow |= (n >> 1) != retval;
-	retval = n | (*s - '0');
-	d++;
     }
-    if (sizeof(UV) > 4 && d > 32) {
+    if (!overflowed)
+	rnv = (NV) ruv;
+    if (sizeof(UV) > 4 && nonzero && (s - nonzero) > 32) {
 	dTHR;
 	if (ckWARN(WARN_UNSAFE))
 	    Perl_warner(aTHX_ WARN_UNSAFE,
 			"Binary number > 0b11111111111111111111111111111111 non-portable");
     }
-    if (overflow)
-	Perl_croak(aTHX_ "Integer overflow in binary number");
     *retlen = s - start;
-    return retval;
+    return rnv;
 }
-UV
+
+NV
 Perl_scan_oct(pTHX_ char *start, I32 len, I32 *retlen)
 {
     register char *s = start;
-    register UV retval = 0;
-    register UV n;
-    register I32 d = 0;
-    register bool overflow = FALSE;
+    register NV rnv = 0.0;
+    register UV ruv = 0;
+    register bool overflowed = FALSE;
+    char *nonzero = NULL;
 
     for (; len-- && *s; s++) {
 	if (!(*s >= '0' && *s <= '7')) {
 	    if (*s == '_')
-		continue;
+		continue; /* Note: does not check for __ and the like. */
 	    else {
 		/* Allow \octal to work the DWIM way (that is, stop scanning
 		 * as soon as non-octal characters are seen, complain only iff
@@ -2846,69 +2868,116 @@ Perl_scan_oct(pTHX_ char *start, I32 len, I32 *retlen)
 		break;
 	    }
 	}
-	n = retval << 3;
-	overflow |= (n >> 3) != retval;
-	retval = n | (*s - '0');
-	d++;
+	else {
+	    if (nonzero == NULL && *s != '0')
+		nonzero = s;
+	}
+	if (!overflowed) {
+	    register xuv = ruv << 3;
+
+	    if ((xuv >> 3) != ruv) {
+		dTHR;
+		overflowed = TRUE;
+		rnv = (NV) ruv;
+		if (ckWARN_d(WARN_UNSAFE))
+		    Perl_warner(aTHX_ WARN_UNSAFE,
+				"Integer overflow in octal number");
+	    } else
+		ruv = xuv | (*s - '0');
+	}
+	if (overflowed) {
+	    rnv *= 8.0;
+	    /* If an NV has not enough bits in its mantissa to
+	     * represent an UV this summing of small low-order numbers
+	     * is a waste of time (because the NV cannot preserve
+	     * the low-order bits anyway): we could just remember when
+	     * did we overflow and in the end just multiply rnv by the
+	     * right amount of 8-tuples. */
+	    rnv += (NV)(*s - '0');
+	}
     }
-    if (sizeof(UV) > 4 && d > 10 && (retval >> 30) > 3) {
+    if (!overflowed)
+	rnv = (NV) ruv;
+    if (sizeof(UV) > 4 &&
+	overflowed ? rnv > 4294967295.0 :
+	(nonzero && (s - nonzero) > 10 && (ruv >> 30) > 3)) {
 	dTHR;
 	if (ckWARN(WARN_UNSAFE))
 	    Perl_warner(aTHX_ WARN_UNSAFE,
 			"Octal number > 037777777777 non-portable");
     }
-    if (overflow)
-	Perl_croak(aTHX_ "Integer overflow in octal number");
     *retlen = s - start;
-    return retval;
+    return rnv;
 }
 
-UV
+NV
 Perl_scan_hex(pTHX_ char *start, I32 len, I32 *retlen)
 {
     register char *s = start;
-    register UV retval = 0;
-    char *tmp = s;
-    register UV n;
-    register I32 d = 0;
+    register NV rnv = 0.0;
+    register UV ruv = 0;
     register bool seenx = FALSE;
-    register bool overflow = FALSE;
+    register bool overflowed = FALSE;
+    char *nonzero = NULL;
+    char *hexdigit;
 
-    while (len-- && *s) {
-	tmp = strchr((char *) PL_hexdigit, *s++);
-	if (!tmp) {
-	    if (*(s-1) == '_')
-		continue;
-	    if (seenx == FALSE && *(s-1) == 'x' && retval == 0) {
+    for (; len-- && *s; s++) {
+	hexdigit = strchr((char *) PL_hexdigit, *s);
+	if (!hexdigit) {
+	    if (*s == '_')
+		continue; /* Note: does not check for __ and the like. */
+	    if (seenx == FALSE && *s == 'x' && nonzero == NULL) {
 		/* Disallow 0xxx0x0xxx... */
 		seenx = TRUE;
-		d = 0; /* Forget any leading zeros before the 'x'. */
 		continue;
 	    }
 	    else {
 		dTHR;
-		--s;
 		if (ckWARN(WARN_UNSAFE))
 		    Perl_warner(aTHX_ WARN_UNSAFE,
 				"Illegal hexadecimal digit '%c' ignored", *s);
 		break;
 	    }
 	}
-	d++;
-	n = retval << 4;
-	overflow |= (n >> 4) != retval;
-	retval = n | ((tmp - PL_hexdigit) & 15);
+	else {
+	    if (nonzero == NULL && *s != '0')
+		nonzero = s;
+	}
+	if (!overflowed) {
+	    register UV xuv = ruv << 4;
+
+	    if ((xuv >> 4) != ruv) {
+		dTHR;
+		overflowed = TRUE;
+		rnv = (NV) ruv;
+		if (ckWARN_d(WARN_UNSAFE))
+		    Perl_warner(aTHX_ WARN_UNSAFE,
+				"Integer overflow in hexadecimal number");
+	    } else
+		ruv = xuv | ((hexdigit - PL_hexdigit) & 15);
+	}
+	if (overflowed) {
+	    rnv *= 16.0;
+	    /* If an NV has not enough bits in its mantissa to
+	     * represent an UV this summing of small low-order numbers
+	     * is a waste of time (because the NV cannot preserve
+	     * the low-order bits anyway): we could just remember when
+	     * did we overflow and in the end just multiply rnv by the
+	     * right amount of 16-tuples. */
+	    rnv += (NV)((hexdigit - PL_hexdigit) & 15);
+	}
     }
-    if (sizeof(UV) > 4 && d > 8) {
+    if (!overflowed)
+	rnv = (NV) ruv;
+    if (sizeof(UV) > 4 &&
+	nonzero && (s - nonzero) > 8) {
 	dTHR;
 	if (ckWARN(WARN_UNSAFE))
 	    Perl_warner(aTHX_ WARN_UNSAFE,
 			"Hexadecimal number > 0xffffffff non-portable");
     }
-    if (overflow)
-	Perl_croak(aTHX_ "Integer overflow in hexadecimal number");
     *retlen = s - start;
-    return retval;
+    return rnv;
 }
 
 char*