diff options
Diffstat (limited to 'op.c.orig')
| -rw-r--r-- | op.c.orig | 4138 |
1 files changed, 0 insertions, 4138 deletions
diff --git a/op.c.orig b/op.c.orig deleted file mode 100644 index 9ae1bdcde1..0000000000 --- a/op.c.orig +++ /dev/null @@ -1,4138 +0,0 @@ -/* op.c - * - * Copyright (c) 1991-1994, 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. - * - */ - -/* - * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was - * our Mr. Bilbo's first cousin on the mother's side (her mother being the - * youngest of the Old Took's daughters); and Mr. Drogo was his second - * cousin. So Mr. Frodo is his first *and* second cousin, once removed - * either way, as the saying is, if you follow me." --the Gaffer - */ - -#include "EXTERN.h" -#include "perl.h" - -#ifdef USE_OP_MASK -/* - * In the following definition, the ", (OP *) op" is just to make the compiler - * think the expression is of the right type: croak actually does a longjmp. - */ -#define CHECKOP(type,op) ((op_mask && op_mask[type]) ? \ - (croak("%s trapped by operation mask", op_name[type]), (OP *) op) \ - : (*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)); -static PADOFFSET pad_findlex _((char* name, PADOFFSET newoff, I32 seq, - CV* startcv, I32 cx_ix)); - -static char* -CvNAME(cv) -CV* cv; -{ - SV* tmpsv = sv_newmortal(); - gv_efullname(tmpsv, CvGV(cv)); - return SvPV(tmpsv,na); -} - -static OP * -no_fh_allowed(op) -OP *op; -{ - sprintf(tokenbuf,"Missing comma after first argument to %s function", - op_name[op->op_type]); - yyerror(tokenbuf); - return op; -} - -static OP * -too_few_arguments(op, name) -OP* op; -char* name; -{ - sprintf(tokenbuf,"Not enough arguments for %s", name); - yyerror(tokenbuf); - return op; -} - -static OP * -too_many_arguments(op, name) -OP *op; -char* name; -{ - sprintf(tokenbuf,"Too many arguments for %s", name); - yyerror(tokenbuf); - return op; -} - -static OP * -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_name[kid->op_type]); - yyerror(tokenbuf); - return op; -} - -void -assertref(op) -OP *op; -{ - int type = op->op_type; - if (type != OP_AELEM && type != OP_HELEM) { - sprintf(tokenbuf, "Can't use subscript on %s", - op_name[type]); - yyerror(tokenbuf); - if (type == OP_RV2HV || type == OP_ENTERSUB) - warn("(Did you mean $ or @ instead of %c?)\n", - type == OP_RV2HV ? '%' : '&'); - } -} - -/* "register" allocation */ - -PADOFFSET -pad_allocmy(name) -char *name; -{ - PADOFFSET off; - SV *sv; - - if (!(isALPHA(name[1]) || name[1] == '_' && (int)strlen(name) > 2)) { - if (!isprint(name[1])) - sprintf(name+1, "^%c", name[1] ^ 64); /* XXX is tokenbuf, really */ - croak("Can't use global %s in \"my\"",name); - } - off = pad_alloc(OP_PADSV, SVs_PADMY); - sv = NEWSV(1102,0); - sv_upgrade(sv, SVt_PVNV); - sv_setpv(sv, name); - av_store(comppad_name, off, sv); - SvNVX(sv) = (double)999999999; - SvIVX(sv) = 0; /* Not yet introduced--see newSTATEOP */ - if (!min_intro_pending) - min_intro_pending = off; - max_intro_pending = off; - if (*name == '@') - av_store(comppad, off, (SV*)newAV()); - else if (*name == '%') - av_store(comppad, off, (SV*)newHV()); - SvPADMY_on(curpad[off]); - return off; -} - -static PADOFFSET -#ifndef CAN_PROTOTYPE -pad_findlex(name, newoff, seq, startcv, cx_ix) -char *name; -PADOFFSET newoff; -I32 seq; -CV* startcv; -I32 cx_ix; -#else -pad_findlex(char *name, PADOFFSET newoff, I32 seq, CV* startcv, I32 cx_ix) -#endif -{ - CV *cv; - I32 off; - SV *sv; - register I32 i; - register CONTEXT *cx; - int saweval; - - for (cv = startcv; cv; cv = CvOUTSIDE(cv)) { - AV* curlist = CvPADLIST(cv); - SV** svp = av_fetch(curlist, 0, FALSE); - AV *curname; - if (!svp || *svp == &sv_undef) - continue; - curname = (AV*)*svp; - svp = AvARRAY(curname); - for (off = AvFILL(curname); off > 0; off--) { - if ((sv = svp[off]) && - sv != &sv_undef && - seq <= SvIVX(sv) && - seq > (I32)SvNVX(sv) && - strEQ(SvPVX(sv), name)) - { - I32 depth = CvDEPTH(cv) ? CvDEPTH(cv) : 1; - AV *oldpad = (AV*)*av_fetch(curlist, depth, FALSE); - SV *oldsv = *av_fetch(oldpad, off, TRUE); - if (!newoff) { /* Not a mere clone operation. */ - SV *sv = 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 */ - SvFLAGS(sv) |= SVf_FAKE; - } - av_store(comppad, newoff, SvREFCNT_inc(oldsv)); - SvFLAGS(compcv) |= SVpcv_CLONE; - return newoff; - } - } - } - - /* Nothing in current lexical context--try eval's context, if any. - * This is necessary to let the perldb get at lexically scoped variables. - * XXX This will also probably interact badly with eval tree caching. - */ - - saweval = 0; - for (i = cx_ix; i >= 0; i--) { - cx = &cxstack[i]; - switch (cx->cx_type) { - default: - if (i == 0 && saweval) { - seq = cxstack[saweval].blk_oldcop->cop_seq; - return pad_findlex(name, newoff, seq, main_cv, 0); - } - break; - case CXt_EVAL: - if (cx->blk_eval.old_op_type != OP_ENTEREVAL) - return 0; /* require must have its own scope */ - saweval = i; - break; - case CXt_SUB: - if (!saweval) - return 0; - cv = cx->blk_sub.cv; - if (debstash && CvSTASH(cv) == debstash) { /* ignore DB'* scope */ - saweval = i; /* so we know where we were called from */ - continue; - } - seq = cxstack[saweval].blk_oldcop->cop_seq; - return pad_findlex(name, newoff, seq, cv, i-1); - } - } - - return 0; -} - -PADOFFSET -pad_findmy(name) -char *name; -{ - I32 off; - SV *sv; - SV **svp = AvARRAY(comppad_name); - I32 seq = cop_seqmax; - - /* The one we're looking for is probably just before comppad_name_fill. */ - for (off = AvFILL(comppad_name); off > 0; off--) { - if ((sv = svp[off]) && - sv != &sv_undef && - seq <= SvIVX(sv) && - seq > (I32)SvNVX(sv) && - strEQ(SvPVX(sv), name)) - { - return (PADOFFSET)off; - } - } - - /* See if it's in a nested scope */ - off = pad_findlex(name, 0, seq, CvOUTSIDE(compcv), cxstack_ix); - if (off) - return off; - - return 0; -} - -void -pad_leavemy(fill) -I32 fill; -{ - I32 off; - SV **svp = AvARRAY(comppad_name); - SV *sv; - if (min_intro_pending && fill < min_intro_pending) { - for (off = max_intro_pending; off >= min_intro_pending; off--) { - if ((sv = svp[off]) && sv != &sv_undef) - warn("%s never introduced", SvPVX(sv)); - } - } - /* "Deintroduce" my variables that are leaving with this scope. */ - for (off = AvFILL(comppad_name); off > fill; off--) { - if ((sv = svp[off]) && sv != &sv_undef && SvIVX(sv) == 999999999) - SvIVX(sv) = cop_seqmax; - } -} - -PADOFFSET -pad_alloc(optype,tmptype) -I32 optype; -U32 tmptype; -{ - SV *sv; - I32 retval; - - if (AvARRAY(comppad) != curpad) - croak("panic: pad_alloc"); - if (pad_reset_pending) - pad_reset(); - if (tmptype & SVs_PADMY) { - do { - sv = *av_fetch(comppad, AvFILL(comppad) + 1, TRUE); - } while (SvPADBUSY(sv)); /* need a fresh one */ - retval = AvFILL(comppad); - } - else { - do { - sv = *av_fetch(comppad, ++padix, TRUE); - } while (SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)); - retval = padix; - } - SvFLAGS(sv) |= tmptype; - curpad = AvARRAY(comppad); - DEBUG_X(fprintf(stderr, "Pad alloc %ld for %s\n", (long) retval, op_name[optype])); - return (PADOFFSET)retval; -} - -SV * -#ifndef CAN_PROTOTYPE -pad_sv(po) -PADOFFSET po; -#else -pad_sv(PADOFFSET po) -#endif /* CAN_PROTOTYPE */ -{ - if (!po) - croak("panic: pad_sv po"); - DEBUG_X(fprintf(stderr, "Pad sv %d\n", po)); - return curpad[po]; /* eventually we'll turn this into a macro */ -} - -void -#ifndef CAN_PROTOTYPE -pad_free(po) -PADOFFSET po; -#else -pad_free(PADOFFSET po) -#endif /* CAN_PROTOTYPE */ -{ - if (!curpad) - return; - if (AvARRAY(comppad) != curpad) - croak("panic: pad_free curpad"); - if (!po) - croak("panic: pad_free po"); - DEBUG_X(fprintf(stderr, "Pad free %d\n", po)); - if (curpad[po] && curpad[po] != &sv_undef) - SvPADTMP_off(curpad[po]); - if ((I32)po < padix) - padix = po - 1; -} - -void -#ifndef CAN_PROTOTYPE -pad_swipe(po) -PADOFFSET po; -#else -pad_swipe(PADOFFSET po) -#endif /* CAN_PROTOTYPE */ -{ - if (AvARRAY(comppad) != curpad) - croak("panic: pad_swipe curpad"); - if (!po) - croak("panic: pad_swipe po"); - DEBUG_X(fprintf(stderr, "Pad swipe %d\n", po)); - SvPADTMP_off(curpad[po]); - curpad[po] = NEWSV(1107,0); - SvPADTMP_on(curpad[po]); - if ((I32)po < padix) - padix = po - 1; -} - -void -pad_reset() -{ - register I32 po; - - if (AvARRAY(comppad) != curpad) - croak("panic: pad_reset curpad"); - DEBUG_X(fprintf(stderr, "Pad reset\n")); - if (!tainting) { /* Can't mix tainted and non-tainted temporaries. */ - for (po = AvMAX(comppad); po > padix_floor; po--) { - if (curpad[po] && curpad[po] != &sv_undef) - SvPADTMP_off(curpad[po]); - } - padix = padix_floor; - } - pad_reset_pending = FALSE; -} - -/* Destructor */ - -void -op_free(op) -OP *op; -{ - register OP *kid, *nextkid; - - if (!op) - return; - - if (op->op_flags & OPf_KIDS) { - for (kid = cUNOP->op_first; kid; kid = nextkid) { - nextkid = kid->op_sibling; /* Get before next freeing kid */ - op_free(kid); - } - } - - switch (op->op_type) { - case OP_NULL: - op->op_targ = 0; /* Was holding old type, if any. */ - break; - case OP_ENTEREVAL: - op->op_targ = 0; /* Was holding hints. */ - break; - case OP_GVSV: - case OP_GV: - SvREFCNT_dec(cGVOP->op_gv); - break; - case OP_NEXTSTATE: - case OP_DBSTATE: - SvREFCNT_dec(cCOP->cop_filegv); - break; - case OP_CONST: - SvREFCNT_dec(cSVOP->op_sv); - break; - case OP_GOTO: - case OP_NEXT: - case OP_LAST: - case OP_REDO: - if (op->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS)) - break; - /* FALL THROUGH */ - case OP_TRANS: - Safefree(cPVOP->op_pv); - break; - case OP_SUBST: - op_free(cPMOP->op_pmreplroot); - /* FALL THROUGH */ - case OP_PUSHRE: - case OP_MATCH: - pregfree(cPMOP->op_pmregexp); - SvREFCNT_dec(cPMOP->op_pmshort); - break; - default: - break; - } - - if (op->op_targ > 0) - pad_free(op->op_targ); - - Safefree(op); -} - -static void -null(op) -OP* op; -{ - 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]; -} - -/* Contextualizers */ - -#define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o)) - -OP * -linklist(op) -OP *op; -{ - register OP *kid; - - if (op->op_next) - return op->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 (kid->op_sibling) - kid->op_next = LINKLIST(kid->op_sibling); - else - kid->op_next = op; - } - } - else - op->op_next = op; - - return op->op_next; -} - -OP * -scalarkids(op) -OP *op; -{ - OP *kid; - if (op && op->op_flags & OPf_KIDS) { - for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) - scalar(kid); - } - return op; -} - -static OP * -scalarboolean(op) -OP *op; -{ - if (dowarn && - op->op_type == OP_SASSIGN && cBINOP->op_first->op_type == OP_CONST) { - line_t oldline = curcop->cop_line; - - if (copline != NOLINE) - curcop->cop_line = copline; - warn("Found = in conditional, should be =="); - curcop->cop_line = oldline; - } - return scalar(op); -} - -OP * -scalar(op) -OP *op; -{ - OP *kid; - - /* assumes no premature commitment */ - if (!op || (op->op_flags & OPf_KNOW) || error_count) - return op; - - op->op_flags &= ~OPf_LIST; - op->op_flags |= OPf_KNOW; - - switch (op->op_type) { - case OP_REPEAT: - if (op->op_private & OPpREPEAT_DOLIST) - null(((LISTOP*)cBINOP->op_first)->op_first); - scalar(cBINOP->op_first); - break; - case OP_OR: - case OP_AND: - case OP_COND_EXPR: - for (kid = cUNOP->op_first->op_sibling; kid; kid = kid->op_sibling) - scalar(kid); - break; - case OP_SPLIT: - if ((kid = ((LISTOP*)op)->op_first) && kid->op_type == OP_PUSHRE) { - if (!kPMOP->op_pmreplroot) - deprecate("implicit split to @_"); - } - /* FALL THROUGH */ - case OP_MATCH: - case OP_SUBST: - case OP_NULL: - default: - if (op->op_flags & OPf_KIDS) { - for (kid = cUNOP->op_first; kid; kid = kid->op_sibling) - scalar(kid); - } - break; - case OP_LEAVE: - case OP_LEAVETRY: - scalar(cLISTOP->op_first); - /* FALL THROUGH */ - case OP_SCOPE: - case OP_LINESEQ: - case OP_LIST: - for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) { - if (kid->op_sibling) - scalarvoid(kid); - else - scalar(kid); - } - curcop = &compiling; - break; - } - return op; -} - -OP * -scalarvoid(op) -OP *op; -{ - OP *kid; - char* useless = 0; - SV* sv; - - if (!op || error_count) - return op; - if (op->op_flags & OPf_LIST) - return op; - - op->op_flags |= OPf_KNOW; - - switch (op->op_type) { - default: - if (!(opargs[op->op_type] & OA_FOLDCONST)) - break; - if (op->op_flags & OPf_STACKED) - break; - /* FALL THROUGH */ - case OP_GVSV: - case OP_WANTARRAY: - case OP_GV: - case OP_PADSV: - case OP_PADAV: - case OP_PADHV: - case OP_PADANY: - case OP_AV2ARYLEN: - case OP_SV2LEN: - case OP_REF: - case OP_REFGEN: - case OP_SREFGEN: - case OP_DEFINED: - case OP_HEX: - case OP_OCT: - case OP_LENGTH: - case OP_SUBSTR: - case OP_VEC: - case OP_INDEX: - case OP_RINDEX: - case OP_SPRINTF: - case OP_AELEM: - case OP_AELEMFAST: - case OP_ASLICE: - case OP_VALUES: - case OP_KEYS: - case OP_HELEM: - case OP_HSLICE: - case OP_UNPACK: - case OP_PACK: - case OP_JOIN: - case OP_LSLICE: - case OP_ANONLIST: - case OP_ANONHASH: - case OP_SORT: - case OP_REVERSE: - case OP_RANGE: - case OP_FLIP: - case OP_FLOP: - case OP_CALLER: - case OP_FILENO: - case OP_EOF: - case OP_TELL: - case OP_GETSOCKNAME: - case OP_GETPEERNAME: - case OP_READLINK: - case OP_TELLDIR: - case OP_GETPPID: - case OP_GETPGRP: - case OP_GETPRIORITY: - case OP_TIME: - case OP_TMS: - case OP_LOCALTIME: - case OP_GMTIME: - case OP_GHBYNAME: - case OP_GHBYADDR: - case OP_GHOSTENT: - case OP_GNBYNAME: - case OP_GNBYADDR: - case OP_GNETENT: - case OP_GPBYNAME: - case OP_GPBYNUMBER: - case OP_GPROTOENT: - case OP_GSBYNAME: - case OP_GSBYPORT: - case OP_GSERVENT: - case OP_GPWNAM: - case OP_GPWUID: - case OP_GGRNAM: - case OP_GGRGID: - case OP_GETLOGIN: - if (!(op->op_private & OPpLVAL_INTRO)) - useless = op_name[op->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)) - useless = "a variable"; - break; - - case OP_NEXTSTATE: - case OP_DBSTATE: - curcop = ((COP*)op); /* for warning below */ - break; - - case OP_CONST: - sv = cSVOP->op_sv; - if (dowarn) { - useless = "a constant"; - if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0)) - useless = 0; - else if (SvPOK(sv)) { - if (strnEQ(SvPVX(sv), "di", 2) || - strnEQ(SvPVX(sv), "ds", 2) || - strnEQ(SvPVX(sv), "ig", 2)) - useless = 0; - } - } - null(op); /* 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]; - break; - - case OP_POSTDEC: - op->op_type = OP_PREDEC; /* pre-decrement is faster */ - op->op_ppaddr = ppaddr[OP_PREDEC]; - break; - - case OP_REPEAT: - scalarvoid(cBINOP->op_first); - useless = op_name[op->op_type]; - break; - - case OP_OR: - case OP_AND: - case OP_COND_EXPR: - for (kid = cUNOP->op_first->op_sibling; kid; kid = kid->op_sibling) - scalarvoid(kid); - break; - case OP_NULL: - if (op->op_targ == OP_NEXTSTATE || op->op_targ == OP_DBSTATE) - curcop = ((COP*)op); /* for warning below */ - if (op->op_flags & OPf_STACKED) - break; - case OP_ENTERTRY: - case OP_ENTER: - case OP_SCALAR: - if (!(op->op_flags & OPf_KIDS)) - break; - 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) - scalarvoid(kid); - break; - case OP_SPLIT: - if ((kid = ((LISTOP*)op)->op_first) && kid->op_type == OP_PUSHRE) { - if (!kPMOP->op_pmreplroot) - deprecate("implicit split to @_"); - } - break; - case OP_DELETE: - op->op_private |= OPpLEAVE_VOID; - break; - } - if (useless && dowarn) - warn("Useless use of %s in void context", useless); - return op; -} - -OP * -listkids(op) -OP *op; -{ - OP *kid; - if (op && op->op_flags & OPf_KIDS) { - for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) - list(kid); - } - return op; -} - -OP * -list(op) -OP *op; -{ - OP *kid; - - /* assumes no premature commitment */ - if (!op || (op->op_flags & OPf_KNOW) || error_count) - return op; - - op->op_flags |= (OPf_KNOW | OPf_LIST); - - switch (op->op_type) { - case OP_FLOP: - case OP_REPEAT: - list(cBINOP->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) - list(kid); - break; - default: - case OP_MATCH: - case OP_SUBST: - case OP_NULL: - if (!(op->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); - } - case OP_LIST: - listkids(op); - break; - case OP_LEAVE: - case OP_LEAVETRY: - list(cLISTOP->op_first); - /* FALL THROUGH */ - case OP_SCOPE: - case OP_LINESEQ: - for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) { - if (kid->op_sibling) - scalarvoid(kid); - else - list(kid); - } - curcop = &compiling; - break; - } - return op; -} - -OP * -scalarseq(op) -OP *op; -{ - 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) - { - for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) { - if (kid->op_sibling) { - scalarvoid(kid); - } - } - curcop = &compiling; - } - op->op_flags &= ~OPf_PARENS; - if (hints & HINT_BLOCK_SCOPE) - op->op_flags |= OPf_PARENS; - } - else - op = newOP(OP_STUB, 0); - return op; -} - -static OP * -modkids(op, type) -OP *op; -I32 type; -{ - OP *kid; - if (op && op->op_flags & OPf_KIDS) { - for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) - mod(kid, type); - } - return op; -} - -static I32 modcount; - -OP * -mod(op, type) -OP *op; -I32 type; -{ - OP *kid; - SV *sv; - char mtype; - - if (!op || error_count) - return op; - - switch (op->op_type) { - case OP_CONST: - if (!(op->op_private & (OPpCONST_ARYBASE))) - goto nomod; - if (eval_start && eval_start->op_type == OP_CONST) { - compiling.cop_arybase = (I32)SvIV(((SVOP*)eval_start)->op_sv); - eval_start = 0; - } - else if (!type) { - SAVEI32(compiling.cop_arybase); - compiling.cop_arybase = 0; - } - else if (type == OP_REFGEN) - goto nomod; - else - croak("That use of $[ is unsupported"); - break; - case OP_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 */ - break; - } - /* FALL THROUGH */ - default: - nomod: - /* grep, foreach, subcalls, refgen */ - if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) - break; - sprintf(tokenbuf, "Can't modify %s in %s", - op_name[op->op_type], - type ? op_name[type] : "local"); - yyerror(tokenbuf); - return op; - - case OP_PREINC: - case OP_PREDEC: - case OP_POW: - case OP_MULTIPLY: - case OP_DIVIDE: - case OP_MODULO: - case OP_REPEAT: - case OP_ADD: - case OP_SUBTRACT: - case OP_CONCAT: - case OP_LEFT_SHIFT: - case OP_RIGHT_SHIFT: - case OP_BIT_AND: - case OP_BIT_XOR: - case OP_BIT_OR: - case OP_I_MULTIPLY: - case OP_I_DIVIDE: - case OP_I_MODULO: - case OP_I_ADD: - case OP_I_SUBTRACT: - if (!(op->op_flags & OPf_STACKED)) - goto nomod; - modcount++; - break; - - case OP_COND_EXPR: - for (kid = cUNOP->op_first->op_sibling; kid; kid = kid->op_sibling) - mod(kid, type); - break; - - case OP_RV2AV: - case OP_RV2HV: - if (type == OP_REFGEN && op->op_flags & OPf_PARENS) { - modcount = 10000; - return op; /* Treat \(@foo) like ordinary list. */ - } - /* FALL THROUGH */ - case OP_RV2GV: - ref(cUNOP->op_first, op->op_type); - /* FALL THROUGH */ - case OP_AASSIGN: - case OP_ASLICE: - case OP_HSLICE: - case OP_NEXTSTATE: - case OP_DBSTATE: - case OP_REFGEN: - case OP_CHOMP: - 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); - /* FALL THROUGH */ - case OP_UNDEF: - case OP_GV: - case OP_AV2ARYLEN: - case OP_SASSIGN: - case OP_AELEMFAST: - modcount++; - break; - - case OP_PADAV: - case OP_PADHV: - modcount = 10000; - /* FALL THROUGH */ - case OP_PADSV: - modcount++; - if (!type) - croak("Can't localize lexical variable %s", - SvPV(*av_fetch(comppad_name, op->op_targ, 4), na)); - break; - - case OP_PUSHMARK: - break; - - case OP_POS: - mtype = '.'; - goto makelv; - case OP_VEC: - mtype = 'v'; - goto makelv; - case OP_SUBSTR: - mtype = 'x'; - makelv: - pad_free(op->op_targ); - op->op_targ = pad_alloc(op->op_type, SVs_PADMY); - sv = PAD_SV(op->op_targ); - sv_upgrade(sv, SVt_PVLV); - sv_magic(sv, Nullsv, mtype, Nullch, 0); - curpad[op->op_targ] = sv; - if (op->op_flags & OPf_KIDS) - mod(cBINOP->op_first->op_sibling, type); - break; - - case OP_AELEM: - case OP_HELEM: - ref(cBINOP->op_first, op->op_type); - modcount++; - break; - - case OP_SCOPE: - case OP_LEAVE: - case OP_ENTER: - if (op->op_flags & OPf_KIDS) - mod(cLISTOP->op_last, type); - break; - - case OP_NULL: - if (!(op->op_flags & OPf_KIDS)) - break; - if (op->op_targ != OP_LIST) { - mod(cBINOP->op_first, type); - break; - } - /* FALL THROUGH */ - case OP_LIST: - for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) - mod(kid, type); - break; - } - op->op_flags |= OPf_MOD; - - if (type == OP_AASSIGN || type == OP_SASSIGN) - op->op_flags |= OPf_SPECIAL|OPf_REF; - else if (!type) { - op->op_private |= OPpLVAL_INTRO; - op->op_flags &= ~OPf_SPECIAL; - } - else if (type != OP_GREPSTART && type != OP_ENTERSUB) - op->op_flags |= OPf_REF; - return op; -} - -OP * -refkids(op, type) -OP *op; -I32 type; -{ - OP *kid; - if (op && op->op_flags & OPf_KIDS) { - for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) - ref(kid, type); - } - return op; -} - -OP * -ref(op, type) -OP *op; -I32 type; -{ - OP *kid; - - if (!op || error_count) - return op; - - switch (op->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; - } - break; - - case OP_COND_EXPR: - for (kid = cUNOP->op_first->op_sibling; kid; kid = kid->op_sibling) - ref(kid, type); - break; - case OP_RV2SV: - ref(cUNOP->op_first, op->op_type); - /* FALL THROUGH */ - case OP_PADSV: - if (type == OP_RV2AV || type == OP_RV2HV) { - op->op_private |= (type == OP_RV2AV ? OPpDEREF_AV : OPpDEREF_HV); - op->op_flags |= OPf_MOD; - } - break; - - case OP_RV2AV: - case OP_RV2HV: - op->op_flags |= OPf_REF; - /* FALL THROUGH */ - case OP_RV2GV: - ref(cUNOP->op_first, op->op_type); - break; - - case OP_PADAV: - case OP_PADHV: - op->op_flags |= OPf_REF; - break; - - case OP_SCALAR: - case OP_NULL: - if (!(op->op_flags & OPf_KIDS)) - break; - ref(cBINOP->op_first, type); - break; - case OP_AELEM: - case OP_HELEM: - ref(cBINOP->op_first, op->op_type); - if (type == OP_RV2AV || type == OP_RV2HV) { - op->op_private |= (type == OP_RV2AV ? OPpDEREF_AV : OPpDEREF_HV); - op->op_flags |= OPf_MOD; - } - break; - - case OP_SCOPE: - case OP_LEAVE: - case OP_ENTER: - case OP_LIST: - if (!(op->op_flags & OPf_KIDS)) - break; - ref(cLISTOP->op_last, type); - break; - default: - break; - } - return scalar(op); - -} - -OP * -my(op) -OP *op; -{ - OP *kid; - I32 type; - - if (!op || error_count) - return op; - - type = op->op_type; - if (type == OP_LIST) { - for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) - my(kid); - } - else if (type != OP_PADSV && - type != OP_PADAV && - type != OP_PADHV && - type != OP_PUSHMARK) - { - sprintf(tokenbuf, "Can't declare %s in my", op_name[op->op_type]); - yyerror(tokenbuf); - return op; - } - op->op_flags |= OPf_MOD; - op->op_private |= OPpLVAL_INTRO; - return op; -} - -OP * -sawparens(o) -OP *o; -{ - if (o) - o->op_flags |= OPf_PARENS; - return o; -} - -OP * -bind_match(type, left, right) -I32 type; -OP *left; -OP *right; -{ - OP *op; - - if (right->op_type == OP_MATCH || - right->op_type == OP_SUBST || - right->op_type == OP_TRANS) { - right->op_flags |= OPf_STACKED; - 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); - else - op = prepend_elem(right->op_type, scalar(left), right); - if (type == OP_NOT) - return newUNOP(OP_NOT, 0, scalar(op)); - return op; - } - else - return bind_match(type, left, - pmruntime(newPMOP(OP_MATCH, 0), right, Nullop)); -} - -OP * -invert(op) -OP *op; -{ - if (!op) - return op; - /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */ - return newUNOP(OP_NOT, OPf_SPECIAL, scalar(op)); -} - -OP * -scope(o) -OP *o; -{ - if (o) { - if (o->op_flags & OPf_PARENS || perldb || tainting) { - o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o); - o->op_type = OP_LEAVE; - o->op_ppaddr = ppaddr[OP_LEAVE]; - } - else { - if (o->op_type == OP_LINESEQ) { - OP *kid; - o->op_type = OP_SCOPE; - o->op_ppaddr = ppaddr[OP_SCOPE]; - kid = ((LISTOP*)o)->op_first; - if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE){ - SvREFCNT_dec(((COP*)kid)->cop_filegv); - null(kid); - } - } - else - o = newLISTOP(OP_SCOPE, 0, o, Nullop); - } - } - return o; -} - -int -block_start() -{ - int retval = savestack_ix; - comppad_name_fill = AvFILL(comppad_name); - SAVEINT(min_intro_pending); - SAVEINT(max_intro_pending); - min_intro_pending = 0; - SAVEINT(comppad_name_fill); - SAVEINT(padix_floor); - padix_floor = padix; - pad_reset_pending = FALSE; - SAVEINT(hints); - hints &= ~HINT_BLOCK_SCOPE; - return retval; -} - -OP* -block_end(line, floor, seq) -int line; -int floor; -OP* seq; -{ - int needblockscope = hints & HINT_BLOCK_SCOPE; - OP* retval = scalarseq(seq); - if (copline > (line_t)line) - copline = line; - LEAVE_SCOPE(floor); - pad_reset_pending = FALSE; - if (needblockscope) - hints |= HINT_BLOCK_SCOPE; /* propagate out */ - pad_leavemy(comppad_name_fill); - return retval; -} - -void -newPROG(op) -OP *op; -{ - if (in_eval) { - eval_root = newUNOP(OP_LEAVEEVAL, 0, op); - eval_start = linklist(eval_root); - eval_root->op_next = 0; - peep(eval_start); - } - else { - if (!op) { - main_start = 0; - return; - } - main_root = scope(sawparens(scalarvoid(op))); - curcop = &compiling; - main_start = LINKLIST(main_root); - main_root->op_next = 0; - peep(main_start); - main_cv = compcv; - compcv = 0; - } -} - -OP * -localize(o, lex) -OP *o; -I32 lex; -{ - if (o->op_flags & OPf_PARENS) - list(o); - else { - scalar(o); - if (dowarn && bufptr > oldbufptr && bufptr[-1] == ',') { - char *s; - for (s = bufptr; *s && (isALNUM(*s) || strchr("@$%, ",*s)); s++) ; - if (*s == ';' || *s == '=') - warn("Parens missing around \"%s\" list", lex ? "my" : "local"); - } - } - in_my = FALSE; - if (lex) - return my(o); - else - return mod(o, OP_NULL); /* a bit kludgey */ -} - -OP * -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)); - } - return o; -} - -OP * -fold_constants(o) -register OP *o; -{ - register OP *curop; - I32 type = o->op_type; - SV *sv; - - if (opargs[type] & OA_RETSCALAR) - scalar(o); - if (opargs[type] & OA_TARGET) - o->op_targ = pad_alloc(type, SVs_PADTMP); - - if ((opargs[type] & OA_OTHERINT) && (hints & HINT_INTEGER)) - o->op_ppaddr = ppaddr[type = ++(o->op_type)]; - - if (!(opargs[type] & OA_FOLDCONST)) - goto nope; - - if (error_count) - goto nope; /* Don't try to run w/ errors */ - - for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) { - if (curop->op_type != OP_CONST && - curop->op_type != OP_LIST && - curop->op_type != OP_SCALAR && - curop->op_type != OP_NULL && - curop->op_type != OP_PUSHMARK) { - goto nope; - } - } - - curop = LINKLIST(o); - o->op_next = 0; - op = curop; - run(); - sv = *(stack_sp--); - if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */ - pad_swipe(o->op_targ); - else if (SvTEMP(sv)) { /* grab mortal temp? */ - (void)SvREFCNT_inc(sv); - SvTEMP_off(sv); - } - op_free(o); - if (type == OP_RV2GV) - return newGVOP(OP_GV, 0, sv); - else { - if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK) { - IV iv = SvIV(sv); - if ((double)iv == SvNV(sv)) { /* can we smush double to int */ - SvREFCNT_dec(sv); - sv = newSViv(iv); - } - } - return newSVOP(OP_CONST, 0, sv); - } - - nope: - if (!(opargs[type] & OA_OTHERINT)) - return o; - - if (!(hints & HINT_INTEGER)) { - if (type == OP_DIVIDE || !(o->op_flags & OPf_KIDS)) - return o; - - for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) { - if (curop->op_type == OP_CONST) { - if (SvIOK(((SVOP*)curop)->op_sv)) - continue; - return o; - } - if (opargs[curop->op_type] & OA_RETINTEGER) - continue; - return o; - } - o->op_ppaddr = ppaddr[++(o->op_type)]; - } - - return o; -} - -OP * -gen_constant_list(o) -register OP *o; -{ - register OP *curop; - I32 oldtmps_floor = tmps_floor; - - list(o); - if (error_count) - return o; /* Don't attempt to run with errors */ - - op = curop = LINKLIST(o); - o->op_next = 0; - pp_pushmark(); - run(); - op = curop; - pp_anonlist(); - tmps_floor = oldtmps_floor; - - o->op_type = OP_RV2AV; - o->op_ppaddr = ppaddr[OP_RV2AV]; - curop = ((UNOP*)o)->op_first; - ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*stack_sp--)); - op_free(curop); - linklist(o); - return list(o); -} - -OP * -convert(type, flags, op) -I32 type; -I32 flags; -OP* op; -{ - OP *kid; - OP *last = 0; - - if (!op || op->op_type != OP_LIST) - op = newLISTOP(OP_LIST, 0, op, Nullop); - else - op->op_flags &= ~(OPf_KNOW|OPf_LIST); - - if (!(opargs[type] & OA_MARK)) - null(cLISTOP->op_first); - - op->op_type = type; - op->op_ppaddr = ppaddr[type]; - op->op_flags |= flags; - - op = CHECKOP(type, op); - if (op->op_type != type) - return op; - - if (cLISTOP->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) - last = kid; - cLISTOP->op_last = last; /* in case check substituted last arg */ - } - - return fold_constants(op); -} - -/* List constructors */ - -OP * -append_elem(type, first, last) -I32 type; -OP* first; -OP* last; -{ - if (!first) - return last; - - if (!last) - return first; - - if (first->op_type != type || type==OP_LIST && first->op_flags & OPf_PARENS) - return newLISTOP(type, 0, first, last); - - if (first->op_flags & OPf_KIDS) - ((LISTOP*)first)->op_last->op_sibling = last; - else { - first->op_flags |= OPf_KIDS; - ((LISTOP*)first)->op_first = last; - } - ((LISTOP*)first)->op_last = last; - ((LISTOP*)first)->op_children++; - return first; -} - -OP * -append_list(type, first, last) -I32 type; -LISTOP* first; -LISTOP* last; -{ - if (!first) - return (OP*)last; - - if (!last) - return (OP*)first; - - if (first->op_type != type) - return prepend_elem(type, (OP*)first, (OP*)last); - - if (last->op_type != type) - return append_elem(type, (OP*)first, (OP*)last); - - first->op_last->op_sibling = last->op_first; - first->op_last = last->op_last; - first->op_children += last->op_children; - if (first->op_children) - last->op_flags |= OPf_KIDS; - - Safefree(last); - return (OP*)first; -} - -OP * -prepend_elem(type, first, last) -I32 type; -OP* first; -OP* last; -{ - if (!first) - return last; - - if (!last) - return first; - - if (last->op_type == type) { - if (type == OP_LIST) { /* already a PUSHMARK there */ - first->op_sibling = ((LISTOP*)last)->op_first->op_sibling; - ((LISTOP*)last)->op_first->op_sibling = first; - } - else { - if (!(last->op_flags & OPf_KIDS)) { - ((LISTOP*)last)->op_last = first; - last->op_flags |= OPf_KIDS; - } - first->op_sibling = ((LISTOP*)last)->op_first; - ((LISTOP*)last)->op_first = first; - } - ((LISTOP*)last)->op_children++; - return last; - } - - return newLISTOP(type, 0, first, last); -} - -/* Constructors */ - -OP * -newNULLLIST() -{ - return newOP(OP_STUB, 0); -} - -OP * -force_list(op) -OP* op; -{ - if (!op || op->op_type != OP_LIST) - op = newLISTOP(OP_LIST, 0, op, Nullop); - null(op); - return op; -} - -OP * -newLISTOP(type, flags, first, last) -I32 type; -I32 flags; -OP* first; -OP* last; -{ - LISTOP *listop; - - Newz(1101, listop, 1, LISTOP); - - listop->op_type = type; - listop->op_ppaddr = ppaddr[type]; - listop->op_children = (first != 0) + (last != 0); - listop->op_flags = flags; - - if (!last && first) - last = first; - else if (!first && last) - first = last; - else if (first) - first->op_sibling = last; - listop->op_first = first; - listop->op_last = last; - if (type == OP_LIST) { - OP* pushop; - pushop = newOP(OP_PUSHMARK, 0); - pushop->op_sibling = first; - listop->op_first = pushop; - listop->op_flags |= OPf_KIDS; - if (!last) - listop->op_last = pushop; - } - else if (listop->op_children) - listop->op_flags |= OPf_KIDS; - - return (OP*)listop; -} - -OP * -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->op_next = op; - /* op->op_private = 0; */ - if (opargs[type] & OA_RETSCALAR) - scalar(op); - if (opargs[type] & OA_TARGET) - op->op_targ = pad_alloc(type, SVs_PADTMP); - return CHECKOP(type, op); -} - -OP * -newUNOP(type, flags, first) -I32 type; -I32 flags; -OP* first; -{ - UNOP *unop; - - if (!first) - first = newOP(OP_STUB, 0); - if (opargs[type] & OA_MARK) - first = force_list(first); - - Newz(1101, unop, 1, UNOP); - unop->op_type = type; - unop->op_ppaddr = ppaddr[type]; - unop->op_first = first; - unop->op_flags = flags | OPf_KIDS; - unop->op_private = 1; - - unop = (UNOP*) CHECKOP(type, unop); - if (unop->op_next) - return (OP*)unop; - - return fold_constants((OP *) unop); -} - -OP * -newBINOP(type, flags, first, last) -I32 type; -I32 flags; -OP* first; -OP* last; -{ - BINOP *binop; - Newz(1101, binop, 1, BINOP); - - if (!first) - first = newOP(OP_NULL, 0); - - binop->op_type = type; - binop->op_ppaddr = ppaddr[type]; - binop->op_first = first; - binop->op_flags = flags | OPf_KIDS; - if (!last) { - last = first; - binop->op_private = 1; - } - else { - binop->op_private = 2; - first->op_sibling = last; - } - - binop = (BINOP*)CHECKOP(type, binop); - if (binop->op_next) - return (OP*)binop; - - binop->op_last = last = binop->op_first->op_sibling; - - return fold_constants((OP *)binop); -} - -OP * -pmtrans(op, expr, repl) -OP *op; -OP *expr; -OP *repl; -{ - SV *tstr = ((SVOP*)expr)->op_sv; - SV *rstr = ((SVOP*)repl)->op_sv; - STRLEN tlen; - STRLEN rlen; - register char *t = SvPV(tstr, tlen); - register char *r = SvPV(rstr, rlen); - register I32 i; - register I32 j; - I32 delete; - 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; */ - - if (complement) { - Zero(tbl, 256, short); - for (i = 0; i < tlen; i++) - tbl[t[i] & 0377] = -1; - for (i = 0, j = 0; i < 256; i++) { - if (!tbl[i]) { - if (j >= rlen) { - if (delete) - tbl[i] = -2; - else if (rlen) - tbl[i] = r[j-1] & 0377; - else - tbl[i] = i; - } - else - tbl[i] = r[j++] & 0377; - } - } - } - else { - if (!rlen && !delete) { - r = t; rlen = tlen; - } - for (i = 0; i < 256; i++) - tbl[i] = -1; - for (i = 0, j = 0; i < tlen; i++,j++) { - if (j >= rlen) { - if (delete) { - if (tbl[t[i] & 0377] == -1) - tbl[t[i] & 0377] = -2; - continue; - } - --j; - } - if (tbl[t[i] & 0377] == -1) - tbl[t[i] & 0377] = r[j] & 0377; - } - } - op_free(expr); - op_free(repl); - - return op; -} - -OP * -newPMOP(type, flags) -I32 type; -I32 flags; -{ - PMOP *pmop; - - Newz(1101, pmop, 1, PMOP); - pmop->op_type = type; - pmop->op_ppaddr = ppaddr[type]; - pmop->op_flags = flags; - pmop->op_private = 0; - - /* link into pm list */ - if (type != OP_TRANS && curstash) { - pmop->op_pmnext = HvPMROOT(curstash); - HvPMROOT(curstash) = pmop; - } - - return (OP*)pmop; -} - -OP * -pmruntime(op, expr, repl) -OP *op; -OP *expr; -OP *repl; -{ - PMOP *pm; - LOGOP *rcop; - - if (op->op_type == OP_TRANS) - return pmtrans(op, expr, repl); - - pm = (PMOP*)op; - - 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, " ")) { - sv_setpvn(pat, "\\s+", 3); - p = SvPV(pat, plen); - pm->op_pmflags |= PMf_SKIPWHITE; - } - pm->op_pmregexp = pregcomp(p, p + plen, pm); - if (strEQ("\\s+", pm->op_pmregexp->precomp)) - pm->op_pmflags |= PMf_WHITE; - hoistmust(pm); - op_free(expr); - } - else { - if (pm->op_pmflags & PMf_KEEP) - expr = newUNOP(OP_REGCMAYBE,0,expr); - - Newz(1101, rcop, 1, LOGOP); - rcop->op_type = OP_REGCOMP; - rcop->op_ppaddr = ppaddr[OP_REGCOMP]; - rcop->op_first = scalar(expr); - rcop->op_flags |= OPf_KIDS; - rcop->op_private = 1; - rcop->op_other = op; - - /* establish postfix order */ - if (pm->op_pmflags & PMf_KEEP) { - LINKLIST(expr); - rcop->op_next = expr; - ((UNOP*)expr)->op_first->op_next = (OP*)rcop; - } - else { - rcop->op_next = LINKLIST(expr); - expr->op_next = (OP*)rcop; - } - - prepend_elem(op->op_type, scalar((OP*)rcop), op); - } - - if (repl) { - OP *curop; - if (pm->op_pmflags & PMf_EVAL) - curop = 0; - 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) { - if (curop->op_type == OP_GV) { - GV *gv = ((GVOP*)curop)->op_gv; - if (strchr("&`'123456789+", *GvENAME(gv))) - break; - } - else if (curop->op_type == OP_RV2CV) - break; - else if (curop->op_type == OP_RV2SV || - curop->op_type == OP_RV2AV || - curop->op_type == OP_RV2HV || - curop->op_type == OP_RV2GV) { - if (lastop && lastop->op_type != OP_GV) /*funny deref?*/ - break; - } - else if (curop->op_type == OP_PADSV || - curop->op_type == OP_PADAV || - curop->op_type == OP_PADHV || - curop->op_type == OP_PADANY) { - /* is okay */ - } - else - break; - } - lastop = curop; - } - } - if (curop == repl) { - pm->op_pmflags |= PMf_CONST; /* const for long enough */ - pm->op_pmpermflags |= PMf_CONST; /* const for long enough */ - prepend_elem(op->op_type, scalar(repl), op); - } - else { - Newz(1101, rcop, 1, LOGOP); - rcop->op_type = OP_SUBSTCONT; - rcop->op_ppaddr = ppaddr[OP_SUBSTCONT]; - rcop->op_first = scalar(repl); - rcop->op_flags |= OPf_KIDS; - rcop->op_private = 1; - rcop->op_other = op; - - /* establish postfix order */ - rcop->op_next = LINKLIST(repl); - repl->op_next = (OP*)rcop; - - pm->op_pmreplroot = scalar((OP*)rcop); - pm->op_pmreplstart = LINKLIST(rcop); - rcop->op_next = 0; - } - } - - return (OP*)pm; -} - -OP * -newSVOP(type, flags, sv) -I32 type; -I32 flags; -SV *sv; -{ - SVOP *svop; - Newz(1101, svop, 1, SVOP); - svop->op_type = type; - svop->op_ppaddr = ppaddr[type]; - svop->op_sv = sv; - svop->op_next = (OP*)svop; - svop->op_flags = flags; - if (opargs[type] & OA_RETSCALAR) - scalar((OP*)svop); - if (opargs[type] & OA_TARGET) - svop->op_targ = pad_alloc(type, SVs_PADTMP); - return CHECKOP(type, svop); -} - -OP * -newGVOP(type, flags, gv) -I32 type; -I32 flags; -GV *gv; -{ - GVOP *gvop; - Newz(1101, gvop, 1, GVOP); - gvop->op_type = type; - gvop->op_ppaddr = ppaddr[type]; - gvop->op_gv = (GV*)SvREFCNT_inc(gv); - gvop->op_next = (OP*)gvop; - gvop->op_flags = flags; - if (opargs[type] & OA_RETSCALAR) - scalar((OP*)gvop); - if (opargs[type] & OA_TARGET) - gvop->op_targ = pad_alloc(type, SVs_PADTMP); - return CHECKOP(type, gvop); -} - -OP * -newPVOP(type, flags, pv) -I32 type; -I32 flags; -char *pv; -{ - PVOP *pvop; - Newz(1101, pvop, 1, PVOP); - pvop->op_type = type; - pvop->op_ppaddr = ppaddr[type]; - pvop->op_pv = pv; - pvop->op_next = (OP*)pvop; - pvop->op_flags = flags; - if (opargs[type] & OA_RETSCALAR) - scalar((OP*)pvop); - if (opargs[type] & OA_TARGET) - pvop->op_targ = pad_alloc(type, SVs_PADTMP); - return CHECKOP(type, pvop); -} - -OP * -newCVOP(type, flags, cv, cont) -I32 type; -I32 flags; -CV *cv; -OP *cont; -{ - CVOP *cvop; - Newz(1101, cvop, 1, CVOP); - cvop->op_type = type; - cvop->op_ppaddr = ppaddr[type]; - cvop->op_cv = cv; - cvop->op_cont = cont; - cvop->op_next = (OP*)cvop; - cvop->op_flags = flags; - if (opargs[type] & OA_RETSCALAR) - scalar((OP*)cvop); - if (opargs[type] & OA_TARGET) - cvop->op_targ = pad_alloc(type, SVs_PADTMP); - return CHECKOP(type, cvop); -} - -void -package(op) -OP *op; -{ - SV *sv; - - save_hptr(&curstash); - save_item(curstname); - if (op) { - STRLEN len; - char *name; - sv = cSVOP->op_sv; - name = SvPV(sv, len); - curstash = gv_stashpv(name,TRUE); - sv_setpvn(curstname, name, len); - op_free(op); - } - else { - sv_setpv(curstname,"<none>"); - curstash = Nullhv; - } - copline = NOLINE; - expect = XSTATE; -} - -void -utilize(aver, id, arg) -int aver; -OP *id; -OP *arg; -{ - OP *pack; - OP *meth; - OP *rqop; - OP *imop; - - if (id->op_type != OP_CONST) - croak("Module name must be constant"); - - /* Fake up an import/unimport */ - if (arg && arg->op_type == OP_STUB) - imop = arg; /* no import on explicit () */ - else { - /* Make copy of id so we don't free it twice */ - pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv)); - - meth = newSVOP(OP_CONST, 0, - aver - ? newSVpv("import", 6) - : newSVpv("unimport", 8) - ); - imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, - append_elem(OP_LIST, - prepend_elem(OP_LIST, pack, list(arg)), - newUNOP(OP_METHOD, 0, meth))); - } - - /* Fake up a require */ - rqop = newUNOP(OP_REQUIRE, 0, id); - - /* Fake up the BEGIN {}, which does its thing immediately. */ - newSUB(start_subparse(), - newSVOP(OP_CONST, 0, newSVpv("BEGIN", 5)), - Nullop, - append_elem(OP_LINESEQ, - newSTATEOP(0, Nullch, rqop), - newSTATEOP(0, Nullch, imop) )); - - copline = NOLINE; - expect = XSTATE; -} - -OP * -newSLICEOP(flags, subscript, listval) -I32 flags; -OP *subscript; -OP *listval; -{ - return newBINOP(OP_LSLICE, flags, - list(force_list(subscript)), - list(force_list(listval)) ); -} - -static I32 -list_assignment(op) -register OP *op; -{ - if (!op) - return TRUE; - - if (op->op_type == OP_NULL && op->op_flags & OPf_KIDS) - op = cUNOP->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 (t && f) - return TRUE; - if (t || f) - yyerror("Assignment to both a list and a scalar"); - 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) - return TRUE; - - if (op->op_type == OP_PADAV || op->op_type == OP_PADHV) - return TRUE; - - if (op->op_type == OP_RV2SV) - return FALSE; - - return FALSE; -} - -OP * -newASSIGNOP(flags, left, optype, right) -I32 flags; -OP *left; -I32 optype; -OP *right; -{ - OP *op; - - if (optype) { - if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) { - return newLOGOP(optype, 0, - mod(scalar(left), optype), - newUNOP(OP_SASSIGN, 0, scalar(right))); - } - else { - return newBINOP(optype, OPf_STACKED, - mod(scalar(left), optype), scalar(right)); - } - } - - if (list_assignment(left)) { - modcount = 0; - eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/ - left = mod(left, OP_AASSIGN); - if (eval_start) - eval_start = 0; - else { - op_free(left); - op_free(right); - return Nullop; - } - if (right && right->op_type == OP_SPLIT) { - if ((op = ((LISTOP*)right)->op_first) && op->op_type == OP_PUSHRE) { - PMOP *pm = (PMOP*)op; - if (left->op_type == OP_RV2AV && - !(left->op_private & OPpLVAL_INTRO) ) - { - op = ((UNOP*)left)->op_first; - if (op->op_type == OP_GV && !pm->op_pmreplroot) { - pm->op_pmreplroot = (OP*)((GVOP*)op)->op_gv; - pm->op_pmflags |= PMf_ONCE; - op_free(left); - return right; - } - } - else { - if (modcount < 10000) { - SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv; - if (SvIVX(sv) == 0) - sv_setiv(sv, modcount+1); - } - } - } - } - op = newBINOP(OP_AASSIGN, flags, - list(force_list(right)), - list(force_list(left)) ); - op->op_private = 0; - if (!(left->op_private & OPpLVAL_INTRO)) { - static int generation = 100; - OP *curop; - OP *lastop = op; - generation++; - for (curop = LINKLIST(op); curop != op; curop = LINKLIST(curop)) { - if (opargs[curop->op_type] & OA_DANGEROUS) { - if (curop->op_type == OP_GV) { - GV *gv = ((GVOP*)curop)->op_gv; - if (gv == defgv || SvCUR(gv) == generation) - break; - SvCUR(gv) = generation; - } - else if (curop->op_type == OP_PADSV || - curop->op_type == OP_PADAV || - curop->op_type == OP_PADHV || - curop->op_type == OP_PADANY) { - SV **svp = AvARRAY(comppad_name); - SV *sv = svp[curop->op_targ]; - if (SvCUR(sv) == generation) - break; - SvCUR(sv) = generation; /* (SvCUR not used any more) */ - } - else if (curop->op_type == OP_RV2CV) - break; - else if (curop->op_type == OP_RV2SV || - curop->op_type == OP_RV2AV || - curop->op_type == OP_RV2HV || - curop->op_type == OP_RV2GV) { - if (lastop->op_type != OP_GV) /* funny deref? */ - break; - } - else - break; - } - lastop = curop; - } - if (curop != op) - op->op_private = OPpASSIGN_COMMON; - } - return op; - } - if (!right) - right = newOP(OP_UNDEF, 0); - if (right->op_type == OP_READLINE) { - right->op_flags |= OPf_STACKED; - return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right)); - } - else { - eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/ - op = newBINOP(OP_SASSIGN, flags, - scalar(right), mod(scalar(left), OP_SASSIGN) ); - if (eval_start) - eval_start = 0; - else { - op_free(op); - return Nullop; - } - } - return op; -} - -OP * -newSTATEOP(flags, label, op) -I32 flags; -char *label; -OP *op; -{ - register COP *cop; - - /* Introduce my variables. */ - if (min_intro_pending) { - SV **svp = AvARRAY(comppad_name); - I32 i; - SV *sv; - for (i = min_intro_pending; i <= max_intro_pending; i++) { - if ((sv = svp[i]) && sv != &sv_undef && !SvIVX(sv)) { - SvIVX(sv) = 999999999; /* Don't know scope end yet. */ - SvNVX(sv) = (double)cop_seqmax; - } - } - min_intro_pending = 0; - comppad_name_fill = max_intro_pending; /* Needn't search higher */ - } - - Newz(1101, cop, 1, COP); - if (perldb && curcop->cop_line && curstash != debstash) { - cop->op_type = OP_DBSTATE; - cop->op_ppaddr = ppaddr[ OP_DBSTATE ]; - } - else { - cop->op_type = OP_NEXTSTATE; - cop->op_ppaddr = ppaddr[ OP_NEXTSTATE ]; - } - cop->op_flags = flags; - cop->op_private = 0; - cop->op_next = (OP*)cop; - - if (label) { - cop->cop_label = label; - hints |= HINT_BLOCK_SCOPE; - } - cop->cop_seq = cop_seqmax++; - cop->cop_arybase = curcop->cop_arybase; - - if (copline == NOLINE) - cop->cop_line = curcop->cop_line; - else { - cop->cop_line = copline; - copline = NOLINE; - } - cop->cop_filegv = SvREFCNT_inc(curcop->cop_filegv); - cop->cop_stash = curstash; - - if (perldb && curstash != debstash) { - SV **svp = av_fetch(GvAV(curcop->cop_filegv),(I32)cop->cop_line, FALSE); - if (svp && *svp != &sv_undef && !SvIOK(*svp)) { - SvIVX(*svp) = 1; - (void)SvIOK_on(*svp); - SvSTASH(*svp) = (HV*)cop; - } - } - - return prepend_elem(OP_LINESEQ, (OP*)cop, op); -} - -OP * -newLOGOP(type, flags, first, other) -I32 type; -I32 flags; -OP* first; -OP* other; -{ - LOGOP *logop; - OP *op; - - if (type == OP_XOR) /* Not short circuit, but here by precedence. */ - return newBINOP(type, flags, scalar(first), scalar(other)); - - scalarboolean(first); - /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */ - if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) { - if (type == OP_AND || type == OP_OR) { - if (type == OP_AND) - 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); - } - } - if (first->op_type == OP_CONST) { - if (dowarn && (first->op_private & OPpCONST_BARE)) - warn("Probable precedence problem on %s", op_name[type]); - if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) { - op_free(first); - return other; - } - else { - op_free(other); - return first; - } - } - else if (first->op_type == OP_WANTARRAY) { - if (type == OP_AND) - list(other); - else - scalar(other); - } - - if (!other) - return first; - - if (type == OP_ANDASSIGN || type == OP_ORASSIGN) - other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */ - - Newz(1101, logop, 1, LOGOP); - - logop->op_type = type; - logop->op_ppaddr = ppaddr[type]; - logop->op_first = first; - logop->op_flags = flags | OPf_KIDS; - logop->op_other = LINKLIST(other); - logop->op_private = 1; - - /* establish postfix order */ - logop->op_next = LINKLIST(first); - first->op_next = (OP*)logop; - first->op_sibling = other; - - op = newUNOP(OP_NULL, 0, (OP*)logop); - other->op_next = op; - - return op; -} - -OP * -newCONDOP(flags, first, true, false) -I32 flags; -OP* first; -OP* true; -OP* false; -{ - CONDOP *condop; - OP *op; - - if (!false) - return newLOGOP(OP_AND, 0, first, true); - if (!true) - return newLOGOP(OP_OR, 0, first, false); - - scalarboolean(first); - if (first->op_type == OP_CONST) { - if (SvTRUE(((SVOP*)first)->op_sv)) { - op_free(first); - op_free(false); - return true; - } - else { - op_free(first); - op_free(true); - return false; - } - } - else if (first->op_type == OP_WANTARRAY) { - list(true); - scalar(false); - } - Newz(1101, condop, 1, CONDOP); - - condop->op_type = OP_COND_EXPR; - condop->op_ppaddr = ppaddr[OP_COND_EXPR]; - condop->op_first = first; - condop->op_flags = flags | OPf_KIDS; - condop->op_true = LINKLIST(true); - condop->op_false = LINKLIST(false); - condop->op_private = 1; - - /* establish postfix order */ - condop->op_next = LINKLIST(first); - first->op_next = (OP*)condop; - - first->op_sibling = true; - true->op_sibling = false; - op = newUNOP(OP_NULL, 0, (OP*)condop); - - true->op_next = op; - false->op_next = op; - - return op; -} - -OP * -newRANGE(flags, left, right) -I32 flags; -OP *left; -OP *right; -{ - CONDOP *condop; - OP *flip; - OP *flop; - OP *op; - - Newz(1101, condop, 1, CONDOP); - - condop->op_type = OP_RANGE; - condop->op_ppaddr = ppaddr[OP_RANGE]; - condop->op_first = left; - condop->op_flags = OPf_KIDS; - condop->op_true = LINKLIST(left); - condop->op_false = LINKLIST(right); - condop->op_private = 1; - - left->op_sibling = 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); - linklist(flop); - - left->op_next = flip; - right->op_next = flop; - - condop->op_targ = pad_alloc(OP_RANGE, SVs_PADMY); - sv_upgrade(PAD_SV(condop->op_targ), SVt_PVNV); - flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY); - sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV); - - 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; - if (!flip->op_private || !flop->op_private) - linklist(op); /* blow off optimizer unless constant */ - - return op; -} - -OP * -newLOOPOP(flags, debuggable, expr, block) -I32 flags; -I32 debuggable; -OP *expr; -OP *block; -{ - OP* listop; - OP* op; - 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 */ - else if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB) - expr = 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); - - ((LISTOP*)listop)->op_last->op_next = LINKLIST(op); - - if (once && op != listop) - op->op_next = ((LOGOP*)cUNOP->op_first)->op_other; - - if (op == listop) - op = newUNOP(OP_NULL, 0, op); /* or do {} while 1 loses outer block */ - - op->op_flags |= flags; - op = scope(op); - op->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/ - return op; -} - -OP * -newWHILEOP(flags, debuggable, loop, expr, block, cont) -I32 flags; -I32 debuggable; -LOOP *loop; -OP *expr; -OP *block; -OP *cont; -{ - OP *redo; - OP *next = 0; - OP *listop; - OP *op; - OP *condop; - - if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB)) { - expr = newUNOP(OP_DEFINED, 0, - newASSIGNOP(0, newSVREF(newGVOP(OP_GV, 0, defgv)), 0, expr) ); - } - - if (!block) - block = newOP(OP_NULL, 0); - - if (cont) - next = LINKLIST(cont); - if (expr) - cont = append_elem(OP_LINESEQ, cont, newOP(OP_UNSTACK, 0)); - - 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)) { - 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)); - if (!next) - next = condop; - } - else - op = listop; - - if (!loop) { - Newz(1101,loop,1,LOOP); - loop->op_type = OP_ENTERLOOP; - loop->op_ppaddr = ppaddr[OP_ENTERLOOP]; - loop->op_private = 0; - loop->op_next = (OP*)loop; - } - - op = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, op); - - loop->op_redoop = redo; - loop->op_lastop = op; - - if (next) - loop->op_nextop = next; - else - loop->op_nextop = op; - - op->op_flags |= flags; - return op; -} - -OP * -#ifndef CAN_PROTOTYPE -newFOROP(flags,label,forline,sv,expr,block,cont) -I32 flags; -char *label; -line_t forline; -OP* sv; -OP* expr; -OP*block; -OP*cont; -#else -newFOROP(I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont) -#endif /* CAN_PROTOTYPE */ -{ - LOOP *loop; - int padoff = 0; - I32 iterflags = 0; - - copline = forline; - if (sv) { - if (sv->op_type == OP_RV2SV) { /* symbol table variable */ - sv->op_type = OP_RV2GV; - sv->op_ppaddr = ppaddr[OP_RV2GV]; - } - else if (sv->op_type == OP_PADSV) { /* private variable */ - padoff = sv->op_targ; - op_free(sv); - sv = Nullop; - } - else - croak("Can't use %s for loop variable", op_name[sv->op_type]); - } - else { - sv = newGVOP(OP_GV, 0, defgv); - } - if (expr->op_type == OP_RV2AV) { - expr = scalar(ref(expr, OP_ITER)); - iterflags |= OPf_STACKED; - } - loop = (LOOP*)list(convert(OP_ENTERITER, iterflags, - append_elem(OP_LIST, mod(force_list(expr), OP_GREPSTART), - scalar(sv)))); - assert(!loop->op_next); - Renew(loop, 1, LOOP); - loop->op_targ = padoff; - return newSTATEOP(0, label, newWHILEOP(flags, 1, loop, - newOP(OP_ITER, 0), block, cont)); -} - -OP* -newLOOPEX(type, label) -I32 type; -OP* label; -{ - OP *op; - if (type != OP_GOTO || label->op_type == OP_CONST) { - op = newPVOP(type, 0, savepv( - label->op_type == OP_CONST - ? SvPVx(((SVOP*)label)->op_sv, na) - : "" )); - op_free(label); - } - else { - if (label->op_type == OP_ENTERSUB) - label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN)); - op = newUNOP(type, OPf_STACKED, label); - } - hints |= HINT_BLOCK_SCOPE; - return op; -} - -void -cv_undef(cv) -CV *cv; -{ - if (!CvXSUB(cv) && CvROOT(cv)) { - if (CvDEPTH(cv)) - croak("Can't undef active subroutine"); - ENTER; - - SAVESPTR(curpad); - curpad = 0; - - if (!(SvFLAGS(cv) & SVpcv_CLONED)) - op_free(CvROOT(cv)); - CvROOT(cv) = Nullop; - LEAVE; - } - SvREFCNT_dec(CvGV(cv)); - CvGV(cv) = Nullgv; - SvREFCNT_dec(CvOUTSIDE(cv)); - CvOUTSIDE(cv) = Nullcv; - if (CvPADLIST(cv)) { - I32 i = AvFILL(CvPADLIST(cv)); - while (i >= 0) { - SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE); - if (svp) - SvREFCNT_dec(*svp); - } - SvREFCNT_dec((SV*)CvPADLIST(cv)); - CvPADLIST(cv) = Nullav; - } -} - -CV * -cv_clone(proto) -CV* proto; -{ - AV* av; - I32 ix; - AV* protopadlist = CvPADLIST(proto); - AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE); - AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE); - SV** svp = AvARRAY(protopad); - AV* comppadlist; - CV* cv; - - ENTER; - SAVESPTR(curpad); - SAVESPTR(comppad); - SAVESPTR(compcv); - - cv = compcv = (CV*)NEWSV(1104,0); - sv_upgrade((SV *)cv, SVt_PVCV); - SvFLAGS(cv) |= SVpcv_CLONED; - - CvFILEGV(cv) = CvFILEGV(proto); - CvGV(cv) = SvREFCNT_inc(CvGV(proto)); - CvSTASH(cv) = CvSTASH(proto); - CvROOT(cv) = CvROOT(proto); - CvSTART(cv) = CvSTART(proto); - if (CvOUTSIDE(proto)) - CvOUTSIDE(cv) = (CV*)SvREFCNT_inc((SV*)CvOUTSIDE(proto)); - - comppad = newAV(); - - comppadlist = newAV(); - AvREAL_off(comppadlist); - av_store(comppadlist, 0, SvREFCNT_inc((SV*)protopad_name)); - av_store(comppadlist, 1, (SV*)comppad); - CvPADLIST(cv) = comppadlist; - av_extend(comppad, AvFILL(protopad)); - curpad = AvARRAY(comppad); - - av = newAV(); /* will be @_ */ - av_extend(av, 0); - av_store(comppad, 0, (SV*)av); - AvFLAGS(av) = AVf_REIFY; - - svp = AvARRAY(protopad_name); - for ( ix = AvFILL(protopad); ix > 0; ix--) { - SV *sv; - if (svp[ix] != &sv_undef) { - char *name = SvPVX(svp[ix]); /* XXX */ - if (SvFLAGS(svp[ix]) & SVf_FAKE) { /* lexical from outside? */ - I32 off = pad_findlex(name,ix,curcop->cop_seq, CvOUTSIDE(proto), - cxstack_ix); - if (off != ix) - croak("panic: cv_clone: %s", name); - } - else { /* our own lexical */ - if (*name == '@') - av_store(comppad, ix, sv = (SV*)newAV()); - else if (*name == '%') - av_store(comppad, ix, sv = (SV*)newHV()); - else - av_store(comppad, ix, sv = NEWSV(0,0)); - SvPADMY_on(sv); - } - } - else { - av_store(comppad, ix, sv = NEWSV(0,0)); - SvPADTMP_on(sv); - } - } - - LEAVE; - return cv; -} - -CV * -newSUB(floor,op,proto,block) -I32 floor; -OP *op; -OP *proto; -OP *block; -{ - register CV *cv; - char *name = op ? SvPVx(cSVOP->op_sv, na) : "__ANON__"; - GV *gv = gv_fetchpv(name, GV_ADDMULTI, SVt_PVCV); - AV* av; - char *s; - I32 ix; - - if (op) - sub_generation++; - if (cv = GvCV(gv)) { - if (GvCVGEN(gv)) - cv = 0; /* just a cached method */ - else if (CvROOT(cv) || CvXSUB(cv) || GvFLAGS(gv) & GVf_IMPORTED) { - if (dowarn) { /* already defined (or promised)? */ - line_t oldline = curcop->cop_line; - - curcop->cop_line = copline; - warn("Subroutine %s redefined",name); - curcop->cop_line = oldline; - } - SvREFCNT_dec(cv); - cv = 0; - } - } - if (cv) { /* must reuse cv if autoloaded */ - cv_undef(cv); - CvOUTSIDE(cv) = CvOUTSIDE(compcv); - CvOUTSIDE(compcv) = 0; - CvPADLIST(cv) = CvPADLIST(compcv); - CvPADLIST(compcv) = 0; - if (SvREFCNT(compcv) > 1) /* XXX Make closures transit through stub. */ - CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc((SV*)cv); - SvREFCNT_dec(compcv); - } - else { - cv = compcv; - } - GvCV(gv) = cv; - GvCVGEN(gv) = 0; - CvFILEGV(cv) = curcop->cop_filegv; - CvGV(cv) = SvREFCNT_inc(gv); - CvSTASH(cv) = curstash; - - if (proto) { - char *p = SvPVx(((SVOP*)proto)->op_sv, na); - if (SvPOK(cv) && strNE(SvPV((SV*)cv,na), p)) - warn("Prototype mismatch: (%s) vs (%s)", SvPV((SV*)cv, na), p); - sv_setpv((SV*)cv, p); - } - - if (!block) { - CvROOT(cv) = 0; - op_free(op); - copline = NOLINE; - LEAVE_SCOPE(floor); - return cv; - } - - av = newAV(); /* Will be @_ */ - av_extend(av, 0); - av_store(comppad, 0, (SV*)av); - AvFLAGS(av) = AVf_REIFY; - - for (ix = AvFILL(comppad); ix > 0; ix--) { - if (!SvPADMY(curpad[ix])) - SvPADTMP_on(curpad[ix]); - } - - if (AvFILL(comppad_name) < AvFILL(comppad)) - av_store(comppad_name, AvFILL(comppad), Nullsv); - - CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block)); - CvSTART(cv) = LINKLIST(CvROOT(cv)); - CvROOT(cv)->op_next = 0; - peep(CvSTART(cv)); - if (s = strrchr(name,':')) - s++; - else - s = name; - if (strEQ(s, "BEGIN") && !error_count) { - line_t oldline = compiling.cop_line; - - ENTER; - SAVESPTR(compiling.cop_filegv); - SAVEI32(perldb); - if (!beginav) - beginav = newAV(); - av_push(beginav, (SV *)cv); - DEBUG_x( dump_sub(gv) ); - rs = nrs; - rslen = nrslen; - rschar = nrschar; - rspara = (nrslen == 2); - GvCV(gv) = 0; - calllist(beginav); - rs = "\n"; - rslen = 1; - rschar = '\n'; - rspara = 0; - curcop = &compiling; - curcop->cop_line = oldline; /* might have recursed to yylex */ - LEAVE; - } - else if (strEQ(s, "END") && !error_count) { - if (!endav) - endav = newAV(); - av_unshift(endav, 1); - av_store(endav, 0, SvREFCNT_inc(cv)); - } - if (perldb && curstash != debstash) { - SV *sv; - SV *tmpstr = sv_newmortal(); - - 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); - gv_efullname(tmpstr,gv); - hv_store(GvHV(DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0); - } - op_free(op); - copline = NOLINE; - LEAVE_SCOPE(floor); - if (!op) { - GvCV(gv) = 0; /* Will remember in SVOP instead. */ - SvFLAGS(cv) |= SVpcv_ANON; - } - 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(cv) = TRUE; - CvXSUBANY(cv).any_i32 = ix; - return cv; -} -#endif - -CV * -newXS(name, subaddr, filename) -char *name; -void (*subaddr) _((CV*)); -char *filename; -{ - register CV *cv; - GV *gv = gv_fetchpv((name ? name : "__ANON__"), GV_ADDMULTI, SVt_PVCV); - char *s; - - if (name) - sub_generation++; - if (cv = GvCV(gv)) { - if (GvCVGEN(gv)) - cv = 0; /* just a cached method */ - else if (CvROOT(cv) || CvXSUB(cv)) { /* already defined? */ - if (dowarn) { - line_t oldline = curcop->cop_line; - - curcop->cop_line = copline; - warn("Subroutine %s redefined",name); - curcop->cop_line = oldline; - } - SvREFCNT_dec(cv); - cv = 0; - } - } - if (cv) { /* must reuse cv if autoloaded */ - assert(SvREFCNT(CvGV(cv)) > 1); - SvREFCNT_dec(CvGV(cv)); - } - else { - cv = (CV*)NEWSV(1105,0); - sv_upgrade((SV *)cv, SVt_PVCV); - } - GvCV(gv) = cv; - CvGV(cv) = SvREFCNT_inc(gv); - GvCVGEN(gv) = 0; - CvFILEGV(cv) = gv_fetchfile(filename); - CvXSUB(cv) = subaddr; - if (!name) - s = "__ANON__"; - else if (s = strrchr(name,':')) - s++; - else - s = name; - if (strEQ(s, "BEGIN")) { - if (!beginav) - beginav = newAV(); - av_push(beginav, SvREFCNT_inc(gv)); - } - else if (strEQ(s, "END")) { - if (!endav) - endav = newAV(); - av_unshift(endav, 1); - av_store(endav, 0, SvREFCNT_inc(gv)); - } - if (!name) { - GvCV(gv) = 0; /* Will remember elsewhere instead. */ - SvFLAGS(cv) |= SVpcv_ANON; - } - return cv; -} - -void -newFORM(floor,op,block) -I32 floor; -OP *op; -OP *block; -{ - register CV *cv; - char *name; - GV *gv; - I32 ix; - - if (op) - name = SvPVx(cSVOP->op_sv, na); - else - name = "STDOUT"; - gv = gv_fetchpv(name,TRUE, SVt_PVFM); - SvMULTI_on(gv); - if (cv = GvFORM(gv)) { - if (dowarn) { - line_t oldline = curcop->cop_line; - - curcop->cop_line = copline; - warn("Format %s redefined",name); - curcop->cop_line = oldline; - } - SvREFCNT_dec(cv); - } - cv = compcv; - GvFORM(gv) = cv; - CvGV(cv) = SvREFCNT_inc(gv); - CvFILEGV(cv) = curcop->cop_filegv; - - for (ix = AvFILL(comppad); ix > 0; ix--) { - if (!SvPADMY(curpad[ix])) - SvPADTMP_on(curpad[ix]); - } - - CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block)); - CvSTART(cv) = LINKLIST(CvROOT(cv)); - CvROOT(cv)->op_next = 0; - peep(CvSTART(cv)); - FmLINES(cv) = 0; - op_free(op); - copline = NOLINE; - LEAVE_SCOPE(floor); -} - -OP * -newMETHOD(ref,name) -OP *ref; -OP *name; -{ - LOGOP* mop; - Newz(1101, mop, 1, LOGOP); - mop->op_type = OP_METHOD; - mop->op_ppaddr = ppaddr[OP_METHOD]; - mop->op_first = scalar(ref); - mop->op_flags |= OPf_KIDS; - mop->op_private = 1; - mop->op_other = LINKLIST(name); - mop->op_targ = pad_alloc(OP_METHOD, SVs_PADTMP); - mop->op_next = LINKLIST(ref); - ref->op_next = (OP*)mop; - return scalar((OP*)mop); -} - -OP * -newANONLIST(op) -OP* op; -{ - return newUNOP(OP_REFGEN, 0, - mod(list(convert(OP_ANONLIST, 0, op)), OP_REFGEN)); -} - -OP * -newANONHASH(op) -OP* op; -{ - return newUNOP(OP_REFGEN, 0, - mod(list(convert(OP_ANONHASH, 0, op)), OP_REFGEN)); -} - -OP * -newANONSUB(floor, proto, block) -I32 floor; -OP *proto; -OP *block; -{ - return newUNOP(OP_REFGEN, 0, - newSVOP(OP_ANONCODE, 0, (SV*)newSUB(floor, 0, proto, block))); -} - -OP * -oopsAV(o) -OP *o; -{ - switch (o->op_type) { - case OP_PADSV: - o->op_type = OP_PADAV; - o->op_ppaddr = ppaddr[OP_PADAV]; - return ref(newUNOP(OP_RV2AV, 0, scalar(o)), OP_RV2AV); - - case OP_RV2SV: - o->op_type = OP_RV2AV; - o->op_ppaddr = ppaddr[OP_RV2AV]; - ref(o, OP_RV2AV); - break; - - default: - warn("oops: oopsAV"); - break; - } - return o; -} - -OP * -oopsHV(o) -OP *o; -{ - switch (o->op_type) { - case OP_PADSV: - case OP_PADAV: - o->op_type = OP_PADHV; - o->op_ppaddr = ppaddr[OP_PADHV]; - return ref(newUNOP(OP_RV2HV, 0, scalar(o)), OP_RV2HV); - - case OP_RV2SV: - case OP_RV2AV: - o->op_type = OP_RV2HV; - o->op_ppaddr = ppaddr[OP_RV2HV]; - ref(o, OP_RV2HV); - break; - - default: - warn("oops: oopsHV"); - break; - } - return o; -} - -OP * -newAVREF(o) -OP *o; -{ - if (o->op_type == OP_PADANY) { - o->op_type = OP_PADAV; - o->op_ppaddr = ppaddr[OP_PADAV]; - return o; - } - return newUNOP(OP_RV2AV, 0, scalar(o)); -} - -OP * -newGVREF(type,o) -I32 type; -OP *o; -{ - if (type == OP_MAPSTART) - return newUNOP(OP_NULL, 0, o); - return ref(newUNOP(OP_RV2GV, OPf_REF, o), type); -} - -OP * -newHVREF(o) -OP *o; -{ - if (o->op_type == OP_PADANY) { - o->op_type = OP_PADHV; - o->op_ppaddr = ppaddr[OP_PADHV]; - return o; - } - return newUNOP(OP_RV2HV, 0, scalar(o)); -} - -OP * -oopsCV(o) -OP *o; -{ - croak("NOT IMPL LINE %d",__LINE__); - /* STUB */ - return o; -} - -OP * -newCVREF(o) -OP *o; -{ - return newUNOP(OP_RV2CV, 0, scalar(o)); -} - -OP * -newSVREF(o) -OP *o; -{ - if (o->op_type == OP_PADANY) { - o->op_type = OP_PADSV; - o->op_ppaddr = ppaddr[OP_PADSV]; - return o; - } - return newUNOP(OP_RV2SV, 0, scalar(o)); -} - -/* Check routines. */ - -OP * -ck_concat(op) -OP *op; -{ - if (cUNOP->op_first->op_type == OP_CONCAT) - op->op_flags |= OPf_STACKED; - return op; -} - -OP * -ck_spair(op) -OP *op; -{ - if (op->op_flags & OPf_KIDS) { - OP* newop; - OP* kid; - op = modkids(ck_fun(op), op->op_type); - kid = cUNOP->op_first; - newop = kUNOP->op_first->op_sibling; - if (newop && - (newop->op_sibling || - !(opargs[newop->op_type] & OA_RETSCALAR) || - newop->op_type == OP_PADAV || newop->op_type == OP_PADHV || - newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) { - - return op; - } - op_free(kUNOP->op_first); - kUNOP->op_first = newop; - } - op->op_ppaddr = ppaddr[++op->op_type]; - return ck_fun(op); -} - -OP * -ck_delete(op) -OP *op; -{ - op = ck_fun(op); - if (op->op_flags & OPf_KIDS) { - OP *kid = cUNOP->op_first; - if (kid->op_type != OP_HELEM) - croak("%s argument is not a HASH element", op_name[op->op_type]); - null(kid); - } - return op; -} - -OP * -ck_eof(op) -OP *op; -{ - I32 type = op->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))); - } - return ck_fun(op); - } - return op; -} - -OP * -ck_eval(op) -OP *op; -{ - hints |= HINT_BLOCK_SCOPE; - if (op->op_flags & OPf_KIDS) { - SVOP *kid = (SVOP*)cUNOP->op_first; - - if (!kid) { - op->op_flags &= ~OPf_KIDS; - null(op); - } - else if (kid->op_type == OP_LINESEQ) { - LOGOP *enter; - - kid->op_next = op->op_next; - cUNOP->op_first = 0; - op_free(op); - - Newz(1101, enter, 1, LOGOP); - enter->op_type = OP_ENTERTRY; - enter->op_ppaddr = ppaddr[OP_ENTERTRY]; - enter->op_private = 0; - - /* 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; - } - } - else { - op_free(op); - op = newUNOP(OP_ENTEREVAL, 0, newSVREF(newGVOP(OP_GV, 0, defgv))); - } - op->op_targ = (PADOFFSET)hints; - return op; -} - -OP * -ck_exec(op) -OP *op; -{ - OP *kid; - if (op->op_flags & OPf_STACKED) { - op = ck_fun(op); - kid = cUNOP->op_first->op_sibling; - if (kid->op_type == OP_RV2GV) - null(kid); - } - else - op = listkids(op); - return op; -} - -OP * -ck_gvconst(o) -register OP *o; -{ - o = fold_constants(o); - if (o->op_type == OP_CONST) - o->op_type = OP_GV; - return o; -} - -OP * -ck_rvconst(op) -register OP *op; -{ - SVOP *kid = (SVOP*)cUNOP->op_first; - - op->op_private = (hints & HINT_STRICT_REFS); - if (kid->op_type == OP_CONST) { - int iscv = (op->op_type==OP_RV2CV)*2; - GV *gv = 0; - kid->op_type = OP_GV; - for (gv = 0; !gv; iscv++) { - /* - * This is a little tricky. We only want to add the symbol if we - * didn't add it in the lexer. Otherwise we get duplicate strict - * warnings. But if we didn't add it in the lexer, we must at - * least pretend like we wanted to add it even if it existed before, - * or we get possible typo warnings. OPpCONST_ENTERED says - * whether the lexer already added THIS instance of this symbol. - */ - gv = gv_fetchpv(SvPVx(kid->op_sv, na), - iscv | !(kid->op_private & OPpCONST_ENTERED), - iscv - ? SVt_PVCV - : op->op_type == OP_RV2SV - ? SVt_PV - : op->op_type == OP_RV2AV - ? SVt_PVAV - : op->op_type == OP_RV2HV - ? SVt_PVHV - : SVt_PVGV); - } - SvREFCNT_dec(kid->op_sv); - kid->op_sv = SvREFCNT_inc(gv); - } - return op; -} - -OP * -ck_formline(op) -OP *op; -{ - return ck_fun(op); -} - -OP * -ck_ftst(op) -OP *op; -{ - I32 type = op->op_type; - - if (op->op_flags & OPf_REF) - return op; - - if (op->op_flags & OPf_KIDS) { - SVOP *kid = (SVOP*)cUNOP->op_first; - - if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { - OP *newop = newGVOP(type, OPf_REF, - gv_fetchpv(SvPVx(kid->op_sv, na), TRUE, SVt_PVIO)); - op_free(op); - return newop; - } - } - else { - op_free(op); - if (type == OP_FTTTY) - 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; -} - -OP * -ck_fun(op) -OP *op; -{ - register OP *kid; - OP **tokid; - OP *sibl; - I32 numargs = 0; - int type = op->op_type; - register I32 oa = opargs[type] >> OASHIFT; - - if (op->op_flags & OPf_STACKED) { - if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL)) - oa &= ~OA_OPTIONAL; - else - return no_fh_allowed(op); - } - - if (op->op_flags & OPf_KIDS) { - tokid = &cLISTOP->op_first; - kid = cLISTOP->op_first; - if (kid->op_type == OP_PUSHMARK || - kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK) - { - tokid = &kid->op_sibling; - kid = kid->op_sibling; - } - if (!kid && opargs[type] & OA_DEFGV) - *tokid = kid = newSVREF(newGVOP(OP_GV, 0, defgv)); - - while (oa && kid) { - numargs++; - sibl = kid->op_sibling; - switch (oa & 7) { - case OA_SCALAR: - scalar(kid); - break; - case OA_LIST: - if (oa < 16) { - kid = 0; - continue; - } - else - list(kid); - break; - case OA_AVREF: - if (kid->op_type == OP_CONST && - (kid->op_private & OPpCONST_BARE)) { - char *name = SvPVx(((SVOP*)kid)->op_sv, na); - OP *newop = newAVREF(newGVOP(OP_GV, 0, - gv_fetchpv(name, TRUE, SVt_PVAV) )); - if (dowarn) - warn("Array @%s missing the @ in argument %d of %s()", - name, numargs, op_name[type]); - op_free(kid); - kid = newop; - kid->op_sibling = sibl; - *tokid = kid; - } - else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) - bad_type(numargs, "array", op_name[op->op_type], kid); - mod(kid, type); - break; - case OA_HVREF: - if (kid->op_type == OP_CONST && - (kid->op_private & OPpCONST_BARE)) { - char *name = SvPVx(((SVOP*)kid)->op_sv, na); - OP *newop = newHVREF(newGVOP(OP_GV, 0, - gv_fetchpv(name, TRUE, SVt_PVHV) )); - if (dowarn) - warn("Hash %%%s missing the %% in argument %d of %s()", - name, numargs, op_name[type]); - op_free(kid); - kid = newop; - kid->op_sibling = sibl; - *tokid = kid; - } - else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV) - bad_type(numargs, "hash", op_name[op->op_type], kid); - mod(kid, type); - break; - case OA_CVREF: - { - OP *newop = newUNOP(OP_NULL, 0, kid); - kid->op_sibling = 0; - linklist(kid); - newop->op_next = newop; - kid = newop; - kid->op_sibling = sibl; - *tokid = kid; - } - break; - case OA_FILEREF: - if (kid->op_type != OP_GV) { - if (kid->op_type == OP_CONST && - (kid->op_private & OPpCONST_BARE)) { - OP *newop = newGVOP(OP_GV, 0, - gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, na), TRUE, - SVt_PVIO) ); - op_free(kid); - kid = newop; - } - else { - kid->op_sibling = 0; - kid = newUNOP(OP_RV2GV, 0, scalar(kid)); - } - kid->op_sibling = sibl; - *tokid = kid; - } - scalar(kid); - break; - case OA_SCALARREF: - mod(scalar(kid), type); - break; - } - oa >>= 4; - tokid = &kid->op_sibling; - kid = kid->op_sibling; - } - op->op_private = numargs; - if (kid) - return too_many_arguments(op,op_name[op->op_type]); - listkids(op); - } - else if (opargs[type] & OA_DEFGV) { - op_free(op); - return newUNOP(type, 0, newSVREF(newGVOP(OP_GV, 0, defgv))); - } - - if (oa) { - while (oa & OA_OPTIONAL) - oa >>= 4; - if (oa && oa != OA_LIST) - return too_few_arguments(op,op_name[op->op_type]); - } - return op; -} - -OP * -ck_glob(op) -OP *op; -{ - GV *gv = newGVgen("main"); - gv_IOadd(gv); - append_elem(OP_GLOB, op, newGVOP(OP_GV, 0, gv)); - scalarkids(op); - return ck_fun(op); -} - -OP * -ck_grep(op) -OP *op; -{ - LOGOP *gwop; - OP *kid; - OPCODE type = op->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE; - - op->op_ppaddr = ppaddr[OP_GREPSTART]; - Newz(1101, gwop, 1, LOGOP); - - if (op->op_flags & OPf_STACKED) { - OP* k; - op = ck_sort(op); - kid = cLISTOP->op_first->op_sibling; - for (k = cLISTOP->op_first->op_sibling->op_next; k; k = k->op_next) { - kid = k; - } - kid->op_next = (OP*)gwop; - op->op_flags &= ~OPf_STACKED; - } - kid = cLISTOP->op_first->op_sibling; - if (type == OP_MAPWHILE) - list(kid); - else - scalar(kid); - op = ck_fun(op); - if (error_count) - return op; - kid = cLISTOP->op_first->op_sibling; - 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_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; - if (!kid || !kid->op_sibling) - return too_few_arguments(op,op_name[op->op_type]); - for (kid = kid->op_sibling; kid; kid = kid->op_sibling) - mod(kid, OP_GREPSTART); - - return (OP*)gwop; -} - -OP * -ck_index(op) -OP *op; -{ - if (op->op_flags & OPf_KIDS) { - OP *kid = cLISTOP->op_first->op_sibling; /* get past pushmark */ - if (kid && kid->op_type == OP_CONST) - fbm_compile(((SVOP*)kid)->op_sv, 0); - } - return ck_fun(op); -} - -OP * -ck_lengthconst(op) -OP *op; -{ - /* XXX length optimization goes here */ - return ck_fun(op); -} - -OP * -ck_lfun(op) -OP *op; -{ - return modkids(ck_fun(op), op->op_type); -} - -OP * -ck_rfun(op) -OP *op; -{ - return refkids(ck_fun(op), op->op_type); -} - -OP * -ck_listiob(op) -OP *op; -{ - register OP *kid; - - kid = cLISTOP->op_first; - if (!kid) { - op = force_list(op); - kid = cLISTOP->op_first; - } - if (kid->op_type == OP_PUSHMARK) - kid = kid->op_sibling; - if (kid && op->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 */ - kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid)); - cLISTOP->op_first->op_sibling = kid; - cLISTOP->op_last = kid; - kid = kid->op_sibling; - } - } - - if (!kid) - append_elem(op->op_type, op, newSVREF(newGVOP(OP_GV, 0, defgv)) ); - - return listkids(op); -} - -OP * -ck_match(op) -OP *op; -{ - cPMOP->op_pmflags |= PMf_RUNTIME; - cPMOP->op_pmpermflags |= PMf_RUNTIME; - return op; -} - -OP * -ck_null(op) -OP *op; -{ - return op; -} - -OP * -ck_repeat(op) -OP *op; -{ - if (cBINOP->op_first->op_flags & OPf_PARENS) { - op->op_private = OPpREPEAT_DOLIST; - cBINOP->op_first = force_list(cBINOP->op_first); - } - else - scalar(op); - return op; -} - -OP * -ck_require(op) -OP *op; -{ - if (op->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */ - SVOP *kid = (SVOP*)cUNOP->op_first; - - if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { - char *s; - for (s = SvPVX(kid->op_sv); *s; s++) { - if (*s == ':' && s[1] == ':') { - *s = '/'; - Move(s+2, s+1, strlen(s+2)+1, char); - --SvCUR(kid->op_sv); - } - } - sv_catpvn(kid->op_sv, ".pm", 3); - } - } - return ck_fun(op); -} - -OP * -ck_retarget(op) -OP *op; -{ - croak("NOT IMPL LINE %d",__LINE__); - /* STUB */ - return op; -} - -OP * -ck_select(op) -OP *op; -{ - if (op->op_flags & OPf_KIDS) { - OP *kid = cLISTOP->op_first->op_sibling; /* get past pushmark */ - if (kid && kid->op_sibling) { - op->op_type = OP_SSELECT; - op->op_ppaddr = ppaddr[OP_SSELECT]; - op = ck_fun(op); - return fold_constants(op); - } - } - return ck_fun(op); -} - -OP * -ck_shift(op) -OP *op; -{ - I32 type = op->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, - gv_fetchpv((subline ? "_" : "ARGV"), TRUE, SVt_PVAV) ))))); - } - return scalar(modkids(ck_fun(op), type)); -} - -OP * -ck_sort(op) -OP *op; -{ - if (op->op_flags & OPf_STACKED) { - OP *kid = cLISTOP->op_first->op_sibling; /* get past pushmark */ - OP *k; - kid = kUNOP->op_first; /* get past rv2gv */ - - if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) { - linklist(kid); - if (kid->op_type == OP_SCOPE) { - k = kid->op_next; - kid->op_next = 0; - } - else if (kid->op_type == OP_LEAVE) { - if (op->op_type == OP_SORT) { - null(kid); /* wipe out leave */ - kid->op_next = kid; - - for (k = kLISTOP->op_first->op_next; k; k = k->op_next) { - if (k->op_next == kid) - k->op_next = 0; - } - } - else - kid->op_next = 0; /* just disconnect the leave */ - k = kLISTOP->op_first; - } - peep(k); - - kid = cLISTOP->op_first->op_sibling; /* get past pushmark */ - null(kid); /* wipe out rv2gv */ - if (op->op_type == OP_SORT) - kid->op_next = kid; - else - kid->op_next = k; - op->op_flags |= OPf_SPECIAL; - } - } - return op; -} - -OP * -ck_split(op) -OP *op; -{ - register OP *kid; - PMOP* pm; - - if (op->op_flags & OPf_STACKED) - return no_fh_allowed(op); - - kid = cLISTOP->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; - if (!kid) { - cLISTOP->op_first = kid = newSVOP(OP_CONST, 0, newSVpv(" ", 1)); - cLISTOP->op_last = kid; /* There was only one element previously */ - } - - if (kid->op_type != OP_MATCH) { - OP *sibl = kid->op_sibling; - 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; - kid->op_sibling = sibl; - } - pm = (PMOP*)kid; - if (pm->op_pmshort && !(pm->op_pmflags & PMf_ALL)) { - SvREFCNT_dec(pm->op_pmshort); /* can't use substring to optimize */ - pm->op_pmshort = 0; - } - - kid->op_type = OP_PUSHRE; - kid->op_ppaddr = ppaddr[OP_PUSHRE]; - scalar(kid); - - if (!kid->op_sibling) - append_elem(OP_SPLIT, op, 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))); - - kid = kid->op_sibling; - scalar(kid); - - if (kid->op_sibling) - return too_many_arguments(op,op_name[op->op_type]); - - return op; -} - -OP * -ck_subr(op) -OP *op; -{ - OP *prev = ((cUNOP->op_first->op_sibling) - ? cUNOP : ((UNOP*)cUNOP->op_first))->op_first; - OP *o = prev->op_sibling; - OP *cvop; - char *proto = 0; - CV *cv = 0; - int optional = 0; - I32 arg = 0; - - for (cvop = o; cvop->op_sibling; cvop = cvop->op_sibling) ; - if (cvop->op_type == OP_RV2CV) { - SVOP* tmpop; - null(cvop); /* disable rv2cv */ - tmpop = (SVOP*)((UNOP*)cvop)->op_first; - if (tmpop->op_type == OP_GV) { - cv = GvCV(tmpop->op_sv); - if (cv && SvPOK(cv) && (op->op_flags & OPf_STACKED)) - proto = SvPV((SV*)cv,na); - } - } - op->op_private = (hints & HINT_STRICT_REFS); - if (perldb && curstash != debstash) - op->op_private |= OPpDEREF_DB; - while (o != cvop) { - if (proto) { - switch (*proto) { - case '\0': - return too_many_arguments(op, CvNAME(cv)); - case ';': - optional = 1; - proto++; - continue; - case '$': - proto++; - arg++; - scalar(o); - break; - case '%': - case '@': - list(o); - arg++; - break; - case '&': - proto++; - arg++; - if (o->op_type != OP_REFGEN && o->op_type != OP_UNDEF) - bad_type(arg, "block", CvNAME(cv), o); - break; - case '*': - proto++; - arg++; - if (o->op_type == OP_RV2GV) - goto wrapref; - { - OP* kid = o; - o = newUNOP(OP_RV2GV, 0, kid); - o->op_sibling = kid->op_sibling; - kid->op_sibling = 0; - prev->op_sibling = o; - } - goto wrapref; - case '\\': - proto++; - arg++; - switch (*proto++) { - case '*': - if (o->op_type != OP_RV2GV) - bad_type(arg, "symbol", CvNAME(cv), o); - goto wrapref; - case '&': - if (o->op_type != OP_RV2CV) - bad_type(arg, "sub", CvNAME(cv), o); - goto wrapref; - case '$': - if (o->op_type != OP_RV2SV && o->op_type != OP_PADSV) - bad_type(arg, "scalar", CvNAME(cv), o); - goto wrapref; - case '@': - if (o->op_type != OP_RV2AV && o->op_type != OP_PADAV) - bad_type(arg, "array", CvNAME(cv), o); - goto wrapref; - case '%': - if (o->op_type != OP_RV2HV && o->op_type != OP_PADHV) - bad_type(arg, "hash", CvNAME(cv), o); - wrapref: - { - OP* kid = o; - o = newUNOP(OP_REFGEN, 0, kid); - o->op_sibling = kid->op_sibling; - kid->op_sibling = 0; - prev->op_sibling = o; - } - break; - default: goto oops; - } - break; - default: - oops: - croak("Malformed prototype for %s: %s", - CvNAME(cv),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; -} - -OP * -ck_svconst(op) -OP *op; -{ - SvREADONLY_on(cSVOP->op_sv); - return op; -} - -OP * -ck_trunc(op) -OP *op; -{ - if (op->op_flags & OPf_KIDS) { - SVOP *kid = (SVOP*)cUNOP->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; - } - return ck_fun(op); -} - -/* A peephole optimizer. We visit the ops in the order they're to execute. */ - -void -peep(o) -register OP* o; -{ - register OP* oldop = 0; - if (!o || o->op_seq) - return; - ENTER; - SAVESPTR(op); - SAVESPTR(curcop); - for (; o; o = o->op_next) { - if (o->op_seq) - break; - op = o; - switch (o->op_type) { - case OP_NEXTSTATE: - case OP_DBSTATE: - curcop = ((COP*)o); /* for warnings */ - o->op_seq = ++op_seqmax; - break; - - case OP_CONCAT: - case OP_CONST: - case OP_JOIN: - case OP_UC: - case OP_UCFIRST: - case OP_LC: - case OP_LCFIRST: - case OP_QUOTEMETA: - if (o->op_next->op_type == OP_STRINGIFY) - null(o->op_next); - o->op_seq = ++op_seqmax; - break; - case OP_STUB: - if ((o->op_flags & (OPf_KNOW|OPf_LIST)) != (OPf_KNOW|OPf_LIST)) { - o->op_seq = ++op_seqmax; - break; /* Scalar stub must produce undef. List stub is noop */ - } - goto nothin; - case OP_NULL: - if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE) - curcop = ((COP*)op); - goto nothin; - case OP_SCALAR: - case OP_LINESEQ: - case OP_SCOPE: - nothin: - if (oldop && o->op_next) { - oldop->op_next = o->op_next; - continue; - } - o->op_seq = ++op_seqmax; - break; - - case OP_GV: - if (o->op_next->op_type == OP_RV2SV) { - if (!(o->op_next->op_private & (OPpDEREF_HV|OPpDEREF_AV))) { - null(o->op_next); - o->op_private |= o->op_next->op_private & OPpLVAL_INTRO; - o->op_next = o->op_next->op_next; - o->op_type = OP_GVSV; - o->op_ppaddr = ppaddr[OP_GVSV]; - } - } - else if (o->op_next->op_type == OP_RV2AV) { - OP* pop = o->op_next->op_next; - IV i; - if (pop->op_type == OP_CONST && - (op = pop->op_next) && - pop->op_next->op_type == OP_AELEM && - !(pop->op_next->op_private & - (OPpDEREF_HV|OPpDEREF_AV|OPpLVAL_INTRO)) && - (i = SvIV(((SVOP*)pop)->op_sv) - compiling.cop_arybase) - <= 255 && - i >= 0) - { - SvREFCNT_dec(((SVOP*)pop)->op_sv); - null(o->op_next); - null(pop->op_next); - null(pop); - o->op_flags |= pop->op_next->op_flags & OPf_MOD; - o->op_next = pop->op_next->op_next; - o->op_type = OP_AELEMFAST; - o->op_ppaddr = ppaddr[OP_AELEMFAST]; - o->op_private = (U8)i; - GvAVn((GV*)(((SVOP*)o)->op_sv)); - } - } - o->op_seq = ++op_seqmax; - break; - - case OP_MAPWHILE: - case OP_GREPWHILE: - case OP_AND: - case OP_OR: - o->op_seq = ++op_seqmax; - peep(cLOGOP->op_other); - break; - - case OP_COND_EXPR: - o->op_seq = ++op_seqmax; - peep(cCONDOP->op_true); - peep(cCONDOP->op_false); - break; - - case OP_ENTERLOOP: - o->op_seq = ++op_seqmax; - peep(cLOOP->op_redoop); - peep(cLOOP->op_nextop); - peep(cLOOP->op_lastop); - break; - - case OP_MATCH: - case OP_SUBST: - o->op_seq = ++op_seqmax; - peep(cPMOP->op_pmreplstart); - break; - - case OP_EXEC: - o->op_seq = ++op_seqmax; - if (dowarn && o->op_next && o->op_next->op_type == OP_NEXTSTATE) { - if (o->op_next->op_sibling && - o->op_next->op_sibling->op_type != OP_DIE) { - line_t oldline = curcop->cop_line; - - curcop->cop_line = ((COP*)o->op_next)->cop_line; - warn("Statement unlikely to be reached"); - warn("(Maybe you meant system() when you said exec()?)\n"); - curcop->cop_line = oldline; - } - } - break; - default: - o->op_seq = ++op_seqmax; - break; - } - oldop = o; - } - LEAVE; -} |