From: Jarkko Hietaniemi <jhi@iki.fi>
Date: Thu, 29 Jul 1999 14:02:50 +0000 (+0000)
Subject: Repent and make overly large integerish
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=9e24b6e2f422a9f67d0605cdea60de0c597868f3;p=p5sagit%2Fp5-mst-13.2.git
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
---
diff --git a/embed.pl b/embed.pl
index 6260550..781addb 100755
--- a/embed.pl
+++ b/embed.pl
@@ -1572,10 +1572,10 @@ p |OP* |scalar |OP* o
p |OP* |scalarkids |OP* o
p |OP* |scalarseq |OP* o
p |OP* |scalarvoid |OP* o
-p |UV |scan_bin |char* start|I32 len|I32* retlen
-p |UV |scan_hex |char* start|I32 len|I32* retlen
+p |NV |scan_bin |char* start|I32 len|I32* retlen
+p |NV |scan_hex |char* start|I32 len|I32* retlen
p |char* |scan_num |char* s
-p |UV |scan_oct |char* start|I32 len|I32* retlen
+p |NV |scan_oct |char* start|I32 len|I32* retlen
p |OP* |scope |OP* o
p |char* |screaminstr |SV* bigsv|SV* littlesv|I32 start_shift \
|I32 end_shift|I32 *state|I32 last
diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index 8a4c2d1..624b152 100644
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -134,10 +134,6 @@ C<oct()>:
$answer = 0b101010;
printf "The answer is: %b\n", oct("0b101010");
-=head2 Too large hexadecimal, octal, and binary constants more serious
-
-Too large hexadecimal, octal, and binary constants now cause fatal errors.
-
=head2 syswrite() ease-of-use
The length argument of C<syswrite()> is now optional.
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 7d27fc2..bffd191 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -469,18 +469,9 @@ likely depends on its correct operation, Perl just gave up.
=item Binary number > 0b11111111111111111111111111111111 non-portable
-(W) The binary number you specified is larger than 2**32-1 and
-therefore non-portable between systems. If you know that your code is
-always going to be used only in systems that have more than 32-bit
-integers (which means that Perl should be able to use such), you can
-silence this warning by
-
- {
- no warning 'unsafe';
- .... your code here ...
- }
-
-See also L<perlport> for writing portable code.
+(W) The binary number you specified is larger than 2**32-1
+(4294967295) and therefore non-portable between systems. See
+L<perlport> for more on portability concerns.
=item bind() on closed fd
@@ -1431,18 +1422,9 @@ is now heavily deprecated.
=item Hexadecimal number > 0xffffffff non-portable
-(W) The hexadecimal number you specified is larger than 2**32-1 and
-therefore non-portable between systems. If you know that your code is
-always going to be used only in systems that have more than 32-bit
-integers (which means that Perl should be able to use such), you can
-silence this warning by
-
- {
- no warning 'unsafe';
- .... your code here ...
- }
-
-See also L<perlport> for writing portable code.
+(W) The hexadecimal number you specified is larger than 2**32-1
+(4294967295) and therefore non-portable between systems. See
+L<perlport> for more on portability concerns.
=item Identifier too long
@@ -1558,18 +1540,15 @@ known value, using trustworthy data. See L<perlsec>.
=item Integer overflow in %s number
-(F,X) The hexadecimal, octal or binary number you have specified
-either as a literal in your code or as a scalar is too big for your
-architecture. On a 32-bit architecture the largest literal hex, octal
-or binary number representable without overflow is 0xFFFFFFFF,
-037777777777, or 0b11111111111111111111111111111111 respectively.
-Note that Perl transparently promotes decimal literals to a floating
-point representation internally--subject to loss of precision errors
-in subsequent operations--so this limit usually doesn't apply to
-decimal literals. If the overflow is in a literal of your code, the
-error is untrappable (there is no way the code could work safely in
-your system), if the overflow happens in hex() or oct() the error is
-trappable.
+(W) The hexadecimal, octal or binary number you have specified either
+as a literal in your code or as a scalar is too big for your
+architecture, and has been converted to a floating point number. On a
+32-bit architecture the largest hexadecimal, octal or binary number
+representable without overflow is 0xFFFFFFFF, 037777777777, or
+0b11111111111111111111111111111111 respectively. Note that Perl
+transparently promotes all numbers to a floating point representation
+internally--subject to loss of precision errors in subsequent
+operations.
=item Internal inconsistency in tracking vforks
@@ -1996,16 +1975,9 @@ try using scientific notation (e.g. "1e6" instead of "1_000_000").
=item Octal number > 037777777777 non-portable
-(W) The octal number you specified is larger than 2**32-1 and
-therefore non-portable between systems. If you know that your code is
-always going to be used only in systems that have more than 32-bit
-integers (which means that Perl should be able to use such), you can
-silence this warning by
-
- {
- no warning 'unsafe';
- .... your code here ...
- }
+(W) The octal number you specified is larger than 2**32-1 (4294967295)
+and therefore non-portable between systems. See L<perlport> for more
+on portability concerns.
See also L<perlport> for writing portable code.
diff --git a/pp.c b/pp.c
index 770b07d..18c875b 100644
--- a/pp.c
+++ b/pp.c
@@ -1885,14 +1885,14 @@ PP(pp_hex)
STRLEN n_a;
tmps = POPpx;
- XPUSHu(scan_hex(tmps, sizeof(UV) * 2 + 1, &argtype));
+ XPUSHn(scan_hex(tmps, 99, &argtype));
RETURN;
}
PP(pp_oct)
{
djSP; dTARGET;
- UV value;
+ NV value;
I32 argtype;
char *tmps;
STRLEN n_a;
@@ -1900,15 +1900,15 @@ PP(pp_oct)
tmps = POPpx;
while (*tmps && isSPACE(*tmps))
tmps++;
- /* Do not eat the leading 0[bx] because we need them
- * to detect malformed binary and hexadecimal numbers. */
- if ((tmps[0] == '0' && tmps[1] == 'x') || tmps[0] == 'x')
- value = scan_hex(tmps, sizeof(UV) * 2 + 1, &argtype);
- else if ((tmps[0] == '0' && tmps[1] == 'b') || tmps[0] == 'b')
- value = scan_bin(tmps, sizeof(UV) * 8 + 1, &argtype);
+ if (*tmps == '0')
+ tmps++;
+ if (*tmps == 'x')
+ value = scan_hex(++tmps, 99, &argtype);
+ else if (*tmps == 'b')
+ value = scan_bin(++tmps, 99, &argtype);
else
- value = scan_oct(tmps, sizeof(UV) * 4 + 1, &argtype);
- XPUSHu(value);
+ value = scan_oct(tmps, 99, &argtype);
+ XPUSHn(value);
RETURN;
}
diff --git a/proto.h b/proto.h
index 7bed4c7..9f63491 100644
--- a/proto.h
+++ b/proto.h
@@ -536,10 +536,10 @@ VIRTUAL OP* Perl_scalar(pTHX_ OP* o);
VIRTUAL OP* Perl_scalarkids(pTHX_ OP* o);
VIRTUAL OP* Perl_scalarseq(pTHX_ OP* o);
VIRTUAL OP* Perl_scalarvoid(pTHX_ OP* o);
-VIRTUAL UV Perl_scan_bin(pTHX_ char* start, I32 len, I32* retlen);
-VIRTUAL UV Perl_scan_hex(pTHX_ char* start, I32 len, I32* retlen);
+VIRTUAL NV Perl_scan_bin(pTHX_ char* start, I32 len, I32* retlen);
+VIRTUAL NV Perl_scan_hex(pTHX_ char* start, I32 len, I32* retlen);
VIRTUAL char* Perl_scan_num(pTHX_ char* s);
-VIRTUAL UV Perl_scan_oct(pTHX_ char* start, I32 len, I32* retlen);
+VIRTUAL NV Perl_scan_oct(pTHX_ char* start, I32 len, I32* retlen);
VIRTUAL OP* Perl_scope(pTHX_ OP* o);
VIRTUAL char* Perl_screaminstr(pTHX_ SV* bigsv, SV* littlesv, I32 start_shift, I32 end_shift, I32 *state, I32 last);
#if !defined(VMS)
diff --git a/t/op/oct.t b/t/op/oct.t
index 1dbb941..28f565b 100755
--- a/t/op/oct.t
+++ b/t/op/oct.t
@@ -1,6 +1,6 @@
#!./perl
-print "1..28\n";
+print "1..32\n";
print +(oct('0b10101') == 0b10101) ? "ok" : "not ok", " 1\n";
print +(oct('0b10101') == 025) ? "ok" : "not ok", " 2\n";
@@ -22,17 +22,22 @@ print +(oct('0x1234') == 011064) ? "ok" : "not ok", " 14\n";
print +(oct('0x1234') == 4660) ? "ok" : "not ok", " 15\n";
print +(oct('0x1234') == 0x1234) ? "ok" : "not ok", " 16\n";
-print +(hex('01234') == 0b1001000110100) ? "ok" : "not ok", " 17\n";
-print +(hex('01234') == 011064) ? "ok" : "not ok", " 18\n";
-print +(hex('01234') == 4660) ? "ok" : "not ok", " 19\n";
-print +(hex('01234') == 0x1234) ? "ok" : "not ok", " 20\n";
-
-print +(hex('0x1234') == 0b1001000110100) ? "ok" : "not ok", " 21\n";
-print +(hex('0x1234') == 011064) ? "ok" : "not ok", " 22\n";
-print +(hex('0x1234') == 4660) ? "ok" : "not ok", " 23\n";
-print +(hex('0x1234') == 0x1234) ? "ok" : "not ok", " 24\n";
-
-print +(hex('x1234') == 0b1001000110100) ? "ok" : "not ok", " 25\n";
-print +(hex('x1234') == 011064) ? "ok" : "not ok", " 26\n";
-print +(hex('x1234') == 4660) ? "ok" : "not ok", " 27\n";
-print +(hex('x1234') == 0x1234) ? "ok" : "not ok", " 28\n";
+print +(oct('x1234') == 0b1001000110100) ? "ok" : "not ok", " 17\n";
+print +(oct('x1234') == 011064) ? "ok" : "not ok", " 18\n";
+print +(oct('x1234') == 4660) ? "ok" : "not ok", " 19\n";
+print +(oct('x1234') == 0x1234) ? "ok" : "not ok", " 20\n";
+
+print +(hex('01234') == 0b1001000110100) ? "ok" : "not ok", " 21\n";
+print +(hex('01234') == 011064) ? "ok" : "not ok", " 22\n";
+print +(hex('01234') == 4660) ? "ok" : "not ok", " 23\n";
+print +(hex('01234') == 0x1234) ? "ok" : "not ok", " 24\n";
+
+print +(hex('0x1234') == 0b1001000110100) ? "ok" : "not ok", " 25\n";
+print +(hex('0x1234') == 011064) ? "ok" : "not ok", " 26\n";
+print +(hex('0x1234') == 4660) ? "ok" : "not ok", " 27\n";
+print +(hex('0x1234') == 0x1234) ? "ok" : "not ok", " 28\n";
+
+print +(hex('x1234') == 0b1001000110100) ? "ok" : "not ok", " 29\n";
+print +(hex('x1234') == 011064) ? "ok" : "not ok", " 30\n";
+print +(hex('x1234') == 4660) ? "ok" : "not ok", " 31\n";
+print +(hex('x1234') == 0x1234) ? "ok" : "not ok", " 32\n";
diff --git a/t/pragma/warn/6default b/t/pragma/warn/6default
index be45c77..5be4112 100644
--- a/t/pragma/warn/6default
+++ b/t/pragma/warn/6default
@@ -9,25 +9,45 @@ Integer overflow in octal number at - line 3.
########
# no warning should be displayed
no warning ;
-my $a = oct "7777777777777777777777777777777777779" ;
+my $a = oct "7777777777777777777777777777777777778" ;
EXPECT
-Integer overflow in octal number at - line 3.
########
# all warning should be displayed
use warning ;
-my $a = oct "77777777797";
+my $a = oct "7777777777777777777777777777777777778" ;
EXPECT
-Illegal octal digit '9' ignored at - line 3.
+Integer overflow in octal number at - line 3.
+Illegal octal digit '8' ignored at - line 3.
+Octal number > 037777777777 non-portable at - line 3.
########
# check scope
use warning ;
-my $a = oct "77777777797";
+my $a = oct "7777777777777777777777777777777777778" ;
{
no warning ;
- my $b = oct "77777777797";
+ my $a = oct "7777777777777777777777777777777777778" ;
}
-my $c = oct "7777777777777777777777777777777777779" ;
+my $c = oct "7777777777777777777777777777777777778" ;
EXPECT
-Illegal octal digit '9' ignored at - line 3.
-Octal number > 037777777777 non-portable at - line 8.
+Integer overflow in octal number at - line 3.
+Illegal octal digit '8' ignored at - line 3.
+Octal number > 037777777777 non-portable at - line 3.
Integer overflow in octal number at - line 8.
+Illegal octal digit '8' ignored at - line 8.
+Octal number > 037777777777 non-portable at - line 8.
+########
+# all warning should be displayed
+use warning ;
+my $a = oct "0xfffffffffffffffffg" ;
+EXPECT
+Integer overflow in hexadecimal number at - line 3.
+Illegal hexadecimal digit 'g' ignored at - line 3.
+Hexadecimal number > 0xffffffff non-portable at - line 3.
+########
+# all warning should be displayed
+use warning ;
+my $a = oct "0b111111111111111111111111111111111111111111111111111111111111111112";
+EXPECT
+Integer overflow in binary number at - line 3.
+Illegal binary digit '2' ignored at - line 3.
+Binary number > 0b11111111111111111111111111111111 non-portable at - line 3.
diff --git a/t/pragma/warn/util b/t/pragma/warn/util
index 87d43e8..605b42a 100644
--- a/t/pragma/warn/util
+++ b/t/pragma/warn/util
@@ -3,25 +3,18 @@
Illegal octal digit ignored
my $a = oct "029" ;
- Illegal hexadecimal digit ignored
+ Illegal hex digit ignored
my $a = hex "0xv9" ;
Illegal binary digit ignored
my $a = oct "0b9" ;
-
- Mandatory Warnings
- ------------------
- Integer overflow in binary number
- Integer overflow in octal number
- Integer overflow in hex number
-
__END__
# util.c
use warning 'octal' ;
my $a = oct "029" ;
no warning 'octal' ;
-my $b = oct "029" ;
+my $a = oct "029" ;
EXPECT
Illegal octal digit '9' ignored at - line 3.
########
@@ -40,49 +33,3 @@ no warning 'unsafe' ;
*a = oct "0b9" ;
EXPECT
Illegal binary digit '9' ignored at - line 3.
-########
-# util.c
-$^W = 1 ;
-sub make_bin { "1" x $_[0] }
-$n = make_bin(33);
-{
- use warning 'unsafe' ;
- my $a = oct "0b$n" ;
- no warning 'unsafe' ;
- my $b = oct "0b$n" ;
-}
-my $c = oct "0b$n" ;
-EXPECT
-Binary number > 0b11111111111111111111111111111111 non-portable at - line 7.
-Binary number > 0b11111111111111111111111111111111 non-portable at - line 11.
-########
-# util.c
-$^W = 1 ;
-sub make_oct { ("","1","3")[$_[0]%3] . "7" x int($_[0]/3) }
-$n = make_oct(33);
-{
- use warning 'unsafe' ;
- my $a = oct "$n" ;
- no warning 'unsafe' ;
- my $b = oct "$n" ;
-}
-my $c = oct "$n" ;
-EXPECT
-Octal number > 037777777777 non-portable at - line 7.
-Octal number > 037777777777 non-portable at - line 11.
-########
-# util.c
-$^W = 1 ;
-sub make_hex { ("","1","3","7")[$_[0]%4] . "f" x int($_[0]/4) }
-$n = make_hex(33);
-{
- use warning 'unsafe' ;
- my $a = hex "$n" ;
- no warning 'unsafe' ;
- my $b = hex "$n" ;
-}
-my $c = hex "$n" ;
-EXPECT
-Hexadecimal number > 0xffffffff non-portable at - line 7.
-Hexadecimal number > 0xffffffff non-portable at - line 11.
-
diff --git a/toke.c b/toke.c
index 6f792f2..d02ac5a 100644
--- a/toke.c
+++ b/toke.c
@@ -6285,8 +6285,21 @@ Perl_scan_num(pTHX_ char *start)
when in octal mode.
*/
dTHR;
- UV u;
+ NV n = 0.0;
+ UV u = 0;
I32 shift;
+ bool overflowed = FALSE;
+ static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
+ static char* bases[5] = { "", "binary", "", "octal",
+ "hexadecimal" };
+ static char* Bases[5] = { "", "Binary", "", "Octal",
+ "Hexadecimal" };
+ static char *maxima[5] = { "",
+ "0b11111111111111111111111111111111",
+ "",
+ "0b37777777777",
+ "0xffffffff" };
+ char *base, *Base, *max;
/* check for hex */
if (s[1] == 'x') {
@@ -6302,11 +6315,16 @@ Perl_scan_num(pTHX_ char *start)
/* so it must be octal */
else
shift = 3;
- u = 0;
+
+ base = bases[shift];
+ Base = Bases[shift];
+ max = maxima[shift];
/* read the rest of the number */
for (;;) {
- UV n, b; /* n is used in the overflow test, b is the digit we're adding on */
+ /* x is used in the overflow test,
+ b is the digit we're adding on */
+ UV x, b;
switch (*s) {
@@ -6352,16 +6370,34 @@ Perl_scan_num(pTHX_ char *start)
*/
digit:
- n = u << shift; /* make room for the digit */
- if ((n >> shift) != u
- && !(PL_hints & HINT_NEW_BINARY))
- {
- Perl_croak(aTHX_
- "Integer overflow in %s number",
- (shift == 4) ? "hexadecimal"
- : ((shift == 3) ? "octal" : "binary"));
+ if (!overflowed) {
+ x = u << shift; /* make room for the digit */
+
+ if ((x >> shift) != u
+ && !(PL_hints & HINT_NEW_BINARY)) {
+ dTHR;
+ overflowed = TRUE;
+ n = (NV) u;
+ if (ckWARN_d(WARN_UNSAFE))
+ Perl_warner(aTHX_ ((shift == 3) ?
+ WARN_OCTAL : WARN_UNSAFE),
+ "Integer overflow in %s number",
+ base);
+ } else
+ u = x | b; /* add the digit to the end */
+ }
+ if (overflowed) {
+ n *= nvshift[shift];
+ /* 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 n by the right
+ * amount. */
+ n += (NV) b;
}
- u = n | b; /* add the digit to the end */
break;
}
}
@@ -6371,7 +6407,22 @@ Perl_scan_num(pTHX_ char *start)
*/
out:
sv = NEWSV(92,0);
- sv_setuv(sv, u);
+ if (overflowed) {
+ dTHR;
+ if (ckWARN(WARN_UNSAFE) && (double) n > 4294967295.0)
+ Perl_warner(aTHX_ WARN_UNSAFE,
+ "%s number > %s non-portable",
+ Base, max);
+ sv_setnv(sv, n);
+ }
+ else {
+ dTHR;
+ if (ckWARN(WARN_UNSAFE) && u > 4294967295)
+ Perl_warner(aTHX_ WARN_UNSAFE,
+ "%s number > %s non-portable",
+ Base, max);
+ sv_setuv(sv, u);
+ }
if ( PL_hints & HINT_NEW_BINARY)
sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
}
diff --git a/util.c b/util.c
index 6fc3d8f..4ef55f2 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*