while (len > 0) \
(U) = ((U) << 8) | (B)[--len];
-STATIC SV *a_tag(pTHX_ UV bits) {
-#define a_tag(B) a_tag(aTHX_ (B))
- SV *hint;
+#if A_WORKAROUND_REQUIRE_PROPAGATION
+STATIC UV a_require_tag(pTHX) {
+#define a_require_tag() a_require_tag(aTHX)
const PERL_SI *si;
- UV requires = 0;
- unsigned char buf[sizeof(UV) * 2];
- STRLEN len;
for (si = PL_curstackinfo; si; si = si->si_prev) {
I32 cxix;
const PERL_CONTEXT *cx = si->si_cxstack + cxix;
if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_REQUIRE)
- ++requires;
+ return PTR2UV(cx);
}
}
- A_ENCODE_UV(buf, requires);
+ return PTR2UV(NULL);
+}
+#endif /* A_WORKAROUND_REQUIRE_PROPAGATION */
+
+STATIC SV *a_tag(pTHX_ UV bits) {
+#define a_tag(B) a_tag(aTHX_ (B))
+ SV *hint;
+ const PERL_SI *si;
+ UV cxreq;
+ unsigned char buf[sizeof(UV) * 2];
+ STRLEN len;
+
+ cxreq = a_require_tag();
+ A_ENCODE_UV(buf, cxreq);
A_ENCODE_UV(buf + sizeof(UV), bits);
hint = newSVpvn(buf, sizeof buf);
SvREADONLY_on(hint);
STATIC UV a_detag(pTHX_ const SV *hint) {
#define a_detag(H) a_detag(aTHX_ (H))
const PERL_SI *si;
- UV requires = 0, requires_max = 0, bits = 0;
+ UV cxreq = 0, bits = 0;
unsigned char *buf;
STRLEN len;
return 0;
buf = SvPVX(hint);
- A_DECODE_UV(requires_max, buf);
- for (si = PL_curstackinfo; si; si = si->si_prev) {
- I32 cxix;
-
- for (cxix = si->si_cxix; cxix >= 0; --cxix) {
- const PERL_CONTEXT *cx = si->si_cxstack + cxix;
-
- if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_REQUIRE
- && ++requires > requires_max)
- return 0;
- }
- }
+ A_DECODE_UV(cxreq, buf);
+ if (a_require_tag() != cxreq)
+ return 0;
- A_DECODE_UV(bits, buf + sizeof(UV));
+ A_DECODE_UV(bits, buf + sizeof(UV));
return bits;
}
#else /* A_WORKAROUND_REQUIRE_PROPAGATION */
#define a_tag(B) newSVuv(B)
-#define a_detag(H) (((H) && SvOK(H)) ? SvUVX(H) : 0)
+/* PVs fetched from the hints chain have their SvLEN set to zero, so get the UV
+ * from a copy. */
+#define a_detag(H) \
+ ((H) \
+ ? (SvIOK(H) \
+ ? SvUVX(H) \
+ : (SvPOK(H) \
+ ? sv_2uv(SvLEN(H) ? (H) : sv_mortalcopy(H)) \
+ : 0 \
+ ) \
+ ) \
+ : 0)
#endif /* !A_WORKAROUND_REQUIRE_PROPAGATION */
/* ... pp_rv2hv ............................................................ */
-STATIC OP *a_pp_rv2hv(pTHX) {
+STATIC OP *a_pp_rv2hv_simple(pTHX) {
a_op_info oi;
UV flags;
dSP;
return CALL_FPTR(oi.old_pp)(aTHX);
}
+STATIC OP *a_pp_rv2hv(pTHX) {
+ a_op_info oi;
+ UV flags;
+ dSP;
+
+ a_map_fetch(PL_op, &oi);
+ flags = oi.flags;
+
+ if (flags & A_HINT_DEREF) {
+ if (!SvOK(TOPs)) {
+ SV *hv;
+ POPs;
+ hv = sv_2mortal((SV *) newHV());
+ PUSHs(hv);
+ RETURN;
+ }
+ } else {
+ PL_op->op_ppaddr = oi.old_pp;
+ }
+
+ return CALL_FPTR(oi.old_pp)(aTHX);
+}
+
/* ... pp_deref (aelem,helem,rv2sv,padsv) .................................. */
STATIC OP *a_pp_deref(pTHX) {
case OP_HELEM:
old_ck = a_old_ck_helem;
if ((hint & A_HINT_DO) && !(hint & A_HINT_STRICT))
- a_recheck_rv2xv(cUNOPo->op_first, OP_RV2HV, a_pp_rv2hv);
+ a_recheck_rv2xv(cUNOPo->op_first, OP_RV2HV, a_pp_rv2hv_simple);
break;
case OP_RV2SV:
old_ck = a_old_ck_rv2sv;
switch (o->op_type) {
case OP_RV2AV: old_ck = a_old_ck_rv2av; new_pp = a_pp_rv2av; break;
- case OP_RV2HV: old_ck = a_old_ck_rv2hv; new_pp = a_pp_rv2hv; break;
+ case OP_RV2HV: old_ck = a_old_ck_rv2hv; new_pp = a_pp_rv2hv_simple; break;
}
o = CALL_FPTR(old_ck)(aTHX_ o);
return o;
}
+/* ... ck_xslice (aslice,hslice) ........................................... */
+
+/* I think those are only found at the root, but there's nothing that really
+ * prevent them to be inside the expression too. We only need to update the
+ * root so that the rest of the expression will see the right context when
+ * resolving. That's why we don't replace the ppaddr. */
+
+STATIC OP *(*a_old_ck_aslice)(pTHX_ OP *) = 0;
+STATIC OP *(*a_old_ck_hslice)(pTHX_ OP *) = 0;
+
+STATIC OP *a_ck_xslice(pTHX_ OP *o) {
+ OP * (*old_ck)(pTHX_ OP *o) = 0;
+ UV hint = a_hint();
+
+ switch (o->op_type) {
+ case OP_ASLICE:
+ old_ck = a_old_ck_aslice;
+ break;
+ case OP_HSLICE:
+ old_ck = a_old_ck_hslice;
+ if (hint & A_HINT_DO)
+ a_recheck_rv2xv(cUNOPo->op_first->op_sibling, OP_RV2HV, a_pp_rv2hv);
+ break;
+ }
+ o = CALL_FPTR(old_ck)(aTHX_ o);
+
+ if (hint & A_HINT_DO) {
+ a_map_store_root(o, 0, hint);
+ } else
+ a_map_delete(o);
+
+ return o;
+}
+
/* ... ck_root (exists,delete,keys,values) ................................. */
/* Those ops are only found at the root of a dereferencing expression. We can
a_old_ck_rv2hv = PL_check[OP_RV2HV];
PL_check[OP_RV2HV] = MEMBER_TO_FPTR(a_ck_rv2xv);
+ a_old_ck_aslice = PL_check[OP_ASLICE];
+ PL_check[OP_ASLICE] = MEMBER_TO_FPTR(a_ck_xslice);
+ a_old_ck_hslice = PL_check[OP_HSLICE];
+ PL_check[OP_HSLICE] = MEMBER_TO_FPTR(a_ck_xslice);
+
a_old_ck_exists = PL_check[OP_EXISTS];
PL_check[OP_EXISTS] = MEMBER_TO_FPTR(a_ck_root);
a_old_ck_delete = PL_check[OP_DELETE];
projects / perl / modules / autovivification.git / blobdiff