X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/2304df62caa7d9be70e8b8bcdb454e139c9c103d..324aa91a3e6fd44523a86df7c5575563c5adf45c:/op.c diff --git a/op.c b/op.c index 86a870e..cf78f86 100644 --- a/op.c +++ b/op.c @@ -1,99 +1,149 @@ -/* $RCSfile: cmd.h,v $$Revision: 4.1 $$Date: 92/08/07 17:19:19 $ +/* op.c * - * Copyright (c) 1991, Larry Wall + * Copyright (c) 1991-1997, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * - * $Log: cmd.h,v $ + */ + +/* + * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was + * our Mr. Bilbo's first cousin on the mother's side (her mother being the + * youngest of the Old Took's daughters); and Mr. Drogo was his second + * cousin. So Mr. Frodo is his first *and* second cousin, once removed + * either way, as the saying is, if you follow me." --the Gaffer */ #include "EXTERN.h" #include "perl.h" -/* Lowest byte of opargs */ -#define OA_MARK 1 -#define OA_FOLDCONST 2 -#define OA_RETSCALAR 4 -#define OA_TARGET 8 -#define OA_RETINTEGER 16 -#define OA_OTHERINT 32 -#define OA_DANGEROUS 64 - -/* Remaining nybbles of opargs */ -#define OA_SCALAR 1 -#define OA_LIST 2 -#define OA_AVREF 3 -#define OA_HVREF 4 -#define OA_CVREF 5 -#define OA_FILEREF 6 -#define OA_SCALARREF 7 -#define OA_OPTIONAL 8 +#define USE_OP_MASK /* Turned on by default in 5.002beta1h */ -void -cpy7bit(d,s,l) -register char *d; -register char *s; -register I32 l; +#ifdef USE_OP_MASK +/* + * In the following definition, the ", (OP *) op" is just to make the compiler + * think the expression is of the right type: croak actually does a Siglongjmp. + */ +#define CHECKOP(type,op) \ + ((op_mask && op_mask[type]) \ + ? ( op_free((OP*)op), \ + croak("%s trapped by operation mask", op_desc[type]), \ + Nullop ) \ + : (*check[type])((OP*)op)) +#else +#define CHECKOP(type,op) (*check[type])(op) +#endif /* USE_OP_MASK */ + +static I32 list_assignment _((OP *op)); +static OP *bad_type _((I32 n, char *t, char *name, OP *kid)); +static OP *modkids _((OP *op, I32 type)); +static OP *no_fh_allowed _((OP *op)); +static bool scalar_mod_type _((OP *op, I32 type)); +static OP *scalarboolean _((OP *op)); +static OP *too_few_arguments _((OP *op, char* name)); +static OP *too_many_arguments _((OP *op, char* name)); +static void null _((OP* op)); +static PADOFFSET pad_findlex _((char* name, PADOFFSET newoff, U32 seq, + CV* startcv, I32 cx_ix)); + +static char* +gv_ename(gv) +GV* gv; { - while (l--) - *d++ = *s++ & 127; - *d = '\0'; + SV* tmpsv = sv_newmortal(); + gv_efullname3(tmpsv, gv, Nullch); + return SvPV(tmpsv,na); } static OP * no_fh_allowed(op) OP *op; { - sprintf(tokenbuf,"Missing comma after first argument to %s function", - op_name[op->op_type]); - yyerror(tokenbuf); + yyerror(form("Missing comma after first argument to %s function", + op_desc[op->op_type])); return op; } static OP * -too_few_arguments(op) -OP *op; +too_few_arguments(op, name) +OP* op; +char* name; { - sprintf(tokenbuf,"Not enough arguments for %s", op_name[op->op_type]); - yyerror(tokenbuf); + yyerror(form("Not enough arguments for %s", name)); return op; } static OP * -too_many_arguments(op) +too_many_arguments(op, name) OP *op; +char* name; { - sprintf(tokenbuf,"Too many arguments for %s", op_name[op->op_type]); - yyerror(tokenbuf); + yyerror(form("Too many arguments for %s", name)); return op; } static OP * -bad_type(n, t, op, kid) +bad_type(n, t, name, kid) I32 n; char *t; -OP *op; +char *name; OP *kid; { - sprintf(tokenbuf, "Type of arg %d to %s must be %s (not %s)", - n, op_name[op->op_type], t, op_name[kid->op_type]); - yyerror(tokenbuf); + yyerror(form("Type of arg %d to %s must be %s (not %s)", + (int)n, name, t, op_desc[kid->op_type])); return op; } +void +assertref(op) +OP *op; +{ + int type = op->op_type; + if (type != OP_AELEM && type != OP_HELEM) { + yyerror(form("Can't use subscript on %s", op_desc[type])); + if (type == OP_ENTERSUB || type == OP_RV2HV || type == OP_PADHV) + warn("(Did you mean $ or @ instead of %c?)\n", + type == OP_ENTERSUB ? '&' : '%'); + } +} + /* "register" allocation */ PADOFFSET pad_allocmy(name) char *name; { - PADOFFSET off = pad_alloc(OP_PADSV, SVs_PADMY); - SV *sv = NEWSV(0,0); + PADOFFSET off; + SV *sv; + + if (!(isALPHA(name[1]) || name[1] == '_' && (int)strlen(name) > 2)) { + if (!isPRINT(name[1])) { + name[3] = '\0'; + name[2] = toCTRL(name[1]); + name[1] = '^'; + } + croak("Can't use global %s in \"my\"",name); + } + if (AvFILL(comppad_name) >= 0) { + SV **svp = AvARRAY(comppad_name); + for (off = AvFILL(comppad_name); off > comppad_name_floor; off--) { + if ((sv = svp[off]) + && sv != &sv_undef + && SvIVX(sv) == 999999999 /* var is in open scope */ + && strEQ(name, SvPVX(sv))) + { + warn("\"my\" variable %s masks earlier declaration in same scope", name); + break; + } + } + } + off = pad_alloc(OP_PADSV, SVs_PADMY); + sv = NEWSV(1102,0); sv_upgrade(sv, SVt_PVNV); sv_setpv(sv, name); av_store(comppad_name, off, sv); - SvNVX(sv) = (double)cop_seqmax; + SvNVX(sv) = (double)999999999; SvIVX(sv) = 0; /* Not yet introduced--see newSTATEOP */ if (!min_intro_pending) min_intro_pending = off; @@ -106,29 +156,97 @@ char *name; return off; } -PADOFFSET -pad_findmy(name) +static PADOFFSET +#ifndef CAN_PROTOTYPE +pad_findlex(name, newoff, seq, startcv, cx_ix) char *name; +PADOFFSET newoff; +U32 seq; +CV* startcv; +I32 cx_ix; +#else +pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix) +#endif { + CV *cv; I32 off; SV *sv; - SV **svp = AvARRAY(comppad_name); register I32 i; register CONTEXT *cx; - bool saweval; - AV *curlist; - AV *curname; - CV *cv; - I32 seq = cop_seqmax; + int saweval; - /* The one we're looking for is probably just before comppad_name_fill. */ - for (off = comppad_name_fill; off > 0; off--) { - if ((sv = svp[off]) && - seq <= SvIVX(sv) && - seq > (I32)SvNVX(sv) && - strEQ(SvPVX(sv), name)) - { - return (PADOFFSET)off; + for (cv = startcv; cv; cv = CvOUTSIDE(cv)) { + AV *curlist = CvPADLIST(cv); + SV **svp = av_fetch(curlist, 0, FALSE); + AV *curname; + + if (!svp || *svp == &sv_undef) + continue; + curname = (AV*)*svp; + svp = AvARRAY(curname); + for (off = AvFILL(curname); off > 0; off--) { + if ((sv = svp[off]) && + sv != &sv_undef && + seq <= SvIVX(sv) && + seq > I_32(SvNVX(sv)) && + strEQ(SvPVX(sv), name)) + { + I32 depth; + AV *oldpad; + SV *oldsv; + + depth = CvDEPTH(cv); + if (!depth) { + if (newoff) { + if (SvFAKE(sv)) + continue; + return 0; /* don't clone from inactive stack frame */ + } + depth = 1; + } + oldpad = (AV*)*av_fetch(curlist, depth, FALSE); + oldsv = *av_fetch(oldpad, off, TRUE); + if (!newoff) { /* Not a mere clone operation. */ + SV *namesv = NEWSV(1103,0); + newoff = pad_alloc(OP_PADSV, SVs_PADMY); + sv_upgrade(namesv, SVt_PVNV); + sv_setpv(namesv, name); + av_store(comppad_name, newoff, namesv); + SvNVX(namesv) = (double)curcop->cop_seq; + SvIVX(namesv) = 999999999; /* A ref, intro immediately */ + SvFAKE_on(namesv); /* A ref, not a real var */ + if (CvANON(compcv) || SvTYPE(compcv) == SVt_PVFM) { + /* "It's closures all the way down." */ + CvCLONE_on(compcv); + if (cv == startcv) { + if (CvANON(compcv)) + oldsv = Nullsv; /* no need to keep ref */ + } + else { + CV *bcv; + for (bcv = startcv; + bcv && bcv != cv && !CvCLONE(bcv); + bcv = CvOUTSIDE(bcv)) { + if (CvANON(bcv)) + CvCLONE_on(bcv); + else { + if (dowarn && !CvUNIQUE(cv)) + warn( + "Variable \"%s\" may be unavailable", + name); + break; + } + } + } + } + else if (!CvUNIQUE(compcv)) { + if (dowarn && !SvFAKE(sv) && !CvUNIQUE(cv)) + warn("Variable \"%s\" will not stay shared", name); + } + } + av_store(comppad, newoff, SvREFCNT_inc(oldsv)); + return newoff; + } } } @@ -137,48 +255,76 @@ char *name; * XXX This will also probably interact badly with eval tree caching. */ - saweval = FALSE; - for (i = cxstack_ix; i >= 0; i--) { + saweval = 0; + for (i = cx_ix; i >= 0; i--) { cx = &cxstack[i]; switch (cx->cx_type) { default: + if (i == 0 && saweval) { + seq = cxstack[saweval].blk_oldcop->cop_seq; + return pad_findlex(name, newoff, seq, main_cv, 0); + } break; case CXt_EVAL: - saweval = TRUE; + switch (cx->blk_eval.old_op_type) { + case OP_ENTEREVAL: + saweval = i; + break; + case OP_REQUIRE: + /* require must have its own scope */ + return 0; + } break; case CXt_SUB: if (!saweval) return 0; cv = cx->blk_sub.cv; - if (debstash && CvSTASH(cv) == debstash) /* ignore DB'* scope */ + if (debstash && CvSTASH(cv) == debstash) { /* ignore DB'* scope */ + saweval = i; /* so we know where we were called from */ continue; - seq = cxstack[i+1].blk_oldcop->cop_seq; - curlist = CvPADLIST(cv); - curname = (AV*)*av_fetch(curlist, 0, FALSE); - svp = AvARRAY(curname); - for (off = AvFILL(curname); off > 0; off--) { - if ((sv = svp[off]) && - seq <= SvIVX(sv) && - seq > (I32)SvNVX(sv) && - strEQ(SvPVX(sv), name)) - { - PADOFFSET newoff = pad_alloc(OP_PADSV, SVs_PADMY); - AV *oldpad = (AV*)*av_fetch(curlist, CvDEPTH(cv), FALSE); - SV *oldsv = *av_fetch(oldpad, off, TRUE); - SV *sv = NEWSV(0,0); - sv_upgrade(sv, SVt_PVNV); - sv_setpv(sv, name); - av_store(comppad_name, newoff, sv); - SvNVX(sv) = (double)curcop->cop_seq; - SvIVX(sv) = 999999999; /* A ref, intro immediately */ - av_store(comppad, newoff, SvREFCNT_inc(oldsv)); - return newoff; - } } - return 0; + seq = cxstack[saweval].blk_oldcop->cop_seq; + return pad_findlex(name, newoff, seq, cv, i-1); + } + } + + return 0; +} + +PADOFFSET +pad_findmy(name) +char *name; +{ + I32 off; + I32 pendoff = 0; + SV *sv; + SV **svp = AvARRAY(comppad_name); + U32 seq = cop_seqmax; + + /* The one we're looking for is probably just before comppad_name_fill. */ + for (off = AvFILL(comppad_name); off > 0; off--) { + if ((sv = svp[off]) && + sv != &sv_undef && + (!SvIVX(sv) || + (seq <= SvIVX(sv) && + seq > I_32(SvNVX(sv)))) && + strEQ(SvPVX(sv), name)) + { + if (SvIVX(sv)) + return (PADOFFSET)off; + pendoff = off; /* this pending def. will override import */ } } + /* See if it's in a nested scope */ + off = pad_findlex(name, 0, seq, CvOUTSIDE(compcv), cxstack_ix); + if (off) { + /* If there is a pending local definition, this new alias must die */ + if (pendoff) + SvIVX(AvARRAY(comppad_name)[off]) = seq; + return off; + } + return 0; } @@ -191,13 +337,13 @@ I32 fill; SV *sv; if (min_intro_pending && fill < min_intro_pending) { for (off = max_intro_pending; off >= min_intro_pending; off--) { - if (sv = svp[off]) + if ((sv = svp[off]) && sv != &sv_undef) warn("%s never introduced", SvPVX(sv)); } } /* "Deintroduce" my variables that are leaving with this scope. */ for (off = AvFILL(comppad_name); off > fill; off--) { - if (sv = svp[off]) + if ((sv = svp[off]) && sv != &sv_undef && SvIVX(sv) == 999999999) SvIVX(sv) = cop_seqmax; } } @@ -212,6 +358,8 @@ U32 tmptype; if (AvARRAY(comppad) != curpad) croak("panic: pad_alloc"); + if (pad_reset_pending) + pad_reset(); if (tmptype & SVs_PADMY) { do { sv = *av_fetch(comppad, AvFILL(comppad) + 1, TRUE); @@ -219,66 +367,81 @@ U32 tmptype; retval = AvFILL(comppad); } else { - do { - sv = *av_fetch(comppad, ++padix, TRUE); - } while (SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)); + SV **names = AvARRAY(comppad_name); + SSize_t names_fill = AvFILL(comppad_name); + for (;;) { + /* + * "foreach" index vars temporarily become aliases to non-"my" + * values. Thus we must skip, not just pad values that are + * marked as current pad values, but also those with names. + */ + if (++padix <= names_fill && + (sv = names[padix]) && sv != &sv_undef) + continue; + sv = *av_fetch(comppad, padix, TRUE); + if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY))) + break; + } retval = padix; } SvFLAGS(sv) |= tmptype; curpad = AvARRAY(comppad); - DEBUG_X(fprintf(stderr, "Pad alloc %d for %s\n", retval, op_name[optype])); + DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad alloc %ld for %s\n", (long) retval, op_name[optype])); return (PADOFFSET)retval; } SV * -#ifndef STANDARD_C +#ifndef CAN_PROTOTYPE pad_sv(po) PADOFFSET po; #else pad_sv(PADOFFSET po) -#endif /* STANDARD_C */ +#endif /* CAN_PROTOTYPE */ { if (!po) croak("panic: pad_sv po"); - DEBUG_X(fprintf(stderr, "Pad sv %d\n", po)); + DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad sv %lu\n", (unsigned long)po)); return curpad[po]; /* eventually we'll turn this into a macro */ } void -#ifndef STANDARD_C +#ifndef CAN_PROTOTYPE pad_free(po) PADOFFSET po; #else pad_free(PADOFFSET po) -#endif /* STANDARD_C */ +#endif /* CAN_PROTOTYPE */ { + if (!curpad) + return; if (AvARRAY(comppad) != curpad) croak("panic: pad_free curpad"); if (!po) croak("panic: pad_free po"); - DEBUG_X(fprintf(stderr, "Pad free %d\n", po)); - if (curpad[po]) + DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad free %lu\n", (unsigned long)po)); + if (curpad[po] && !SvIMMORTAL(curpad[po])) SvPADTMP_off(curpad[po]); - if (po < padix) + if ((I32)po < padix) padix = po - 1; } void -#ifndef STANDARD_C +#ifndef CAN_PROTOTYPE pad_swipe(po) PADOFFSET po; #else pad_swipe(PADOFFSET po) -#endif /* STANDARD_C */ +#endif /* CAN_PROTOTYPE */ { if (AvARRAY(comppad) != curpad) croak("panic: pad_swipe curpad"); if (!po) croak("panic: pad_swipe po"); - DEBUG_X(fprintf(stderr, "Pad swipe %d\n", po)); - curpad[po] = NEWSV(0,0); + DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad swipe %lu\n", (unsigned long)po)); SvPADTMP_off(curpad[po]); - if (po < padix) + curpad[po] = NEWSV(1107,0); + SvPADTMP_on(curpad[po]); + if ((I32)po < padix) padix = po - 1; } @@ -289,12 +452,15 @@ pad_reset() if (AvARRAY(comppad) != curpad) croak("panic: pad_reset curpad"); - DEBUG_X(fprintf(stderr, "Pad reset\n")); - for (po = AvMAX(comppad); po > 0; po--) { - if (curpad[po]) - SvPADTMP_off(curpad[po]); + DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad reset\n")); + if (!tainting) { /* Can't mix tainted and non-tainted temporaries. */ + for (po = AvMAX(comppad); po > padix_floor; po--) { + if (curpad[po] && !SvIMMORTAL(curpad[po])) + SvPADTMP_off(curpad[po]); + } + padix = padix_floor; } - padix = 0; + pad_reset_pending = FALSE; } /* Destructor */ @@ -303,32 +469,60 @@ void op_free(op) OP *op; { - register OP *kid; + register OP *kid, *nextkid; - if (!op) + if (!op || op->op_seq == (U16)-1) return; if (op->op_flags & OPf_KIDS) { - for (kid = cUNOP->op_first; kid; kid = kid->op_sibling) + for (kid = cUNOP->op_first; kid; kid = nextkid) { + nextkid = kid->op_sibling; /* Get before next freeing kid */ op_free(kid); + } } - switch (op->op_type) { case OP_NULL: op->op_targ = 0; /* Was holding old type, if any. */ break; + case OP_ENTEREVAL: + op->op_targ = 0; /* Was holding hints. */ + break; + default: + if (!(op->op_flags & OPf_REF) || (check[op->op_type] != ck_ftst)) + break; + /* FALL THROUGH */ case OP_GVSV: case OP_GV: - SvREFCNT_dec((SV*)cGVOP->op_gv); + case OP_AELEMFAST: + SvREFCNT_dec(cGVOP->op_gv); break; case OP_NEXTSTATE: case OP_DBSTATE: + Safefree(cCOP->cop_label); SvREFCNT_dec(cCOP->cop_filegv); break; case OP_CONST: SvREFCNT_dec(cSVOP->op_sv); break; + case OP_GOTO: + case OP_NEXT: + case OP_LAST: + case OP_REDO: + if (op->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS)) + break; + /* FALL THROUGH */ + case OP_TRANS: + Safefree(cPVOP->op_pv); + break; + case OP_SUBST: + op_free(cPMOP->op_pmreplroot); + /* FALL THROUGH */ + case OP_PUSHRE: + case OP_MATCH: + pregfree(cPMOP->op_pmregexp); + SvREFCNT_dec(cPMOP->op_pmshort); + break; } if (op->op_targ > 0) @@ -348,17 +542,6 @@ OP* op; op->op_ppaddr = ppaddr[OP_NULL]; } -static void -unlist(op) -OP* op; -{ - OP* kid = cLISTOP->op_first; - assert(kid->op_type == OP_PUSHMARK); - cLISTOP->op_first = kid->op_sibling; - null(kid); - null(op); -} - /* Contextualizers */ #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o)) @@ -400,13 +583,19 @@ OP *op; return op; } -OP * +static OP * scalarboolean(op) OP *op; { if (dowarn && - op->op_type == OP_SASSIGN && cBINOP->op_first->op_type == OP_CONST) - warn("Found = in conditional, should be =="); + op->op_type == OP_SASSIGN && cBINOP->op_first->op_type == OP_CONST) { + line_t oldline = curcop->cop_line; + + if (copline != NOLINE) + curcop->cop_line = copline; + warn("Found = in conditional, should be =="); + curcop->cop_line = oldline; + } return scalar(op); } @@ -416,14 +605,17 @@ OP *op; { OP *kid; - if (!op || (op->op_flags & OPf_KNOW)) /* assumes no premature commitment */ + /* assumes no premature commitment */ + if (!op || (op->op_flags & OPf_WANT) || error_count + || op->op_type == OP_RETURN) return op; - op->op_flags &= ~OPf_LIST; - op->op_flags |= OPf_KNOW; + op->op_flags = (op->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR; switch (op->op_type) { case OP_REPEAT: + if (op->op_private & OPpREPEAT_DOLIST) + null(((LISTOP*)cBINOP->op_first)->op_first); scalar(cBINOP->op_first); break; case OP_OR: @@ -432,6 +624,12 @@ OP *op; for (kid = cUNOP->op_first->op_sibling; kid; kid = kid->op_sibling) scalar(kid); break; + case OP_SPLIT: + if ((kid = ((LISTOP*)op)->op_first) && kid->op_type == OP_PUSHRE) { + if (!kPMOP->op_pmreplroot) + deprecate("implicit split to @_"); + } + /* FALL THROUGH */ case OP_MATCH: case OP_SUBST: case OP_NULL: @@ -441,9 +639,19 @@ OP *op; scalar(kid); } break; - case OP_SCOPE: case OP_LEAVE: case OP_LEAVETRY: + kid = cLISTOP->op_first; + scalar(kid); + while (kid = kid->op_sibling) { + if (kid->op_sibling) + scalarvoid(kid); + else + scalar(kid); + } + curcop = &compiling; + break; + case OP_SCOPE: case OP_LINESEQ: case OP_LIST: for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) { @@ -466,17 +674,19 @@ OP *op; char* useless = 0; SV* sv; - if (!op) - return op; - if (op->op_flags & OPf_LIST) + /* assumes no premature commitment */ + if (!op || (op->op_flags & OPf_WANT) == OPf_WANT_LIST || error_count + || op->op_type == OP_RETURN) return op; - op->op_flags |= OPf_KNOW; + op->op_flags = (op->op_flags & ~OPf_WANT) | OPf_WANT_VOID; switch (op->op_type) { default: if (!(opargs[op->op_type] & OA_FOLDCONST)) break; + /* FALL THROUGH */ + case OP_REPEAT: if (op->op_flags & OPf_STACKED) break; /* FALL THROUGH */ @@ -488,8 +698,9 @@ OP *op; case OP_PADHV: case OP_PADANY: case OP_AV2ARYLEN: - case OP_SV2LEN: case OP_REF: + case OP_REFGEN: + case OP_SREFGEN: case OP_DEFINED: case OP_HEX: case OP_OCT: @@ -502,8 +713,6 @@ OP *op; case OP_AELEM: case OP_AELEMFAST: case OP_ASLICE: - case OP_VALUES: - case OP_KEYS: case OP_HELEM: case OP_HSLICE: case OP_UNPACK: @@ -549,21 +758,22 @@ OP *op; case OP_GGRNAM: case OP_GGRGID: case OP_GETLOGIN: - if (!(op->op_flags & OPf_INTRO)) - useless = op_name[op->op_type]; + if (!(op->op_private & OPpLVAL_INTRO)) + useless = op_desc[op->op_type]; break; case OP_RV2GV: case OP_RV2SV: case OP_RV2AV: case OP_RV2HV: - if (!(op->op_flags & OPf_INTRO)) + if (!(op->op_private & OPpLVAL_INTRO) && + (!op->op_sibling || op->op_sibling->op_type != OP_READLINE)) useless = "a variable"; break; case OP_NEXTSTATE: case OP_DBSTATE: - curcop = ((COP*)op); /* for warning above */ + curcop = ((COP*)op); /* for warning below */ break; case OP_CONST: @@ -574,6 +784,7 @@ OP *op; useless = 0; else if (SvPOK(sv)) { if (strnEQ(SvPVX(sv), "di", 2) || + strnEQ(SvPVX(sv), "ds", 2) || strnEQ(SvPVX(sv), "ig", 2)) useless = 0; } @@ -592,31 +803,44 @@ OP *op; op->op_ppaddr = ppaddr[OP_PREDEC]; break; - case OP_REPEAT: - scalarvoid(cBINOP->op_first); - useless = op_name[op->op_type]; - break; - case OP_OR: case OP_AND: case OP_COND_EXPR: for (kid = cUNOP->op_first->op_sibling; kid; kid = kid->op_sibling) scalarvoid(kid); break; + + case OP_NULL: + if (op->op_targ == OP_NEXTSTATE || op->op_targ == OP_DBSTATE) + curcop = ((COP*)op); /* for warning below */ + if (op->op_flags & OPf_STACKED) + break; + /* FALL THROUGH */ case OP_ENTERTRY: case OP_ENTER: case OP_SCALAR: - case OP_NULL: if (!(op->op_flags & OPf_KIDS)) break; + /* FALL THROUGH */ case OP_SCOPE: case OP_LEAVE: case OP_LEAVETRY: + case OP_LEAVELOOP: case OP_LINESEQ: case OP_LIST: for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) scalarvoid(kid); break; + case OP_REQUIRE: + /* since all requires must return a value, they're never void */ + op->op_flags &= ~OPf_WANT; + return scalar(op); + case OP_SPLIT: + if ((kid = ((LISTOP*)op)->op_first) && kid->op_type == OP_PUSHRE) { + if (!kPMOP->op_pmreplroot) + deprecate("implicit split to @_"); + } + break; } if (useless && dowarn) warn("Useless use of %s in void context", useless); @@ -641,10 +865,12 @@ OP *op; { OP *kid; - if (!op || (op->op_flags & OPf_KNOW)) /* assumes no premature commitment */ + /* assumes no premature commitment */ + if (!op || (op->op_flags & OPf_WANT) || error_count + || op->op_type == OP_RETURN) return op; - op->op_flags |= (OPf_KNOW | OPf_LIST); + op->op_flags = (op->op_flags & ~OPf_WANT) | OPf_WANT_LIST; switch (op->op_type) { case OP_FLOP: @@ -670,9 +896,19 @@ OP *op; case OP_LIST: listkids(op); break; - case OP_SCOPE: case OP_LEAVE: case OP_LEAVETRY: + kid = cLISTOP->op_first; + list(kid); + while (kid = kid->op_sibling) { + if (kid->op_sibling) + scalarvoid(kid); + else + list(kid); + } + curcop = &compiling; + break; + case OP_SCOPE: case OP_LINESEQ: for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) { if (kid->op_sibling) @@ -706,7 +942,7 @@ OP *op; curcop = &compiling; } op->op_flags &= ~OPf_PARENS; - if (needblockscope) + if (hints & HINT_BLOCK_SCOPE) op->op_flags |= OPf_PARENS; } else @@ -714,7 +950,7 @@ OP *op; return op; } -OP * +static OP * modkids(op, type) OP *op; I32 type; @@ -737,25 +973,77 @@ I32 type; OP *kid; SV *sv; - if (!op) + if (!op || error_count) return op; switch (op->op_type) { - case OP_ENTERSUBR: - if ((type == OP_UNDEF) && !(op->op_flags & OPf_STACKED)) { - op->op_type = OP_RV2CV; /* entersubr => rv2cv */ + case OP_UNDEF: + return op; + case OP_CONST: + if (!(op->op_private & (OPpCONST_ARYBASE))) + goto nomod; + if (eval_start && eval_start->op_type == OP_CONST) { + compiling.cop_arybase = (I32)SvIV(((SVOP*)eval_start)->op_sv); + eval_start = 0; + } + else if (!type) { + SAVEI32(compiling.cop_arybase); + compiling.cop_arybase = 0; + } + else if (type == OP_REFGEN) + goto nomod; + else + croak("That use of $[ is unsupported"); + break; + case OP_STUB: + if (op->op_flags & OPf_PARENS) + break; + goto nomod; + case OP_ENTERSUB: + if ((type == OP_UNDEF || type == OP_REFGEN) && + !(op->op_flags & OPf_STACKED)) { + op->op_type = OP_RV2CV; /* entersub => rv2cv */ op->op_ppaddr = ppaddr[OP_RV2CV]; - null(cUNOP->op_first); /* disable pushmark */ + assert(cUNOP->op_first->op_type == OP_NULL); + null(((LISTOP*)cUNOP->op_first)->op_first); /* disable pushmark */ break; } /* FALL THROUGH */ default: - sprintf(tokenbuf, "Can't modify %s in %s", - op_name[op->op_type], - type ? op_name[type] : "local"); - yyerror(tokenbuf); + nomod: + /* grep, foreach, subcalls, refgen */ + if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) + break; + yyerror(form("Can't modify %s in %s", + op_desc[op->op_type], + type ? op_desc[type] : "local")); return op; + case OP_PREINC: + case OP_PREDEC: + case OP_POW: + case OP_MULTIPLY: + case OP_DIVIDE: + case OP_MODULO: + case OP_REPEAT: + case OP_ADD: + case OP_SUBTRACT: + case OP_CONCAT: + case OP_LEFT_SHIFT: + case OP_RIGHT_SHIFT: + case OP_BIT_AND: + case OP_BIT_XOR: + case OP_BIT_OR: + case OP_I_MULTIPLY: + case OP_I_DIVIDE: + case OP_I_MODULO: + case OP_I_ADD: + case OP_I_SUBTRACT: + if (!(op->op_flags & OPf_STACKED)) + goto nomod; + modcount++; + break; + case OP_COND_EXPR: for (kid = cUNOP->op_first->op_sibling; kid; kid = kid->op_sibling) mod(kid, type); @@ -763,7 +1051,14 @@ I32 type; case OP_RV2AV: case OP_RV2HV: + if (type == OP_REFGEN && op->op_flags & OPf_PARENS) { + modcount = 10000; + return op; /* Treat \(@foo) like ordinary list. */ + } + /* FALL THROUGH */ case OP_RV2GV: + if (scalar_mod_type(op, type)) + goto nomod; ref(cUNOP->op_first, op->op_type); /* FALL THROUGH */ case OP_AASSIGN: @@ -771,17 +1066,15 @@ I32 type; case OP_HSLICE: case OP_NEXTSTATE: case OP_DBSTATE: + case OP_REFGEN: + case OP_CHOMP: modcount = 10000; break; case OP_RV2SV: - if (type == OP_RV2AV || type == OP_RV2HV) - op->op_private = type; + if (!type && cUNOP->op_first->op_type != OP_GV) + croak("Can't localize a reference"); ref(cUNOP->op_first, op->op_type); /* FALL THROUGH */ - case OP_PADSV: - case OP_PADAV: - case OP_PADHV: - case OP_UNDEF: case OP_GV: case OP_AV2ARYLEN: case OP_SASSIGN: @@ -789,56 +1082,126 @@ I32 type; modcount++; break; - case OP_REFGEN: + case OP_PADAV: + case OP_PADHV: + modcount = 10000; + if (type == OP_REFGEN && op->op_flags & OPf_PARENS) + return op; /* Treat \(@foo) like ordinary list. */ + if (scalar_mod_type(op, type)) + goto nomod; + /* FALL THROUGH */ + case OP_PADSV: modcount++; + if (!type) + croak("Can't localize lexical variable %s", + SvPV(*av_fetch(comppad_name, op->op_targ, 4), na)); break; case OP_PUSHMARK: break; - - case OP_SUBSTR: + + case OP_KEYS: + if (type != OP_SASSIGN) + goto nomod; + /* FALL THROUGH */ + case OP_POS: case OP_VEC: + case OP_SUBSTR: pad_free(op->op_targ); op->op_targ = pad_alloc(op->op_type, SVs_PADMY); - sv = PAD_SV(op->op_targ); - sv_upgrade(sv, SVt_PVLV); - sv_magic(sv, 0, op->op_type == OP_VEC ? 'v' : 'x', 0, 0); - curpad[op->op_targ] = sv; - /* FALL THROUGH */ - case OP_NULL: + assert(SvTYPE(PAD_SV(op->op_targ)) == SVt_NULL); if (op->op_flags & OPf_KIDS) - mod(cBINOP->op_first, type); + mod(cBINOP->op_first->op_sibling, type); break; + case OP_AELEM: case OP_HELEM: ref(cBINOP->op_first, op->op_type); - if (type == OP_RV2AV || type == OP_RV2HV) - op->op_private = type; + if (type == OP_ENTERSUB && + !(op->op_private & (OPpLVAL_INTRO | OPpDEREF))) + op->op_private |= OPpLVAL_DEFER; + modcount++; break; case OP_SCOPE: case OP_LEAVE: case OP_ENTER: + if (op->op_flags & OPf_KIDS) + mod(cLISTOP->op_last, type); + break; + + case OP_NULL: if (!(op->op_flags & OPf_KIDS)) break; - mod(cLISTOP->op_last, type); - break; - + if (op->op_targ != OP_LIST) { + mod(cBINOP->op_first, type); + break; + } + /* FALL THROUGH */ case OP_LIST: for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) mod(kid, type); break; } - op->op_flags |= OPf_LVAL; - if (!type) { + op->op_flags |= OPf_MOD; + + if (type == OP_AASSIGN || type == OP_SASSIGN) + op->op_flags |= OPf_SPECIAL|OPf_REF; + else if (!type) { + op->op_private |= OPpLVAL_INTRO; op->op_flags &= ~OPf_SPECIAL; - op->op_flags |= OPf_INTRO; } - else if (type == OP_AASSIGN || type == OP_SASSIGN) - op->op_flags |= OPf_SPECIAL; + else if (type != OP_GREPSTART && type != OP_ENTERSUB) + op->op_flags |= OPf_REF; return op; } +static bool +scalar_mod_type(op, type) +OP *op; +I32 type; +{ + switch (type) { + case OP_SASSIGN: + if (op->op_type == OP_RV2GV) + return FALSE; + /* FALL THROUGH */ + case OP_PREINC: + case OP_PREDEC: + case OP_POSTINC: + case OP_POSTDEC: + case OP_I_PREINC: + case OP_I_PREDEC: + case OP_I_POSTINC: + case OP_I_POSTDEC: + case OP_POW: + case OP_MULTIPLY: + case OP_DIVIDE: + case OP_MODULO: + case OP_REPEAT: + case OP_ADD: + case OP_SUBTRACT: + case OP_I_MULTIPLY: + case OP_I_DIVIDE: + case OP_I_MODULO: + case OP_I_ADD: + case OP_I_SUBTRACT: + case OP_LEFT_SHIFT: + case OP_RIGHT_SHIFT: + case OP_BIT_AND: + case OP_BIT_XOR: + case OP_BIT_OR: + case OP_CONCAT: + case OP_SUBST: + case OP_TRANS: + case OP_ANDASSIGN: /* may work later */ + case OP_ORASSIGN: /* may work later */ + return TRUE; + default: + return FALSE; + } +} + OP * refkids(op, type) OP *op; @@ -858,18 +1221,19 @@ OP *op; I32 type; { OP *kid; - SV *sv; - if (!op) + if (!op || error_count) return op; switch (op->op_type) { - case OP_ENTERSUBR: - if ((type == OP_REFGEN || type == OP_DEFINED) - && !(op->op_flags & (OPf_STACKED|OPf_PARENS))) { - op->op_type = OP_RV2CV; /* entersubr => rv2cv */ + case OP_ENTERSUB: + if ((type == OP_DEFINED) && + !(op->op_flags & OPf_STACKED)) { + op->op_type = OP_RV2CV; /* entersub => rv2cv */ op->op_ppaddr = ppaddr[OP_RV2CV]; - null(cUNOP->op_first); + assert(cUNOP->op_first->op_type == OP_NULL); + null(((LISTOP*)cUNOP->op_first)->op_first); /* disable pushmark */ + op->op_flags |= OPf_SPECIAL; } break; @@ -878,14 +1242,20 @@ I32 type; ref(kid, type); break; case OP_RV2SV: - if (type == OP_RV2AV || type == OP_RV2HV) - op->op_private = type; ref(cUNOP->op_first, op->op_type); + /* FALL THROUGH */ + case OP_PADSV: + if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) { + op->op_private |= (type == OP_RV2AV ? OPpDEREF_AV + : type == OP_RV2HV ? OPpDEREF_HV + : OPpDEREF_SV); + op->op_flags |= OPf_MOD; + } break; case OP_RV2AV: case OP_RV2HV: - op->op_flags |= OPf_LVAL; + op->op_flags |= OPf_REF; /* FALL THROUGH */ case OP_RV2GV: ref(cUNOP->op_first, op->op_type); @@ -893,7 +1263,7 @@ I32 type; case OP_PADAV: case OP_PADHV: - op->op_flags |= OPf_LVAL; + op->op_flags |= OPf_REF; break; case OP_SCALAR: @@ -905,9 +1275,11 @@ I32 type; case OP_AELEM: case OP_HELEM: ref(cBINOP->op_first, op->op_type); - if (type == OP_RV2AV || type == OP_RV2HV || type == OP_REFGEN) { - op->op_private = type; - op->op_flags |= OPf_LVAL; + if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) { + op->op_private |= (type == OP_RV2AV ? OPpDEREF_AV + : type == OP_RV2HV ? OPpDEREF_HV + : OPpDEREF_SV); + op->op_flags |= OPf_MOD; } break; @@ -919,6 +1291,8 @@ I32 type; break; ref(cLISTOP->op_last, type); break; + default: + break; } return scalar(op); @@ -929,10 +1303,9 @@ my(op) OP *op; { OP *kid; - SV *sv; I32 type; - if (!op) + if (!op || error_count) return op; type = op->op_type; @@ -945,11 +1318,11 @@ OP *op; type != OP_PADHV && type != OP_PUSHMARK) { - sprintf(tokenbuf, "Can't declare %s in my", op_name[op->op_type]); - yyerror(tokenbuf); + yyerror(form("Can't declare %s in my", op_desc[op->op_type])); return op; } - op->op_flags |= OPf_LVAL|OPf_INTRO; + op->op_flags |= OPf_MOD; + op->op_private |= OPpLVAL_INTRO; return op; } @@ -970,6 +1343,20 @@ OP *right; { OP *op; + if (dowarn && + (left->op_type == OP_RV2AV || + left->op_type == OP_RV2HV || + left->op_type == OP_PADAV || + left->op_type == OP_PADHV)) { + char *desc = op_desc[(right->op_type == OP_SUBST || + right->op_type == OP_TRANS) + ? right->op_type : OP_MATCH]; + char *sample = ((left->op_type == OP_RV2AV || + left->op_type == OP_PADAV) + ? "@array" : "%hash"); + warn("Applying %s to %s will act on scalar(%s)", desc, sample, sample); + } + if (right->op_type == OP_MATCH || right->op_type == OP_SUBST || right->op_type == OP_TRANS) { @@ -977,7 +1364,7 @@ OP *right; if (right->op_type != OP_MATCH) left = mod(left, right->op_type); if (right->op_type == OP_TRANS) - op = newBINOP(OP_NULL, 0, scalar(left), right); + op = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right); else op = prepend_elem(right->op_type, scalar(left), right); if (type == OP_NOT) @@ -1004,7 +1391,7 @@ scope(o) OP *o; { if (o) { - if (o->op_flags & OPf_PARENS) { + if (o->op_flags & OPf_PARENS || perldb || tainting) { o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o); o->op_type = OP_LEAVE; o->op_ppaddr = ppaddr[OP_LEAVE]; @@ -1015,31 +1402,90 @@ OP *o; o->op_type = OP_SCOPE; o->op_ppaddr = ppaddr[OP_SCOPE]; kid = ((LISTOP*)o)->op_first; - if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) + if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE){ + SvREFCNT_dec(((COP*)kid)->cop_filegv); null(kid); + } } else - o = newUNOP(OP_SCOPE, 0, o); + o = newLISTOP(OP_SCOPE, 0, o, Nullop); } } return o; } -OP * -block_head(o, startp) -OP *o; -OP **startp; +int +block_start(full) +int full; { - if (!o) { - *startp = 0; - return o; + int retval = savestack_ix; + SAVEI32(comppad_name_floor); + if (full) { + if ((comppad_name_fill = AvFILL(comppad_name)) > 0) + comppad_name_floor = comppad_name_fill; + else + comppad_name_floor = 0; + } + SAVEI32(min_intro_pending); + SAVEI32(max_intro_pending); + min_intro_pending = 0; + SAVEI32(comppad_name_fill); + SAVEI32(padix_floor); + padix_floor = padix; + pad_reset_pending = FALSE; + SAVEI32(hints); + hints &= ~HINT_BLOCK_SCOPE; + return retval; +} + +OP* +block_end(floor, seq) +I32 floor; +OP* seq; +{ + int needblockscope = hints & HINT_BLOCK_SCOPE; + OP* retval = scalarseq(seq); + LEAVE_SCOPE(floor); + pad_reset_pending = FALSE; + if (needblockscope) + hints |= HINT_BLOCK_SCOPE; /* propagate out */ + pad_leavemy(comppad_name_fill); + cop_seqmax++; + return retval; +} + +void +newPROG(op) +OP *op; +{ + if (in_eval) { + eval_root = newUNOP(OP_LEAVEEVAL, ((in_eval & 4) ? OPf_SPECIAL : 0), op); + eval_start = linklist(eval_root); + eval_root->op_next = 0; + peep(eval_start); + } + else { + if (!op) + return; + main_root = scope(sawparens(scalarvoid(op))); + curcop = &compiling; + main_start = LINKLIST(main_root); + main_root->op_next = 0; + peep(main_start); + compcv = 0; + + /* Register with debugger */ + if (perldb) { + CV *cv = perl_get_cv("DB::postponed", FALSE); + if (cv) { + dSP; + PUSHMARK(sp); + XPUSHs((SV*)compiling.cop_filegv); + PUTBACK; + perl_call_sv((SV*)cv, G_DISCARD); + } + } } - o = scope(sawparens(scalarvoid(o))); - curcop = &compiling; - *startp = LINKLIST(o); - o->op_next = 0; - peep(*startp); - return o; } OP * @@ -1054,7 +1500,7 @@ I32 lex; if (dowarn && bufptr > oldbufptr && bufptr[-1] == ',') { char *s; for (s = bufptr; *s && (isALNUM(*s) || strchr("@$%, ",*s)); s++) ; - if (*s == ';' || *s == '=' && (s[1] == '@' || s[2] == '@')) + if (*s == ';' || *s == '=') warn("Parens missing around \"%s\" list", lex ? "my" : "local"); } } @@ -1072,7 +1518,7 @@ OP *o; if (o->op_type == OP_LIST) { o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, - newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE))), + newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))), o)); } return o; @@ -1091,13 +1537,20 @@ register OP *o; if (opargs[type] & OA_TARGET) o->op_targ = pad_alloc(type, SVs_PADTMP); + if ((opargs[type] & OA_OTHERINT) && (hints & HINT_INTEGER)) + o->op_ppaddr = ppaddr[type = ++(o->op_type)]; + if (!(opargs[type] & OA_FOLDCONST)) goto nope; + if (error_count) + goto nope; /* Don't try to run w/ errors */ + for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) { if (curop->op_type != OP_CONST && curop->op_type != OP_LIST && curop->op_type != OP_SCALAR && + curop->op_type != OP_NULL && curop->op_type != OP_PUSHMARK) { goto nope; } @@ -1106,33 +1559,51 @@ register OP *o; curop = LINKLIST(o); o->op_next = 0; op = curop; - run(); - if (o->op_targ && *stack_sp == PAD_SV(o->op_targ)) + runops(); + sv = *(stack_sp--); + if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */ pad_swipe(o->op_targ); + else if (SvTEMP(sv)) { /* grab mortal temp? */ + (void)SvREFCNT_inc(sv); + SvTEMP_off(sv); + } op_free(o); if (type == OP_RV2GV) - return newGVOP(OP_GV, 0, *(stack_sp--)); - else - return newSVOP(OP_CONST, 0, *(stack_sp--)); + return newGVOP(OP_GV, 0, (GV*)sv); + else { + if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK) { + IV iv = SvIV(sv); + if ((double)iv == SvNV(sv)) { /* can we smush double to int */ + SvREFCNT_dec(sv); + sv = newSViv(iv); + } + else + SvIOK_off(sv); /* undo SvIV() damage */ + } + return newSVOP(OP_CONST, 0, sv); + } nope: if (!(opargs[type] & OA_OTHERINT)) return o; - if (!(o->op_flags & OPf_KIDS)) - return o; - for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) { - if (curop->op_type == OP_CONST) { - if (SvIOK(((SVOP*)curop)->op_sv)) + if (!(hints & HINT_INTEGER)) { + if (type == OP_DIVIDE || !(o->op_flags & OPf_KIDS)) + return o; + + for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) { + if (curop->op_type == OP_CONST) { + if (SvIOK(((SVOP*)curop)->op_sv)) + continue; + return o; + } + if (opargs[curop->op_type] & OA_RETINTEGER) continue; return o; } - if (opargs[curop->op_type] & OA_RETINTEGER) - continue; - return o; + o->op_ppaddr = ppaddr[++(o->op_type)]; } - o->op_ppaddr = ppaddr[++(o->op_type)]; return o; } @@ -1141,34 +1612,25 @@ gen_constant_list(o) register OP *o; { register OP *curop; - OP *anonop; - I32 tmpmark; - I32 tmpsp; I32 oldtmps_floor = tmps_floor; - AV *av; - GV *gv; - tmpmark = stack_sp - stack_base; - anonop = newANONLIST(o); - curop = LINKLIST(anonop); - anonop->op_next = 0; + list(o); + if (error_count) + return o; /* Don't attempt to run with errors */ + + op = curop = LINKLIST(o); + o->op_next = 0; + pp_pushmark(); + runops(); op = curop; - run(); - tmpsp = stack_sp - stack_base; + pp_anonlist(); tmps_floor = oldtmps_floor; - stack_sp = stack_base + tmpmark; o->op_type = OP_RV2AV; o->op_ppaddr = ppaddr[OP_RV2AV]; - o->op_sibling = 0; curop = ((UNOP*)o)->op_first; - ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, newSVsv(stack_sp[1])); + ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*stack_sp--)); op_free(curop); - curop = ((UNOP*)anonop)->op_first; - curop = ((UNOP*)curop)->op_first; - curop->op_sibling = 0; - op_free(anonop); - o->op_next = 0; linklist(o); return list(o); } @@ -1180,10 +1642,12 @@ I32 flags; OP* op; { OP *kid; - OP *last; + OP *last = 0; if (!op || op->op_type != OP_LIST) op = newLISTOP(OP_LIST, 0, op, Nullop); + else + op->op_flags &= ~OPf_WANT; if (!(opargs[type] & OA_MARK)) null(cLISTOP->op_first); @@ -1192,7 +1656,7 @@ OP* op; op->op_ppaddr = ppaddr[type]; op->op_flags |= flags; - op = (*check[type])(op); + op = CHECKOP(type, op); if (op->op_type != type) return op; @@ -1220,19 +1684,18 @@ OP* last; if (!last) return first; - if (first->op_type == type) { - if (first->op_flags & OPf_KIDS) - ((LISTOP*)first)->op_last->op_sibling = last; - else { - first->op_flags |= OPf_KIDS; - ((LISTOP*)first)->op_first = last; - } - ((LISTOP*)first)->op_last = last; - ((LISTOP*)first)->op_children++; - return first; - } + if (first->op_type != type || type==OP_LIST && first->op_flags & OPf_PARENS) + return newLISTOP(type, 0, first, last); - return newLISTOP(type, 0, first, last); + if (first->op_flags & OPf_KIDS) + ((LISTOP*)first)->op_last->op_sibling = last; + else { + first->op_flags |= OPf_KIDS; + ((LISTOP*)first)->op_first = last; + } + ((LISTOP*)first)->op_last = last; + ((LISTOP*)first)->op_children++; + return first; } OP * @@ -1364,12 +1827,12 @@ I32 flags; op->op_flags = flags; op->op_next = op; - /* op->op_private = 0; */ + op->op_private = 0 + (flags >> 8); if (opargs[type] & OA_RETSCALAR) scalar(op); if (opargs[type] & OA_TARGET) op->op_targ = pad_alloc(type, SVs_PADTMP); - return (*check[type])(op); + return CHECKOP(type, op); } OP * @@ -1384,21 +1847,19 @@ OP* first; first = newOP(OP_STUB, 0); if (opargs[type] & OA_MARK) first = force_list(first); - else if (first->op_type == OP_LIST) - unlist(first); Newz(1101, unop, 1, UNOP); unop->op_type = type; unop->op_ppaddr = ppaddr[type]; unop->op_first = first; unop->op_flags = flags | OPf_KIDS; - unop->op_private = 1; + unop->op_private = 1 | (flags >> 8); - unop = (UNOP*)(*check[type])((OP*)unop); + unop = (UNOP*) CHECKOP(type, unop); if (unop->op_next) return (OP*)unop; - return fold_constants(unop); + return fold_constants((OP *) unop); } OP * @@ -1420,20 +1881,20 @@ OP* last; binop->op_flags = flags | OPf_KIDS; if (!last) { last = first; - binop->op_private = 1; + binop->op_private = 1 | (flags >> 8); } else { - binop->op_private = 2; + binop->op_private = 2 | (flags >> 8); first->op_sibling = last; } - binop = (BINOP*)(*check[type])((OP*)binop); + binop = (BINOP*)CHECKOP(type, binop); if (binop->op_next) return (OP*)binop; binop->op_last = last = binop->op_first->op_sibling; - return fold_constants(binop); + return fold_constants((OP *)binop); } OP * @@ -1442,16 +1903,14 @@ OP *op; OP *expr; OP *repl; { - PMOP *pm = (PMOP*)op; SV *tstr = ((SVOP*)expr)->op_sv; SV *rstr = ((SVOP*)repl)->op_sv; STRLEN tlen; STRLEN rlen; - register char *t = SvPV(tstr, tlen); - register char *r = SvPV(rstr, rlen); + register U8 *t = (U8*)SvPV(tstr, tlen); + register U8 *r = (U8*)SvPV(rstr, rlen); register I32 i; register I32 j; - I32 squash; I32 delete; I32 complement; register short *tbl; @@ -1459,24 +1918,24 @@ OP *repl; tbl = (short*)cPVOP->op_pv; complement = op->op_private & OPpTRANS_COMPLEMENT; delete = op->op_private & OPpTRANS_DELETE; - squash = op->op_private & OPpTRANS_SQUASH; + /* squash = op->op_private & OPpTRANS_SQUASH; */ if (complement) { Zero(tbl, 256, short); for (i = 0; i < tlen; i++) - tbl[t[i] & 0377] = -1; + tbl[t[i]] = -1; for (i = 0, j = 0; i < 256; i++) { if (!tbl[i]) { if (j >= rlen) { if (delete) tbl[i] = -2; else if (rlen) - tbl[i] = r[j-1] & 0377; + tbl[i] = r[j-1]; else tbl[i] = i; } else - tbl[i] = r[j++] & 0377; + tbl[i] = r[j++]; } } } @@ -1489,14 +1948,14 @@ OP *repl; for (i = 0, j = 0; i < tlen; i++,j++) { if (j >= rlen) { if (delete) { - if (tbl[t[i] & 0377] == -1) - tbl[t[i] & 0377] = -2; + if (tbl[t[i]] == -1) + tbl[t[i]] = -2; continue; } --j; } - if (tbl[t[i] & 0377] == -1) - tbl[t[i] & 0377] = r[j] & 0377; + if (tbl[t[i]] == -1) + tbl[t[i]] = r[j]; } } op_free(expr); @@ -1516,10 +1975,13 @@ I32 flags; pmop->op_type = type; pmop->op_ppaddr = ppaddr[type]; pmop->op_flags = flags; - pmop->op_private = 0; + pmop->op_private = 0 | (flags >> 8); + + if (hints & HINT_LOCALE) + pmop->op_pmpermflags = (pmop->op_pmflags |= PMf_LOCALE); /* link into pm list */ - if (type != OP_TRANS) { + if (type != OP_TRANS && curstash) { pmop->op_pmnext = HvPMROOT(curstash); HvPMROOT(curstash) = pmop; } @@ -1550,10 +2012,9 @@ OP *repl; p = SvPV(pat, plen); pm->op_pmflags |= PMf_SKIPWHITE; } - scan_prefix(pm, p, plen); - if (pm->op_pmshort && (pm->op_pmflags & PMf_SCANFIRST)) - fbm_compile(pm->op_pmshort, pm->op_pmflags & PMf_FOLD); - pm->op_pmregexp = regcomp(p, p + plen, pm->op_pmflags & PMf_FOLD); + pm->op_pmregexp = pregcomp(p, p + plen, pm); + if (strEQ("\\s+", pm->op_pmregexp->precomp)) + pm->op_pmflags |= PMf_WHITE; hoistmust(pm); op_free(expr); } @@ -1584,12 +2045,12 @@ OP *repl; } if (repl) { - if (repl->op_type == OP_CONST) { - pm->op_pmflags |= PMf_CONST; - prepend_elem(op->op_type, scalar(repl), op); - } + OP *curop; + if (pm->op_pmflags & PMf_EVAL) + curop = 0; + else if (repl->op_type == OP_CONST) + curop = repl; else { - OP *curop; OP *lastop = 0; for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) { if (opargs[curop->op_type] & OA_DANGEROUS) { @@ -1607,32 +2068,39 @@ OP *repl; if (lastop && lastop->op_type != OP_GV) /*funny deref?*/ break; } + else if (curop->op_type == OP_PADSV || + curop->op_type == OP_PADAV || + curop->op_type == OP_PADHV || + curop->op_type == OP_PADANY) { + /* is okay */ + } else break; } lastop = curop; } - if (curop == repl) { - pm->op_pmflags |= PMf_CONST; /* const for long enough */ - prepend_elem(op->op_type, scalar(repl), op); - } - else { - Newz(1101, rcop, 1, LOGOP); - rcop->op_type = OP_SUBSTCONT; - rcop->op_ppaddr = ppaddr[OP_SUBSTCONT]; - rcop->op_first = scalar(repl); - rcop->op_flags |= OPf_KIDS; - rcop->op_private = 1; - rcop->op_other = op; - - /* establish postfix order */ - rcop->op_next = LINKLIST(repl); - repl->op_next = (OP*)rcop; - - pm->op_pmreplroot = scalar((OP*)rcop); - pm->op_pmreplstart = LINKLIST(rcop); - rcop->op_next = 0; - } + } + if (curop == repl) { + pm->op_pmflags |= PMf_CONST; /* const for long enough */ + pm->op_pmpermflags |= PMf_CONST; /* const for long enough */ + prepend_elem(op->op_type, scalar(repl), op); + } + else { + Newz(1101, rcop, 1, LOGOP); + rcop->op_type = OP_SUBSTCONT; + rcop->op_ppaddr = ppaddr[OP_SUBSTCONT]; + rcop->op_first = scalar(repl); + rcop->op_flags |= OPf_KIDS; + rcop->op_private = 1; + rcop->op_other = op; + + /* establish postfix order */ + rcop->op_next = LINKLIST(repl); + repl->op_next = (OP*)rcop; + + pm->op_pmreplroot = scalar((OP*)rcop); + pm->op_pmreplstart = LINKLIST(rcop); + rcop->op_next = 0; } } @@ -1656,7 +2124,7 @@ SV *sv; scalar((OP*)svop); if (opargs[type] & OA_TARGET) svop->op_targ = pad_alloc(type, SVs_PADTMP); - return (*check[type])((OP*)svop); + return CHECKOP(type, svop); } OP * @@ -1676,7 +2144,7 @@ GV *gv; scalar((OP*)gvop); if (opargs[type] & OA_TARGET) gvop->op_targ = pad_alloc(type, SVs_PADTMP); - return (*check[type])((OP*)gvop); + return CHECKOP(type, gvop); } OP * @@ -1696,29 +2164,7 @@ char *pv; scalar((OP*)pvop); if (opargs[type] & OA_TARGET) pvop->op_targ = pad_alloc(type, SVs_PADTMP); - return (*check[type])((OP*)pvop); -} - -OP * -newCVOP(type, flags, cv, cont) -I32 type; -I32 flags; -CV *cv; -OP *cont; -{ - CVOP *cvop; - Newz(1101, cvop, 1, CVOP); - cvop->op_type = type; - cvop->op_ppaddr = ppaddr[type]; - cvop->op_cv = cv; - cvop->op_cont = cont; - cvop->op_next = (OP*)cvop; - cvop->op_flags = flags; - if (opargs[type] & OA_RETSCALAR) - scalar((OP*)cvop); - if (opargs[type] & OA_TARGET) - cvop->op_targ = pad_alloc(type, SVs_PADTMP); - return (*check[type])((OP*)cvop); + return CHECKOP(type, pvop); } void @@ -1733,8 +2179,8 @@ OP *op; STRLEN len; char *name; sv = cSVOP->op_sv; - curstash = fetch_stash(sv,TRUE); name = SvPV(sv, len); + curstash = gv_stashpvn(name,len,TRUE); sv_setpvn(curstname, name, len); op_free(op); } @@ -1746,25 +2192,85 @@ OP *op; expect = XSTATE; } -HV* -fetch_stash(sv,create) -SV *sv; -I32 create; +void +utilize(aver, floor, version, id, arg) +int aver; +I32 floor; +OP *version; +OP *id; +OP *arg; { - char tmpbuf[256]; - HV *stash; - GV *tmpgv; - char *name = SvPV(sv, na); - sprintf(tmpbuf,"%s::",name); - tmpgv = gv_fetchpv(tmpbuf,create); - if (!tmpgv) - return 0; - if (!GvHV(tmpgv)) - GvHV(tmpgv) = newHV(); - stash = GvHV(tmpgv); - if (!HvNAME(stash)) - HvNAME(stash) = savestr(name); - return stash; + OP *pack; + OP *meth; + OP *rqop; + OP *imop; + OP *veop; + + if (id->op_type != OP_CONST) + croak("Module name must be constant"); + + veop = Nullop; + + if(version != Nullop) { + SV *vesv = ((SVOP*)version)->op_sv; + + if (arg == Nullop && !SvNIOK(vesv)) { + arg = version; + } + else { + OP *pack; + OP *meth; + + if (version->op_type != OP_CONST || !SvNIOK(vesv)) + croak("Version number must be constant number"); + + /* Make copy of id so we don't free it twice */ + pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv)); + + /* Fake up a method call to VERSION */ + meth = newSVOP(OP_CONST, 0, newSVpv("VERSION", 7)); + veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, + append_elem(OP_LIST, + prepend_elem(OP_LIST, pack, list(version)), + newUNOP(OP_METHOD, 0, meth))); + } + } + + /* Fake up an import/unimport */ + if (arg && arg->op_type == OP_STUB) + imop = arg; /* no import on explicit () */ + else if(SvNIOK(((SVOP*)id)->op_sv)) { + imop = Nullop; /* use 5.0; */ + } + else { + /* Make copy of id so we don't free it twice */ + pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv)); + meth = newSVOP(OP_CONST, 0, + aver + ? newSVpv("import", 6) + : newSVpv("unimport", 8) + ); + imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, + append_elem(OP_LIST, + prepend_elem(OP_LIST, pack, list(arg)), + newUNOP(OP_METHOD, 0, meth))); + } + + /* Fake up a require */ + rqop = newUNOP(OP_REQUIRE, 0, id); + + /* Fake up the BEGIN {}, which does its thing immediately. */ + newSUB(floor, + newSVOP(OP_CONST, 0, newSVpv("BEGIN", 5)), + Nullop, + append_elem(OP_LINESEQ, + append_elem(OP_LINESEQ, + newSTATEOP(0, Nullch, rqop), + newSTATEOP(0, Nullch, veop)), + newSTATEOP(0, Nullch, imop) )); + + copline = NOLINE; + expect = XSTATE; } OP * @@ -1814,43 +2320,43 @@ register OP *op; } OP * -newASSIGNOP(flags, left, right) +newASSIGNOP(flags, left, optype, right) I32 flags; OP *left; +I32 optype; OP *right; { OP *op; + if (optype) { + if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) { + return newLOGOP(optype, 0, + mod(scalar(left), optype), + newUNOP(OP_SASSIGN, 0, scalar(right))); + } + else { + return newBINOP(optype, OPf_STACKED, + mod(scalar(left), optype), scalar(right)); + } + } + if (list_assignment(left)) { modcount = 0; + eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/ left = mod(left, OP_AASSIGN); - if (right && right->op_type == OP_SPLIT) { - if ((op = ((LISTOP*)right)->op_first) && op->op_type == OP_PUSHRE) { - PMOP *pm = (PMOP*)op; - if (left->op_type == OP_RV2AV) { - op = ((UNOP*)left)->op_first; - if (op->op_type == OP_GV && !pm->op_pmreplroot) { - pm->op_pmreplroot = (OP*)((GVOP*)op)->op_gv; - pm->op_pmflags |= PMf_ONCE; - op_free(left); - return right; - } - } - else { - if (modcount < 10000) { - SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv; - if (SvIVX(sv) == 0) - sv_setiv(sv, modcount+1); - } - } - } + if (eval_start) + eval_start = 0; + else { + op_free(left); + op_free(right); + return Nullop; } op = newBINOP(OP_AASSIGN, flags, list(force_list(right)), list(force_list(left)) ); - op->op_private = 0; - if (!(left->op_flags & OPf_INTRO)) { - static int generation = 0; + op->op_private = 0 | (flags >> 8); + if (!(left->op_private & OPpLVAL_INTRO)) { + static int generation = 100; OP *curop; OP *lastop = op; generation++; @@ -1862,6 +2368,16 @@ OP *right; break; SvCUR(gv) = generation; } + else if (curop->op_type == OP_PADSV || + curop->op_type == OP_PADAV || + curop->op_type == OP_PADHV || + curop->op_type == OP_PADANY) { + SV **svp = AvARRAY(comppad_name); + SV *sv = svp[curop->op_targ]; + if (SvCUR(sv) == generation) + break; + SvCUR(sv) = generation; /* (SvCUR not used any more) */ + } else if (curop->op_type == OP_RV2CV) break; else if (curop->op_type == OP_RV2SV || @@ -1879,6 +2395,41 @@ OP *right; if (curop != op) op->op_private = OPpASSIGN_COMMON; } + if (right && right->op_type == OP_SPLIT) { + OP* tmpop; + if ((tmpop = ((LISTOP*)right)->op_first) && + tmpop->op_type == OP_PUSHRE) + { + PMOP *pm = (PMOP*)tmpop; + if (left->op_type == OP_RV2AV && + !(left->op_private & OPpLVAL_INTRO) && + !(op->op_private & OPpASSIGN_COMMON) ) + { + tmpop = ((UNOP*)left)->op_first; + if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) { + pm->op_pmreplroot = (OP*)((GVOP*)tmpop)->op_gv; + pm->op_pmflags |= PMf_ONCE; + tmpop = ((UNOP*)op)->op_first; /* to list (nulled) */ + tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */ + tmpop->op_sibling = Nullop; /* don't free split */ + right->op_next = tmpop->op_next; /* fix starting loc */ + op_free(op); /* blow off assign */ + right->op_flags &= ~OPf_WANT; + /* "I don't know and I don't care." */ + return right; + } + } + else { + if (modcount < 10000 && + ((LISTOP*)right)->op_last->op_type == OP_CONST) + { + SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv; + if (SvIVX(sv) == 0) + sv_setiv(sv, modcount+1); + } + } + } + } return op; } if (!right) @@ -1887,9 +2438,17 @@ OP *right; right->op_flags |= OPf_STACKED; return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right)); } - else + else { + eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/ op = newBINOP(OP_SASSIGN, flags, scalar(right), mod(scalar(left), OP_SASSIGN) ); + if (eval_start) + eval_start = 0; + else { + op_free(op); + return Nullop; + } + } return op; } @@ -1899,21 +2458,9 @@ I32 flags; char *label; OP *op; { + U32 seq = intro_my(); register COP *cop; - /* Introduce my variables. */ - if (min_intro_pending) { - SV **svp = AvARRAY(comppad_name); - I32 i; - SV *sv; - for (i = min_intro_pending; i <= max_intro_pending; i++) { - if (sv = svp[i]) - SvIVX(sv) = 999999999; /* Don't know scope end yet. */ - } - min_intro_pending = 0; - comppad_name_fill = max_intro_pending; /* Needn't search higher */ - } - Newz(1101, cop, 1, COP); if (perldb && curcop->cop_line && curstash != debstash) { cop->op_type = OP_DBSTATE; @@ -1924,14 +2471,18 @@ OP *op; cop->op_ppaddr = ppaddr[ OP_NEXTSTATE ]; } cop->op_flags = flags; - cop->op_private = 0; + cop->op_private = 0 | (flags >> 8); +#ifdef NATIVE_HINTS + cop->op_private |= NATIVE_HINTS; +#endif cop->op_next = (OP*)cop; if (label) { cop->cop_label = label; - needblockscope = TRUE; + hints |= HINT_BLOCK_SCOPE; } - cop->cop_seq = cop_seqmax++; + cop->cop_seq = seq; + cop->cop_arybase = curcop->cop_arybase; if (copline == NOLINE) cop->cop_line = curcop->cop_line; @@ -1939,14 +2490,14 @@ OP *op; cop->cop_line = copline; copline = NOLINE; } - cop->cop_filegv = SvREFCNT_inc(curcop->cop_filegv); + cop->cop_filegv = (GV*)SvREFCNT_inc(curcop->cop_filegv); cop->cop_stash = curstash; if (perldb && curstash != debstash) { SV **svp = av_fetch(GvAV(curcop->cop_filegv),(I32)cop->cop_line, FALSE); if (svp && *svp != &sv_undef && !SvIOK(*svp)) { + (void)SvIOK_on(*svp); SvIVX(*svp) = 1; - SvIOK_on(*svp); SvSTASH(*svp) = (HV*)cop; } } @@ -1954,6 +2505,29 @@ OP *op; return prepend_elem(OP_LINESEQ, (OP*)cop, op); } +/* "Introduce" my variables to visible status. */ +U32 +intro_my() +{ + SV **svp; + SV *sv; + I32 i; + + if (! min_intro_pending) + return cop_seqmax; + + svp = AvARRAY(comppad_name); + for (i = min_intro_pending; i <= max_intro_pending; i++) { + if ((sv = svp[i]) && sv != &sv_undef && !SvIVX(sv)) { + SvIVX(sv) = 999999999; /* Don't know scope end yet. */ + SvNVX(sv) = (double)cop_seqmax; + } + } + min_intro_pending = 0; + comppad_name_fill = max_intro_pending; /* Needn't search higher */ + return cop_seqmax++; +} + OP * newLOGOP(type, flags, first, other) I32 type; @@ -1964,6 +2538,9 @@ OP* other; LOGOP *logop; OP *op; + if (type == OP_XOR) /* Not short circuit, but here by precedence. */ + return newBINOP(type, flags, scalar(first), scalar(other)); + scalarboolean(first); /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */ if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) { @@ -1982,7 +2559,7 @@ OP* other; } if (first->op_type == OP_CONST) { if (dowarn && (first->op_private & OPpCONST_BARE)) - warn("Probable precedence problem on %s", op_name[type]); + warn("Probable precedence problem on %s", op_desc[type]); if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) { op_free(first); return other; @@ -1998,10 +2575,43 @@ OP* other; else scalar(other); } + else if (dowarn && (first->op_flags & OPf_KIDS)) { + OP *k1 = ((UNOP*)first)->op_first; + OP *k2 = k1->op_sibling; + OPCODE warnop = 0; + switch (first->op_type) + { + case OP_NULL: + if (k2 && k2->op_type == OP_READLINE + && (k2->op_flags & OPf_STACKED) + && (k1->op_type == OP_RV2SV || k1->op_type == OP_PADSV)) + warnop = k2->op_type; + break; + + case OP_SASSIGN: + if (k1->op_type == OP_READDIR + || k1->op_type == OP_GLOB + || k1->op_type == OP_EACH) + warnop = k1->op_type; + break; + } + if (warnop) { + line_t oldline = curcop->cop_line; + curcop->cop_line = copline; + warn("Value of %s%s can be \"0\"; test with defined()", + op_desc[warnop], + ((warnop == OP_READLINE || warnop == OP_GLOB) + ? " construct" : "() operator")); + curcop->cop_line = oldline; + } + } if (!other) return first; + if (type == OP_ANDASSIGN || type == OP_ORASSIGN) + other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */ + Newz(1101, logop, 1, LOGOP); logop->op_type = type; @@ -2009,7 +2619,7 @@ OP* other; logop->op_first = first; logop->op_flags = flags | OPf_KIDS; logop->op_other = LINKLIST(other); - logop->op_private = 1; + logop->op_private = 1 | (flags >> 8); /* establish postfix order */ logop->op_next = LINKLIST(first); @@ -2023,36 +2633,36 @@ OP* other; } OP * -newCONDOP(flags, first, true, false) +newCONDOP(flags, first, trueop, falseop) I32 flags; OP* first; -OP* true; -OP* false; +OP* trueop; +OP* falseop; { CONDOP *condop; OP *op; - if (!false) - return newLOGOP(OP_AND, 0, first, true); - if (!true) - return newLOGOP(OP_OR, 0, first, false); + if (!falseop) + return newLOGOP(OP_AND, 0, first, trueop); + if (!trueop) + return newLOGOP(OP_OR, 0, first, falseop); scalarboolean(first); if (first->op_type == OP_CONST) { if (SvTRUE(((SVOP*)first)->op_sv)) { op_free(first); - op_free(false); - return true; + op_free(falseop); + return trueop; } else { op_free(first); - op_free(true); - return false; + op_free(trueop); + return falseop; } } else if (first->op_type == OP_WANTARRAY) { - list(true); - scalar(false); + list(trueop); + scalar(falseop); } Newz(1101, condop, 1, CONDOP); @@ -2060,20 +2670,20 @@ OP* false; condop->op_ppaddr = ppaddr[OP_COND_EXPR]; condop->op_first = first; condop->op_flags = flags | OPf_KIDS; - condop->op_true = LINKLIST(true); - condop->op_false = LINKLIST(false); - condop->op_private = 1; + condop->op_true = LINKLIST(trueop); + condop->op_false = LINKLIST(falseop); + condop->op_private = 1 | (flags >> 8); /* establish postfix order */ condop->op_next = LINKLIST(first); first->op_next = (OP*)condop; - first->op_sibling = true; - true->op_sibling = false; + first->op_sibling = trueop; + trueop->op_sibling = falseop; op = newUNOP(OP_NULL, 0, (OP*)condop); - true->op_next = op; - false->op_next = op; + trueop->op_next = op; + falseop->op_next = op; return op; } @@ -2097,7 +2707,7 @@ OP *right; condop->op_flags = OPf_KIDS; condop->op_true = LINKLIST(left); condop->op_false = LINKLIST(right); - condop->op_private = 1; + condop->op_private = 1 | (flags >> 8); left->op_sibling = right; @@ -2135,13 +2745,15 @@ OP *block; OP* listop; OP* op; int once = block && block->op_flags & OPf_SPECIAL && - (block->op_type == OP_ENTERSUBR || block->op_type == OP_NULL); + (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL); if (expr) { if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv)) return block; /* do {} while 0 does once */ - else if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB) - expr = newASSIGNOP(0, newSVREF(newGVOP(OP_GV, 0, defgv)), expr); + if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB) { + expr = newUNOP(OP_DEFINED, 0, + newASSIGNOP(0, newSVREF(newGVOP(OP_GV, 0, defgv)), 0, expr) ); + } } listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0)); @@ -2152,8 +2764,13 @@ OP *block; if (once && op != listop) op->op_next = ((LOGOP*)cUNOP->op_first)->op_other; + if (op == listop) + op = newUNOP(OP_NULL, 0, op); /* or do {} while 1 loses outer block */ + op->op_flags |= flags; - return scope(op); + op = scope(op); + op->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/ + return op; } OP * @@ -2171,8 +2788,10 @@ OP *cont; OP *op; OP *condop; - if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB)) - expr = newASSIGNOP(0, newSVREF(newGVOP(OP_GV, 0, defgv)), expr); + if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB)) { + expr = newUNOP(OP_DEFINED, 0, + newASSIGNOP(0, newSVREF(newGVOP(OP_GV, 0, defgv)), 0, expr) ); + } if (!block) block = newOP(OP_NULL, 0); @@ -2187,8 +2806,8 @@ OP *cont; if (expr) { op = newLOGOP(OP_AND, 0, expr, scalar(listop)); - if (op == expr) { /* oops, it's a while (0) */ - op_free(expr); + if (op == expr && op->op_type == OP_CONST && !SvTRUE(cSVOP->op_sv)) { + op_free(expr); /* oops, it's a while (0) */ op_free((OP*)loop); return Nullop; /* (listop already freed by newLOGOP) */ } @@ -2219,11 +2838,12 @@ OP *cont; loop->op_nextop = op; op->op_flags |= flags; + op->op_private |= (flags >> 8); return op; } OP * -#ifndef STANDARD_C +#ifndef CAN_PROTOTYPE newFOROP(flags,label,forline,sv,expr,block,cont) I32 flags; char *label; @@ -2234,29 +2854,41 @@ OP*block; OP*cont; #else newFOROP(I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont) -#endif /* STANDARD_C */ +#endif /* CAN_PROTOTYPE */ { LOOP *loop; + int padoff = 0; + I32 iterflags = 0; copline = forline; if (sv) { - if (sv->op_type == OP_RV2SV) { - OP *op = sv; - sv = cUNOP->op_first; - sv->op_next = sv; - cUNOP->op_first = Nullop; - op_free(op); + if (sv->op_type == OP_RV2SV) { /* symbol table variable */ + sv->op_type = OP_RV2GV; + sv->op_ppaddr = ppaddr[OP_RV2GV]; + } + else if (sv->op_type == OP_PADSV) { /* private variable */ + padoff = sv->op_targ; + op_free(sv); + sv = Nullop; } else - croak("Can't use %s for loop variable", op_name[sv->op_type]); + croak("Can't use %s for loop variable", op_desc[sv->op_type]); } else { sv = newGVOP(OP_GV, 0, defgv); } - loop = (LOOP*)list(convert(OP_ENTERITER, 0, - append_elem(OP_LIST, force_list(expr), scalar(sv)))); - return newSTATEOP(0, label, newWHILEOP(flags, 1, - loop, newOP(OP_ITER, 0), block, cont)); + if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) { + expr = scalar(ref(expr, OP_ITER)); + iterflags |= OPf_STACKED; + } + loop = (LOOP*)list(convert(OP_ENTERITER, iterflags, + append_elem(OP_LIST, mod(force_list(expr), OP_GREPSTART), + scalar(sv)))); + assert(!loop->op_next); + Renew(loop, 1, LOOP); + loop->op_targ = padoff; + return newSTATEOP(0, label, newWHILEOP(flags, 1, loop, + newOP(OP_ITER, 0), block, cont)); } OP* @@ -2266,212 +2898,595 @@ OP* label; { OP *op; if (type != OP_GOTO || label->op_type == OP_CONST) { - op = newPVOP(type, 0, savestr(SvPVx(((SVOP*)label)->op_sv, na))); + op = newPVOP(type, 0, savepv( + label->op_type == OP_CONST + ? SvPVx(((SVOP*)label)->op_sv, na) + : "" )); op_free(label); } else { - if (label->op_type == OP_ENTERSUBR) - label = newUNOP(OP_REFGEN, 0, ref(label, OP_REFGEN)); + if (label->op_type == OP_ENTERSUB) + label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN)); op = newUNOP(type, OPf_STACKED, label); } - needblockscope = TRUE; + hints |= HINT_BLOCK_SCOPE; return op; } void -cv_clear(cv) +cv_undef(cv) CV *cv; { - if (!CvUSERSUB(cv) && CvROOT(cv)) { + if (!CvXSUB(cv) && CvROOT(cv)) { + if (CvDEPTH(cv)) + croak("Can't undef active subroutine"); ENTER; - if (CvPADLIST(cv)) { - SV** svp = av_fetch(CvPADLIST(cv), 0, FALSE); - if (svp) { - SAVESPTR(comppad); - SAVESPTR(curpad); - comppad = (AV*)*svp; /* Need same context we had compiling */ - curpad = AvARRAY(comppad); - } - } - op_free(CvROOT(cv)); + + SAVESPTR(curpad); + curpad = 0; + + if (!CvCLONED(cv)) + op_free(CvROOT(cv)); CvROOT(cv) = Nullop; - if (CvDEPTH(cv)) - warn("Deleting active subroutine"); /* XXX */ - if (CvPADLIST(cv)) { + LEAVE; + } + CvFLAGS(cv) = 0; + SvREFCNT_dec(CvGV(cv)); + CvGV(cv) = Nullgv; + SvREFCNT_dec(CvOUTSIDE(cv)); + CvOUTSIDE(cv) = Nullcv; + if (CvPADLIST(cv)) { + /* may be during global destruction */ + if (SvREFCNT(CvPADLIST(cv))) { I32 i = AvFILL(CvPADLIST(cv)); - while (i > 0) { + while (i >= 0) { SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE); - if (svp) - av_free((AV*)*svp); + SV* sv = svp ? *svp : Nullsv; + if (!sv) + continue; + if (sv == (SV*)comppad_name) + comppad_name = Nullav; + else if (sv == (SV*)comppad) { + comppad = Nullav; + curpad = Null(SV**); + } + SvREFCNT_dec(sv); } - av_free((AV*)CvPADLIST(cv)); + SvREFCNT_dec((SV*)CvPADLIST(cv)); + } + CvPADLIST(cv) = Nullav; + } +} + +#ifdef DEBUG_CLOSURES +static void +cv_dump(cv) +CV* cv; +{ + CV *outside = CvOUTSIDE(cv); + AV* padlist = CvPADLIST(cv); + AV* pad_name; + AV* pad; + SV** pname; + SV** ppad; + I32 ix; + + PerlIO_printf(Perl_debug_log, "\tCV=0x%p (%s), OUTSIDE=0x%p (%s)\n", + cv, + (CvANON(cv) ? "ANON" + : (cv == main_cv) ? "MAIN" + : CvUNIQUE(outside) ? "UNIQUE" + : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"), + outside, + (!outside ? "null" + : CvANON(outside) ? "ANON" + : (outside == main_cv) ? "MAIN" + : CvUNIQUE(outside) ? "UNIQUE" + : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED")); + + if (!padlist) + return; + + pad_name = (AV*)*av_fetch(padlist, 0, FALSE); + pad = (AV*)*av_fetch(padlist, 1, FALSE); + pname = AvARRAY(pad_name); + ppad = AvARRAY(pad); + + for (ix = 1; ix <= AvFILL(pad_name); ix++) { + if (SvPOK(pname[ix])) + PerlIO_printf(Perl_debug_log, "\t%4d. 0x%p (%s\"%s\" %ld-%ld)\n", + ix, ppad[ix], + SvFAKE(pname[ix]) ? "FAKE " : "", + SvPVX(pname[ix]), + (long)I_32(SvNVX(pname[ix])), + (long)SvIVX(pname[ix])); + } +} +#endif /* DEBUG_CLOSURES */ + +static CV * +cv_clone2(proto, outside) +CV* proto; +CV* outside; +{ + AV* av; + I32 ix; + AV* protopadlist = CvPADLIST(proto); + AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE); + AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE); + SV** pname = AvARRAY(protopad_name); + SV** ppad = AvARRAY(protopad); + I32 fname = AvFILL(protopad_name); + I32 fpad = AvFILL(protopad); + AV* comppadlist; + CV* cv; + + assert(!CvUNIQUE(proto)); + + ENTER; + SAVESPTR(curpad); + SAVESPTR(comppad); + SAVESPTR(comppad_name); + SAVESPTR(compcv); + + cv = compcv = (CV*)NEWSV(1104,0); + sv_upgrade((SV *)cv, SvTYPE(proto)); + CvCLONED_on(cv); + if (CvANON(proto)) + CvANON_on(cv); + + CvFILEGV(cv) = CvFILEGV(proto); + CvGV(cv) = (GV*)SvREFCNT_inc(CvGV(proto)); + CvSTASH(cv) = CvSTASH(proto); + CvROOT(cv) = CvROOT(proto); + CvSTART(cv) = CvSTART(proto); + if (outside) + CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside); + + if (SvPOK(proto)) + sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto)); + + comppad_name = newAV(); + for (ix = fname; ix >= 0; ix--) + av_store(comppad_name, ix, SvREFCNT_inc(pname[ix])); + + comppad = newAV(); + + comppadlist = newAV(); + AvREAL_off(comppadlist); + av_store(comppadlist, 0, (SV*)comppad_name); + av_store(comppadlist, 1, (SV*)comppad); + CvPADLIST(cv) = comppadlist; + av_fill(comppad, AvFILL(protopad)); + curpad = AvARRAY(comppad); + + av = newAV(); /* will be @_ */ + av_extend(av, 0); + av_store(comppad, 0, (SV*)av); + AvFLAGS(av) = AVf_REIFY; + + for (ix = fpad; ix > 0; ix--) { + SV* namesv = (ix <= fname) ? pname[ix] : Nullsv; + if (namesv && namesv != &sv_undef) { + char *name = SvPVX(namesv); /* XXX */ + if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */ + I32 off = pad_findlex(name, ix, SvIVX(namesv), + CvOUTSIDE(cv), cxstack_ix); + if (!off) + curpad[ix] = SvREFCNT_inc(ppad[ix]); + else if (off != ix) + croak("panic: cv_clone: %s", name); + } + else { /* our own lexical */ + SV* sv; + if (*name == '&') { + /* anon code -- we'll come back for it */ + sv = SvREFCNT_inc(ppad[ix]); + } + else if (*name == '@') + sv = (SV*)newAV(); + else if (*name == '%') + sv = (SV*)newHV(); + else + sv = NEWSV(0,0); + if (!SvPADBUSY(sv)) + SvPADMY_on(sv); + curpad[ix] = sv; + } + } + else { + SV* sv = NEWSV(0,0); + SvPADTMP_on(sv); + curpad[ix] = sv; } - SvREFCNT_dec(CvGV(cv)); - LEAVE; } + + /* Now that vars are all in place, clone nested closures. */ + + for (ix = fpad; ix > 0; ix--) { + SV* namesv = (ix <= fname) ? pname[ix] : Nullsv; + if (namesv + && namesv != &sv_undef + && !(SvFLAGS(namesv) & SVf_FAKE) + && *SvPVX(namesv) == '&' + && CvCLONE(ppad[ix])) + { + CV *kid = cv_clone2((CV*)ppad[ix], cv); + SvREFCNT_dec(ppad[ix]); + CvCLONE_on(kid); + SvPADMY_on(kid); + curpad[ix] = (SV*)kid; + } + } + +#ifdef DEBUG_CLOSURES + PerlIO_printf(Perl_debug_log, "Cloned inside:\n"); + cv_dump(outside); + PerlIO_printf(Perl_debug_log, " from:\n"); + cv_dump(proto); + PerlIO_printf(Perl_debug_log, " to:\n"); + cv_dump(cv); +#endif + + LEAVE; + return cv; +} + +CV * +cv_clone(proto) +CV* proto; +{ + return cv_clone2(proto, CvOUTSIDE(proto)); } void -newSUB(floor,op,block) +cv_ckproto(cv, gv, p) +CV* cv; +GV* gv; +char* p; +{ + if ((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) { + SV* msg = sv_newmortal(); + SV* name = Nullsv; + + if (gv) + gv_efullname3(name = sv_newmortal(), gv, Nullch); + sv_setpv(msg, "Prototype mismatch:"); + if (name) + sv_catpvf(msg, " sub %_", name); + if (SvPOK(cv)) + sv_catpvf(msg, " (%s)", SvPVX(cv)); + sv_catpv(msg, " vs "); + if (p) + sv_catpvf(msg, "(%s)", p); + else + sv_catpv(msg, "none"); + warn("%_", msg); + } +} + +SV * +cv_const_sv(cv) +CV* cv; +{ + OP *o; + SV *sv; + + if (!cv || !SvPOK(cv) || SvCUR(cv)) + return Nullsv; + + sv = Nullsv; + for (o = CvSTART(cv); o; o = o->op_next) { + OPCODE type = o->op_type; + + if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK) + continue; + if (type == OP_LEAVESUB || type == OP_RETURN) + break; + if (sv) + return Nullsv; + if (type == OP_CONST) + sv = ((SVOP*)o)->op_sv; + else if (type == OP_PADSV) { + AV* pad = (AV*)(AvARRAY(CvPADLIST(cv))[1]); + sv = pad ? AvARRAY(pad)[o->op_targ] : Nullsv; + if (!sv || (!SvREADONLY(sv) && SvREFCNT(sv) > 1)) + return Nullsv; + } + else + return Nullsv; + } + if (sv) + SvREADONLY_on(sv); + return sv; +} + +CV * +newSUB(floor,op,proto,block) I32 floor; OP *op; +OP *proto; OP *block; { + char *name = op ? SvPVx(cSVOP->op_sv, na) : Nullch; + GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV); + char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, na) : Nullch; register CV *cv; - char *name = SvPVx(cSVOP->op_sv, na); - GV *gv = gv_fetchpv(name,2); - AV* av; - char *s; + I32 ix; - sub_generation++; - if ((cv = GvCV(gv)) && !GvCVGEN(gv)) { - if (CvDEPTH(cv)) - CvDELETED(cv) = TRUE; /* probably an autoloader */ - else { - if (dowarn && CvROOT(cv)) { + if (op) + SAVEFREEOP(op); + if (proto) + SAVEFREEOP(proto); + + if (!name || GvCVGEN(gv)) + cv = Nullcv; + else if (cv = GvCV(gv)) { + cv_ckproto(cv, gv, ps); + /* already defined (or promised)? */ + if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) { + SV* const_sv; + if (!block) { + /* just a "sub foo;" when &foo is already defined */ + SAVEFREESV(compcv); + goto done; + } + const_sv = cv_const_sv(cv); + if (const_sv || dowarn) { line_t oldline = curcop->cop_line; - curcop->cop_line = copline; - warn("Subroutine %s redefined",name); + warn(const_sv ? "Constant subroutine %s redefined" + : "Subroutine %s redefined", name); curcop->cop_line = oldline; } SvREFCNT_dec(cv); + cv = Nullcv; } } - Newz(101,cv,1,CV); - sv_upgrade(cv, SVt_PVCV); - SvREFCNT(cv) = 1; - GvCV(gv) = cv; - GvCVGEN(gv) = 0; + if (cv) { /* must reuse cv if autoloaded */ + cv_undef(cv); + CvFLAGS(cv) = CvFLAGS(compcv); + CvOUTSIDE(cv) = CvOUTSIDE(compcv); + CvOUTSIDE(compcv) = 0; + CvPADLIST(cv) = CvPADLIST(compcv); + CvPADLIST(compcv) = 0; + if (SvREFCNT(compcv) > 1) /* XXX Make closures transit through stub. */ + CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc((SV*)cv); + SvREFCNT_dec(compcv); + } + else { + cv = compcv; + if (name) { + GvCV(gv) = cv; + GvCVGEN(gv) = 0; + sub_generation++; + } + } + CvGV(cv) = (GV*)SvREFCNT_inc(gv); CvFILEGV(cv) = curcop->cop_filegv; - CvGV(cv) = SvREFCNT_inc(gv); CvSTASH(cv) = curstash; - av = newAV(); - av_store(av, 0, Nullsv); - av_store(comppad, 0, (SV*)av); - SvOK_on(av); - AvREAL_off(av); + if (ps) + sv_setpv((SV*)cv, ps); + + if (error_count) { + op_free(block); + block = Nullop; + if (name) { + char *s = strrchr(name, ':'); + s = s ? s+1 : name; + if (strEQ(s, "BEGIN")) { + char *not_safe = + "BEGIN not safe after errors--compilation aborted"; + if (in_eval & 4) + croak(not_safe); + else { + /* force display of errors found but not reported */ + sv_catpv(GvSV(errgv), not_safe); + croak("%s", SvPVx(GvSV(errgv), na)); + } + } + } + } + if (!block) { + copline = NOLINE; + LEAVE_SCOPE(floor); + return cv; + } - av = newAV(); - AvREAL_off(av); if (AvFILL(comppad_name) < AvFILL(comppad)) av_store(comppad_name, AvFILL(comppad), Nullsv); - av_store(av, 0, (SV*)comppad_name); - av_store(av, 1, (SV*)comppad); - AvFILL(av) = 1; - CvPADLIST(cv) = av; - comppad_name = newAV(); - if (!block) { - CvROOT(cv) = 0; - op_free(op); - copline = NOLINE; - LEAVE_SCOPE(floor); - return; + if (CvCLONE(cv)) { + SV **namep = AvARRAY(comppad_name); + for (ix = AvFILL(comppad); ix > 0; ix--) { + SV *namesv; + + if (SvIMMORTAL(curpad[ix])) + continue; + /* + * The only things that a clonable function needs in its + * pad are references to outer lexicals and anonymous subs. + * The rest are created anew during cloning. + */ + if (!((namesv = namep[ix]) != Nullsv && + namesv != &sv_undef && + (SvFAKE(namesv) || + *SvPVX(namesv) == '&'))) + { + SvREFCNT_dec(curpad[ix]); + curpad[ix] = Nullsv; + } + } + } + else { + AV *av = newAV(); /* Will be @_ */ + av_extend(av, 0); + av_store(comppad, 0, (SV*)av); + AvFLAGS(av) = AVf_REIFY; + + for (ix = AvFILL(comppad); ix > 0; ix--) { + if (SvIMMORTAL(curpad[ix])) + continue; + if (!SvPADMY(curpad[ix])) + SvPADTMP_on(curpad[ix]); + } } - CvROOT(cv) = newUNOP(OP_LEAVESUBR, 0, scalarseq(block)); + + CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block)); CvSTART(cv) = LINKLIST(CvROOT(cv)); CvROOT(cv)->op_next = 0; peep(CvSTART(cv)); - CvDELETED(cv) = FALSE; - if (s = strrchr(name,':')) - s++; - else - s = name; - if (strEQ(s, "BEGIN")) { - line_t oldline = compiling.cop_line; - ENTER; - SAVESPTR(compiling.cop_filegv); - SAVEI32(perldb); - if (!beginav) - beginav = newAV(); - av_push(beginav, cv); - DEBUG_x( dump_sub(gv) ); - rs = nrs; - rslen = nrslen; - rschar = nrschar; - rspara = (nrslen == 2); - GvCV(gv) = 0; - calllist(beginav); - rs = "\n"; - rslen = 1; - rschar = '\n'; - rspara = 0; - curcop = &compiling; - curcop->cop_line = oldline; /* might have recursed to yylex */ - LEAVE; - } - else if (strEQ(s, "END")) { - if (!endav) - endav = newAV(); - av_unshift(endav, 1); - av_store(endav, 0, SvREFCNT_inc(cv)); - } - if (perldb && curstash != debstash) { - SV *sv; - SV *tmpstr = sv_newmortal(); + if (name) { + char *s; + + if (perldb && curstash != debstash) { + SV *sv = NEWSV(0,0); + SV *tmpstr = sv_newmortal(); + static GV *db_postponed; + CV *cv; + HV *hv; + + sv_setpvf(sv, "%_:%ld-%ld", + GvSV(curcop->cop_filegv), + (long)subline, (long)curcop->cop_line); + gv_efullname3(tmpstr, gv, Nullch); + hv_store(GvHV(DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0); + if (!db_postponed) { + db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV); + } + hv = GvHVn(db_postponed); + if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr)) + && (cv = GvCV(db_postponed))) { + dSP; + PUSHMARK(sp); + XPUSHs(tmpstr); + PUTBACK; + perl_call_sv((SV*)cv, G_DISCARD); + } + } + + if ((s = strrchr(name,':'))) + s++; + else + s = name; + if (strEQ(s, "BEGIN")) { + I32 oldscope = scopestack_ix; + ENTER; + SAVESPTR(compiling.cop_filegv); + SAVEI16(compiling.cop_line); + SAVEI32(perldb); + save_svref(&rs); + sv_setsv(rs, nrs); + + if (!beginav) + beginav = newAV(); + DEBUG_x( dump_sub(gv) ); + av_push(beginav, (SV *)cv); + GvCV(gv) = 0; + call_list(oldscope, beginav); - sprintf(buf,"%s:%ld",SvPVX(GvSV(curcop->cop_filegv)), subline); - sv = newSVpv(buf,0); - sv_catpv(sv,"-"); - sprintf(buf,"%ld",(long)curcop->cop_line); - sv_catpv(sv,buf); - gv_efullname(tmpstr,gv); - hv_store(GvHV(DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0); + curcop = &compiling; + LEAVE; + } + else if (strEQ(s, "END") && !error_count) { + if (!endav) + endav = newAV(); + av_unshift(endav, 1); + av_store(endav, 0, (SV *)cv); + GvCV(gv) = 0; + } } - op_free(op); + + done: copline = NOLINE; LEAVE_SCOPE(floor); + return cv; } -void +#ifdef DEPRECATED +CV * newXSUB(name, ix, subaddr, filename) char *name; I32 ix; I32 (*subaddr)(); char *filename; { + CV* cv = newXS(name, (void(*)())subaddr, filename); + CvOLDSTYLE_on(cv); + CvXSUBANY(cv).any_i32 = ix; + return cv; +} +#endif + +CV * +newXS(name, subaddr, filename) +char *name; +void (*subaddr) _((CV*)); +char *filename; +{ + GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV); register CV *cv; - GV *gv = gv_fetchpv(name,2); - char *s; - - sub_generation++; - if ((cv = GvCV(gv)) && !GvCVGEN(gv)) { - if (dowarn) - warn("Subroutine %s redefined",name); - if (!CvUSERSUB(cv) && CvROOT(cv)) { - op_free(CvROOT(cv)); - CvROOT(cv) = Nullop; + + if (cv = (name ? GvCV(gv) : Nullcv)) { + if (GvCVGEN(gv)) { + /* just a cached method */ + SvREFCNT_dec(cv); + cv = 0; + } + else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) { + /* already defined (or promised) */ + if (dowarn) { + line_t oldline = curcop->cop_line; + curcop->cop_line = copline; + warn("Subroutine %s redefined",name); + curcop->cop_line = oldline; + } + SvREFCNT_dec(cv); + cv = 0; } - Safefree(cv); } - Newz(101,cv,1,CV); - sv_upgrade(cv, SVt_PVCV); - SvREFCNT(cv) = 1; - GvCV(gv) = cv; - CvGV(cv) = SvREFCNT_inc(gv); - GvCVGEN(gv) = 0; - CvFILEGV(cv) = gv_fetchfile(filename); - CvUSERSUB(cv) = subaddr; - CvUSERINDEX(cv) = ix; - CvDELETED(cv) = FALSE; - if (s = strrchr(name,':')) - s++; - else - s = name; - if (strEQ(s, "BEGIN")) { - if (!beginav) - beginav = newAV(); - av_push(beginav, SvREFCNT_inc(gv)); + + if (cv) /* must reuse cv if autoloaded */ + cv_undef(cv); + else { + cv = (CV*)NEWSV(1105,0); + sv_upgrade((SV *)cv, SVt_PVCV); + if (name) { + GvCV(gv) = cv; + GvCVGEN(gv) = 0; + sub_generation++; + } } - else if (strEQ(s, "END")) { - if (!endav) - endav = newAV(); - av_unshift(endav, 1); - av_store(endav, 0, SvREFCNT_inc(gv)); + CvGV(cv) = (GV*)SvREFCNT_inc(gv); + CvFILEGV(cv) = gv_fetchfile(filename); + CvXSUB(cv) = subaddr; + + if (name) { + char *s = strrchr(name,':'); + if (s) + s++; + else + s = name; + if (strEQ(s, "BEGIN")) { + if (!beginav) + beginav = newAV(); + av_push(beginav, (SV *)cv); + GvCV(gv) = 0; + } + else if (strEQ(s, "END")) { + if (!endav) + endav = newAV(); + av_unshift(endav, 1); + av_store(endav, 0, (SV *)cv); + GvCV(gv) = 0; + } } + else + CvANON_on(cv); + + return cv; } void @@ -2483,13 +3498,14 @@ OP *block; register CV *cv; char *name; GV *gv; - AV* av; + I32 ix; if (op) name = SvPVx(cSVOP->op_sv, na); else name = "STDOUT"; - gv = gv_fetchpv(name,TRUE); + gv = gv_fetchpv(name,TRUE, SVt_PVFM); + GvMULTI_on(gv); if (cv = GvFORM(gv)) { if (dowarn) { line_t oldline = curcop->cop_line; @@ -2500,62 +3516,49 @@ OP *block; } SvREFCNT_dec(cv); } - Newz(101,cv,1,CV); - sv_upgrade(cv, SVt_PVFM); - SvREFCNT(cv) = 1; + cv = compcv; GvFORM(gv) = cv; - CvGV(cv) = SvREFCNT_inc(gv); + CvGV(cv) = (GV*)SvREFCNT_inc(gv); CvFILEGV(cv) = curcop->cop_filegv; - CvPADLIST(cv) = av = newAV(); - AvREAL_off(av); - av_store(av, 1, (SV*)comppad); - AvFILL(av) = 1; + for (ix = AvFILL(comppad); ix > 0; ix--) { + if (!SvPADMY(curpad[ix]) && !SvIMMORTAL(curpad[ix])) + SvPADTMP_on(curpad[ix]); + } CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block)); CvSTART(cv) = LINKLIST(CvROOT(cv)); CvROOT(cv)->op_next = 0; peep(CvSTART(cv)); - CvDELETED(cv) = FALSE; - FmLINES(cv) = 0; op_free(op); copline = NOLINE; LEAVE_SCOPE(floor); } OP * -newMETHOD(ref,name) -OP *ref; -OP *name; +newANONLIST(op) +OP* op; { - LOGOP* mop; - Newz(1101, mop, 1, LOGOP); - mop->op_type = OP_METHOD; - mop->op_ppaddr = ppaddr[OP_METHOD]; - mop->op_first = scalar(ref); - mop->op_flags |= OPf_KIDS; - mop->op_private = 1; - mop->op_other = LINKLIST(name); - mop->op_targ = pad_alloc(OP_METHOD, SVs_PADTMP); - mop->op_next = LINKLIST(ref); - ref->op_next = (OP*)mop; - return scalar((OP*)mop); + return newUNOP(OP_REFGEN, 0, + mod(list(convert(OP_ANONLIST, 0, op)), OP_REFGEN)); } OP * -newANONLIST(op) +newANONHASH(op) OP* op; { return newUNOP(OP_REFGEN, 0, - ref(list(convert(OP_ANONLIST, 0, op)), OP_REFGEN)); + mod(list(convert(OP_ANONHASH, 0, op)), OP_REFGEN)); } OP * -newANONHASH(op) -OP* op; +newANONSUB(floor, proto, block) +I32 floor; +OP *proto; +OP *block; { return newUNOP(OP_REFGEN, 0, - ref(list(convert(OP_ANONHASH, 0, op)), OP_REFGEN)); + newSVOP(OP_ANONCODE, 0, (SV*)newSUB(floor, 0, proto, block))); } OP * @@ -2619,10 +3622,13 @@ OP *o; } OP * -newGVREF(o) +newGVREF(type,o) +I32 type; OP *o; { - return newUNOP(OP_RV2GV, 0, scalar(o)); + if (type == OP_MAPSTART) + return newUNOP(OP_NULL, 0, o); + return ref(newUNOP(OP_RV2GV, OPf_REF, o), type); } OP * @@ -2647,10 +3653,11 @@ OP *o; } OP * -newCVREF(o) +newCVREF(flags, o) +I32 flags; OP *o; { - return newUNOP(OP_RV2CV, 0, scalar(o)); + return newUNOP(OP_RV2CV, flags, scalar(o)); } OP * @@ -2668,6 +3675,35 @@ OP *o; /* Check routines. */ OP * +ck_anoncode(op) +OP *op; +{ + PADOFFSET ix; + SV* name; + + name = NEWSV(1106,0); + sv_upgrade(name, SVt_PVNV); + sv_setpvn(name, "&", 1); + SvIVX(name) = -1; + SvNVX(name) = 1; + ix = pad_alloc(op->op_type, SVs_PADMY); + av_store(comppad_name, ix, name); + av_store(comppad, ix, cSVOP->op_sv); + SvPADMY_on(cSVOP->op_sv); + cSVOP->op_sv = Nullsv; + cSVOP->op_targ = ix; + return op; +} + +OP * +ck_bitop(op) +OP *op; +{ + op->op_private = hints; + return op; +} + +OP * ck_concat(op) OP *op; { @@ -2677,22 +3713,46 @@ OP *op; } OP * -ck_chop(op) +ck_spair(op) OP *op; { if (op->op_flags & OPf_KIDS) { OP* newop; - op = modkids(ck_fun(op), op->op_type); - if (op->op_private != 1) - return op; - newop = cUNOP->op_first->op_sibling; - if (!newop || newop->op_type != OP_RV2SV) + OP* kid; + OPCODE type = op->op_type; + op = modkids(ck_fun(op), type); + kid = cUNOP->op_first; + newop = kUNOP->op_first->op_sibling; + if (newop && + (newop->op_sibling || + !(opargs[newop->op_type] & OA_RETSCALAR) || + newop->op_type == OP_PADAV || newop->op_type == OP_PADHV || + newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) { + return op; - op_free(cUNOP->op_first); - cUNOP->op_first = newop; + } + op_free(kUNOP->op_first); + kUNOP->op_first = newop; + } + op->op_ppaddr = ppaddr[++op->op_type]; + return ck_fun(op); +} + +OP * +ck_delete(op) +OP *op; +{ + op = ck_fun(op); + op->op_private = 0; + if (op->op_flags & OPf_KIDS) { + OP *kid = cUNOP->op_first; + if (kid->op_type == OP_HSLICE) + op->op_private |= OPpSLICE; + else if (kid->op_type != OP_HELEM) + croak("%s argument is not a HASH element or slice", + op_desc[op->op_type]); + null(kid); } - op->op_type = OP_SCHOP; - op->op_ppaddr = ppaddr[OP_SCHOP]; return op; } @@ -2706,7 +3766,7 @@ OP *op; if (cLISTOP->op_first->op_type == OP_STUB) { op_free(op); op = newUNOP(type, OPf_SPECIAL, - newGVOP(OP_GV, 0, gv_fetchpv("main'ARGV", TRUE))); + newGVOP(OP_GV, 0, gv_fetchpv("main'ARGV", TRUE, SVt_PVAV))); } return ck_fun(op); } @@ -2717,7 +3777,7 @@ OP * ck_eval(op) OP *op; { - needblockscope = TRUE; + hints |= HINT_BLOCK_SCOPE; if (op->op_flags & OPf_KIDS) { SVOP *kid = (SVOP*)cUNOP->op_first; @@ -2751,6 +3811,7 @@ OP *op; op_free(op); op = newUNOP(OP_ENTEREVAL, 0, newSVREF(newGVOP(OP_GV, 0, defgv))); } + op->op_targ = (PADOFFSET)hints; return op; } @@ -2771,6 +3832,20 @@ OP *op; } OP * +ck_exists(op) +OP *op; +{ + op = ck_fun(op); + if (op->op_flags & OPf_KIDS) { + OP *kid = cUNOP->op_first; + if (kid->op_type != OP_HELEM) + croak("%s argument is not a HASH element", op_desc[op->op_type]); + null(kid); + } + return op; +} + +OP * ck_gvconst(o) register OP *o; { @@ -2785,36 +3860,76 @@ ck_rvconst(op) register OP *op; { SVOP *kid = (SVOP*)cUNOP->op_first; + + op->op_private |= (hints & HINT_STRICT_REFS); if (kid->op_type == OP_CONST) { + char *name; + int iscv; + GV *gv; + + name = SvPV(kid->op_sv, na); + if ((hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) { + char *badthing = Nullch; + switch (op->op_type) { + case OP_RV2SV: + badthing = "a SCALAR"; + break; + case OP_RV2AV: + badthing = "an ARRAY"; + break; + case OP_RV2HV: + badthing = "a HASH"; + break; + } + if (badthing) + croak( + "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use", + name, badthing); + } kid->op_type = OP_GV; - kid->op_sv = SvREFCNT_inc(gv_fetchpv(SvPVx(kid->op_sv, na), - 1+(op->op_type==OP_RV2CV))); + iscv = (op->op_type == OP_RV2CV) * 2; + for (gv = 0; !gv; iscv++) { + /* + * This is a little tricky. We only want to add the symbol if we + * didn't add it in the lexer. Otherwise we get duplicate strict + * warnings. But if we didn't add it in the lexer, we must at + * least pretend like we wanted to add it even if it existed before, + * or we get possible typo warnings. OPpCONST_ENTERED says + * whether the lexer already added THIS instance of this symbol. + */ + gv = gv_fetchpv(name, + iscv | !(kid->op_private & OPpCONST_ENTERED), + iscv + ? SVt_PVCV + : op->op_type == OP_RV2SV + ? SVt_PV + : op->op_type == OP_RV2AV + ? SVt_PVAV + : op->op_type == OP_RV2HV + ? SVt_PVHV + : SVt_PVGV); + } + SvREFCNT_dec(kid->op_sv); + kid->op_sv = SvREFCNT_inc(gv); } return op; } OP * -ck_formline(op) -OP *op; -{ - return ck_fun(op); -} - -OP * ck_ftst(op) OP *op; { I32 type = op->op_type; - if (op->op_flags & OPf_SPECIAL) + if (op->op_flags & OPf_REF) return op; if (op->op_flags & OPf_KIDS) { SVOP *kid = (SVOP*)cUNOP->op_first; if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { - OP *newop = newGVOP(type, OPf_SPECIAL, - gv_fetchpv(SvPVx(kid->op_sv, na), TRUE)); + OP *newop = newGVOP(type, OPf_REF, + gv_fetchpv(SvPVx(kid->op_sv, na), TRUE, SVt_PVIO)); op_free(op); return newop; } @@ -2822,7 +3937,8 @@ OP *op; else { op_free(op); if (type == OP_FTTTY) - return newGVOP(type, OPf_SPECIAL, gv_fetchpv("main'STDIN", TRUE)); + return newGVOP(type, OPf_REF, gv_fetchpv("main'STDIN", TRUE, + SVt_PVIO)); else return newUNOP(type, 0, newSVREF(newGVOP(OP_GV, 0, defgv))); } @@ -2837,7 +3953,8 @@ OP *op; OP **tokid; OP *sibl; I32 numargs = 0; - register I32 oa = opargs[op->op_type] >> 8; + int type = op->op_type; + register I32 oa = opargs[type] >> OASHIFT; if (op->op_flags & OPf_STACKED) { if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL)) @@ -2855,6 +3972,8 @@ OP *op; tokid = &kid->op_sibling; kid = kid->op_sibling; } + if (!kid && opargs[type] & OA_DEFGV) + *tokid = kid = newSVREF(newGVOP(OP_GV, 0, defgv)); while (oa && kid) { numargs++; @@ -2876,40 +3995,40 @@ OP *op; (kid->op_private & OPpCONST_BARE)) { char *name = SvPVx(((SVOP*)kid)->op_sv, na); OP *newop = newAVREF(newGVOP(OP_GV, 0, - gv_fetchpv(name, TRUE) )); + gv_fetchpv(name, TRUE, SVt_PVAV) )); if (dowarn) - warn("Array @%s missing the @ in argument %d of %s()", - name, numargs, op_name[op->op_type]); + warn("Array @%s missing the @ in argument %ld of %s()", + name, (long)numargs, op_desc[type]); op_free(kid); kid = newop; kid->op_sibling = sibl; *tokid = kid; } else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) - bad_type(numargs, "array", op, kid); - mod(kid, op->op_type); + bad_type(numargs, "array", op_desc[op->op_type], kid); + mod(kid, type); break; case OA_HVREF: if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { char *name = SvPVx(((SVOP*)kid)->op_sv, na); OP *newop = newHVREF(newGVOP(OP_GV, 0, - gv_fetchpv(name, TRUE) )); + gv_fetchpv(name, TRUE, SVt_PVHV) )); if (dowarn) - warn("Hash %%%s missing the %% in argument %d of %s()", - name, numargs, op_name[op->op_type]); + warn("Hash %%%s missing the %% in argument %ld of %s()", + name, (long)numargs, op_desc[type]); op_free(kid); kid = newop; kid->op_sibling = sibl; *tokid = kid; } else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV) - bad_type(numargs, "hash", op, kid); - mod(kid, op->op_type); + bad_type(numargs, "hash", op_desc[op->op_type], kid); + mod(kid, type); break; case OA_CVREF: { - OP *newop = newUNOP(OP_NULL, 0, scalar(kid)); + OP *newop = newUNOP(OP_NULL, 0, kid); kid->op_sibling = 0; linklist(kid); newop->op_next = newop; @@ -2923,7 +4042,8 @@ OP *op; if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { OP *newop = newGVOP(OP_GV, 0, - gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, na), TRUE) ); + gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, na), TRUE, + SVt_PVIO) ); op_free(kid); kid = newop; } @@ -2937,23 +4057,28 @@ OP *op; scalar(kid); break; case OA_SCALARREF: - mod(scalar(kid), op->op_type); + mod(scalar(kid), type); break; } oa >>= 4; tokid = &kid->op_sibling; kid = kid->op_sibling; } - op->op_private = numargs; + op->op_private |= numargs; if (kid) - return too_many_arguments(op); + return too_many_arguments(op,op_desc[op->op_type]); listkids(op); } + else if (opargs[type] & OA_DEFGV) { + op_free(op); + return newUNOP(type, 0, newSVREF(newGVOP(OP_GV, 0, defgv))); + } + if (oa) { while (oa & OA_OPTIONAL) oa >>= 4; if (oa && oa != OA_LIST) - return too_few_arguments(op); + return too_few_arguments(op,op_desc[op->op_type]); } return op; } @@ -2962,11 +4087,30 @@ OP * ck_glob(op) OP *op; { - GV *gv = newGVgen(); - GvIOn(gv); + GV *gv = gv_fetchpv("glob", FALSE, SVt_PVCV); + + if (gv && GvIMPORTED_CV(gv)) { + static int glob_index; + + append_elem(OP_GLOB, op, + newSVOP(OP_CONST, 0, newSViv(glob_index++))); + op->op_type = OP_LIST; + op->op_ppaddr = ppaddr[OP_LIST]; + ((LISTOP*)op)->op_first->op_type = OP_PUSHMARK; + ((LISTOP*)op)->op_first->op_ppaddr = ppaddr[OP_PUSHMARK]; + op = newUNOP(OP_ENTERSUB, OPf_STACKED, + append_elem(OP_LIST, op, + scalar(newUNOP(OP_RV2CV, 0, + newGVOP(OP_GV, 0, gv))))); + return ck_subr(op); + } + if ((op->op_flags & OPf_KIDS) && !cLISTOP->op_first->op_sibling) + append_elem(OP_GLOB, op, newSVREF(newGVOP(OP_GV, 0, defgv))); + gv = newGVgen("main"); + gv_IOadd(gv); append_elem(OP_GLOB, op, newGVOP(OP_GV, 0, gv)); scalarkids(op); - return op; + return ck_fun(op); } OP * @@ -2975,29 +4119,49 @@ OP *op; { LOGOP *gwop; OP *kid; + OPCODE type = op->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE; + op->op_ppaddr = ppaddr[OP_GREPSTART]; + Newz(1101, gwop, 1, LOGOP); + if (op->op_flags & OPf_STACKED) { + OP* k; op = ck_sort(op); + kid = cLISTOP->op_first->op_sibling; + for (k = cLISTOP->op_first->op_sibling->op_next; k; k = k->op_next) { + kid = k; + } + kid->op_next = (OP*)gwop; op->op_flags &= ~OPf_STACKED; } + kid = cLISTOP->op_first->op_sibling; + if (type == OP_MAPWHILE) + list(kid); + else + scalar(kid); op = ck_fun(op); if (error_count) return op; - kid = cLISTOP->op_first->op_sibling; + kid = cLISTOP->op_first->op_sibling; if (kid->op_type != OP_NULL) croak("panic: ck_grep"); kid = kUNOP->op_first; - Newz(1101, gwop, 1, LOGOP); - gwop->op_type = OP_GREPWHILE; - gwop->op_ppaddr = ppaddr[OP_GREPWHILE]; - gwop->op_first = list(op); + gwop->op_type = type; + gwop->op_ppaddr = ppaddr[type]; + gwop->op_first = listkids(op); gwop->op_flags |= OPf_KIDS; gwop->op_private = 1; gwop->op_other = LINKLIST(kid); - gwop->op_targ = pad_alloc(OP_GREPWHILE, SVs_PADTMP); + gwop->op_targ = pad_alloc(type, SVs_PADTMP); kid->op_next = (OP*)gwop; + kid = cLISTOP->op_first->op_sibling; + if (!kid || !kid->op_sibling) + return too_few_arguments(op,op_desc[op->op_type]); + for (kid = kid->op_sibling; kid; kid = kid->op_sibling) + mod(kid, OP_GREPSTART); + return (OP*)gwop; } @@ -3008,7 +4172,7 @@ OP *op; if (op->op_flags & OPf_KIDS) { OP *kid = cLISTOP->op_first->op_sibling; /* get past pushmark */ if (kid && kid->op_type == OP_CONST) - fbm_compile(((SVOP*)kid)->op_sv, 0); + fbm_compile(((SVOP*)kid)->op_sv); } return ck_fun(op); } @@ -3018,21 +4182,23 @@ ck_lengthconst(op) OP *op; { /* XXX length optimization goes here */ - return op; + return ck_fun(op); } OP * ck_lfun(op) OP *op; { - return modkids(ck_fun(op), op->op_type); + OPCODE type = op->op_type; + return modkids(ck_fun(op), type); } OP * ck_rfun(op) OP *op; { - return refkids(ck_fun(op), op->op_type); + OPCODE type = op->op_type; + return refkids(ck_fun(op), type); } OP * @@ -3053,7 +4219,7 @@ OP *op; else if (kid && !kid->op_sibling) { /* print HANDLE; */ if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) { op->op_flags |= OPf_STACKED; /* make it a filehandle */ - kid = newUNOP(OP_RV2GV, 0, scalar(kid)); + kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid)); cLISTOP->op_first->op_sibling = kid; cLISTOP->op_last = kid; kid = kid->op_sibling; @@ -3063,7 +4229,43 @@ OP *op; if (!kid) append_elem(op->op_type, op, newSVREF(newGVOP(OP_GV, 0, defgv)) ); - return listkids(op); + op = listkids(op); + + op->op_private = 0; +#ifdef USE_LOCALE + if (hints & HINT_LOCALE) + op->op_private |= OPpLOCALE; +#endif + + return op; +} + +OP * +ck_fun_locale(op) +OP *op; +{ + op = ck_fun(op); + + op->op_private = 0; +#ifdef USE_LOCALE + if (hints & HINT_LOCALE) + op->op_private |= OPpLOCALE; +#endif + + return op; +} + +OP * +ck_scmp(op) +OP *op; +{ + op->op_private = 0; +#ifdef USE_LOCALE + if (hints & HINT_LOCALE) + op->op_private |= OPpLOCALE; +#endif + + return op; } OP * @@ -3071,6 +4273,7 @@ ck_match(op) OP *op; { cPMOP->op_pmflags |= PMf_RUNTIME; + cPMOP->op_pmpermflags |= PMf_RUNTIME; return op; } @@ -3086,7 +4289,7 @@ ck_repeat(op) OP *op; { if (cBINOP->op_first->op_flags & OPf_PARENS) { - op->op_private = OPpREPEAT_DOLIST; + op->op_private |= OPpREPEAT_DOLIST; cBINOP->op_first = force_list(cBINOP->op_first); } else @@ -3098,24 +4301,19 @@ OP * ck_require(op) OP *op; { - if (op->op_flags & OPf_KIDS) { /* Shall we fake a BEGIN {}? */ + if (op->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */ SVOP *kid = (SVOP*)cUNOP->op_first; if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { - char *name = SvPVX(subname); char *s; - sv_catpvn(kid->op_sv, ".pm", 3); - if (s = strrchr(name,':')) - s++; - else - s = name; - if (strNE(s, "BEGIN")) { - op = newSTATEOP(0, Nullch, op); - newSUB(start_subparse(), - newSVOP(OP_CONST, 0, newSVpv("BEGIN", 5)), - op); - return newOP(OP_STUB,0); + for (s = SvPVX(kid->op_sv); *s; s++) { + if (*s == ':' && s[1] == ':') { + *s = '/'; + Move(s+2, s+1, strlen(s+2)+1, char); + --SvCUR(kid->op_sv); + } } + sv_catpvn(kid->op_sv, ".pm", 3); } } return ck_fun(op); @@ -3134,8 +4332,9 @@ OP * ck_select(op) OP *op; { + OP* kid; if (op->op_flags & OPf_KIDS) { - OP *kid = cLISTOP->op_first->op_sibling; /* get past pushmark */ + kid = cLISTOP->op_first->op_sibling; /* get past pushmark */ if (kid && kid->op_sibling) { op->op_type = OP_SSELECT; op->op_ppaddr = ppaddr[OP_SSELECT]; @@ -3143,7 +4342,11 @@ OP *op; return fold_constants(op); } } - return ck_fun(op); + op = ck_fun(op); + kid = cLISTOP->op_first->op_sibling; /* get past pushmark */ + if (kid && kid->op_type == OP_RV2GV) + kid->op_private &= ~HINT_STRICT_REFS; + return op; } OP * @@ -3156,8 +4359,9 @@ OP *op; op_free(op); return newUNOP(type, 0, scalar(newUNOP(OP_RV2AV, 0, - scalar(newGVOP(OP_GV, 0, - gv_fetchpv((subline ? "_" : "ARGV"), TRUE) ))))); + scalar(newGVOP(OP_GV, 0, subline + ? defgv + : gv_fetchpv("ARGV", TRUE, SVt_PVAV) ))))); } return scalar(modkids(ck_fun(op), type)); } @@ -3166,6 +4370,12 @@ OP * ck_sort(op) OP *op; { + op->op_private = 0; +#ifdef USE_LOCALE + if (hints & HINT_LOCALE) + op->op_private |= OPpLOCALE; +#endif + if (op->op_flags & OPf_STACKED) { OP *kid = cLISTOP->op_first->op_sibling; /* get past pushmark */ OP *k; @@ -3176,24 +4386,33 @@ OP *op; if (kid->op_type == OP_SCOPE) { k = kid->op_next; kid->op_next = 0; - peep(k); } else if (kid->op_type == OP_LEAVE) { - null(kid); /* wipe out leave */ - kid->op_next = kid; + if (op->op_type == OP_SORT) { + null(kid); /* wipe out leave */ + kid->op_next = kid; - for (k = kLISTOP->op_first->op_next; k; k = k->op_next) { - if (k->op_next == kid) - k->op_next = 0; + for (k = kLISTOP->op_first->op_next; k; k = k->op_next) { + if (k->op_next == kid) + k->op_next = 0; + } } - peep(kLISTOP->op_first); + else + kid->op_next = 0; /* just disconnect the leave */ + k = kLISTOP->op_first; } + peep(k); + kid = cLISTOP->op_first->op_sibling; /* get past pushmark */ null(kid); /* wipe out rv2gv */ - kid->op_next = kid; + if (op->op_type == OP_SORT) + kid->op_next = kid; + else + kid->op_next = k; op->op_flags |= OPf_SPECIAL; } } + return op; } @@ -3213,8 +4432,10 @@ OP *op; kid = kid->op_sibling; op_free(cLISTOP->op_first); cLISTOP->op_first = kid; - if (!kid) + if (!kid) { cLISTOP->op_first = kid = newSVOP(OP_CONST, 0, newSVpv(" ", 1)); + cLISTOP->op_last = kid; /* There was only one element previously */ + } if (kid->op_type != OP_MATCH) { OP *sibl = kid->op_sibling; @@ -3248,7 +4469,7 @@ OP *op; scalar(kid); if (kid->op_sibling) - return too_many_arguments(op); + return too_many_arguments(op,op_desc[op->op_type]); return op; } @@ -3257,14 +4478,123 @@ OP * ck_subr(op) OP *op; { - OP *o = ((cUNOP->op_first->op_sibling) - ? cUNOP : ((UNOP*)cUNOP->op_first))->op_first->op_sibling; - - if (o->op_type == OP_RV2CV) - null(o); /* disable rv2cv */ - op->op_private = 0; + OP *prev = ((cUNOP->op_first->op_sibling) + ? cUNOP : ((UNOP*)cUNOP->op_first))->op_first; + OP *o = prev->op_sibling; + OP *cvop; + char *proto = 0; + CV *cv = 0; + GV *namegv = 0; + int optional = 0; + I32 arg = 0; + + for (cvop = o; cvop->op_sibling; cvop = cvop->op_sibling) ; + if (cvop->op_type == OP_RV2CV) { + SVOP* tmpop; + op->op_private |= (cvop->op_private & OPpENTERSUB_AMPER); + null(cvop); /* disable rv2cv */ + tmpop = (SVOP*)((UNOP*)cvop)->op_first; + if (tmpop->op_type == OP_GV) { + cv = GvCVu(tmpop->op_sv); + if (cv && SvPOK(cv) && !(op->op_private & OPpENTERSUB_AMPER)) { + namegv = CvANON(cv) ? (GV*)tmpop->op_sv : CvGV(cv); + proto = SvPV((SV*)cv, na); + } + } + } + op->op_private |= (hints & HINT_STRICT_REFS); if (perldb && curstash != debstash) - op->op_private |= OPpSUBR_DB; + op->op_private |= OPpENTERSUB_DB; + while (o != cvop) { + if (proto) { + switch (*proto) { + case '\0': + return too_many_arguments(op, gv_ename(namegv)); + case ';': + optional = 1; + proto++; + continue; + case '$': + proto++; + arg++; + scalar(o); + break; + case '%': + case '@': + list(o); + arg++; + break; + case '&': + proto++; + arg++; + if (o->op_type != OP_REFGEN && o->op_type != OP_UNDEF) + bad_type(arg, "block", gv_ename(namegv), o); + break; + case '*': + proto++; + arg++; + if (o->op_type == OP_RV2GV) + goto wrapref; + { + OP* kid = o; + o = newUNOP(OP_RV2GV, 0, kid); + o->op_sibling = kid->op_sibling; + kid->op_sibling = 0; + prev->op_sibling = o; + } + goto wrapref; + case '\\': + proto++; + arg++; + switch (*proto++) { + case '*': + if (o->op_type != OP_RV2GV) + bad_type(arg, "symbol", gv_ename(namegv), o); + goto wrapref; + case '&': + if (o->op_type != OP_RV2CV) + bad_type(arg, "sub", gv_ename(namegv), o); + goto wrapref; + case '$': + if (o->op_type != OP_RV2SV && o->op_type != OP_PADSV) + bad_type(arg, "scalar", gv_ename(namegv), o); + goto wrapref; + case '@': + if (o->op_type != OP_RV2AV && o->op_type != OP_PADAV) + bad_type(arg, "array", gv_ename(namegv), o); + goto wrapref; + case '%': + if (o->op_type != OP_RV2HV && o->op_type != OP_PADHV) + bad_type(arg, "hash", gv_ename(namegv), o); + wrapref: + { + OP* kid = o; + o = newUNOP(OP_REFGEN, 0, kid); + o->op_sibling = kid->op_sibling; + kid->op_sibling = 0; + prev->op_sibling = o; + } + break; + default: goto oops; + } + break; + case ' ': + proto++; + continue; + default: + oops: + croak("Malformed prototype for %s: %s", + gv_ename(namegv), SvPV((SV*)cv, na)); + } + } + else + list(o); + mod(o, OP_ENTERSUB); + prev = o; + o = o->op_sibling; + } + if (proto && !optional && *proto == '$') + return too_few_arguments(op, gv_ename(namegv)); return op; } @@ -3283,7 +4613,10 @@ OP *op; if (op->op_flags & OPf_KIDS) { SVOP *kid = (SVOP*)cUNOP->op_first; - if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) + if (kid->op_type == OP_NULL) + kid = (SVOP*)kid->op_sibling; + if (kid && + kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) op->op_flags |= OPf_SPECIAL; } return ck_fun(op); @@ -3292,83 +4625,114 @@ OP *op; /* A peephole optimizer. We visit the ops in the order they're to execute. */ void -peep(op) -register OP* op; +peep(o) +register OP* o; { register OP* oldop = 0; - if (!op || op->op_seq) + if (!o || o->op_seq) return; - for (; op; op = op->op_next) { - if (op->op_seq) - return; - switch (op->op_type) { + ENTER; + SAVESPTR(op); + SAVESPTR(curcop); + for (; o; o = o->op_next) { + if (o->op_seq) + break; + if (!op_seqmax) + op_seqmax++; + op = o; + switch (o->op_type) { + case OP_NEXTSTATE: + case OP_DBSTATE: + curcop = ((COP*)o); /* for warnings */ + o->op_seq = op_seqmax++; + break; + + case OP_CONCAT: + case OP_CONST: + case OP_JOIN: + case OP_UC: + case OP_UCFIRST: + case OP_LC: + case OP_LCFIRST: + case OP_QUOTEMETA: + if (o->op_next->op_type == OP_STRINGIFY) + null(o->op_next); + o->op_seq = op_seqmax++; + break; case OP_STUB: - if ((op->op_flags & (OPf_KNOW|OPf_LIST)) != (OPf_KNOW|OPf_LIST)) { - op->op_seq = ++op_seqmax; - break; /* Scalar stub must produce undef. List stub is noop */ + if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) { + o->op_seq = op_seqmax++; + break; /* Scalar stub must produce undef. List stub is noop */ } - /* FALL THROUGH */ + goto nothin; case OP_NULL: + if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE) + curcop = ((COP*)op); + goto nothin; case OP_SCALAR: case OP_LINESEQ: case OP_SCOPE: - if (oldop) { - oldop->op_next = op->op_next; + nothin: + if (oldop && o->op_next) { + oldop->op_next = o->op_next; continue; } - op->op_seq = ++op_seqmax; + o->op_seq = op_seqmax++; break; case OP_GV: - if (op->op_next->op_type == OP_RV2SV) { - if (op->op_next->op_private < OP_RV2GV) { - null(op->op_next); - op->op_flags |= op->op_next->op_flags & OPf_INTRO; - op->op_next = op->op_next->op_next; - op->op_type = OP_GVSV; - op->op_ppaddr = ppaddr[OP_GVSV]; + if (o->op_next->op_type == OP_RV2SV) { + if (!(o->op_next->op_private & OPpDEREF)) { + null(o->op_next); + o->op_private |= o->op_next->op_private & OPpLVAL_INTRO; + o->op_next = o->op_next->op_next; + o->op_type = OP_GVSV; + o->op_ppaddr = ppaddr[OP_GVSV]; } } - else if (op->op_next->op_type == OP_RV2AV) { - OP* pop = op->op_next->op_next; - I32 i; + else if (o->op_next->op_type == OP_RV2AV) { + OP* pop = o->op_next->op_next; + IV i; if (pop->op_type == OP_CONST && + (op = pop->op_next) && pop->op_next->op_type == OP_AELEM && - pop->op_next->op_private < OP_RV2GV && - !(pop->op_next->op_flags & OPf_INTRO) && - (i = SvIV(((SVOP*)pop)->op_sv)) <= 255 && + !(pop->op_next->op_private & + (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF)) && + (i = SvIV(((SVOP*)pop)->op_sv) - compiling.cop_arybase) + <= 255 && i >= 0) { - null(op->op_next); + SvREFCNT_dec(((SVOP*)pop)->op_sv); + null(o->op_next); null(pop->op_next); null(pop); - op->op_flags &= ~OPf_LVAL; - op->op_flags |= pop->op_next->op_flags & OPf_LVAL; - op->op_next = pop->op_next->op_next; - op->op_type = OP_AELEMFAST; - op->op_ppaddr = ppaddr[OP_AELEMFAST]; - op->op_private = i; - GvAVn((GV*)cSVOP->op_sv); + o->op_flags |= pop->op_next->op_flags & OPf_MOD; + o->op_next = pop->op_next->op_next; + o->op_type = OP_AELEMFAST; + o->op_ppaddr = ppaddr[OP_AELEMFAST]; + o->op_private = (U8)i; + GvAVn(((GVOP*)o)->op_gv); } } - op->op_seq = ++op_seqmax; + o->op_seq = op_seqmax++; break; + case OP_MAPWHILE: case OP_GREPWHILE: case OP_AND: case OP_OR: - op->op_seq = ++op_seqmax; + o->op_seq = op_seqmax++; peep(cLOGOP->op_other); break; case OP_COND_EXPR: - op->op_seq = ++op_seqmax; + o->op_seq = op_seqmax++; peep(cCONDOP->op_true); peep(cCONDOP->op_false); break; case OP_ENTERLOOP: - op->op_seq = ++op_seqmax; + o->op_seq = op_seqmax++; peep(cLOOP->op_redoop); peep(cLOOP->op_nextop); peep(cLOOP->op_lastop); @@ -3376,14 +4740,29 @@ register OP* op; case OP_MATCH: case OP_SUBST: - op->op_seq = ++op_seqmax; - peep(cPMOP->op_pmreplroot); + o->op_seq = op_seqmax++; + peep(cPMOP->op_pmreplstart); break; + case OP_EXEC: + o->op_seq = op_seqmax++; + if (dowarn && o->op_next && o->op_next->op_type == OP_NEXTSTATE) { + if (o->op_next->op_sibling && + o->op_next->op_sibling->op_type != OP_DIE) { + line_t oldline = curcop->cop_line; + + curcop->cop_line = ((COP*)o->op_next)->cop_line; + warn("Statement unlikely to be reached"); + warn("(Maybe you meant system() when you said exec()?)\n"); + curcop->cop_line = oldline; + } + } + break; default: - op->op_seq = ++op_seqmax; + o->op_seq = op_seqmax++; break; } - oldop = op; + oldop = o; } + LEAVE; }