Repent and make overly large integerish
Jarkko Hietaniemi [Thu, 29 Jul 1999 14:02:50 +0000 (14:02 +0000)]
constants non-fatal.  They are now promoted
to NVs, accompanied by an overflow warning that
is by default on.

p4raw-id: //depot/cfgperl@3832

embed.pl
pod/perldelta.pod
pod/perldiag.pod
pp.c
proto.h
t/op/oct.t
t/pragma/warn/6default
t/pragma/warn/util
toke.c
util.c

index 6260550..781addb 100755 (executable)
--- 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
index 8a4c2d1..624b152 100644 (file)
@@ -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.
index 7d27fc2..bffd191 100644 (file)
@@ -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 (file)
--- 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 (file)
--- 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)
index 1dbb941..28f565b 100755 (executable)
@@ -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";
index be45c77..5be4112 100644 (file)
@@ -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.
index 87d43e8..605b42a 100644 (file)
@@ -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 (file)
--- 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 (file)
--- 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*