X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=3bd44fc280d36931409ea038595f33242f7b5aa6;hb=1d64a758d60d7ded97c59c753fea85d3365ca0df;hp=db97cb64cb936cdf4ebfae4cfdc7c106ba9fdfb9;hpb=6bbcb22c3aeb67c92a6ca7dbdd7c51c54615d260;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index db97cb6..3bd44fc 100644 --- a/op.c +++ b/op.c @@ -1,6 +1,6 @@ /* op.c * - * Copyright (c) 1991-1994, 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. @@ -18,94 +18,83 @@ #include "EXTERN.h" #include "perl.h" -#define USE_OP_MASK /* Turned on by default in 5.002beta1h */ - -#ifdef USE_OP_MASK /* - * In the following definition, the ", (OP *) op" is just to make the compiler + * In the following definition, the ", Nullop" is just to make the compiler * think the expression is of the right type: croak actually does a Siglongjmp. */ -#define CHECKOP(type,op) \ +#define CHECKOP(type,o) \ ((op_mask && op_mask[type]) \ - ? ( op_free((OP*)op), \ + ? ( op_free((OP*)o), \ 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 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)); + : (*check[type])((OP*)o)) + +static I32 list_assignment _((OP *o)); +static void bad_type _((I32 n, char *t, char *name, OP *kid)); +static OP *modkids _((OP *o, I32 type)); +static OP *no_fh_allowed _((OP *o)); +static bool scalar_mod_type _((OP *o, I32 type)); +static OP *scalarboolean _((OP *o)); +static OP *too_few_arguments _((OP *o, char* name)); +static OP *too_many_arguments _((OP *o, char* name)); +static void null _((OP* o)); static PADOFFSET pad_findlex _((char* name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix)); static char* -CvNAME(cv) -CV* cv; +gv_ename(gv) +GV* gv; { SV* tmpsv = sv_newmortal(); - gv_efullname3(tmpsv, CvGV(cv), Nullch); + gv_efullname3(tmpsv, gv, Nullch); return SvPV(tmpsv,na); } static OP * -no_fh_allowed(op) -OP *op; +no_fh_allowed(o) +OP *o; { - sprintf(tokenbuf,"Missing comma after first argument to %s function", - op_desc[op->op_type]); - yyerror(tokenbuf); - return op; + yyerror(form("Missing comma after first argument to %s function", + op_desc[o->op_type])); + return o; } static OP * -too_few_arguments(op, name) -OP* op; +too_few_arguments(o, name) +OP* o; char* name; { - sprintf(tokenbuf,"Not enough arguments for %s", name); - yyerror(tokenbuf); - return op; + yyerror(form("Not enough arguments for %s", name)); + return o; } static OP * -too_many_arguments(op, name) -OP *op; +too_many_arguments(o, name) +OP *o; char* name; { - sprintf(tokenbuf,"Too many arguments for %s", name); - yyerror(tokenbuf); - return op; + yyerror(form("Too many arguments for %s", name)); + return o; } -static OP * +static void bad_type(n, t, name, kid) I32 n; char *t; char *name; OP *kid; { - sprintf(tokenbuf, "Type of arg %d to %s must be %s (not %s)", - (int) n, name, t, op_desc[kid->op_type]); - yyerror(tokenbuf); - return op; + yyerror(form("Type of arg %d to %s must be %s (not %s)", + (int)n, name, t, op_desc[kid->op_type])); } void -assertref(op) -OP *op; +assertref(o) +OP *o; { - int type = op->op_type; + int type = o->op_type; if (type != OP_AELEM && type != OP_HELEM) { - sprintf(tokenbuf, "Can't use subscript on %s", op_desc[type]); - yyerror(tokenbuf); + 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 ? '&' : '%'); @@ -118,15 +107,19 @@ PADOFFSET pad_allocmy(name) char *name; { + dTHR; PADOFFSET off; SV *sv; if (!(isALPHA(name[1]) || name[1] == '_' && (int)strlen(name) > 2)) { - if (!isPRINT(name[1])) - sprintf(name+1, "^%c", toCTRL(name[1])); /* XXX tokenbuf, really */ + 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) { + if (dowarn && AvFILL(comppad_name) >= 0) { SV **svp = AvARRAY(comppad_name); for (off = AvFILL(comppad_name); off > comppad_name_floor; off--) { if ((sv = svp[off]) @@ -143,6 +136,14 @@ char *name; sv = NEWSV(1102,0); sv_upgrade(sv, SVt_PVNV); sv_setpv(sv, name); + if (in_my_stash) { + if (*name != '$') + croak("Can't declare class for non-scalar %s in \"my\"",name); + SvOBJECT_on(sv); + (void)SvUPGRADE(sv, SVt_PVMG); + SvSTASH(sv) = (HV*)SvREFCNT_inc(in_my_stash); + sv_objcount++; + } av_store(comppad_name, off, sv); SvNVX(sv) = (double)999999999; SvIVX(sv) = 0; /* Not yet introduced--see newSTATEOP */ @@ -169,6 +170,7 @@ I32 cx_ix; pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix) #endif { + dTHR; CV *cv; I32 off; SV *sv; @@ -188,7 +190,6 @@ pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix) for (off = AvFILL(curname); off > 0; off--) { if ((sv = svp[off]) && sv != &sv_undef && - !SvFAKE(sv) && seq <= SvIVX(sv) && seq > I_32(SvNVX(sv)) && strEQ(SvPVX(sv), name)) @@ -199,25 +200,32 @@ pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix) depth = CvDEPTH(cv); if (!depth) { - if (newoff) + 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 *sv = NEWSV(1103,0); + SV *namesv = NEWSV(1103,0); newoff = pad_alloc(OP_PADSV, SVs_PADMY); - 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 */ - SvFAKE_on(sv); /* A ref, not a real var */ + 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 (cv == startcv) { + if (CvANON(compcv)) + oldsv = Nullsv; /* no need to keep ref */ + } + else { CV *bcv; for (bcv = startcv; bcv && bcv != cv && !CvCLONE(bcv); @@ -235,7 +243,7 @@ pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix) } } else if (!CvUNIQUE(compcv)) { - if (dowarn && !CvUNIQUE(cv)) + if (dowarn && !SvFAKE(sv) && !CvUNIQUE(cv)) warn("Variable \"%s\" will not stay shared", name); } } @@ -290,29 +298,50 @@ PADOFFSET pad_findmy(name) char *name; { + dTHR; I32 off; + I32 pendoff = 0; SV *sv; SV **svp = AvARRAY(comppad_name); U32 seq = cop_seqmax; +#ifdef USE_THREADS + /* + * Special case to get lexical (and hence per-thread) @_. + * XXX I need to find out how to tell at parse-time whether use + * of @_ should refer to a lexical (from a sub) or defgv (global + * scope and maybe weird sub-ish things like formats). See + * startsub in perly.y. It's possible that @_ could be lexical + * (at least from subs) even in non-threaded perl. + */ + if (strEQ(name, "@_")) + return 0; /* success. (NOT_IN_PAD indicates failure) */ +#endif /* USE_THREADS */ + /* 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 && - seq <= SvIVX(sv) && - seq > I_32(SvNVX(sv)) && + (!SvIVX(sv) || + (seq <= SvIVX(sv) && + seq > I_32(SvNVX(sv)))) && strEQ(SvPVX(sv), name)) { - return (PADOFFSET)off; + 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) - return off; - - return 0; + if (off) { + /* If there is a pending local definition, this new alias must die */ + if (pendoff) + SvIVX(AvARRAY(comppad_name)[off]) = seq; + return off; /* pad_findlex returns 0 for failure...*/ + } + return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */ } void @@ -340,6 +369,7 @@ pad_alloc(optype,tmptype) I32 optype; U32 tmptype; { + dTHR; SV *sv; I32 retval; @@ -373,7 +403,14 @@ U32 tmptype; } SvFLAGS(sv) |= tmptype; curpad = AvARRAY(comppad); - DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad alloc %ld for %s\n", (long) retval, op_name[optype])); +#ifdef USE_THREADS + DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx alloc %ld for %s\n", + (unsigned long) thr, (unsigned long) curpad, + (long) retval, op_name[optype])); +#else + DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad alloc %ld for %s\n", + (long) retval, op_name[optype])); +#endif /* USE_THREADS */ return (PADOFFSET)retval; } @@ -385,9 +422,15 @@ PADOFFSET po; pad_sv(PADOFFSET po) #endif /* CAN_PROTOTYPE */ { + dTHR; +#ifdef USE_THREADS + DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx sv %d\n", + (unsigned long) thr, (unsigned long) curpad, po)); +#else if (!po) croak("panic: pad_sv po"); DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad sv %d\n", po)); +#endif /* USE_THREADS */ return curpad[po]; /* eventually we'll turn this into a macro */ } @@ -399,14 +442,20 @@ PADOFFSET po; pad_free(PADOFFSET po) #endif /* CAN_PROTOTYPE */ { + dTHR; if (!curpad) return; if (AvARRAY(comppad) != curpad) croak("panic: pad_free curpad"); if (!po) croak("panic: pad_free po"); +#ifdef USE_THREADS + DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx free %d\n", + (unsigned long) thr, (unsigned long) curpad, po)); +#else DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad free %d\n", po)); - if (curpad[po] && !SvIMMORTAL(curpad[po])) +#endif /* USE_THREADS */ + if (curpad[po] && curpad[po] != &sv_undef) SvPADTMP_off(curpad[po]); if ((I32)po < padix) padix = po - 1; @@ -420,11 +469,17 @@ PADOFFSET po; pad_swipe(PADOFFSET po) #endif /* CAN_PROTOTYPE */ { + dTHR; if (AvARRAY(comppad) != curpad) croak("panic: pad_swipe curpad"); if (!po) croak("panic: pad_swipe po"); +#ifdef USE_THREADS + DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx swipe %d\n", + (unsigned long) thr, (unsigned long) curpad, po)); +#else DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad swipe %d\n", po)); +#endif /* USE_THREADS */ SvPADTMP_off(curpad[po]); curpad[po] = NEWSV(1107,0); SvPADTMP_on(curpad[po]); @@ -435,11 +490,17 @@ pad_swipe(PADOFFSET po) void pad_reset() { + dTHR; register I32 po; if (AvARRAY(comppad) != curpad) croak("panic: pad_reset curpad"); +#ifdef USE_THREADS + DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx reset\n", + (unsigned long) thr, (unsigned long) curpad)); +#else DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad reset\n")); +#endif /* USE_THREADS */ if (!tainting) { /* Can't mix tainted and non-tainted temporaries. */ for (po = AvMAX(comppad); po > padix_floor; po--) { if (curpad[po] && !SvIMMORTAL(curpad[po])) @@ -450,83 +511,127 @@ pad_reset() pad_reset_pending = FALSE; } +#ifdef USE_THREADS +/* find_thread_magical is not reentrant */ +PADOFFSET +find_thread_magical(name) +char *name; +{ + dTHR; + char *p; + PADOFFSET key; + SV **svp; + /* We currently only handle single character magicals */ + p = strchr(per_thread_magicals, *name); + if (!p) + return NOT_IN_PAD; + key = p - per_thread_magicals; + svp = av_fetch(thr->magicals, key, FALSE); + if (!svp) { + SV *sv = NEWSV(0, 0); + av_store(thr->magicals, key, sv); + /* + * Some magic variables used to be automagically initialised + * in gv_fetchpv. Those which are now per-thread magicals get + * initialised here instead. + */ + switch (*name) { + case ';': + sv_setpv(sv, "\034"); + break; + } + sv_magic(sv, 0, 0, name, 1); + DEBUG_L(PerlIO_printf(PerlIO_stderr(), + "find_thread_magical: new SV %p for $%s%c\n", + sv, (*name < 32) ? "^" : "", + (*name < 32) ? toCTRL(*name) : *name)); + } + return key; +} +#endif /* USE_THREADS */ + /* Destructor */ void -op_free(op) -OP *op; +op_free(o) +OP *o; { register OP *kid, *nextkid; - if (!op || op->op_seq == (U16)-1) + if (!o || o->op_seq == (U16)-1) return; - if (op->op_flags & OPf_KIDS) { - for (kid = cUNOP->op_first; kid; kid = nextkid) { + if (o->op_flags & OPf_KIDS) { + for (kid = cUNOPo->op_first; kid; kid = nextkid) { nextkid = kid->op_sibling; /* Get before next freeing kid */ op_free(kid); } } - switch (op->op_type) { + switch (o->op_type) { case OP_NULL: - op->op_targ = 0; /* Was holding old type, if any. */ + o->op_targ = 0; /* Was holding old type, if any. */ break; case OP_ENTEREVAL: - op->op_targ = 0; /* Was holding hints. */ + o->op_targ = 0; /* Was holding hints. */ break; +#ifdef USE_THREADS + case OP_SPECIFIC: + o->op_targ = 0; /* Was holding index into thr->magicals AV. */ + break; +#endif /* USE_THREADS */ default: - if (!(op->op_flags & OPf_REF) || (check[op->op_type] != ck_ftst)) + if (!(o->op_flags & OPf_REF) || (check[o->op_type] != ck_ftst)) break; /* FALL THROUGH */ case OP_GVSV: case OP_GV: case OP_AELEMFAST: - SvREFCNT_dec(cGVOP->op_gv); + SvREFCNT_dec(cGVOPo->op_gv); break; case OP_NEXTSTATE: case OP_DBSTATE: - Safefree(cCOP->cop_label); - SvREFCNT_dec(cCOP->cop_filegv); + Safefree(cCOPo->cop_label); + SvREFCNT_dec(cCOPo->cop_filegv); break; case OP_CONST: - SvREFCNT_dec(cSVOP->op_sv); + SvREFCNT_dec(cSVOPo->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)) + if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS)) break; /* FALL THROUGH */ case OP_TRANS: - Safefree(cPVOP->op_pv); + Safefree(cPVOPo->op_pv); break; case OP_SUBST: - op_free(cPMOP->op_pmreplroot); + op_free(cPMOPo->op_pmreplroot); /* FALL THROUGH */ case OP_PUSHRE: case OP_MATCH: - pregfree(cPMOP->op_pmregexp); - SvREFCNT_dec(cPMOP->op_pmshort); + pregfree(cPMOPo->op_pmregexp); + SvREFCNT_dec(cPMOPo->op_pmshort); break; } - if (op->op_targ > 0) - pad_free(op->op_targ); + if (o->op_targ > 0) + pad_free(o->op_targ); - Safefree(op); + Safefree(o); } static void -null(op) -OP* op; +null(o) +OP* o; { - if (op->op_type != OP_NULL && op->op_targ > 0) - pad_free(op->op_targ); - op->op_targ = op->op_type; - op->op_type = OP_NULL; - op->op_ppaddr = ppaddr[OP_NULL]; + if (o->op_type != OP_NULL && o->op_targ > 0) + pad_free(o->op_targ); + o->op_targ = o->op_type; + o->op_type = OP_NULL; + o->op_ppaddr = ppaddr[OP_NULL]; } /* Contextualizers */ @@ -534,48 +639,49 @@ OP* op; #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o)) OP * -linklist(op) -OP *op; +linklist(o) +OP *o; { register OP *kid; - if (op->op_next) - return op->op_next; + if (o->op_next) + return o->op_next; /* establish postfix order */ - if (cUNOP->op_first) { - op->op_next = LINKLIST(cUNOP->op_first); - for (kid = cUNOP->op_first; kid; kid = kid->op_sibling) { + if (cUNOPo->op_first) { + o->op_next = LINKLIST(cUNOPo->op_first); + for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { if (kid->op_sibling) kid->op_next = LINKLIST(kid->op_sibling); else - kid->op_next = op; + kid->op_next = o; } } else - op->op_next = op; + o->op_next = o; - return op->op_next; + return o->op_next; } OP * -scalarkids(op) -OP *op; +scalarkids(o) +OP *o; { OP *kid; - if (op && op->op_flags & OPf_KIDS) { - for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) + if (o && o->op_flags & OPf_KIDS) { + for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) scalar(kid); } - return op; + return o; } static OP * -scalarboolean(op) -OP *op; +scalarboolean(o) +OP *o; { if (dowarn && - op->op_type == OP_SASSIGN && cBINOP->op_first->op_type == OP_CONST) { + o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) { + dTHR; line_t oldline = curcop->cop_line; if (copline != NOLINE) @@ -583,37 +689,36 @@ OP *op; warn("Found = in conditional, should be =="); curcop->cop_line = oldline; } - return scalar(op); + return scalar(o); } OP * -scalar(op) -OP *op; +scalar(o) +OP *o; { OP *kid; /* assumes no premature commitment */ - if (!op || (op->op_flags & OPf_KNOW) || op->op_type == OP_RETURN - || error_count) - return op; + if (!o || (o->op_flags & OPf_WANT) || error_count + || o->op_type == OP_RETURN) + return o; - op->op_flags &= ~OPf_LIST; - op->op_flags |= OPf_KNOW; + o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR; - switch (op->op_type) { + switch (o->op_type) { case OP_REPEAT: - if (op->op_private & OPpREPEAT_DOLIST) - null(((LISTOP*)cBINOP->op_first)->op_first); - scalar(cBINOP->op_first); + if (o->op_private & OPpREPEAT_DOLIST) + null(((LISTOP*)cBINOPo->op_first)->op_first); + scalar(cBINOPo->op_first); break; case OP_OR: case OP_AND: case OP_COND_EXPR: - for (kid = cUNOP->op_first->op_sibling; kid; kid = kid->op_sibling) + for (kid = cUNOPo->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 ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) { if (!kPMOP->op_pmreplroot) deprecate("implicit split to @_"); } @@ -622,52 +727,60 @@ OP *op; case OP_SUBST: case OP_NULL: default: - if (op->op_flags & OPf_KIDS) { - for (kid = cUNOP->op_first; kid; kid = kid->op_sibling) + if (o->op_flags & OPf_KIDS) { + for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) scalar(kid); } break; case OP_LEAVE: case OP_LEAVETRY: - scalar(cLISTOP->op_first); - /* FALL THROUGH */ + kid = cLISTOPo->op_first; + scalar(kid); + while (kid = kid->op_sibling) { + if (kid->op_sibling) + scalarvoid(kid); + else + scalar(kid); + } + WITH_THR(curcop = &compiling); + break; case OP_SCOPE: case OP_LINESEQ: case OP_LIST: - for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) { + for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { if (kid->op_sibling) scalarvoid(kid); else scalar(kid); } - curcop = &compiling; + WITH_THR(curcop = &compiling); break; } - return op; + return o; } OP * -scalarvoid(op) -OP *op; +scalarvoid(o) +OP *o; { OP *kid; char* useless = 0; SV* sv; - if (!op || error_count) - return op; - if (op->op_flags & OPf_LIST) - return op; + /* assumes no premature commitment */ + if (!o || (o->op_flags & OPf_WANT) == OPf_WANT_LIST || error_count + || o->op_type == OP_RETURN) + return o; - op->op_flags |= OPf_KNOW; + o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID; - switch (op->op_type) { + switch (o->op_type) { default: - if (!(opargs[op->op_type] & OA_FOLDCONST)) + if (!(opargs[o->op_type] & OA_FOLDCONST)) break; /* FALL THROUGH */ case OP_REPEAT: - if (op->op_flags & OPf_STACKED) + if (o->op_flags & OPf_STACKED) break; /* FALL THROUGH */ case OP_GVSV: @@ -738,26 +851,26 @@ OP *op; case OP_GGRNAM: case OP_GGRGID: case OP_GETLOGIN: - if (!(op->op_private & OPpLVAL_INTRO)) - useless = op_desc[op->op_type]; + if (!(o->op_private & OPpLVAL_INTRO)) + useless = op_desc[o->op_type]; break; case OP_RV2GV: case OP_RV2SV: case OP_RV2AV: case OP_RV2HV: - if (!(op->op_private & OPpLVAL_INTRO) && - (!op->op_sibling || op->op_sibling->op_type != OP_READLINE)) + if (!(o->op_private & OPpLVAL_INTRO) && + (!o->op_sibling || o->op_sibling->op_type != OP_READLINE)) useless = "a variable"; break; case OP_NEXTSTATE: case OP_DBSTATE: - curcop = ((COP*)op); /* for warning below */ + WITH_THR(curcop = ((COP*)o)); /* for warning below */ break; case OP_CONST: - sv = cSVOP->op_sv; + sv = cSVOPo->op_sv; if (dowarn) { useless = "a constant"; if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0)) @@ -769,187 +882,208 @@ OP *op; useless = 0; } } - null(op); /* don't execute a constant */ + null(o); /* don't execute a constant */ SvREFCNT_dec(sv); /* don't even remember it */ break; case OP_POSTINC: - op->op_type = OP_PREINC; /* pre-increment is faster */ - op->op_ppaddr = ppaddr[OP_PREINC]; + o->op_type = OP_PREINC; /* pre-increment is faster */ + o->op_ppaddr = ppaddr[OP_PREINC]; break; case OP_POSTDEC: - op->op_type = OP_PREDEC; /* pre-decrement is faster */ - op->op_ppaddr = ppaddr[OP_PREDEC]; + o->op_type = OP_PREDEC; /* pre-decrement is faster */ + o->op_ppaddr = ppaddr[OP_PREDEC]; break; case OP_OR: case OP_AND: case OP_COND_EXPR: - for (kid = cUNOP->op_first->op_sibling; kid; kid = kid->op_sibling) + for (kid = cUNOPo->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) + if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE) + WITH_THR(curcop = ((COP*)o)); /* for warning below */ + if (o->op_flags & OPf_STACKED) break; + /* FALL THROUGH */ case OP_ENTERTRY: case OP_ENTER: case OP_SCALAR: - if (!(op->op_flags & OPf_KIDS)) + if (!(o->op_flags & OPf_KIDS)) break; + /* FALL THROUGH */ case OP_SCOPE: case OP_LEAVE: case OP_LEAVETRY: case OP_LEAVELOOP: - op->op_private |= OPpLEAVE_VOID; case OP_LINESEQ: case OP_LIST: - for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) + for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) scalarvoid(kid); break; + case OP_ENTEREVAL: + scalarkids(o); + break; + case OP_REQUIRE: + /* all requires must return a boolean value */ + o->op_flags &= ~OPf_WANT; + return scalar(o); case OP_SPLIT: - if ((kid = ((LISTOP*)op)->op_first) && kid->op_type == OP_PUSHRE) { + if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) { if (!kPMOP->op_pmreplroot) deprecate("implicit split to @_"); } break; - case OP_KEYS: - case OP_VALUES: - case OP_DELETE: - op->op_private |= OPpLEAVE_VOID; - break; } if (useless && dowarn) warn("Useless use of %s in void context", useless); - return op; + return o; } OP * -listkids(op) -OP *op; +listkids(o) +OP *o; { OP *kid; - if (op && op->op_flags & OPf_KIDS) { - for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) + if (o && o->op_flags & OPf_KIDS) { + for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) list(kid); } - return op; + return o; } OP * -list(op) -OP *op; +list(o) +OP *o; { OP *kid; /* assumes no premature commitment */ - if (!op || (op->op_flags & OPf_KNOW) || op->op_type == OP_RETURN - || error_count) - return op; + if (!o || (o->op_flags & OPf_WANT) || error_count + || o->op_type == OP_RETURN) + return o; - op->op_flags |= (OPf_KNOW | OPf_LIST); + o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST; - switch (op->op_type) { + switch (o->op_type) { case OP_FLOP: case OP_REPEAT: - list(cBINOP->op_first); + list(cBINOPo->op_first); break; case OP_OR: case OP_AND: case OP_COND_EXPR: - for (kid = cUNOP->op_first->op_sibling; kid; kid = kid->op_sibling) + for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) list(kid); break; default: case OP_MATCH: case OP_SUBST: case OP_NULL: - if (!(op->op_flags & OPf_KIDS)) + if (!(o->op_flags & OPf_KIDS)) break; - if (!op->op_next && cUNOP->op_first->op_type == OP_FLOP) { - list(cBINOP->op_first); - return gen_constant_list(op); + if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) { + list(cBINOPo->op_first); + return gen_constant_list(o); } case OP_LIST: - listkids(op); + listkids(o); break; case OP_LEAVE: case OP_LEAVETRY: - list(cLISTOP->op_first); - /* FALL THROUGH */ + kid = cLISTOPo->op_first; + list(kid); + while (kid = kid->op_sibling) { + if (kid->op_sibling) + scalarvoid(kid); + else + list(kid); + } + WITH_THR(curcop = &compiling); + break; case OP_SCOPE: case OP_LINESEQ: - for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) { + for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { if (kid->op_sibling) scalarvoid(kid); else list(kid); } - curcop = &compiling; + WITH_THR(curcop = &compiling); break; + case OP_REQUIRE: + /* all requires must return a boolean value */ + o->op_flags &= ~OPf_WANT; + return scalar(o); } - return op; + return o; } OP * -scalarseq(op) -OP *op; +scalarseq(o) +OP *o; { OP *kid; - if (op) { - if (op->op_type == OP_LINESEQ || - op->op_type == OP_SCOPE || - op->op_type == OP_LEAVE || - op->op_type == OP_LEAVETRY) + if (o) { + if (o->op_type == OP_LINESEQ || + o->op_type == OP_SCOPE || + o->op_type == OP_LEAVE || + o->op_type == OP_LEAVETRY) { - for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) { + dTHR; + for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { if (kid->op_sibling) { scalarvoid(kid); } } curcop = &compiling; } - op->op_flags &= ~OPf_PARENS; + o->op_flags &= ~OPf_PARENS; if (hints & HINT_BLOCK_SCOPE) - op->op_flags |= OPf_PARENS; + o->op_flags |= OPf_PARENS; } else - op = newOP(OP_STUB, 0); - return op; + o = newOP(OP_STUB, 0); + return o; } static OP * -modkids(op, type) -OP *op; +modkids(o, type) +OP *o; I32 type; { OP *kid; - if (op && op->op_flags & OPf_KIDS) { - for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) + if (o && o->op_flags & OPf_KIDS) { + for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) mod(kid, type); } - return op; + return o; } static I32 modcount; OP * -mod(op, type) -OP *op; +mod(o, type) +OP *o; I32 type; { + dTHR; OP *kid; SV *sv; - if (!op || error_count) - return op; + if (!o || error_count) + return o; - switch (op->op_type) { + switch (o->op_type) { + case OP_UNDEF: + modcount++; + return o; case OP_CONST: - if (!(op->op_private & (OPpCONST_ARYBASE))) + if (!(o->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); @@ -965,16 +1099,16 @@ I32 type; croak("That use of $[ is unsupported"); break; case OP_STUB: - if (op->op_flags & OPf_PARENS) + if (o->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]; - assert(cUNOP->op_first->op_type == OP_NULL); - null(((LISTOP*)cUNOP->op_first)->op_first); /* disable pushmark */ + !(o->op_flags & OPf_STACKED)) { + o->op_type = OP_RV2CV; /* entersub => rv2cv */ + o->op_ppaddr = ppaddr[OP_RV2CV]; + assert(cUNOPo->op_first->op_type == OP_NULL); + null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */ break; } /* FALL THROUGH */ @@ -983,11 +1117,10 @@ I32 type; /* grep, foreach, subcalls, refgen */ if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) break; - sprintf(tokenbuf, "Can't modify %s in %s", - op_desc[op->op_type], - type ? op_desc[type] : "local"); - yyerror(tokenbuf); - return op; + yyerror(form("Can't modify %s in %s", + op_desc[o->op_type], + type ? op_desc[type] : "local")); + return o; case OP_PREINC: case OP_PREDEC: @@ -1009,25 +1142,29 @@ I32 type; case OP_I_MODULO: case OP_I_ADD: case OP_I_SUBTRACT: - if (!(op->op_flags & OPf_STACKED)) + if (!(o->op_flags & OPf_STACKED)) goto nomod; modcount++; break; case OP_COND_EXPR: - for (kid = cUNOP->op_first->op_sibling; kid; kid = kid->op_sibling) + for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) mod(kid, type); break; case OP_RV2AV: case OP_RV2HV: - if (type == OP_REFGEN && op->op_flags & OPf_PARENS) { + if (!type && cUNOPo->op_first->op_type != OP_GV) + croak("Can't localize through a reference"); + if (type == OP_REFGEN && o->op_flags & OPf_PARENS) { modcount = 10000; - return op; /* Treat \(@foo) like ordinary list. */ + return o; /* Treat \(@foo) like ordinary list. */ } /* FALL THROUGH */ case OP_RV2GV: - ref(cUNOP->op_first, op->op_type); + if (scalar_mod_type(o, type)) + goto nomod; + ref(cUNOPo->op_first, o->op_type); /* FALL THROUGH */ case OP_AASSIGN: case OP_ASLICE: @@ -1039,11 +1176,10 @@ I32 type; modcount = 10000; break; case OP_RV2SV: - if (!type && cUNOP->op_first->op_type != OP_GV) - croak("Can't localize a reference"); - ref(cUNOP->op_first, op->op_type); + if (!type && cUNOPo->op_first->op_type != OP_GV) + croak("Can't localize through a reference"); + ref(cUNOPo->op_first, o->op_type); /* FALL THROUGH */ - case OP_UNDEF: case OP_GV: case OP_AV2ARYLEN: case OP_SASSIGN: @@ -1054,15 +1190,27 @@ I32 type; 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 (type == OP_REFGEN && o->op_flags & OPf_PARENS) + return o; /* Treat \(@foo) like ordinary list. */ + if (scalar_mod_type(o, 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)); + SvPV(*av_fetch(comppad_name, o->op_targ, 4), na)); + break; + +#ifdef USE_THREADS + case OP_SPECIFIC: + modcount++; /* XXX ??? */ +#if 0 + if (!type) + croak("Can't localize thread-specific variable"); +#endif break; +#endif /* USE_THREADS */ case OP_PUSHMARK: break; @@ -1074,130 +1222,183 @@ I32 type; case OP_POS: case OP_VEC: case OP_SUBSTR: - pad_free(op->op_targ); - op->op_targ = pad_alloc(op->op_type, SVs_PADMY); - assert(SvTYPE(PAD_SV(op->op_targ)) == SVt_NULL); - if (op->op_flags & OPf_KIDS) - mod(cBINOP->op_first->op_sibling, type); + pad_free(o->op_targ); + o->op_targ = pad_alloc(o->op_type, SVs_PADMY); + assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL); + if (o->op_flags & OPf_KIDS) + mod(cBINOPo->op_first->op_sibling, type); break; case OP_AELEM: case OP_HELEM: - ref(cBINOP->op_first, op->op_type); + ref(cBINOPo->op_first, o->op_type); + if (type == OP_ENTERSUB && + !(o->op_private & (OPpLVAL_INTRO | OPpDEREF))) + o->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); + if (o->op_flags & OPf_KIDS) + mod(cLISTOPo->op_last, type); break; case OP_NULL: - if (!(op->op_flags & OPf_KIDS)) + if (!(o->op_flags & OPf_KIDS)) break; - if (op->op_targ != OP_LIST) { - mod(cBINOP->op_first, type); + if (o->op_targ != OP_LIST) { + mod(cBINOPo->op_first, type); break; } /* FALL THROUGH */ case OP_LIST: - for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) + for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) mod(kid, type); break; } - op->op_flags |= OPf_MOD; + o->op_flags |= OPf_MOD; if (type == OP_AASSIGN || type == OP_SASSIGN) - op->op_flags |= OPf_SPECIAL|OPf_REF; + o->op_flags |= OPf_SPECIAL|OPf_REF; else if (!type) { - op->op_private |= OPpLVAL_INTRO; - op->op_flags &= ~OPf_SPECIAL; + o->op_private |= OPpLVAL_INTRO; + o->op_flags &= ~OPf_SPECIAL; } else if (type != OP_GREPSTART && type != OP_ENTERSUB) - op->op_flags |= OPf_REF; - return op; + o->op_flags |= OPf_REF; + return o; +} + +static bool +scalar_mod_type(o, type) +OP *o; +I32 type; +{ + switch (type) { + case OP_SASSIGN: + if (o->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; +refkids(o, type) +OP *o; I32 type; { OP *kid; - if (op && op->op_flags & OPf_KIDS) { - for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) + if (o && o->op_flags & OPf_KIDS) { + for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) ref(kid, type); } - return op; + return o; } OP * -ref(op, type) -OP *op; +ref(o, type) +OP *o; I32 type; { OP *kid; - if (!op || error_count) - return op; + if (!o || error_count) + return o; - switch (op->op_type) { + switch (o->op_type) { 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]; - assert(cUNOP->op_first->op_type == OP_NULL); - null(((LISTOP*)cUNOP->op_first)->op_first); /* disable pushmark */ - op->op_flags |= OPf_SPECIAL; + if ((type == OP_DEFINED || type == OP_LOCK) && + !(o->op_flags & OPf_STACKED)) { + o->op_type = OP_RV2CV; /* entersub => rv2cv */ + o->op_ppaddr = ppaddr[OP_RV2CV]; + assert(cUNOPo->op_first->op_type == OP_NULL); + null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */ + o->op_flags |= OPf_SPECIAL; } break; case OP_COND_EXPR: - for (kid = cUNOP->op_first->op_sibling; kid; kid = kid->op_sibling) + for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) ref(kid, type); break; case OP_RV2SV: - ref(cUNOP->op_first, op->op_type); + ref(cUNOPo->op_first, o->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; + o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV + : type == OP_RV2HV ? OPpDEREF_HV + : OPpDEREF_SV); + o->op_flags |= OPf_MOD; } break; + case OP_SPECIFIC: + o->op_flags |= OPf_MOD; /* XXX ??? */ + break; + case OP_RV2AV: case OP_RV2HV: - op->op_flags |= OPf_REF; + o->op_flags |= OPf_REF; /* FALL THROUGH */ case OP_RV2GV: - ref(cUNOP->op_first, op->op_type); + ref(cUNOPo->op_first, o->op_type); break; case OP_PADAV: case OP_PADHV: - op->op_flags |= OPf_REF; + o->op_flags |= OPf_REF; break; case OP_SCALAR: case OP_NULL: - if (!(op->op_flags & OPf_KIDS)) + if (!(o->op_flags & OPf_KIDS)) break; - ref(cBINOP->op_first, type); + ref(cBINOPo->op_first, type); break; case OP_AELEM: case OP_HELEM: - ref(cBINOP->op_first, op->op_type); + ref(cBINOPo->op_first, o->op_type); 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; + o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV + : type == OP_RV2HV ? OPpDEREF_HV + : OPpDEREF_SV); + o->op_flags |= OPf_MOD; } break; @@ -1205,30 +1406,30 @@ I32 type; case OP_LEAVE: case OP_ENTER: case OP_LIST: - if (!(op->op_flags & OPf_KIDS)) + if (!(o->op_flags & OPf_KIDS)) break; - ref(cLISTOP->op_last, type); + ref(cLISTOPo->op_last, type); break; default: break; } - return scalar(op); + return scalar(o); } OP * -my(op) -OP *op; +my(o) +OP *o; { OP *kid; I32 type; - if (!op || error_count) - return op; + if (!o || error_count) + return o; - type = op->op_type; + type = o->op_type; if (type == OP_LIST) { - for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) + for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) my(kid); } else if (type != OP_PADSV && @@ -1236,13 +1437,12 @@ OP *op; type != OP_PADHV && type != OP_PUSHMARK) { - sprintf(tokenbuf, "Can't declare %s in my", op_desc[op->op_type]); - yyerror(tokenbuf); - return op; + yyerror(form("Can't declare %s in my", op_desc[o->op_type])); + return o; } - op->op_flags |= OPf_MOD; - op->op_private |= OPpLVAL_INTRO; - return op; + o->op_flags |= OPf_MOD; + o->op_private |= OPpLVAL_INTRO; + return o; } OP * @@ -1260,7 +1460,21 @@ I32 type; OP *left; OP *right; { - OP *op; + OP *o; + + 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 || @@ -1269,12 +1483,12 @@ OP *right; if (right->op_type != OP_MATCH) left = mod(left, right->op_type); if (right->op_type == OP_TRANS) - op = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right); + o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right); else - op = prepend_elem(right->op_type, scalar(left), right); + o = prepend_elem(right->op_type, scalar(left), right); if (type == OP_NOT) - return newUNOP(OP_NOT, 0, scalar(op)); - return op; + return newUNOP(OP_NOT, 0, scalar(o)); + return o; } else return bind_match(type, left, @@ -1282,13 +1496,13 @@ OP *right; } OP * -invert(op) -OP *op; +invert(o) +OP *o; { - if (!op) - return op; + if (!o) + return o; /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */ - return newUNOP(OP_NOT, OPf_SPECIAL, scalar(op)); + return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o)); } OP * @@ -1296,7 +1510,7 @@ scope(o) OP *o; { if (o) { - if (o->op_flags & OPf_PARENS || perldb || tainting) { + if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || tainting) { o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o); o->op_type = OP_LEAVE; o->op_ppaddr = ppaddr[OP_LEAVE]; @@ -1323,6 +1537,7 @@ int block_start(full) int full; { + dTHR; int retval = savestack_ix; SAVEI32(comppad_name_floor); if (full) { @@ -1348,6 +1563,7 @@ block_end(floor, seq) I32 floor; OP* seq; { + dTHR; int needblockscope = hints & HINT_BLOCK_SCOPE; OP* retval = scalarseq(seq); LEAVE_SCOPE(floor); @@ -1360,19 +1576,20 @@ OP* seq; } void -newPROG(op) -OP *op; +newPROG(o) +OP *o; { + dTHR; if (in_eval) { - eval_root = newUNOP(OP_LEAVEEVAL, ((in_eval & 4) ? OPf_SPECIAL : 0), op); + eval_root = newUNOP(OP_LEAVEEVAL, ((in_eval & 4) ? OPf_SPECIAL : 0), o); eval_start = linklist(eval_root); eval_root->op_next = 0; peep(eval_start); } else { - if (!op) + if (!o) return; - main_root = scope(sawparens(scalarvoid(op))); + main_root = scope(sawparens(scalarvoid(o))); curcop = &compiling; main_start = LINKLIST(main_root); main_root->op_next = 0; @@ -1380,7 +1597,7 @@ OP *op; compcv = 0; /* Register with debugger */ - if (perldb) { + if (PERLDB_INTER) { CV *cv = perl_get_cv("DB::postponed", FALSE); if (cv) { dSP; @@ -1410,6 +1627,7 @@ I32 lex; } } in_my = FALSE; + in_my_stash = Nullhv; if (lex) return my(o); else @@ -1421,10 +1639,14 @@ jmaybe(o) 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, SVt_PV))), - o)); + OP *o2; +#ifdef USE_THREADS + o2 = newOP(OP_SPECIFIC, 0); + o2->op_targ = find_thread_magical(";"); +#else + o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))), +#endif /* USE_THREADS */ + o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o)); } return o; } @@ -1433,6 +1655,7 @@ OP * fold_constants(o) register OP *o; { + dTHR; register OP *curop; I32 type = o->op_type; SV *sv; @@ -1448,6 +1671,16 @@ register OP *o; if (!(opargs[type] & OA_FOLDCONST)) goto nope; + switch (type) { + case OP_SPRINTF: + case OP_UCFIRST: + case OP_LCFIRST: + case OP_UC: + case OP_LC: + if (o->op_private & OPpLOCALE) + goto nope; + } + if (error_count) goto nope; /* Don't try to run w/ errors */ @@ -1516,6 +1749,7 @@ OP * gen_constant_list(o) register OP *o; { + dTHR; register OP *curop; I32 oldtmps_floor = tmps_floor; @@ -1525,10 +1759,10 @@ register OP *o; op = curop = LINKLIST(o); o->op_next = 0; - pp_pushmark(); + pp_pushmark(ARGS); runops(); op = curop; - pp_anonlist(); + pp_anonlist(ARGS); tmps_floor = oldtmps_floor; o->op_type = OP_RV2AV; @@ -1541,38 +1775,38 @@ register OP *o; } OP * -convert(type, flags, op) +convert(type, flags, o) I32 type; I32 flags; -OP* op; +OP* o; { OP *kid; OP *last = 0; - if (!op || op->op_type != OP_LIST) - op = newLISTOP(OP_LIST, 0, op, Nullop); + if (!o || o->op_type != OP_LIST) + o = newLISTOP(OP_LIST, 0, o, Nullop); else - op->op_flags &= ~(OPf_KNOW|OPf_LIST); + o->op_flags &= ~OPf_WANT; if (!(opargs[type] & OA_MARK)) - null(cLISTOP->op_first); + null(cLISTOPo->op_first); - op->op_type = type; - op->op_ppaddr = ppaddr[type]; - op->op_flags |= flags; + o->op_type = type; + o->op_ppaddr = ppaddr[type]; + o->op_flags |= flags; - op = CHECKOP(type, op); - if (op->op_type != type) - return op; + o = CHECKOP(type, o); + if (o->op_type != type) + return o; - if (cLISTOP->op_children < 7) { + if (cLISTOPo->op_children < 7) { /* XXX do we really need to do this if we're done appending?? */ - for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) + for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) last = kid; - cLISTOP->op_last = last; /* in case check substituted last arg */ + cLISTOPo->op_last = last; /* in case check substituted last arg */ } - return fold_constants(op); + return fold_constants(o); } /* List constructors */ @@ -1672,13 +1906,13 @@ newNULLLIST() } OP * -force_list(op) -OP* op; +force_list(o) +OP *o; { - if (!op || op->op_type != OP_LIST) - op = newLISTOP(OP_LIST, 0, op, Nullop); - null(op); - return op; + if (!o || o->op_type != OP_LIST) + o = newLISTOP(OP_LIST, 0, o, Nullop); + null(o); + return o; } OP * @@ -1725,19 +1959,19 @@ newOP(type, flags) I32 type; I32 flags; { - OP *op; - Newz(1101, op, 1, OP); - op->op_type = type; - op->op_ppaddr = ppaddr[type]; - op->op_flags = flags; + OP *o; + Newz(1101, o, 1, OP); + o->op_type = type; + o->op_ppaddr = ppaddr[type]; + o->op_flags = flags; - op->op_next = op; - op->op_private = 0 + (flags >> 8); + o->op_next = o; + o->op_private = 0 + (flags >> 8); if (opargs[type] & OA_RETSCALAR) - scalar(op); + scalar(o); if (opargs[type] & OA_TARGET) - op->op_targ = pad_alloc(type, SVs_PADTMP); - return CHECKOP(type, op); + o->op_targ = pad_alloc(type, SVs_PADTMP); + return CHECKOP(type, o); } OP * @@ -1803,8 +2037,8 @@ OP* last; } OP * -pmtrans(op, expr, repl) -OP *op; +pmtrans(o, expr, repl) +OP *o; OP *expr; OP *repl; { @@ -1820,10 +2054,10 @@ OP *repl; I32 complement; register short *tbl; - tbl = (short*)cPVOP->op_pv; - complement = op->op_private & OPpTRANS_COMPLEMENT; - delete = op->op_private & OPpTRANS_DELETE; - /* squash = op->op_private & OPpTRANS_SQUASH; */ + tbl = (short*)cPVOPo->op_pv; + complement = o->op_private & OPpTRANS_COMPLEMENT; + delete = o->op_private & OPpTRANS_DELETE; + /* squash = o->op_private & OPpTRANS_SQUASH; */ if (complement) { Zero(tbl, 256, short); @@ -1866,7 +2100,7 @@ OP *repl; op_free(expr); op_free(repl); - return op; + return o; } OP * @@ -1874,6 +2108,7 @@ newPMOP(type, flags) I32 type; I32 flags; { + dTHR; PMOP *pmop; Newz(1101, pmop, 1, PMOP); @@ -1895,24 +2130,25 @@ I32 flags; } OP * -pmruntime(op, expr, repl) -OP *op; +pmruntime(o, expr, repl) +OP *o; OP *expr; OP *repl; { PMOP *pm; LOGOP *rcop; - if (op->op_type == OP_TRANS) - return pmtrans(op, expr, repl); + if (o->op_type == OP_TRANS) + return pmtrans(o, expr, repl); - pm = (PMOP*)op; + hints |= HINT_BLOCK_SCOPE; + pm = (PMOP*)o; if (expr->op_type == OP_CONST) { STRLEN plen; SV *pat = ((SVOP*)expr)->op_sv; char *p = SvPV(pat, plen); - if ((op->op_flags & OPf_SPECIAL) && strEQ(p, " ")) { + if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) { sv_setpvn(pat, "\\s+", 3); p = SvPV(pat, plen); pm->op_pmflags |= PMf_SKIPWHITE; @@ -1933,7 +2169,7 @@ OP *repl; rcop->op_first = scalar(expr); rcop->op_flags |= OPf_KIDS; rcop->op_private = 1; - rcop->op_other = op; + rcop->op_other = o; /* establish postfix order */ if (pm->op_pmflags & PMf_KEEP) { @@ -1946,24 +2182,39 @@ OP *repl; expr->op_next = (OP*)rcop; } - prepend_elem(op->op_type, scalar((OP*)rcop), op); + prepend_elem(o->op_type, scalar((OP*)rcop), o); } if (repl) { OP *curop; if (pm->op_pmflags & PMf_EVAL) curop = 0; +#ifdef USE_THREADS + else if (repl->op_type == OP_SPECIFIC + && strchr("&`'123456789+", + per_thread_magicals[repl->op_targ])) + { + curop = 0; + } +#endif /* USE_THREADS */ else if (repl->op_type == OP_CONST) curop = repl; else { OP *lastop = 0; for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) { if (opargs[curop->op_type] & OA_DANGEROUS) { +#ifdef USE_THREADS + if (curop->op_type == OP_SPECIFIC + && strchr("&`'123456789+", curop->op_private)) { + break; + } +#else if (curop->op_type == OP_GV) { GV *gv = ((GVOP*)curop)->op_gv; if (strchr("&`'123456789+", *GvENAME(gv))) break; } +#endif /* USE_THREADS */ else if (curop->op_type == OP_RV2CV) break; else if (curop->op_type == OP_RV2SV || @@ -1988,7 +2239,7 @@ OP *repl; 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); + prepend_elem(o->op_type, scalar(repl), o); } else { Newz(1101, rcop, 1, LOGOP); @@ -1997,7 +2248,7 @@ OP *repl; rcop->op_first = scalar(repl); rcop->op_flags |= OPf_KIDS; rcop->op_private = 1; - rcop->op_other = op; + rcop->op_other = o; /* establish postfix order */ rcop->op_next = LINKLIST(repl); @@ -2038,6 +2289,7 @@ I32 type; I32 flags; GV *gv; { + dTHR; GVOP *gvop; Newz(1101, gvop, 1, GVOP); gvop->op_type = type; @@ -2073,21 +2325,22 @@ char *pv; } void -package(op) -OP *op; +package(o) +OP *o; { + dTHR; SV *sv; save_hptr(&curstash); save_item(curstname); - if (op) { + if (o) { STRLEN len; char *name; - sv = cSVOP->op_sv; + sv = cSVOPo->op_sv; name = SvPV(sv, len); curstash = gv_stashpvn(name,len,TRUE); sv_setpvn(curstname, name, len); - op_free(op); + op_free(o); } else { sv_setpv(curstname,""); @@ -2190,18 +2443,18 @@ OP *listval; } static I32 -list_assignment(op) -register OP *op; +list_assignment(o) +register OP *o; { - if (!op) + if (!o) return TRUE; - if (op->op_type == OP_NULL && op->op_flags & OPf_KIDS) - op = cUNOP->op_first; + if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS) + o = cUNOPo->op_first; - if (op->op_type == OP_COND_EXPR) { - I32 t = list_assignment(cCONDOP->op_first->op_sibling); - I32 f = list_assignment(cCONDOP->op_first->op_sibling->op_sibling); + if (o->op_type == OP_COND_EXPR) { + I32 t = list_assignment(cCONDOPo->op_first->op_sibling); + I32 f = list_assignment(cCONDOPo->op_first->op_sibling->op_sibling); if (t && f) return TRUE; @@ -2210,15 +2463,15 @@ register OP *op; return FALSE; } - if (op->op_type == OP_LIST || op->op_flags & OPf_PARENS || - op->op_type == OP_RV2AV || op->op_type == OP_RV2HV || - op->op_type == OP_ASLICE || op->op_type == OP_HSLICE) + if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS || + o->op_type == OP_RV2AV || o->op_type == OP_RV2HV || + o->op_type == OP_ASLICE || o->op_type == OP_HSLICE) return TRUE; - if (op->op_type == OP_PADAV || op->op_type == OP_PADHV) + if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) return TRUE; - if (op->op_type == OP_RV2SV) + if (o->op_type == OP_RV2SV) return FALSE; return FALSE; @@ -2231,7 +2484,7 @@ OP *left; I32 optype; OP *right; { - OP *op; + OP *o; if (optype) { if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) { @@ -2256,16 +2509,16 @@ OP *right; op_free(right); return Nullop; } - op = newBINOP(OP_AASSIGN, flags, + o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), list(force_list(left)) ); - op->op_private = 0 | (flags >> 8); + o->op_private = 0 | (flags >> 8); if (!(left->op_private & OPpLVAL_INTRO)) { static int generation = 100; OP *curop; - OP *lastop = op; + OP *lastop = o; generation++; - for (curop = LINKLIST(op); curop != op; curop = LINKLIST(curop)) { + for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) { if (opargs[curop->op_type] & OA_DANGEROUS) { if (curop->op_type == OP_GV) { GV *gv = ((GVOP*)curop)->op_gv; @@ -2297,8 +2550,8 @@ OP *right; } lastop = curop; } - if (curop != op) - op->op_private = OPpASSIGN_COMMON; + if (curop != o) + o->op_private = OPpASSIGN_COMMON; } if (right && right->op_type == OP_SPLIT) { OP* tmpop; @@ -2308,18 +2561,18 @@ OP *right; PMOP *pm = (PMOP*)tmpop; if (left->op_type == OP_RV2AV && !(left->op_private & OPpLVAL_INTRO) && - !(op->op_private & OPpASSIGN_COMMON) ) + !(o->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 = cUNOPo->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_KNOW|OPf_LIST); + op_free(o); /* blow off assign */ + right->op_flags &= ~OPf_WANT; /* "I don't know and I don't care." */ return right; } @@ -2335,7 +2588,7 @@ OP *right; } } } - return op; + return o; } if (!right) right = newOP(OP_UNDEF, 0); @@ -2345,29 +2598,30 @@ OP *right; } else { eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/ - op = newBINOP(OP_SASSIGN, flags, + o = newBINOP(OP_SASSIGN, flags, scalar(right), mod(scalar(left), OP_SASSIGN) ); if (eval_start) eval_start = 0; else { - op_free(op); + op_free(o); return Nullop; } } - return op; + return o; } OP * -newSTATEOP(flags, label, op) +newSTATEOP(flags, label, o) I32 flags; char *label; -OP *op; +OP *o; { + dTHR; U32 seq = intro_my(); register COP *cop; Newz(1101, cop, 1, COP); - if (perldb && curcop->cop_line && curstash != debstash) { + if (PERLDB_LINE && curcop->cop_line && curstash != debstash) { cop->op_type = OP_DBSTATE; cop->op_ppaddr = ppaddr[ OP_DBSTATE ]; } @@ -2398,7 +2652,7 @@ OP *op; cop->cop_filegv = (GV*)SvREFCNT_inc(curcop->cop_filegv); cop->cop_stash = curstash; - if (perldb && curstash != debstash) { + if (PERLDB_LINE && 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); @@ -2407,7 +2661,7 @@ OP *op; } } - return prepend_elem(OP_LINESEQ, (OP*)cop, op); + return prepend_elem(OP_LINESEQ, (OP*)cop, o); } /* "Introduce" my variables to visible status. */ @@ -2440,8 +2694,9 @@ I32 flags; OP* first; OP* other; { + dTHR; LOGOP *logop; - OP *op; + OP *o; if (type == OP_XOR) /* Not short circuit, but here by precedence. */ return newBINOP(type, flags, scalar(first), scalar(other)); @@ -2454,12 +2709,12 @@ OP* other; type = OP_OR; else type = OP_AND; - op = first; - first = cUNOP->op_first; - if (op->op_next) - first->op_next = op->op_next; - cUNOP->op_first = Nullop; - op_free(op); + o = first; + first = cUNOPo->op_first; + if (o->op_next) + first->op_next = o->op_next; + cUNOPo->op_first = Nullop; + op_free(o); } } if (first->op_type == OP_CONST) { @@ -2494,16 +2749,20 @@ OP* other; break; case OP_SASSIGN: - if (k1->op_type == OP_READDIR || k1->op_type == OP_GLOB) + 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 construct can be \"0\"; test with defined()", - op_desc[warnop]); - curcop->cop_line = oldline; + 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; } } @@ -2527,10 +2786,10 @@ OP* other; first->op_next = (OP*)logop; first->op_sibling = other; - op = newUNOP(OP_NULL, 0, (OP*)logop); - other->op_next = op; + o = newUNOP(OP_NULL, 0, (OP*)logop); + other->op_next = o; - return op; + return o; } OP * @@ -2540,8 +2799,9 @@ OP* first; OP* trueop; OP* falseop; { + dTHR; CONDOP *condop; - OP *op; + OP *o; if (!falseop) return newLOGOP(OP_AND, 0, first, trueop); @@ -2581,12 +2841,12 @@ OP* falseop; first->op_sibling = trueop; trueop->op_sibling = falseop; - op = newUNOP(OP_NULL, 0, (OP*)condop); + o = newUNOP(OP_NULL, 0, (OP*)condop); - trueop->op_next = op; - falseop->op_next = op; + trueop->op_next = o; + falseop->op_next = o; - return op; + return o; } OP * @@ -2595,10 +2855,11 @@ I32 flags; OP *left; OP *right; { + dTHR; CONDOP *condop; OP *flip; OP *flop; - OP *op; + OP *o; Newz(1101, condop, 1, CONDOP); @@ -2615,7 +2876,7 @@ OP *right; condop->op_next = (OP*)condop; flip = newUNOP(OP_FLIP, flags, (OP*)condop); flop = newUNOP(OP_FLOP, 0, flip); - op = newUNOP(OP_NULL, 0, flop); + o = newUNOP(OP_NULL, 0, flop); linklist(flop); left->op_next = flip; @@ -2629,11 +2890,11 @@ OP *right; flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0; flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0; - flip->op_next = op; + flip->op_next = o; if (!flip->op_private || !flop->op_private) - linklist(op); /* blow off optimizer unless constant */ + linklist(o); /* blow off optimizer unless constant */ - return op; + return o; } OP * @@ -2643,53 +2904,58 @@ I32 debuggable; OP *expr; OP *block; { + dTHR; OP* listop; - OP* op; + OP* o; int once = block && block->op_flags & OPf_SPECIAL && (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 */ - if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB) { + if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB + || (expr->op_type == OP_NULL && expr->op_targ == 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)); - op = newLOGOP(OP_AND, 0, expr, listop); + o = newLOGOP(OP_AND, 0, expr, listop); - ((LISTOP*)listop)->op_last->op_next = LINKLIST(op); + ((LISTOP*)listop)->op_last->op_next = LINKLIST(o); - if (once && op != listop) - op->op_next = ((LOGOP*)cUNOP->op_first)->op_other; + if (once && o != listop) + o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other; - if (op == listop) - op = newUNOP(OP_NULL, 0, op); /* or do {} while 1 loses outer block */ + if (o == listop) + o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */ - op->op_flags |= flags; - op = scope(op); - op->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/ - return op; + o->op_flags |= flags; + o = scope(o); + o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/ + return o; } OP * -newWHILEOP(flags, debuggable, loop, expr, block, cont) +newWHILEOP(flags, debuggable, loop, whileline, expr, block, cont) I32 flags; I32 debuggable; LOOP *loop; +I32 whileline; OP *expr; OP *block; OP *cont; { + dTHR; OP *redo; OP *next = 0; OP *listop; - OP *op; + OP *o; OP *condop; - if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB)) { + if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB + || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) { expr = newUNOP(OP_DEFINED, 0, newASSIGNOP(0, newSVREF(newGVOP(OP_GV, 0, defgv)), 0, expr) ); } @@ -2699,26 +2965,32 @@ OP *cont; if (cont) next = LINKLIST(cont); - if (expr) + if (expr) { cont = append_elem(OP_LINESEQ, cont, newOP(OP_UNSTACK, 0)); + if ((line_t)whileline != NOLINE) { + copline = whileline; + cont = append_elem(OP_LINESEQ, cont, + newSTATEOP(0, Nullch, Nullop)); + } + } listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont); redo = LINKLIST(listop); if (expr) { - op = newLOGOP(OP_AND, 0, expr, scalar(listop)); - if (op == expr && op->op_type == OP_CONST && !SvTRUE(cSVOP->op_sv)) { + o = newLOGOP(OP_AND, 0, expr, scalar(listop)); + if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) { op_free(expr); /* oops, it's a while (0) */ op_free((OP*)loop); return Nullop; /* (listop already freed by newLOGOP) */ } ((LISTOP*)listop)->op_last->op_next = condop = - (op == listop ? redo : LINKLIST(op)); + (o == listop ? redo : LINKLIST(o)); if (!next) next = condop; } else - op = listop; + o = listop; if (!loop) { Newz(1101,loop,1,LOOP); @@ -2728,19 +3000,19 @@ OP *cont; loop->op_next = (OP*)loop; } - op = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, op); + o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o); loop->op_redoop = redo; - loop->op_lastop = op; + loop->op_lastop = o; if (next) loop->op_nextop = next; else - loop->op_nextop = op; + loop->op_nextop = o; - op->op_flags |= flags; - op->op_private |= (flags >> 8); - return op; + o->op_flags |= flags; + o->op_private |= (flags >> 8); + return o; } OP * @@ -2758,10 +3030,10 @@ newFOROP(I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont #endif /* CAN_PROTOTYPE */ { LOOP *loop; + OP *wop; int padoff = 0; I32 iterflags = 0; - copline = forline; if (sv) { if (sv->op_type == OP_RV2SV) { /* symbol table variable */ sv->op_type = OP_RV2GV; @@ -2788,8 +3060,9 @@ newFOROP(I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont 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)); + wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont); + copline = forline; + return newSTATEOP(0, label, wop); } OP* @@ -2797,9 +3070,10 @@ newLOOPEX(type, label) I32 type; OP* label; { - OP *op; + dTHR; + OP *o; if (type != OP_GOTO || label->op_type == OP_CONST) { - op = newPVOP(type, 0, savepv( + o = newPVOP(type, 0, savepv( label->op_type == OP_CONST ? SvPVx(((SVOP*)label)->op_sv, na) : "" )); @@ -2808,19 +3082,33 @@ OP* label; else { if (label->op_type == OP_ENTERSUB) label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN)); - op = newUNOP(type, OPf_STACKED, label); + o = newUNOP(type, OPf_STACKED, label); } hints |= HINT_BLOCK_SCOPE; - return op; + return o; } void cv_undef(cv) CV *cv; { + dTHR; +#ifdef USE_THREADS + if (CvMUTEXP(cv)) { + MUTEX_DESTROY(CvMUTEXP(cv)); + Safefree(CvMUTEXP(cv)); + CvMUTEXP(cv) = 0; + } +#endif /* USE_THREADS */ + if (!CvXSUB(cv) && CvROOT(cv)) { +#ifdef USE_THREADS + if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr)) + croak("Can't undef active subroutine"); +#else if (CvDEPTH(cv)) croak("Can't undef active subroutine"); +#endif /* USE_THREADS */ ENTER; SAVESPTR(curpad); @@ -2831,6 +3119,7 @@ CV *cv; CvROOT(cv) = Nullop; LEAVE; } + SvPOK_off((SV*)cv); /* forget prototype */ CvFLAGS(cv) = 0; SvREFCNT_dec(CvGV(cv)); CvGV(cv) = Nullgv; @@ -2842,8 +3131,16 @@ CV *cv; I32 i = AvFILL(CvPADLIST(cv)); while (i >= 0) { SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE); - if (svp) - SvREFCNT_dec(*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); } SvREFCNT_dec((SV*)CvPADLIST(cv)); } @@ -2864,7 +3161,7 @@ CV* cv; SV** ppad; I32 ix; - PerlIO_printf(Perl_debug_log, "\tCV=0x%p (%s), OUTSIDE=0x%p (%s)\n", + PerlIO_printf(Perl_debug_log, "\tCV=0x%lx (%s), OUTSIDE=0x%lx (%s)\n", cv, (CvANON(cv) ? "ANON" : (cv == main_cv) ? "MAIN" @@ -2885,9 +3182,9 @@ CV* cv; pname = AvARRAY(pad_name); ppad = AvARRAY(pad); - for (ix = 1; ix <= AvFILL(pad); ix++) { + 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", + PerlIO_printf(Perl_debug_log, "\t%4d. 0x%lx (%s\"%s\" %ld-%ld)\n", ix, ppad[ix], SvFAKE(pname[ix]) ? "FAKE " : "", SvPVX(pname[ix]), @@ -2902,6 +3199,7 @@ cv_clone2(proto, outside) CV* proto; CV* outside; { + dTHR; AV* av; I32 ix; AV* protopadlist = CvPADLIST(proto); @@ -2909,6 +3207,8 @@ CV* outside; 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; @@ -2917,6 +3217,7 @@ CV* outside; ENTER; SAVESPTR(curpad); SAVESPTR(comppad); + SAVESPTR(comppad_name); SAVESPTR(compcv); cv = compcv = (CV*)NEWSV(1104,0); @@ -2925,6 +3226,11 @@ CV* outside; if (CvANON(proto)) CvANON_on(cv); +#ifdef USE_THREADS + New(666, CvMUTEXP(cv), 1, perl_mutex); + MUTEX_INIT(CvMUTEXP(cv)); + CvOWNER(cv) = 0; +#endif /* USE_THREADS */ CvFILEGV(cv) = CvFILEGV(proto); CvGV(cv) = (GV*)SvREFCNT_inc(CvGV(proto)); CvSTASH(cv) = CvSTASH(proto); @@ -2933,11 +3239,18 @@ CV* outside; 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, SvREFCNT_inc((SV*)protopad_name)); + av_store(comppadlist, 0, (SV*)comppad_name); av_store(comppadlist, 1, (SV*)comppad); CvPADLIST(cv) = comppadlist; av_fill(comppad, AvFILL(protopad)); @@ -2948,8 +3261,8 @@ CV* outside; av_store(comppad, 0, (SV*)av); AvFLAGS(av) = AVf_REIFY; - for (ix = AvFILL(protopad); ix > 0; ix--) { - SV* namesv = pname[ix]; + 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? */ @@ -2986,8 +3299,8 @@ CV* outside; /* Now that vars are all in place, clone nested closures. */ - for (ix = AvFILL(protopad); ix > 0; ix--) { - SV* namesv = pname[ix]; + for (ix = fpad; ix > 0; ix--) { + SV* namesv = (ix <= fname) ? pname[ix] : Nullsv; if (namesv && namesv != &sv_undef && !(SvFLAGS(namesv) & SVf_FAKE) @@ -3022,76 +3335,112 @@ CV* proto; return cv_clone2(proto, CvOUTSIDE(proto)); } +void +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; +CV* cv; { OP *o; - SV *sv = Nullsv; + SV *sv; - if(cv && SvPOK(cv) && !SvCUR(cv)) { - for (o = CvSTART(cv); o; o = o->op_next) { - OPCODE type = o->op_type; + 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 (type != OP_CONST || sv) + 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 = cSVOPo->op_sv; + else if (type == OP_PADSV) { + AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]); + sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv; + if (!sv || (!SvREADONLY(sv) && SvREFCNT(sv) > 1)) return Nullsv; - - sv = ((SVOP*)o)->op_sv; } + else + return Nullsv; } + if (sv) + SvREADONLY_on(sv); return sv; } CV * -newSUB(floor,op,proto,block) +newSUB(floor,o,proto,block) I32 floor; -OP *op; +OP *o; OP *proto; OP *block; { - char *name = op ? SvPVx(cSVOP->op_sv, na) : Nullch; + dTHR; + char *name = o ? SvPVx(cSVOPo->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; - AV *av; I32 ix; - if (op) - SAVEFREEOP(op); - 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) */ - - SV* const_sv = cv_const_sv(cv); - char *p = proto ? SvPVx(((SVOP*)proto)->op_sv, na) : Nullch; - - if((!proto != !SvPOK(cv)) || (p && strNE(SvPV((SV*)cv,na), p))) { - warn("Prototype mismatch: (%s) vs (%s)", - SvPOK(cv) ? SvPV((SV*)cv,na) : "none", - p ? p : "none"); - } + if (o) + SAVEFREEOP(o); + 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; } + /* ahem, death to those who redefine active sort subs */ + if (curstack == sortstack && sortcop == CvSTART(cv)) + croak("Can't redefine active sort subroutine %s", name); + const_sv = cv_const_sv(cv); if (const_sv || dowarn) { line_t oldline = curcop->cop_line; curcop->cop_line = copline; warn(const_sv ? "Constant subroutine %s redefined" - : "Subroutine %s redefined",name); + : "Subroutine %s redefined", name); curcop->cop_line = oldline; } SvREFCNT_dec(cv); - cv = 0; + cv = Nullcv; } } if (cv) { /* must reuse cv if autoloaded */ @@ -3116,16 +3465,33 @@ OP *block; CvGV(cv) = (GV*)SvREFCNT_inc(gv); CvFILEGV(cv) = curcop->cop_filegv; CvSTASH(cv) = curstash; +#ifdef USE_THREADS + CvOWNER(cv) = 0; + New(666, CvMUTEXP(cv), 1, perl_mutex); + MUTEX_INIT(CvMUTEXP(cv)); +#endif /* USE_THREADS */ - if (proto) { - char *p = SvPVx(((SVOP*)proto)->op_sv, na); - sv_setpv((SV*)cv, p); - op_free(proto); - } + 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(errsv, not_safe); + croak("%s", SvPV(errsv, na)); + } + } + } } if (!block) { copline = NOLINE; @@ -3133,18 +3499,44 @@ OP *block; return cv; } - av = newAV(); /* Will be @_ */ - av_extend(av, 0); - av_store(comppad, 0, (SV*)av); - AvFLAGS(av) = AVf_REIFY; + if (AvFILL(comppad_name) < AvFILL(comppad)) + av_store(comppad_name, AvFILL(comppad), Nullsv); - for (ix = AvFILL(comppad); ix > 0; ix--) { - if (!SvPADMY(curpad[ix]) && !SvIMMORTAL(curpad[ix])) - SvPADTMP_on(curpad[ix]); + 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; - if (AvFILL(comppad_name) < AvFILL(comppad)) - av_store(comppad_name, AvFILL(comppad), Nullsv); + for (ix = AvFILL(comppad); ix > 0; ix--) { + if (SvIMMORTAL(curpad[ix])) + continue; + if (!SvPADMY(curpad[ix])) + SvPADTMP_on(curpad[ix]); + } + } CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block)); CvSTART(cv) = LINKLIST(CvROOT(cv)); @@ -3154,27 +3546,24 @@ OP *block; if (name) { char *s; - if (perldb && curstash != debstash) { - SV *sv; + if (PERLDB_SUBLINE && curstash != debstash) { + SV *sv = NEWSV(0,0); SV *tmpstr = sv_newmortal(); static GV *db_postponed; CV *cv; HV *hv; - sprintf(buf, "%s:%ld", - SvPVX(GvSV(curcop->cop_filegv)), (long)subline); - sv = newSVpv(buf,0); - sv_catpv(sv,"-"); - sprintf(buf,"%ld",(long)curcop->cop_line); - sv_catpv(sv,buf); + 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))) { + if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr)) + && (cv = GvCV(db_postponed))) { dSP; PUSHMARK(sp); XPUSHs(tmpstr); @@ -3187,7 +3576,8 @@ OP *block; s++; else s = name; - if (strEQ(s, "BEGIN") && !error_count) { + if (strEQ(s, "BEGIN")) { + I32 oldscope = scopestack_ix; ENTER; SAVESPTR(compiling.cop_filegv); SAVEI16(compiling.cop_line); @@ -3200,7 +3590,7 @@ OP *block; DEBUG_x( dump_sub(gv) ); av_push(beginav, (SV *)cv); GvCV(gv) = 0; - calllist(beginav); + call_list(oldscope, beginav); curcop = &compiling; LEAVE; @@ -3212,6 +3602,11 @@ OP *block; av_store(endav, 0, (SV *)cv); GvCV(gv) = 0; } + else if (strEQ(s, "INIT") && !error_count) { + if (!initav) + initav = newAV(); + av_push(initav, SvREFCNT_inc(cv)); + } } done: @@ -3220,27 +3615,13 @@ OP *block; return cv; } -#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; { + dTHR; GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV); register CV *cv; @@ -3275,6 +3656,11 @@ char *filename; } } CvGV(cv) = (GV*)SvREFCNT_inc(gv); +#ifdef USE_THREADS + New(666, CvMUTEXP(cv), 1, perl_mutex); + MUTEX_INIT(CvMUTEXP(cv)); + CvOWNER(cv) = 0; +#endif /* USE_THREADS */ CvFILEGV(cv) = gv_fetchfile(filename); CvXSUB(cv) = subaddr; @@ -3297,6 +3683,11 @@ char *filename; av_store(endav, 0, (SV *)cv); GvCV(gv) = 0; } + else if (strEQ(s, "INIT")) { + if (!initav) + initav = newAV(); + av_push(initav, (SV *)cv); + } } else CvANON_on(cv); @@ -3305,18 +3696,19 @@ char *filename; } void -newFORM(floor,op,block) +newFORM(floor,o,block) I32 floor; -OP *op; +OP *o; OP *block; { + dTHR; register CV *cv; char *name; GV *gv; I32 ix; - if (op) - name = SvPVx(cSVOP->op_sv, na); + if (o) + name = SvPVx(cSVOPo->op_sv, na); else name = "STDOUT"; gv = gv_fetchpv(name,TRUE, SVt_PVFM); @@ -3345,25 +3737,25 @@ OP *block; CvSTART(cv) = LINKLIST(CvROOT(cv)); CvROOT(cv)->op_next = 0; peep(CvSTART(cv)); - op_free(op); + op_free(o); copline = NOLINE; LEAVE_SCOPE(floor); } OP * -newANONLIST(op) -OP* op; +newANONLIST(o) +OP* o; { return newUNOP(OP_REFGEN, 0, - mod(list(convert(OP_ANONLIST, 0, op)), OP_REFGEN)); + mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN)); } OP * -newANONHASH(op) -OP* op; +newANONHASH(o) +OP* o; { return newUNOP(OP_REFGEN, 0, - mod(list(convert(OP_ANONHASH, 0, op)), OP_REFGEN)); + mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN)); } OP * @@ -3484,14 +3876,16 @@ OP *o; o->op_ppaddr = ppaddr[OP_PADSV]; return o; } + else if (o->op_type == OP_SPECIFIC) + return o; return newUNOP(OP_RV2SV, 0, scalar(o)); } /* Check routines. */ OP * -ck_anoncode(op) -OP *op; +ck_anoncode(o) +OP *o; { PADOFFSET ix; SV* name; @@ -3501,42 +3895,42 @@ OP *op; sv_setpvn(name, "&", 1); SvIVX(name) = -1; SvNVX(name) = 1; - ix = pad_alloc(op->op_type, SVs_PADMY); + ix = pad_alloc(o->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; + av_store(comppad, ix, cSVOPo->op_sv); + SvPADMY_on(cSVOPo->op_sv); + cSVOPo->op_sv = Nullsv; + cSVOPo->op_targ = ix; + return o; } OP * -ck_bitop(op) -OP *op; +ck_bitop(o) +OP *o; { - op->op_private = hints; - return op; + o->op_private = hints; + return o; } OP * -ck_concat(op) -OP *op; +ck_concat(o) +OP *o; { - if (cUNOP->op_first->op_type == OP_CONCAT) - op->op_flags |= OPf_STACKED; - return op; + if (cUNOPo->op_first->op_type == OP_CONCAT) + o->op_flags |= OPf_STACKED; + return o; } OP * -ck_spair(op) -OP *op; +ck_spair(o) +OP *o; { - if (op->op_flags & OPf_KIDS) { + if (o->op_flags & OPf_KIDS) { OP* newop; OP* kid; - OPCODE type = op->op_type; - op = modkids(ck_fun(op), type); - kid = cUNOP->op_first; + OPCODE type = o->op_type; + o = modkids(ck_fun(o), type); + kid = cUNOPo->op_first; newop = kUNOP->op_first->op_sibling; if (newop && (newop->op_sibling || @@ -3544,68 +3938,68 @@ OP *op; newop->op_type == OP_PADAV || newop->op_type == OP_PADHV || newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) { - return op; + return o; } op_free(kUNOP->op_first); kUNOP->op_first = newop; } - op->op_ppaddr = ppaddr[++op->op_type]; - return ck_fun(op); + o->op_ppaddr = ppaddr[++o->op_type]; + return ck_fun(o); } OP * -ck_delete(op) -OP *op; +ck_delete(o) +OP *o; { - op = ck_fun(op); - op->op_private = 0; - if (op->op_flags & OPf_KIDS) { - OP *kid = cUNOP->op_first; + o = ck_fun(o); + o->op_private = 0; + if (o->op_flags & OPf_KIDS) { + OP *kid = cUNOPo->op_first; if (kid->op_type == OP_HSLICE) - op->op_private |= OPpSLICE; + o->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]); + op_desc[o->op_type]); null(kid); } - return op; + return o; } OP * -ck_eof(op) -OP *op; +ck_eof(o) +OP *o; { - I32 type = op->op_type; + I32 type = o->op_type; - if (op->op_flags & OPf_KIDS) { - 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, SVt_PVAV))); + if (o->op_flags & OPf_KIDS) { + if (cLISTOPo->op_first->op_type == OP_STUB) { + op_free(o); + o = newUNOP(type, OPf_SPECIAL, + newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV))); } - return ck_fun(op); + return ck_fun(o); } - return op; + return o; } OP * -ck_eval(op) -OP *op; +ck_eval(o) +OP *o; { hints |= HINT_BLOCK_SCOPE; - if (op->op_flags & OPf_KIDS) { - SVOP *kid = (SVOP*)cUNOP->op_first; + if (o->op_flags & OPf_KIDS) { + SVOP *kid = (SVOP*)cUNOPo->op_first; if (!kid) { - op->op_flags &= ~OPf_KIDS; - null(op); + o->op_flags &= ~OPf_KIDS; + null(o); } else if (kid->op_type == OP_LINESEQ) { LOGOP *enter; - kid->op_next = op->op_next; - cUNOP->op_first = 0; - op_free(op); + kid->op_next = o->op_next; + cUNOPo->op_first = 0; + op_free(o); Newz(1101, enter, 1, LOGOP); enter->op_type = OP_ENTERTRY; @@ -3615,49 +4009,49 @@ OP *op; /* establish postfix order */ enter->op_next = (OP*)enter; - op = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid); - op->op_type = OP_LEAVETRY; - op->op_ppaddr = ppaddr[OP_LEAVETRY]; - enter->op_other = op; - return op; + o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid); + o->op_type = OP_LEAVETRY; + o->op_ppaddr = ppaddr[OP_LEAVETRY]; + enter->op_other = o; + return o; } } else { - op_free(op); - op = newUNOP(OP_ENTEREVAL, 0, newSVREF(newGVOP(OP_GV, 0, defgv))); + op_free(o); + o = newUNOP(OP_ENTEREVAL, 0, newSVREF(newGVOP(OP_GV, 0, defgv))); } - op->op_targ = (PADOFFSET)hints; - return op; + o->op_targ = (PADOFFSET)hints; + return o; } OP * -ck_exec(op) -OP *op; +ck_exec(o) +OP *o; { OP *kid; - if (op->op_flags & OPf_STACKED) { - op = ck_fun(op); - kid = cUNOP->op_first->op_sibling; + if (o->op_flags & OPf_STACKED) { + o = ck_fun(o); + kid = cUNOPo->op_first->op_sibling; if (kid->op_type == OP_RV2GV) null(kid); } else - op = listkids(op); - return op; + o = listkids(o); + return o; } OP * -ck_exists(op) -OP *op; +ck_exists(o) +OP *o; { - op = ck_fun(op); - if (op->op_flags & OPf_KIDS) { - OP *kid = cUNOP->op_first; + o = ck_fun(o); + if (o->op_flags & OPf_KIDS) { + OP *kid = cUNOPo->op_first; if (kid->op_type != OP_HELEM) - croak("%s argument is not a HASH element", op_desc[op->op_type]); + croak("%s argument is not a HASH element", op_desc[o->op_type]); null(kid); } - return op; + return o; } OP * @@ -3671,12 +4065,13 @@ register OP *o; } OP * -ck_rvconst(op) -register OP *op; +ck_rvconst(o) +register OP *o; { - SVOP *kid = (SVOP*)cUNOP->op_first; + dTHR; + SVOP *kid = (SVOP*)cUNOPo->op_first; - op->op_private |= (hints & HINT_STRICT_REFS); + o->op_private |= (hints & HINT_STRICT_REFS); if (kid->op_type == OP_CONST) { char *name; int iscv; @@ -3685,7 +4080,7 @@ register OP *op; name = SvPV(kid->op_sv, na); if ((hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) { char *badthing = Nullch; - switch (op->op_type) { + switch (o->op_type) { case OP_RV2SV: badthing = "a SCALAR"; break; @@ -3702,7 +4097,7 @@ register OP *op; name, badthing); } kid->op_type = OP_GV; - iscv = (op->op_type == OP_RV2CV) * 2; + iscv = (o->op_type == OP_RV2CV) * 2; for (gv = 0; !gv; iscv++) { /* * This is a little tricky. We only want to add the symbol if we @@ -3716,71 +4111,73 @@ register OP *op; iscv | !(kid->op_private & OPpCONST_ENTERED), iscv ? SVt_PVCV - : op->op_type == OP_RV2SV + : o->op_type == OP_RV2SV ? SVt_PV - : op->op_type == OP_RV2AV + : o->op_type == OP_RV2AV ? SVt_PVAV - : op->op_type == OP_RV2HV + : o->op_type == OP_RV2HV ? SVt_PVHV : SVt_PVGV); } SvREFCNT_dec(kid->op_sv); kid->op_sv = SvREFCNT_inc(gv); } - return op; + return o; } OP * -ck_ftst(op) -OP *op; +ck_ftst(o) +OP *o; { - I32 type = op->op_type; + dTHR; + I32 type = o->op_type; - if (op->op_flags & OPf_REF) - return op; + if (o->op_flags & OPf_REF) + return o; - if (op->op_flags & OPf_KIDS) { - SVOP *kid = (SVOP*)cUNOP->op_first; + if (o->op_flags & OPf_KIDS) { + SVOP *kid = (SVOP*)cUNOPo->op_first; if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { OP *newop = newGVOP(type, OPf_REF, gv_fetchpv(SvPVx(kid->op_sv, na), TRUE, SVt_PVIO)); - op_free(op); + op_free(o); return newop; } } else { - op_free(op); + op_free(o); if (type == OP_FTTTY) - return newGVOP(type, OPf_REF, 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))); } - return op; + return o; } OP * -ck_fun(op) -OP *op; +ck_fun(o) +OP *o; { + dTHR; register OP *kid; OP **tokid; OP *sibl; I32 numargs = 0; - int type = op->op_type; + int type = o->op_type; register I32 oa = opargs[type] >> OASHIFT; - if (op->op_flags & OPf_STACKED) { + if (o->op_flags & OPf_STACKED) { if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL)) oa &= ~OA_OPTIONAL; else - return no_fh_allowed(op); + return no_fh_allowed(o); } - if (op->op_flags & OPf_KIDS) { - tokid = &cLISTOP->op_first; - kid = cLISTOP->op_first; + if (o->op_flags & OPf_KIDS) { + tokid = &cLISTOPo->op_first; + kid = cLISTOPo->op_first; if (kid->op_type == OP_PUSHMARK || kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK) { @@ -3820,7 +4217,7 @@ OP *op; *tokid = kid; } else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) - bad_type(numargs, "array", op_desc[op->op_type], kid); + bad_type(numargs, "array", op_desc[o->op_type], kid); mod(kid, type); break; case OA_HVREF: @@ -3838,7 +4235,7 @@ OP *op; *tokid = kid; } else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV) - bad_type(numargs, "hash", op_desc[op->op_type], kid); + bad_type(numargs, "hash", op_desc[o->op_type], kid); mod(kid, type); break; case OA_CVREF: @@ -3879,13 +4276,13 @@ OP *op; tokid = &kid->op_sibling; kid = kid->op_sibling; } - op->op_private |= numargs; + o->op_private |= numargs; if (kid) - return too_many_arguments(op,op_desc[op->op_type]); - listkids(op); + return too_many_arguments(o,op_desc[o->op_type]); + listkids(o); } else if (opargs[type] & OA_DEFGV) { - op_free(op); + op_free(o); return newUNOP(type, 0, newSVREF(newGVOP(OP_GV, 0, defgv))); } @@ -3893,81 +4290,93 @@ OP *op; while (oa & OA_OPTIONAL) oa >>= 4; if (oa && oa != OA_LIST) - return too_few_arguments(op,op_desc[op->op_type]); + return too_few_arguments(o,op_desc[o->op_type]); } - return op; + return o; } OP * -ck_glob(op) -OP *op; +ck_glob(o) +OP *o; { - GV *gv = gv_fetchpv("glob", FALSE, SVt_PVCV); + GV *gv; + + if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling) + append_elem(OP_GLOB, o, newSVREF(newGVOP(OP_GV, 0, defgv))); + + if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv))) + gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV); if (gv && GvIMPORTED_CV(gv)) { - op->op_type = OP_LIST; - op->op_ppaddr = ppaddr[OP_LIST]; - 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))); + static int glob_index; + + append_elem(OP_GLOB, o, + newSVOP(OP_CONST, 0, newSViv(glob_index++))); + o->op_type = OP_LIST; + o->op_ppaddr = ppaddr[OP_LIST]; + cLISTOPo->op_first->op_type = OP_PUSHMARK; + cLISTOPo->op_first->op_ppaddr = ppaddr[OP_PUSHMARK]; + o = newUNOP(OP_ENTERSUB, OPf_STACKED, + append_elem(OP_LIST, o, + scalar(newUNOP(OP_RV2CV, 0, + newGVOP(OP_GV, 0, gv))))); + o = newUNOP(OP_NULL, 0, ck_subr(o)); + o->op_targ = OP_GLOB; /* hint at what it used to be */ + return o; + } gv = newGVgen("main"); gv_IOadd(gv); - append_elem(OP_GLOB, op, newGVOP(OP_GV, 0, gv)); - scalarkids(op); - return ck_fun(op); + append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv)); + scalarkids(o); + return ck_fun(o); } OP * -ck_grep(op) -OP *op; +ck_grep(o) +OP *o; { LOGOP *gwop; OP *kid; - OPCODE type = op->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE; + OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE; - op->op_ppaddr = ppaddr[OP_GREPSTART]; + o->op_ppaddr = ppaddr[OP_GREPSTART]; Newz(1101, gwop, 1, LOGOP); - if (op->op_flags & OPf_STACKED) { + if (o->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) { + o = ck_sort(o); + kid = cLISTOPo->op_first->op_sibling; + for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) { kid = k; } kid->op_next = (OP*)gwop; - op->op_flags &= ~OPf_STACKED; + o->op_flags &= ~OPf_STACKED; } - kid = cLISTOP->op_first->op_sibling; + kid = cLISTOPo->op_first->op_sibling; if (type == OP_MAPWHILE) list(kid); else scalar(kid); - op = ck_fun(op); + o = ck_fun(o); if (error_count) - return op; - kid = cLISTOP->op_first->op_sibling; + return o; + kid = cLISTOPo->op_first->op_sibling; if (kid->op_type != OP_NULL) croak("panic: ck_grep"); kid = kUNOP->op_first; gwop->op_type = type; gwop->op_ppaddr = ppaddr[type]; - gwop->op_first = listkids(op); + gwop->op_first = listkids(o); gwop->op_flags |= OPf_KIDS; gwop->op_private = 1; gwop->op_other = LINKLIST(kid); gwop->op_targ = pad_alloc(type, SVs_PADTMP); kid->op_next = (OP*)gwop; - kid = cLISTOP->op_first->op_sibling; + kid = cLISTOPo->op_first->op_sibling; if (!kid || !kid->op_sibling) - return too_few_arguments(op,op_desc[op->op_type]); + return too_few_arguments(o,op_desc[o->op_type]); for (kid = kid->op_sibling; kid; kid = kid->op_sibling) mod(kid, OP_GREPSTART); @@ -3975,143 +4384,142 @@ OP *op; } OP * -ck_index(op) -OP *op; +ck_index(o) +OP *o; { - if (op->op_flags & OPf_KIDS) { - OP *kid = cLISTOP->op_first->op_sibling; /* get past pushmark */ + if (o->op_flags & OPf_KIDS) { + OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ if (kid && kid->op_type == OP_CONST) fbm_compile(((SVOP*)kid)->op_sv); } - return ck_fun(op); + return ck_fun(o); } OP * -ck_lengthconst(op) -OP *op; +ck_lengthconst(o) +OP *o; { /* XXX length optimization goes here */ - return ck_fun(op); + return ck_fun(o); } OP * -ck_lfun(op) -OP *op; +ck_lfun(o) +OP *o; { - OPCODE type = op->op_type; - return modkids(ck_fun(op), type); + OPCODE type = o->op_type; + return modkids(ck_fun(o), type); } OP * -ck_rfun(op) -OP *op; +ck_rfun(o) +OP *o; { - OPCODE type = op->op_type; - return refkids(ck_fun(op), type); + OPCODE type = o->op_type; + return refkids(ck_fun(o), type); } OP * -ck_listiob(op) -OP *op; +ck_listiob(o) +OP *o; { register OP *kid; - kid = cLISTOP->op_first; + kid = cLISTOPo->op_first; if (!kid) { - op = force_list(op); - kid = cLISTOP->op_first; + o = force_list(o); + kid = cLISTOPo->op_first; } if (kid->op_type == OP_PUSHMARK) kid = kid->op_sibling; - if (kid && op->op_flags & OPf_STACKED) + if (kid && o->op_flags & OPf_STACKED) kid = kid->op_sibling; 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 */ + o->op_flags |= OPf_STACKED; /* make it a filehandle */ kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid)); - cLISTOP->op_first->op_sibling = kid; - cLISTOP->op_last = kid; + cLISTOPo->op_first->op_sibling = kid; + cLISTOPo->op_last = kid; kid = kid->op_sibling; } } if (!kid) - append_elem(op->op_type, op, newSVREF(newGVOP(OP_GV, 0, defgv)) ); + append_elem(o->op_type, o, newSVREF(newGVOP(OP_GV, 0, defgv)) ); - op = listkids(op); + o = listkids(o); - op->op_private = 0; + o->op_private = 0; #ifdef USE_LOCALE if (hints & HINT_LOCALE) - op->op_private |= OPpLOCALE; + o->op_private |= OPpLOCALE; #endif - return op; + return o; } OP * -ck_fun_locale(op) -OP *op; +ck_fun_locale(o) +OP *o; { - op = ck_fun(op); + o = ck_fun(o); - op->op_private = 0; + o->op_private = 0; #ifdef USE_LOCALE if (hints & HINT_LOCALE) - op->op_private |= OPpLOCALE; + o->op_private |= OPpLOCALE; #endif - return op; + return o; } OP * -ck_scmp(op) -OP *op; +ck_scmp(o) +OP *o; { - op->op_private = 0; + o->op_private = 0; #ifdef USE_LOCALE if (hints & HINT_LOCALE) - op->op_private |= OPpLOCALE; + o->op_private |= OPpLOCALE; #endif - return op; + return o; } OP * -ck_match(op) -OP *op; +ck_match(o) +OP *o; { - cPMOP->op_pmflags |= PMf_RUNTIME; - cPMOP->op_pmpermflags |= PMf_RUNTIME; - return op; + o->op_private |= OPpRUNTIME; + return o; } OP * -ck_null(op) -OP *op; +ck_null(o) +OP *o; { - return op; + return o; } OP * -ck_repeat(op) -OP *op; +ck_repeat(o) +OP *o; { - if (cBINOP->op_first->op_flags & OPf_PARENS) { - op->op_private |= OPpREPEAT_DOLIST; - cBINOP->op_first = force_list(cBINOP->op_first); + if (cBINOPo->op_first->op_flags & OPf_PARENS) { + o->op_private |= OPpREPEAT_DOLIST; + cBINOPo->op_first = force_list(cBINOPo->op_first); } else - scalar(op); - return op; + scalar(o); + return o; } OP * -ck_require(op) -OP *op; +ck_require(o) +OP *o; { - if (op->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */ - SVOP *kid = (SVOP*)cUNOP->op_first; + if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */ + SVOP *kid = (SVOP*)cUNOPo->op_first; if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { char *s; @@ -4125,68 +4533,81 @@ OP *op; sv_catpvn(kid->op_sv, ".pm", 3); } } - return ck_fun(op); + return ck_fun(o); } OP * -ck_retarget(op) -OP *op; +ck_retarget(o) +OP *o; { croak("NOT IMPL LINE %d",__LINE__); /* STUB */ - return op; + return o; } OP * -ck_select(op) -OP *op; +ck_select(o) +OP *o; { OP* kid; - if (op->op_flags & OPf_KIDS) { - kid = cLISTOP->op_first->op_sibling; /* get past pushmark */ + if (o->op_flags & OPf_KIDS) { + kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ if (kid && kid->op_sibling) { - op->op_type = OP_SSELECT; - op->op_ppaddr = ppaddr[OP_SSELECT]; - op = ck_fun(op); - return fold_constants(op); + o->op_type = OP_SSELECT; + o->op_ppaddr = ppaddr[OP_SSELECT]; + o = ck_fun(o); + return fold_constants(o); } } - op = ck_fun(op); - kid = cLISTOP->op_first->op_sibling; /* get past pushmark */ + o = ck_fun(o); + kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ if (kid && kid->op_type == OP_RV2GV) kid->op_private &= ~HINT_STRICT_REFS; - return op; + return o; } OP * -ck_shift(op) -OP *op; +ck_shift(o) +OP *o; { - I32 type = op->op_type; + I32 type = o->op_type; - if (!(op->op_flags & OPf_KIDS)) { - op_free(op); - return newUNOP(type, 0, - scalar(newUNOP(OP_RV2AV, 0, - scalar(newGVOP(OP_GV, 0, subline - ? defgv - : gv_fetchpv("ARGV", TRUE, SVt_PVAV) ))))); + if (!(o->op_flags & OPf_KIDS)) { + OP *argop; + + op_free(o); +#ifdef USE_THREADS + if (subline) { + argop = newOP(OP_PADAV, OPf_REF); + argop->op_targ = 0; /* curpad[0] is @_ */ + } + else { + argop = newUNOP(OP_RV2AV, 0, + scalar(newGVOP(OP_GV, 0, + gv_fetchpv("ARGV", TRUE, SVt_PVAV)))); + } +#else + argop = newUNOP(OP_RV2AV, 0, + scalar(newGVOP(OP_GV, 0, subline ? + defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV)))); +#endif /* USE_THREADS */ + return newUNOP(type, 0, scalar(argop)); } - return scalar(modkids(ck_fun(op), type)); + return scalar(modkids(ck_fun(o), type)); } OP * -ck_sort(op) -OP *op; +ck_sort(o) +OP *o; { - op->op_private = 0; + o->op_private = 0; #ifdef USE_LOCALE if (hints & HINT_LOCALE) - op->op_private |= OPpLOCALE; + o->op_private |= OPpLOCALE; #endif - if (op->op_flags & OPf_STACKED) { - OP *kid = cLISTOP->op_first->op_sibling; /* get past pushmark */ + if (o->op_flags & OPf_STACKED) { + OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ OP *k; kid = kUNOP->op_first; /* get past rv2gv */ @@ -4197,7 +4618,7 @@ OP *op; kid->op_next = 0; } else if (kid->op_type == OP_LEAVE) { - if (op->op_type == OP_SORT) { + if (o->op_type == OP_SORT) { null(kid); /* wipe out leave */ kid->op_next = kid; @@ -4212,47 +4633,47 @@ OP *op; } peep(k); - kid = cLISTOP->op_first->op_sibling; /* get past pushmark */ + kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ null(kid); /* wipe out rv2gv */ - if (op->op_type == OP_SORT) + if (o->op_type == OP_SORT) kid->op_next = kid; else kid->op_next = k; - op->op_flags |= OPf_SPECIAL; + o->op_flags |= OPf_SPECIAL; } } - return op; + return o; } OP * -ck_split(op) -OP *op; +ck_split(o) +OP *o; { register OP *kid; PMOP* pm; - if (op->op_flags & OPf_STACKED) - return no_fh_allowed(op); + if (o->op_flags & OPf_STACKED) + return no_fh_allowed(o); - kid = cLISTOP->op_first; + kid = cLISTOPo->op_first; if (kid->op_type != OP_NULL) croak("panic: ck_split"); kid = kid->op_sibling; - op_free(cLISTOP->op_first); - cLISTOP->op_first = kid; + op_free(cLISTOPo->op_first); + cLISTOPo->op_first = kid; if (!kid) { - cLISTOP->op_first = kid = newSVOP(OP_CONST, 0, newSVpv(" ", 1)); - cLISTOP->op_last = kid; /* There was only one element previously */ + cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpv(" ", 1)); + cLISTOPo->op_last = kid; /* There was only one element previously */ } if (kid->op_type != OP_MATCH) { OP *sibl = kid->op_sibling; kid->op_sibling = 0; kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop); - if (cLISTOP->op_first == cLISTOP->op_last) - cLISTOP->op_last = kid; - cLISTOP->op_first = kid; + if (cLISTOPo->op_first == cLISTOPo->op_last) + cLISTOPo->op_last = kid; + cLISTOPo->op_first = kid; kid->op_sibling = sibl; } pm = (PMOP*)kid; @@ -4266,56 +4687,60 @@ OP *op; scalar(kid); if (!kid->op_sibling) - append_elem(OP_SPLIT, op, newSVREF(newGVOP(OP_GV, 0, defgv)) ); + append_elem(OP_SPLIT, o, newSVREF(newGVOP(OP_GV, 0, defgv)) ); kid = kid->op_sibling; scalar(kid); if (!kid->op_sibling) - append_elem(OP_SPLIT, op, newSVOP(OP_CONST, 0, newSViv(0))); + append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0))); kid = kid->op_sibling; scalar(kid); if (kid->op_sibling) - return too_many_arguments(op,op_desc[op->op_type]); + return too_many_arguments(o,op_desc[o->op_type]); - return op; + return o; } OP * -ck_subr(op) -OP *op; +ck_subr(o) +OP *o; { - OP *prev = ((cUNOP->op_first->op_sibling) - ? cUNOP : ((UNOP*)cUNOP->op_first))->op_first; - OP *o = prev->op_sibling; + dTHR; + OP *prev = ((cUNOPo->op_first->op_sibling) + ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first; + OP *o2 = 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) ; + for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ; if (cvop->op_type == OP_RV2CV) { SVOP* tmpop; - op->op_private |= (cvop->op_private & OPpENTERSUB_AMPER); + o->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)) - proto = SvPV((SV*)cv,na); + if (cv && SvPOK(cv) && !(o->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 |= OPpENTERSUB_DB; - while (o != cvop) { + o->op_private |= (hints & HINT_STRICT_REFS); + if (PERLDB_SUB && curstash != debstash) + o->op_private |= OPpENTERSUB_DB; + while (o2 != cvop) { if (proto) { switch (*proto) { case '\0': - return too_many_arguments(op, CvNAME(cv)); + return too_many_arguments(o, gv_ename(namegv)); case ';': optional = 1; proto++; @@ -4323,28 +4748,28 @@ OP *op; case '$': proto++; arg++; - scalar(o); + scalar(o2); break; case '%': case '@': - list(o); + list(o2); arg++; break; case '&': proto++; arg++; - if (o->op_type != OP_REFGEN && o->op_type != OP_UNDEF) - bad_type(arg, "block", CvNAME(cv), o); + if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF) + bad_type(arg, "block", gv_ename(namegv), o2); break; case '*': proto++; arg++; - if (o->op_type == OP_RV2GV) + if (o2->op_type == OP_RV2GV) goto wrapref; { - OP* kid = o; - o = newUNOP(OP_RV2GV, 0, kid); - o->op_sibling = kid->op_sibling; + OP* kid = o2; + o2 = newUNOP(OP_RV2GV, 0, kid); + o2->op_sibling = kid->op_sibling; kid->op_sibling = 0; prev->op_sibling = o; } @@ -4354,31 +4779,31 @@ OP *op; arg++; switch (*proto++) { case '*': - if (o->op_type != OP_RV2GV) - bad_type(arg, "symbol", CvNAME(cv), o); + if (o2->op_type != OP_RV2GV) + bad_type(arg, "symbol", gv_ename(namegv), o2); goto wrapref; case '&': - if (o->op_type != OP_RV2CV) - bad_type(arg, "sub", CvNAME(cv), o); + if (o2->op_type != OP_RV2CV) + bad_type(arg, "sub", gv_ename(namegv), o2); goto wrapref; case '$': - if (o->op_type != OP_RV2SV && o->op_type != OP_PADSV) - bad_type(arg, "scalar", CvNAME(cv), o); + if (o2->op_type != OP_RV2SV && o2->op_type != OP_PADSV) + bad_type(arg, "scalar", gv_ename(namegv), o2); goto wrapref; case '@': - if (o->op_type != OP_RV2AV && o->op_type != OP_PADAV) - bad_type(arg, "array", CvNAME(cv), o); + if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV) + bad_type(arg, "array", gv_ename(namegv), o2); goto wrapref; case '%': - if (o->op_type != OP_RV2HV && o->op_type != OP_PADHV) - bad_type(arg, "hash", CvNAME(cv), o); + if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV) + bad_type(arg, "hash", gv_ename(namegv), o2); wrapref: { - OP* kid = o; - o = newUNOP(OP_REFGEN, 0, kid); - o->op_sibling = kid->op_sibling; + OP* kid = o2; + o2 = newUNOP(OP_REFGEN, 0, kid); + o2->op_sibling = kid->op_sibling; kid->op_sibling = 0; - prev->op_sibling = o; + prev->op_sibling = o2; } break; default: goto oops; @@ -4390,42 +4815,43 @@ OP *op; default: oops: croak("Malformed prototype for %s: %s", - CvNAME(cv),SvPV((SV*)cv,na)); + 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, CvNAME(cv)); - return op; + list(o2); + mod(o2, OP_ENTERSUB); + prev = o2; + o2 = o2->op_sibling; + } + if (proto && !optional && + (*proto && *proto != '@' && *proto != '%' && *proto != ';')) + return too_few_arguments(o, gv_ename(namegv)); + return o; } OP * -ck_svconst(op) -OP *op; +ck_svconst(o) +OP *o; { - SvREADONLY_on(cSVOP->op_sv); - return op; + SvREADONLY_on(cSVOPo->op_sv); + return o; } OP * -ck_trunc(op) -OP *op; +ck_trunc(o) +OP *o; { - if (op->op_flags & OPf_KIDS) { - SVOP *kid = (SVOP*)cUNOP->op_first; + if (o->op_flags & OPf_KIDS) { + SVOP *kid = (SVOP*)cUNOPo->op_first; 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; + o->op_flags |= OPf_SPECIAL; } - return ck_fun(op); + return ck_fun(o); } /* A peephole optimizer. We visit the ops in the order they're to execute. */ @@ -4434,11 +4860,12 @@ void peep(o) register OP* o; { + dTHR; register OP* oldop = 0; if (!o || o->op_seq) return; ENTER; - SAVESPTR(op); + SAVEOP(); SAVESPTR(curcop); for (; o; o = o->op_next) { if (o->op_seq) @@ -4466,9 +4893,9 @@ register OP* o; o->op_seq = op_seqmax++; break; case OP_STUB: - if ((o->op_flags & (OPf_KNOW|OPf_LIST)) != (OPf_KNOW|OPf_LIST)) { + if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) { o->op_seq = op_seqmax++; - break; /* Scalar stub must produce undef. List stub is noop */ + break; /* Scalar stub must produce undef. List stub is noop */ } goto nothin; case OP_NULL: @@ -4502,7 +4929,8 @@ register OP* o; if (pop->op_type == OP_CONST && (op = pop->op_next) && pop->op_next->op_type == OP_AELEM && - !(pop->op_next->op_private & (OPpDEREF|OPpLVAL_INTRO)) && + !(pop->op_next->op_private & + (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF)) && (i = SvIV(((SVOP*)pop)->op_sv) - compiling.cop_arybase) <= 255 && i >= 0) @@ -4522,6 +4950,24 @@ register OP* o; o->op_seq = op_seqmax++; break; + case OP_PADAV: + if (o->op_next->op_type == OP_RV2AV + && (o->op_next->op_flags && OPf_REF)) + { + null(o->op_next); + o->op_next = o->op_next->op_next; + } + break; + + case OP_PADHV: + if (o->op_next->op_type == OP_RV2HV + && (o->op_next->op_flags && OPf_REF)) + { + null(o->op_next); + o->op_next = o->op_next->op_next; + } + break; + case OP_MAPWHILE: case OP_GREPWHILE: case OP_AND: @@ -4563,6 +5009,47 @@ register OP* o; } } break; + + case OP_HELEM: { + UNOP *rop; + SV *lexname; + GV **fields; + SV **svp, **indsvp; + I32 ind; + char *key; + STRLEN keylen; + + if (o->op_private & (OPpDEREF_HV|OPpDEREF_AV|OPpLVAL_INTRO) + || ((BINOP*)o)->op_last->op_type != OP_CONST) + break; + rop = (UNOP*)((BINOP*)o)->op_first; + if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV) + break; + lexname = *av_fetch(comppad_name, rop->op_first->op_targ, TRUE); + if (!SvOBJECT(lexname)) + break; + fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE); + if (!fields || !GvHV(*fields)) + break; + svp = &((SVOP*)((BINOP*)o)->op_last)->op_sv; + key = SvPV(*svp, keylen); + indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE); + if (!indsvp) { + croak("No such field \"%s\" in variable %s of type %s", + key, SvPV(lexname, na), HvNAME(SvSTASH(lexname))); + } + ind = SvIV(*indsvp); + if (ind < 1) + croak("Bad index while coercing array into hash"); + rop->op_type = OP_RV2AV; + rop->op_ppaddr = ppaddr[OP_RV2AV]; + o->op_type = OP_AELEM; + o->op_ppaddr = ppaddr[OP_AELEM]; + SvREFCNT_dec(*svp); + *svp = newSViv(ind); + break; + } + default: o->op_seq = op_seqmax++; break;