Integrate with Sarathy.

[perl5.git] / pp.c

diff --git a/pp.c b/pp.c
index 9406a0b..fcae1e4 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -28,37 +28,6 @@ static double UV_MAX_cxux = ((double)UV_MAX);
 #endif
 
 /*
 #endif
 
 /*

- * Types used in bitwise operations.
- *
- * Normally we'd just use IV and UV.  However, some hardware and
- * software combinations (e.g. Alpha and current OSF/1) don't have a
- * floating-point type to use for NV that has adequate bits to fully
- * hold an IV/UV.  (In other words, sizeof(long) == sizeof(double).)
- *
- * It just so happens that "int" is the right size almost everywhere.
- */
-typedef int IBW;
-typedef unsigned UBW;
-
-/*
- * Mask used after bitwise operations.
- *
- * There is at least one realm (Cray word machines) that doesn't
- * have an integral type (except char) small enough to be represented
- * in a double without loss; that is, it has no 32-bit type.
- */
-#if LONGSIZE > 4  && defined(_CRAY)
-#  define BW_BITS  32
-#  define BW_MASK  ((1 << BW_BITS) - 1)
-#  define BW_SIGN  (1 << (BW_BITS - 1))
-#  define BWi(i)  (((i) & BW_SIGN) ? ((i) | ~BW_MASK) : ((i) & BW_MASK))
-#  define BWu(u)  ((u) & BW_MASK)
-#else
-#  define BWi(i)  (i)
-#  define BWu(u)  (u)
-#endif
-
-/*

  * Offset for integer pack/unpack.
  *
  * On architectures where I16 and I32 aren't really 16 and 32 bits,
  * Offset for integer pack/unpack.
  *
  * On architectures where I16 and I32 aren't really 16 and 32 bits,


@@ -585,8 +554,8 @@ PP(pp_bless)
        SV *ssv = POPs;
        STRLEN len;
        char *ptr = SvPV(ssv,len);
        SV *ssv = POPs;
        STRLEN len;
        char *ptr = SvPV(ssv,len);

-       if (ckWARN(WARN_UNSAFE) && len == 0)
-           Perl_warner(aTHX_ WARN_UNSAFE, 
+       if (ckWARN(WARN_MISC) && len == 0)
+           Perl_warner(aTHX_ WARN_MISC, 

                   "Explicit blessing to '' (assuming package main)");
        stash = gv_stashpvn(ptr, len, TRUE);
     }
                   "Explicit blessing to '' (assuming package main)");
        stash = gv_stashpvn(ptr, len, TRUE);
     }


@@ -832,8 +801,8 @@ PP(pp_undef)
        hv_undef((HV*)sv);
        break;
     case SVt_PVCV:
        hv_undef((HV*)sv);
        break;
     case SVt_PVCV:

-       if (ckWARN(WARN_UNSAFE) && cv_const_sv((CV*)sv))
-           Perl_warner(aTHX_ WARN_UNSAFE, "Constant subroutine %s undefined",
+       if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
+           Perl_warner(aTHX_ WARN_MISC, "Constant subroutine %s undefined",

                 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
        /* FALL THROUGH */
     case SVt_PVFM:
                 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
        /* FALL THROUGH */
     case SVt_PVFM:


@@ -936,7 +905,7 @@ PP(pp_pow)
     djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
     {
       dPOPTOPnnrl;
     djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
     {
       dPOPTOPnnrl;

-      SETn( pow( left, right) );
+      SETn( Perl_pow( left, right) );

       RETURN;
     }
 }
       RETURN;
     }
 }


@@ -1041,8 +1010,8 @@ PP(pp_modulo)
 #endif
 
            /* Backward-compatibility clause: */
 #endif
 
            /* Backward-compatibility clause: */

-           dright = floor(dright + 0.5);
-           dleft  = floor(dleft + 0.5);
+           dright = Perl_floor(dright + 0.5);
+           dleft  = Perl_floor(dleft + 0.5);

 
            if (!dright)
                DIE(aTHX_ "Illegal modulus zero");
 
            if (!dright)
                DIE(aTHX_ "Illegal modulus zero");


