Fix overloading for 64-bit ints (revised)
authorJerry D. Hedden <jdhedden@cpan.org>
Thu, 18 Oct 2007 14:49:40 +0000 (10:49 -0400)
committerRafael Garcia-Suarez <rgarciasuarez@gmail.com>
Fri, 19 Oct 2007 07:47:45 +0000 (07:47 +0000)
From: "Jerry D. Hedden" <jdhedden@cpan.org>
Message-ID: <1ff86f510710181149s1c096dd9qffa8fe42046e675b@mail.gmail.com>

p4raw-id: //depot/perl@32141

MANIFEST
embed.fnc
embed.h
lib/overload.t
lib/overload64.t [new file with mode: 0644]
pod/perlintern.pod
pp.c
pp_hot.c
proto.h
sv.c

index d85ca32..e25143a 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -2287,6 +2287,7 @@ lib/open2.pl                      Open a two-ended pipe (uses IPC::Open2)
 lib/open3.pl                   Open a three-ended pipe (uses IPC::Open3)
 lib/open.pm                    Pragma to specify default I/O layers
 lib/open.t                     See if the open pragma works
+lib/overload64.t               See if operator overloading works with 64-bit ints
 lib/overload.pm                        Module for overloading perl operators
 lib/overload.t                 See if operator overloading works
 lib/Package/Constants.pm       Package::Constants
index 89fa7ea..fd145ad 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -815,6 +815,7 @@ Amb |IV     |sv_2iv         |NN SV* sv
 Apd    |IV     |sv_2iv_flags   |NN SV* sv|I32 flags
 Apd    |SV*    |sv_2mortal     |NULLOK SV* sv
 Apd    |NV     |sv_2nv         |NN SV* sv
+pMd    |SV*    |sv_2num        |NN SV* sv
 Amb    |char*  |sv_2pv         |NN SV* sv|NULLOK STRLEN* lp
 Apd    |char*  |sv_2pv_flags   |NN SV* sv|NULLOK STRLEN* lp|I32 flags
 Apd    |char*  |sv_2pvutf8     |NN SV* sv|NULLOK STRLEN* lp
diff --git a/embed.h b/embed.h
index 57f6185..eba1305 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define sv_2iv_flags           Perl_sv_2iv_flags
 #define sv_2mortal             Perl_sv_2mortal
 #define sv_2nv                 Perl_sv_2nv
+#ifdef PERL_CORE
+#define sv_2num                        Perl_sv_2num
+#endif
 #define sv_2pv_flags           Perl_sv_2pv_flags
 #define sv_2pvutf8             Perl_sv_2pvutf8
 #define sv_2pvbyte             Perl_sv_2pvbyte
 #define sv_2iv_flags(a,b)      Perl_sv_2iv_flags(aTHX_ a,b)
 #define sv_2mortal(a)          Perl_sv_2mortal(aTHX_ a)
 #define sv_2nv(a)              Perl_sv_2nv(aTHX_ a)
+#ifdef PERL_CORE
+#define sv_2num(a)             Perl_sv_2num(aTHX_ a)
+#endif
 #define sv_2pv_flags(a,b,c)    Perl_sv_2pv_flags(aTHX_ a,b,c)
 #define sv_2pvutf8(a,b)                Perl_sv_2pvutf8(aTHX_ a,b)
 #define sv_2pvbyte(a,b)                Perl_sv_2pvbyte(aTHX_ a,b)
index 29411e1..94cd296 100644 (file)
@@ -47,7 +47,7 @@ sub numify { 0 + "${$_[0]}" } # Not needed, additional overhead
 package main;
 
 $| = 1;
-use Test::More tests => 536;
+use Test::More tests => 556;
 
 
 $a = new Oscalar "087";
