From: Lukas Mai Date: Thu, 21 Jun 2012 16:20:39 +0000 (+0200) Subject: rewrite to generate actual ops, not source code X-Git-Tag: v0.06_01~22 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=p5sagit%2FFunction-Parameters.git;a=commitdiff_plain;h=c311cef3f01393a6a5d55985277b65399550b858 rewrite to generate actual ops, not source code --- diff --git a/Parameters.xs b/Parameters.xs index 87b1e38..47ad69d 100644 --- a/Parameters.xs +++ b/Parameters.xs @@ -144,37 +144,116 @@ static int kw_flags(pTHX_ const char *kw_ptr, STRLEN kw_len, Spec *spec) { #include "toke_on_crack.c.inc" +static void free_ptr_op(void *vp) { + OP **pp = vp; + op_free(*pp); + Safefree(pp); +} + +#define sv_eq_pvs(SV, S) sv_eq_pvn(SV, "" S "", sizeof (S) - 1) + +static int sv_eq_pvn(SV *sv, const char *p, STRLEN n) { + STRLEN sv_len; + const char *sv_p = SvPV(sv, sv_len); + return + sv_len == n && + memcmp(sv_p, p, n) == 0 + ; +} + + +#include "padop_on_crack.c.inc" + + +#if 0 +static PADOFFSET pad_add_my_sv(SV *name) { + PADOFFSET offset; + SV *namesv, *myvar; + char *p; + STRLEN len; + + p = SvPV(name, len); + myvar = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, 1); + offset = AvFILLp(PL_comppad); + SvPADMY_on(myvar); + if (*p == '@') { + SvUPGRADE(myvar, SVt_PVAV); + } else if (*p == '%') { + SvUPGRADE(myvar, SVt_PVHV); + } + PL_curpad = AvARRAY(PL_comppad); + namesv = newSV_type(SVt_PVMG); + sv_setpvn(namesv, p, len); + COP_SEQ_RANGE_LOW_set(namesv, PL_cop_seqmax); + COP_SEQ_RANGE_HIGH_set(namesv, PERL_PADSEQ_INTRO); + PL_cop_seqmax++; + av_store(PL_comppad_name, offset, namesv); + return offset; +} +#endif + +enum { + MY_ATTR_LVALUE = 0x01, + MY_ATTR_METHOD = 0x02, + MY_ATTR_SPECIAL = 0x04 +}; + static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len, const Spec *spec) { - SV *gen, *declarator, *params, *sv; - int saw_name, saw_colon; + SV *declarator; + I32 floor_ix; + SV *saw_name; + AV *params; + SV *proto; + OP **attrs_sentinel, *body; + unsigned builtin_attrs; + int saw_colon; STRLEN len; char *s; I32 c; - gen = sv_2mortal(newSVpvs("sub")); declarator = sv_2mortal(newSVpvn(keyword_ptr, keyword_len)); - params = sv_2mortal(newSVpvs("")); lex_read_space(0); + builtin_attrs = 0; + /* function name */ - saw_name = 0; + saw_name = NULL; s = PL_parser->bufptr; if (spec->name != FLAG_NAME_PROHIBITED && (len = S_scan_word(aTHX_ s, TRUE))) { - sv_catpvs(gen, " "); - sv_catpvn(gen, s, len); + saw_name = sv_2mortal(newSVpvn_flags(s, len, PARSING_UTF ? SVf_UTF8 : 0)); + + if (PL_parser->expect != XSTATE) { + /* bail out early so we don't predeclare $saw_name */ + croak("In %"SVf": I was expecting a function body, not \"%"SVf"\"", SVfARG(declarator), SVfARG(saw_name)); + } + sv_catpvs(declarator, " "); - sv_catpvn(declarator, s, len); + sv_catsv(declarator, saw_name); + + if ( + sv_eq_pvs(saw_name, "BEGIN") || + sv_eq_pvs(saw_name, "END") || + sv_eq_pvs(saw_name, "INIT") || + sv_eq_pvs(saw_name, "CHECK") || + sv_eq_pvs(saw_name, "UNITCHECK") + ) { + builtin_attrs |= MY_ATTR_SPECIAL; + } + lex_read_to(s + len); lex_read_space(0); - saw_name = 1; } else if (spec->name == FLAG_NAME_REQUIRED) { croak("I was expecting a function name, not \"%.*s\"", (int)(PL_parser->bufend - s), s); } else { sv_catpvs(declarator, " (anon)"); } + floor_ix = start_subparse(FALSE, saw_name ? 0 : CVf_ANON); + SAVEFREESV(PL_compcv); + /* parameters */ + params = NULL; c = lex_peek_unichar(0); if (c == '(') { SV *saw_slurpy = NULL; @@ -182,10 +261,14 @@ static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len lex_read_unichar(0); lex_read_space(0); + params = newAV(); + sv_2mortal((SV *)params); + for (;;) { c = lex_peek_unichar(0); if (c == '$' || c == '@' || c == '%') { - sv_catpvf(params, "%c", (int)c); + SV *param; + lex_read_unichar(0); lex_read_space(0); @@ -193,14 +276,14 @@ static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len if (!(len = S_scan_word(aTHX_ s, FALSE))) { croak("In %"SVf": missing identifier", SVfARG(declarator)); } + param = sv_2mortal(newSVpvf("%c%.*s", (int)c, (int)len, s)); if (saw_slurpy) { - croak("In %"SVf": I was expecting \")\" after \"%"SVf"\", not \"%c%.*s\"", SVfARG(declarator), SVfARG(saw_slurpy), (int)c, (int)len, s); + croak("In %"SVf": I was expecting \")\" after \"%"SVf"\", not \"%"SVf"\"", SVfARG(declarator), SVfARG(saw_slurpy), SVfARG(param)); } if (c != '$') { - saw_slurpy = sv_2mortal(newSVpvf("%c%.*s", (int)c, (int)len, s)); + saw_slurpy = param; } - sv_catpvn(params, s, len); - sv_catpvs(params, ","); + av_push(params, SvREFCNT_inc_simple_NN(param)); lex_read_to(s + len); lex_read_space(0); @@ -226,6 +309,7 @@ static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len } /* prototype */ + proto = NULL; saw_colon = 0; c = lex_peek_unichar(0); if (c == ':') { @@ -234,102 +318,195 @@ static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len c = lex_peek_unichar(0); if (c != '(') { - saw_colon = 1; + lex_stuff_pvs(":", 0); + c = ':'; } else { - sv = sv_2mortal(newSVpvs("")); - if (!S_scan_str(aTHX_ sv, TRUE, TRUE)) { + proto = sv_2mortal(newSVpvs("")); + if (!S_scan_str(aTHX_ proto, FALSE, FALSE)) { croak("In %"SVf": prototype not terminated", SVfARG(declarator)); } - sv_catsv(gen, sv); + S_check_prototype(declarator, proto); lex_read_space(0); + c = lex_peek_unichar(0); } } + /* surprise predeclaration! */ if (saw_name) { - len = SvCUR(gen); - s = SvGROW(gen, (len + 1) * 2); - sv_catpvs(gen, ";"); - sv_catpvn(gen, s, len); + /* 'sub NAME (PROTO);' to make name/proto known to perl before it + starts parsing the body */ + SvREFCNT_inc_simple_void(PL_compcv); + + newATTRSUB( + floor_ix, + newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(saw_name)), + proto ? newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(proto)) : NULL, + NULL, + NULL + ); + + floor_ix = start_subparse(FALSE, 0); + SAVEFREESV(PL_compcv); } + /* attributes */ - if (SvTRUE(spec->attrs)) { - sv_catsv(gen, spec->attrs); - } + Newx(attrs_sentinel, 1, OP *); + *attrs_sentinel = NULL; + SAVEDESTRUCTOR(free_ptr_op, attrs_sentinel); + + if (c == ':' || c == '{') { + + /* kludge default attributes in */ + if (SvTRUE(spec->attrs) && SvPV_nolen(spec->attrs)[0] == ':') { + lex_stuff_sv(spec->attrs, 0); + c = ':'; + } - if (!saw_colon) { - c = lex_peek_unichar(0); if (c == ':') { - saw_colon = 1; lex_read_unichar(0); lex_read_space(0); - } - } - if (saw_colon) { - for (;;) { - s = PL_parser->bufptr; - if (!(len = S_scan_word(aTHX_ s, FALSE))) { - break; - } - sv_catpvs(gen, ":"); - sv_catpvn(gen, s, len); - lex_read_to(s + len); - lex_read_space(0); c = lex_peek_unichar(0); - if (c == '(') { - sv = sv_2mortal(newSVpvs("")); - if (!S_scan_str(aTHX_ sv, TRUE, TRUE)) { - croak("In %"SVf": unterminated attribute parameter in attribute list", SVfARG(declarator)); + + for (;;) { + SV *attr; + + s = PL_parser->bufptr; + if (!(len = S_scan_word(aTHX_ s, FALSE))) { + break; } - sv_catsv(gen, sv); + + attr = sv_2mortal(newSVpvn_flags(s, len, PARSING_UTF ? SVf_UTF8 : 0)); + + lex_read_to(s + len); lex_read_space(0); c = lex_peek_unichar(0); - } - if (c == ':') { - lex_read_unichar(0); - lex_read_space(0); + + if (c != '(') { + if (sv_eq_pvs(attr, "lvalue")) { + builtin_attrs |= MY_ATTR_LVALUE; + attr = NULL; + } else if (sv_eq_pvs(attr, "method")) { + builtin_attrs |= MY_ATTR_METHOD; + attr = NULL; + } + } else { + SV *sv = sv_2mortal(newSVpvs("")); + if (!S_scan_str(aTHX_ sv, TRUE, TRUE)) { + croak("In %"SVf": unterminated attribute parameter in attribute list", SVfARG(declarator)); + } + sv_catsv(attr, sv); + + lex_read_space(0); + c = lex_peek_unichar(0); + } + + if (attr) { + *attrs_sentinel = op_append_elem(OP_LIST, *attrs_sentinel, newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(attr))); + } + + if (c == ':') { + lex_read_unichar(0); + lex_read_space(0); + c = lex_peek_unichar(0); + } } } } /* body */ - c = lex_peek_unichar(0); if (c != '{') { croak("In %"SVf": I was expecting a function body, not \"%c\"", SVfARG(declarator), (int)c); } - lex_read_unichar(0); - sv_catpvs(gen, "{"); - if (SvTRUE(spec->shift)) { - sv_catpvs(gen, "my"); - sv_catsv(gen, spec->shift); - sv_catpvs(gen, "=shift;"); + + if (builtin_attrs & MY_ATTR_LVALUE) { + CvLVALUE_on(PL_compcv); } - if (SvCUR(params)) { - sv_catpvs(gen, "my("); - sv_catsv(gen, params); - sv_catpvs(gen, ")=@_;"); + if (builtin_attrs & MY_ATTR_METHOD) { + CvMETHOD_on(PL_compcv); + } + if (builtin_attrs & MY_ATTR_SPECIAL) { + CvSPECIAL_on(PL_compcv); } - /* named sub */ - if (saw_name) { - /* fprintf(stderr, "! [%.*s]\n", (int)(PL_bufend - PL_bufptr), PL_bufptr); */ - lex_stuff_sv(gen, SvUTF8(gen)); - *pop = parse_barestmt(0); - return KEYWORD_PLUGIN_STMT; + /* munge */ + { + /* create outer block: '{' */ + const int save_ix = S_block_start(TRUE); + OP *init = NULL; + + /* my $self = shift; */ + if (SvTRUE(spec->shift)) { + OP *const var = newOP(OP_PADSV, OPf_WANT_SCALAR | (OPpLVAL_INTRO << 8)); + var->op_targ = pad_add_name_sv(spec->shift, 0, NULL, NULL); + + init = newASSIGNOP(OPf_STACKED, var, 0, newOP(OP_SHIFT, 0)); + init = newSTATEOP(0, NULL, init); + } + + /* my (PARAMS) = @_; */ + if (params && av_len(params) > -1) { + SV *param; + OP *init_param, *left, *right; + + left = NULL; + while ((param = av_shift(params)) != &PL_sv_undef) { + OP *const var = newOP(OP_PADSV, OPf_WANT_LIST | (OPpLVAL_INTRO << 8)); + var->op_targ = pad_add_name_sv(param, 0, NULL, NULL); + SvREFCNT_dec(param); + left = op_append_elem(OP_LIST, left, var); + } + + left->op_flags |= OPf_PARENS; + right = newAVREF(newGVOP(OP_GV, 0, PL_defgv)); + init_param = newASSIGNOP(OPf_STACKED, left, 0, right); + init_param = newSTATEOP(0, NULL, init_param); + + init = op_append_list(OP_LINESEQ, init, init_param); + } + + /* add '();' to make function return nothing by default */ + /* (otherwise the invisible parameter initialization can "leak" into + the return value: fun ($x) {}->("asdf", 0) == 2) */ + if (init) { + init = op_append_list(OP_LINESEQ, init, newSTATEOP(0, NULL, newOP(OP_STUB, OPf_PARENS))); + } + + /* finally let perl parse the actual subroutine body */ + body = parse_block(0); + + body = op_append_list(OP_LINESEQ, init, body); + + /* close outer block: '}' */ + S_block_end(save_ix, body); } - /* anon sub */ - sv_catpvs(gen, "BEGIN{" MY_PKG "::_fini}"); - /* fprintf(stderr, "!> [%.*s]\n", (int)(PL_bufend - PL_bufptr), PL_bufptr); */ - lex_stuff_sv(gen, SvUTF8(gen)); - *pop = parse_arithexpr(0); - s = PL_parser->bufptr; - if (*s != '}') { - croak("%s: internal error: expected '}', found '%c'", MY_PKG, *s); + /* it's go time. */ + { + OP *const attrs = *attrs_sentinel; + *attrs_sentinel = NULL; + SvREFCNT_inc_simple_void(PL_compcv); + + if (!saw_name) { + *pop = newANONATTRSUB( + floor_ix, + proto ? newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(proto)) : NULL, + attrs, + body + ); + return KEYWORD_PLUGIN_EXPR; + } + + newATTRSUB( + floor_ix, + newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(saw_name)), + proto ? newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(proto)) : NULL, + attrs, + body + ); + *pop = NULL; + return KEYWORD_PLUGIN_STMT; } - lex_unstuff(s + 1); - /* fprintf(stderr, "!< [%.*s]\n", (int)(PL_bufend - PL_bufptr), PL_bufptr); */ - return KEYWORD_PLUGIN_EXPR; } static int my_keyword_plugin(pTHX_ char *keyword_ptr, STRLEN keyword_len, OP **op_ptr) { @@ -349,27 +526,6 @@ static int my_keyword_plugin(pTHX_ char *keyword_ptr, STRLEN keyword_len, OP **o return ret; } -static int magic_free(pTHX_ SV *sv, MAGIC *mg) { - lex_stuff_pvn("}", 1, 0); - /* fprintf(stderr, "!~ [%.*s]\n", (int)(PL_bufend - PL_bufptr), PL_bufptr); */ - return 0; -} - -static int magic_nop(pTHX_ SV *sv, MAGIC *mg) { - return 0; -} - -static MGVTBL my_vtbl = { - 0, /* get */ - 0, /* set */ - 0, /* len */ - 0, /* clear */ - magic_free, /* free */ - 0, /* copy */ - 0, /* dup */ - magic_nop /* local */ -}; - WARNINGS_RESET MODULE = Function::Parameters PACKAGE = Function::Parameters @@ -390,8 +546,3 @@ WARNINGS_ENABLE { next_keyword_plugin = PL_keyword_plugin; PL_keyword_plugin = my_keyword_plugin; } WARNINGS_RESET - -void -_fini() - CODE: - sv_magicext((SV *)GvHV(PL_hintgv), NULL, PERL_MAGIC_ext, &my_vtbl, NULL, 0); diff --git a/padop_on_crack.c.inc b/padop_on_crack.c.inc new file mode 100644 index 0000000..f40ded3 --- /dev/null +++ b/padop_on_crack.c.inc @@ -0,0 +1,627 @@ +/* + * This code was copied from perl/pad.c and perl/op.c and subsequently + * butchered by Lukas Mai (2012). + */ +/* vi: set ft=c inde=: */ + +#define COP_SEQ_RANGE_LOW_set(SV, VAL) \ + do { ((XPVNV*)SvANY(SV))->xnv_u.xpad_cop_seq.xlow = (VAL); } while (0) +#define COP_SEQ_RANGE_HIGH_set(SV, VAL) \ + do { ((XPVNV*)SvANY(SV))->xnv_u.xpad_cop_seq.xhigh = (VAL); } while (0) + +static void S_pad_block_start(pTHX_ int full) { + dVAR; + ASSERT_CURPAD_ACTIVE("pad_block_start"); + SAVEI32(PL_comppad_name_floor); + PL_comppad_name_floor = AvFILLp(PL_comppad_name); + if (full) + PL_comppad_name_fill = PL_comppad_name_floor; + if (PL_comppad_name_floor < 0) + PL_comppad_name_floor = 0; + SAVEI32(PL_min_intro_pending); + SAVEI32(PL_max_intro_pending); + PL_min_intro_pending = 0; + SAVEI32(PL_comppad_name_fill); + SAVEI32(PL_padix_floor); + PL_padix_floor = PL_padix; + PL_pad_reset_pending = FALSE; +} + +static int S_block_start(pTHX_ int full) { + dVAR; + const int retval = PL_savestack_ix; + + S_pad_block_start(full); + SAVEHINTS(); + PL_hints &= ~HINT_BLOCK_SCOPE; + SAVECOMPILEWARNINGS(); + PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings); + + CALL_BLOCK_HOOKS(bhk_start, full); + + return retval; +} + +/* Check for in place reverse and sort assignments like "@a = reverse @a" + and modify the optree to make them work inplace */ + +static void S_inplace_aassign(pTHX_ OP *o) { + OP *modop, *modop_pushmark; + OP *oright; + OP *oleft, *oleft_pushmark; + + assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID); + + assert(cUNOPo->op_first->op_type == OP_NULL); + modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first; + assert(modop_pushmark->op_type == OP_PUSHMARK); + modop = modop_pushmark->op_sibling; + + if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE) + return; + + /* no other operation except sort/reverse */ + if (modop->op_sibling) + return; + + assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK); + if (!(oright = cUNOPx(modop)->op_first->op_sibling)) return; + + if (modop->op_flags & OPf_STACKED) { + /* skip sort subroutine/block */ + assert(oright->op_type == OP_NULL); + oright = oright->op_sibling; + } + + assert(cUNOPo->op_first->op_sibling->op_type == OP_NULL); + oleft_pushmark = cUNOPx(cUNOPo->op_first->op_sibling)->op_first; + assert(oleft_pushmark->op_type == OP_PUSHMARK); + oleft = oleft_pushmark->op_sibling; + + /* Check the lhs is an array */ + if (!oleft || + (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV) + || oleft->op_sibling + || (oleft->op_private & OPpLVAL_INTRO) + ) + return; + + /* Only one thing on the rhs */ + if (oright->op_sibling) + return; + + /* check the array is the same on both sides */ + if (oleft->op_type == OP_RV2AV) { + if (oright->op_type != OP_RV2AV + || !cUNOPx(oright)->op_first + || cUNOPx(oright)->op_first->op_type != OP_GV + || cUNOPx(oleft )->op_first->op_type != OP_GV + || cGVOPx_gv(cUNOPx(oleft)->op_first) != + cGVOPx_gv(cUNOPx(oright)->op_first) + ) + return; + } + else if (oright->op_type != OP_PADAV + || oright->op_targ != oleft->op_targ + ) + return; + + /* This actually is an inplace assignment */ + + modop->op_private |= OPpSORT_INPLACE; + + /* transfer MODishness etc from LHS arg to RHS arg */ + oright->op_flags = oleft->op_flags; + + /* remove the aassign op and the lhs */ + op_null(o); + op_null(oleft_pushmark); + if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first) + op_null(cUNOPx(oleft)->op_first); + op_null(oleft); +} + +static OP *S_scalarvoid(pTHX_ OP *); + +static OP *S_scalar(pTHX_ OP *o) { + dVAR; + OP *kid; + + /* assumes no premature commitment */ + if (!o || (PL_parser && PL_parser->error_count) + || (o->op_flags & OPf_WANT) + || o->op_type == OP_RETURN) + { + return o; + } + + o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR; + + switch (o->op_type) { + case OP_REPEAT: + S_scalar(cBINOPo->op_first); + break; + case OP_OR: + case OP_AND: + case OP_COND_EXPR: + for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) + S_scalar(kid); + break; + /* FALL THROUGH */ + case OP_SPLIT: + case OP_MATCH: + case OP_QR: + case OP_SUBST: + case OP_NULL: + default: + if (o->op_flags & OPf_KIDS) { + for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) + S_scalar(kid); + } + break; + case OP_LEAVE: + case OP_LEAVETRY: + kid = cLISTOPo->op_first; + S_scalar(kid); + kid = kid->op_sibling; +do_kids: + while (kid) { + OP *sib = kid->op_sibling; + if (sib && kid->op_type != OP_LEAVEWHEN) + S_scalarvoid(kid); + else + S_scalar(kid); + kid = sib; + } + PL_curcop = &PL_compiling; + break; + case OP_SCOPE: + case OP_LINESEQ: + case OP_LIST: + kid = cLISTOPo->op_first; + goto do_kids; + case OP_SORT: + Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context"); + break; + } + return o; +} + +static OP *S_scalarkids(pTHX_ OP *o) { + if (o && o->op_flags & OPf_KIDS) { + OP *kid; + for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) + S_scalar(kid); + } + return o; +} + +static OP *S_scalarvoid(pTHX_ OP *o) { + dVAR; + OP *kid; + const char *useless = NULL; + U32 useless_is_utf8 = 0; + SV *sv; + U8 want; + + PERL_ARGS_ASSERT_SCALARVOID; + + if ( + o->op_type == OP_NEXTSTATE || + o->op_type == OP_DBSTATE || ( + o->op_type == OP_NULL && ( + o->op_targ == OP_NEXTSTATE || + o->op_targ == OP_DBSTATE + ) + ) + ) { + PL_curcop = (COP*)o; /* for warning below */ + } + + /* assumes no premature commitment */ + want = o->op_flags & OPf_WANT; + if ( + (want && want != OPf_WANT_SCALAR) || + (PL_parser && PL_parser->error_count) || + o->op_type == OP_RETURN || + o->op_type == OP_REQUIRE || + o->op_type == OP_LEAVEWHEN + ) { + return o; + } + + if ( + (o->op_private & OPpTARGET_MY) && + (PL_opargs[o->op_type] & OA_TARGLEX) + /* OPp share the meaning */ + ) { + return S_scalar(o); /* As if inside SASSIGN */ + } + + o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID; + + switch (o->op_type) { + default: + if (!(PL_opargs[o->op_type] & OA_FOLDCONST)) + break; + /* FALL THROUGH */ + case OP_REPEAT: + if (o->op_flags & OPf_STACKED) + break; + goto func_ops; + case OP_SUBSTR: + if (o->op_private == 4) + break; + /* FALL THROUGH */ + case OP_GVSV: + case OP_WANTARRAY: + case OP_GV: + case OP_SMARTMATCH: + case OP_PADSV: + case OP_PADAV: + case OP_PADHV: + case OP_PADANY: + case OP_AV2ARYLEN: + case OP_REF: + case OP_REFGEN: + case OP_SREFGEN: + case OP_DEFINED: + case OP_HEX: + case OP_OCT: + case OP_LENGTH: + case OP_VEC: + case OP_INDEX: + case OP_RINDEX: + case OP_SPRINTF: + case OP_AELEM: + case OP_AELEMFAST: + case OP_AELEMFAST_LEX: + case OP_ASLICE: + 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: + case OP_PROTOTYPE: + case OP_RUNCV: +func_ops: + if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO))) + /* Otherwise it's "Useless use of grep iterator" */ + useless = OP_DESC(o); + break; + + case OP_SPLIT: + kid = cLISTOPo->op_first; + if (kid && kid->op_type == OP_PUSHRE +#ifdef USE_ITHREADS + && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff) +#else + && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv) +#endif + useless = OP_DESC(o); + break; + + case OP_NOT: + kid = cUNOPo->op_first; + if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST && + kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) { + goto func_ops; + } + useless = "negative pattern binding (!~)"; + break; + + case OP_SUBST: + if (cPMOPo->op_pmflags & PMf_NONDESTRUCT) + useless = "non-destructive substitution (s///r)"; + break; + + case OP_TRANSR: + useless = "non-destructive transliteration (tr///r)"; + break; + + case OP_RV2GV: + case OP_RV2SV: + case OP_RV2AV: + case OP_RV2HV: + if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) && + (!o->op_sibling || o->op_sibling->op_type != OP_READLINE)) + useless = "a variable"; + break; + + case OP_CONST: + sv = cSVOPo_sv; + if (cSVOPo->op_private & OPpCONST_STRICT) { + //no_bareword_allowed(o); + *((int *)NULL) += 1; + } else { + if (ckWARN(WARN_VOID)) { + /* don't warn on optimised away booleans, eg + * use constant Foo, 5; Foo || print; */ + if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT) + useless = NULL; + /* the constants 0 and 1 are permitted as they are + conventionally used as dummies in constructs like + 1 while some_condition_with_side_effects; */ + else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0)) + useless = NULL; + else if (SvPOK(sv)) { + /* perl4's way of mixing documentation and code + (before the invention of POD) was based on a + trick to mix nroff and perl code. The trick was + built upon these three nroff macros being used in + void context. The pink camel has the details in + the script wrapman near page 319. */ + const char * const maybe_macro = SvPVX_const(sv); + if (strnEQ(maybe_macro, "di", 2) || + strnEQ(maybe_macro, "ds", 2) || + strnEQ(maybe_macro, "ig", 2)) + useless = NULL; + else { + SV * const dsv = newSVpvs(""); + SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_ + "a constant (%s)", + pv_pretty(dsv, maybe_macro, SvCUR(sv), 32, NULL, NULL, + PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_NOCLEAR | PERL_PV_ESCAPE_UNI_DETECT ))); + SvREFCNT_dec(dsv); + useless = SvPV_nolen(msv); + useless_is_utf8 = SvUTF8(msv); + } + } + else if (SvOK(sv)) { + SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_ + "a constant (%"SVf")", sv)); + useless = SvPV_nolen(msv); + } + else + useless = "a constant (undef)"; + } + } + op_null(o); /* don't execute or even remember it */ + break; + + case OP_POSTINC: + o->op_type = OP_PREINC; /* pre-increment is faster */ + o->op_ppaddr = PL_ppaddr[OP_PREINC]; + break; + + case OP_POSTDEC: + o->op_type = OP_PREDEC; /* pre-decrement is faster */ + o->op_ppaddr = PL_ppaddr[OP_PREDEC]; + break; + + case OP_I_POSTINC: + o->op_type = OP_I_PREINC; /* pre-increment is faster */ + o->op_ppaddr = PL_ppaddr[OP_I_PREINC]; + break; + + case OP_I_POSTDEC: + o->op_type = OP_I_PREDEC; /* pre-decrement is faster */ + o->op_ppaddr = PL_ppaddr[OP_I_PREDEC]; + break; + + case OP_SASSIGN: { + OP *rv2gv; + UNOP *refgen, *rv2cv; + LISTOP *exlist; + + if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2) + break; + + rv2gv = ((BINOP *)o)->op_last; + if (!rv2gv || rv2gv->op_type != OP_RV2GV) + break; + + refgen = (UNOP *)((BINOP *)o)->op_first; + + if (!refgen || refgen->op_type != OP_REFGEN) + break; + + exlist = (LISTOP *)refgen->op_first; + if (!exlist || exlist->op_type != OP_NULL + || exlist->op_targ != OP_LIST) + break; + + if (exlist->op_first->op_type != OP_PUSHMARK) + break; + + rv2cv = (UNOP*)exlist->op_last; + + if (rv2cv->op_type != OP_RV2CV) + break; + + assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0); + assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0); + assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0); + + o->op_private |= OPpASSIGN_CV_TO_GV; + rv2gv->op_private |= OPpDONT_INIT_GV; + rv2cv->op_private |= OPpMAY_RETURN_CONSTANT; + + break; + } + + case OP_AASSIGN: { + S_inplace_aassign(o); + break; + } + + case OP_OR: + case OP_AND: + kid = cLOGOPo->op_first; + if (kid->op_type == OP_NOT + && (kid->op_flags & OPf_KIDS) + && !PL_madskills) { + if (o->op_type == OP_AND) { + o->op_type = OP_OR; + o->op_ppaddr = PL_ppaddr[OP_OR]; + } else { + o->op_type = OP_AND; + o->op_ppaddr = PL_ppaddr[OP_AND]; + } + op_null(kid); + } + + case OP_DOR: + case OP_COND_EXPR: + case OP_ENTERGIVEN: + case OP_ENTERWHEN: + for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) + S_scalarvoid(kid); + break; + + case OP_NULL: + if (o->op_flags & OPf_STACKED) + break; + /* FALL THROUGH */ + case OP_NEXTSTATE: + case OP_DBSTATE: + case OP_ENTERTRY: + case OP_ENTER: + if (!(o->op_flags & OPf_KIDS)) + break; + /* FALL THROUGH */ + case OP_SCOPE: + case OP_LEAVE: + case OP_LEAVETRY: + case OP_LEAVELOOP: + case OP_LINESEQ: + case OP_LIST: + case OP_LEAVEGIVEN: + case OP_LEAVEWHEN: + for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) + S_scalarvoid(kid); + break; + case OP_ENTEREVAL: + S_scalarkids(o); + break; + case OP_SCALAR: + return S_scalar(o); + } + if (useless) + Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %"SVf" in void context", + newSVpvn_flags(useless, strlen(useless), + SVs_TEMP | ( useless_is_utf8 ? SVf_UTF8 : 0 ))); + return o; +} + +static OP *S_scalarseq(pTHX_ OP *o) { + dVAR; + if (o) { + const OPCODE type = o->op_type; + + if (type == OP_LINESEQ || type == OP_SCOPE || + type == OP_LEAVE || type == OP_LEAVETRY) + { + OP *kid; + for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { + if (kid->op_sibling) { + S_scalarvoid(kid); + } + } + PL_curcop = &PL_compiling; + } + o->op_flags &= ~OPf_PARENS; + if (PL_hints & HINT_BLOCK_SCOPE) + o->op_flags |= OPf_PARENS; + } + else + o = newOP(OP_STUB, 0); + return o; +} + +static void S_pad_leavemy(pTHX) { + dVAR; + I32 off; + SV * const * const svp = AvARRAY(PL_comppad_name); + + PL_pad_reset_pending = FALSE; + + ASSERT_CURPAD_ACTIVE("pad_leavemy"); + if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) { + for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) { + const SV * const sv = svp[off]; + if (sv && sv != &PL_sv_undef && !SvFAKE(sv)) + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), + "%"SVf" never introduced", + SVfARG(sv)); + } + } + /* "Deintroduce" my variables that are leaving with this scope. */ + for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) { + const SV * const sv = svp[off]; + if (sv && sv != &PL_sv_undef && !SvFAKE(sv) + && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO) + { + COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax); + DEBUG_Xv(PerlIO_printf(Perl_debug_log, + "Pad leavemy: %ld \"%s\", (%lu,%lu)\n", + (long)off, SvPVX_const(sv), + (unsigned long)COP_SEQ_RANGE_LOW(sv), + (unsigned long)COP_SEQ_RANGE_HIGH(sv)) + ); + } + } + PL_cop_seqmax++; + if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */ + PL_cop_seqmax++; + DEBUG_Xv(PerlIO_printf(Perl_debug_log, + "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax)); +} + +static OP *S_block_end(pTHX_ I32 floor, OP *seq) { + dVAR; + const int needblockscope = PL_hints & HINT_BLOCK_SCOPE; + OP *retval = S_scalarseq(seq); + + CALL_BLOCK_HOOKS(bhk_pre_end, &retval); + + LEAVE_SCOPE(floor); + CopHINTS_set(&PL_compiling, PL_hints); + if (needblockscope) + PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */ + S_pad_leavemy(); + + CALL_BLOCK_HOOKS(bhk_post_end, &retval); + + return retval; +} diff --git a/t/02-compiles.t b/t/02-compiles.t index 4128807..1e50754 100644 --- a/t/02-compiles.t +++ b/t/02-compiles.t @@ -27,7 +27,7 @@ method## # ) ##AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA { ## - ## + $self ## } ## method add($y) { diff --git a/t/03-compiles.t b/t/03-compiles.t index 277b3bd..7c10546 100644 --- a/t/03-compiles.t +++ b/t/03-compiles.t @@ -27,7 +27,7 @@ clathod## # ) ##AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA { ## - ## + $class## } ## clathod add($y) { diff --git a/t/precedence.t b/t/precedence.t index c988bab..01f088d 100644 --- a/t/precedence.t +++ b/t/precedence.t @@ -19,10 +19,10 @@ is quantum / 2 #/ , 0xf00d / 2, "basic sanity 4 - () proto"; is eval('my $x = fun forbidden {}'), undef, "statements aren't expressions"; -like $@, qr/syntax error/; +like $@, qr/expect.*function body/; is eval('my $x = { fun forbidden {} }'), undef, "statements aren't expressions 2 - electric boogaloo"; -like $@, qr/syntax error/; +like $@, qr/expect.*function body/; is fun { join '.', five, four }->(), '5.4', "can immedicall anon subs"; diff --git a/t/regress.t b/t/regress.t new file mode 100644 index 0000000..2c4bbfb --- /dev/null +++ b/t/regress.t @@ -0,0 +1,44 @@ +#!perl + +use Test::More tests => 21; + +use warnings FATAL => 'all'; +use strict; + +use Function::Parameters; + +fun mk_counter($i) { + fun () { $i++ } +} + +method nop() {} +fun fnop($x, $y, $z) { +} + +is_deeply [nop], []; +is_deeply [main->nop], []; +is_deeply [nop 1], []; +is scalar(nop), undef; +is scalar(nop 2), undef; + +is_deeply [fnop], []; +is_deeply [fnop 3, 4], []; +is scalar(fnop), undef; +is scalar(fnop 5, 6), undef; + +my $f = mk_counter 0; +my $g = mk_counter 10; +my $h = mk_counter 50; + +is $f->(), 0; +is $g->(), 10; +is $h->(), 50; +is $f->(), 1; +is $g->(), 11; +is $h->(), 51; +is $f->(), 2; +is $f->(), 3; +is $f->(), 4; +is $g->(), 12; +is $h->(), 52; +is $g->(), 13; diff --git a/toke_on_crack.c.inc b/toke_on_crack.c.inc index bd609eb..fca95b5 100644 --- a/toke_on_crack.c.inc +++ b/toke_on_crack.c.inc @@ -18,21 +18,21 @@ #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline)) #ifdef USE_UTF8_SCRIPTS -# define UTF (!IN_BYTES) +# define PARSING_UTF (!IN_BYTES) #else -# define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8)) +# define PARSING_UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8)) #endif static STRLEN S_scan_word(pTHX_ const char *start, int allow_package) { const char *s = start; for (;;) { - if (isALNUM(*s) || (!UTF && isALNUMC_L1(*s))) { /* UTF handled below */ + if (isALNUM(*s) || (!PARSING_UTF && isALNUMC_L1(*s))) { /* UTF handled below */ s++; - } else if (allow_package && s > start && *s == '\'' && isIDFIRST_lazy_if(s+1, UTF)) { + } else if (allow_package && s > start && *s == '\'' && isIDFIRST_lazy_if(s+1, PARSING_UTF)) { s++; - } else if (allow_package && s[0] == ':' && s[1] == ':' && isIDFIRST_lazy_if(s+2, UTF)) { + } else if (allow_package && s[0] == ':' && s[1] == ':' && isIDFIRST_lazy_if(s+2, PARSING_UTF)) { s += 2; - } else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) { + } else if (PARSING_UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) { do { s += UTF8SKIP(s); } while (UTF8_IS_CONTINUED(*s) && is_utf8_mark((U8*)s)); @@ -63,7 +63,7 @@ static char *S_scan_str(pTHX_ SV *sv, int keep_quoted, int keep_delims) { /* after skipping whitespace, the next character is the terminator */ term = *s; - if (!UTF) { + if (!PARSING_UTF) { termcode = termstr[0] = term; termlen = 1; } @@ -99,7 +99,7 @@ static char *S_scan_str(pTHX_ SV *sv, int keep_quoted, int keep_delims) { sv_catpvn(sv, s, termlen); s += termlen; for (;;) { - if (PL_encoding && !UTF) { + if (PL_encoding && !PARSING_UTF) { bool cont = TRUE; while (cont) { @@ -205,7 +205,7 @@ static char *S_scan_str(pTHX_ SV *sv, int keep_quoted, int keep_delims) { if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen)) break; } - else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF) + else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && PARSING_UTF) has_utf8 = TRUE; *to = *s; } @@ -239,7 +239,7 @@ static char *S_scan_str(pTHX_ SV *sv, int keep_quoted, int keep_delims) { break; else if (*s == PL_multi_open) brackets++; - else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF) + else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && PARSING_UTF) has_utf8 = TRUE; *to = *s; } @@ -286,7 +286,7 @@ static char *S_scan_str(pTHX_ SV *sv, int keep_quoted, int keep_delims) { /* at this point, we have successfully read the delimited string */ - if (!PL_encoding || UTF) { + if (!PL_encoding || PARSING_UTF) { if (keep_delims) sv_catpvn(sv, s, termlen); s += termlen; @@ -305,4 +305,84 @@ static char *S_scan_str(pTHX_ SV *sv, int keep_quoted, int keep_delims) { PL_bufptr = s; return s; } + +static void S_check_prototype(const SV *declarator, SV *proto) { + bool bad_proto = FALSE; + bool in_brackets = FALSE; + char greedy_proto = ' '; + bool proto_after_greedy_proto = FALSE; + bool must_be_last = FALSE; + bool underscore = FALSE; + bool seen_underscore = FALSE; + const bool warnillegalproto = ckWARN(WARN_ILLEGALPROTO); + char *d, *p; + STRLEN tmp, tmplen; + + /* strip spaces and check for bad characters */ + d = SvPV(proto, tmplen); + tmp = 0; + for (p = d; tmplen; tmplen--, ++p) { + if (!isSPACE(*p)) { + d[tmp++] = *p; + + if (warnillegalproto) { + if (must_be_last) { + proto_after_greedy_proto = TRUE; + } + if (!strchr("$@%*;[]&\\_+", *p) || *p == '\0') { + bad_proto = TRUE; + } else { + if (underscore) { + if (!strchr(";@%", *p)) { + bad_proto = TRUE; + } + underscore = FALSE; + } + if (*p == '[') { + in_brackets = TRUE; + } else if (*p == ']') { + in_brackets = FALSE; + } else if ( + (*p == '@' || *p == '%') && + (tmp < 2 || d[tmp - 2] != '\\') && + !in_brackets + ) { + must_be_last = TRUE; + greedy_proto = *p; + } else if (*p == '_') { + underscore = seen_underscore = TRUE; + } + } + } + } + } + d[tmp] = '\0'; + SvCUR_set(proto, tmp); + if (proto_after_greedy_proto) { + Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO), + "In %"SVf": prototype after '%c': %s", + SVfARG(declarator), greedy_proto, d + ); + } + if (bad_proto) { + SV *dsv = newSVpvs_flags("", SVs_TEMP); + Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO), + "In %"SVf": illegal character %sin prototype: %s", + SVfARG(declarator), + seen_underscore ? "after '_' " : "", + SvUTF8(proto) + ? sv_uni_display(dsv, + newSVpvn_flags(d, tmp, SVs_TEMP | SVf_UTF8), + tmp, + UNI_DISPLAY_ISPRINT + ) + : pv_pretty(dsv, d, tmp, 60, NULL, NULL, + PERL_PV_ESCAPE_NONASCII + ) + ); + } + SvCUR_set(proto, tmp); +} + +#undef CLINE /* ^^^^^^^^^^^^^^^^^^^^^ I HAVE NO IDEA WHAT I'M DOING ^^^^^^^^^^^^^^^^^^^^ */