Merge branch for mostly regen/regcharclass.pl into blead

[perl5.git] / pp_ctl.c

diff --git a/pp_ctl.c b/pp_ctl.c
index 55d9c89..1fc855d 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -77,7 +77,7 @@ PP(pp_regcomp)
 {
     dVAR;
     dSP;
-    register PMOP *pm = (PMOP*)cLOGOP->op_other;
+    PMOP *pm = (PMOP*)cLOGOP->op_other;
     SV **args;
     int nargs;
     REGEXP *re = NULL;
@@ -177,13 +177,13 @@ PP(pp_substcont)
 {
     dVAR;
     dSP;
-    register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
-    register PMOP * const pm = (PMOP*) cLOGOP->op_other;
-    register SV * const dstr = cx->sb_dstr;
-    register char *s = cx->sb_s;
-    register char *m = cx->sb_m;
+    PERL_CONTEXT *cx = &cxstack[cxstack_ix];
+    PMOP * const pm = (PMOP*) cLOGOP->op_other;
+    SV * const dstr = cx->sb_dstr;
+    char *s = cx->sb_s;
+    char *m = cx->sb_m;
     char *orig = cx->sb_orig;
-    register REGEXP * const rx = cx->sb_rx;
+    REGEXP * const rx = cx->sb_rx;
     SV *nsv = NULL;
     REGEXP *old = PM_GETRE(pm);
 
@@ -216,9 +216,7 @@ PP(pp_substcont)
        if (CxONCE(cx) || s < orig ||
                !CALLREGEXEC(rx, s, cx->sb_strend, orig,
                             (s == m) + RX_GOFS(rx), cx->sb_targ, NULL,
-                            ((cx->sb_rflags & REXEC_COPY_STR)
-                             ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
-                             : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
+                                (REXEC_IGNOREPOS|REXEC_NOT_FIRST)))
        {
            SV *targ = cx->sb_targ;
 
@@ -289,6 +287,7 @@ PP(pp_substcont)
     if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
        m = s;
        s = orig;
+        assert(!RX_SUBOFFSET(rx));
        cx->sb_orig = orig = RX_SUBBEG(rx);
        s = orig + (m - s);
        cx->sb_strend = s + (cx->sb_strend - m);
@@ -353,9 +352,9 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
 
     if (!p || p[1] < RX_NPARENS(rx)) {
 #ifdef PERL_OLD_COPY_ON_WRITE
-       i = 7 + RX_NPARENS(rx) * 2;
+       i = 7 + (RX_NPARENS(rx)+1) * 2;
 #else
-       i = 6 + RX_NPARENS(rx) * 2;
+       i = 6 + (RX_NPARENS(rx)+1) * 2;
 #endif
        if (!p)
            Newx(p, i, UV);
@@ -364,6 +363,7 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
        *rsp = (void*)p;
     }
 
+    /* what (if anything) to free on croak */
     *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
     RX_MATCH_COPIED_off(rx);
 
@@ -373,9 +373,10 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
 #endif
 
     *p++ = RX_NPARENS(rx);
-
     *p++ = PTR2UV(RX_SUBBEG(rx));
     *p++ = (UV)RX_SUBLEN(rx);
+    *p++ = (UV)RX_SUBOFFSET(rx);
+    *p++ = (UV)RX_SUBCOFFSET(rx);
     for (i = 0; i <= RX_NPARENS(rx); ++i) {
        *p++ = (UV)RX_OFFS(rx)[i].start;
        *p++ = (UV)RX_OFFS(rx)[i].end;
@@ -403,9 +404,10 @@ S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
 #endif
 
     RX_NPARENS(rx) = *p++;
-
     RX_SUBBEG(rx) = INT2PTR(char*,*p++);
     RX_SUBLEN(rx) = (I32)(*p++);
+    RX_SUBOFFSET(rx) = (I32)*p++;
+    RX_SUBCOFFSET(rx) = (I32)*p++;
     for (i = 0; i <= RX_NPARENS(rx); ++i) {
        RX_OFFS(rx)[i].start = (I32)(*p++);
        RX_OFFS(rx)[i].end = (I32)(*p++);
@@ -445,13 +447,13 @@ S_rxres_free(pTHX_ void **rsp)
 PP(pp_formline)
 {
     dVAR; dSP; dMARK; dORIGMARK;
-    register SV * const tmpForm = *++MARK;
+    SV * const tmpForm = *++MARK;
     SV *formsv;                    /* contains text of original format */
-    register U32 *fpc;     /* format ops program counter */
-    register char *t;      /* current append position in target string */
+    U32 *fpc;      /* format ops program counter */
+    char *t;       /* current append position in target string */
     const char *f;         /* current position in format string */
-    register I32 arg;
-    register SV *sv = NULL; /* current item */
+    I32 arg;
+    SV *sv = NULL; /* current item */
     const char *item = NULL;/* string value of current item */
     I32 itemsize  = 0;     /* length of current item, possibly truncated */
     I32 fieldsize = 0;     /* width of current field */
@@ -1209,7 +1211,7 @@ PP(pp_flop)
        SvGETMAGIC(right);
 
        if (RANGE_IS_NUMERIC(left,right)) {
-           register IV i, j;
+           IV i, j;
            IV max;
            if ((SvOK(left) && SvNV_nomg(left) < IV_MIN) ||
                (SvOK(right) && SvNV_nomg(right) > IV_MAX))
@@ -1293,12 +1295,12 @@ STATIC I32
 S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
 {
     dVAR;
-    register I32 i;
+    I32 i;
 
     PERL_ARGS_ASSERT_DOPOPTOLABEL;
 
     for (i = cxstack_ix; i >= 0; i--) {
-       register const PERL_CONTEXT * const cx = &cxstack[i];
+       const PERL_CONTEXT * const cx = &cxstack[i];
        switch (CxTYPE(cx)) {
        case CXt_SUBST:
        case CXt_SUB:
@@ -1410,7 +1412,7 @@ S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
     PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
 
     for (i = startingblock; i >= 0; i--) {
-       register const PERL_CONTEXT * const cx = &cxstk[i];
+       const PERL_CONTEXT * const cx = &cxstk[i];
        switch (CxTYPE(cx)) {
        default:
            continue;
@@ -1430,7 +1432,7 @@ S_dopoptoeval(pTHX_ I32 startingblock)
     dVAR;
     I32 i;
     for (i = startingblock; i >= 0; i--) {
-       register const PERL_CONTEXT *cx = &cxstack[i];
+       const PERL_CONTEXT *cx = &cxstack[i];
        switch (CxTYPE(cx)) {
        default:
            continue;
@@ -1448,7 +1450,7 @@ S_dopoptoloop(pTHX_ I32 startingblock)
     dVAR;
     I32 i;
     for (i = startingblock; i >= 0; i--) {
-       register const PERL_CONTEXT * const cx = &cxstack[i];
+       const PERL_CONTEXT * const cx = &cxstack[i];
        switch (CxTYPE(cx)) {
        case CXt_SUBST:
        case CXt_SUB:
@@ -1478,7 +1480,7 @@ S_dopoptogiven(pTHX_ I32 startingblock)
     dVAR;
     I32 i;
     for (i = startingblock; i >= 0; i--) {
-       register const PERL_CONTEXT *cx = &cxstack[i];
+       const PERL_CONTEXT *cx = &cxstack[i];
        switch (CxTYPE(cx)) {
        default:
            continue;
@@ -1506,7 +1508,7 @@ S_dopoptowhen(pTHX_ I32 startingblock)
     dVAR;
     I32 i;
     for (i = startingblock; i >= 0; i--) {
-       register const PERL_CONTEXT *cx = &cxstack[i];
+       const PERL_CONTEXT *cx = &cxstack[i];
        switch (CxTYPE(cx)) {
        default:
            continue;
@@ -1529,7 +1531,7 @@ Perl_dounwind(pTHX_ I32 cxix)
 
     while (cxstack_ix > cxix) {
        SV *sv;
-        register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
+        PERL_CONTEXT *cx = &cxstack[cxstack_ix];
        DEBUG_CX("UNWIND");                                             \
        /* Note: we don't need to restore the base context info till the end. */
        switch (CxTYPE(cx)) {
@@ -1639,7 +1641,7 @@ Perl_die_unwind(pTHX_ SV *msv)
        if (cxix >= 0) {
            I32 optype;
            SV *namesv;
-           register PERL_CONTEXT *cx;
+           PERL_CONTEXT *cx;
            SV **newsp;
            COP *oldcop;
            JMPENV *restartjmpenv;
@@ -1737,9 +1739,9 @@ frame for the sub call itself.
 const PERL_CONTEXT *
 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
 {
-    register I32 cxix = dopoptosub(cxstack_ix);
-    register const PERL_CONTEXT *cx;
-    register const PERL_CONTEXT *ccstack = cxstack;
+    I32 cxix = dopoptosub(cxstack_ix);
+    const PERL_CONTEXT *cx;
+    const PERL_CONTEXT *ccstack = cxstack;
     const PERL_SI *top_si = PL_curstackinfo;
 
     for (;;) {
@@ -1779,7 +1781,7 @@ PP(pp_caller)
 {
     dVAR;
     dSP;
-    register const PERL_CONTEXT *cx;
+    const PERL_CONTEXT *cx;
     const PERL_CONTEXT *dbcx;
     I32 gimme;
     const HEK *stash_hek;
@@ -1857,7 +1859,9 @@ PP(pp_caller)
     if (CxTYPE(cx) == CXt_EVAL) {
        /* eval STRING */
        if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
-           PUSHs(cx->blk_eval.cur_text);
+           PUSHs(newSVpvn_flags(SvPVX(cx->blk_eval.cur_text),
+                                SvCUR(cx->blk_eval.cur_text)-2,
+                                SvUTF8(cx->blk_eval.cur_text)|SVs_TEMP));
            PUSHs(&PL_sv_no);
        }
        /* require */
@@ -1950,11 +1954,11 @@ PP(pp_dbstate)
            || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
     {
        dSP;
-       register PERL_CONTEXT *cx;
+       PERL_CONTEXT *cx;
        const I32 gimme = G_ARRAY;
        U8 hasargs;
        GV * const gv = PL_DBgv;
-       register CV * const cv = GvCV(gv);
+       CV * const cv = GvCV(gv);
 
        if (!cv)
            DIE(aTHX_ "No DB::DB routine defined");
@@ -1973,10 +1977,8 @@ PP(pp_dbstate)
        SPAGAIN;
 
        if (CvISXSUB(cv)) {
-           CvDEPTH(cv)++;
            PUSHMARK(SP);
            (void)(*CvXSUB(cv))(aTHX_ cv);
-           CvDEPTH(cv)--;
            FREETMPS;
            LEAVE;
            return NORMAL;
@@ -2037,7 +2039,7 @@ S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 fla
 PP(pp_enter)
 {
     dVAR; dSP;
-    register PERL_CONTEXT *cx;
+    PERL_CONTEXT *cx;
     I32 gimme = GIMME_V;
 
     ENTER_with_name("block");
@@ -2051,7 +2053,7 @@ PP(pp_enter)
 PP(pp_leave)
 {
     dVAR; dSP;
-    register PERL_CONTEXT *cx;
+    PERL_CONTEXT *cx;
     SV **newsp;
     PMOP *newpm;
     I32 gimme;
@@ -2077,7 +2079,7 @@ PP(pp_leave)
 PP(pp_enteriter)
 {
     dVAR; dSP; dMARK;
-    register PERL_CONTEXT *cx;
+    PERL_CONTEXT *cx;
     const I32 gimme = GIMME_V;
     void *itervar; /* location of the iteration variable */
     U8 cxtype = CXt_LOOP_FOR;
@@ -2200,7 +2202,7 @@ PP(pp_enteriter)
 PP(pp_enterloop)
 {
     dVAR; dSP;
-    register PERL_CONTEXT *cx;
+    PERL_CONTEXT *cx;
     const I32 gimme = GIMME_V;
 
     ENTER_with_name("loop1");
@@ -2216,7 +2218,7 @@ PP(pp_enterloop)
 PP(pp_leaveloop)
 {
     dVAR; dSP;
-    register PERL_CONTEXT *cx;
+    PERL_CONTEXT *cx;
     I32 gimme;
     SV **newsp;
     PMOP *newpm;
@@ -2353,7 +2355,7 @@ S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme,
 PP(pp_return)
 {
     dVAR; dSP; dMARK;
-    register PERL_CONTEXT *cx;
+    PERL_CONTEXT *cx;
     bool popsub2 = FALSE;
     bool clear_errsv = FALSE;
     bool lval = FALSE;
@@ -2497,7 +2499,7 @@ PP(pp_leavesublv)
     SV **newsp;
     PMOP *newpm;
     I32 gimme;
-    register PERL_CONTEXT *cx;
+    PERL_CONTEXT *cx;
     SV *sv;
 
     if (CxMULTICALL(&cxstack[cxstack_ix]))
@@ -2562,7 +2564,7 @@ S_unwind_loop(pTHX_ const char * const opname)
 PP(pp_last)
 {
     dVAR;
-    register PERL_CONTEXT *cx;
+    PERL_CONTEXT *cx;
     I32 pop2 = 0;
     I32 gimme;
     I32 optype;
@@ -2632,7 +2634,7 @@ PP(pp_last)
 PP(pp_next)
 {
     dVAR;
-    register PERL_CONTEXT *cx;
+    PERL_CONTEXT *cx;
     const I32 inner = PL_scopestack_ix;
 
     S_unwind_loop(aTHX_ "next");
@@ -2650,7 +2652,7 @@ PP(pp_redo)
 {
     dVAR;
     const I32 cxix = S_unwind_loop(aTHX_ "redo");
-    register PERL_CONTEXT *cx;
+    PERL_CONTEXT *cx;
     I32 oldsave;
     OP* redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
 
@@ -2739,7 +2741,7 @@ PP(pp_goto)
     dVAR; dSP;
     OP *retop = NULL;
     I32 ix;
-    register PERL_CONTEXT *cx;
+    PERL_CONTEXT *cx;
 #define GOTO_DEPTH 64
     OP *enterops[GOTO_DEPTH];
     const char *label = NULL;
@@ -2754,7 +2756,7 @@ PP(pp_goto)
        /* This egregious kludge implements goto &subroutine */
        if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
            I32 cxix;
-           register PERL_CONTEXT *cx;
+           PERL_CONTEXT *cx;
            CV *cv = MUTABLE_CV(SvRV(sv));
            SV** mark;
            I32 items = 0;
@@ -2873,7 +2875,7 @@ PP(pp_goto)
                return retop;
            }
            else {
-               AV* const padlist = CvPADLIST(cv);
+               PADLIST * const padlist = CvPADLIST(cv);
                if (CxTYPE(cx) == CXt_EVAL) {
                    PL_in_eval = CxOLD_IN_EVAL(cx);
                    PL_eval_root = cx->blk_eval.old_eval_root;
@@ -3229,12 +3231,12 @@ than in the scope of the debugger itself).
 CV*
 Perl_find_runcv(pTHX_ U32 *db_seqp)
 {
-    return Perl_find_runcv_where(aTHX_ 0, NULL, db_seqp);
+    return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
 }
 
 /* If this becomes part of the API, it might need a better name. */
 CV *
-Perl_find_runcv_where(pTHX_ U8 cond, void *arg, U32 *db_seqp)
+Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
 {
     dVAR;
     PERL_SI     *si;
@@ -3259,11 +3261,12 @@ Perl_find_runcv_where(pTHX_ U8 cond, void *arg, U32 *db_seqp)
                cv = cx->blk_eval.cv;
            if (cv) {
                switch (cond) {
-               case FIND_RUNCV_root_eq:
-                   if (CvROOT(cv) != (OP *)arg) continue;
+               case FIND_RUNCV_padid_eq:
+                   if (!CvPADLIST(cv)
+                    || CvPADLIST(cv)->xpadl_id != (U32)arg) continue;
                    return cv;
                case FIND_RUNCV_level_eq:
-                   if (level++ != PTR2IV(arg)) continue;
+                   if (level++ != arg) continue;
                    /* GERONIMO! */
                default:
                    return cv;
@@ -3271,7 +3274,7 @@ Perl_find_runcv_where(pTHX_ U8 cond, void *arg, U32 *db_seqp)
            }
        }
     }
-    return cond == FIND_RUNCV_root_eq ? NULL : PL_main_cv;
+    return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
 }
 
 
@@ -3572,7 +3575,7 @@ S_doopen_pm(pTHX_ SV *name)
 PP(pp_require)
 {
     dVAR; dSP;
-    register PERL_CONTEXT *cx;
+    PERL_CONTEXT *cx;
     SV *sv;
     const char *name;
     STRLEN len;
@@ -3695,6 +3698,8 @@ PP(pp_require)
        }
     }
 
+    LOADING_FILE_PROBE(unixname);
+
     /* prepare to compile file */
 
     if (path_is_absolute(name)) {
@@ -3997,6 +4002,8 @@ PP(pp_require)
     /* Restore encoding. */
     PL_encoding = encoding;
 
+    LOADED_FILE_PROBE(unixname);
+
     return op;
 }
 
@@ -4016,7 +4023,7 @@ PP(pp_hintseval)
 PP(pp_entereval)
 {
     dVAR; dSP;
-    register PERL_CONTEXT *cx;
+    PERL_CONTEXT *cx;
     SV *sv;
     const I32 gimme = GIMME_V;
     const U32 was = PL_breakable_sub_gen;
@@ -4147,7 +4154,7 @@ PP(pp_leaveeval)
     SV **newsp;
     PMOP *newpm;
     I32 gimme;
-    register PERL_CONTEXT *cx;
+    PERL_CONTEXT *cx;
     OP *retop;
     const U8 save_flags = PL_op -> op_flags;
     I32 optype;
@@ -4201,7 +4208,7 @@ Perl_delete_eval_scope(pTHX)
     SV **newsp;
     PMOP *newpm;
     I32 gimme;
-    register PERL_CONTEXT *cx;
+    PERL_CONTEXT *cx;
     I32 optype;
        
     POPBLOCK(cx,newpm);
@@ -4252,7 +4259,7 @@ PP(pp_leavetry)
     SV **newsp;
     PMOP *newpm;
     I32 gimme;
-    register PERL_CONTEXT *cx;
+    PERL_CONTEXT *cx;
     I32 optype;
 
     PERL_ASYNC_CHECK();
@@ -4272,7 +4279,7 @@ PP(pp_leavetry)
 PP(pp_entergiven)
 {
     dVAR; dSP;
-    register PERL_CONTEXT *cx;
+    PERL_CONTEXT *cx;
     const I32 gimme = GIMME_V;
     
     ENTER_with_name("given");
@@ -4297,7 +4304,7 @@ PP(pp_entergiven)
 PP(pp_leavegiven)
 {
     dVAR; dSP;
-    register PERL_CONTEXT *cx;
+    PERL_CONTEXT *cx;
     I32 gimme;
     SV **newsp;
     PMOP *newpm;
@@ -4845,7 +4852,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
 PP(pp_enterwhen)
 {
     dVAR; dSP;
-    register PERL_CONTEXT *cx;
+    PERL_CONTEXT *cx;
     const I32 gimme = GIMME_V;
 
     /* This is essentially an optimization: if the match
@@ -4870,7 +4877,7 @@ PP(pp_leavewhen)
 {
     dVAR; dSP;
     I32 cxix;
-    register PERL_CONTEXT *cx;
+    PERL_CONTEXT *cx;
     I32 gimme;
     SV **newsp;
     PMOP *newpm;
@@ -4914,7 +4921,7 @@ PP(pp_continue)
 {
     dVAR; dSP;
     I32 cxix;
-    register PERL_CONTEXT *cx;
+    PERL_CONTEXT *cx;
     I32 gimme;
     SV **newsp;
     PMOP *newpm;
@@ -4942,7 +4949,7 @@ PP(pp_break)
 {
     dVAR;   
     I32 cxix;
-    register PERL_CONTEXT *cx;
+    PERL_CONTEXT *cx;
 
     cxix = dopoptogiven(cxstack_ix); 
     if (cxix < 0)
@@ -4965,17 +4972,17 @@ static MAGIC *
 S_doparseform(pTHX_ SV *sv)
 {
     STRLEN len;
-    register char *s = SvPV(sv, len);
-    register char *send;
-    register char *base = NULL; /* start of current field */
-    register I32 skipspaces = 0; /* number of contiguous spaces seen */
+    char *s = SvPV(sv, len);
+    char *send;
+    char *base = NULL; /* start of current field */
+    I32 skipspaces = 0; /* number of contiguous spaces seen */
     bool noblank   = FALSE; /* ~ or ~~ seen on this line */
     bool repeat    = FALSE; /* ~~ seen on this line */
     bool postspace = FALSE; /* a text field may need right padding */
     U32 *fops;
-    register U32 *fpc;
+    U32 *fpc;
     U32 *linepc = NULL;            /* position of last FF_LINEMARK */
-    register I32 arg;
+    I32 arg;
     bool ischop;           /* it's a ^ rather than a @ */
     bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */