PP(pp_stub)
{
- dVAR;
dSP;
if (GIMME_V == G_SCALAR)
XPUSHs(&PL_sv_undef);
PP(pp_padav)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
I32 gimme;
assert(SvTYPE(TARG) == SVt_PVAV);
if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
PP(pp_padhv)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
I32 gimme;
assert(SvTYPE(TARG) == SVt_PVHV);
PP(pp_padcv)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
assert(SvTYPE(TARG) == SVt_PVCV);
XPUSHs(TARG);
RETURN;
PP(pp_introcv)
{
- dVAR; dTARGET;
+ dTARGET;
SvPADSTALE_off(TARG);
return NORMAL;
}
PP(pp_clonecv)
{
- dVAR; dTARGET;
+ dTARGET;
MAGIC * const mg =
mg_find(PadlistNAMESARRAY(CvPADLIST(find_runcv(NULL)))[ARGTARG],
PERL_MAGIC_proto);
S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict,
const bool noinit)
{
- dVAR;
if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv);
if (SvROK(sv)) {
if (SvAMAGIC(sv)) {
SvREFCNT_inc_void_NN(sv);
sv = MUTABLE_SV(gv);
}
- else if (!isGV_with_GP(sv))
- return (SV *)Perl_die(aTHX_ "Not a GLOB reference");
+ else if (!isGV_with_GP(sv)) {
+ Perl_die(aTHX_ "Not a GLOB reference");
+ }
}
else {
if (!isGV_with_GP(sv)) {
const char * const name = CopSTASHPV(PL_curcop);
gv = newGVgen_flags(name,
HvNAMEUTF8(CopSTASH(PL_curcop)) ? SVf_UTF8 : 0 );
+ SvREFCNT_inc_simple_void_NN(gv);
}
prepare_SV_for_RV(sv);
SvRV_set(sv, MUTABLE_SV(gv));
SvSETMAGIC(sv);
goto wasref;
}
- if (PL_op->op_flags & OPf_REF || strict)
- return (SV *)Perl_die(aTHX_ PL_no_usym, "a symbol");
+ if (PL_op->op_flags & OPf_REF || strict) {
+ Perl_die(aTHX_ PL_no_usym, "a symbol");
+ }
if (ckWARN(WARN_UNINITIALIZED))
report_uninit(sv);
return &PL_sv_undef;
return &PL_sv_undef;
}
else {
- if (strict)
- return
- (SV *)Perl_die(aTHX_
- S_no_symref_sv,
- sv,
- (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""),
- "a symbol"
- );
+ if (strict) {
+ Perl_die(aTHX_
+ S_no_symref_sv,
+ sv,
+ (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""),
+ "a symbol"
+ );
+ }
if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
== OPpDONT_INIT_GV) {
/* We are the target of a coderef assignment. Return
PP(pp_rv2gv)
{
- dVAR; dSP; dTOPss;
+ dSP; dTOPss;
sv = S_rv2gv(aTHX_
sv, PL_op->op_private & OPpDEREF,
Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
const svtype type, SV ***spp)
{
- dVAR;
GV *gv;
PERL_ARGS_ASSERT_SOFTREF2XV;
PP(pp_rv2sv)
{
- dVAR; dSP; dTOPss;
+ dSP; dTOPss;
GV *gv = NULL;
SvGETMAGIC(sv);
PP(pp_av2arylen)
{
- dVAR; dSP;
+ dSP;
AV * const av = MUTABLE_AV(TOPs);
const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
if (lvalue) {
PP(pp_pos)
{
- dVAR; dSP; dPOPss;
+ dSP; dPOPss;
if (PL_op->op_flags & OPf_MOD || LVRET) {
SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));/* Not TARG RT#67838 */
PP(pp_rv2cv)
{
- dVAR; dSP;
+ dSP;
GV *gv;
HV *stash_unused;
const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
if (cv) NOOP;
else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
- cv = MUTABLE_CV(gv);
+ cv = SvTYPE(SvRV(gv)) == SVt_PVCV
+ ? MUTABLE_CV(SvRV(gv))
+ : MUTABLE_CV(gv);
}
else
cv = MUTABLE_CV(&PL_sv_undef);
PP(pp_prototype)
{
- dVAR; dSP;
+ dSP;
CV *cv;
HV *stash;
GV *gv;
PP(pp_anoncode)
{
- dVAR; dSP;
+ dSP;
CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
if (CvCLONE(cv))
cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
PP(pp_srefgen)
{
- dVAR; dSP;
+ dSP;
*SP = refto(*SP);
RETURN;
}
PP(pp_refgen)
{
- dVAR; dSP; dMARK;
+ dSP; dMARK;
if (GIMME != G_ARRAY) {
if (++MARK <= SP)
*MARK = *SP;
STATIC SV*
S_refto(pTHX_ SV *sv)
{
- dVAR;
SV* rv;
PERL_ARGS_ASSERT_REFTO;
SvREFCNT_inc_void_NN(sv);
}
else if (SvPADTMP(sv)) {
- assert(!IS_PADGV(sv));
sv = newSVsv(sv);
}
else {
PP(pp_ref)
{
- dVAR; dSP; dTARGET;
- SV * const sv = POPs;
+ dSP;
+ SV * const sv = TOPs;
SvGETMAGIC(sv);
if (!SvROK(sv))
- RETPUSHNO;
+ SETs(&PL_sv_no);
+ else {
+ dTARGET;
+ SETs(TARG);
+ /* use the return value that is in a register, its the same as TARG */
+ TARG = sv_ref(TARG,SvRV(sv),TRUE);
+ SvSETMAGIC(TARG);
+ }
- (void)sv_ref(TARG,SvRV(sv),TRUE);
- PUSHTARG;
- RETURN;
+ return NORMAL;
}
PP(pp_bless)
{
- dVAR; dSP;
+ dSP;
HV *stash;
if (MAXARG == 1)
PP(pp_gelem)
{
- dVAR; dSP;
+ dSP;
SV *sv = POPs;
STRLEN len;
PP(pp_study)
{
- dVAR; dSP; dPOPss;
+ dSP; dPOPss;
STRLEN len;
(void)SvPV(sv, len);
RETPUSHYES;
}
+
+/* also used for: pp_transr() */
+
PP(pp_trans)
{
- dVAR; dSP; dTARG;
+ dSP; dTARG;
SV *sv;
if (PL_op->op_flags & OPf_STACKED)
static void
S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
{
- dVAR;
STRLEN len;
char *s;
}
}
+
+/* also used for: pp_schomp() */
+
PP(pp_schop)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
const bool chomping = PL_op->op_type == OP_SCHOMP;
if (chomping)
RETURN;
}
+
+/* also used for: pp_chomp() */
+
PP(pp_chop)
{
- dVAR; dSP; dMARK; dTARGET; dORIGMARK;
+ dSP; dMARK; dTARGET; dORIGMARK;
const bool chomping = PL_op->op_type == OP_CHOMP;
if (chomping)
PP(pp_undef)
{
- dVAR; dSP;
+ dSP;
SV *sv;
if (!PL_op->op_private) {
if (!sv)
RETPUSHUNDEF;
- SV_CHECK_THINKFIRST_COW_DROP(sv);
+ if (SvTHINKFIRST(sv))
+ sv_force_normal_flags(sv, SV_COW_DROP_PV|SV_IMMEDIATE_UNREF);
switch (SvTYPE(sv)) {
case SVt_NULL:
));
/* FALLTHROUGH */
case SVt_PVFM:
- {
/* let user-undef'd sub keep its identity */
- GV* const gv = CvGV((const CV *)sv);
- HEK * const hek = CvNAME_HEK((CV *)sv);
- if (hek) share_hek_hek(hek);
- cv_undef(MUTABLE_CV(sv));
- if (gv) CvGV_set(MUTABLE_CV(sv), gv);
- else if (hek) {
- SvANY((CV *)sv)->xcv_gv_u.xcv_hek = hek;
- CvNAMED_on(sv);
- }
- }
+ cv_undef_flags(MUTABLE_CV(sv), CV_UNDEF_KEEP_NAME);
break;
case SVt_PVGV:
assert(isGV_with_GP(sv));
RETPUSHUNDEF;
}
+
+/* also used for: pp_i_postdec() pp_i_postinc() pp_postdec() */
+
PP(pp_postinc)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
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)))
PP(pp_pow)
{
- dVAR; dSP; dATARGET; SV *svl, *svr;
+ dSP; dATARGET; SV *svl, *svr;
#ifdef PERL_PRESERVE_IVUV
bool is_int = 0;
#endif
PP(pp_multiply)
{
- dVAR; dSP; dATARGET; SV *svl, *svr;
+ dSP; dATARGET; SV *svl, *svr;
tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
svr = TOPs;
svl = TOPm1s;
PP(pp_divide)
{
- dVAR; dSP; dATARGET; SV *svl, *svr;
+ dSP; dATARGET; SV *svl, *svr;
tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
svr = TOPs;
svl = TOPm1s;
PP(pp_modulo)
{
- dVAR; dSP; dATARGET;
+ dSP; dATARGET;
tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
{
UV left = 0;
PP(pp_repeat)
{
- dVAR; dSP; dATARGET;
+ dSP; dATARGET;
IV count;
SV *sv;
else
count = uv;
} else {
- const IV iv = SvIV_nomg(sv);
- if (iv < 0)
- count = 0;
- else
- count = iv;
+ count = SvIV_nomg(sv);
}
}
else if (SvNOKp(sv)) {
const NV nv = SvNV_nomg(sv);
if (nv < 0.0)
- count = 0;
+ count = -1; /* An arbitrary negative integer */
else
count = (IV)nv;
}
else
count = SvIV_nomg(sv);
+ if (count < 0) {
+ count = 0;
+ Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
+ "Negative repeat count does nothing");
+ }
+
if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
dMARK;
static const char* const oom_list_extend = "Out of memory during list extend";
#else
if (*SP) {
if (mod && SvPADTMP(*SP)) {
- assert(!IS_PADGV(*SP));
*SP = sv_mortalcopy(*SP);
}
SvTEMP_off((*SP));
PP(pp_subtract)
{
- dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
+ dSP; dATARGET; bool useleft; SV *svl, *svr;
tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
svr = TOPs;
svl = TOPm1s;
PP(pp_left_shift)
{
- dVAR; dSP; dATARGET; SV *svl, *svr;
+ dSP; dATARGET; SV *svl, *svr;
tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
svr = POPs;
svl = TOPs;
PP(pp_right_shift)
{
- dVAR; dSP; dATARGET; SV *svl, *svr;
+ dSP; dATARGET; SV *svl, *svr;
tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
svr = POPs;
svl = TOPs;
PP(pp_lt)
{
- dVAR; dSP;
+ dSP;
SV *left, *right;
tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
PP(pp_gt)
{
- dVAR; dSP;
+ dSP;
SV *left, *right;
tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
PP(pp_le)
{
- dVAR; dSP;
+ dSP;
SV *left, *right;
tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
PP(pp_ge)
{
- dVAR; dSP;
+ dSP;
SV *left, *right;
tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric);
PP(pp_ne)
{
- dVAR; dSP;
+ dSP;
SV *left, *right;
tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric);
I32
Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
{
- dVAR;
-
PERL_ARGS_ASSERT_DO_NCMP;
#ifdef PERL_PRESERVE_IVUV
/* Fortunately it seems NaN isn't IOK */
PP(pp_ncmp)
{
- dVAR; dSP;
+ dSP;
SV *left, *right;
I32 value;
tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
RETURN;
}
+
+/* also used for: pp_sge() pp_sgt() pp_slt() */
+
PP(pp_sle)
{
- dVAR; dSP;
+ dSP;
int amg_type = sle_amg;
int multiplier = 1;
{
dPOPTOPssrl;
const int cmp =
-#ifdef USE_LC_COLLATE
+#ifdef USE_LOCALE_COLLATE
(IN_LC_RUNTIME(LC_COLLATE))
? sv_cmp_locale_flags(left, right, 0)
:
PP(pp_seq)
{
- dVAR; dSP;
+ dSP;
tryAMAGICbin_MG(seq_amg, AMGf_set);
{
dPOPTOPssrl;
PP(pp_sne)
{
- dVAR; dSP;
+ dSP;
tryAMAGICbin_MG(sne_amg, AMGf_set);
{
dPOPTOPssrl;
PP(pp_scmp)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
tryAMAGICbin_MG(scmp_amg, 0);
{
dPOPTOPssrl;
const int cmp =
-#ifdef USE_LC_COLLATE
+#ifdef USE_LOCALE_COLLATE
(IN_LC_RUNTIME(LC_COLLATE))
? sv_cmp_locale_flags(left, right, 0)
:
PP(pp_bit_and)
{
- dVAR; dSP; dATARGET;
+ dSP; dATARGET;
tryAMAGICbin_MG(band_amg, AMGf_assign);
{
dPOPTOPssrl;
}
}
+
+/* also used for: pp_bit_xor() */
+
PP(pp_bit_or)
{
- dVAR; dSP; dATARGET;
+ dSP; dATARGET;
const int op_type = PL_op->op_type;
tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
PP(pp_negate)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
tryAMAGICun_MG(neg_amg, AMGf_numeric);
if (S_negate_string(aTHX)) return NORMAL;
{
PP(pp_not)
{
- dVAR; dSP;
+ dSP;
tryAMAGICun_MG(not_amg, AMGf_set);
*PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
return NORMAL;
PP(pp_complement)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
tryAMAGICun_MG(compl_amg, AMGf_numeric);
{
dTOPss;
PP(pp_i_multiply)
{
- dVAR; dSP; dATARGET;
+ dSP; dATARGET;
tryAMAGICbin_MG(mult_amg, AMGf_assign);
{
dPOPTOPiirl_nomg;
PP(pp_i_divide)
{
IV num;
- dVAR; dSP; dATARGET;
+ dSP; dATARGET;
tryAMAGICbin_MG(div_amg, AMGf_assign);
{
dPOPTOPssrl;
#endif
{
/* This is the vanilla old i_modulo. */
- dVAR; dSP; dATARGET;
+ dSP; dATARGET;
tryAMAGICbin_MG(modulo_amg, AMGf_assign);
{
dPOPTOPiirl_nomg;
/* This is the i_modulo with the workaround for the _moddi3 bug
* in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
* See below for pp_i_modulo. */
- dVAR; dSP; dATARGET;
+ dSP; dATARGET;
tryAMAGICbin_MG(modulo_amg, AMGf_assign);
{
dPOPTOPiirl_nomg;
PP(pp_i_add)
{
- dVAR; dSP; dATARGET;
+ dSP; dATARGET;
tryAMAGICbin_MG(add_amg, AMGf_assign);
{
dPOPTOPiirl_ul_nomg;
PP(pp_i_subtract)
{
- dVAR; dSP; dATARGET;
+ dSP; dATARGET;
tryAMAGICbin_MG(subtr_amg, AMGf_assign);
{
dPOPTOPiirl_ul_nomg;
PP(pp_i_lt)
{
- dVAR; dSP;
+ dSP;
tryAMAGICbin_MG(lt_amg, AMGf_set);
{
dPOPTOPiirl_nomg;
PP(pp_i_gt)
{
- dVAR; dSP;
+ dSP;
tryAMAGICbin_MG(gt_amg, AMGf_set);
{
dPOPTOPiirl_nomg;
PP(pp_i_le)
{
- dVAR; dSP;
+ dSP;
tryAMAGICbin_MG(le_amg, AMGf_set);
{
dPOPTOPiirl_nomg;
PP(pp_i_ge)
{
- dVAR; dSP;
+ dSP;
tryAMAGICbin_MG(ge_amg, AMGf_set);
{
dPOPTOPiirl_nomg;
PP(pp_i_eq)
{
- dVAR; dSP;
+ dSP;
tryAMAGICbin_MG(eq_amg, AMGf_set);
{
dPOPTOPiirl_nomg;
PP(pp_i_ne)
{
- dVAR; dSP;
+ dSP;
tryAMAGICbin_MG(ne_amg, AMGf_set);
{
dPOPTOPiirl_nomg;
PP(pp_i_ncmp)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
tryAMAGICbin_MG(ncmp_amg, 0);
{
dPOPTOPiirl_nomg;
PP(pp_i_negate)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
tryAMAGICun_MG(neg_amg, 0);
if (S_negate_string(aTHX)) return NORMAL;
{
PP(pp_atan2)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
tryAMAGICbin_MG(atan2_amg, 0);
{
dPOPTOPnnrl_nomg;
}
}
+
+/* also used for: pp_cos() pp_exp() pp_log() pp_sqrt() */
+
PP(pp_sin)
{
- dVAR; dSP; dTARGET;
- int amg_type = sin_amg;
+ dSP; dTARGET;
+ int amg_type = fallback_amg;
const char *neg_report = NULL;
- NV (*func)(NV) = Perl_sin;
const int op_type = PL_op->op_type;
switch (op_type) {
- case OP_COS:
- amg_type = cos_amg;
- func = Perl_cos;
- break;
- case OP_EXP:
- amg_type = exp_amg;
- func = Perl_exp;
- break;
- case OP_LOG:
- amg_type = log_amg;
- func = Perl_log;
- neg_report = "log";
- break;
- case OP_SQRT:
- amg_type = sqrt_amg;
- func = Perl_sqrt;
- neg_report = "sqrt";
- break;
+ case OP_SIN: amg_type = sin_amg; break;
+ case OP_COS: amg_type = cos_amg; break;
+ case OP_EXP: amg_type = exp_amg; break;
+ case OP_LOG: amg_type = log_amg; neg_report = "log"; break;
+ case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break;
}
+ assert(amg_type != fallback_amg);
tryAMAGICun_MG(amg_type, 0);
{
SV * const arg = POPs;
const NV value = SvNV_nomg(arg);
- if (neg_report) {
+ NV result = NV_NAN;
+ if (neg_report) { /* log or sqrt */
if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
SET_NUMERIC_STANDARD();
/* diag_listed_as: Can't take log of %g */
DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
}
}
- XPUSHn(func(value));
+ switch (op_type) {
+ default:
+ case OP_SIN: result = Perl_sin(value); break;
+ case OP_COS: result = Perl_cos(value); break;
+ case OP_EXP: result = Perl_exp(value); break;
+ case OP_LOG: result = Perl_log(value); break;
+ case OP_SQRT: result = Perl_sqrt(value); break;
+ }
+ XPUSHn(result);
RETURN;
}
}
PP(pp_rand)
{
- dVAR;
if (!PL_srand_called) {
(void)seedDrand01((Rand_seed_t)seed());
PL_srand_called = TRUE;
PP(pp_srand)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
UV anum;
if (MAXARG >= 1 && (TOPs || POPs)) {
PP(pp_int)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
tryAMAGICun_MG(int_amg, AMGf_numeric);
{
SV * const sv = TOPs;
}
else {
const NV value = SvNV_nomg(sv);
- if (value >= 0.0) {
+ if (SvNOK(sv) && UNLIKELY(Perl_isinfnan(SvNV(sv))))
+ SETn(SvNV(sv));
+ else if (value >= 0.0) {
if (value < (NV)UV_MAX + 0.5) {
SETu(U_V(value));
} else {
PP(pp_abs)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
tryAMAGICun_MG(abs_amg, AMGf_numeric);
{
SV * const sv = TOPs;
RETURN;
}
+
+/* also used for: pp_hex() */
+
PP(pp_oct)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
const char *tmps;
I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
STRLEN len;
tmps++, len--;
if (*tmps == '0')
tmps++, len--;
- if (*tmps == 'x' || *tmps == 'X') {
+ if (isALPHA_FOLD_EQ(*tmps, 'x')) {
hex:
result_uv = grok_hex (tmps, &len, &flags, &result_nv);
}
- else if (*tmps == 'b' || *tmps == 'B')
+ else if (isALPHA_FOLD_EQ(*tmps, 'b'))
result_uv = grok_bin (tmps, &len, &flags, &result_nv);
else
result_uv = grok_oct (tmps, &len, &flags, &result_nv);
PP(pp_length)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
SV * const sv = TOPs;
- SvGETMAGIC(sv);
+ U32 in_bytes = IN_BYTES;
+ /* simplest case shortcut */
+ /* turn off SVf_UTF8 in tmp flags if HINT_BYTES on*/
+ U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8);
+ assert(HINT_BYTES == 0x00000008 && SVf_UTF8 == 0x20000000 && (SVf_UTF8 == HINT_BYTES << 26));
+ SETs(TARG);
+
+ if(LIKELY(svflags == SVf_POK))
+ goto simple_pv;
+ if(svflags & SVs_GMG)
+ mg_get(sv);
if (SvOK(sv)) {
- if (!IN_BYTES)
- SETi(sv_len_utf8_nomg(sv));
+ if (!IN_BYTES) /* reread to avoid using an C auto/register */
+ sv_setiv(TARG, (IV)sv_len_utf8_nomg(sv));
else
{
STRLEN len;
- (void)SvPV_nomg_const(sv,len);
- SETi(len);
+ /* unrolled SvPV_nomg_const(sv,len) */
+ if(SvPOK_nog(sv)){
+ simple_pv:
+ len = SvCUR(sv);
+ } else {
+ (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN);
+ }
+ sv_setiv(TARG, (IV)(len));
}
} else {
if (!SvPADTMP(TARG)) {
sv_setsv_nomg(TARG, &PL_sv_undef);
- SETTARG;
- }
- SETs(&PL_sv_undef);
+ } else { /* TARG is on stack at this point and is overwriten by SETs.
+ This branch is the odd one out, so put TARG by default on
+ stack earlier to let local SP go out of liveness sooner */
+ SETs(&PL_sv_undef);
+ goto no_set_magic;
+ }
}
- RETURN;
+ SvSETMAGIC(TARG);
+ no_set_magic:
+ return NORMAL; /* no putback, SP didn't move in this opcode */
}
/* Returns false if substring is completely outside original string.
always be true for an explicit 0.
*/
bool
-Perl_translate_substr_offsets(pTHX_ STRLEN curlen, IV pos1_iv,
- bool pos1_is_uv, IV len_iv,
- bool len_is_uv, STRLEN *posp,
- STRLEN *lenp)
+Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv,
+ bool pos1_is_uv, IV len_iv,
+ bool len_is_uv, STRLEN *posp,
+ STRLEN *lenp)
{
IV pos2_iv;
int pos2_is_uv;
PP(pp_substr)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
SV *sv;
STRLEN curlen;
STRLEN utf8_curlen;
PP(pp_vec)
{
- dVAR; dSP;
+ dSP;
const IV size = POPi;
const IV offset = POPi;
SV * const src = POPs;
RETURN;
}
+
+/* also used for: pp_rindex() */
+
PP(pp_index)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
SV *big;
SV *little;
SV *temp = NULL;
PP(pp_sprintf)
{
- dVAR; dSP; dMARK; dORIGMARK; dTARGET;
+ dSP; dMARK; dORIGMARK; dTARGET;
SvTAINTED_off(TARG);
do_sprintf(TARG, SP-MARK, MARK+1);
TAINT_IF(SvTAINTED(TARG));
PP(pp_ord)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
SV *argsv = POPs;
STRLEN len;
PP(pp_chr)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
char *tmps;
UV value;
SV *top = POPs;
SvGETMAGIC(top);
- if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
- && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
- ||
- ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
- && SvNV_nomg(top) < 0.0))) {
+ if (UNLIKELY(isinfnansv(top)))
+ Perl_croak(aTHX_ "Cannot chr %"NVgf, SvNV(top));
+ else {
+ if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
+ && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
+ ||
+ ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
+ && SvNV_nomg(top) < 0.0))) {
if (ckWARN(WARN_UTF8)) {
if (SvGMAGICAL(top)) {
SV *top2 = sv_newmortal();
sv_setsv_nomg(top2, top);
top = top2;
}
- Perl_warner(aTHX_ packWARN(WARN_UTF8),
- "Invalid negative number (%"SVf") in chr", top);
- }
- value = UNICODE_REPLACEMENT;
- } else {
- value = SvUV_nomg(top);
+ Perl_warner(aTHX_ packWARN(WARN_UTF8),
+ "Invalid negative number (%"SVf") in chr", SVfARG(top));
+ }
+ value = UNICODE_REPLACEMENT;
+ } else {
+ value = SvUV_nomg(top);
+ }
}
SvUPGRADE(TARG,SVt_PV);
PP(pp_crypt)
{
#ifdef HAS_CRYPT
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
dPOPTOPssrl;
STRLEN len;
const char *tmps = SvPV_const(left, len);
/* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
* most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
+
+/* also used for: pp_lcfirst() */
+
PP(pp_ucfirst)
{
/* Actually is both lcfirst() and ucfirst(). Only the first character
* take the source and change that one character and store it back, but not
* if read-only etc, or if the length changes */
- dVAR;
dSP;
SV *source = TOPs;
STRLEN slen; /* slen is the byte length of the whole SV. */
doing_utf8 = TRUE;
ulen = UTF8SKIP(s);
if (op_type == OP_UCFIRST) {
- _to_utf8_title_flags(s, tmpbuf, &tculen,
#ifdef USE_LOCALE_CTYPE
- IN_LC_RUNTIME(LC_CTYPE)
+ _to_utf8_title_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
#else
- 0
+ _to_utf8_title_flags(s, tmpbuf, &tculen, 0);
#endif
- );
}
else {
- _to_utf8_lower_flags(s, tmpbuf, &tculen,
#ifdef USE_LOCALE_CTYPE
- IN_LC_RUNTIME(LC_CTYPE)
+ _to_utf8_lower_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
#else
- 0
+ _to_utf8_lower_flags(s, tmpbuf, &tculen, 0);
#endif
- );
}
/* we can't do in-place if the length changes. */
/* Here, is ucfirst non-UTF-8, not in locale (unless that locale is
* UTF-8, which we treat as not in locale), and cased latin1 */
UV title_ord;
-
+#ifdef USE_LOCALE_CTYPE
do_uni_rules:
+#endif
title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
if (tculen > 1) {
of the three tight loops. There is less and less commonality though */
PP(pp_uc)
{
- dVAR;
dSP;
SV *source = TOPs;
STRLEN len;
* and copy it to the output buffer */
u = UTF8SKIP(s);
- uv = _to_utf8_upper_flags(s, tmpbuf, &ulen,
#ifdef USE_LOCALE_CTYPE
- IN_LC_RUNTIME(LC_CTYPE)
+ uv = _to_utf8_upper_flags(s, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
#else
- 0
+ uv = _to_utf8_upper_flags(s, tmpbuf, &ulen, 0);
#endif
- );
#define GREEK_CAPITAL_LETTER_IOTA 0x0399
#define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
if (uv == GREEK_CAPITAL_LETTER_IOTA
}
}
else {
+#ifdef USE_LOCALE_CTYPE
do_uni_rules:
+#endif
for (; s < send; d++, s++) {
*d = toUPPER_LATIN1_MOD(*s);
if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
PP(pp_lc)
{
- dVAR;
dSP;
SV *source = TOPs;
STRLEN len;
const STRLEN u = UTF8SKIP(s);
STRLEN ulen;
- _to_utf8_lower_flags(s, tmpbuf, &ulen,
#ifdef USE_LOCALE_CTYPE
- IN_LC_RUNTIME(LC_CTYPE)
+ _to_utf8_lower_flags(s, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
#else
- 0
+ _to_utf8_lower_flags(s, tmpbuf, &ulen, 0);
#endif
- );
/* Here is where we would do context-sensitive actions. See the
* commit message for 86510fb15 for why there isn't any */
PP(pp_quotemeta)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
SV * const sv = TOPs;
STRLEN len;
const char *s = SvPV_const(sv,len);
}
}
else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
+ if (
#ifdef USE_LOCALE_CTYPE
/* In locale, we quote all non-ASCII Latin1 chars.
* Otherwise use the quoting rules */
- if (IN_LC_RUNTIME(LC_CTYPE)
- || _isQUOTEMETA(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s + 1))))
+
+ IN_LC_RUNTIME(LC_CTYPE)
+ ||
+#endif
+ _isQUOTEMETA(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s + 1))))
{
to_quote = TRUE;
}
-#endif
}
else if (is_QUOTEMETA_high(s)) {
to_quote = TRUE;
PP(pp_fc)
{
- dVAR;
dTARGET;
dSP;
SV *source = TOPs;
const U8 *send;
U8 *d;
U8 tmpbuf[UTF8_MAXBYTES_CASE + 1];
- const bool full_folding = TRUE;
+ const bool full_folding = TRUE; /* This variable is here so we can easily
+ move to more generality later */
const U8 flags = ( full_folding ? FOLD_FLAGS_FULL : 0 )
#ifdef USE_LOCALE_CTYPE
| ( IN_LC_RUNTIME(LC_CTYPE) ? FOLD_FLAGS_LOCALE : 0 )
*d = toFOLD(*s);
}
else {
+#ifdef USE_LOCALE_CTYPE
do_uni_folding:
+#endif
/* For ASCII and the Latin-1 range, there's only two troublesome
* folds, \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
* casefolding becomes 'ss'; and \x{B5} (\N{MICRO SIGN}), which
PP(pp_aslice)
{
- dVAR; dSP; dMARK; dORIGMARK;
+ dSP; dMARK; dORIGMARK;
AV *const av = MUTABLE_AV(POPs);
const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
PP(pp_kvaslice)
{
- dVAR; dSP; dMARK;
+ dSP; dMARK;
AV *const av = MUTABLE_AV(POPs);
I32 lval = (PL_op->op_flags & OPf_MOD);
SSize_t items = SP - MARK;
RETURN;
}
+
/* Smart dereferencing for keys, values and each */
+
+/* also used for: pp_reach() pp_rvalues() */
+
PP(pp_rkeys)
{
- dVAR;
dSP;
dPOPss;
PP(pp_aeach)
{
- dVAR;
dSP;
AV *array = MUTABLE_AV(POPs);
const I32 gimme = GIMME_V;
RETURN;
}
+/* also used for: pp_avalues()*/
PP(pp_akeys)
{
- dVAR;
dSP;
AV *array = MUTABLE_AV(POPs);
const I32 gimme = GIMME_V;
PP(pp_each)
{
- dVAR;
dSP;
HV * hash = MUTABLE_HV(POPs);
HE *entry;
STATIC OP *
S_do_delete_local(pTHX)
{
- dVAR;
dSP;
const I32 gimme = GIMME_V;
const MAGIC *mg;
PP(pp_delete)
{
- dVAR;
dSP;
I32 gimme;
I32 discard;
PP(pp_exists)
{
- dVAR;
dSP;
SV *tmpsv;
HV *hv;
PP(pp_hslice)
{
- dVAR; dSP; dMARK; dORIGMARK;
+ dSP; dMARK; dORIGMARK;
HV * const hv = MUTABLE_HV(POPs);
const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
PP(pp_kvhslice)
{
- dVAR; dSP; dMARK;
+ dSP; dMARK;
HV * const hv = MUTABLE_HV(POPs);
I32 lval = (PL_op->op_flags & OPf_MOD);
SSize_t items = SP - MARK;
PP(pp_list)
{
- dVAR;
I32 markidx = POPMARK;
if (GIMME != G_ARRAY) {
SV **mark = PL_stack_base + markidx;
PP(pp_lslice)
{
- dVAR;
dSP;
SV ** const lastrelem = PL_stack_sp;
SV ** const lastlelem = PL_stack_base + POPMARK;
if (!(*lelem = firstrelem[ix]))
*lelem = &PL_sv_undef;
else if (mod && SvPADTMP(*lelem)) {
- assert(!IS_PADGV(*lelem));
*lelem = firstrelem[ix] = sv_mortalcopy(*lelem);
}
}
PP(pp_anonlist)
{
- dVAR; dSP; dMARK;
+ dSP; dMARK;
const I32 items = SP - MARK;
SV * const av = MUTABLE_SV(av_make(items, MARK+1));
SP = MARK;
PP(pp_anonhash)
{
- dVAR; dSP; dMARK; dORIGMARK;
+ dSP; dMARK; dORIGMARK;
HV* const hv = newHV();
SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL
? newRV_noinc(MUTABLE_SV(hv))
PP(pp_splice)
{
- dVAR; dSP; dMARK; dORIGMARK;
+ dSP; dMARK; dORIGMARK;
int num_args = (SP - MARK);
AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
SV **src;
PP(pp_push)
{
- dVAR; dSP; dMARK; dORIGMARK; dTARGET;
+ dSP; dMARK; dORIGMARK; dTARGET;
AV * const ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
RETURN;
}
+/* also used for: pp_pop()*/
PP(pp_shift)
{
- dVAR;
dSP;
AV * const av = PL_op->op_flags & OPf_SPECIAL
? MUTABLE_AV(GvAV(PL_defgv)) : DEREF_PLAIN_ARRAY(MUTABLE_AV(POPs));
PP(pp_unshift)
{
- dVAR; dSP; dMARK; dORIGMARK; dTARGET;
+ dSP; dMARK; dORIGMARK; dTARGET;
AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
PP(pp_reverse)
{
- dVAR; dSP; dMARK;
+ dSP; dMARK;
if (GIMME == G_ARRAY) {
if (PL_op->op_private & OPpREVERSE_INPLACE) {
PP(pp_split)
{
- dVAR; dSP; dTARG;
+ dSP; dTARG;
AV *ary;
IV limit = POPi; /* note, negative is forever */
SV * const sv = POPs;
PP(pp_lock)
{
- dVAR;
dSP;
dTOPss;
SV *retsv = sv;
}
+/* used for: pp_padany(), pp_mapstart(), pp_custom(); plus any system ops
+ * that aren't implemented on a particular platform */
+
PP(unimplemented_op)
{
- dVAR;
const Optype op_type = PL_op->op_type;
/* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
with out of range op numbers - it only "special" cases op_custom.
https://perl5.git.perl.org / perl5.git / blobdiff