/* op.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
* is made, called opmini.c.
*/
+/*
+Perl's compiler is essentially a 3-pass compiler with interleaved phases:
+
+ A bottom-up pass
+ A top-down pass
+ An execution-order pass
+
+The bottom-up pass is represented by all the "newOP" routines and
+the ck_ routines. The bottom-upness is actually driven by yacc.
+So at the point that a ck_ routine fires, we have no idea what the
+context is, either upward in the syntax tree, or either forward or
+backward in the execution order. (The bottom-up parser builds that
+part of the execution order it knows about, but if you follow the "next"
+links around, you'll find it's actually a closed loop through the
+top level node.
+
+Whenever the bottom-up parser gets to a node that supplies context to
+its components, it invokes that portion of the top-down pass that applies
+to that part of the subtree (and marks the top node as processed, so
+if a node further up supplies context, it doesn't have to take the
+plunge again). As a particular subcase of this, as the new node is
+built, it takes all the closed execution loops of its subcomponents
+and links them into a new closed loop for the higher level node. But
+it's still not the real execution order.
+
+The actual execution order is not known till we get a grammar reduction
+to a top-level unit like a subroutine or file that will be called by
+"name" rather than via a "next" pointer. At that point, we can call
+into peep() to do that code's portion of the 3rd pass. It has to be
+recursive, but it's recursive on basic blocks, not on tree nodes.
+*/
+
#include "EXTERN.h"
#define PERL_IN_OP_C
#include "perl.h"
off = pad_add_name(name,
PL_in_my_stash,
(PL_in_my == KEY_our
- ? (PL_curstash ? PL_curstash : PL_defstash)
+ /* $_ is always in main::, even with our */
+ ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
: Nullhv
),
0 /* not fake */
{
register OP *kid, *nextkid;
OPCODE type;
+ PADOFFSET refcnt;
if (!o || o->op_static)
return;
case OP_SCOPE:
case OP_LEAVEWRITE:
OP_REFCNT_LOCK;
- if (OpREFCNT_dec(o)) {
- OP_REFCNT_UNLOCK;
- return;
- }
+ refcnt = OpREFCNT_dec(o);
OP_REFCNT_UNLOCK;
+ if (refcnt)
+ return;
break;
default:
break;
o->op_ppaddr = PL_ppaddr[OP_NULL];
}
+void
+Perl_op_refcnt_lock(pTHX)
+{
+ OP_REFCNT_LOCK;
+}
+
+void
+Perl_op_refcnt_unlock(pTHX)
+{
+ OP_REFCNT_UNLOCK;
+}
+
/* Contextualizers */
#define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
}
else
return bind_match(type, left,
- pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
+ pmruntime(newPMOP(OP_MATCH, 0), right, 0));
}
OP *
*/
if (complement) {
- U8 tmpbuf[UTF8_MAXLEN+1];
+ U8 tmpbuf[UTF8_MAXBYTES+1];
UV *cp;
UV nextmin = 0;
New(1109, cp, 2*tlen, UV);
return CHECKOP(type, pmop);
}
+/* Given some sort of match op o, and an expression expr containing a
+ * pattern, either compile expr into a regex and attach it to o (if it's
+ * constant), or convert expr into a runtime regcomp op sequence (if it's
+ * not)
+ *
+ * isreg indicates that the pattern is part of a regex construct, eg
+ * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
+ * split "pattern", which aren't. In the former case, expr will be a list
+ * if the pattern contains more than one term (eg /a$b/) or if it contains
+ * a replacement, ie s/// or tr///.
+ */
+
OP *
-Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
+Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
{
PMOP *pm;
LOGOP *rcop;
I32 repl_has_vars = 0;
+ OP* repl = Nullop;
+ bool reglist;
+
+ if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
+ /* last element in list is the replacement; pop it */
+ OP* kid;
+ repl = cLISTOPx(expr)->op_last;
+ kid = cLISTOPx(expr)->op_first;
+ while (kid->op_sibling != repl)
+ kid = kid->op_sibling;
+ kid->op_sibling = Nullop;
+ cLISTOPx(expr)->op_last = kid;
+ }
+
+ if (isreg && expr->op_type == OP_LIST &&
+ cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
+ {
+ /* convert single element list to element */
+ OP* oe = expr;
+ expr = cLISTOPx(oe)->op_first->op_sibling;
+ cLISTOPx(oe)->op_first->op_sibling = Nullop;
+ cLISTOPx(oe)->op_last = Nullop;
+ op_free(oe);
+ }
- if (o->op_type == OP_TRANS)
+ if (o->op_type == OP_TRANS) {
return pmtrans(o, expr, repl);
+ }
+
+ reglist = isreg && expr->op_type == OP_LIST;
+ if (reglist)
+ op_null(expr);
PL_hints |= HINT_BLOCK_SCOPE;
pm = (PMOP*)o;
STRLEN plen;
SV *pat = ((SVOP*)expr)->op_sv;
char *p = SvPV(pat, plen);
- if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
+ if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
sv_setpvn(pat, "\\s+", 3);
p = SvPV(pat, plen);
pm->op_pmflags |= PMf_SKIPWHITE;
rcop->op_type = OP_REGCOMP;
rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
rcop->op_first = scalar(expr);
- rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
- ? (OPf_SPECIAL | OPf_KIDS)
- : OPf_KIDS);
+ rcop->op_flags |= OPf_KIDS
+ | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
+ | (reglist ? OPf_STACKED : 0);
rcop->op_private = 1;
rcop->op_other = o;
+ if (reglist)
+ rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
+
/* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
PL_cv_has_eval = 1;
}
void
-Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
+Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
{
if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
SV* msg = sv_newmortal();
if (SvPOK(cv))
Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv);
else
- Perl_sv_catpvf(aTHX_ msg, ": none");
+ Perl_sv_catpv(aTHX_ msg, ": none");
sv_catpv(msg, " vs ");
if (p)
Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
}
else
aname = Nullch;
- gv = gv_fetchpv(name ? name : (aname ? aname :
- (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
- GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
- SVt_PVCV);
+ gv = name ? gv_fetchsv(cSVOPo->op_sv,
+ GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
+ SVt_PVCV)
+ : gv_fetchpv(aname ? aname
+ : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
+ GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
+ SVt_PVCV);
if (o)
SAVEFREEOP(o);
Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
{
register CV *cv;
- char *name;
GV *gv;
- STRLEN n_a;
if (o)
- name = SvPVx(cSVOPo->op_sv, n_a);
+ gv = gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM);
else
- name = "STDOUT";
- gv = gv_fetchpv(name,TRUE, SVt_PVFM);
+ gv = gv_fetchpv("STDOUT", TRUE, SVt_PVFM);
+
#ifdef GV_UNIQUE_CHECK
if (GvUNIQUE(gv)) {
Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
line_t oldline = CopLINE(PL_curcop);
if (PL_copline != NOLINE)
CopLINE_set(PL_curcop, PL_copline);
- Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
+ Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
+ o ? "Format %"SVf" redefined"
+ : "Format STDOUT redefined" ,cSVOPo->op_sv);
CopLINE_set(PL_curcop, oldline);
}
SvREFCNT_dec(cv);
return newUNOP(OP_RV2SV, 0, scalar(o));
}
-/* Check routines. */
+/* Check routines. See the comments at the top of this file for details
+ * on when these are called */
OP *
Perl_ck_anoncode(pTHX_ OP *o)
o->op_private |= (PL_hints & HINT_STRICT_REFS);
if (kid->op_type == OP_CONST) {
- char *name;
int iscv;
GV *gv;
SV *kidsv = kid->op_sv;
- STRLEN n_a;
/* Is it a constant from cv_const_sv()? */
if (SvROK(kidsv) && SvREADONLY(kidsv)) {
Perl_croak(aTHX_ "Constant is not %s reference", badtype);
return o;
}
- name = SvPV(kidsv, n_a);
if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
char *badthing = Nullch;
switch (o->op_type) {
}
if (badthing)
Perl_croak(aTHX_
- "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
- name, badthing);
+ "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
+ kidsv, badthing);
}
/*
* This is a little tricky. We only want to add the symbol if we
*/
iscv = (o->op_type == OP_RV2CV) * 2;
do {
- gv = gv_fetchpv(name,
+ gv = gv_fetchsv(kidsv,
iscv | !(kid->op_private & OPpCONST_ENTERED),
iscv
? SVt_PVCV
SVOP *kid = (SVOP*)cUNOPo->op_first;
if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
- STRLEN n_a;
OP *newop = newGVOP(type, OPf_REF,
- gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
+ gv_fetchsv(kid->op_sv, TRUE, SVt_PVIO));
op_free(o);
o = newop;
return o;
}
if (o->op_flags & OPf_KIDS) {
- STRLEN n_a;
tokid = &cLISTOPo->op_first;
kid = cLISTOPo->op_first;
if (kid->op_type == OP_PUSHMARK ||
if (kid->op_type == OP_CONST &&
(kid->op_private & OPpCONST_BARE))
{
- char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
OP *newop = newAVREF(newGVOP(OP_GV, 0,
- gv_fetchpv(name, TRUE, SVt_PVAV) ));
+ gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVAV) ));
if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
- "Array @%s missing the @ in argument %"IVdf" of %s()",
- name, (IV)numargs, PL_op_desc[type]);
+ "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
+ ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
op_free(kid);
kid = newop;
kid->op_sibling = sibl;
if (kid->op_type == OP_CONST &&
(kid->op_private & OPpCONST_BARE))
{
- char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
OP *newop = newHVREF(newGVOP(OP_GV, 0,
- gv_fetchpv(name, TRUE, SVt_PVHV) ));
+ gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVHV) ));
if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
- "Hash %%%s missing the %% in argument %"IVdf" of %s()",
- name, (IV)numargs, PL_op_desc[type]);
+ "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
+ ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
op_free(kid);
kid = newop;
kid->op_sibling = sibl;
(kid->op_private & OPpCONST_BARE))
{
OP *newop = newGVOP(OP_GV, 0,
- gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
- SVt_PVIO) );
+ gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVIO) );
if (!(o->op_private & 1) && /* if not unop */
kid == cLISTOPo->op_last)
cLISTOPo->op_last = newop;
OP *k;
int descending;
GV *gv;
+ const char *gvname;
if (!(o->op_flags & OPf_STACKED))
return;
GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
gv = kGVOP_gv;
if (GvSTASH(gv) != PL_curstash)
return;
- if (strEQ(GvNAME(gv), "a"))
+ gvname = GvNAME(gv);
+ if (*gvname == 'a' && gvname[1] == '\0')
descending = 0;
- else if (strEQ(GvNAME(gv), "b"))
+ else if (*gvname == 'b' && gvname[1] == '\0')
descending = 1;
else
return;
return;
kid = kUNOP->op_first; /* get past rv2sv */
gv = kGVOP_gv;
- if (GvSTASH(gv) != PL_curstash
- || ( descending
- ? strNE(GvNAME(gv), "a")
- : strNE(GvNAME(gv), "b")))
+ if (GvSTASH(gv) != PL_curstash)
+ return;
+ gvname = GvNAME(gv);
+ if ( descending
+ ? !(*gvname == 'a' && gvname[1] == '\0')
+ : !(*gvname == 'b' && gvname[1] == '\0'))
return;
o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
if (descending)
if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
OP *sibl = kid->op_sibling;
kid->op_sibling = 0;
- kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
+ kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
if (cLISTOPo->op_first == cLISTOPo->op_last)
cLISTOPo->op_last = kid;
cLISTOPo->op_first = kid;
OP *sibling = o2->op_sibling;
SV *n = newSVpvn("",0);
op_free(o2);
- gv_fullname3(n, gv, "");
- if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
- sv_chop(n, SvPVX(n)+6);
+ gv_fullname4(n, gv, "", FALSE);
o2 = newSVOP(OP_CONST, 0, n);
prev->op_sibling = o2;
o2->op_sibling = sibling;
return o;
}
-/* A peephole optimizer. We visit the ops in the order they're to execute. */
+/* A peephole optimizer. We visit the ops in the order they're to execute.
+ * See the comments at the top of this file for more details about when
+ * peep() is called */
void
Perl_peep(pTHX_ register OP *o)
projects / p5sagit/p5-mst-13.2.git / blobdiff