X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=eecde6766066e759e10a60f90a0a7d8e7855df5c;hb=3ed26a2c26e4f1468588c483e9e86eae4e74f24f;hp=639454dfd6e94a667fc121626c5351b9ac6ec8cf;hpb=36477c247f3c188fb8cc7e276c87b739d3e6ab7c;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/op.c b/op.c
index 639454d..eecde67 100644
--- a/op.c
+++ b/op.c
@@ -186,12 +186,21 @@ pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix)
 	    if ((sv = svp[off]) &&
 		sv != &sv_undef &&
 		seq <= SvIVX(sv) &&
-		seq > (I32)SvNVX(sv) &&
+		seq > I_32(SvNVX(sv)) &&
 		strEQ(SvPVX(sv), name))
 	    {
-		I32 depth = CvDEPTH(cv) ? CvDEPTH(cv) : 1;
-		AV *oldpad = (AV*)*av_fetch(curlist, depth, FALSE);
-		SV *oldsv = *av_fetch(oldpad, off, TRUE);
+		I32 depth;
+		AV *oldpad;
+		SV *oldsv;
+
+		depth = CvDEPTH(cv);
+		if (!depth) {
+		    if (newoff && !CvUNIQUE(cv))
+			return 0; /* don't clone inactive sub's stack frame */
+		    depth = 1;
+		}
+		oldpad = (AV*)*av_fetch(curlist, depth, FALSE);
+		oldsv = *av_fetch(oldpad, off, TRUE);
 		if (!newoff) {		/* Not a mere clone operation. */
 		    SV *sv = NEWSV(1103,0);
 		    newoff = pad_alloc(OP_PADSV, SVs_PADMY);
@@ -201,9 +210,19 @@ pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix)
 		    SvNVX(sv) = (double)curcop->cop_seq;
 		    SvIVX(sv) = 999999999;	/* A ref, intro immediately */
 		    SvFLAGS(sv) |= SVf_FAKE;
+		    if (!CvUNIQUE(cv)) {
+			/* "It's closures all the way down." */
+			CvCLONE_on(compcv);
+			if (cv != startcv) {
+			    CV *bcv;
+			    for (bcv = startcv;
+				 bcv && bcv != cv && !CvCLONE(bcv);
+				 bcv = CvOUTSIDE(bcv))
+				CvCLONE_on(bcv);
+			}
+		    }
 		}
 		av_store(comppad, newoff, SvREFCNT_inc(oldsv));
-		CvCLONE_on(compcv);
 		return newoff;
 	    }
 	}
