warn if ++ or -- are unable to change the value because it's beyond

the limit of representation in NVs, using a new warnings category
"imprecision".

p4raw-id: //depot/perl@32990

diff --git a/lib/warnings.pm b/lib/warnings.pm
index 79a5aa8..fb8c02a 100644 (file)
--- a/lib/warnings.pm
+++ b/lib/warnings.pm
@@ -188,10 +188,14 @@ our %Offsets = (
     'untie'            => 86,
     'utf8'             => 88,
     'void'             => 90,
+
+    # Warnings Categories added in Perl 5.011
+
+    'imprecision'      => 92,
   );
 
 our %Bits = (
-    'all'              => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x05", # [0..45]
+    'all'              => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x15", # [0..46]
     'ambiguous'                => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29]
     'bareword'         => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30]
     'closed'           => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
@@ -202,6 +206,7 @@ our %Bits = (
     'exec'             => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
     'exiting'          => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
     'glob'             => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
+    'imprecision'      => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [46]
     'inplace'          => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [23]
     'internal'         => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [24]
     'io'               => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
@@ -240,7 +245,7 @@ our %Bits = (
   );
 
 our %DeadBits = (
-    'all'              => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x0a", # [0..45]
+    'all'              => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x2a", # [0..46]
     'ambiguous'                => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29]
     'bareword'         => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30]
     'closed'           => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
@@ -251,6 +256,7 @@ our %DeadBits = (
     'exec'             => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
     'exiting'          => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
     'glob'             => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
+    'imprecision'      => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [46]
     'inplace'          => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [23]
     'internal'         => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [24]
     'io'               => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
@@ -289,7 +295,7 @@ our %DeadBits = (
   );
 
 $NONE     = "\0\0\0\0\0\0\0\0\0\0\0\0";
-$LAST_BIT = 92 ;
+$LAST_BIT = 94 ;
 $BYTES    = 12 ;
 
 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;

diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index caa3915..05a082c 100644 (file)
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -2258,6 +2258,15 @@ L<perlfunc/listen>.
 (F) There is currently a limit on the length of string which lookbehind can
 handle. This restriction may be eased in a future release. 
 
+=item Lost precision when %s %f by 1
+
+(W) The value you attempted to increment or decrement by one is too large
+for the underlying floating point representation to store accurately,
+hence the target of C<++> or C<--> is unchanged. Perl issues this warning
+because it has already switched from integers to floating point when values
+are too large for integers, and now even floating point is insufficient.
+You may wish to switch to using L<Math::BigInt> explicitly.
+
 =item lstat() on filehandle %s
 
 (W io) You tried to do an lstat on a filehandle.  What did you mean

diff --git a/pod/perllexwarn.pod b/pod/perllexwarn.pod
index 72370c7..8c07c77 100644 (file)
--- a/pod/perllexwarn.pod
+++ b/pod/perllexwarn.pod
@@ -236,6 +236,8 @@ The current hierarchy is:
        |                |
        |                +- unopened
        |
+       +- imprecision
+       |
        +- misc
        |
        +- numeric

diff --git a/sv.c b/sv.c
index 5230175..e801249 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -6794,8 +6794,15 @@ Perl_sv_inc(pTHX_ register SV *sv)
        return;
     }
     if (flags & SVp_NOK) {
+       const NV was = SvNVX(sv);
+       const NV now = was + 1.0;
+       if (now - was != 1.0 && ckWARN(WARN_IMPRECISION)) {
+           Perl_warner(aTHX_ packWARN(WARN_IMPRECISION),
+                       "Lost precision when incrementing %" NVff " by 1",
+                       was);
+       }
        (void)SvNOK_only(sv);
-        SvNV_set(sv, SvNVX(sv) + 1.0);
+        SvNV_set(sv, now);
        return;
     }
 
