This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add new opcodes to Opcode.pm
[perl5.git] / op.c
diff --git a/op.c b/op.c
index c911b79..771c105 100644 (file)
--- a/op.c
+++ b/op.c
@@ -1276,8 +1276,10 @@ Perl_scalarvoid(pTHX_ OP *o)
     case OP_AELEMFAST:
     case OP_AELEMFAST_LEX:
     case OP_ASLICE:
+    case OP_KVASLICE:
     case OP_HELEM:
     case OP_HSLICE:
+    case OP_KVHSLICE:
     case OP_UNPACK:
     case OP_PACK:
     case OP_JOIN:
@@ -1754,24 +1756,10 @@ S_finalize_op(pTHX_ OP* o)
         * for reference counts, sv_upgrade() etc. */
        if (cSVOPo->op_sv) {
            const PADOFFSET ix = pad_alloc(OP_CONST, SVf_READONLY);
-           if (o->op_type != OP_METHOD_NAMED
-               && cSVOPo->op_sv == &PL_sv_undef) {
-               /* PL_sv_undef is hack - it's unsafe to store it in the
-                  AV that is the pad, because av_fetch treats values of
-                  PL_sv_undef as a "free" AV entry and will merrily
-                  replace them with a new SV, causing pad_alloc to think
-                  that this pad slot is free. (When, clearly, it is not)
-               */
-               SvOK_off(PAD_SVl(ix));
-               SvPADTMP_on(PAD_SVl(ix));
-               SvREADONLY_on(PAD_SVl(ix));
-           }
-           else {
-               SvREFCNT_dec(PAD_SVl(ix));
-               PAD_SETSV(ix, cSVOPo->op_sv);
-               /* XXX I don't know how this isn't readonly already. */
-               if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
-           }
+           SvREFCNT_dec(PAD_SVl(ix));
+           PAD_SETSV(ix, cSVOPo->op_sv);
+           /* XXX I don't know how this isn't readonly already. */
+           if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
            cSVOPo->op_sv = NULL;
            o->op_targ = ix;
        }
@@ -2075,6 +2063,11 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
     case OP_DBSTATE:
        PL_modcount = RETURN_UNLIMITED_NUMBER;
        break;
+    case OP_KVHSLICE:
+    case OP_KVASLICE:
+       if (type == OP_LEAVESUBLV)
+           o->op_private |= OPpMAYBE_LVSUB;
+        goto nomod;
     case OP_AV2ARYLEN:
        PL_hints |= HINT_BLOCK_SCOPE;
        if (type == OP_LEAVESUBLV)
@@ -3355,7 +3348,7 @@ S_gen_constant_list(pTHX_ OP *o)
 {
     dVAR;
     OP *curop;
-    const I32 oldtmps_floor = PL_tmps_floor;
+    const SSize_t oldtmps_floor = PL_tmps_floor;
     SV **svp;
     AV *av;
 
@@ -4117,11 +4110,9 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
            rend = r + len;
        }
 