@@ -1384,7 +1384,7 @@ foreach my $op (qw(<=> == != < <= > >=)) {
     package numify_other;
     use overload "0+" => sub { $_[0][0]++; $_[0][1] = bless [], 'numify_int' };
     package numify_by_fallback;
-    use overload "-" => sub { 1 }, fallback => 1;
+    use overload fallback => 1;
 
     package main;
     my $o = bless [], 'numify_int';
@@ -1404,4 +1404,27 @@ foreach my $op (qw(<=> == != < <= > >=)) {
 
     my $m = bless $aref, 'numify_by_fallback';
     is(int($m), $num_val, 'numifies to usual reference value');
+    is(abs($m), $num_val, 'numifies to usual reference value');
+    is(-$m, -$num_val, 'numifies to usual reference value');
+    is(0+$m, $num_val, 'numifies to usual reference value');
+    is($m+0, $num_val, 'numifies to usual reference value');
+    is($m+$m, 2*$num_val, 'numifies to usual reference value');
+    is(0-$m, -$num_val, 'numifies to usual reference value');
+    is(1*$m, $num_val, 'numifies to usual reference value');
+    is($m/1, $num_val, 'numifies to usual reference value');
+    is($m%100, $num_val%100, 'numifies to usual reference value');
+    is($m**1, $num_val, 'numifies to usual reference value');
+
+    is(abs($aref), $num_val, 'abs() of ref');
+    is(-$aref, -$num_val, 'negative of ref');
+    is(0+$aref, $num_val, 'ref addition');
+    is($aref+0, $num_val, 'ref addition');
+    is($aref+$aref, 2*$num_val, 'ref addition');
+    is(0-$aref, -$num_val, 'subtraction of ref');
+    is(1*$aref, $num_val, 'multiplicaton of ref');
+    is($aref/1, $num_val, 'division of ref');
+    is($aref%100, $num_val%100, 'modulo of ref');
+    is($aref**1, $num_val, 'exponentiation of ref');
 }
+
+# EOF
diff --git a/lib/overload64.t b/lib/overload64.t
new file mode 100644 (file)
index 0000000..f4b0cb0
--- /dev/null
@@ -0,0 +1,216 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    require Config;
+    if ($Config::Config{'uvsize'} != 8) {
+        print "1..0 # Skip -- Perl configured with 32-bit ints\n";
+        exit 0;
+    }
+}
+
+$| = 1;
+use Test::More 'tests' => 100;
+
+
+my $ii = 36028797018963971;  # 2^55 + 3
+
+
+### Tests with numerifying large positive int
+{ package Oobj;
+    use overload '0+' => sub { ${$_[0]} += 1; $ii },
+                 'fallback' => 1;
+}
+my $oo = bless(\do{my $x = 0}, 'Oobj');
+my $cnt = 1;
+
+is("$oo", "$ii", '0+ overload with stringification');
+is($$oo, $cnt++, 'overload called once');
+
+is($oo>>3, $ii>>3, '0+ overload with bit shift right');
+is($$oo, $cnt++, 'overload called once');
+
+is($oo<<2, $ii<<2, '0+ overload with bit shift left');
+is($$oo, $cnt++, 'overload called once');
+
+is($oo|0xFF00, $ii|0xFF00, '0+ overload with bitwise or');
+is($$oo, $cnt++, 'overload called once');
+
+is($oo&0xFF03, $ii&0xFF03, '0+ overload with bitwise and');
+is($$oo, $cnt++, 'overload called once');
+
+ok($oo == $ii, '0+ overload with equality');
+is($$oo, $cnt++, 'overload called once');
+
+is(int($oo), $ii, '0+ overload with int()');
+is($$oo, $cnt++, 'overload called once');
+
+is(abs($oo), $ii, '0+ overload with abs()');
+is($$oo, $cnt++, 'overload called once');
+
+is(-$oo, -$ii, '0+ overload with unary minus');
+is($$oo, $cnt++, 'overload called once');
+
+is(0+$oo, $ii, '0+ overload with addition');
+is($$oo, $cnt++, 'overload called once');
+is($oo+0, $ii, '0+ overload with addition');
+is($$oo, $cnt++, 'overload called once');
+is($oo+$oo, 2*$ii, '0+ overload with addition');
+$cnt++;
+is($$oo, $cnt++, 'overload called once');
+
+is(0-$oo, -$ii, '0+ overload with subtraction');
+is($$oo, $cnt++, 'overload called once');
+is($oo-99, $ii-99, '0+ overload with subtraction');
+is($$oo, $cnt++, 'overload called once');
+
+is(2*$oo, 2*$ii, '0+ overload with multiplication');
+is($$oo, $cnt++, 'overload called once');
+is($oo*3, 3*$ii, '0+ overload with multiplication');
+is($$oo, $cnt++, 'overload called once');
+
+is($oo/1, $ii, '0+ overload with division');
+is($$oo, $cnt++, 'overload called once');
+is($ii/$oo, 1, '0+ overload with division');
+is($$oo, $cnt++, 'overload called once');
+
+is($oo%100, $ii%100, '0+ overload with modulo');
+is($$oo, $cnt++, 'overload called once');
+is($ii%$oo, 0, '0+ overload with modulo');
+is($$oo, $cnt++, 'overload called once');
+
+is($oo**1, $ii, '0+ overload with exponentiation');
+is($$oo, $cnt++, 'overload called once');
+
+
+### Tests with numerifying large negative int
+{ package Oobj2;
+    use overload '0+' => sub { ${$_[0]} += 1; -$ii },
+                 'fallback' => 1;
+}
+$oo = bless(\do{my $x = 0}, 'Oobj2');
+$cnt = 1;
+
+is(int($oo), -$ii, '0+ overload with int()');
+is($$oo, $cnt++, 'overload called once');
+
+is(abs($oo), $ii, '0+ overload with abs()');
+is($$oo, $cnt++, 'overload called once');
+
+is(-$oo, $ii, '0+ overload with unary -');
+is($$oo, $cnt++, 'overload called once');
+
+is(0+$oo, -$ii, '0+ overload with addition');
+is($$oo, $cnt++, 'overload called once');
+is($oo+0, -$ii, '0+ overload with addition');
+is($$oo, $cnt++, 'overload called once');
+is($oo+$oo, -2*$ii, '0+ overload with addition');
+$cnt++;
+is($$oo, $cnt++, 'overload called once');
+
+is(0-$oo, $ii, '0+ overload with subtraction');
+is($$oo, $cnt++, 'overload called once');
+
+is(2*$oo, -2*$ii, '0+ overload with multiplication');
+is($$oo, $cnt++, 'overload called once');
+is($oo*3, -3*$ii, '0+ overload with multiplication');
+is($$oo, $cnt++, 'overload called once');
+
+is($oo/1, -$ii, '0+ overload with division');
+is($$oo, $cnt++, 'overload called once');
+is($ii/$oo, -1, '0+ overload with division');
+is($$oo, $cnt++, 'overload called once');
+
+is($oo%100, (-$ii)%100, '0+ overload with modulo');
+is($$oo, $cnt++, 'overload called once');
+is($ii%$oo, 0, '0+ overload with modulo');
+is($$oo, $cnt++, 'overload called once');
+
+is($oo**1, -$ii, '0+ overload with exponentiation');
+is($$oo, $cnt++, 'overload called once');
+
+### Tests with overloading but no fallback
+{ package Oobj3;
+    use overload
+        'int' => sub { ${$_[0]} += 1; $ii },
+        'abs' => sub { ${$_[0]} += 1; $ii },
+        'neg' => sub { ${$_[0]} += 1; -$ii },
+        '+' => sub {
+            ${$_[0]} += 1;
+            my $res = (ref($_[0]) eq __PACKAGE__) ? $ii : $_[0];
+            $res   += (ref($_[1]) eq __PACKAGE__) ? $ii : $_[1];
+        },
+        '-' => sub {
+            ${$_[0]} += 1;
+            my ($l, $r) = ($_[2]) ? (1, 0) : (0, 1);
+            my $res = (ref($_[$l]) eq __PACKAGE__) ? $ii : $_[$l];
+            $res   -= (ref($_[$r]) eq __PACKAGE__) ? $ii : $_[$r];
+        },
+        '*' => sub {
+            ${$_[0]} += 1;
+            my $res = (ref($_[0]) eq __PACKAGE__) ? $ii : $_[0];
+            $res   *= (ref($_[1]) eq __PACKAGE__) ? $ii : $_[1];
+        },
+        '/' => sub {
+            ${$_[0]} += 1;
+            my ($l, $r) = ($_[2]) ? (1, 0) : (0, 1);
+            my $res = (ref($_[$l]) eq __PACKAGE__) ? $ii+1 : $_[$l];
+            $res   /= (ref($_[$r]) eq __PACKAGE__) ? $ii+1 : $_[$r];
+        },
+        '%' => sub {
+            ${$_[0]} += 1;
+            my ($l, $r) = ($_[2]) ? (1, 0) : (0, 1);
+            my $res = (ref($_[$l]) eq __PACKAGE__) ? $ii : $_[$l];
+            $res   %= (ref($_[$r]) eq __PACKAGE__) ? $ii : $_[$r];
+        },
+        '**' => sub {
+            ${$_[0]} += 1;
+            my ($l, $r) = ($_[2]) ? (1, 0) : (0, 1);
+            my $res = (ref($_[$l]) eq __PACKAGE__) ? $ii : $_[$l];
+            $res  **= (ref($_[$r]) eq __PACKAGE__) ? $ii : $_[$r];
+        },
+}
+$oo = bless(\do{my $x = 0}, 'Oobj3');
+$cnt = 1;
+
+is(int($oo), $ii, 'int() overload');
+is($$oo, $cnt++, 'overload called once');
+
+is(abs($oo), $ii, 'abs() overload');
+is($$oo, $cnt++, 'overload called once');
+
+is(-$oo, -$ii, 'neg overload');
+is($$oo, $cnt++, 'overload called once');
+
+is(0+$oo, $ii, '+ overload');
+is($$oo, $cnt++, 'overload called once');
+is($oo+0, $ii, '+ overload');
+is($$oo, $cnt++, 'overload called once');
+is($oo+$oo, 2*$ii, '+ overload');
+is($$oo, $cnt++, 'overload called once');
+
+is(0-$oo, -$ii, '- overload');
+is($$oo, $cnt++, 'overload called once');
+is($oo-99, $ii-99, '- overload');
+is($$oo, $cnt++, 'overload called once');
+
+is($oo*2, 2*$ii, '* overload');
+is($$oo, $cnt++, 'overload called once');
+is(-3*$oo, -3*$ii, '* overload');
+is($$oo, $cnt++, 'overload called once');
+
+is($oo/2, ($ii+1)/2, '/ overload');
+is($$oo, $cnt++, 'overload called once');
+is(($ii+1)/$oo, 1, '/ overload');
+is($$oo, $cnt++, 'overload called once');
+
+is($oo%100, $ii%100, '% overload');
+is($$oo, $cnt++, 'overload called once');
+is($ii%$oo, 0, '% overload');
+is($$oo, $cnt++, 'overload called once');
+
+is($oo**1, $ii, '** overload');
+is($$oo, $cnt++, 'overload called once');
+
+# EOF
index 54fffe6..272e5d4 100644 (file)
@@ -1036,6 +1036,24 @@ heads and bodies within the arenas must already have been freed.
 Found in file sv.c
 
 
