/* This file contains the functions that create, manipulate and optimize
* the OP structures that hold a compiled perl program.
*
- * A Perl program is compiled into a tree of OPs. Each op contains
- * structural pointers (eg to its siblings and the next op in the
- * execution sequence), a pointer to the function that would execute the
- * op, plus any data specific to that op. For example, an OP_CONST op
- * points to the pp_const() function and to an SV containing the constant
- * value. When pp_const() is executed, its job is to push that SV onto the
- * stack.
+ * Note that during the build of miniperl, a temporary copy of this file
+ * is made, called opmini.c.
+ *
+ * A Perl program is compiled into a tree of OP nodes. Each op contains:
+ * * structural OP pointers to its children and siblings (op_sibling,
+ * op_first etc) that define the tree structure;
+ * * execution order OP pointers (op_next, plus sometimes op_other,
+ * op_lastop etc) that define the execution sequence plus variants;
+ * * a pointer to the C "pp" function that would execute the op;
+ * * any data specific to that op.
+ * For example, an OP_CONST op points to the pp_const() function and to an
+ * SV containing the constant value. When pp_const() is executed, its job
+ * is to push that SV onto the stack.
*
* OPs are mainly created by the newFOO() functions, which are mainly
* called from the parser (in perly.y) as the code is parsed. For example
* newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
* )
*
- * Note that during the build of miniperl, a temporary copy of this file
- * is made, called opmini.c.
+ * As the parser reduces low-level rules, it creates little op subtrees;
+ * as higher-level rules are resolved, these subtrees get joined together
+ * as branches on a bigger subtree, until eventually a top-level rule like
+ * a subroutine definition is reduced, at which point there is one large
+ * parse tree left.
+ *
+ * The execution order pointers (op_next) are generated as the subtrees
+ * are joined together. Consider this sub-expression: A*B + C/D: at the
+ * point when it's just been parsed, the op tree looks like:
+ *
+ * [+]
+ * |
+ * [*]------[/]
+ * | |
+ * A---B C---D
+ *
+ * with the intended execution order being:
+ *
+ * [PREV] => A => B => [*] => C => D => [/] => [+] => [NEXT]
+ *
+ * At this point all the nodes' op_next pointers will have been set,
+ * except that:
+ * * we don't know what the [NEXT] node will be yet;
+ * * we don't know what the [PREV] node will be yet, but when it gets
+ * created and needs its op_next set, it needs to be set to point to
+ * A, which is non-obvious.
+ * To handle both those cases, we temporarily set the top node's
+ * op_next to point to the first node to be executed in this subtree (A in
+ * this case). This means that initially a subtree's op_next chain,
+ * starting from the top node, will visit each node in execution sequence
+ * then point back at the top node.
+ * When we embed this subtree in a larger tree, its top op_next is used
+ * to get the start node, then is set to point to its new neighbour.
+ * For example the two separate [*],A,B and [/],C,D subtrees would
+ * initially have had:
+ * [*] => A; A => B; B => [*]
+ * and
+ * [/] => C; C => D; D => [/]
+ * When these two subtrees were joined together to make the [+] subtree,
+ * [+]'s op_next was set to [*]'s op_next, i.e. A; then [*]'s op_next was
+ * set to point to [/]'s op_next, i.e. C.
+ *
+ * This op_next linking is done by the LINKLIST() macro and its underlying
+ * op_linklist() function. Given a top-level op, if its op_next is
+ * non-null, it's already been linked, so leave it. Otherwise link it with
+ * its children as described above, possibly recursively if any of the
+ * children have a null op_next.
+ *
+ * In summary: given a subtree, its top-level node's op_next will either
+ * be:
+ * NULL: the subtree hasn't been LINKLIST()ed yet;
+ * fake: points to the start op for this subtree;
+ * real: once the subtree has been embedded into a larger tree
*/
/*
+
+Here's an older description from Larry.
+
Perl's compiler is essentially a 3-pass compiler with interleaved phases:
A bottom-up pass
/* FALLTHROUGH */
case OP_ENTERTRY:
case OP_ENTEREVAL: /* Was holding hints. */
+ case OP_ARGDEFELEM: /* Was holding signature index. */
o->op_targ = 0;
break;
default:
break;
+ case OP_ARGCHECK:
+ PerlMemShared_free(cUNOP_AUXo->op_aux);
+ break;
+
case OP_MULTIDEREF:
{
UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
* being spread throughout this file.
*/
-STATIC LOGOP *
-S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
+LOGOP *
+Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
{
dVAR;
LOGOP *logop;
{
PERL_ARGS_ASSERT_SCALARBOOLEAN;
- if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
- && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
+ if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
+ !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
+ (o->op_type == OP_NOT && cUNOPo->op_first->op_type == OP_SASSIGN &&
+ cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
+ !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
if (ckWARN(WARN_SYNTAX)) {
const line_t oldline = CopLINE(PL_curcop);
case OP_ASLICE:
case OP_HSLICE:
OpTYPE_set(o, OP_LVREFSLICE);
- o->op_private &= OPpLVAL_INTRO|OPpLVREF_ELEM;
+ o->op_private &= OPpLVAL_INTRO;
return;
case OP_NULL:
if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
o->op_private |= OPpLVREF_ITER;
}
+PERL_STATIC_INLINE bool
+S_potential_mod_type(I32 type)
+{
+ /* Types that only potentially result in modification. */
+ return type == OP_GREPSTART || type == OP_ENTERSUB
+ || type == OP_REFGEN || type == OP_LEAVESUBLV;
+}
+
OP *
Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
{
else { /* lvalue subroutine call */
o->op_private |= OPpLVAL_INTRO;
PL_modcount = RETURN_UNLIMITED_NUMBER;
- if (type == OP_GREPSTART || type == OP_ENTERSUB
- || type == OP_REFGEN || type == OP_LEAVESUBLV) {
- /* Potential lvalue context: */
+ if (S_potential_mod_type(type)) {
o->op_private |= OPpENTERSUB_INARGS;
break;
}
nomod:
if (flags & OP_LVALUE_NO_CROAK) return NULL;
/* grep, foreach, subcalls, refgen */
- if (type == OP_GREPSTART || type == OP_ENTERSUB
- || type == OP_REFGEN || type == OP_LEAVESUBLV)
+ if (S_potential_mod_type(type))
break;
yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
break;
case OP_KVHSLICE:
case OP_KVASLICE:
+ case OP_AKEYS:
if (type == OP_LEAVESUBLV)
o->op_private |= OPpMAYBE_LVSUB;
goto nomod;
+ case OP_AVHVSWITCH:
+ if (type == OP_LEAVESUBLV
+ && (o->op_private & 3) + OP_EACH == OP_KEYS)
+ o->op_private |= OPpMAYBE_LVSUB;
+ goto nomod;
case OP_AV2ARYLEN:
PL_hints |= HINT_BLOCK_SCOPE;
if (type == OP_LEAVESUBLV)
break;
case OP_KEYS:
- if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
+ if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
goto nomod;
goto lvalue_func;
case OP_SUBSTR:
lvalue_func:
if (type == OP_LEAVESUBLV)
o->op_private |= OPpMAYBE_LVSUB;
- if (o->op_flags & OPf_KIDS)
- op_lvalue(OpSIBLING(cBINOPo->op_first), type);
+ if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
+ /* substr and vec */
+ /* If this op is in merely potential (non-fatal) modifiable
+ context, then apply OP_ENTERSUB context to
+ the kid op (to avoid croaking). Other-
+ wise pass this op’s own type so the correct op is mentioned
+ in error messages. */
+ op_lvalue(OpSIBLING(cBINOPo->op_first),
+ S_potential_mod_type(type)
+ ? (I32)OP_ENTERSUB
+ : o->op_type);
+ }
break;
case OP_AELEM:
goto nomod;
case OP_SREFGEN:
+ if (type == OP_NULL) { /* local */
+ local_refgen:
+ if (!FEATURE_MYREF_IS_ENABLED)
+ Perl_croak(aTHX_ "The experimental declared_refs "
+ "feature is not enabled");
+ Perl_ck_warner_d(aTHX_
+ packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
+ "Declaring references is experimental");
+ op_lvalue(cUNOPo->op_first, OP_NULL);
+ return o;
+ }
if (type != OP_AASSIGN && type != OP_SASSIGN
&& type != OP_ENTERLOOP)
goto nomod;
assert (!OpHAS_SIBLING(kid));
goto kid_2lvref;
case OP_REFGEN:
+ if (type == OP_NULL) /* local */
+ goto local_refgen;
if (type != OP_AASSIGN) goto nomod;
kid = cUNOPo->op_first;
kid_2lvref:
goto nomod;
}
- /* [20011101.069] File test operators interpret OPf_REF to mean that
+ /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
their argument is a filehandle; thus \stat(".") should not set
it. AMS 20011102 */
if (type == OP_REFGEN &&
case OP_BIT_AND:
case OP_BIT_XOR:
case OP_BIT_OR:
+ case OP_NBIT_AND:
+ case OP_NBIT_XOR:
+ case OP_NBIT_OR:
+ case OP_SBIT_AND:
+ case OP_SBIT_XOR:
+ case OP_SBIT_OR:
case OP_CONCAT:
case OP_SUBST:
case OP_TRANS:
case OP_ANDASSIGN:
case OP_ORASSIGN:
case OP_DORASSIGN:
+ case OP_VEC:
+ case OP_SUBSTR:
return TRUE;
default:
return FALSE;
type = o->op_type;
- if (type == OP_LIST) {
+ if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
OP *kid;
for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
my_kid(kid, attrs, imopsp);
return o;
} else if (type == OP_RV2SV || /* "our" declaration */
type == OP_RV2AV ||
- type == OP_RV2HV) { /* XXX does this let anything illegal in? */
+ type == OP_RV2HV) {
if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
S_cant_declare(aTHX_ o);
} else if (attrs) {
o->op_private |= OPpOUR_INTRO;
return o;
}
+ else if (type == OP_REFGEN || type == OP_SREFGEN) {
+ if (!FEATURE_MYREF_IS_ENABLED)
+ Perl_croak(aTHX_ "The experimental declared_refs "
+ "feature is not enabled");
+ Perl_ck_warner_d(aTHX_
+ packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
+ "Declaring references is experimental");
+ /* Kid is a nulled OP_LIST, handled above. */
+ my_kid(cUNOPo->op_first, attrs, imopsp);
+ return o;
+ }
else if (type != OP_PADSV &&
type != OP_PADAV &&
type != OP_PADHV &&
for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
switch (curop->op_type) {
case OP_CONST:
- if ((curop->op_private & OPpCONST_BARE)) {
+ if ( (curop->op_private & OPpCONST_BARE)
+ && (curop->op_private & OPpCONST_STRICT)) {
+ no_bareword_allowed(curop);
goto nope;
}
/* FALLTHROUGH */
expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
}
- rcop = S_alloc_LOGOP(aTHX_ OP_REGCOMP, scalar(expr), o);
+ rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
| (reglist ? OPf_STACKED : 0);
rcop->op_targ = cv_targ;
op_prepend_elem(o->op_type, scalar(repl), o);
}
else {
- rcop = S_alloc_LOGOP(aTHX_ OP_SUBSTCONT, scalar(repl), o);
+ rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
rcop->op_private = 1;
/* establish postfix order */
}
}
- logop = S_alloc_LOGOP(aTHX_ type, first, LINKLIST(other));
+ logop = alloc_LOGOP(type, first, LINKLIST(other));
logop->op_flags |= (U8)flags;
logop->op_private = (U8)(1 | (flags >> 8));
live->op_folded = 1;
return live;
}
- logop = S_alloc_LOGOP(aTHX_ OP_COND_EXPR, first, LINKLIST(trueop));
+ logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
logop->op_flags |= (U8)flags;
logop->op_private = (U8)(1 | (flags >> 8));
logop->op_next = LINKLIST(falseop);
PERL_ARGS_ASSERT_NEWRANGE;
- range = S_alloc_LOGOP(aTHX_ OP_RANGE, left, LINKLIST(right));
+ range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
range->op_flags = OPf_KIDS;
leftstart = LINKLIST(left);
range->op_private = (U8)(1 | (flags >> 8));
PERL_ARGS_ASSERT_NEWGIVWHENOP;
PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
- enterop = S_alloc_LOGOP(aTHX_ enter_opcode, block, NULL);
+ enterop = alloc_LOGOP(enter_opcode, block, NULL);
enterop->op_targ = 0;
enterop->op_private = 0;
if (ckWARN(WARN_REDEFINE)
|| ( ckWARN_d(WARN_REDEFINE)
&& ( !const_sv || SvRV(gv) == const_sv
- || sv_cmp(SvRV(gv), const_sv) )))
+ || sv_cmp(SvRV(gv), const_sv) ))) {
+ assert(cSVOPo);
Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
"Constant subroutine %"SVf" redefined",
SVfARG(cSVOPo->op_sv));
+ }
SvREFCNT_inc_simple_void_NN(PL_compcv);
CopLINE_set(PL_curcop, oldline);
assert(!GvCVu(gv));
GvCV_set(gv, cv);
GvCVGEN(gv) = 0;
- if (!fake && HvENAME_HEK(GvSTASH(gv)))
+ if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
gv_method_changed(gv);
if (SvFAKE(gv)) {
cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
op_sibling_splice(o, NULL, -1, NULL);
op_free(o);
- enter = S_alloc_LOGOP(aTHX_ OP_ENTERTRY, NULL, NULL);
+ enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
/* establish postfix order */
enter->op_next = (OP*)enter;
Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
kid = kUNOP->op_first;
- gwop = S_alloc_LOGOP(aTHX_ type, o, LINKLIST(kid));
+ gwop = alloc_LOGOP(type, o, LINKLIST(kid));
kid->op_next = (OP*)gwop;
o->op_private = gwop->op_private = 0;
gwop->op_targ = pad_alloc(type, SVs_PADTMP);
|| ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
&& SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
)
- /* we let ck_fun handle it */
- break;
+ goto bad;
default:
- Perl_croak_nocontext(
+ qerror(Perl_mess(aTHX_
"Experimental %s on scalar is now forbidden",
- PL_op_desc[orig_type]);
- break;
+ PL_op_desc[orig_type]));
+ bad:
+ bad_type_pv(1, "hash or array", o, kid);
+ return o;
}
}
return ck_fun(o);
is_last = TRUE;
index_skip = action_count;
action |= MDEREF_FLAG_last;
+ if (index_type != MDEREF_INDEX_none)
+ arg--;
}
if (pass)
/* XXX: We avoid setting op_seq here to prevent later calls
to rpeep() from mistakenly concluding that optimisation
has already occurred. This doesn't fix the real problem,
- though (See 20010220.007). AMS 20010719 */
+ though (See 20010220.007 (#5874)). AMS 20010719 */
/* op_seq functionality is now replaced by op_opt */
o->op_opt = 0;
/* FALLTHROUGH */
case OP_DORASSIGN:
case OP_RANGE:
case OP_ONCE:
+ case OP_ARGDEFELEM:
while (cLOGOP->op_other->op_type == OP_NULL)
cLOGOP->op_other = cLOGOP->op_other->op_next;
DEFER(cLOGOP->op_other);
case KEY_keys: retsetpvs("\\[%@]", OP_KEYS);
case KEY_values: retsetpvs("\\[%@]", OP_VALUES);
case KEY_each: retsetpvs("\\[%@]", OP_EACH);
- case KEY_push: retsetpvs("\\@@", OP_PUSH);
- case KEY_unshift: retsetpvs("\\@@", OP_UNSHIFT);
- case KEY_pop: retsetpvs(";\\@", OP_POP);
- case KEY_shift: retsetpvs(";\\@", OP_SHIFT);
case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
- case KEY_splice:
- retsetpvs("\\@;$$@", OP_SPLICE);
case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
retsetpvs("", 0);
case KEY_evalbytes:
newOP(OP_CALLER,0)
)
);
+ case OP_EACH:
+ case OP_KEYS:
+ case OP_VALUES:
+ o = newUNOP(OP_AVHVSWITCH,0,argop);
+ o->op_private = opnum-OP_EACH;
+ return o;
case OP_SELECT: /* which represents OP_SSELECT as well */
if (code)
return newCONDOP(
XSRETURN(AvFILLp(av)+1);
}
+
/*
* ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff