Commit 2b7c69bdcd for perl
commit 2b7c69bdcd39d7f75345fef54a6609698928d953
Author: Yves Orton <demerphq@gmail.com>
Date: Mon Nov 9 12:17:36 2026 +0100
op.c/perly.y - use deterministic call order in parser where it matters
With a function call like
f( a(), b() )
C does not define which of `a()` or `b()` is executed first, with some
platforms or compilers preferring one order or the other, or even doing either
depending on circumstance. Clang and GCC may differ in some cases, etc. This
may not matter where the functions are free of side effects, but in the parser
this can affect the order that error messages are emitted, or the line an
operation is attributed to.
Making this deterministic is a matter of restructuring it to call the
functions in an explicit order, for instance:
a_tmp = a();
f(a_tmp, b());
I created a test to audit the parser (only the parser) for this type of issue
and this is what I came up with.
diff --git a/MANIFEST b/MANIFEST
index 04333d701e..46d9fda707 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -6430,6 +6430,7 @@ t/op/concat2.t Tests too complex for concat.t
t/op/cond.t See if conditional expressions work
t/op/const-optree.t Tests for sub(){...} becoming constant
t/op/context.t See if context propagation works
+t/op/context_order.t Check parser contextualization order
t/op/coreamp.t Test &foo() calls for CORE subs
t/op/coresubs.t Generic tests for CORE subs
t/op/cproto.t Check builtin prototypes
@@ -6679,6 +6680,7 @@ t/porting/maintainers.t Test that Porting/Maintainers.pl is up to date
t/porting/makerel.t Test that files used by Porting/makerel exist
t/porting/manifest.t Test that this MANIFEST file is well formed
t/porting/merge-deltas.t Test that the Porting/merge-deltas.pl script does its job
+t/porting/parser_order.t Check parser C argument evaluation order
t/porting/perlfunc.t Test that Functions_pm.PL can parse perlfunc.pod
t/porting/pod_rules.t Check that various pod lists are consistent
t/porting/podcheck.t Test the POD of shipped modules is well formed
diff --git a/op.c b/op.c
index ababd13e3e..0403d2fd5c 100644
--- a/op.c
+++ b/op.c
@@ -8859,16 +8859,22 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
));
}
+ /* newSTATEOP() can clear PL_parser->copline. Sequence these calls
+ * explicitly so their line numbers do not depend on C argument
+ * evaluation order. */
+ OP * const require_state =
+ newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop));
+ OP * const version_state = newSTATEOP(0, NULL, veop);
+ OP * const import_state = newSTATEOP(0, NULL, imop);
+
/* Fake up the BEGIN {}, which does its thing immediately. */
newATTRSUB(floor,
newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
NULL,
NULL,
op_append_elem(OP_LINESEQ,
- op_append_elem(OP_LINESEQ,
- newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
- newSTATEOP(0, NULL, veop)),
- newSTATEOP(0, NULL, imop) ));
+ op_append_elem(OP_LINESEQ, require_state, version_state),
+ import_state));
if (use_version) {
/* Enable the feature bundle that corresponds to the required version. */
@@ -9221,9 +9227,9 @@ Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
if (o) return o;
}
- return newBINOP(OP_LSLICE, flags,
- list(op_force_list(subscript)),
- list(op_force_list(listval)));
+ subscript = list(op_force_list(subscript));
+ listval = list(op_force_list(listval));
+ return newBINOP(OP_LSLICE, flags, subscript, listval);
}
#define ASSIGN_SCALAR 0
@@ -9441,12 +9447,15 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
case OP_ORASSIGN:
case OP_DORASSIGN:
right = scalar(right);
- return newLOGOP(optype, 0,
- op_lvalue(scalar(left), optype),
- newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right));
+ left = op_lvalue(scalar(left), optype);
+ o = newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right);
+ return newLOGOP(optype, 0, left, o);
default:
- return newBINOP(optype, OPf_STACKED,
- op_lvalue(scalar(left), optype), scalar(right));
+ /* Validate the target before processing the RHS. An invalid
+ * target suppresses secondary scalar-context diagnostics. */
+ left = op_lvalue(scalar(left), optype);
+ right = scalar(right);
+ return newBINOP(optype, OPf_STACKED, left, right);
}
if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
@@ -9614,14 +9623,18 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
right = newOP(OP_UNDEF, 0);
if (right->op_type == OP_READLINE) {
right->op_flags |= OPf_STACKED;
- return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
- scalar(right));
+ left = op_lvalue(scalar(left), OP_SASSIGN);
+ right = scalar(right);
+ return newBINOP(OP_NULL, flags, left, right);
}
else {
if(UNLIKELY(OP_TYPE_IS(right, OP_AASSIGN)))
right = S_maybe_match_count(aTHX_ right);
- o = newBINOP(OP_SASSIGN, flags,
- scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
+ /* Keep target validation ahead of RHS diagnostics, even though
+ * the assignment op stores its children in the reverse order. */
+ left = op_lvalue(scalar(left), OP_SASSIGN);
+ right = scalar(right);
+ o = newBINOP(OP_SASSIGN, flags, right, left);
}
return o;
}
@@ -9912,8 +9925,12 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
first = *firstp;
other = *otherp;
- if (type == OP_XOR) /* Not short circuit, but here by precedence. */
- return newBINOP(type, flags, scalar(first), scalar(other));
+ if (type == OP_XOR) { /* Not short circuit, but here by precedence. */
+ /* Contextualization can emit diagnostics. Keep source order. */
+ first = scalar(first);
+ other = scalar(other);
+ return newBINOP(type, flags, first, other);
+ }
assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
|| type == OP_CUSTOM);
@@ -10851,9 +10868,10 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
expr = op_lvalue(op_force_list(expr), OP_GREPSTART);
}
+ expr = list(expr);
+ sv = scalar(sv);
loop = (LOOP*)op_convert_list(OP_ENTERITER, enteriterflags,
- op_append_elem(OP_LIST, list(expr),
- scalar(sv)));
+ op_append_elem(OP_LIST, expr, sv));
assert(!loop->op_next);
/* for my $x () sets OPpLVAL_INTRO;
* for our $x () sets OPpOUR_INTRO */
diff --git a/perly.act b/perly.act
index 1a74bb335d..9b119ddba4 100644
--- a/perly.act
+++ b/perly.act
@@ -1347,37 +1347,41 @@ case 2: /* @1: %empty */
case 208: /* subscripted: scalar subscript_index */
#line 1460 "perly.y"
- { (yyval.opval) = newBINOP(OP_AELEM, 0, oopsAV((ps[-1].val.opval)), scalar((ps[0].val.opval)));
+ { OP * const arrayop = oopsAV((ps[-1].val.opval));
+ OP * const index = scalar((ps[0].val.opval));
+ (yyval.opval) = newBINOP(OP_AELEM, 0, arrayop, index);
}
break;
case 209: /* subscripted: subscriptable_reference subscript_index */
-#line 1463 "perly.y"
- { (yyval.opval) = newBINOP(OP_AELEM, 0,
- ref(newAVREF((ps[-1].val.opval)),OP_RV2AV),
- scalar((ps[0].val.opval)));
+#line 1465 "perly.y"
+ { OP * const arrayop = ref(newAVREF((ps[-1].val.opval)), OP_RV2AV);
+ OP * const index = scalar((ps[0].val.opval));
+ (yyval.opval) = newBINOP(OP_AELEM, 0, arrayop, index);
}
break;
case 210: /* subscripted: scalar subscript_keys */
-#line 1468 "perly.y"
- { (yyval.opval) = newBINOP(OP_HELEM, 0, oopsHV((ps[-1].val.opval)), jmaybe((ps[0].val.opval)));
+#line 1470 "perly.y"
+ { OP * const hashop = oopsHV((ps[-1].val.opval));
+ OP * const key = jmaybe((ps[0].val.opval));
+ (yyval.opval) = newBINOP(OP_HELEM, 0, hashop, key);
}
break;
case 211: /* subscripted: subscriptable_reference subscript_keys */
-#line 1471 "perly.y"
- { (yyval.opval) = newBINOP(OP_HELEM, 0,
- ref(newHVREF((ps[-1].val.opval)),OP_RV2HV),
- jmaybe((ps[0].val.opval))); }
+#line 1475 "perly.y"
+ { OP * const hashop = ref(newHVREF((ps[-1].val.opval)), OP_RV2HV);
+ OP * const key = jmaybe((ps[0].val.opval));
+ (yyval.opval) = newBINOP(OP_HELEM, 0, hashop, key); }
break;
case 212: /* subscripted: subscriptable_reference PERLY_PAREN_OPEN expr PERLY_PAREN_CLOSE */
-#line 1479 "perly.y"
+#line 1483 "perly.y"
{
(yyval.opval) = build_function_invocation (
OPf_STACKED,
@@ -1391,7 +1395,7 @@ case 2: /* @1: %empty */
break;
case 213: /* subscripted: subscriptable_reference PERLY_PAREN_OPEN PERLY_PAREN_CLOSE */
-#line 1492 "perly.y"
+#line 1496 "perly.y"
{
(yyval.opval) = build_function_invocation (
OPf_STACKED,
@@ -1405,55 +1409,57 @@ case 2: /* @1: %empty */
break;
case 214: /* subscripted: PERLY_PAREN_OPEN expr PERLY_PAREN_CLOSE subscript_index */
-#line 1502 "perly.y"
+#line 1506 "perly.y"
{ (yyval.opval) = newSLICEOP(0, (ps[0].val.opval), (ps[-2].val.opval)); }
break;
case 215: /* subscripted: QWLIST subscript_index */
-#line 1504 "perly.y"
+#line 1508 "perly.y"
{ (yyval.opval) = newSLICEOP(0, (ps[0].val.opval), (ps[-1].val.opval)); }
break;
case 216: /* subscripted: PERLY_PAREN_OPEN PERLY_PAREN_CLOSE subscript_index */
-#line 1506 "perly.y"
+#line 1510 "perly.y"
{ (yyval.opval) = newSLICEOP(0, (ps[0].val.opval), NULL); }
break;
case 217: /* termbinop: term PLUGIN_HIGH_OP term */
-#line 1511 "perly.y"
+#line 1517 "perly.y"
{ (yyval.opval) = build_infix_plugin((ps[-2].val.opval), (ps[0].val.opval), (ps[-1].val.pval)); }
break;
case 218: /* termbinop: term ASSIGNOP term */
-#line 1513 "perly.y"
+#line 1519 "perly.y"
{ (yyval.opval) = newASSIGNOP(OPf_STACKED, (ps[-2].val.opval), (ps[-1].val.ival), (ps[0].val.opval)); }
break;
case 219: /* termbinop: term PLUGIN_ASSIGN_OP term */
-#line 1515 "perly.y"
+#line 1521 "perly.y"
{ (yyval.opval) = build_infix_plugin((ps[-2].val.opval), (ps[0].val.opval), (ps[-1].val.pval)); }
break;
case 220: /* termbinop: term POWOP term */
-#line 1517 "perly.y"
- { (yyval.opval) = newBINOP((ps[-1].val.ival), 0, scalar((ps[-2].val.opval)), scalar((ps[0].val.opval))); }
+#line 1523 "perly.y"
+ { OP * const left = scalar((ps[-2].val.opval));
+ OP * const right = scalar((ps[0].val.opval));
+ (yyval.opval) = newBINOP((ps[-1].val.ival), 0, left, right); }
break;
case 221: /* termbinop: term PLUGIN_POW_OP term */
-#line 1519 "perly.y"
+#line 1527 "perly.y"
{ (yyval.opval) = build_infix_plugin((ps[-2].val.opval), (ps[0].val.opval), (ps[-1].val.pval)); }
break;
case 222: /* termbinop: term MULOP term */
-#line 1521 "perly.y"
+#line 1529 "perly.y"
{ if ((ps[-1].val.ival) != OP_REPEAT)
scalar((ps[-2].val.opval));
(yyval.opval) = newBINOP((ps[-1].val.ival), 0, (ps[-2].val.opval), scalar((ps[0].val.opval)));
@@ -1462,219 +1468,233 @@ case 2: /* @1: %empty */
break;
case 223: /* termbinop: term PLUGIN_MUL_OP term */
-#line 1526 "perly.y"
+#line 1534 "perly.y"
{ (yyval.opval) = build_infix_plugin((ps[-2].val.opval), (ps[0].val.opval), (ps[-1].val.pval)); }
break;
case 224: /* termbinop: term ADDOP term */
-#line 1528 "perly.y"
- { (yyval.opval) = newBINOP((ps[-1].val.ival), 0, scalar((ps[-2].val.opval)), scalar((ps[0].val.opval))); }
+#line 1536 "perly.y"
+ { OP * const left = scalar((ps[-2].val.opval));
+ OP * const right = scalar((ps[0].val.opval));
+ (yyval.opval) = newBINOP((ps[-1].val.ival), 0, left, right); }
break;
case 225: /* termbinop: term PLUGIN_ADD_OP term */
-#line 1530 "perly.y"
+#line 1540 "perly.y"
{ (yyval.opval) = build_infix_plugin((ps[-2].val.opval), (ps[0].val.opval), (ps[-1].val.pval)); }
break;
case 226: /* termbinop: term SHIFTOP term */
-#line 1532 "perly.y"
- { (yyval.opval) = newBINOP((ps[-1].val.ival), 0, scalar((ps[-2].val.opval)), scalar((ps[0].val.opval))); }
+#line 1542 "perly.y"
+ { OP * const left = scalar((ps[-2].val.opval));
+ OP * const right = scalar((ps[0].val.opval));
+ (yyval.opval) = newBINOP((ps[-1].val.ival), 0, left, right); }
break;
case 227: /* termbinop: termrelop */
-#line 1534 "perly.y"
+#line 1546 "perly.y"
{ (yyval.opval) = (ps[0].val.opval); }
break;
case 228: /* termbinop: termeqop */
-#line 1536 "perly.y"
+#line 1548 "perly.y"
{ (yyval.opval) = (ps[0].val.opval); }
break;
case 229: /* termbinop: term BITANDOP term */
-#line 1538 "perly.y"
- { (yyval.opval) = newBINOP((ps[-1].val.ival), 0, scalar((ps[-2].val.opval)), scalar((ps[0].val.opval))); }
+#line 1550 "perly.y"
+ { OP * const left = scalar((ps[-2].val.opval));
+ OP * const right = scalar((ps[0].val.opval));
+ (yyval.opval) = newBINOP((ps[-1].val.ival), 0, left, right); }
break;
case 230: /* termbinop: term BITOROP term */
-#line 1540 "perly.y"
- { (yyval.opval) = newBINOP((ps[-1].val.ival), 0, scalar((ps[-2].val.opval)), scalar((ps[0].val.opval))); }
+#line 1554 "perly.y"
+ { OP * const left = scalar((ps[-2].val.opval));
+ OP * const right = scalar((ps[0].val.opval));
+ (yyval.opval) = newBINOP((ps[-1].val.ival), 0, left, right); }
break;
case 231: /* termbinop: term DOTDOT term */
-#line 1542 "perly.y"
- { (yyval.opval) = newRANGE((ps[-1].val.ival), scalar((ps[-2].val.opval)), scalar((ps[0].val.opval))); }
+#line 1558 "perly.y"
+ { OP * const left = scalar((ps[-2].val.opval));
+ OP * const right = scalar((ps[0].val.opval));
+ (yyval.opval) = newRANGE((ps[-1].val.ival), left, right); }
break;
case 232: /* termbinop: term ANDAND term */
-#line 1544 "perly.y"
+#line 1562 "perly.y"
{ (yyval.opval) = newLOGOP(OP_AND, 0, (ps[-2].val.opval), (ps[0].val.opval)); }
break;
case 233: /* termbinop: term PLUGIN_LOGICAL_AND_OP term */
-#line 1546 "perly.y"
+#line 1564 "perly.y"
{ (yyval.opval) = build_infix_plugin((ps[-2].val.opval), (ps[0].val.opval), (ps[-1].val.pval)); }
break;
case 234: /* termbinop: term OROR term */
-#line 1548 "perly.y"
+#line 1566 "perly.y"
{ (yyval.opval) = newLOGOP((ps[-1].val.ival), 0, (ps[-2].val.opval), (ps[0].val.opval)); }
break;
case 235: /* termbinop: term PLUGIN_LOGICAL_OR_OP term */
-#line 1550 "perly.y"
+#line 1568 "perly.y"
{ (yyval.opval) = build_infix_plugin((ps[-2].val.opval), (ps[0].val.opval), (ps[-1].val.pval)); }
break;
case 236: /* termbinop: term DORDOR term */
-#line 1552 "perly.y"
+#line 1570 "perly.y"
{ (yyval.opval) = newLOGOP(OP_DOR, 0, (ps[-2].val.opval), (ps[0].val.opval)); }
break;
case 237: /* termbinop: term MATCHOP term */
-#line 1554 "perly.y"
+#line 1572 "perly.y"
{ (yyval.opval) = bind_match((ps[-1].val.ival), (ps[-2].val.opval), (ps[0].val.opval)); }
break;
case 238: /* termbinop: term PLUGIN_LOW_OP term */
-#line 1556 "perly.y"
+#line 1574 "perly.y"
{ (yyval.opval) = build_infix_plugin((ps[-2].val.opval), (ps[0].val.opval), (ps[-1].val.pval)); }
break;
case 239: /* termrelop: relopchain */
-#line 1560 "perly.y"
+#line 1578 "perly.y"
{ (yyval.opval) = cmpchain_finish((ps[0].val.opval)); }
break;
case 240: /* termrelop: term NCRELOP term */
-#line 1562 "perly.y"
- { (yyval.opval) = newBINOP((ps[-1].val.ival), 0, scalar((ps[-2].val.opval)), scalar((ps[0].val.opval))); }
+#line 1580 "perly.y"
+ { OP * const left = scalar((ps[-2].val.opval));
+ OP * const right = scalar((ps[0].val.opval));
+ (yyval.opval) = newBINOP((ps[-1].val.ival), 0, left, right); }
break;
case 241: /* termrelop: termrelop NCRELOP */
-#line 1564 "perly.y"
+#line 1584 "perly.y"
{ yyerror("syntax error"); YYERROR; }
break;
case 242: /* termrelop: termrelop CHRELOP */
-#line 1566 "perly.y"
+#line 1586 "perly.y"
{ yyerror("syntax error"); YYERROR; }
break;
case 243: /* termrelop: term PLUGIN_REL_OP term */
-#line 1568 "perly.y"
+#line 1588 "perly.y"
{ (yyval.opval) = build_infix_plugin((ps[-2].val.opval), (ps[0].val.opval), (ps[-1].val.pval)); }
break;
case 244: /* relopchain: term CHRELOP term */
-#line 1572 "perly.y"
+#line 1592 "perly.y"
{ (yyval.opval) = cmpchain_start((ps[-1].val.ival), (ps[-2].val.opval), (ps[0].val.opval)); }
break;
case 245: /* relopchain: relopchain CHRELOP term */
-#line 1574 "perly.y"
+#line 1594 "perly.y"
{ (yyval.opval) = cmpchain_extend((ps[-1].val.ival), (ps[-2].val.opval), (ps[0].val.opval)); }
break;
case 246: /* termeqop: eqopchain */
-#line 1578 "perly.y"
+#line 1598 "perly.y"
{ (yyval.opval) = cmpchain_finish((ps[0].val.opval)); }
break;
case 247: /* termeqop: term NCEQOP term */
-#line 1580 "perly.y"
- { (yyval.opval) = newBINOP((ps[-1].val.ival), 0, scalar((ps[-2].val.opval)), scalar((ps[0].val.opval))); }
+#line 1600 "perly.y"
+ { OP * const left = scalar((ps[-2].val.opval));
+ OP * const right = scalar((ps[0].val.opval));
+ (yyval.opval) = newBINOP((ps[-1].val.ival), 0, left, right); }
break;
case 248: /* termeqop: termeqop NCEQOP */
-#line 1582 "perly.y"
+#line 1604 "perly.y"
{ yyerror("syntax error"); YYERROR; }
break;
case 249: /* termeqop: termeqop CHEQOP */
-#line 1584 "perly.y"
+#line 1606 "perly.y"
{ yyerror("syntax error"); YYERROR; }
break;
case 250: /* eqopchain: term CHEQOP term */
-#line 1588 "perly.y"
+#line 1610 "perly.y"
{ (yyval.opval) = cmpchain_start((ps[-1].val.ival), (ps[-2].val.opval), (ps[0].val.opval)); }
break;
case 251: /* eqopchain: eqopchain CHEQOP term */
-#line 1590 "perly.y"
+#line 1612 "perly.y"
{ (yyval.opval) = cmpchain_extend((ps[-1].val.ival), (ps[-2].val.opval), (ps[0].val.opval)); }
break;
case 252: /* termunop: PERLY_MINUS term */
-#line 1595 "perly.y"
+#line 1617 "perly.y"
{ (yyval.opval) = newUNOP(OP_NEGATE, 0, scalar((ps[0].val.opval))); }
break;
case 253: /* termunop: PERLY_PLUS term */
-#line 1597 "perly.y"
+#line 1619 "perly.y"
{ (yyval.opval) = (ps[0].val.opval); }
break;
case 254: /* termunop: PERLY_EXCLAMATION_MARK term */
-#line 1600 "perly.y"
+#line 1622 "perly.y"
{ (yyval.opval) = newUNOP(OP_NOT, 0, scalar((ps[0].val.opval))); }
break;
case 255: /* termunop: PERLY_TILDE term */
-#line 1602 "perly.y"
+#line 1624 "perly.y"
{ (yyval.opval) = newUNOP((ps[-1].val.ival), 0, scalar((ps[0].val.opval))); }
break;
case 256: /* termunop: term POSTINC */
-#line 1604 "perly.y"
+#line 1626 "perly.y"
{ (yyval.opval) = newUNOP(OP_POSTINC, 0,
op_lvalue(scalar((ps[-1].val.opval)), OP_POSTINC)); }
break;
case 257: /* termunop: term POSTDEC */
-#line 1607 "perly.y"
+#line 1629 "perly.y"
{ (yyval.opval) = newUNOP(OP_POSTDEC, 0,
op_lvalue(scalar((ps[-1].val.opval)), OP_POSTDEC));}
break;
case 258: /* termunop: term POSTJOIN */
-#line 1610 "perly.y"
+#line 1632 "perly.y"
{ (yyval.opval) = op_convert_list(OP_JOIN, 0,
op_append_elem(
OP_LIST,
@@ -1689,59 +1709,59 @@ case 2: /* @1: %empty */
break;
case 259: /* termunop: PREINC term */
-#line 1621 "perly.y"
+#line 1643 "perly.y"
{ (yyval.opval) = newUNOP(OP_PREINC, 0,
op_lvalue(scalar((ps[0].val.opval)), OP_PREINC)); }
break;
case 260: /* termunop: PREDEC term */
-#line 1624 "perly.y"
+#line 1646 "perly.y"
{ (yyval.opval) = newUNOP(OP_PREDEC, 0,
op_lvalue(scalar((ps[0].val.opval)), OP_PREDEC)); }
break;
case 261: /* anonymous: PERLY_BRACKET_OPEN optexpr PERLY_BRACKET_CLOSE */
-#line 1632 "perly.y"
+#line 1654 "perly.y"
{ (yyval.opval) = newANONLIST((ps[-1].val.opval)); }
break;
case 262: /* anonymous: HASHBRACK optexpr PERLY_SEMICOLON PERLY_BRACE_CLOSE */
-#line 1634 "perly.y"
+#line 1656 "perly.y"
{ (yyval.opval) = newANONHASH((ps[-2].val.opval)); }
break;
case 263: /* anonymous: KW_SUB_anon startanonsub proto subattrlist subbody */
-#line 1636 "perly.y"
+#line 1658 "perly.y"
{ SvREFCNT_inc_simple_void(PL_compcv);
(yyval.opval) = newANONATTRSUB((ps[-3].val.ival), (ps[-2].val.opval), (ps[-1].val.opval), (ps[0].val.opval)); }
break;
case 264: /* anonymous: KW_SUB_anon startanonsub proto subattrlist */
-#line 1639 "perly.y"
+#line 1661 "perly.y"
{ yyerror("Illegal declaration of anonymous subroutine"); YYERROR; }
break;
case 265: /* anonymous: KW_SUB_anon_sig startanonsub subattrlist sigsubbody */
-#line 1641 "perly.y"
+#line 1663 "perly.y"
{ SvREFCNT_inc_simple_void(PL_compcv);
(yyval.opval) = newANONATTRSUB((ps[-2].val.ival), NULL, (ps[-1].val.opval), (ps[0].val.opval)); }
break;
case 266: /* anonymous: KW_SUB_anon_sig startanonsub subattrlist */
-#line 1644 "perly.y"
+#line 1666 "perly.y"
{ yyerror("Illegal declaration of anonymous subroutine"); YYERROR; }
break;
case 267: /* anonymous: KW_METHOD_anon startanonmethod subattrlist sigsubbody */
-#line 1646 "perly.y"
+#line 1668 "perly.y"
{
SvREFCNT_inc_simple_void(PL_compcv);
(yyval.opval) = newANONATTRSUB((ps[-2].val.ival), NULL, (ps[-1].val.opval), (ps[0].val.opval));
@@ -1750,108 +1770,108 @@ case 2: /* @1: %empty */
break;
case 268: /* anonymous: KW_METHOD_anon startanonmethod subattrlist */
-#line 1651 "perly.y"
+#line 1673 "perly.y"
{ yyerror("Illegal declaration of anonymous subroutine"); YYERROR; }
break;
case 269: /* termdo: KW_DO term */
-#line 1656 "perly.y"
+#line 1678 "perly.y"
{ (yyval.opval) = dofile((ps[0].val.opval), (ps[-1].val.ival));}
break;
case 270: /* termdo: KW_DO block */
-#line 1658 "perly.y"
+#line 1680 "perly.y"
{ (yyval.opval) = newUNOP(OP_NULL, OPf_SPECIAL, op_scope((ps[0].val.opval)));}
break;
case 275: /* term: term PERLY_QUESTION_MARK term PERLY_COLON term */
-#line 1666 "perly.y"
+#line 1688 "perly.y"
{ (yyval.opval) = newCONDOP(0, (ps[-4].val.opval), (ps[-2].val.opval), (ps[0].val.opval)); }
break;
case 276: /* term: REFGEN term */
-#line 1668 "perly.y"
+#line 1690 "perly.y"
{ (yyval.opval) = newUNOP(OP_REFGEN, 0, (ps[0].val.opval)); }
break;
case 277: /* term: myattrterm */
-#line 1670 "perly.y"
+#line 1692 "perly.y"
{ (yyval.opval) = (ps[0].val.opval); }
break;
case 278: /* term: KW_LOCAL term */
-#line 1672 "perly.y"
+#line 1694 "perly.y"
{ (yyval.opval) = localize((ps[0].val.opval),0); }
break;
case 279: /* term: PERLY_PAREN_OPEN expr PERLY_PAREN_CLOSE */
-#line 1674 "perly.y"
+#line 1696 "perly.y"
{ (yyval.opval) = sawparens((ps[-1].val.opval)); }
break;
case 280: /* term: QWLIST */
-#line 1676 "perly.y"
+#line 1698 "perly.y"
{ (yyval.opval) = (ps[0].val.opval); }
break;
case 281: /* term: PERLY_PAREN_OPEN PERLY_PAREN_CLOSE */
-#line 1678 "perly.y"
+#line 1700 "perly.y"
{ (yyval.opval) = sawparens(newNULLLIST()); }
break;
case 282: /* term: scalar */
-#line 1680 "perly.y"
+#line 1702 "perly.y"
{ (yyval.opval) = (ps[0].val.opval); }
break;
case 283: /* term: star */
-#line 1682 "perly.y"
+#line 1704 "perly.y"
{ (yyval.opval) = (ps[0].val.opval); }
break;
case 284: /* term: hsh */
-#line 1684 "perly.y"
+#line 1706 "perly.y"
{ (yyval.opval) = (ps[0].val.opval); }
break;
case 285: /* term: ary */
-#line 1686 "perly.y"
+#line 1708 "perly.y"
{ (yyval.opval) = (ps[0].val.opval); }
break;
case 286: /* term: arylen */
-#line 1688 "perly.y"
+#line 1710 "perly.y"
{ (yyval.opval) = newUNOP(OP_AV2ARYLEN, 0, ref((ps[0].val.opval), OP_AV2ARYLEN));}
break;
case 287: /* term: subscripted */
-#line 1690 "perly.y"
+#line 1712 "perly.y"
{ (yyval.opval) = (ps[0].val.opval); }
break;
case 288: /* term: sliceme subscript_index */
-#line 1692 "perly.y"
- { (yyval.opval) = op_prepend_elem(OP_ASLICE,
+#line 1714 "perly.y"
+ { OP * const selector = list((ps[0].val.opval));
+ OP * const arrayop = ref((ps[-1].val.opval), OP_ASLICE);
+ (yyval.opval) = op_prepend_elem(OP_ASLICE,
newOP(OP_PUSHMARK, 0),
- newLISTOP(OP_ASLICE, 0,
- list((ps[0].val.opval)),
- ref((ps[-1].val.opval), OP_ASLICE)));
+ newLISTOP(OP_ASLICE, 0, selector, arrayop));
if ((yyval.opval) && (ps[-1].val.opval))
(yyval.opval)->op_private |=
(ps[-1].val.opval)->op_private & OPpSLICEWARNING;
@@ -1860,12 +1880,12 @@ case 2: /* @1: %empty */
break;
case 289: /* term: kvslice subscript_index */
-#line 1702 "perly.y"
- { (yyval.opval) = op_prepend_elem(OP_KVASLICE,
+#line 1724 "perly.y"
+ { OP * const selector = list((ps[0].val.opval));
+ OP * const arrayop = ref(oopsAV((ps[-1].val.opval)), OP_KVASLICE);
+ (yyval.opval) = op_prepend_elem(OP_KVASLICE,
newOP(OP_PUSHMARK, 0),
- newLISTOP(OP_KVASLICE, 0,
- list((ps[0].val.opval)),
- ref(oopsAV((ps[-1].val.opval)), OP_KVASLICE)));
+ newLISTOP(OP_KVASLICE, 0, selector, arrayop));
if ((yyval.opval) && (ps[-1].val.opval))
(yyval.opval)->op_private |=
(ps[-1].val.opval)->op_private & OPpSLICEWARNING;
@@ -1874,12 +1894,12 @@ case 2: /* @1: %empty */
break;
case 290: /* term: sliceme subscript_keys */
-#line 1712 "perly.y"
- { (yyval.opval) = op_prepend_elem(OP_HSLICE,
+#line 1734 "perly.y"
+ { OP * const selector = list((ps[0].val.opval));
+ OP * const hashop = ref(oopsHV((ps[-1].val.opval)), OP_HSLICE);
+ (yyval.opval) = op_prepend_elem(OP_HSLICE,
newOP(OP_PUSHMARK, 0),
- newLISTOP(OP_HSLICE, 0,
- list((ps[0].val.opval)),
- ref(oopsHV((ps[-1].val.opval)), OP_HSLICE)));
+ newLISTOP(OP_HSLICE, 0, selector, hashop));
if ((yyval.opval) && (ps[-1].val.opval))
(yyval.opval)->op_private |=
(ps[-1].val.opval)->op_private & OPpSLICEWARNING;
@@ -1888,12 +1908,12 @@ case 2: /* @1: %empty */
break;
case 291: /* term: kvslice subscript_keys */
-#line 1722 "perly.y"
- { (yyval.opval) = op_prepend_elem(OP_KVHSLICE,
+#line 1744 "perly.y"
+ { OP * const selector = list((ps[0].val.opval));
+ OP * const hashop = ref((ps[-1].val.opval), OP_KVHSLICE);
+ (yyval.opval) = op_prepend_elem(OP_KVHSLICE,
newOP(OP_PUSHMARK, 0),
- newLISTOP(OP_KVHSLICE, 0,
- list((ps[0].val.opval)),
- ref((ps[-1].val.opval), OP_KVHSLICE)));
+ newLISTOP(OP_KVHSLICE, 0, selector, hashop));
if ((yyval.opval) && (ps[-1].val.opval))
(yyval.opval)->op_private |=
(ps[-1].val.opval)->op_private & OPpSLICEWARNING;
@@ -1902,13 +1922,13 @@ case 2: /* @1: %empty */
break;
case 292: /* term: THING */
-#line 1732 "perly.y"
+#line 1754 "perly.y"
{ (yyval.opval) = (ps[0].val.opval); }
break;
case 293: /* term: amper */
-#line 1735 "perly.y"
+#line 1757 "perly.y"
{
(yyval.opval) = build_function_invocation (
0,
@@ -1920,7 +1940,7 @@ case 2: /* @1: %empty */
break;
case 294: /* term: amper PERLY_PAREN_OPEN PERLY_PAREN_CLOSE */
-#line 1746 "perly.y"
+#line 1768 "perly.y"
{
(yyval.opval) = build_function_invocation (
OPf_STACKED,
@@ -1932,7 +1952,7 @@ case 2: /* @1: %empty */
break;
case 295: /* term: amper PERLY_PAREN_OPEN expr PERLY_PAREN_CLOSE */
-#line 1758 "perly.y"
+#line 1780 "perly.y"
{
(yyval.opval) = build_function_invocation (
OPf_STACKED,
@@ -1944,7 +1964,7 @@ case 2: /* @1: %empty */
break;
case 296: /* term: NOAMP subname optlistexpr */
-#line 1769 "perly.y"
+#line 1791 "perly.y"
{
(yyval.opval) = build_function_invocation (
OPf_STACKED,
@@ -1956,25 +1976,25 @@ case 2: /* @1: %empty */
break;
case 297: /* term: term ARROW PERLY_DOLLAR PERLY_STAR */
-#line 1777 "perly.y"
+#line 1799 "perly.y"
{ (yyval.opval) = newSVREF((ps[-3].val.opval)); }
break;
case 298: /* term: term ARROW PERLY_SNAIL PERLY_STAR */
-#line 1779 "perly.y"
+#line 1801 "perly.y"
{ (yyval.opval) = newAVREF((ps[-3].val.opval)); }
break;
case 299: /* term: term ARROW PERLY_PERCENT_SIGN PERLY_STAR */
-#line 1781 "perly.y"
+#line 1803 "perly.y"
{ (yyval.opval) = newHVREF((ps[-3].val.opval)); }
break;
case 300: /* term: term ARROW PERLY_AMPERSAND PERLY_STAR */
-#line 1786 "perly.y"
+#line 1808 "perly.y"
{
(yyval.opval) = build_function_invocation (
0,
@@ -1986,62 +2006,62 @@ case 2: /* @1: %empty */
break;
case 301: /* term: term ARROW PERLY_STAR PERLY_STAR */
-#line 1794 "perly.y"
+#line 1816 "perly.y"
{ (yyval.opval) = newGVREF(0,(ps[-3].val.opval)); }
break;
case 302: /* term: LOOPEX */
-#line 1796 "perly.y"
+#line 1818 "perly.y"
{ (yyval.opval) = newOP((ps[0].val.ival), OPf_SPECIAL);
PL_hints |= HINT_BLOCK_SCOPE; }
break;
case 303: /* term: LOOPEX term */
-#line 1799 "perly.y"
+#line 1821 "perly.y"
{ (yyval.opval) = newLOOPEX((ps[-1].val.ival),(ps[0].val.opval)); }
break;
case 304: /* term: NOTOP listexpr */
-#line 1801 "perly.y"
+#line 1823 "perly.y"
{ (yyval.opval) = newUNOP(OP_NOT, 0, scalar((ps[0].val.opval))); }
break;
case 305: /* term: UNIOP */
-#line 1803 "perly.y"
+#line 1825 "perly.y"
{ (yyval.opval) = newOP((ps[0].val.ival), 0); }
break;
case 306: /* term: UNIOP block */
-#line 1805 "perly.y"
+#line 1827 "perly.y"
{ (yyval.opval) = newUNOP((ps[-1].val.ival), 0, (ps[0].val.opval)); }
break;
case 307: /* term: UNIOP term */
-#line 1807 "perly.y"
+#line 1829 "perly.y"
{ (yyval.opval) = newUNOP((ps[-1].val.ival), 0, (ps[0].val.opval)); }
break;
case 308: /* term: KW_REQUIRE */
-#line 1809 "perly.y"
+#line 1831 "perly.y"
{ (yyval.opval) = newOP(OP_REQUIRE, (ps[0].val.ival) ? OPf_SPECIAL : 0); }
break;
case 309: /* term: KW_REQUIRE term */
-#line 1811 "perly.y"
+#line 1833 "perly.y"
{ (yyval.opval) = newUNOP(OP_REQUIRE, (ps[-1].val.ival) ? OPf_SPECIAL : 0, (ps[0].val.opval)); }
break;
case 310: /* term: UNIOPSUB */
-#line 1813 "perly.y"
+#line 1835 "perly.y"
{
(yyval.opval) = build_function_invocation (
OPf_STACKED,
@@ -2053,7 +2073,7 @@ case 2: /* @1: %empty */
break;
case 311: /* term: UNIOPSUB term */
-#line 1823 "perly.y"
+#line 1845 "perly.y"
{
(yyval.opval) = build_function_invocation (
OPf_STACKED,
@@ -2065,31 +2085,31 @@ case 2: /* @1: %empty */
break;
case 312: /* term: FUNC0 */
-#line 1831 "perly.y"
+#line 1853 "perly.y"
{ (yyval.opval) = newOP((ps[0].val.ival), 0); }
break;
case 313: /* term: FUNC0 PERLY_PAREN_OPEN PERLY_PAREN_CLOSE */
-#line 1833 "perly.y"
+#line 1855 "perly.y"
{ (yyval.opval) = newOP((ps[-2].val.ival), 0);}
break;
case 314: /* term: FUNC0OP */
-#line 1835 "perly.y"
+#line 1857 "perly.y"
{ (yyval.opval) = (ps[0].val.opval); }
break;
case 315: /* term: FUNC0OP PERLY_PAREN_OPEN PERLY_PAREN_CLOSE */
-#line 1837 "perly.y"
+#line 1859 "perly.y"
{ (yyval.opval) = (ps[-2].val.opval); }
break;
case 316: /* term: FUNC0SUB */
-#line 1840 "perly.y"
+#line 1862 "perly.y"
{
(yyval.opval) = build_function_invocation (
OPf_STACKED,
@@ -2101,7 +2121,7 @@ case 2: /* @1: %empty */
break;
case 317: /* term: FUNC1 PERLY_PAREN_OPEN PERLY_PAREN_CLOSE */
-#line 1848 "perly.y"
+#line 1870 "perly.y"
{ (yyval.opval) = ((ps[-2].val.ival) == OP_NOT)
? newUNOP((ps[-2].val.ival), 0, newSVOP(OP_CONST, 0, newSViv(0)))
: newOP((ps[-2].val.ival), OPf_SPECIAL); }
@@ -2109,13 +2129,13 @@ case 2: /* @1: %empty */
break;
case 318: /* term: FUNC1 PERLY_PAREN_OPEN expr PERLY_PAREN_CLOSE */
-#line 1852 "perly.y"
+#line 1874 "perly.y"
{ (yyval.opval) = newUNOP((ps[-3].val.ival), 0, (ps[-1].val.opval)); }
break;
case 319: /* @25: %empty */
-#line 1854 "perly.y"
+#line 1876 "perly.y"
{
if ( (ps[0].val.opval)->op_type != OP_TRANS
&& (ps[0].val.opval)->op_type != OP_TRANSR
@@ -2130,67 +2150,67 @@ case 2: /* @1: %empty */
break;
case 320: /* term: PMFUNC @25 SUBLEXSTART listexpr optrepl SUBLEXEND */
-#line 1865 "perly.y"
+#line 1887 "perly.y"
{ (yyval.opval) = pmruntime((ps[-5].val.opval), (ps[-2].val.opval), (ps[-1].val.opval), 1, (ps[-4].val.ival)); }
break;
case 324: /* myattrterm: KW_MY myterm attrlist */
-#line 1874 "perly.y"
+#line 1896 "perly.y"
{ (yyval.opval) = my_attrs((ps[-1].val.opval),(ps[0].val.opval)); }
break;
case 325: /* myattrterm: KW_MY myterm */
-#line 1876 "perly.y"
+#line 1898 "perly.y"
{ (yyval.opval) = localize((ps[0].val.opval),1); }
break;
case 326: /* myattrterm: KW_MY REFGEN myterm attrlist */
-#line 1878 "perly.y"
+#line 1900 "perly.y"
{ (yyval.opval) = newUNOP(OP_REFGEN, 0, my_attrs((ps[-1].val.opval),(ps[0].val.opval))); }
break;
case 327: /* myattrterm: KW_MY REFGEN term */
-#line 1880 "perly.y"
+#line 1902 "perly.y"
{ (yyval.opval) = newUNOP(OP_REFGEN, 0, localize((ps[0].val.opval),1)); }
break;
case 328: /* myterm: PERLY_PAREN_OPEN expr PERLY_PAREN_CLOSE */
-#line 1885 "perly.y"
+#line 1907 "perly.y"
{ (yyval.opval) = sawparens((ps[-1].val.opval)); }
break;
case 329: /* myterm: PERLY_PAREN_OPEN PERLY_PAREN_CLOSE */
-#line 1887 "perly.y"
+#line 1909 "perly.y"
{ (yyval.opval) = sawparens(newNULLLIST()); }
break;
case 330: /* myterm: scalar */
-#line 1890 "perly.y"
+#line 1912 "perly.y"
{ (yyval.opval) = (ps[0].val.opval); }
break;
case 331: /* myterm: hsh */
-#line 1892 "perly.y"
+#line 1914 "perly.y"
{ (yyval.opval) = (ps[0].val.opval); }
break;
case 332: /* myterm: ary */
-#line 1894 "perly.y"
+#line 1916 "perly.y"
{ (yyval.opval) = (ps[0].val.opval); }
break;
case 333: /* fieldvar: scalar */
-#line 1899 "perly.y"
+#line 1921 "perly.y"
{
(yyval.pval) = PadnamelistARRAY(PL_comppad_name)[(ps[0].val.opval)->op_targ];
op_free((ps[0].val.opval));
@@ -2199,7 +2219,7 @@ case 2: /* @1: %empty */
break;
case 334: /* fieldvar: hsh */
-#line 1904 "perly.y"
+#line 1926 "perly.y"
{
(yyval.pval) = PadnamelistARRAY(PL_comppad_name)[(ps[0].val.opval)->op_targ];
op_free((ps[0].val.opval));
@@ -2208,7 +2228,7 @@ case 2: /* @1: %empty */
break;
case 335: /* fieldvar: ary */
-#line 1909 "perly.y"
+#line 1931 "perly.y"
{
(yyval.pval) = PadnamelistARRAY(PL_comppad_name)[(ps[0].val.opval)->op_targ];
op_free((ps[0].val.opval));
@@ -2217,7 +2237,7 @@ case 2: /* @1: %empty */
break;
case 336: /* fielddecl: KW_FIELD fieldvar optattrlist */
-#line 1917 "perly.y"
+#line 1939 "perly.y"
{
parser->in_my = 0;
if((ps[0].val.opval))
@@ -2228,7 +2248,7 @@ case 2: /* @1: %empty */
break;
case 337: /* $@26: %empty */
-#line 1924 "perly.y"
+#line 1946 "perly.y"
{
parser->in_my = 0;
if((ps[-1].val.opval))
@@ -2240,7 +2260,7 @@ case 2: /* @1: %empty */
break;
case 338: /* fielddecl: KW_FIELD fieldvar optattrlist ASSIGNOP $@26 term */
-#line 1932 "perly.y"
+#line 1954 "perly.y"
{
class_set_field_defop((PADNAME *)(ps[-4].val.pval), (ps[-2].val.ival), (ps[0].val.opval));
LEAVE;
@@ -2250,25 +2270,25 @@ case 2: /* @1: %empty */
break;
case 344: /* optrepl: PERLY_SLASH expr */
-#line 1952 "perly.y"
+#line 1974 "perly.y"
{ (yyval.opval) = (ps[0].val.opval); }
break;
case 345: /* my_scalar: scalar */
-#line 1958 "perly.y"
+#line 1980 "perly.y"
{ parser->in_my = 0; (yyval.opval) = my((ps[0].val.opval)); }
break;
case 346: /* list_of_itervars: list_of_itervars PERLY_COMMA */
-#line 1963 "perly.y"
+#line 1985 "perly.y"
{ (yyval.opval) = (ps[-1].val.opval); }
break;
case 347: /* list_of_itervars: list_of_itervars PERLY_COMMA scalar */
-#line 1965 "perly.y"
+#line 1987 "perly.y"
{
(yyval.opval) = op_append_elem(OP_LIST, (ps[-2].val.opval), (ps[0].val.opval));
}
@@ -2276,7 +2296,7 @@ case 2: /* @1: %empty */
break;
case 348: /* list_of_itervars: list_of_itervars PERLY_COMMA REFGEN my_var */
-#line 1969 "perly.y"
+#line 1991 "perly.y"
{
(yyval.opval) = op_append_elem(OP_LIST, (ps[-3].val.opval), newUNOP(OP_REFGEN, 0, (ps[0].val.opval)));
}
@@ -2284,7 +2304,7 @@ case 2: /* @1: %empty */
break;
case 350: /* list_of_itervars: REFGEN my_var */
-#line 1974 "perly.y"
+#line 1996 "perly.y"
{
(yyval.opval) = newUNOP(OP_REFGEN, 0, (ps[0].val.opval));
}
@@ -2292,25 +2312,25 @@ case 2: /* @1: %empty */
break;
case 351: /* my_list_of_itervars: list_of_itervars */
-#line 1980 "perly.y"
+#line 2002 "perly.y"
{ parser->in_my = 0; (yyval.opval) = (ps[0].val.opval); }
break;
case 359: /* amper: PERLY_AMPERSAND indirob */
-#line 1997 "perly.y"
+#line 2019 "perly.y"
{ (yyval.opval) = newCVREF((ps[-1].val.ival),(ps[0].val.opval)); }
break;
case 360: /* scalar: PERLY_DOLLAR indirob */
-#line 2001 "perly.y"
+#line 2023 "perly.y"
{ (yyval.opval) = newSVREF((ps[0].val.opval)); }
break;
case 361: /* ary: PERLY_SNAIL indirob */
-#line 2005 "perly.y"
+#line 2027 "perly.y"
{ (yyval.opval) = newAVREF((ps[0].val.opval));
if ((yyval.opval)) (yyval.opval)->op_private |= (ps[-1].val.ival);
}
@@ -2318,7 +2338,7 @@ case 2: /* @1: %empty */
break;
case 362: /* hsh: PERLY_PERCENT_SIGN indirob */
-#line 2011 "perly.y"
+#line 2033 "perly.y"
{ (yyval.opval) = newHVREF((ps[0].val.opval));
if ((yyval.opval)) (yyval.opval)->op_private |= (ps[-1].val.ival);
}
@@ -2326,61 +2346,61 @@ case 2: /* @1: %empty */
break;
case 363: /* arylen: DOLSHARP indirob */
-#line 2017 "perly.y"
+#line 2039 "perly.y"
{ (yyval.opval) = newAVREF((ps[0].val.opval)); }
break;
case 364: /* arylen: term ARROW DOLSHARP PERLY_STAR */
-#line 2019 "perly.y"
+#line 2041 "perly.y"
{ (yyval.opval) = newAVREF((ps[-3].val.opval)); }
break;
case 365: /* star: PERLY_STAR indirob */
-#line 2023 "perly.y"
+#line 2045 "perly.y"
{ (yyval.opval) = newGVREF(0,(ps[0].val.opval)); }
break;
case 367: /* sliceme: term ARROW PERLY_SNAIL */
-#line 2028 "perly.y"
+#line 2050 "perly.y"
{ (yyval.opval) = newAVREF((ps[-2].val.opval)); }
break;
case 369: /* kvslice: term ARROW PERLY_PERCENT_SIGN */
-#line 2033 "perly.y"
+#line 2055 "perly.y"
{ (yyval.opval) = newHVREF((ps[-2].val.opval)); }
break;
case 371: /* gelem: term ARROW PERLY_STAR */
-#line 2038 "perly.y"
+#line 2060 "perly.y"
{ (yyval.opval) = newGVREF(0,(ps[-2].val.opval)); }
break;
case 372: /* indirob: BAREWORD */
-#line 2043 "perly.y"
+#line 2065 "perly.y"
{ (yyval.opval) = scalar((ps[0].val.opval)); }
break;
case 373: /* indirob: scalar */
-#line 2045 "perly.y"
+#line 2067 "perly.y"
{ (yyval.opval) = scalar((ps[0].val.opval)); }
break;
case 374: /* indirob: block */
-#line 2047 "perly.y"
+#line 2069 "perly.y"
{ (yyval.opval) = op_scope((ps[0].val.opval)); }
break;
case 375: /* indirob: PRIVATEREF */
-#line 2050 "perly.y"
+#line 2072 "perly.y"
{ (yyval.opval) = (ps[0].val.opval); }
break;
@@ -2392,6 +2412,6 @@ case 2: /* @1: %empty */
/* Generated from:
- * 929dc63ce54a4820bfd1a816b39ce87bc29a548457b00daf8373ae061bb933de perly.y
+ * 596ffbde4f1abc36c642f98c48fb06e7b7ee990827ae7cdfb4c02f5b06b630b5 perly.y
* ba173fe7f0e9b6b5465fb5d0705af3290ac7d8b511f0eead585307eb6c68918d regen_perly.pl
* ex: set ro ft=c: */
diff --git a/perly.h b/perly.h
index c00fcbf184..fe27423ed1 100644
--- a/perly.h
+++ b/perly.h
@@ -248,6 +248,6 @@ int yyparse (void);
/* Generated from:
- * 929dc63ce54a4820bfd1a816b39ce87bc29a548457b00daf8373ae061bb933de perly.y
+ * 596ffbde4f1abc36c642f98c48fb06e7b7ee990827ae7cdfb4c02f5b06b630b5 perly.y
* ba173fe7f0e9b6b5465fb5d0705af3290ac7d8b511f0eead585307eb6c68918d regen_perly.pl
* ex: set ro ft=c: */
diff --git a/perly.tab b/perly.tab
index 9abe4bbcee..9ceae1a3a0 100644
--- a/perly.tab
+++ b/perly.tab
@@ -385,24 +385,24 @@ static const yytype_int16 yyrline[] =
1219, 1223, 1227, 1227, 1260, 1261, 1267, 1266, 1283, 1284,
1289, 1294, 1288, 1306, 1308, 1310, 1312, 1314, 1318, 1320,
1325, 1329, 1333, 1337, 1342, 1356, 1367, 1382, 1394, 1405,
- 1417, 1419, 1421, 1427, 1424, 1450, 1451, 1455, 1459, 1462,
- 1467, 1470, 1475, 1488, 1501, 1503, 1505, 1510, 1512, 1514,
- 1516, 1518, 1520, 1525, 1527, 1529, 1531, 1533, 1535, 1537,
- 1539, 1541, 1543, 1545, 1547, 1549, 1551, 1553, 1555, 1559,
- 1561, 1563, 1565, 1567, 1571, 1573, 1577, 1579, 1581, 1583,
- 1587, 1589, 1594, 1596, 1599, 1601, 1603, 1606, 1609, 1620,
- 1623, 1631, 1633, 1635, 1638, 1640, 1643, 1645, 1650, 1655,
- 1657, 1661, 1662, 1663, 1664, 1665, 1667, 1669, 1671, 1673,
- 1675, 1677, 1679, 1681, 1683, 1685, 1687, 1689, 1691, 1701,
- 1711, 1721, 1731, 1734, 1743, 1754, 1766, 1776, 1778, 1780,
- 1782, 1793, 1795, 1798, 1800, 1802, 1804, 1806, 1808, 1810,
- 1812, 1821, 1830, 1832, 1834, 1836, 1839, 1847, 1851, 1854,
- 1853, 1866, 1867, 1868, 1873, 1875, 1877, 1879, 1884, 1886,
- 1889, 1891, 1893, 1898, 1903, 1908, 1916, 1924, 1923, 1941,
- 1942, 1946, 1947, 1951, 1952, 1957, 1962, 1964, 1968, 1972,
- 1973, 1979, 1983, 1984, 1985, 1988, 1989, 1992, 1993, 1996,
- 2000, 2004, 2010, 2016, 2018, 2022, 2026, 2027, 2031, 2032,
- 2036, 2037, 2042, 2044, 2046, 2049
+ 1417, 1419, 1421, 1427, 1424, 1450, 1451, 1455, 1459, 1464,
+ 1469, 1474, 1479, 1492, 1505, 1507, 1509, 1516, 1518, 1520,
+ 1522, 1526, 1528, 1533, 1535, 1539, 1541, 1545, 1547, 1549,
+ 1553, 1557, 1561, 1563, 1565, 1567, 1569, 1571, 1573, 1577,
+ 1579, 1583, 1585, 1587, 1591, 1593, 1597, 1599, 1603, 1605,
+ 1609, 1611, 1616, 1618, 1621, 1623, 1625, 1628, 1631, 1642,
+ 1645, 1653, 1655, 1657, 1660, 1662, 1665, 1667, 1672, 1677,
+ 1679, 1683, 1684, 1685, 1686, 1687, 1689, 1691, 1693, 1695,
+ 1697, 1699, 1701, 1703, 1705, 1707, 1709, 1711, 1713, 1723,
+ 1733, 1743, 1753, 1756, 1765, 1776, 1788, 1798, 1800, 1802,
+ 1804, 1815, 1817, 1820, 1822, 1824, 1826, 1828, 1830, 1832,
+ 1834, 1843, 1852, 1854, 1856, 1858, 1861, 1869, 1873, 1876,
+ 1875, 1888, 1889, 1890, 1895, 1897, 1899, 1901, 1906, 1908,
+ 1911, 1913, 1915, 1920, 1925, 1930, 1938, 1946, 1945, 1963,
+ 1964, 1968, 1969, 1973, 1974, 1979, 1984, 1986, 1990, 1994,
+ 1995, 2001, 2005, 2006, 2007, 2010, 2011, 2014, 2015, 2018,
+ 2022, 2026, 2032, 2038, 2040, 2044, 2048, 2049, 2053, 2054,
+ 2058, 2059, 2064, 2066, 2068, 2071
};
#endif
@@ -1667,6 +1667,6 @@ static const toketypes yy_type_tab[] =
};
/* Generated from:
- * 929dc63ce54a4820bfd1a816b39ce87bc29a548457b00daf8373ae061bb933de perly.y
+ * 596ffbde4f1abc36c642f98c48fb06e7b7ee990827ae7cdfb4c02f5b06b630b5 perly.y
* ba173fe7f0e9b6b5465fb5d0705af3290ac7d8b511f0eead585307eb6c68918d regen_perly.pl
* ex: set ro ft=c: */
diff --git a/perly.y b/perly.y
index 10f15dbd5d..49015672b2 100644
--- a/perly.y
+++ b/perly.y
@@ -1457,20 +1457,24 @@ subscripted: gelem subscript_keys[selector] /* *main::{something} */
* provided by the tokeniser */
{ $$ = newBINOP(OP_GELEM, 0, $gelem, scalar($selector)); }
| scalar[array] subscript_index[selector] /* $array[$element] */
- { $$ = newBINOP(OP_AELEM, 0, oopsAV($array), scalar($selector));
+ { OP * const arrayop = oopsAV($array);
+ OP * const index = scalar($selector);
+ $$ = newBINOP(OP_AELEM, 0, arrayop, index);
}
| subscriptable_reference[array_reference] subscript_index[selector] /* $ref->[..]; $foo{$bar}[..] */
- { $$ = newBINOP(OP_AELEM, 0,
- ref(newAVREF($array_reference),OP_RV2AV),
- scalar($selector));
+ { OP * const arrayop = ref(newAVREF($array_reference), OP_RV2AV);
+ OP * const index = scalar($selector);
+ $$ = newBINOP(OP_AELEM, 0, arrayop, index);
}
| scalar[hash] subscript_keys[selector] /* $foo{bar();} */
- { $$ = newBINOP(OP_HELEM, 0, oopsHV($hash), jmaybe($selector));
+ { OP * const hashop = oopsHV($hash);
+ OP * const key = jmaybe($selector);
+ $$ = newBINOP(OP_HELEM, 0, hashop, key);
}
| subscriptable_reference[hash_reference] subscript_keys[selector] /* $foo->[bar]->{baz;} */
- { $$ = newBINOP(OP_HELEM, 0,
- ref(newHVREF($hash_reference),OP_RV2HV),
- jmaybe($selector)); }
+ { OP * const hashop = ref(newHVREF($hash_reference), OP_RV2HV);
+ OP * const key = jmaybe($selector);
+ $$ = newBINOP(OP_HELEM, 0, hashop, key); }
| /* $subref->(@args); $foo->{bar}(@args) */
subscriptable_reference [code_reference]
PERLY_PAREN_OPEN
@@ -1506,7 +1510,9 @@ subscripted: gelem subscript_keys[selector] /* *main::{something} */
{ $$ = newSLICEOP(0, $selector, NULL); }
;
-/* Binary operators between terms */
+/* Binary operators between terms. Where both operands require scalar
+ * context, process them in source order: scalar() can issue diagnostics
+ * or observe an earlier compile error. */
termbinop: term[lhs] PLUGIN_HIGH_OP[op] term[rhs]
{ $$ = build_infix_plugin($lhs, $rhs, $op); }
| term[lhs] ASSIGNOP term[rhs] /* $x = $y, $x += $y */
@@ -1514,7 +1520,9 @@ termbinop: term[lhs] PLUGIN_HIGH_OP[op] term[rhs]
| term[lhs] PLUGIN_ASSIGN_OP[op] term[rhs]
{ $$ = build_infix_plugin($lhs, $rhs, $op); }
| term[lhs] POWOP term[rhs] /* $x ** $y */
- { $$ = newBINOP($POWOP, 0, scalar($lhs), scalar($rhs)); }
+ { OP * const left = scalar($lhs);
+ OP * const right = scalar($rhs);
+ $$ = newBINOP($POWOP, 0, left, right); }
| term[lhs] PLUGIN_POW_OP[op] term[rhs]
{ $$ = build_infix_plugin($lhs, $rhs, $op); }
| term[lhs] MULOP term[rhs] /* $x * $y, $x x $y */
@@ -1525,21 +1533,31 @@ termbinop: term[lhs] PLUGIN_HIGH_OP[op] term[rhs]
| term[lhs] PLUGIN_MUL_OP[op] term[rhs]
{ $$ = build_infix_plugin($lhs, $rhs, $op); }
| term[lhs] ADDOP term[rhs] /* $x + $y */
- { $$ = newBINOP($ADDOP, 0, scalar($lhs), scalar($rhs)); }
+ { OP * const left = scalar($lhs);
+ OP * const right = scalar($rhs);
+ $$ = newBINOP($ADDOP, 0, left, right); }
| term[lhs] PLUGIN_ADD_OP[op] term[rhs]
{ $$ = build_infix_plugin($lhs, $rhs, $op); }
| term[lhs] SHIFTOP term[rhs] /* $x >> $y, $x << $y */
- { $$ = newBINOP($SHIFTOP, 0, scalar($lhs), scalar($rhs)); }
+ { OP * const left = scalar($lhs);
+ OP * const right = scalar($rhs);
+ $$ = newBINOP($SHIFTOP, 0, left, right); }
| termrelop %prec PREC_LOW /* $x > $y, etc. */
{ $$ = $termrelop; }
| termeqop %prec PREC_LOW /* $x == $y, $x cmp $y */
{ $$ = $termeqop; }
| term[lhs] BITANDOP term[rhs] /* $x & $y */
- { $$ = newBINOP($BITANDOP, 0, scalar($lhs), scalar($rhs)); }
+ { OP * const left = scalar($lhs);
+ OP * const right = scalar($rhs);
+ $$ = newBINOP($BITANDOP, 0, left, right); }
| term[lhs] BITOROP term[rhs] /* $x | $y */
- { $$ = newBINOP($BITOROP, 0, scalar($lhs), scalar($rhs)); }
+ { OP * const left = scalar($lhs);
+ OP * const right = scalar($rhs);
+ $$ = newBINOP($BITOROP, 0, left, right); }
| term[lhs] DOTDOT term[rhs] /* $x..$y, $x...$y */
- { $$ = newRANGE($DOTDOT, scalar($lhs), scalar($rhs)); }
+ { OP * const left = scalar($lhs);
+ OP * const right = scalar($rhs);
+ $$ = newRANGE($DOTDOT, left, right); }
| term[lhs] ANDAND term[rhs] /* $x && $y */
{ $$ = newLOGOP(OP_AND, 0, $lhs, $rhs); }
| term[lhs] PLUGIN_LOGICAL_AND_OP[op] term[rhs]
@@ -1559,7 +1577,9 @@ termbinop: term[lhs] PLUGIN_HIGH_OP[op] term[rhs]
termrelop: relopchain %prec PREC_LOW
{ $$ = cmpchain_finish($relopchain); }
| term[lhs] NCRELOP term[rhs]
- { $$ = newBINOP($NCRELOP, 0, scalar($lhs), scalar($rhs)); }
+ { OP * const left = scalar($lhs);
+ OP * const right = scalar($rhs);
+ $$ = newBINOP($NCRELOP, 0, left, right); }
| termrelop NCRELOP
{ yyerror("syntax error"); YYERROR; }
| termrelop CHRELOP
@@ -1577,7 +1597,9 @@ relopchain: term[lhs] CHRELOP term[rhs]
termeqop: eqopchain %prec PREC_LOW
{ $$ = cmpchain_finish($eqopchain); }
| term[lhs] NCEQOP term[rhs]
- { $$ = newBINOP($NCEQOP, 0, scalar($lhs), scalar($rhs)); }
+ { OP * const left = scalar($lhs);
+ OP * const right = scalar($rhs);
+ $$ = newBINOP($NCEQOP, 0, left, right); }
| termeqop NCEQOP
{ yyerror("syntax error"); YYERROR; }
| termeqop CHEQOP
@@ -1689,41 +1711,41 @@ term[product] : termbinop
| subscripted
{ $$ = $subscripted; }
| sliceme subscript_index[selector] /* array slice */
- { $$ = op_prepend_elem(OP_ASLICE,
+ { OP * const selector = list($selector);
+ OP * const arrayop = ref($sliceme, OP_ASLICE);
+ $$ = op_prepend_elem(OP_ASLICE,
newOP(OP_PUSHMARK, 0),
- newLISTOP(OP_ASLICE, 0,
- list($selector),
- ref($sliceme, OP_ASLICE)));
+ newLISTOP(OP_ASLICE, 0, selector, arrayop));
if ($$ && $sliceme)
$$->op_private |=
$sliceme->op_private & OPpSLICEWARNING;
}
| kvslice subscript_index[selector] /* array key/value slice */
- { $$ = op_prepend_elem(OP_KVASLICE,
+ { OP * const selector = list($selector);
+ OP * const arrayop = ref(oopsAV($kvslice), OP_KVASLICE);
+ $$ = op_prepend_elem(OP_KVASLICE,
newOP(OP_PUSHMARK, 0),
- newLISTOP(OP_KVASLICE, 0,
- list($selector),
- ref(oopsAV($kvslice), OP_KVASLICE)));
+ newLISTOP(OP_KVASLICE, 0, selector, arrayop));
if ($$ && $kvslice)
$$->op_private |=
$kvslice->op_private & OPpSLICEWARNING;
}
| sliceme subscript_keys[selector] /* @hash{@keys} */
- { $$ = op_prepend_elem(OP_HSLICE,
+ { OP * const selector = list($selector);
+ OP * const hashop = ref(oopsHV($sliceme), OP_HSLICE);
+ $$ = op_prepend_elem(OP_HSLICE,
newOP(OP_PUSHMARK, 0),
- newLISTOP(OP_HSLICE, 0,
- list($selector),
- ref(oopsHV($sliceme), OP_HSLICE)));
+ newLISTOP(OP_HSLICE, 0, selector, hashop));
if ($$ && $sliceme)
$$->op_private |=
$sliceme->op_private & OPpSLICEWARNING;
}
| kvslice subscript_keys[selector] /* %hash{@keys} */
- { $$ = op_prepend_elem(OP_KVHSLICE,
+ { OP * const selector = list($selector);
+ OP * const hashop = ref($kvslice, OP_KVHSLICE);
+ $$ = op_prepend_elem(OP_KVHSLICE,
newOP(OP_PUSHMARK, 0),
- newLISTOP(OP_KVHSLICE, 0,
- list($selector),
- ref($kvslice, OP_KVHSLICE)));
+ newLISTOP(OP_KVHSLICE, 0, selector, hashop));
if ($$ && $kvslice)
$$->op_private |=
$kvslice->op_private & OPpSLICEWARNING;
diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index 4002c085cf..79804413f0 100644
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -459,6 +459,14 @@ array. [GH #25038]
=item *
+Various operations in the parser have now been made deterministic where
+they used to be at the mercy of the C compiler. Parser errors and warnings
+should now be emitted in consistent order in all build contexts. Line
+attribution for the implicit statements in a C<use> no longer depends on
+C compiler argument evaluation order.
+
+=item *
+
A case-insensitive regex trie no longer accepts a word ending partway through
an input character's fold. For example, C</s|zoo/iu> no longer matches a
sharp-s, whose full fold is C<ss>. Later alternatives are tried in order.
diff --git a/t/op/caller.t b/t/op/caller.t
index 6f5b71bd34..a0a76e4142 100644
--- a/t/op/caller.t
+++ b/t/op/caller.t
@@ -5,7 +5,7 @@ BEGIN {
chdir 't' if -d 't';
require './test.pl';
set_up_inc('../lib');
- plan( tests => 127 ); # some tests are run in a BEGIN block
+ plan( tests => 128 ); # some tests are run in a BEGIN block
}
my @c;
@@ -328,6 +328,31 @@ fresh_perl_is(<<'EOP', "6\n9\n", {}, 'RT #7165: line number should be consistent
sub {};
EOP
+# The require state consumes the saved parser line. The following import
+# state uses the current line at the end of the use statement.
+# Before we sequenced the newSTATEOP() calls, some builds reported these
+# lines in reverse order because the import state consumed the saved line.
+fresh_perl_is(<<'EOP', "17\n18\n", {}, 'in multiline use with anon subs check line no');
+BEGIN {
+ unshift @INC, sub {
+ return unless $_[1] eq 'LineProbe.pm';
+ my $src = <<'MODULE';
+package LineProbe;
+print +(caller)[2], "\n";
+sub import {
+ print +(caller)[2], "\n";
+}
+1;
+MODULE
+ open my $fh, '<', \$src or die;
+ return $fh;
+ };
+}
+use LineProbe
+ one => sub { 1 },
+ two => sub { 2 };
+EOP
+
$::testing_caller = 1;
do './op/caller.pl' or die $@;
diff --git a/t/op/context_order.t b/t/op/context_order.t
new file mode 100644
index 0000000000..abca1876f4
--- /dev/null
+++ b/t/op/context_order.t
@@ -0,0 +1,84 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ require './test.pl';
+ set_up_inc('../lib');
+}
+
+use strict;
+use warnings;
+
+# Compile a sub without executing its body. The two operands warn in
+# different categories, so making one category fatal reveals which operand
+# was processed first without depending on rendered diagnostic text.
+sub compile_expression {
+ my ($body, $fatal_category) = @_;
+ my @warnings;
+ local $SIG{__WARN__} = sub { push @warnings, $_[0] };
+ local $SIG{__DIE__};
+
+ my $policy = defined $fatal_category
+ ? "use warnings FATAL => '$fatal_category';"
+ : 'use warnings;';
+ my $sub = eval "$policy sub { my \@a; my %h; $body }";
+
+ return (defined($sub) ? 1 : 0, scalar @warnings);
+}
+
+# Binary operands and the array reference/selector must be contextualized
+# in source order. Multiplication is a control: it already used separate
+# statements before the other binary actions were repaired.
+my @expressions = map {
+ [$_, "my \$x = ((sort \@a) $_ %h{1,2});"]
+} qw(+ - ** << >> & | ^ .. ... cmp <=> xor * / %);
+push @expressions, ['array subscript', 'my $x = (sort @a)->[%h{1,2}];'];
+
+for my $expression (@expressions) {
+ my ($name, $body) = @$expression;
+
+ my ($compiled, $warnings) = compile_expression($body);
+ ok($compiled, "$name compiles with nonfatal warnings");
+ is($warnings, 2, "$name emits both operand warnings");
+
+ ($compiled, $warnings) = compile_expression($body, 'scalar');
+ ok(!$compiled, "$name stops on the left operand's fatal warning");
+ is($warnings, 0, "$name does not process the right operand first");
+
+ ($compiled, $warnings) = compile_expression($body, 'syntax');
+ ok(!$compiled, "$name reaches the right operand's fatal warning");
+ is($warnings, 1, "$name warns about the left operand before stopping");
+}
+
+# Repetition first handles its scalar RHS while its LHS can remain a list.
+# That defined order differs from ordinary binary scalar operands.
+my ($repeat_compiled, $repeat_warnings) =
+ compile_expression('my $x = ((sort @a) x %h{1,2});', 'scalar');
+ok(!$repeat_compiled, 'repetition eventually applies scalar context to its LHS');
+is($repeat_warnings, 1, 'repetition processes its scalar RHS first');
+($repeat_compiled, $repeat_warnings) =
+ compile_expression('my $x = ((sort @a) x %h{1,2});', 'syntax');
+ok(!$repeat_compiled, 'repetition stops on a fatal RHS warning');
+is($repeat_warnings, 0, 'repetition preserves its distinct LHS context');
+
+# Invalid assignment targets are diagnosed before contextualizing the RHS.
+# Once the target adds a compile error, the unrelated RHS warning is skipped.
+for my $operator (qw(= += -= *= **=)) {
+ my ($compiled, $warnings) = compile_expression("1 $operator sort \@a;");
+ ok(!$compiled, "$operator rejects a constant assignment target");
+ is($warnings, 0, "$operator suppresses a secondary RHS warning");
+}
+
+my ($compiled, $warnings) = compile_expression('(sort @a) += %h{1,2};');
+ok(!$compiled, 'compound assignment rejects a sort target');
+is($warnings, 1, 'only the target warning precedes its lvalue error');
+
+# Logical assignment already contextualizes the RHS before validating the
+# target. Keep that explicit policy while sequencing its op construction.
+for my $operator (qw(||= &&= //=)) {
+ my ($compiled, $warnings) = compile_expression("1 $operator sort \@a;");
+ ok(!$compiled, "$operator rejects a constant assignment target");
+ is($warnings, 1, "$operator preserves its explicit RHS-first policy");
+}
+
+done_testing();
diff --git a/t/porting/parser_order.t b/t/porting/parser_order.t
new file mode 100644
index 0000000000..6c8be15a74
--- /dev/null
+++ b/t/porting/parser_order.t
@@ -0,0 +1,154 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ require './test.pl';
+ set_up_inc('../lib');
+}
+
+use strict;
+use warnings;
+use Config;
+
+#
+# C does not define the evaluation order for the arguments to a function,
+# instead it relies on the developer to structure their code appropriately
+# if they need a well defined evaluation order.
+#
+# This is fine for functions which have no visible side-effects, but for
+# functions which can generate warnings, or increment line numbers or alter
+# parse state, the order may matter and may even be visible to the end user.
+#
+# This test checks parser .c files for such cases, and fails tests if there
+# are any such cases. It is by no means complete, this is just what I could
+# work out so far. Feel free to extend the list to handle more cases or
+# functions.
+#
+
+my @files_to_check = qw( perly.y op.c toke.c );
+
+my $sensitive = qr/\b(?:Perl_|S_)?(?:
+ scalar | list | scalarvoid | voidnonfinal | op_contextualize
+ | op_lvalue(?:_flags)? | ref | doref | jmaybe | oopsAV | oopsHV
+ | newAVREF | newHVREF | newSTATEOP
+)\s*\(/x;
+
+my $parens = qr/(?<parens> \( (?: [^()]++ | (?&parens) )* \) )/x;
+
+sub unordered_calls {
+ my ($source) = @_;
+
+ # Hide comments and literals while preserving diagnostic line numbers.
+ $source =~ s{
+ /\* .*? \*/ | // [^\n]*
+ | " (?: \\. | [^"\\] )* "
+ | ' (?: \\. | [^'\\] )* '
+ }{' ' . ("\n" x ($& =~ tr/\n//)) . ' '}gsex;
+
+ my @found;
+
+ # Look ahead so nested calls are checked as well as their parents.
+ while ( $source =~ /(?=\b([A-Za-z_]\w*)\s*($parens))/g ) {
+ my ( $name, $args ) = ( $1, $2 );
+ my $offset = pos($source);
+ next if $name =~ /\A(?:if|while|switch|for|sizeof|return)\z/;
+ $args = substr( $args, 1, -1 );
+
+ # Parenthesized expressions consume their own commas. Only commas
+ # at this level separate the enclosing call's arguments.
+ my $affected = 0;
+ while ( $args =~ /\G((?:[^(),]++|$parens)*)(?:,|\z)/g ) {
+ my $arg = $1;
+ ++$affected if $arg =~ $sensitive;
+ last if pos($args) == length($args);
+ }
+ if ( $affected > 1 ) {
+ my $line = 1 + ( substr( $source, 0, $offset ) =~ tr/\n// );
+ push @found, "$name at line $line";
+ }
+ }
+ return @found;
+}
+
+# The original failure patterns this test was set up to find
+my @bad = (
+ 'newBINOP(op, 0, scalar(left), scalar(right));',
+ 'newBINOP(op, 0, op_lvalue(scalar(left), op), scalar(right));',
+ 'newBINOP(op, 0, ref(newAVREF(array), OP_RV2AV), scalar(index));',
+ 'newRANGE(op, scalar(left), scalar(right));',
+ 'op_append_elem(OP_LINESEQ, op_append_elem(OP_LINESEQ,
+ newSTATEOP(0, NULL, require_op), newSTATEOP(0, NULL, version_op)),
+ newSTATEOP(0, NULL, import_op));',
+ 'newBINOP(op, 0, Perl_scalar(aTHX_ left), scalar(right));',
+ 'newBINOP(OP_AELEM, 0, oopsAV(array), scalar(selector));',
+ 'newBINOP(OP_HELEM, 0, oopsHV(hash), jmaybe(selector));',
+ 'newBINOP(OP_HELEM, 0,
+ ref(newHVREF(hash_reference), OP_RV2HV), jmaybe(selector));',
+ 'op_prepend_elem(OP_ASLICE, newOP(OP_PUSHMARK, 0),
+ newLISTOP(OP_ASLICE, 0, list(selector), ref(sliceme, OP_ASLICE)));',
+ 'op_prepend_elem(OP_KVASLICE, newOP(OP_PUSHMARK, 0),
+ newLISTOP(OP_KVASLICE, 0,
+ list(selector), ref(oopsAV(kvslice), OP_KVASLICE)));',
+ 'op_prepend_elem(OP_HSLICE, newOP(OP_PUSHMARK, 0),
+ newLISTOP(OP_HSLICE, 0,
+ list(selector), ref(oopsHV(sliceme), OP_HSLICE)));',
+ 'op_prepend_elem(OP_KVHSLICE, newOP(OP_PUSHMARK, 0),
+ newLISTOP(OP_KVHSLICE, 0, list(selector), ref(kvslice, OP_KVHSLICE)));',
+ 'return newBINOP(OP_LSLICE, flags,
+ list(op_force_list(subscript)), list(op_force_list(listval)));',
+ 'loop = (LOOP*)op_convert_list(OP_ENTERITER, enteriterflags,
+ op_append_elem(OP_LIST, list(expr), scalar(sv)));',
+);
+
+# We shouldn't trigger on any of this.
+my @good = (
+ 'left = scalar(left); right = scalar(right); newBINOP(op, 0, left, right);',
+ 'newBINOP(op, 0, op_lvalue(scalar(left), op), right);',
+ 'f((scalar(left), scalar(right)), other);',
+ 'return (scalar(left), scalar(right));',
+ 'f("scalar(left)", scalar(right));',
+ 'f("\"scalar(left)\"", scalar(right));',
+ "f('(', scalar(right));",
+ 'f(/* scalar(left), */ scalar(right));',
+ "f(// scalar(left),\n scalar(right));",
+ 'f(newOP(op, 0), newOP(op, 0));',
+);
+
+# First we test the test code on prior cases.
+for my $source (@bad) {
+ my @found = unordered_calls($source);
+ ( my $label = $source ) =~ s/\s+/ /g;
+ cmp_ok( scalar @found, '>', 0, "detect unordered calls in $label" );
+}
+
+# Make sure we don't match any good cases.
+for my $source (@good) {
+ my @found = unordered_calls($source);
+ ( my $label = $source ) =~ s/\s+/ /g;
+ is( scalar @found, 0, "allow $label" );
+}
+
+# Make sure comments don't mess stuff up.
+my @located =
+ unordered_calls("/* comment\n */\nf(scalar(left), scalar(right));");
+is( $located[0], 'f at line 3', 'comments preserve diagnostic line numbers' );
+
+# and finally the real test!
+SKIP: {
+ skip( 'Source files are unavailable when cross-compiling', 3 )
+ if $Config{usecrosscompile};
+
+ # Check the grammar input rather than its generated copies. This is a
+ # guard for known helpers, not a general C side-effect analysis. Macros
+ # and helpers outside the list above need separate review.
+ for my $file (@files_to_check) {
+ open my $fh, '<', "../$file" or die "Cannot open $file: $!";
+ my $source = do { local $/; <$fh> };
+ close $fh or die "Cannot close $file: $!";
+ my @found = unordered_calls($source);
+ is( 0 + @found, 0, "$file sequences order-sensitive parser calls" )
+ or diag( join "\n", @found );
+ }
+}
+
+done_testing();