@@ -260,7 +279,7 @@ char *name;
 	if ((sv = svp[off]) &&
 	    sv != &sv_undef &&
 	    seq <= SvIVX(sv) &&
-	    seq > (I32)SvNVX(sv) &&
+	    seq > I_32(SvNVX(sv)) &&
 	    strEQ(SvPVX(sv), name))
 	{
 	    return (PADOFFSET)off;
@@ -441,9 +460,9 @@ OP *op;
 	break;
     case OP_NEXTSTATE:
     case OP_DBSTATE:
+	Safefree(cCOP->cop_label);
 	SvREFCNT_dec(cCOP->cop_filegv);
 	break;
-    /* case OP_ANONCODE: XXX breaks eval of anon subs in closures (cf. Opcode) */
     case OP_CONST:
 	SvREFCNT_dec(cSVOP->op_sv);
 	break;
@@ -900,7 +919,6 @@ I32 type;
 {
     OP *kid;
     SV *sv;
-    char mtype;
 
     if (!op || error_count)
 	return op;
@@ -922,6 +940,10 @@ I32 type;
 	else
 	    croak("That use of $[ is unsupported");
 	break;
+    case OP_STUB:
+	if (op->op_flags & OPf_PARENS)
+	    break;
+	goto nomod;
     case OP_ENTERSUB:
 	if ((type == OP_UNDEF || type == OP_REFGEN) &&
 	    !(op->op_flags & OPf_STACKED)) {
@@ -1024,23 +1046,13 @@ I32 type;
     case OP_KEYS:
 	if (type != OP_SASSIGN)
 	    goto nomod;
-	mtype = 'k';
-	goto makelv;
+	/* FALL THROUGH */
     case OP_POS:
-	mtype = '.';
-	goto makelv;
     case OP_VEC:
-	mtype = 'v';
-	goto makelv;
     case OP_SUBSTR:
-	mtype = 'x';
-      makelv:
 	pad_free(op->op_targ);
 	op->op_targ = pad_alloc(op->op_type, SVs_PADMY);
-	sv = PAD_SV(op->op_targ);
-	sv_upgrade(sv, SVt_PVLV);
-	sv_magic(sv, Nullsv, mtype, Nullch, 0);
-	curpad[op->op_targ] = sv;
+	assert(SvTYPE(PAD_SV(op->op_targ)) == SVt_NULL);
 	if (op->op_flags & OPf_KIDS)
 	    mod(cBINOP->op_first->op_sibling, type);
 	break;
@@ -1127,8 +1139,10 @@ I32 type;
 	ref(cUNOP->op_first, op->op_type);
 	/* FALL THROUGH */
     case OP_PADSV:
-	if (type == OP_RV2AV || type == OP_RV2HV) {
-	    op->op_private |= (type == OP_RV2AV ? OPpDEREF_AV : OPpDEREF_HV);
+	if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
+	    op->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
+			       : type == OP_RV2HV ? OPpDEREF_HV
+			       : OPpDEREF_SV);
 	    op->op_flags |= OPf_MOD;
 	}
 	break;
@@ -1155,8 +1169,10 @@ I32 type;
     case OP_AELEM:
     case OP_HELEM:
 	ref(cBINOP->op_first, op->op_type);
-	if (type == OP_RV2AV || type == OP_RV2HV) {
-	    op->op_private |= (type == OP_RV2AV ? OPpDEREF_AV : OPpDEREF_HV);
+	if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
+	    op->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
+			       : type == OP_RV2HV ? OPpDEREF_HV
+			       : OPpDEREF_SV);
 	    op->op_flags |= OPf_MOD;
 	}
 	break;
@@ -2698,7 +2714,7 @@ newFOROP(I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont
     else {
 	sv = newGVOP(OP_GV, 0, defgv);
     }
-    if (expr->op_type == OP_RV2AV) {
+    if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
 	expr = scalar(ref(expr, OP_ITER));
 	iterflags |= OPf_STACKED;
     }
@@ -2767,19 +2783,59 @@ CV *cv;
     }
 }
 
-CV *
-cv_clone(proto)
+#ifdef DEBUG_CLOSURES
+static void
+cv_dump(cv)
+CV* cv;
+{
+    CV *outside = CvOUTSIDE(cv);
+    AV* padlist = CvPADLIST(cv);
+    AV* pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
+    AV* pad = (AV*)*av_fetch(padlist, 1, FALSE);
+    SV** pname = AvARRAY(pad_name);
+    SV** ppad = AvARRAY(pad);
+    I32 ix;
+
+    PerlIO_printf(Perl_debug_log, "\tCV=0x%p (%s), OUTSIDE=0x%p (%s)\n",
+		  cv,
+		  (CvANON(cv) ? "ANON"
+		   : (cv == main_cv) ? "MAIN"
+		   : CvUNIQUE(outside) ? "UNIQUE"
+		   : CvGV(cv) ? GvNAME(CvGV(cv)) : "?mystery?"),
+		  outside,
+		  (!outside ? "null"
+		   : CvANON(outside) ? "ANON"
+		   : (outside == main_cv) ? "MAIN"
+		   : CvUNIQUE(outside) ? "UNIQUE"
+		   : CvGV(outside) ? GvNAME(CvGV(outside)) : "?mystery?"));
+
+    for (ix = 1; ix <= AvFILL(pad); ix++) {
+	if (SvPOK(pname[ix]))
+	    PerlIO_printf(Perl_debug_log, "\t%4d. 0x%p (\"%s\" %ld-%ld)\n",
+			  ix, ppad[ix], SvPVX(pname[ix]),
+			  (long)I_32(SvNVX(pname[ix])),
+			  (long)SvIVX(pname[ix]));
+    }
+}
+#endif /* DEBUG_CLOSURES */
+
+static CV *
+cv_clone2(proto, outside)
 CV* proto;
