From b88df9907a8d7b4fae1100629cc85633a901355e Mon Sep 17 00:00:00 2001
From: Nicholas Clark <nick@ccl4.org>
Date: Thu, 17 Jan 2008 14:23:48 +0000
Subject: [PATCH] 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
---
 lib/warnings.pm     | 12 +++++++---
 pod/perldiag.pod    |  9 +++++++
 pod/perllexwarn.pod |  2 ++
 sv.c                | 31 ++++++++++++++++++++-----
 t/op/inc.t          | 67 ++++++++++++++++++++++++++++++++++++++++++++++++++++-
 warnings.h          |  4 ++++
 warnings.pl         |  1 +
 7 files changed, 116 insertions(+), 10 deletions(-)

diff --git a/lib/warnings.pm b/lib/warnings.pm
index 79a5aa8..fb8c02a 100644
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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 ],
   	}],
-- 
1.8.3.1