@@ -6939,8 +6946,10 @@ Perl_sv_dec(pTHX_ register SV *sv)
                SvUV_set(sv, SvUVX(sv) - 1);
            }   
        } else {
-           if (SvIVX(sv) == IV_MIN)
-               sv_setnv(sv, (NV)IV_MIN - 1.0);
+           if (SvIVX(sv) == IV_MIN) {
+               sv_setnv(sv, (NV)IV_MIN);
+               goto oops_its_num;
+           }
            else {
                (void)SvIOK_only(sv);
                SvIV_set(sv, SvIVX(sv) - 1);
@@ -6949,9 +6958,19 @@ Perl_sv_dec(pTHX_ register SV *sv)
        return;
     }
     if (flags & SVp_NOK) {
-        SvNV_set(sv, SvNVX(sv) - 1.0);
-       (void)SvNOK_only(sv);
-       return;
+    oops_its_num:
+       {
+           const NV was = SvNVX(sv);
+           const NV now = was - 1.0;
+           if (now - was != -1.0 && ckWARN(WARN_IMPRECISION)) {
+               Perl_warner(aTHX_ packWARN(WARN_IMPRECISION),
+                           "Lost precision when decrementing %" NVff " by 1",
+                           was);
+           }
+           (void)SvNOK_only(sv);
+           SvNV_set(sv, now);
+           return;
+       }
     }
     if (!(flags & SVp_POK)) {
        if ((flags & SVTYPEMASK) < SVt_PVIV)

diff --git a/t/op/inc.t b/t/op/inc.t
index 3eec5cd..95b0698 100755 (executable)
--- a/t/op/inc.t
+++ b/t/op/inc.t
@@ -2,7 +2,7 @@
 
 # use strict;
 
-print "1..34\n";
+print "1..50\n";
 
 my $test = 1;
 
@@ -194,3 +194,68 @@ ok ($a == 2147483647, $a);
     $x--;
     ok ($x == 0, "(void) i_postdec");
 }
+
+# I'm sure that there's an IBM format with a 48 bit mantissa
+# IEEE doubles have a 53 bit mantissa
+# 80 bit long doubles have a 64 bit mantissa
+# sparcs have a 112 bit mantissa for their long doubles. Just to be awkward :-)
+
+sub check_some_code {
+    my ($start, $warn, $action, $description) = @_;
+    my $warn_line = ($warn ? 'use' : 'no') . " warnings 'imprecision';";
+    my @warnings;
+    local $SIG{__WARN__} = sub {push @warnings, "@_"};
+
+    print "# checking $action under $warn_line\n";
+    my $code = <<"EOC";
+$warn_line
+my \$i = \$start;
+for(0 .. 3) {
+    my \$a = $action;
+}
+1;
+EOC
+    eval $code or die "# $@\n$code";
+
+    if ($warn) {
+       unless (ok (scalar @warnings == 2, scalar @warnings)) {
+           print STDERR "# $_" foreach @warnings;
+       }
+       foreach (@warnings) {
+           unless (ok (/Lost precision when incrementing \d+/, $_)) {
+               print STDERR "# $_"
+           }
+       }
+    } else {
+       unless (ok (scalar @warnings == 0)) {
+           print STDERR "# @$_" foreach @warnings;
+       }
+    }
+}
+
+my $found;
+for my $n (47..113) {
+    my $power_of_2 = 2**$n;
+    my $plus_1 = $power_of_2 + 1;
+    next if $plus_1 != $power_of_2;
+    print "# Testing for 2**$n ($power_of_2) which overflows the mantissa\n";
+    # doing int here means that for NV > IV on the first go we're in the
+    # IV upgrade to NV case, and the second go we're in the NV already case.
+    my $start = int($power_of_2 - 2);
+    my $check = $power_of_2 - 2;
+    die "Something wrong with our rounding assumptions: $check vs $start"
+       unless $start == $check;
+
+    foreach my $warn (0, 1) {
+       foreach (['++$i', 'pre-inc'], ['$i++', 'post-inc']) {
+           check_some_code($start, $warn, @$_);
+       }
+       foreach (['--$i', 'pre-dec'], ['$i--', 'post-dec']) {
+           check_some_code(-$start, $warn, @$_);
+       }
+    }
+
+    $found = 1;
+    last;
+}
+die "Could not find a value which overflows the mantissa" unless $found;

diff --git a/warnings.h b/warnings.h
index 66a9a0a..8f891a7 100644 (file)
--- a/warnings.h
+++ b/warnings.h
@@ -76,6 +76,10 @@
 #define WARN_UTF8              44
 #define WARN_VOID              45
 
+/* Warnings Categories added in Perl 5.011 */
+
+#define WARN_IMPRECISION       46
+
 #define WARNsize               12
 #define WARN_ALLstring         "\125\125\125\125\125\125\125\125\125\125\125\125"
 #define WARN_NONEstring                "\0\0\0\0\0\0\0\0\0\0\0\0"

diff --git a/warnings.pl b/warnings.pl
index 4168c58..97d5d14 100644 (file)
--- a/warnings.pl
+++ b/warnings.pl
@@ -61,6 +61,7 @@ my $tree = {
                'pack'          => [ 5.008, DEFAULT_OFF],
                'unpack'        => [ 5.008, DEFAULT_OFF],
                'threads'       => [ 5.008, DEFAULT_OFF],
+               'imprecision'   => [ 5.011, DEFAULT_OFF],
 
                 #'default'     => [ 5.008, DEFAULT_ON ],
        }],