+CV* outside;
 {
     AV* av;
     I32 ix;
     AV* protopadlist = CvPADLIST(proto);
     AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
     AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
-    SV** svp = AvARRAY(protopad);
+    SV** pname = AvARRAY(protopad_name);
+    SV** ppad = AvARRAY(protopad);
     AV* comppadlist;
     CV* cv;
 
+    assert(!CvUNIQUE(proto));
+
     ENTER;
     SAVESPTR(curpad);
     SAVESPTR(comppad);
@@ -2788,14 +2844,16 @@ CV* proto;
     cv = compcv = (CV*)NEWSV(1104,0);
     sv_upgrade((SV *)cv, SVt_PVCV);
     CvCLONED_on(cv);
+    if (CvANON(proto))
+	CvANON_on(cv);
 
     CvFILEGV(cv)	= CvFILEGV(proto);
     CvGV(cv)		= GvREFCNT_inc(CvGV(proto));
     CvSTASH(cv)		= CvSTASH(proto);
     CvROOT(cv)		= CvROOT(proto);
     CvSTART(cv)		= CvSTART(proto);
-    if (CvOUTSIDE(proto))
-	CvOUTSIDE(cv)	= (CV*)SvREFCNT_inc((SV*)CvOUTSIDE(proto));
+    if (outside)
+	CvOUTSIDE(cv)	= (CV*)SvREFCNT_inc(outside);
 
     comppad = newAV();
 
@@ -2804,7 +2862,7 @@ CV* proto;
     av_store(comppadlist, 0, SvREFCNT_inc((SV*)protopad_name));
     av_store(comppadlist, 1, (SV*)comppad);
     CvPADLIST(cv) = comppadlist;
-    av_extend(comppad, AvFILL(protopad));
+    av_fill(comppad, AvFILL(protopad));
     curpad = AvARRAY(comppad);
 
     av = newAV();           /* will be @_ */
@@ -2812,37 +2870,77 @@ CV* proto;
     av_store(comppad, 0, (SV*)av);
     AvFLAGS(av) = AVf_REIFY;
 
-    svp = AvARRAY(protopad_name);
-    for ( ix = AvFILL(protopad); ix > 0; ix--) {
-	SV *sv;
-	if (svp[ix] != &sv_undef) {
-	    char *name = SvPVX(svp[ix]);    /* XXX */
-	    if (SvFLAGS(svp[ix]) & SVf_FAKE) {	/* lexical from outside? */
-		I32 off = pad_findlex(name,ix,curcop->cop_seq, CvOUTSIDE(proto),
-					cxstack_ix);
-		if (off != ix)
+    for (ix = AvFILL(protopad); ix > 0; ix--) {
+	SV* sv;
+	if (pname[ix] != &sv_undef) {
+	    char *name = SvPVX(pname[ix]);    /* XXX */
+	    if (SvFLAGS(pname[ix]) & SVf_FAKE) {   /* lexical from outside? */
+		I32 off = pad_findlex(name, ix, SvIVX(pname[ix]),
+				      CvOUTSIDE(cv), cxstack_ix);
+		if (!off)
+		    curpad[ix] = SvREFCNT_inc(ppad[ix]);
+		else if (off != ix)
 		    croak("panic: cv_clone: %s", name);
 	    }
 	    else {				/* our own lexical */
-		if (*name == '@')
-		    av_store(comppad, ix, sv = (SV*)newAV());
+		if (*name == '&') {
+		    /* anon code -- we'll come back for it */
+		    sv = SvREFCNT_inc(ppad[ix]);
+		}
+		else if (*name == '@')
+		    sv = (SV*)newAV();
 		else if (*name == '%')
-		    av_store(comppad, ix, sv = (SV*)newHV());
+		    sv = (SV*)newHV();
 		else
-		    av_store(comppad, ix, sv = NEWSV(0,0));
-		SvPADMY_on(sv);
+		    sv = NEWSV(0,0);
+		if (!SvPADBUSY(sv))
+		    SvPADMY_on(sv);
+		curpad[ix] = sv;
 	    }
 	}
 	else {
-	    av_store(comppad, ix, sv = NEWSV(0,0));
+	    sv = NEWSV(0,0);
 	    SvPADTMP_on(sv);
+	    curpad[ix] = sv;
 	}
     }
 
+    /* Now that vars are all in place, clone nested closures. */
+
+    for (ix = AvFILL(protopad); ix > 0; ix--) {
+	if (pname[ix] != &sv_undef
+	    && !(SvFLAGS(pname[ix]) & SVf_FAKE)
+	    && *SvPVX(pname[ix]) == '&'
+	    && CvCLONE(ppad[ix]))
+	{
+	    CV *kid = cv_clone2((CV*)ppad[ix], cv);
+	    SvREFCNT_dec(ppad[ix]);
+	    CvCLONE_on(kid);
+	    SvPADMY_on(kid);
+	    curpad[ix] = (SV*)kid;
+	}
+    }
+
+#ifdef DEBUG_CLOSURES
+    PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
+    cv_dump(outside);
+    PerlIO_printf(Perl_debug_log, "  from:\n");
+    cv_dump(proto);
+    PerlIO_printf(Perl_debug_log, "   to:\n");
+    cv_dump(cv);
+#endif
+
     LEAVE;
     return cv;
 }
 
+CV *
+cv_clone(proto)
+CV* proto;
+{
+    return cv_clone2(proto, CvOUTSIDE(proto));
+}
+
 SV *
 cv_const_sv(cv)
 CV *cv;
@@ -3300,6 +3398,27 @@ OP *o;
 /* Check routines. */
 
 OP *
+ck_anoncode(op)
+OP *op;
+{
+    PADOFFSET ix;
+    SV* name;
+
+    name = NEWSV(1106,0);
+    sv_upgrade(name, SVt_PVNV);
+    sv_setpvn(name, "&", 1);
+    SvIVX(name) = -1;
+    SvNVX(name) = 1;
+    ix = pad_alloc(op->op_type, SVs_PADMY);
+    av_store(comppad_name, ix, name);
+    av_store(comppad, ix, cSVOP->op_sv);
+    SvPADMY_on(cSVOP->op_sv);
+    cSVOP->op_sv = Nullsv;
+    cSVOP->op_targ = ix;
+    return op;
+}
+
+OP *
 ck_bitop(op)
 OP *op;
 {
@@ -3346,10 +3465,14 @@ ck_delete(op)
 OP *op;
 {
     op = ck_fun(op);
+    op->op_private = 0;
     if (op->op_flags & OPf_KIDS) {
 	OP *kid = cUNOP->op_first;
-	if (kid->op_type != OP_HELEM)
-	    croak("%s argument is not a HASH element", op_desc[op->op_type]);
+	if (kid->op_type == OP_HSLICE)
+	    op->op_private |= OPpSLICE;
+	else if (kid->op_type != OP_HELEM)
+	    croak("%s argument is not a HASH element or slice",
+		  op_desc[op->op_type]);
 	null(kid);
     }
     return op;
@@ -3431,6 +3554,20 @@ OP *op;
 }
 
 OP *
+ck_exists(op)
+OP *op;
+{
+    op = ck_fun(op);
+    if (op->op_flags & OPf_KIDS) {
+	OP *kid = cUNOP->op_first;
+	if (kid->op_type != OP_HELEM)
+	    croak("%s argument is not a HASH element", op_desc[op->op_type]);
+	null(kid);
+    }
+    return op;
+}
+
+OP *
 ck_gvconst(o)
 register OP *o;
 {
@@ -4232,7 +4369,7 @@ register OP* o;
 
 	case OP_GV:
 	    if (o->op_next->op_type == OP_RV2SV) {
-		if (!(o->op_next->op_private & (OPpDEREF_HV|OPpDEREF_AV))) {
+		if (!(o->op_next->op_private & OPpDEREF)) {
 		    null(o->op_next);
 		    o->op_private |= o->op_next->op_private & OPpLVAL_INTRO;
 		    o->op_next = o->op_next->op_next;
@@ -4246,8 +4383,7 @@ register OP* o;
 		if (pop->op_type == OP_CONST &&
 		    (op = pop->op_next) &&
 		    pop->op_next->op_type == OP_AELEM &&
-		    !(pop->op_next->op_private &
-			(OPpDEREF_HV|OPpDEREF_AV|OPpLVAL_INTRO)) &&
+		    !(pop->op_next->op_private & (OPpDEREF|OPpLVAL_INTRO)) &&
 		    (i = SvIV(((SVOP*)pop)->op_sv) - compiling.cop_arybase)
 				<= 255 &&
 		    i >= 0)