/* 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
#define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
#define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
+static const char array_passed_to_stat[] = "Array passed to stat will be coerced to a scalar";
+
/* Used to avoid recursion through the op tree in scalarvoid() and
op_free()
*/
!(is_our ||
isALPHA(name[1]) ||
((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
- (name[1] == '_' && (*name == '$' || len > 2))))
+ (name[1] == '_' && len > 2)))
{
if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
&& isASCII(name[1])
PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
}
}
- else if (len == 2 && name[1] == '_' && !is_our)
- /* diag_listed_as: Use of my $_ is experimental */
- Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__LEXICAL_TOPIC),
- "Use of %s $_ is experimental",
- PL_parser->in_my == KEY_state
- ? "state"
- : "my");
/* allocate a spare slot and store the name in that slot */
type = o->op_type;
/* an op should only ever acquire op_private flags that we know about.
- * If this fails, you may need to fix something in regen/op_private */
- if (o->op_ppaddr == PL_ppaddr[o->op_type]) {
+ * If this fails, you may need to fix something in regen/op_private.
+ * Don't bother testing if:
+ * * the op_ppaddr doesn't match the op; someone may have
+ * overridden the op and be doing strange things with it;
+ * * we've errored, as op flags are often left in an
+ * inconsistent state then. Note that an error when
+ * compiling the main program leaves PL_parser NULL, so
+ * we can't spot faults in the main code, only
+ * evaled/required code */
+#ifdef DEBUGGING
+ if ( o->op_ppaddr == PL_ppaddr[o->op_type]
+ && PL_parser
+ && !PL_parser->error_count)
+ {
assert(!(o->op_private & ~PL_op_private_valid[type]));
}
+#endif
if (o->op_private & OPpREFCOUNTED) {
switch (type) {
/* S_op_clear_gv(): free a GV attached to an OP */
+STATIC
#ifdef USE_ITHREADS
void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
#else
/* 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;
void
Perl_op_refcnt_lock(pTHX)
+ PERL_TSA_ACQUIRE(PL_op_mutex)
{
#ifdef USE_ITHREADS
dVAR;
void
Perl_op_refcnt_unlock(pTHX)
+ PERL_TSA_RELEASE(PL_op_mutex)
{
#ifdef USE_ITHREADS
dVAR;
=for apidoc op_sibling_splice
A general function for editing the structure of an existing chain of
-op_sibling nodes. By analogy with the perl-level splice() function, allows
+op_sibling nodes. By analogy with the perl-level C<splice()> function, allows
you to delete zero or more sequential nodes, replacing them with zero or
more different nodes. Performs the necessary op_first/op_last
housekeeping on the parent node and op_sibling manipulation on the
responsibility of the caller. It also won't create a new list op for an
empty list etc; use higher-level functions like op_append_elem() for that.
-parent is the parent node of the sibling chain. It may passed as NULL if
+C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
the splicing doesn't affect the first or last op in the chain.
-start is the node preceding the first node to be spliced. Node(s)
+C<start> is the node preceding the first node to be spliced. Node(s)
following it will be deleted, and ops will be inserted after it. If it is
-NULL, the first node onwards is deleted, and nodes are inserted at the
+C<NULL>, the first node onwards is deleted, and nodes are inserted at the
beginning.
-del_count is the number of nodes to delete. If zero, no nodes are deleted.
+C<del_count> is the number of nodes to delete. If zero, no nodes are deleted.
If -1 or greater than or equal to the number of remaining kids, all
remaining kids are deleted.
-insert is the first of a chain of nodes to be inserted in place of the nodes.
-If NULL, no nodes are inserted.
+C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
+If C<NULL>, no nodes are inserted.
-The head of the chain of deleted ops is returned, or NULL if no ops were
+The head of the chain of deleted ops is returned, or C<NULL> if no ops were
deleted.
For example:
For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
-see C<OpMORESIB_set>, C<OpLASTSIB_set>, C<OpMAYBESIB_set>.
+see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
=cut
*/
/*
=for apidoc op_parent
-Returns the parent OP of o, if it has a parent. Returns NULL otherwise.
+Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
This function is only available on perls built with C<-DPERL_OP_PARENT>.
=cut
* Returns the new UNOP.
*/
-OP *
+STATIC OP *
S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
{
OP *kid, *newop;
*/
LOGOP *
-S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
+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);
}
static SV *
-S_op_varname(pTHX_ const OP *o)
+S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
{
assert(o);
assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
if (cUNOPo->op_first->op_type != OP_GV
|| !(gv = cGVOPx_gv(cUNOPo->op_first)))
return NULL;
- return varname(gv, funny, 0, NULL, 0, 1);
+ return varname(gv, funny, 0, NULL, 0, subscript_type);
}
return
- varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, 1);
+ varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
}
}
+static SV *
+S_op_varname(pTHX_ const OP *o)
+{
+ return S_op_varname_subscript(aTHX_ o, 1);
+}
+
static void
S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
{ /* or not so pretty :-) */
* key_op is the first key
*/
-void
+STATIC void
S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op)
{
PADNAME *lexname;
continue;
svp = cSVOPx_svp(key_op);
+ /* make sure it's not a bareword under strict subs */
+ if (key_op->op_private & OPpCONST_BARE &&
+ key_op->op_private & OPpCONST_STRICT)
+ {
+ no_bareword_allowed((OP*)key_op);
+ }
+
/* Make the CONST have a shared SV */
if ( !SvIsCOW_shared_hash(sv = *svp)
&& SvTYPE(sv) < SVt_PVMG
This function finalizes the optree. Should be called directly after
the complete optree is built. It does some additional
-checking which can't be done in the normal ck_xxx functions and makes
+checking which can't be done in the normal C<ck_>xxx functions and makes
the tree thread-safe.
=cut
Propagate lvalue ("modifiable") context to an op and its children.
C<type> represents the context type, roughly based on the type of op that
-would do the modifying, although C<local()> is represented by OP_NULL,
+would do the modifying, although C<local()> is represented by C<OP_NULL>,
because it has no op type of its own (it is signalled by a flag on
the lvalue op).
This function detects things that can't be modified, such as C<$x+1>, and
generates errors for them. For example, C<$x+1 = 2> would cause it to be
-called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
+called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
It also flags things that need to behave specially in an lvalue context,
such as C<$$x = 5> which might have to vivify a reference in C<$x>.
PadnameLVALUE_on(pn);
while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
cv = CvOUTSIDE(cv);
- assert(cv);
+ /* RT #127786: cv can be NULL due to an eval within the DB package
+ * called from an anon sub - anon subs don't have CvOUTSIDE() set
+ * unless they contain an eval, but calling eval within DB
+ * pretends the eval was done in the caller's scope.
+ */
+ if (!cv)
+ break;
assert(CvPADLIST(cv));
pn =
PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
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;
}
OP *kid = cUNOPo->op_first;
CV *cv;
GV *gv;
+ SV *namesv;
if (kid->op_type != OP_PUSHMARK) {
if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
break;
if (CvLVALUE(cv))
break;
+ if (flags & OP_LVALUE_NO_CROAK)
+ return NULL;
+
+ namesv = cv_name(cv, NULL, 0);
+ yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
+ "subroutine call of &%"SVf" in %s",
+ SVfARG(namesv), PL_op_desc[type]),
+ SvUTF8(namesv));
+ return o;
}
}
/* FALLTHROUGH */
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)
? "do block"
- : (o->op_type == OP_ENTERSUB
- ? "non-lvalue subroutine call"
- : OP_DESC(o))),
+ : OP_DESC(o)),
type ? PL_op_desc[type] : "local"));
return o;
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 &&
((PL_in_eval & EVAL_KEEPERR)
? OPf_SPECIAL : 0), o);
- cx = &cxstack[cxstack_ix];
+ cx = CX_CUR();
assert(CxTYPE(cx) == CXt_EVAL);
if ((cx->blk_gimme & G_WANT) == G_VOID)
s++;
while (1) {
- if (*s && strchr("@$%*", *s) && *++s
+ if (*s && (strchr("@$%", *s) || (!lex && *s == '*'))
+ && *++s
&& (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
s++;
sigil = TRUE;
bool is_stringify;
SV * VOL sv = NULL;
int ret = 0;
- I32 oldscope;
OP *old_next;
SV * const oldwarnhook = PL_warnhook;
SV * const olddiehook = PL_diehook;
COP not_compiling;
U8 oldwarn = PL_dowarn;
+ I32 old_cxix;
dJMPENV;
PERL_ARGS_ASSERT_FOLD_CONSTANTS;
goto nope; /* Don't try to run w/ errors */
for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
- const OPCODE type = curop->op_type;
- if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
- type != OP_LIST &&
- type != OP_SCALAR &&
- type != OP_NULL &&
- type != OP_PUSHMARK)
- {
+ switch (curop->op_type) {
+ case OP_CONST:
+ if ( (curop->op_private & OPpCONST_BARE)
+ && (curop->op_private & OPpCONST_STRICT)) {
+ no_bareword_allowed(curop);
+ goto nope;
+ }
+ /* FALLTHROUGH */
+ case OP_LIST:
+ case OP_SCALAR:
+ case OP_NULL:
+ case OP_PUSHMARK:
+ /* Foldable; move to next op in list */
+ break;
+
+ default:
+ /* No other op types are considered foldable */
goto nope;
}
}
o->op_next = 0;
PL_op = curop;
- oldscope = PL_scopestack_ix;
- create_eval_scope(G_FAKINGEVAL);
+ old_cxix = cxstack_ix;
+ create_eval_scope(NULL, G_FAKINGEVAL);
/* Verify that we don't need to save it: */
assert(PL_curcop == &PL_compiling);
PL_diehook = olddiehook;
PL_curcop = &PL_compiling;
- if (PL_scopestack_ix > oldscope)
- delete_eval_scope();
-
+ /* if we croaked, depending on how we croaked the eval scope
+ * may or may not have already been popped */
+ if (cxstack_ix > old_cxix) {
+ assert(cxstack_ix == old_cxix + 1);
+ assert(CxTYPE(CX_CUR()) == CXt_EVAL);
+ delete_eval_scope();
+ }
if (ret)
goto nope;
For most list operators, the check function expects all the kid ops to be
present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
appropriate. What you want to do in that case is create an op of type
-OP_LIST, append more children to it, and then call L</op_convert_list>.
+C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
See L</op_convert_list> for more information.
/*
=for apidoc newUNOP_AUX
-Similar to C<newUNOP>, but creates an UNOP_AUX struct instead, with op_aux
-initialised to aux
+Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
+initialised to C<aux>
=cut
*/
the bit with value 1 is automatically set. C<dynamic_meth> supplies an
op which evaluates method name; it is consumed by this function and
become part of the constructed op tree.
-Supported optypes: OP_METHOD.
+Supported optypes: C<OP_METHOD>.
=cut
*/
C<op_flags>, and, shifted up eight bits, the eight bits of
C<op_private>. C<const_meth> supplies a constant method name;
it must be a shared COW string.
-Supported optypes: OP_METHOD_NAMED.
+Supported optypes: C<OP_METHOD_NAMED>.
=cut
*/
max = rfirst + diff;
if (!grows)
grows = (tfirst < rfirst &&
- UNISKIP(tfirst) < UNISKIP(rfirst + diff));
+ UVCHR_SKIP(tfirst) < UVCHR_SKIP(rfirst + diff));
rfirst += diff + 1;
}
tfirst += diff + 1;
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 */
/*
=for apidoc Am|OP *|newDEFSVOP|
-Constructs and returns an op to access C<$_>, either as a lexical
-variable (if declared as C<my $_>) in the current scope, or the
-global C<$_>.
+Constructs and returns an op to access C<$_>.
=cut
*/
OP *
Perl_newDEFSVOP(pTHX)
{
- const PADOFFSET offset = pad_findmy_pvs("$_", 0);
- if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
- }
- else {
- OP * const o = newOP(OP_PADSV, 0);
- o->op_targ = offset;
- return o;
- }
}
#ifdef USE_ITHREADS
Loads the module whose name is pointed to by the string part of name.
Note that the actual module name, not its filename, should be given.
Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
-PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
+C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
(or 0 for no flags). ver, if specified
and not NULL, provides version semantics
similar to C<use Foo::Bar VERSION>. The optional trailing SV*
-arguments can be used to specify arguments to the module's import()
+arguments can be used to specify arguments to the module's C<import()>
method, similar to C<use Foo::Bar VERSION LIST>. They must be
-terminated with a final NULL pointer. Note that this list can only
-be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
-Otherwise at least a single NULL pointer to designate the default
+terminated with a final C<NULL> pointer. Note that this list can only
+be omitted when the C<PERL_LOADMOD_NOIMPORT> flag has been used.
+Otherwise at least a single C<NULL> pointer to designate the default
import list is required.
The reference count for each specified C<SV*> parameter is decremented.
|| type == OP_CUSTOM);
scalarboolean(first);
- /* optimize AND and OR ops that have NOTs as children */
- if (first->op_type == OP_NOT
- && (first->op_flags & OPf_KIDS)
- && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
- || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
- ) {
- if (type == OP_AND || type == OP_OR) {
- if (type == OP_AND)
- type = OP_OR;
- else
- type = OP_AND;
- op_null(first);
- if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
- op_null(other);
- prepend_not = 1; /* prepend a NOT op later */
- }
- }
- }
+
/* search for a constant op that could let us fold the test */
if ((cstop = search_const(first))) {
if (cstop->op_private & OPpCONST_STRICT)
if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
(type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
(type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
+ /* Elide the (constant) lhs, since it can't affect the outcome */
*firstp = NULL;
if (other->op_type == OP_CONST)
other->op_private |= OPpCONST_SHORTCIRCUIT;
return other;
}
else {
+ /* Elide the rhs, since the outcome is entirely determined by
+ * the (constant) lhs */
+
/* check for C<my $x if 0>, or C<my($x,$y) if 0> */
const OP *o2 = other;
if ( ! (o2->op_type == OP_LIST
*otherp = NULL;
if (cstop->op_type == OP_CONST)
cstop->op_private |= OPpCONST_SHORTCIRCUIT;
- op_free(other);
+ op_free(other);
return first;
}
}
}
}
- if (!other)
- return first;
-
if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
- logop = S_alloc_LOGOP(aTHX_ type, first, LINKLIST(other));
+ /* optimize AND and OR ops that have NOTs as children */
+ if (first->op_type == OP_NOT
+ && (first->op_flags & OPf_KIDS)
+ && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
+ || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
+ ) {
+ if (type == OP_AND || type == OP_OR) {
+ if (type == OP_AND)
+ type = OP_OR;
+ else
+ type = OP_AND;
+ op_null(first);
+ if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
+ op_null(other);
+ prepend_not = 1; /* prepend a NOT op later */
+ }
+ }
+ }
+
+ 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));
o->op_flags |= flags;
o = op_scope(o);
- o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
+ o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
return o;
}
with structure that allows exiting the loop by C<last> and suchlike.
C<sv> optionally supplies the variable that will be aliased to each
-item in turn; if null, it defaults to C<$_> (either lexical or global).
+item in turn; if null, it defaults to C<$_>.
C<expr> supplies the list of values to iterate over. C<block> supplies
the main body of the loop, and C<cont> optionally supplies a C<continue>
block that operates as a second half of the body. All of these optree
}
}
else {
- const PADOFFSET offset = pad_findmy_pvs("$_", 0);
- if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
- sv = newGVOP(OP_GV, 0, PL_defgv);
- }
- else {
- padoff = offset;
- }
+ sv = newGVOP(OP_GV, 0, PL_defgv);
iterpflags |= OPpITER_DEF;
}
OP *o;
PERL_ARGS_ASSERT_NEWGIVWHENOP;
+ PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
- enterop = S_alloc_LOGOP(aTHX_ enter_opcode, block, NULL);
- enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
+ enterop = alloc_LOGOP(enter_opcode, block, NULL);
+ enterop->op_targ = 0;
enterop->op_private = 0;
o = newUNOP(leave_opcode, 0, (OP *) enterop);
C<cond> supplies the expression that will be locally assigned to a lexical
variable, and C<block> supplies the body of the C<given> construct; they
are consumed by this function and become part of the constructed op tree.
-C<defsv_off> is the pad offset of the scalar lexical variable that will
-be affected. If it is 0, the global $_ will be used.
+C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
=cut
*/
Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
{
PERL_ARGS_ASSERT_NEWGIVENOP;
+ PERL_UNUSED_ARG(defsv_off);
+
+ assert(!defsv_off);
return newGIVWHENOP(
ref_array_or_hash(cond),
block,
OP_ENTERGIVEN, OP_LEAVEGIVEN,
- defsv_off);
+ 0);
}
/*
=for apidoc cv_const_sv
If C<cv> is a constant sub eligible for inlining, returns the constant
-value returned by the sub. Otherwise, returns NULL.
+value returned by the sub. Otherwise, returns C<NULL>.
Constant subs can be created with C<newCONSTSUB> or as described in
L<perlsub/"Constant Functions">.
: NULL;
if (block) {
+ assert(PL_parser);
/* This makes sub {}; work as expected. */
if (block->op_type == OP_STUB) {
const line_t l = PL_parser->copline;
block->op_next = 0;
if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
const_sv =
- S_op_const_sv(aTHX_ start, PL_compcv, CvCLONE(PL_compcv));
+ S_op_const_sv(aTHX_ start, PL_compcv,
+ cBOOL(CvCLONE(PL_compcv)));
else
const_sv = NULL;
}
const_sv = NULL;
if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
- assert (block);
cv_ckproto_len_flags((const CV *)gv,
o ? (const GV *)cSVOPo->op_sv : NULL, ps,
ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
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);
/*
=for apidoc newCONSTSUB_flags
-Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
+Creates a constant sub equivalent to Perl S<C<sub FOO () { 123 }>> which is
eligible for inlining at compile-time.
-Currently, the only useful value for C<flags> is SVf_UTF8.
+Currently, the only useful value for C<flags> is C<SVf_UTF8>.
The newly created subroutine takes ownership of a reference to the passed in
SV.
-Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
+Passing C<NULL> for SV creates a constant sub equivalent to S<C<sub BAR () {}>>,
which won't be called if used as a destructor, but will suppress the overhead
of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
compile time.)
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;
op_free(o);
return newop;
}
+
+ if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
+ SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
+ if (name) {
+ /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
+ array_passed_to_stat, name);
+ }
+ else {
+ /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
+ }
+ }
+ scalar((OP *) kid);
if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
o->op_private |= OPpFT_ACCESS;
if (type != OP_STAT && type != OP_LSTAT
LOGOP *gwop;
OP *kid;
const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
- PADOFFSET offset;
PERL_ARGS_ASSERT_CK_GREP;
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;
- offset = pad_findmy_pvs("$_", 0);
- if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
- o->op_private = gwop->op_private = 0;
- gwop->op_targ = pad_alloc(type, SVs_PADTMP);
- }
- else {
- o->op_private = gwop->op_private = OPpGREP_LEX;
- gwop->op_targ = o->op_targ = offset;
- }
+ o->op_private = gwop->op_private = 0;
+ gwop->op_targ = pad_alloc(type, SVs_PADTMP);
kid = OpSIBLING(cLISTOPo->op_first);
for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
OP *
Perl_ck_match(pTHX_ OP *o)
{
+ PERL_UNUSED_CONTEXT;
PERL_ARGS_ASSERT_CK_MATCH;
- if (o->op_type != OP_QR && PL_compcv) {
- const PADOFFSET offset = pad_findmy_pvs("$_", 0);
- if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
- o->op_targ = offset;
- o->op_private |= OPpTARGET_MY;
- }
- }
if (o->op_type == OP_MATCH || o->op_type == OP_QR)
o->op_private |= OPpRUNTIME;
return o;
s = SvPVX(sv);
len = SvCUR(sv);
end = s + len;
+ /* treat ::foo::bar as foo::bar */
+ if (len >= 2 && s[0] == ':' && s[1] == ':')
+ DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
+ if (s == end)
+ DIE(aTHX_ "Bareword in require maps to empty filename");
+
for (; s < end; s++) {
if (*s == ':' && s[1] == ':') {
*s = '/';
Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
{
OP *aop;
+
PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
+
aop = cUNOPx(entersubop)->op_first;
if (!OpHAS_SIBLING(aop))
aop = cUNOPx(aop)->op_first;
for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
+ /* skip the extra attributes->import() call implicitly added in
+ * something like foo(my $x : bar)
+ */
+ if ( aop->op_type == OP_ENTERSUB
+ && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
+ )
+ continue;
list(aop);
op_lvalue(aop, OP_ENTERSUB);
}
|| ( 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);
that's flagged OA_DANGEROUS */
AAS_SAFE_SCALAR = 0x100, /* produces at least one scalar SV that's
not in any of the categories above */
- AAS_DEFAV = 0x200, /* contains just a single '@_' on RHS */
+ AAS_DEFAV = 0x200 /* contains just a single '@_' on RHS */
};
break;
case OP_UNDEF:
+ /* undef counts as a scalar on the RHS:
+ * (undef, $x) = ...; # only 1 scalar on LHS: always safe
+ * ($x, $y) = (undef, $x); # 2 scalars on RHS: unsafe
+ */
+ if (rhs)
+ (*scalars_p)++;
+ flags = AAS_SAFE_SCALAR;
+ break;
+
case OP_PUSHMARK:
case OP_STUB:
/* these are all no-ops; they don't push a potentially common SV
default:
if (PL_opargs[o->op_type] & OA_DANGEROUS) {
(*scalars_p) += 2;
- return AAS_DANGEROUS;
+ flags = AAS_DANGEROUS;
+ break;
}
if ( (PL_opargs[o->op_type] & OA_TARGLEX)
* OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
*/
-void
+STATIC void
S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
{
dVAR;
is_last = TRUE;
index_skip = action_count;
action |= MDEREF_FLAG_last;
+ if (index_type != MDEREF_INDEX_none)
+ arg--;
}
if (pass)
}
redo:
+
+ /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
+ assert(!oldoldop || oldoldop->op_next == oldop);
+ assert(!oldop || oldop->op_next == o);
+
/* By default, this op has now been optimised. A couple of cases below
clear this again. */
o->op_opt = 1;
op_null(o);
if (oldop)
oldop->op_next = nextop;
+ o = nextop;
/* Skip (old)oldop assignment since the current oldop's
op_next already points to the next op. */
- continue;
+ goto redo;
}
}
break;
/* 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 */
/* Note that you'd normally expect targs to be
* contiguous in my($a,$b,$c), but that's not the case
* when external modules start doing things, e.g.
- i* Function::Parameters */
+ * Function::Parameters */
if (p->op_targ != base + count)
break;
assert(p->op_targ == base + count);
break;
/* there's a biggest base we can fit into a
- * SAVEt_CLEARPADRANGE in pp_padrange */
- if (intro && base >
- (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)))
+ * SAVEt_CLEARPADRANGE in pp_padrange.
+ * (The sizeof() stuff will be constant-folded, and is
+ * intended to avoid getting "comparison is always false"
+ * compiler warnings. See the comments above
+ * MEM_WRAP_CHECK for more explanation on why we do this
+ * in a weird way to avoid compiler warnings.)
+ */
+ if ( intro
+ && (8*sizeof(base) >
+ 8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
+ ? base
+ : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
+ ) >
+ (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
+ )
break;
/* Success! We've got another valid pad op to optimise away */
* optimise away would have exactly the same effect as the
* padrange.
* In particular in void context, we can only optimise to
- * a padrange if see see the complete sequence
+ * a padrange if we see the complete sequence
* pushmark, pad*v, ...., list
- * which has the net effect of of leaving the markstack as it
- * was. Not pushing on to the stack (whereas padsv does touch
+ * which has the net effect of leaving the markstack as it
+ * was. Not pushing onto the stack (whereas padsv does touch
* the stack) makes no difference in void context.
*/
assert(followop);
oldoldop = NULL;
goto redo;
}
- o = oldop;
+ o = oldop->op_next;
+ goto redo;
}
else if (o->op_next->op_type == OP_RV2SV) {
if (!(o->op_next->op_private & OPpDEREF)) {
|| o->op_next->op_type == OP_NULL))
o->op_next = o->op_next->op_next;
- /* if we're an OR and our next is a AND in void context, we'll
- follow it's op_other on short circuit, same for reverse.
+ /* If we're an OR and our next is an AND in void context, we'll
+ follow its op_other on short circuit, same for reverse.
We can't do this with OP_DOR since if it's true, its return
value is the underlying value which must be evaluated
- by the next op */
+ by the next op. */
if (o->op_next &&
(
(IS_AND_OP(o) && IS_OR_OP(o->op_next))
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);
op_null(o);
enter->op_private |= OPpITER_REVERSED;
iter->op_private |= OPpITER_REVERSED;
+
+ oldoldop = NULL;
+ oldop = ourlast;
+ o = oldop->op_next;
+ goto redo;
break;
}
|| !r /* .... = (); */
|| !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
|| !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
- || (lscalars < 2) /* ($x) = ... */
+ || (lscalars < 2) /* ($x, undef) = ... */
) {
NOOP; /* always safe */
}
/* ... = ($x)
* may have to handle aggregate on LHS, but we can't
- * have common scalars*/
+ * have common scalars. */
if (rscalars < 2)
o->op_private &=
~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
=for apidoc Ao||custom_op_xop
Return the XOP structure for a given custom op. This macro should be
-considered internal to OP_NAME and the other access macros: use them instead.
+considered internal to C<OP_NAME> and the other access macros: use them instead.
This macro does call a function. Prior
to 5.19.6, this was implemented as a
function.
}
}
}
- /* Some gcc releases emit a warning for this function:
+ /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
* op.c: In function 'Perl_custom_op_get_field':
* op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
- * Whether this is true, is currently unknown. */
+ * This is because on those platforms (with -DEBUGGING) NOT_REACHED
+ * expands to assert(0), which expands to ((0) ? (void)0 :
+ * __assert(...)), and gcc doesn't know that __assert can never return. */
return any;
}
}
=for apidoc core_prototype
This function assigns the prototype of the named core function to C<sv>, or
-to a new mortal SV if C<sv> is NULL. It returns the modified C<sv>, or
-NULL if the core function has no prototype. C<code> is a code as returned
+to a new mortal SV if C<sv> is C<NULL>. It returns the modified C<sv>, or
+C<NULL> if the core function has no prototype. C<code> is a code as returned
by C<keyword()>. It must not be equal to 0.
=cut
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