case SVt_PVAV:
case SVt_PVHV:
case SVt_PVCV:
+ case SVt_PVFM:
+ case SVt_PVIO:
DIE(aTHX_ "Not a SCALAR reference");
}
}
if (cv_const_sv((CV*)sv) && ckWARN(WARN_MISC))
Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case SVt_PVFM:
{
/* let user-undef'd sub keep its identity */
bhigh = blow >> (4 * sizeof (UV));
blow &= botmask;
if (ahigh && bhigh) {
+ /*EMPTY*/;
/* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
which is overflow. Drop to NVs below. */
} else if (!ahigh && !bhigh) {
}
}
-PP(pp_bit_xor)
-{
- dVAR; dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
- {
- dPOPTOPssrl;
- SvGETMAGIC(left);
- SvGETMAGIC(right);
- if (SvNIOKp(left) || SvNIOKp(right)) {
- if (PL_op->op_private & HINT_INTEGER) {
- const IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) ^ SvIV_nomg(right);
- SETi(i);
- }
- else {
- const UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) ^ SvUV_nomg(right);
- SETu(u);
- }
- }
- else {
- do_vop(PL_op->op_type, TARG, left, right);
- SETTARG;
- }
- RETURN;
- }
-}
-
PP(pp_bit_or)
{
- dVAR; dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
+ dVAR; dSP; dATARGET;
+ const int op_type = PL_op->op_type;
+
+ tryAMAGICbin_var((op_type == OP_BIT_OR ? bor_amg : bxor_amg), opASSIGN);
{
dPOPTOPssrl;
SvGETMAGIC(left);
SvGETMAGIC(right);
if (SvNIOKp(left) || SvNIOKp(right)) {
if (PL_op->op_private & HINT_INTEGER) {
- const IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) | SvIV_nomg(right);
- SETi(i);
+ const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
+ const IV r = SvIV_nomg(right);
+ const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
+ SETi(result);
}
else {
- const UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) | SvUV_nomg(right);
- SETu(u);
+ const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
+ const UV r = SvUV_nomg(right);
+ const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
+ SETu(result);
}
}
else {
- do_vop(PL_op->op_type, TARG, left, right);
+ do_vop(op_type, TARG, left, right);
SETTARG;
}
RETURN;
PP(pp_i_divide)
{
+ IV num;
dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
{
dPOPiv;
if (value == 0)
- DIE(aTHX_ "Illegal division by zero");
- value = POPi / value;
+ DIE(aTHX_ "Illegal division by zero");
+ num = POPi;
+
+ /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
+ if (value == -1)
+ value = - num;
+ else
+ value = num / value;
PUSHi( value );
RETURN;
}
dPOPTOPiirl;
if (!right)
DIE(aTHX_ "Illegal modulus zero");
- SETi( left % right );
+ /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
+ if (right == -1)
+ SETi( 0 );
+ else
+ SETi( left % right );
RETURN;
}
}
dPOPTOPiirl;
if (!right)
DIE(aTHX_ "Illegal modulus zero");
- SETi( left % PERL_ABS(right) );
+ /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
+ if (right == -1)
+ SETi( 0 );
+ else
+ SETi( left % PERL_ABS(right) );
RETURN;
}
}
}
}
#endif
- SETi( left % right );
+ /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
+ if (right == -1)
+ SETi( 0 );
+ else
+ SETi( left % right );
RETURN;
}
}
PP(pp_sin)
{
- dVAR; dSP; dTARGET; tryAMAGICun(sin);
- {
- const NV value = POPn;
- XPUSHn(Perl_sin(value));
- RETURN;
+ dVAR; dSP; dTARGET;
+ int amg_type = sin_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;
}
-}
-PP(pp_cos)
-{
- dVAR; dSP; dTARGET; tryAMAGICun(cos);
+ tryAMAGICun_var(amg_type);
{
const NV value = POPn;
- XPUSHn(Perl_cos(value));
+ if (neg_report) {
+ if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
+ SET_NUMERIC_STANDARD();
+ DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
+ }
+ }
+ XPUSHn(func(value));
RETURN;
}
}
RETPUSHYES;
}
-PP(pp_exp)
-{
- dVAR; dSP; dTARGET; tryAMAGICun(exp);
- {
- NV value;
- value = POPn;
- value = Perl_exp(value);
- XPUSHn(value);
- RETURN;
- }
-}
-
-PP(pp_log)
-{
- dVAR; dSP; dTARGET; tryAMAGICun(log);
- {
- const NV value = POPn;
- if (value <= 0.0) {
- SET_NUMERIC_STANDARD();
- DIE(aTHX_ "Can't take log of %"NVgf, value);
- }
- XPUSHn(Perl_log(value));
- RETURN;
- }
-}
-
-PP(pp_sqrt)
-{
- dVAR; dSP; dTARGET; tryAMAGICun(sqrt);
- {
- const NV value = POPn;
- if (value < 0.0) {
- SET_NUMERIC_STANDARD();
- DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
- }
- XPUSHn(Perl_sqrt(value));
- RETURN;
- }
-}
-
PP(pp_int)
{
dVAR; dSP; dTARGET; tryAMAGICun(int);
RETURN;
}
-
-PP(pp_hex)
-{
- dVAR; dSP; dTARGET;
- const char *tmps;
- I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
- STRLEN len;
- NV result_nv;
- UV result_uv;
- SV* const sv = POPs;
-
- tmps = (SvPV_const(sv, len));
- if (DO_UTF8(sv)) {
- /* If Unicode, try to downgrade
- * If not possible, croak. */
- SV* const tsv = sv_2mortal(newSVsv(sv));
-
- SvUTF8_on(tsv);
- sv_utf8_downgrade(tsv, FALSE);
- tmps = SvPV_const(tsv, len);
- }
- result_uv = grok_hex (tmps, &len, &flags, &result_nv);
- if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
- XPUSHn(result_nv);
- }
- else {
- XPUSHu(result_uv);
- }
- RETURN;
-}
-
PP(pp_oct)
{
dVAR; dSP; dTARGET;
sv_utf8_downgrade(tsv, FALSE);
tmps = SvPV_const(tsv, len);
}
+ if (PL_op->op_type == OP_HEX)
+ goto hex;
+
while (*tmps && len && isSPACE(*tmps))
tmps++, len--;
if (*tmps == '0')
tmps++, len--;
- if (*tmps == 'x')
+ if (*tmps == 'x') {
+ hex:
result_uv = grok_hex (tmps, &len, &flags, &result_nv);
+ }
else if (*tmps == 'b')
result_uv = grok_bin (tmps, &len, &flags, &result_nv);
else
SV *little;
SV *temp = NULL;
STRLEN biglen;
+ STRLEN llen = 0;
I32 offset;
I32 retval;
const char *tmps;
const I32 arybase = PL_curcop->cop_arybase;
bool big_utf8;
bool little_utf8;
+ const bool is_index = PL_op->op_type == OP_INDEX;
- if (MAXARG >= 3)
+ if (MAXARG >= 3) {
+ /* arybase is in characters, like offset, so combine prior to the
+ UTF-8 to bytes calculation. */
offset = POPi - arybase;
+ }
little = POPs;
big = POPs;
big_utf8 = DO_UTF8(big);
}
}
}
+ /* Don't actually need the NULL initialisation, but it keeps gcc quiet. */
+ tmps2 = is_index ? NULL : SvPV_const(little, llen);
tmps = SvPV_const(big, biglen);
if (MAXARG < 3)
- offset = 0;
+ offset = is_index ? 0 : biglen;
else {
if (big_utf8 && offset > 0)
sv_pos_u2b(big, &offset, 0);
- }
- if (offset < 0)
- offset = 0;
- else if (offset > (I32)biglen)
- offset = biglen;
- if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
- (unsigned char*)tmps + biglen, little, 0)))
- retval = -1;
- else {
- retval = tmps2 - tmps;
- if (retval > 0 && big_utf8)
- sv_pos_b2u(big, &retval);
- }
- if (temp)
- SvREFCNT_dec(temp);
- fail:
- PUSHi(retval + arybase);
- RETURN;
-}
-
-PP(pp_rindex)
-{
- dVAR; dSP; dTARGET;
- SV *big;
- SV *little;
- SV *temp = NULL;
- STRLEN biglen;
- STRLEN llen;
- I32 offset;
- I32 retval;
- const char *tmps;
- const char *tmps2;
- const I32 arybase = PL_curcop->cop_arybase;
- int big_utf8;
- int little_utf8;
-
- if (MAXARG >= 3) {
- /* arybase is in characters, like offset, so combine prior to the
- UTF-8 to bytes calculation. */
- offset = POPi - arybase;
- }
- little = POPs;
- big = POPs;
- big_utf8 = DO_UTF8(big);
- little_utf8 = DO_UTF8(little);
- if (big_utf8 ^ little_utf8) {
- /* One needs to be upgraded. */
- SV * const bytes = little_utf8 ? big : little;
- STRLEN len;
- const char *p = SvPV_const(bytes, len);
-
- temp = newSVpvn(p, len);
-
- if (PL_encoding) {
- sv_recode_to_utf8(temp, PL_encoding);
- } else {
- sv_utf8_upgrade(temp);
- }
- if (little_utf8) {
- big = temp;
- big_utf8 = TRUE;
- } else {
- little = temp;
- }
- }
- tmps2 = SvPV_const(little, llen);
- tmps = SvPV_const(big, biglen);
-
- if (MAXARG < 3)
- offset = biglen;
- else {
- if (big_utf8 && offset > 0)
- sv_pos_u2b(big, &offset, 0);
- /* llen is in bytes. */
offset += llen;
}
if (offset < 0)
offset = 0;
else if (offset > (I32)biglen)
offset = biglen;
- if (!(tmps2 = rninstr(tmps, tmps + offset,
- tmps2, tmps2 + llen)))
+ if (!(tmps2 = is_index
+ ? fbm_instr((unsigned char*)tmps + offset,
+ (unsigned char*)tmps + biglen, little, 0)
+ : rninstr(tmps, tmps + offset,
+ tmps2, tmps2 + llen)))
retval = -1;
else {
retval = tmps2 - tmps;
}
if (temp)
SvREFCNT_dec(temp);
+ fail:
PUSHi(retval + arybase);
RETURN;
}
#define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
+ /*EMPTY*/
/*
* Now if the sigma is NOT followed by
* /$ignorable_sequence$cased_letter/;
RETURN;
}
-PP(pp_pop)
-{
- dVAR;
- dSP;
- AV * const av = (AV*)POPs;
- SV * const sv = av_pop(av);
- if (AvREAL(av))
- (void)sv_2mortal(sv);
- PUSHs(sv);
- RETURN;
-}
-
PP(pp_shift)
{
dVAR;
dSP;
AV * const av = (AV*)POPs;
- SV * const sv = av_shift(av);
+ SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
EXTEND(SP, 1);
- if (!sv)
- RETPUSHUNDEF;
+ assert (sv);
if (AvREAL(av))
(void)sv_2mortal(sv);
PUSHs(sv);
https://perl5.git.perl.org / perl5.git / blobdiff