From: Jarkko Hietaniemi 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: $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 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 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 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 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 for more on portability concerns. =item Identifier too long @@ -1558,18 +1540,15 @@ known value, using trustworthy data. See L. =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 for more +on portability concerns. See also L 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*