@@ -1144,16 +1113,14 @@ PP(pp_left_shift)
 {
     djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
     {
 {
     djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
     {

-      IBW shift = POPi;
+      IV shift = POPi;

       if (PL_op->op_private & HINT_INTEGER) {
       if (PL_op->op_private & HINT_INTEGER) {

-       IBW i = TOPi;
-       i = BWi(i) << shift;
-       SETi(BWi(i));
+       IV i = TOPi;
+       SETi(i << shift);

       }
       else {
       }
       else {

-       UBW u = TOPu;
-       u <<= shift;
-       SETu(BWu(u));
+       UV u = TOPu;
+       SETu(u << shift);

       }
       RETURN;
     }
       }
       RETURN;
     }


@@ -1163,16 +1130,14 @@ PP(pp_right_shift)
 {
     djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
     {
 {
     djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
     {

-      IBW shift = POPi;
+      IV shift = POPi;

       if (PL_op->op_private & HINT_INTEGER) {
       if (PL_op->op_private & HINT_INTEGER) {

-       IBW i = TOPi;
-       i = BWi(i) >> shift;
-       SETi(BWi(i));
+       IV i = TOPi;
+       SETi(i >> shift);

       }
       else {
       }
       else {

-       UBW u = TOPu;
-       u >>= shift;
-       SETu(BWu(u));
+       UV u = TOPu;
+       SETu(u >> shift);

       }
       RETURN;
     }
       }
       RETURN;
     }


@@ -1234,7 +1199,21 @@ PP(pp_ncmp)
     {
       dPOPTOPnnrl;
       I32 value;
     {
       dPOPTOPnnrl;
       I32 value;

+#ifdef __osf__ /* XXX fix in 5.6.1 --jhi */
+#if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)
+#define Perl_isnan isnanl
+#else
+#define Perl_isnan isnan
+#endif
+#endif

 
 

+#ifdef __osf__ /* XXX fix in 5.6.1 --jhi */
+      if (Perl_isnan(left) || Perl_isnan(right)) {
+         SETs(&PL_sv_undef);
+         RETURN;
+       }
+      value = (left > right) - (left < right);
+#else

       if (left == right)
        value = 0;
       else if (left < right)
       if (left == right)
        value = 0;
       else if (left < right)


@@ -1245,6 +1224,7 @@ PP(pp_ncmp)
        SETs(&PL_sv_undef);
        RETURN;
       }
        SETs(&PL_sv_undef);
        RETURN;
       }

+#endif

       SETi(value);
       RETURN;
     }
       SETi(value);
       RETURN;
     }


@@ -1342,12 +1322,12 @@ PP(pp_bit_and)
       dPOPTOPssrl;
       if (SvNIOKp(left) || SvNIOKp(right)) {
        if (PL_op->op_private & HINT_INTEGER) {
       dPOPTOPssrl;
       if (SvNIOKp(left) || SvNIOKp(right)) {
        if (PL_op->op_private & HINT_INTEGER) {

-         IBW value = SvIV(left) & SvIV(right);
-         SETi(BWi(value));
+         IV i = SvIV(left) & SvIV(right);
+         SETi(i);

        }
        else {
        }
        else {

-         UBW value = SvUV(left) & SvUV(right);
-         SETu(BWu(value));
+         UV u = SvUV(left) & SvUV(right);
+         SETu(u);

        }
       }
       else {
        }
       }
       else {


@@ -1365,12 +1345,12 @@ PP(pp_bit_xor)
       dPOPTOPssrl;
       if (SvNIOKp(left) || SvNIOKp(right)) {
        if (PL_op->op_private & HINT_INTEGER) {
       dPOPTOPssrl;
       if (SvNIOKp(left) || SvNIOKp(right)) {
        if (PL_op->op_private & HINT_INTEGER) {

-         IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
-         SETi(BWi(value));
+         IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
+         SETi(i);

        }
        else {
        }
        else {

-         UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
-         SETu(BWu(value));
+         UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
+         SETu(u);

        }
       }
       else {
        }
       }
       else {


@@ -1388,12 +1368,12 @@ PP(pp_bit_or)
       dPOPTOPssrl;
       if (SvNIOKp(left) || SvNIOKp(right)) {
        if (PL_op->op_private & HINT_INTEGER) {
       dPOPTOPssrl;
       if (SvNIOKp(left) || SvNIOKp(right)) {
        if (PL_op->op_private & HINT_INTEGER) {

-         IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
-         SETi(BWi(value));
+         IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
+         SETi(i);

        }
        else {
        }
        else {

-         UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
-         SETu(BWu(value));
+         UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
+         SETu(u);

        }
       }
       else {
        }
       }
       else {


@@ -1411,9 +1391,23 @@ PP(pp_negate)
        dTOPss;
        if (SvGMAGICAL(sv))
            mg_get(sv);
        dTOPss;
        if (SvGMAGICAL(sv))
            mg_get(sv);

-       if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv) && SvIVX(sv) != IV_MIN)
-           SETi(-SvIVX(sv));
-       else if (SvNIOKp(sv))
+       if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv)) {
+           if (SvIsUV(sv)) {
+               if (SvIVX(sv) == IV_MIN) {
+                   SETi(SvIVX(sv));    /* special case: -((UV)IV_MAX+1) == IV_MIN */
+                   RETURN;
+               }
+               else if (SvUVX(sv) <= IV_MAX) {
+                   SETi(-SvUVX(sv));
+                   RETURN;
+               }
+           }
+           else if (SvIVX(sv) != IV_MIN) {
+               SETi(-SvIVX(sv));
+               RETURN;
+           }
+       }
+       if (SvNIOKp(sv))

            SETn(-SvNV(sv));
        else if (SvPOKp(sv)) {
            STRLEN len;
            SETn(-SvNV(sv));
        else if (SvPOKp(sv)) {
            STRLEN len;


@@ -1454,12 +1448,12 @@ PP(pp_complement)
       dTOPss;
       if (SvNIOKp(sv)) {
        if (PL_op->op_private & HINT_INTEGER) {
       dTOPss;
       if (SvNIOKp(sv)) {
        if (PL_op->op_private & HINT_INTEGER) {

-         IBW value = ~SvIV(sv);
-         SETi(BWi(value));
+         IV i = ~SvIV(sv);
+         SETi(i);

        }
        else {
        }
        else {

-         UBW value = ~SvUV(sv);
-         SETu(BWu(value));
+         UV u = ~SvUV(sv);
+         SETu(u);

        }
       }
       else {
        }
       }
       else {


@@ -2012,7 +2006,9 @@ PP(pp_substr)
        rem -= pos;
     }
     if (fail < 0) {
        rem -= pos;
     }
     if (fail < 0) {

-       if (ckWARN(WARN_SUBSTR) || lvalue || repl)
+       if (lvalue || repl)
+           Perl_croak(aTHX_ "substr outside of string");
+       if (ckWARN(WARN_SUBSTR))

            Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
        RETPUSHUNDEF;
     }
            Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
        RETPUSHUNDEF;
     }


@@ -2199,17 +2195,16 @@ PP(pp_chr)
     char *tmps;
     U32 value = POPu;
 
     char *tmps;
     U32 value = POPu;
 

-    SvUTF8_off(TARG);                          /* decontaminate */

     (void)SvUPGRADE(TARG,SVt_PV);
 
     (void)SvUPGRADE(TARG,SVt_PV);
 

-    if (value >= 128 && PL_bigchar && !IN_BYTE) {
-       SvGROW(TARG,8);
+    if (value > 255 && !IN_BYTE) {
+       SvGROW(TARG, UTF8_MAXLEN+1);

        tmps = SvPVX(TARG);
        tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
        SvCUR_set(TARG, tmps - SvPVX(TARG));
        *tmps = '\0';
        tmps = SvPVX(TARG);
        tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
        SvCUR_set(TARG, tmps - SvPVX(TARG));
        *tmps = '\0';

-       SvUTF8_on(TARG);

        (void)SvPOK_only(TARG);
        (void)SvPOK_only(TARG);

+       SvUTF8_on(TARG);

        XPUSHs(TARG);
        RETURN;
     }
        XPUSHs(TARG);
        RETURN;
     }


@@ -2219,6 +2214,7 @@ PP(pp_chr)
     tmps = SvPVX(TARG);
     *tmps++ = value;
     *tmps = '\0';
     tmps = SvPVX(TARG);
     *tmps++ = value;
     *tmps = '\0';

+    SvUTF8_off(TARG);                          /* decontaminate */

     (void)SvPOK_only(TARG);
     XPUSHs(TARG);
     RETURN;
     (void)SvPOK_only(TARG);
     XPUSHs(TARG);
     RETURN;


@@ -2252,7 +2248,7 @@ PP(pp_ucfirst)
 
     if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
        I32 ulen;
 
     if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
        I32 ulen;

-       U8 tmpbuf[10];
+       U8 tmpbuf[UTF8_MAXLEN];

        U8 *tend;
        UV uv = utf8_to_uv(s, &ulen);
 
        U8 *tend;
        UV uv = utf8_to_uv(s, &ulen);
 


@@ -2311,7 +2307,7 @@ PP(pp_lcfirst)
 
     if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
        I32 ulen;
 
     if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
        I32 ulen;

-       U8 tmpbuf[10];
+       U8 tmpbuf[UTF8_MAXLEN];

        U8 *tend;
        UV uv = utf8_to_uv(s, &ulen);
 
        U8 *tend;
        UV uv = utf8_to_uv(s, &ulen);
 


@@ -2881,8 +2877,8 @@ PP(pp_anonhash)
        SV *val = NEWSV(46, 0);
        if (MARK < SP)
            sv_setsv(val, *++MARK);
        SV *val = NEWSV(46, 0);
        if (MARK < SP)
            sv_setsv(val, *++MARK);

-       else if (ckWARN(WARN_UNSAFE))
-           Perl_warner(aTHX_ WARN_UNSAFE, "Odd number of elements in hash assignment");
+       else if (ckWARN(WARN_MISC))
+           Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");

        (void)hv_store_ent(hv,key,val,0);
     }
     SP = ORIGMARK;
        (void)hv_store_ent(hv,key,val,0);
     }
     SP = ORIGMARK;


@@ -3392,8 +3388,8 @@ PP(pp_unpack)
        default:
            DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
        case ',': /* grandfather in commas but with a warning */
        default:
            DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
        case ',': /* grandfather in commas but with a warning */

-           if (commas++ == 0 && ckWARN(WARN_UNSAFE))
-               Perl_warner(aTHX_ WARN_UNSAFE,
+           if (commas++ == 0 && ckWARN(WARN_UNPACK))
+               Perl_warner(aTHX_ WARN_UNPACK,

                            "Invalid type in unpack: '%c'", (int)datumtype);
            break;
        case '%':
                            "Invalid type in unpack: '%c'", (int)datumtype);
            break;
        case '%':


@@ -4455,8 +4451,8 @@ PP(pp_pack)
        default:
            DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
        case ',': /* grandfather in commas but with a warning */
        default:
            DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
        case ',': /* grandfather in commas but with a warning */

-           if (commas++ == 0 && ckWARN(WARN_UNSAFE))
-               Perl_warner(aTHX_ WARN_UNSAFE,
+           if (commas++ == 0 && ckWARN(WARN_PACK))
+               Perl_warner(aTHX_ WARN_PACK,

                            "Invalid type in pack: '%c'", (int)datumtype);
            break;
        case '%':
                            "Invalid type in pack: '%c'", (int)datumtype);
            break;
        case '%':


@@ -4643,7 +4639,7 @@ PP(pp_pack)
            while (len-- > 0) {
                fromstr = NEXTFROM;
                auint = SvUV(fromstr);
            while (len-- > 0) {
                fromstr = NEXTFROM;
                auint = SvUV(fromstr);

-               SvGROW(cat, SvCUR(cat) + 10);
+               SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN);

                SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
                               - SvPVX(cat));
            }
                SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
                               - SvPVX(cat));
            }


@@ -4747,15 +4743,11 @@ PP(pp_pack)
                    DIE(aTHX_ "Cannot compress negative numbers");
 
                if (
                    DIE(aTHX_ "Cannot compress negative numbers");
 
                if (

-#ifdef BW_BITS
-                   adouble <= BW_MASK
-#else

 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
                    adouble <= UV_MAX_cxux
 #else
                    adouble <= UV_MAX
 #endif
 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
                    adouble <= UV_MAX_cxux
 #else
                    adouble <= UV_MAX
 #endif

-#endif

                    )
                {
                    char   buf[1 + sizeof(UV)];
                    )
                {
                    char   buf[1 + sizeof(UV)];


@@ -4908,11 +4900,11 @@ PP(pp_pack)
                     * of pack() (and all copies of the result) are
                     * gone.
                     */
                     * of pack() (and all copies of the result) are
                     * gone.
                     */

-                   if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr)
+                   if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)

                                                || (SvPADTMP(fromstr)
                                                    && !SvREADONLY(fromstr))))
                    {
                                                || (SvPADTMP(fromstr)
                                                    && !SvREADONLY(fromstr))))
                    {

-                       Perl_warner(aTHX_ WARN_UNSAFE,
+                       Perl_warner(aTHX_ WARN_PACK,

                                "Attempt to pack pointer to temporary value");
                    }
                    if (SvPOK(fromstr) || SvNIOK(fromstr))
                                "Attempt to pack pointer to temporary value");
                    }
                    if (SvPOK(fromstr) || SvNIOK(fromstr))