PP(pp_padav)
{
dSP; dTARGET;
- I32 gimme;
+ U8 gimme;
assert(SvTYPE(TARG) == SVt_PVAV);
if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
SAVECLEARSV(PAD_SVl(PL_op->op_targ));
EXTEND(SP, 1);
+
if (PL_op->op_flags & OPf_REF) {
PUSHs(TARG);
RETURN;
- } else if (PL_op->op_private & OPpMAYBE_LVSUB) {
- const I32 flags = is_lvalue_sub();
- if (flags && !(flags & OPpENTERSUB_INARGS)) {
- if (GIMME_V == G_SCALAR)
- /* diag_listed_as: Can't return %s to lvalue scalar context */
- Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
- PUSHs(TARG);
- RETURN;
+ }
+ else if (PL_op->op_private & OPpMAYBE_LVSUB) {
+ const I32 flags = is_lvalue_sub();
+ if (flags && !(flags & OPpENTERSUB_INARGS)) {
+ if (GIMME_V == G_SCALAR)
+ /* diag_listed_as: Can't return %s to lvalue scalar context */
+ Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
+ PUSHs(TARG);
+ RETURN;
}
}
+
gimme = GIMME_V;
if (gimme == G_ARRAY) {
/* XXX see also S_pushav in pp_hot.c */
- const Size_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
+ const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
EXTEND(SP, maxarg);
if (SvMAGICAL(TARG)) {
- Size_t i;
+ SSize_t i;
for (i=0; i < maxarg; i++) {
SV * const * const svp = av_fetch(MUTABLE_AV(TARG), i, FALSE);
SP[i+1] = (svp) ? *svp : &PL_sv_undef;
}
}
else {
- PADOFFSET i;
- for (i=0; i < (PADOFFSET)maxarg; i++) {
+ SSize_t i;
+ for (i=0; i < maxarg; i++) {
SV * const sv = AvARRAY((const AV *)TARG)[i];
SP[i+1] = sv ? sv : &PL_sv_undef;
}
PP(pp_padhv)
{
dSP; dTARGET;
- I32 gimme;
+ U8 gimme;
assert(SvTYPE(TARG) == SVt_PVHV);
XPUSHs(TARG);
if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
SAVECLEARSV(PAD_SVl(PL_op->op_targ));
+
if (PL_op->op_flags & OPf_REF)
RETURN;
else if (PL_op->op_private & OPpMAYBE_LVSUB) {
- const I32 flags = is_lvalue_sub();
- if (flags && !(flags & OPpENTERSUB_INARGS)) {
- if (GIMME_V == G_SCALAR)
- /* diag_listed_as: Can't return %s to lvalue scalar context */
- Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
- RETURN;
- }
+ const I32 flags = is_lvalue_sub();
+ if (flags && !(flags & OPpENTERSUB_INARGS)) {
+ if (GIMME_V == G_SCALAR)
+ /* diag_listed_as: Can't return %s to lvalue scalar context */
+ Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
+ RETURN;
+ }
}
+
gimme = GIMME_V;
if (gimme == G_ARRAY) {
RETURNOP(Perl_do_kv(aTHX));
else if ((PL_op->op_private & OPpTRUEBOOL
|| ( PL_op->op_private & OPpMAYBE_TRUEBOOL
&& block_gimme() == G_VOID ))
- && (!SvRMAGICAL(TARG) || !mg_find(TARG, PERL_MAGIC_tied)))
+ && (!SvRMAGICAL(TARG) || !mg_find(TARG, PERL_MAGIC_tied))
+ )
SETs(HvUSEDKEYS(TARG) ? &PL_sv_yes : sv_2mortal(newSViv(0)));
else if (gimme == G_SCALAR) {
SV* const sv = Perl_hv_scalar(aTHX_ MUTABLE_HV(TARG));
break;
case 'F':
if (len == 10 && strEQ(second_letter, "ILEHANDLE")) {
- /* finally deprecated in 5.8.0 */
- deprecate("*glob{FILEHANDLE}");
tmpRef = MUTABLE_SV(GvIOp(gv));
}
else
PUSHs(newsv);
}
else {
- mPUSHi(do_trans(sv));
+ I32 i = do_trans(sv);
+ mPUSHi(i);
}
RETURN;
}
}
-/* also used for: pp_i_postdec() pp_i_postinc() pp_postdec() */
+/* common "slow" code for pp_postinc and pp_postdec */
-PP(pp_postinc)
+static OP *
+S_postincdec_common(pTHX_ SV *sv, SV *targ)
{
- dSP; dTARGET;
+ dSP;
const bool inc =
PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC;
- if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))
- Perl_croak_no_modify();
- if (SvROK(TOPs))
+
+ if (SvROK(sv))
TARG = sv_newmortal();
- sv_setsv(TARG, TOPs);
- if (!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
- && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
- {
- SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
- SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
- }
- else if (inc)
- sv_inc_nomg(TOPs);
- else sv_dec_nomg(TOPs);
- SvSETMAGIC(TOPs);
+ sv_setsv(TARG, sv);
+ if (inc)
+ sv_inc_nomg(sv);
+ else
+ sv_dec_nomg(sv);
+ SvSETMAGIC(sv);
/* special case for undef: see thread at 2003-03/msg00536.html in archive */
if (inc && !SvOK(TARG))
sv_setiv(TARG, 0);
return NORMAL;
}
+
+/* also used for: pp_i_postinc() */
+
+PP(pp_postinc)
+{
+ dSP; dTARGET;
+ SV *sv = TOPs;
+
+ /* special-case sv being a simple integer */
+ if (LIKELY(((sv->sv_flags &
+ (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
+ SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
+ == SVf_IOK))
+ && SvIVX(sv) != IV_MAX)
+ {
+ IV iv = SvIVX(sv);
+ SvIV_set(sv, iv + 1);
+ TARGi(iv, 0); /* arg not GMG, so can't be tainted */
+ SETs(TARG);
+ return NORMAL;
+ }
+
+ return S_postincdec_common(aTHX_ sv, TARG);
+}
+
+
+/* also used for: pp_i_postdec() */
+
+PP(pp_postdec)
+{
+ dSP; dTARGET;
+ SV *sv = TOPs;
+
+ /* special-case sv being a simple integer */
+ if (LIKELY(((sv->sv_flags &
+ (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
+ SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
+ == SVf_IOK))
+ && SvIVX(sv) != IV_MIN)
+ {
+ IV iv = SvIVX(sv);
+ SvIV_set(sv, iv - 1);
+ TARGi(iv, 0); /* arg not GMG, so can't be tainted */
+ SETs(TARG);
+ return NORMAL;
+ }
+
+ return S_postincdec_common(aTHX_ sv, TARG);
+}
+
+
/* Ordinary operators. */
PP(pp_pow)
tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
svr = TOPs;
svl = TOPm1s;
+
#ifdef PERL_PRESERVE_IVUV
+
+ /* special-case some simple common cases */
+ if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
+ IV il, ir;
+ U32 flags = (svl->sv_flags & svr->sv_flags);
+ if (flags & SVf_IOK) {
+ /* both args are simple IVs */
+ UV topl, topr;
+ il = SvIVX(svl);
+ ir = SvIVX(svr);
+ do_iv:
+ topl = ((UV)il) >> (UVSIZE * 4 - 1);
+ topr = ((UV)ir) >> (UVSIZE * 4 - 1);
+
+ /* if both are in a range that can't under/overflow, do a
+ * simple integer multiply: if the top halves(*) of both numbers
+ * are 00...00 or 11...11, then it's safe.
+ * (*) for 32-bits, the "top half" is the top 17 bits,
+ * for 64-bits, its 33 bits */
+ if (!(
+ ((topl+1) | (topr+1))
+ & ( (((UV)1) << (UVSIZE * 4 + 1)) - 2) /* 11..110 */
+ )) {
+ SP--;
+ TARGi(il * ir, 0); /* args not GMG, so can't be tainted */
+ SETs(TARG);
+ RETURN;
+ }
+ goto generic;
+ }
+ else if (flags & SVf_NOK) {
+ /* both args are NVs */
+ NV nl = SvNVX(svl);
+ NV nr = SvNVX(svr);
+ NV result;
+
+ if (
+#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
+ !Perl_isnan(nl) && nl == (NV)(il = (IV)nl)
+ && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr)
+#else
+ nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr)
+#endif
+ )
+ /* nothing was lost by converting to IVs */
+ goto do_iv;
+ SP--;
+ result = nl * nr;
+# if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE && NVSIZE == 16
+ if (Perl_isinf(result)) {
+ Zero((U8*)&result + 8, 8, U8);
+ }
+# endif
+ TARGn(result, 0); /* args not GMG, so can't be tainted */
+ SETs(TARG);
+ RETURN;
+ }
+ }
+
+ generic:
+
if (SvIV_please_nomg(svr)) {
/* Unless the left argument is integer in range we are going to have to
use NV maths. Hence only attempt to coerce the right argument if
{
NV right = SvNV_nomg(svr);
NV left = SvNV_nomg(svl);
+ NV result = left * right;
+
(void)POPs;
- SETn( left * right );
+#if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE && NVSIZE == 16
+ if (Perl_isinf(result)) {
+ Zero((U8*)&result + 8, 8, U8);
+ }
+#endif
+ SETn(result);
RETURN;
}
}
if (GIMME_V == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
dMARK;
- const Size_t items = SP - MARK;
+ const SSize_t items = SP - MARK;
const U8 mod = PL_op->op_flags & OPf_MOD;
if (count > 1) {
- Size_t max;
+ SSize_t max;
- if ( items > MEM_SIZE_MAX / (UV)count /* max would overflow */
- || items > (U32)I32_MAX / sizeof(SV *) /* repeatcpy would overflow */
+ if ( items > SSize_t_MAX / count /* max would overflow */
+ /* repeatcpy would overflow */
+ || items > I32_MAX / (I32)sizeof(SV *)
)
Perl_croak(aTHX_ "%s","Out of memory during list extend");
max = items * count;
SP += max;
}
else if (count <= 0)
- SP -= items;
+ SP = MARK;
}
else { /* Note: mark already snarfed by pp_list */
SV * const tmpstr = POPs;
tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
svr = TOPs;
svl = TOPm1s;
- useleft = USE_LEFT(svl);
+
#ifdef PERL_PRESERVE_IVUV
+
+ /* special-case some simple common cases */
+ if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
+ IV il, ir;
+ U32 flags = (svl->sv_flags & svr->sv_flags);
+ if (flags & SVf_IOK) {
+ /* both args are simple IVs */
+ UV topl, topr;
+ il = SvIVX(svl);
+ ir = SvIVX(svr);
+ do_iv:
+ topl = ((UV)il) >> (UVSIZE * 8 - 2);
+ topr = ((UV)ir) >> (UVSIZE * 8 - 2);
+
+ /* if both are in a range that can't under/overflow, do a
+ * simple integer subtract: if the top of both numbers
+ * are 00 or 11, then it's safe */
+ if (!( ((topl+1) | (topr+1)) & 2)) {
+ SP--;
+ TARGi(il - ir, 0); /* args not GMG, so can't be tainted */
+ SETs(TARG);
+ RETURN;
+ }
+ goto generic;
+ }
+ else if (flags & SVf_NOK) {
+ /* both args are NVs */
+ NV nl = SvNVX(svl);
+ NV nr = SvNVX(svr);
+
+ if (
+#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
+ !Perl_isnan(nl) && nl == (NV)(il = (IV)nl)
+ && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr)
+#else
+ nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr)
+#endif
+ )
+ /* nothing was lost by converting to IVs */
+ goto do_iv;
+ SP--;
+ TARGn(nl - nr, 0); /* args not GMG, so can't be tainted */
+ SETs(TARG);
+ RETURN;
+ }
+ }
+
+ generic:
+
+ useleft = USE_LEFT(svl);
/* See comments in pp_add (in pp_hot.c) about Overflow, and how
"bad things" happen if you rely on signed integers wrapping. */
if (SvIV_please_nomg(svr)) {
} /* Overflow, drop through to NVs. */
}
}
+#else
+ useleft = USE_LEFT(svl);
#endif
{
NV value = SvNV_nomg(svr);
while (tmps < send) {
const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
tmps += l;
- targlen += UNISKIP(~c);
+ targlen += UVCHR_SKIP(~c);
nchar++;
if (c > 0xff)
nwide++;
U8 *result;
U8 *p;
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
+ deprecated_above_ff_msg, PL_op_desc[PL_op->op_type]);
Newx(result, targlen + 1, U8);
p = result;
while (tmps < send) {
} else {
/* 2s complement assumption. Also, not really needed as
IV_MIN and -IV_MIN should both be %100...00 and NV-able */
- SETu(IV_MIN);
+ SETu((UV)IV_MIN);
}
}
}
SvUPGRADE(TARG,SVt_PV);
if (value > 255 && !IN_BYTES) {
- SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
+ SvGROW(TARG, (STRLEN)UVCHR_SKIP(value)+1);
tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
SvCUR_set(TARG, tmps - SvPVX_const(TARG));
*tmps = '\0';
/* We may be able to get away with changing only the first character, in
* place, but not if read-only, etc. Later we may discover more reasons to
* not convert in-place. */
- inplace = !SvREADONLY(source)
- && ( SvPADTMP(source)
- || ( SvTEMP(source) && !SvSMAGICAL(source)
- && SvREFCNT(source) == 1));
+ inplace = !SvREADONLY(source) && SvPADTMP(source);
/* First calculate what the changed first character should be. This affects
* whether we can just swap it out, leaving the rest of the string unchanged,
SvGETMAGIC(source);
- if ((SvPADTMP(source)
- ||
- (SvTEMP(source) && !SvSMAGICAL(source) && SvREFCNT(source) == 1))
+ if ( SvPADTMP(source)
&& !SvREADONLY(source) && SvPOK(source)
&& !DO_UTF8(source)
&& (
SvGETMAGIC(source);
- if ( ( SvPADTMP(source)
- || ( SvTEMP(source) && !SvSMAGICAL(source)
- && SvREFCNT(source) == 1 )
- )
+ if ( SvPADTMP(source)
&& !SvREADONLY(source) && SvPOK(source)
&& !DO_UTF8(source)) {
IN_LC_RUNTIME(LC_CTYPE)
||
#endif
- _isQUOTEMETA(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s + 1))))
+ _isQUOTEMETA(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s + 1))))
{
to_quote = TRUE;
}
{
dSP;
AV *array = MUTABLE_AV(POPs);
- const I32 gimme = GIMME_V;
+ const U8 gimme = GIMME_V;
IV *iterp = Perl_av_iter_p(aTHX_ array);
const IV current = (*iterp)++;
{
dSP;
AV *array = MUTABLE_AV(POPs);
- const I32 gimme = GIMME_V;
+ const U8 gimme = GIMME_V;
*Perl_av_iter_p(aTHX_ array) = 0;
dSP;
HV * hash = MUTABLE_HV(POPs);
HE *entry;
- const I32 gimme = GIMME_V;
+ const U8 gimme = GIMME_V;
entry = hv_iternext(hash);
S_do_delete_local(pTHX)
{
dSP;
- const I32 gimme = GIMME_V;
+ const U8 gimme = GIMME_V;
const MAGIC *mg;
HV *stash;
const bool sliced = !!(PL_op->op_private & OPpSLICE);
PP(pp_delete)
{
dSP;
- I32 gimme;
+ U8 gimme;
I32 discard;
if (PL_op->op_private & OPpLVAL_INTRO)
SV **lelem;
if (GIMME_V != G_ARRAY) {
- I32 ix = SvIV(*lastlelem);
- if (ix < 0)
- ix += max;
- if (ix < 0 || ix >= max)
- *firstlelem = &PL_sv_undef;
- else
- *firstlelem = firstrelem[ix];
- SP = firstlelem;
- RETURN;
+ if (lastlelem < firstlelem) {
+ *firstlelem = &PL_sv_undef;
+ }
+ else {
+ I32 ix = SvIV(*lastlelem);
+ if (ix < 0)
+ ix += max;
+ if (ix < 0 || ix >= max)
+ *firstlelem = &PL_sv_undef;
+ else
+ *firstlelem = firstrelem[ix];
+ }
+ SP = firstlelem;
+ RETURN;
}
if (max == 0) {
/* SPAGAIN; not needed: SP is assigned to immediately below */
}
else {
+ /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
+ * only need to save locally, not on the save stack */
+ U16 old_delaymagic = PL_delaymagic;
+
if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify();
PL_delaymagic = DM_DELAY;
for (++MARK; MARK <= SP; MARK++) {
}
if (PL_delaymagic & DM_ARRAY_ISA)
mg_set(MUTABLE_SV(ary));
-
- PL_delaymagic = 0;
+ PL_delaymagic = old_delaymagic;
}
SP = ORIGMARK;
if (OP_GIMME(PL_op, 0) != G_VOID) {
/* SPAGAIN; not needed: SP is assigned to immediately below */
}
else {
+ /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
+ * only need to save locally, not on the save stack */
+ U16 old_delaymagic = PL_delaymagic;
SSize_t i = 0;
+
av_unshift(ary, SP - MARK);
+ PL_delaymagic = DM_DELAY;
while (MARK < SP) {
SV * const sv = newSVsv(*++MARK);
(void)av_store(ary, i++, sv);
}
+ if (PL_delaymagic & DM_ARRAY_ISA)
+ mg_set(MUTABLE_SV(ary));
+ PL_delaymagic = old_delaymagic;
}
SP = ORIGMARK;
if (OP_GIMME(PL_op, 0) != G_VOID) {
if (SP - MARK > 1)
do_join(TARG, &PL_sv_no, MARK, SP);
else {
- sv_setsv(TARG, SP > MARK ? *SP : find_rundefsv());
+ sv_setsv(TARG, SP > MARK ? *SP : DEFSV);
}
up = SvPV_force(TARG, len);
SSize_t maxiters = slen + 10;
I32 trailing_empty = 0;
const char *orig;
- const I32 origlimit = limit;
+ const IV origlimit = limit;
I32 realarray = 0;
I32 base;
- const I32 gimme = GIMME_V;
+ const U8 gimme = GIMME_V;
bool gimme_scalar;
const I32 oldsave = PL_savestack_ix;
U32 make_mortal = SVs_TEMP;
split //, $str, $i;
*/
if (!gimme_scalar) {
- const U32 items = limit - 1;
- if (items < slen)
+ const IV items = limit - 1;
+ /* setting it to -1 will trigger a panic in EXTEND() */
+ const SSize_t sslen = slen > SSize_t_MAX ? -1 : (SSize_t)slen;
+ if (items >=0 && items < sslen)
EXTEND(SP, items);
else
- EXTEND(SP, slen);
+ EXTEND(SP, sslen);
}
if (do_utf8) {
to return. nextstate usually does this on sub entry, but we need
to run the next op with the caller's hints, so we cannot have a
nextstate. */
- SP = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
+ SP = PL_stack_base + CX_CUR()->blk_oldsp;
if(!maxargs) RETURN;
case OA_SCALAR:
try_defsv:
if (!numargs && defgv && whicharg == minargs + 1) {
- PUSHs(find_rundefsv2(
- find_runcv_where(FIND_RUNCV_level_eq, 1, NULL),
- cxstack[cxstack_ix].blk_oldcop->cop_seq
- ));
+ PUSHs(DEFSV);
}
else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
break;
);
PUSHs(SvRV(*svp));
if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv
- && cxstack[cxstack_ix].cx_type & CXp_HASARGS) {
+ && CX_CUR()->cx_type & CXp_HASARGS) {
/* Undo @_ localisation, so that sub exit does not undo
part of our undeffing. */
- PERL_CONTEXT *cx = &cxstack[cxstack_ix];
- POP_SAVEARRAY();
- cx->cx_type &= ~ CXp_HASARGS;
- assert(!AvREAL(cx->blk_sub.argarray));
+ PERL_CONTEXT *cx = CX_CUR();
+
+ assert(CxHASARGS(cx));
+ cx_popsub_args(cx);;
+ cx->cx_type &= ~CXp_HASARGS;
}
}
break;
https://perl5.git.perl.org / perl5.git / blobdiff