-/* There are several snags with this code on EBCDIC:
-   1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
-   2. scan_const() in toke.c has encoded chars in native encoding which makes
-      ranges at least in EBCDIC 0..255 range the bottom odd.
-*/
+/* There is a  snag with this code on EBCDIC: scan_const() in toke.c has
+ * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
+ * odd.  */
 
        if (complement) {
            U8 tmpbuf[UTF8_MAXBYTES+1];
@@ -4131,11 +4122,11 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
            i = 0;
            transv = newSVpvs("");
            while (t < tend) {
-               cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
+               cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
                t += ulen;
-               if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
+               if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
                    t++;
-                   cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
+                   cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
                    t += ulen;
                }
                else {
@@ -4148,11 +4139,11 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
                UV  val = cp[2*j];
                diff = val - nextmin;
                if (diff > 0) {
-                   t = uvuni_to_utf8(tmpbuf,nextmin);
+                   t = uvchr_to_utf8(tmpbuf,nextmin);
                    sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
                    if (diff > 1) {
-                       U8  range_mark = UTF_TO_NATIVE(0xff);
-                       t = uvuni_to_utf8(tmpbuf, val - 1);
+                       U8  range_mark = ILLEGAL_UTF8_BYTE;
+                       t = uvchr_to_utf8(tmpbuf, val - 1);
                        sv_catpvn(transv, (char *)&range_mark, 1);
                        sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
                    }
@@ -4161,13 +4152,13 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
                if (val >= nextmin)
                    nextmin = val + 1;
            }
-           t = uvuni_to_utf8(tmpbuf,nextmin);
+           t = uvchr_to_utf8(tmpbuf,nextmin);
            sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
            {
-               U8 range_mark = UTF_TO_NATIVE(0xff);
+               U8 range_mark = ILLEGAL_UTF8_BYTE;
                sv_catpvn(transv, (char *)&range_mark, 1);
            }
-           t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
+           t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
            sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
            t = (const U8*)SvPVX_const(transv);
            tlen = SvCUR(transv);
@@ -4188,11 +4179,11 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
        while (t < tend || tfirst <= tlast) {
            /* see if we need more "t" chars */
            if (tfirst > tlast) {
-               tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
+               tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
                t += ulen;
-               if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {    /* illegal utf8 val indicates range */
+               if (t < tend && *t == ILLEGAL_UTF8_BYTE) {      /* illegal utf8 val indicates range */
                    t++;
-                   tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
+                   tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
                    t += ulen;
                }
                else
@@ -4202,11 +4193,11 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
            /* now see if we need more "r" chars */
            if (rfirst > rlast) {
                if (r < rend) {
-                   rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
+                   rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
                    r += ulen;
-                   if (r < rend && NATIVE_TO_UTF(*r) == 0xff) {        /* illegal utf8 val indicates range */
+                   if (r < rend && *r == ILLEGAL_UTF8_BYTE) {  /* illegal utf8 val indicates range */
                        r++;
-                       rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
+                       rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
                        r += ulen;
                    }
                    else
@@ -4777,10 +4768,6 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
     if (repl) {
        OP *curop = repl;
        bool konst;
-       if (pm->op_pmflags & PMf_EVAL) {
-           if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
-               CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
-       }
        /* If we are looking at s//.../e with a single statement, get past
           the implicit do{}. */
        if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
@@ -5369,7 +5356,8 @@ S_is_list_assignment(pTHX_ const OP *o)
 
     if (type == OP_LIST || flags & OPf_PARENS ||
        type == OP_RV2AV || type == OP_RV2HV ||
-       type == OP_ASLICE || type == OP_HSLICE)
+       type == OP_ASLICE || type == OP_HSLICE ||
+        type == OP_KVASLICE || type == OP_KVHSLICE)
        return TRUE;
 
     if (type == OP_PADAV || type == OP_PADHV)
@@ -5712,7 +5700,11 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
        SAVEFREEPV(label);
     }
 
-    if (PL_parser && PL_parser->copline == NOLINE)
+    if (PL_parser->preambling != NOLINE) {
+        CopLINE_set(cop, PL_parser->preambling);
+        PL_parser->copline = NOLINE;
+    }
+    else if (PL_parser->copline == NOLINE)
         CopLINE_set(cop, CopLINE(PL_curcop));
     else {
        CopLINE_set(cop, PL_parser->copline);
@@ -5729,7 +5721,7 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
        /* this line can have a breakpoint - store the cop in IV */
        AV *av = CopFILEAVx(PL_curcop);
        if (av) {
-           SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
+           SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
            if (svp && *svp != &PL_sv_undef ) {
                (void)SvIOK_on(*svp);
                SvIV_set(*svp, PTR2IV(cop));
@@ -5901,8 +5893,8 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
            }
 
            *otherp = NULL;
-           if (first->op_type == OP_CONST)
-               first->op_private |= OPpCONST_SHORTCIRCUIT;
+           if (cstop->op_type == OP_CONST)
+               cstop->op_private |= OPpCONST_SHORTCIRCUIT;
            if (PL_madskills) {
                first = newUNOP(OP_NULL, 0, first);
                op_getmad(other, first, '2');
@@ -6573,7 +6565,9 @@ S_ref_array_or_hash(pTHX_ OP *cond)
 
     else if(cond
     && (cond->op_type == OP_ASLICE
-    ||  cond->op_type == OP_HSLICE)) {
+    ||  cond->op_type == OP_KVASLICE
+    ||  cond->op_type == OP_HSLICE
+    ||  cond->op_type == OP_KVHSLICE)) {
 
        /* anonlist now needs a list from this op, was previously used in
         * scalar context */
@@ -8054,11 +8048,13 @@ Perl_oopsAV(pTHX_ OP *o)
 
     switch (o->op_type) {
     case OP_PADSV:
+    case OP_PADHV:
        o->op_type = OP_PADAV;
        o->op_ppaddr = PL_ppaddr[OP_PADAV];
        return ref(o, OP_RV2AV);
 
     case OP_RV2SV:
+    case OP_RV2HV:
        o->op_type = OP_RV2AV;
        o->op_ppaddr = PL_ppaddr[OP_RV2AV];
        ref(o, OP_RV2AV);
@@ -8312,9 +8308,15 @@ Perl_ck_delete(pTHX_ OP *o)
            /* FALL THROUGH */
        case OP_HELEM:
            break;
+       case OP_KVASLICE:
+           Perl_croak(aTHX_ "delete argument is index/value array slice,"
+                            " use array slice");
+       case OP_KVHSLICE:
+           Perl_croak(aTHX_ "delete argument is key/value hash slice, use"
+                            " hash slice");
        default:
-           Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
-                 OP_DESC(o));
+           Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
+                            "element or slice");
        }
        if (kid->op_private & OPpLVAL_INTRO)
            o->op_private |= OPpLVAL_INTRO;
@@ -8478,15 +8480,15 @@ Perl_ck_exists(pTHX_ OP *o)
            (void) ref(kid, o->op_type);
            if (kid->op_type != OP_RV2CV
                        && !(PL_parser && PL_parser->error_count))
-               Perl_croak(aTHX_ "%s argument is not a subroutine name",
-                           OP_DESC(o));
+               Perl_croak(aTHX_
+                         "exists argument is not a subroutine name");
            o->op_private |= OPpEXISTS_SUB;
        }
        else if (kid->op_type == OP_AELEM)
            o->op_flags |= OPf_SPECIAL;
        else if (kid->op_type != OP_HELEM)
-           Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
-                       OP_DESC(o));
+           Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
+                            "element or a subroutine");
        op_null(kid);
     }
     return o;
@@ -11155,8 +11157,8 @@ Perl_rpeep(pTHX_ OP *o)
                             && (   p->op_next->op_type == OP_NEXTSTATE
                                 || p->op_next->op_type == OP_DBSTATE)
                             && count < OPpPADRANGE_COUNTMASK
+                            && base + count == p->op_targ
                     ) {
-                        assert(base + count == p->op_targ);
                         count++;
                         followop = p->op_next;
                     }