#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
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;
* being spread throughout this file.
*/
-LOGOP *
+STATIC LOGOP *
S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
{
dVAR;
}
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)];
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 */
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;
((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;
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;
/*
=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.
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->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);
/*
=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.)
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;
gwop = S_alloc_LOGOP(aTHX_ 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);
}
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 */
};
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;
}
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;
/* 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))
op_null(o);
enter->op_private |= OPpITER_REVERSED;
iter->op_private |= OPpITER_REVERSED;
+
+ oldoldop = NULL;
+ oldop = ourlast;
+ o = oldop->op_next;
+ goto redo;
break;
}
=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
https://perl5.git.perl.org / perl5.git / blobdiff