Within Perl_newSVhek, inline most of newSVpvn_share(), because

[p5sagit/p5-mst-13.2.git] / pp.c

diff --git a/pp.c b/pp.c
index 467ef22..b52be7c 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -334,7 +334,7 @@ PP(pp_pos)
                I32 i = mg->mg_len;
                if (DO_UTF8(sv))
                    sv_pos_b2u(sv, &i);
-               PUSHi(i + PL_curcop->cop_arybase);
+               PUSHi(i + CopARYBASE_get(PL_curcop));
                RETURN;
            }
        }
@@ -998,7 +998,47 @@ PP(pp_pow)
 #endif    
     {
        dPOPTOPnnrl;
+
+#if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
+    /*
+    We are building perl with long double support and are on an AIX OS
+    afflicted with a powl() function that wrongly returns NaNQ for any
+    negative base.  This was reported to IBM as PMR #23047-379 on
+    03/06/2006.  The problem exists in at least the following versions
+    of AIX and the libm fileset, and no doubt others as well:
+
+       AIX 4.3.3-ML10      bos.adt.libm 4.3.3.50
+       AIX 5.1.0-ML04      bos.adt.libm 5.1.0.29
+       AIX 5.2.0           bos.adt.libm 5.2.0.85
+
+    So, until IBM fixes powl(), we provide the following workaround to
+    handle the problem ourselves.  Our logic is as follows: for
+    negative bases (left), we use fmod(right, 2) to check if the
+    exponent is an odd or even integer:
+
+       - if odd,  powl(left, right) == -powl(-left, right)
+       - if even, powl(left, right) ==  powl(-left, right)
+
+    If the exponent is not an integer, the result is rightly NaNQ, so
+    we just return that (as NV_NAN).
+    */
+
+       if (left < 0.0) {
+           NV mod2 = Perl_fmod( right, 2.0 );
+           if (mod2 == 1.0 || mod2 == -1.0) {  /* odd integer */
+               SETn( -Perl_pow( -left, right) );
+           } else if (mod2 == 0.0) {           /* even integer */
+               SETn( Perl_pow( -left, right) );
+           } else {                            /* fractional power */
+               SETn( NV_NAN );
+           }
+       } else {
+           SETn( Perl_pow( left, right) );
+       }
+#else
        SETn( Perl_pow( left, right) );
+#endif  /* HAS_AIX_POWL_NEG_BASE_BUG */
+
 #ifdef PERL_PRESERVE_IVUV
        if (is_int)
            SvIV_please(TOPs);
@@ -2923,7 +2963,7 @@ PP(pp_substr)
     I32 fail;
     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
     const char *tmps;
-    const I32 arybase = PL_curcop->cop_arybase;
+    const I32 arybase = CopARYBASE_get(PL_curcop);
     SV *repl_sv = NULL;
     const char *repl = NULL;
     STRLEN repl_len;
@@ -3124,7 +3164,7 @@ PP(pp_index)
     I32 retval;
     const char *tmps;
     const char *tmps2;
-    const I32 arybase = PL_curcop->cop_arybase;
+    const I32 arybase = CopARYBASE_get(PL_curcop);
     bool big_utf8;
     bool little_utf8;
     const bool is_index = PL_op->op_type == OP_INDEX;
@@ -3673,7 +3713,7 @@ PP(pp_aslice)
     register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
 
     if (SvTYPE(av) == SVt_PVAV) {
-       const I32 arybase = PL_curcop->cop_arybase;
+       const I32 arybase = CopARYBASE_get(PL_curcop);
        if (lval && PL_op->op_private & OPpLVAL_INTRO) {
            register SV **svp;
            I32 max = -1;
@@ -3886,7 +3926,7 @@ PP(pp_hslice)
                        save_helem(hv, keysv, svp);
                    else {
                        STRLEN keylen;
-                       const char *key = SvPV_const(keysv, keylen);
+                       const char * const key = SvPV_const(keysv, keylen);
                        SAVEDELETE(hv, savepvn(key,keylen),
                                   SvUTF8(keysv) ? -keylen : keylen);
                    }
@@ -3926,7 +3966,7 @@ PP(pp_lslice)
     SV ** const lastlelem = PL_stack_base + POPMARK;
     SV ** const firstlelem = PL_stack_base + POPMARK + 1;
     register SV ** const firstrelem = lastlelem + 1;
-    const I32 arybase = PL_curcop->cop_arybase;
+    const I32 arybase = CopARYBASE_get(PL_curcop);
     I32 is_something_there = PL_op->op_flags & OPf_MOD;
 
     register const I32 max = lastrelem - lastlelem;
@@ -4013,7 +4053,6 @@ PP(pp_splice)
     I32 newlen;
     I32 after;
     I32 diff;
-    SV **tmparyval = NULL;
     const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
 
     if (mg) {
@@ -4034,7 +4073,7 @@ PP(pp_splice)
        if (offset < 0)
            offset += AvFILLp(ary) + 1;
        else
-           offset -= PL_curcop->cop_arybase;
+           offset -= CopARYBASE_get(PL_curcop);
        if (offset < 0)
            DIE(aTHX_ PL_no_aelem, i);
        if (++MARK < SP) {
@@ -4079,6 +4118,7 @@ PP(pp_splice)
     }
 
     if (diff < 0) {                            /* shrinking the area */
+       SV **tmparyval;
        if (newlen) {
            Newx(tmparyval, newlen, SV*);       /* so remember insertion */
            Copy(MARK, tmparyval, newlen, SV*);
@@ -4139,15 +4179,14 @@ PP(pp_splice)
        }
     }
     else {                                     /* no, expanding (or same) */
+       SV** tmparyval = NULL;
        if (length) {
            Newx(tmparyval, length, SV*);       /* so remember deletion */
            Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
        }
 
        if (diff > 0) {                         /* expanding */
-
            /* push up or down? */
-
            if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
                if (offset) {
                    src = AvARRAY(ary);
@@ -4188,7 +4227,6 @@ PP(pp_splice)
                        dst++;
                    }
                }
-               Safefree(tmparyval);
            }
            MARK += length - 1;
        }
@@ -4199,10 +4237,10 @@ PP(pp_splice)
                while (length-- > 0)
                    SvREFCNT_dec(tmparyval[length]);
            }
-           Safefree(tmparyval);
        }
        else
            *MARK = &PL_sv_undef;
+       Safefree(tmparyval);
     }
     SP = MARK;
     RETURN;