+=back
+
+=head1 SV-Body Allocation
+
+=over 8
+
+=item sv_2num
+X<sv_2num>
+
+Return an SV with the numeric value of the source SV, doing any necessary
+reference or overload conversion.
+
+       SV*     sv_2num(SV* sv)
+
+=for hackers
+Found in file sv.c
+
+
 =back
 
 =head1 Unicode Support
diff --git a/pp.c b/pp.c
index d533738..cd04198 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -921,28 +921,30 @@ PP(pp_postdec)
 
 PP(pp_pow)
 {
-    dVAR; dSP; dATARGET;
+    dVAR; dSP; dATARGET; SV *svl, *svr;
 #ifdef PERL_PRESERVE_IVUV
     bool is_int = 0;
 #endif
     tryAMAGICbin(pow,opASSIGN);
+    svl = sv_2num(TOPm1s);
+    svr = sv_2num(TOPs);
 #ifdef PERL_PRESERVE_IVUV
     /* For integer to integer power, we do the calculation by hand wherever
        we're sure it is safe; otherwise we call pow() and try to convert to
        integer afterwards. */
     {
-       SvIV_please(TOPs);
-       if (SvIOK(TOPs)) {
-           SvIV_please(TOPm1s);
-           if (SvIOK(TOPm1s)) {
+       SvIV_please(svr);
+       if (SvIOK(svr)) {
+           SvIV_please(svl);
+           if (SvIOK(svl)) {
                UV power;
                bool baseuok;
                UV baseuv;
 
-               if (SvUOK(TOPs)) {
-                   power = SvUVX(TOPs);
+               if (SvUOK(svr)) {
+                   power = SvUVX(svr);
                } else {
-                   const IV iv = SvIVX(TOPs);
+                   const IV iv = SvIVX(svr);
                    if (iv >= 0) {
                        power = iv;
                    } else {
@@ -950,11 +952,11 @@ PP(pp_pow)
                    }
                }
 
-               baseuok = SvUOK(TOPm1s);
+               baseuok = SvUOK(svl);
                if (baseuok) {
-                   baseuv = SvUVX(TOPm1s);
+                   baseuv = SvUVX(svl);
                } else {
-                   const IV iv = SvIVX(TOPm1s);
+                   const IV iv = SvIVX(svl);
                    if (iv >= 0) {
                        baseuv = iv;
                        baseuok = TRUE; /* effectively it's a UV now */
@@ -989,7 +991,7 @@ PP(pp_pow)
                    }
                     SP--;
                     SETn( result );
-                    SvIV_please(TOPs);
+                    SvIV_please(svr);
                     RETURN;
                } else {
                    register unsigned int highbit = 8 * sizeof(UV);
@@ -1082,7 +1084,7 @@ PP(pp_pow)
 
 #ifdef PERL_PRESERVE_IVUV
        if (is_int)
-           SvIV_please(TOPs);
+           SvIV_please(svr);
 #endif
        RETURN;
     }
@@ -1090,18 +1092,21 @@ PP(pp_pow)
 
 PP(pp_multiply)
 {
-    dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
+    dVAR; dSP; dATARGET; SV *svl, *svr;
+    tryAMAGICbin(mult,opASSIGN);
+    svl = sv_2num(TOPm1s);
+    svr = sv_2num(TOPs);
 #ifdef PERL_PRESERVE_IVUV
-    SvIV_please(TOPs);
-    if (SvIOK(TOPs)) {
+    SvIV_please(svr);
+    if (SvIOK(svr)) {
        /* Unless the left argument is integer in range we are going to have to
           use NV maths. Hence only attempt to coerce the right argument if
           we know the left is integer.  */
        /* Left operand is defined, so is it IV? */
-       SvIV_please(TOPm1s);
-       if (SvIOK(TOPm1s)) {
-           bool auvok = SvUOK(TOPm1s);
-           bool buvok = SvUOK(TOPs);
+       SvIV_please(svl);
+       if (SvIOK(svl)) {
+           bool auvok = SvUOK(svl);
+           bool buvok = SvUOK(svr);
            const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
            const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
            UV alow;
@@ -1110,9 +1115,9 @@ PP(pp_multiply)
            UV bhigh;
 
            if (auvok) {
-               alow = SvUVX(TOPm1s);
+               alow = SvUVX(svl);
            } else {
-               const IV aiv = SvIVX(TOPm1s);
+               const IV aiv = SvIVX(svl);
                if (aiv >= 0) {
                    alow = aiv;
                    auvok = TRUE; /* effectively it's a UV now */
@@ -1121,9 +1126,9 @@ PP(pp_multiply)
                }
            }
            if (buvok) {
-               blow = SvUVX(TOPs);
+               blow = SvUVX(svr);
            } else {
-               const IV biv = SvIVX(TOPs);
+               const IV biv = SvIVX(svr);
                if (biv >= 0) {
                    blow = biv;
                    buvok = TRUE; /* effectively it's a UV now */
@@ -1197,8 +1202,8 @@ PP(pp_multiply)
                    }
                } /* product_middle too large */
            } /* ahigh && bhigh */
-       } /* SvIOK(TOPm1s) */
-    } /* SvIOK(TOPs) */
+       } /* SvIOK(svl) */
+    } /* SvIOK(svr) */
 #endif
     {
       dPOPTOPnnrl;
@@ -1209,7 +1214,10 @@ PP(pp_multiply)
 
 PP(pp_divide)
 {
-    dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
+    dVAR; dSP; dATARGET; SV *svl, *svr;
+    tryAMAGICbin(div,opASSIGN);
+    svl = sv_2num(TOPm1s);
+    svr = sv_2num(TOPs);
     /* Only try to do UV divide first
        if ((SLOPPYDIVIDE is true) or
            (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
@@ -1232,20 +1240,20 @@ PP(pp_divide)
 #endif
 
 #ifdef PERL_TRY_UV_DIVIDE
-    SvIV_please(TOPs);
-    if (SvIOK(TOPs)) {
-        SvIV_please(TOPm1s);
-        if (SvIOK(TOPm1s)) {
-            bool left_non_neg = SvUOK(TOPm1s);
-            bool right_non_neg = SvUOK(TOPs);
+    SvIV_please(svr);
+    if (SvIOK(svr)) {
+        SvIV_please(svl);
+        if (SvIOK(svl)) {
+            bool left_non_neg = SvUOK(svl);
+            bool right_non_neg = SvUOK(svr);
             UV left;
             UV right;
 
             if (right_non_neg) {
-                right = SvUVX(TOPs);
+                right = SvUVX(svr);
             }
            else {
-               const IV biv = SvIVX(TOPs);
+               const IV biv = SvIVX(svr);
                 if (biv >= 0) {
                     right = biv;
                     right_non_neg = TRUE; /* effectively it's a UV now */
@@ -1263,10 +1271,10 @@ PP(pp_divide)
                 DIE(aTHX_ "Illegal division by zero");
 
             if (left_non_neg) {
-                left = SvUVX(TOPm1s);
+                left = SvUVX(svl);
             }
            else {
-               const IV aiv = SvIVX(TOPm1s);
+               const IV aiv = SvIVX(svl);
                 if (aiv >= 0) {
                     left = aiv;
                     left_non_neg = TRUE; /* effectively it's a UV now */
@@ -1338,14 +1346,15 @@ PP(pp_modulo)
        bool dright_valid = FALSE;
        NV dright = 0.0;
        NV dleft  = 0.0;
-
-        SvIV_please(TOPs);
-        if (SvIOK(TOPs)) {
-            right_neg = !SvUOK(TOPs);
+        SV * svl;
+        SV * const svr = sv_2num(TOPs);
+        SvIV_please(svr);
+        if (SvIOK(svr)) {
+            right_neg = !SvUOK(svr);
             if (!right_neg) {
-                right = SvUVX(POPs);
+                right = SvUVX(svr);
             } else {
-               const IV biv = SvIVX(POPs);
+               const IV biv = SvIVX(svr);
                 if (biv >= 0) {
                     right = biv;
                     right_neg = FALSE; /* effectively it's a UV now */
@@ -1353,6 +1362,7 @@ PP(pp_modulo)
                     right = -biv;
                 }
             }
+            sp--;
         }
         else {
            dright = POPn;
@@ -1370,14 +1380,15 @@ PP(pp_modulo)
         /* At this point use_double is only true if right is out of range for
            a UV.  In range NV has been rounded down to nearest UV and
            use_double false.  */
-        SvIV_please(TOPs);
-       if (!use_double && SvIOK(TOPs)) {
-            if (SvIOK(TOPs)) {
-                left_neg = !SvUOK(TOPs);
+        svl = sv_2num(TOPs);
+        SvIV_please(svl);
+       if (!use_double && SvIOK(svl)) {
+            if (SvIOK(svl)) {
+                left_neg = !SvUOK(svl);
                 if (!left_neg) {
-                    left = SvUVX(POPs);
+                    left = SvUVX(svl);
                 } else {
-                   const IV aiv = SvIVX(POPs);
+                   const IV aiv = SvIVX(svl);
                     if (aiv >= 0) {
                         left = aiv;
                         left_neg = FALSE; /* effectively it's a UV now */
@@ -1385,6 +1396,7 @@ PP(pp_modulo)
                         left = -aiv;
                     }
                 }
+                sp--;
             }
         }
        else {
@@ -1581,13 +1593,16 @@ PP(pp_repeat)
 
 PP(pp_subtract)
 {
-    dVAR; dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
-    useleft = USE_LEFT(TOPm1s);
+    dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
+    tryAMAGICbin(subtr,opASSIGN);
+    svl = sv_2num(TOPm1s);
+    svr = sv_2num(TOPs);
+    useleft = USE_LEFT(svl);
 #ifdef PERL_PRESERVE_IVUV
     /* See comments in pp_add (in pp_hot.c) about Overflow, and how
        "bad things" happen if you rely on signed integers wrapping.  */
-    SvIV_please(TOPs);
-    if (SvIOK(TOPs)) {
+    SvIV_please(svr);
+    if (SvIOK(svr)) {
        /* Unless the left argument is integer in range we are going to have to
           use NV maths. Hence only attempt to coerce the right argument if
           we know the left is integer.  */
@@ -1601,12 +1616,12 @@ PP(pp_subtract)
            /* left operand is undef, treat as zero.  */
        } else {
            /* Left operand is defined, so is it IV? */
-           SvIV_please(TOPm1s);
-           if (SvIOK(TOPm1s)) {
-               if ((auvok = SvUOK(TOPm1s)))
-                   auv = SvUVX(TOPm1s);
+           SvIV_please(svl);
+           if (SvIOK(svl)) {
+               if ((auvok = SvUOK(svl)))
+                   auv = SvUVX(svl);
                else {
-                   register const IV aiv = SvIVX(TOPm1s);
+                   register const IV aiv = SvIVX(svl);
                    if (aiv >= 0) {
                        auv = aiv;
                        auvok = 1;      /* Now acting as a sign flag.  */
@@ -1621,12 +1636,12 @@ PP(pp_subtract)
            bool result_good = 0;
            UV result;
            register UV buv;
-           bool buvok = SvUOK(TOPs);
+           bool buvok = SvUOK(svr);
        
            if (buvok)
-               buv = SvUVX(TOPs);
+               buv = SvUVX(svr);
            else {
-               register const IV biv = SvIVX(TOPs);
+               register const IV biv = SvIVX(svr);
                if (biv >= 0) {
                    buv = biv;
                    buvok = 1;
@@ -1683,7 +1698,6 @@ PP(pp_subtract)
        }
     }
 #endif
-    useleft = USE_LEFT(TOPm1s);
     {
        dPOPnv;
        if (!useleft) {
@@ -2373,7 +2387,7 @@ PP(pp_negate)
 {
     dVAR; dSP; dTARGET; tryAMAGICun(neg);
     {
-       dTOPss;
+       SV * const sv = sv_2num(TOPs);
        const int flags = SvFLAGS(sv);
        SvGETMAGIC(sv);
        if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
@@ -2874,26 +2888,13 @@ PP(pp_int)
 {
     dVAR; dSP; dTARGET; tryAMAGICun(int);
     {
-      dTOPss;
-      IV iv;
+      SV * const sv = sv_2num(TOPs);
+      const IV iv = SvIV(sv);
       /* XXX it's arguable that compiler casting to IV might be subtly
         different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
         else preferring IV has introduced a subtle behaviour change bug. OTOH
         relying on floating point to be accurate is a bug.  */
 
-      while (SvAMAGIC(sv)) {
-       SV *tsv = AMG_CALLun(sv,numer);
-       if (!tsv)
-           break;
-       if (SvROK(tsv) && SvRV(tsv) == SvRV(sv)) {
-           SETu(PTR2UV(SvRV(sv)));
-           RETURN;
-       }
-       else
-           sv = tsv;
-      }
-      iv = SvIV(sv); /* attempt to convert to IV if possible. */
-
       if (!SvOK(sv)) {
         SETu(0);
       }
@@ -2903,9 +2904,6 @@ PP(pp_int)
        else
            SETi(iv);
       }
-      else if (SvROK(sv)) {
-           SETu(PTR2UV(SvRV(sv)));
-      }
       else {
          const NV value = SvNV(sv);
          if (value >= 0.0) {
@@ -2931,15 +2929,17 @@ PP(pp_abs)
 {
     dVAR; dSP; dTARGET; tryAMAGICun(abs);
     {
+      SV * const sv = sv_2num(TOPs);
       /* This will cache the NV value if string isn't actually integer  */
-      const IV iv = TOPi;
+      const IV iv = SvIV(sv);
 
-      if (!SvOK(TOPs))
+      if (!SvOK(sv)) {
         SETu(0);
-      else if (SvIOK(TOPs)) {
+      }
+      else if (SvIOK(sv)) {
        /* IVX is precise  */
-       if (SvIsUV(TOPs)) {
-         SETu(TOPu);   /* force it to be numeric only */
+       if (SvIsUV(sv)) {
+         SETu(SvUV(sv));       /* force it to be numeric only */
        } else {
          if (iv >= 0) {
            SETi(iv);
@@ -2954,7 +2954,7 @@ PP(pp_abs)
          }
        }
       } else{
-       const NV value = TOPn;
+       const NV value = SvNV(sv);
        if (value < 0.0)
          SETn(-value);
        else
index 423c4c8..17eb6f2 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -496,8 +496,11 @@ PP(pp_defined)
 
 PP(pp_add)
 {
-    dVAR; dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
-    useleft = USE_LEFT(TOPm1s);
+    dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
+    tryAMAGICbin(add,opASSIGN);
+    svl = sv_2num(TOPm1s);
+    svr = sv_2num(TOPs);
+    useleft = USE_LEFT(svl);
 #ifdef PERL_PRESERVE_IVUV
     /* We must see if we can perform the addition with integers if possible,
        as the integer code detects overflow while the NV code doesn't.
@@ -545,8 +548,8 @@ PP(pp_add)
        unsigned code below is actually shorter than the old code. :-)
     */
 
-    SvIV_please(TOPs);
-    if (SvIOK(TOPs)) {
+    SvIV_please(svr);
+    if (SvIOK(svr)) {
        /* Unless the left argument is integer in range we are going to have to
           use NV maths. Hence only attempt to coerce the right argument if
           we know the left is integer.  */
@@ -562,12 +565,12 @@ PP(pp_add)
               lots of code to speed up what is probably a rarish case.  */
        } else {
            /* Left operand is defined, so is it IV? */
-           SvIV_please(TOPm1s);
-           if (SvIOK(TOPm1s)) {
-               if ((auvok = SvUOK(TOPm1s)))
-                   auv = SvUVX(TOPm1s);
+           SvIV_please(svl);
+           if (SvIOK(svl)) {
+               if ((auvok = SvUOK(svl)))
+                   auv = SvUVX(svl);
                else {
-                   register const IV aiv = SvIVX(TOPm1s);
+                   register const IV aiv = SvIVX(svl);
                    if (aiv >= 0) {
                        auv = aiv;
                        auvok = 1;      /* Now acting as a sign flag.  */
@@ -582,12 +585,12 @@ PP(pp_add)
            bool result_good = 0;
            UV result;
            register UV buv;
-           bool buvok = SvUOK(TOPs);
+           bool buvok = SvUOK(svr);
        
            if (buvok)
-               buv = SvUVX(TOPs);
+               buv = SvUVX(svr);
            else {
-               register const IV biv = SvIVX(TOPs);
+               register const IV biv = SvIVX(svr);
                if (biv >= 0) {
                    buv = biv;
                    buvok = 1;
diff --git a/proto.h b/proto.h
index 7adaac7..19cfb10 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -2179,6 +2179,9 @@ PERL_CALLCONV SV* Perl_sv_2mortal(pTHX_ SV* sv);
 PERL_CALLCONV NV       Perl_sv_2nv(pTHX_ SV* sv)
                        __attribute__nonnull__(pTHX_1);
 
+PERL_CALLCONV SV*      Perl_sv_2num(pTHX_ SV* sv)
+                       __attribute__nonnull__(pTHX_1);
+
 /* PERL_CALLCONV char* Perl_sv_2pv(pTHX_ SV* sv, STRLEN* lp)
                        __attribute__nonnull__(pTHX_1); */
 
diff --git a/sv.c b/sv.c
index df7a1b8..f418b05 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -2501,6 +2501,29 @@ Perl_sv_2nv(pTHX_ register SV *sv)
     return SvNVX(sv);
 }
 
+/*
+=for apidoc sv_2num
+
+Return an SV with the numeric value of the source SV, doing any necessary
+reference or overload conversion.
+
+=cut
+*/
+
+SV *
+Perl_sv_2num(pTHX_ register SV *sv)
+{
+    if (!SvROK(sv))
+       return sv;
+
+    if (SvAMAGIC(sv)) {
+       SV * const tmpsv = AMG_CALLun(sv,numer);
+       if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
+           return sv_2num(tmpsv);
+    }
+    return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
+}
+
 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
  * UV as a string towards the end of buf, and return pointers to start and
  * end of it.