X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/7c70caa5333de92b09e138154bed7f78f783be3b..2c6ee1a7a1ce7cff7755f9aa43a65b8278dd82a1:/perly.y diff --git a/perly.y b/perly.y index b940bc6..1047913 100644 --- a/perly.y +++ b/perly.y @@ -84,8 +84,8 @@ %token FUNC0 FUNC1 FUNC UNIOP LSTOP %token RELOP EQOP MULOP ADDOP %token DOLSHARP DO HASHBRACK NOAMP -%token LOCAL MY MYSUB REQUIRE -%token COLONATTR +%token LOCAL MY REQUIRE +%token COLONATTR FORMLBRACK FORMRBRACK %type grammar remember mremember %type startsub startanonsub startformsub @@ -94,11 +94,13 @@ %type stmtseq fullstmt labfullstmt barestmt block mblock else %type expr term subscripted scalar ary hsh arylen star amper sideff +%type sliceme kvslice gelem %type listexpr nexpr texpr iexpr mexpr mnexpr miexpr %type optlistexpr optexpr indirob listop method -%type formname subname proto subbody cont my_scalar formblock +%type formname subname proto optsubbody cont my_scalar formblock %type subattrlist myattrlist myattrterm myterm -%type termbinop termunop anonymous termdo +%type realsubbody subsignature termbinop termunop anonymous termdo +%type formstmtseq formline formarg %nonassoc PREC_LOW %nonassoc LOOPEX @@ -125,7 +127,7 @@ %left MATCHOP %right '!' '~' UMINUS REFGEN %right POWOP -%nonassoc PREINC PREDEC POSTINC POSTDEC +%nonassoc PREINC PREDEC POSTINC POSTDEC POSTJOIN %left ARROW %nonassoc ')' %left '(' @@ -212,12 +214,12 @@ block : '{' remember stmtseq '}' ; /* format body */ -formblock: '=' remember stmtseq '.' +formblock: '=' remember ';' FORMRBRACK formstmtseq ';' '.' { if (PL_parser->copline > (line_t)IVAL($1)) PL_parser->copline = (line_t)IVAL($1); - $$ = block_end($2, $3); + $$ = block_end($2, $5); TOKEN_GETMAD($1,$$,'{'); - TOKEN_GETMAD($4,$$,'}'); + TOKEN_GETMAD($7,$$,'}'); } ; @@ -249,6 +251,17 @@ stmtseq : /* NULL */ } ; +/* A sequence of format lines */ +formstmtseq: /* NULL */ + { $$ = (OP*)NULL; } + | formstmtseq formline + { $$ = op_append_list(OP_LINESEQ, $1, $2); + PL_pad_reset_pending = TRUE; + if ($1 && $2) + PL_hints |= HINT_BLOCK_SCOPE; + } + ; + /* A statement in the program, including optional labels */ fullstmt: barestmt { @@ -264,15 +277,17 @@ fullstmt: barestmt labfullstmt: LABEL barestmt { - $$ = newSTATEOP(SvUTF8(((SVOP*)$1)->op_sv), - savepv(SvPVX(((SVOP*)$1)->op_sv)), $2); + $$ = newSTATEOP(SVf_UTF8 + * PVAL($1)[strlen(PVAL($1))+1], + PVAL($1), $2); TOKEN_GETMAD($1, $2 ? cLISTOPx($$)->op_first : $$, 'L'); } | LABEL labfullstmt { - $$ = newSTATEOP(SvUTF8(((SVOP*)$1)->op_sv), - savepv(SvPVX(((SVOP*)$1)->op_sv)), $2); + $$ = newSTATEOP(SVf_UTF8 + * PVAL($1)[strlen(PVAL($1))+1], + PVAL($1), $2); TOKEN_GETMAD($1, cLISTOPx($$)->op_first, 'L'); } ; @@ -288,7 +303,6 @@ barestmt: PLUGSTMT | FORMAT startformsub formname formblock { CV *fmtcv = PL_compcv; - SvREFCNT_inc_simple_void(PL_compcv); #ifdef MAD $$ = newFORM($2, $3, $4); prepend_madprops($1->tk_mad, $$, 'F'); @@ -303,38 +317,55 @@ barestmt: PLUGSTMT pad_add_anon(fmtcv, OP_NULL); } } - | SUB startsub subname proto subattrlist subbody + | SUB subname startsub + { + if ($2->op_type == OP_CONST) { + const char *const name = + SvPV_nolen_const(((SVOP*)$2)->op_sv); + if (strEQ(name, "BEGIN") || strEQ(name, "END") + || strEQ(name, "INIT") || strEQ(name, "CHECK") + || strEQ(name, "UNITCHECK")) + CvSPECIAL_on(PL_compcv); + } + else + /* State subs inside anonymous subs need to be + clonable themselves. */ + if (CvANON(CvOUTSIDE(PL_compcv)) + || CvCLONE(CvOUTSIDE(PL_compcv)) + || !PadnameIsSTATE(PadlistNAMESARRAY(CvPADLIST( + CvOUTSIDE(PL_compcv) + ))[$2->op_targ])) + CvCLONE_on(PL_compcv); + PL_parser->in_my = 0; + PL_parser->in_my_stash = NULL; + } + proto subattrlist optsubbody { SvREFCNT_inc_simple_void(PL_compcv); #ifdef MAD { OP* o = newSVOP(OP_ANONCODE, 0, - (SV*)newATTRSUB($2, $3, $4, $5, $6)); + (SV*)( +#endif + $2->op_type == OP_CONST + ? newATTRSUB($3, $2, $5, $6, $7) + : newMYSUB($3, $2, $5, $6, $7) +#ifdef MAD + )); $$ = newOP(OP_NULL,0); op_getmad(o,$$,'&'); - op_getmad($3,$$,'n'); - op_getmad($4,$$,'s'); - op_getmad($5,$$,'a'); + op_getmad($2,$$,'n'); + op_getmad($5,$$,'s'); + op_getmad($6,$$,'a'); token_getmad($1,$$,'d'); - append_madprops($6->op_madprop, $$, 0); - $6->op_madprop = 0; + append_madprops($7->op_madprop, $$, 0); + $7->op_madprop = 0; } #else - newATTRSUB($2, $3, $4, $5, $6); - $$ = (OP*)NULL; -#endif - } - | MYSUB startsub subname proto subattrlist subbody - { - /* Unimplemented "my sub foo { }" */ - SvREFCNT_inc_simple_void(PL_compcv); -#ifdef MAD - $$ = newMYSUB($2, $3, $4, $5, $6); - token_getmad($1,$$,'d'); -#else - newMYSUB($2, $3, $4, $5, $6); + ; $$ = (OP*)NULL; #endif + intro_my(); } | PACKAGE WORD WORD ';' { @@ -507,6 +538,36 @@ barestmt: PLUGSTMT } ; +/* Format line */ +formline: THING formarg + { OP *list; + if ($2) { + OP *term = $2; + DO_MAD(term = newUNOP(OP_NULL, 0, term)); + list = op_append_elem(OP_LIST, $1, term); + } + else { +#ifdef MAD + OP *op = newNULLLIST(); + list = op_append_elem(OP_LIST, $1, op); +#else + list = $1; +#endif + } + if (PL_parser->copline == NOLINE) + PL_parser->copline = CopLINE(PL_curcop)-1; + else PL_parser->copline--; + $$ = newSTATEOP(0, NULL, + convert(OP_FORMLINE, 0, list)); + } + ; + +formarg : /* NULL */ + { $$ = NULL; } + | FORMLBRACK stmtseq FORMRBRACK + { $$ = op_unscope($2); } + ; + /* An expression which may have a side-effect */ sideff : error { $$ = (OP*)NULL; } @@ -627,12 +688,8 @@ startformsub: /* NULL */ /* start a format subroutine scope */ ; /* Name of a subroutine - must be a bareword, could be special */ -subname : WORD { const char *const name = SvPV_nolen_const(((SVOP*)$1)->op_sv); - if (strEQ(name, "BEGIN") || strEQ(name, "END") - || strEQ(name, "INIT") || strEQ(name, "CHECK") - || strEQ(name, "UNITCHECK")) - CvSPECIAL_on(PL_compcv); - $$ = $1; } +subname : WORD + | PRIVATEREF ; /* Subroutine prototype */ @@ -671,8 +728,40 @@ myattrlist: COLONATTR THING } ; -/* Subroutine body - either null or a block */ -subbody : block { $$ = $1; } +/* Optional subroutine signature */ +subsignature: /* NULL */ { $$ = (OP*)NULL; } + | '(' + { + if (!FEATURE_SIGNATURES_IS_ENABLED) + Perl_croak(aTHX_ "Experimental " + "subroutine signatures not enabled"); + Perl_ck_warner_d(aTHX_ + packWARN(WARN_EXPERIMENTAL__SIGNATURES), + "The signatures feature is experimental"); + $$ = parse_subsignature(); + } + ')' + { + $$ = op_append_list(OP_LINESEQ, $2, + newSTATEOP(0, NULL, sawparens(newNULLLIST()))); + PL_parser->expect = XBLOCK; + } + ; + +/* Subroutine body - block with optional signature */ +realsubbody: remember subsignature '{' stmtseq '}' + { + if (PL_parser->copline > (line_t)IVAL($3)) + PL_parser->copline = (line_t)IVAL($3); + $$ = block_end($1, + op_append_list(OP_LINESEQ, $2, $4)); + TOKEN_GETMAD($3,$$,'{'); + TOKEN_GETMAD($5,$$,'}'); + } + ; + +/* Optional subroutine body, for named subroutine declaration */ +optsubbody: realsubbody { $$ = $1; } | ';' { $$ = IF_MAD( newOP(OP_NULL,0), (OP*)NULL @@ -789,7 +878,7 @@ method : METHOD ; /* Some kind of subscripted expression */ -subscripted: star '{' expr ';' '}' /* *main::{something} */ +subscripted: gelem '{' expr ';' '}' /* *main::{something} */ /* In this and all the hash accessors, ';' is * provided by the tokeniser */ { $$ = newBINOP(OP_GELEM, 0, $1, scalar($3)); @@ -943,7 +1032,7 @@ termbinop: term ASSIGNOP term /* $x = $y */ op = (UNOP*)op->op_first; /* get to flip */ op = (UNOP*)op->op_first; /* get to range */ token_getmad($2,(OP*)op,'o'); - }) + }); } | term ANDAND term /* $x && $y */ { $$ = newLOGOP(OP_AND, 0, $1, $3); @@ -996,6 +1085,18 @@ termunop : '-' term %prec UMINUS /* -$x */ op_lvalue(scalar($1), OP_POSTDEC)); TOKEN_GETMAD($2,$$,'o'); } + | term POSTJOIN /* implicit join after interpolated ->@ */ + { $$ = convert(OP_JOIN, 0, + op_append_elem( + OP_LIST, + newSVREF(scalar( + newSVOP(OP_CONST,0, + newSVpvs("\"")) + )), + $1 + )); + TOKEN_GETMAD($2,$$,'o'); + } | PREINC term /* ++$x */ { $$ = newUNOP(OP_PREINC, 0, op_lvalue(scalar($2), OP_PREINC)); @@ -1032,7 +1133,7 @@ anonymous: '[' expr ']' TOKEN_GETMAD($2,$$,';'); TOKEN_GETMAD($3,$$,'}'); } - | ANONSUB startanonsub proto subattrlist block %prec '(' + | ANONSUB startanonsub proto subattrlist realsubbody %prec '(' { SvREFCNT_inc_simple_void(PL_compcv); $$ = newANONATTRSUB($2, $3, $4, $5); TOKEN_GETMAD($1,$$,'o'); @@ -1051,49 +1152,6 @@ termdo : DO term %prec UNIOP /* do $filename */ { $$ = newUNOP(OP_NULL, OPf_SPECIAL, op_scope($2)); TOKEN_GETMAD($1,$$,'D'); } - | DO WORD '(' ')' /* do somesub() */ - { $$ = newUNOP(OP_ENTERSUB, - OPf_SPECIAL|OPf_STACKED, - op_prepend_elem(OP_LIST, - scalar(newCVREF( - (OPpENTERSUB_AMPER<<8), - scalar($2) - )),(OP*)NULL)); dep(); - TOKEN_GETMAD($1,$$,'o'); - TOKEN_GETMAD($3,$$,'('); - TOKEN_GETMAD($4,$$,')'); - } - | DO WORD '(' expr ')' /* do somesub(@args) */ - { $$ = newUNOP(OP_ENTERSUB, - OPf_SPECIAL|OPf_STACKED, - op_append_elem(OP_LIST, - $4, - scalar(newCVREF( - (OPpENTERSUB_AMPER<<8), - scalar($2) - )))); dep(); - TOKEN_GETMAD($1,$$,'o'); - TOKEN_GETMAD($3,$$,'('); - TOKEN_GETMAD($5,$$,')'); - } - | DO scalar '(' ')' /* do $subref () */ - { $$ = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, - op_prepend_elem(OP_LIST, - scalar(newCVREF(0,scalar($2))), (OP*)NULL)); dep(); - TOKEN_GETMAD($1,$$,'o'); - TOKEN_GETMAD($3,$$,'('); - TOKEN_GETMAD($4,$$,')'); - } - | DO scalar '(' expr ')' /* do $subref (@args) */ - { $$ = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, - op_prepend_elem(OP_LIST, - $4, - scalar(newCVREF(0,scalar($2))))); dep(); - TOKEN_GETMAD($1,$$,'o'); - TOKEN_GETMAD($3,$$,'('); - TOKEN_GETMAD($5,$$,')'); - } - ; term : termbinop @@ -1139,21 +1197,53 @@ term : termbinop { $$ = newUNOP(OP_AV2ARYLEN, 0, ref($1, OP_AV2ARYLEN));} | subscripted { $$ = $1; } - | ary '[' expr ']' /* array slice */ + | sliceme '[' expr ']' /* array slice */ { $$ = op_prepend_elem(OP_ASLICE, newOP(OP_PUSHMARK, 0), newLISTOP(OP_ASLICE, 0, list($3), ref($1, OP_ASLICE))); + if ($$ && $1) + $$->op_private |= + $1->op_private & OPpSLICEWARNING; TOKEN_GETMAD($2,$$,'['); TOKEN_GETMAD($4,$$,']'); } - | ary '{' expr ';' '}' /* @hash{@keys} */ + | kvslice '[' expr ']' /* array key/value slice */ + { $$ = op_prepend_elem(OP_KVASLICE, + newOP(OP_PUSHMARK, 0), + newLISTOP(OP_KVASLICE, 0, + list($3), + ref(oopsAV($1), OP_KVASLICE))); + if ($$ && $1) + $$->op_private |= + $1->op_private & OPpSLICEWARNING; + TOKEN_GETMAD($2,$$,'['); + TOKEN_GETMAD($4,$$,']'); + } + | sliceme '{' expr ';' '}' /* @hash{@keys} */ { $$ = op_prepend_elem(OP_HSLICE, newOP(OP_PUSHMARK, 0), newLISTOP(OP_HSLICE, 0, list($3), ref(oopsHV($1), OP_HSLICE))); + if ($$ && $1) + $$->op_private |= + $1->op_private & OPpSLICEWARNING; + PL_parser->expect = XOPERATOR; + TOKEN_GETMAD($2,$$,'{'); + TOKEN_GETMAD($4,$$,';'); + TOKEN_GETMAD($5,$$,'}'); + } + | kvslice '{' expr ';' '}' /* %hash{@keys} */ + { $$ = op_prepend_elem(OP_KVHSLICE, + newOP(OP_PUSHMARK, 0), + newLISTOP(OP_KVHSLICE, 0, + list($3), + ref($1, OP_KVHSLICE))); + if ($$ && $1) + $$->op_private |= + $1->op_private & OPpSLICEWARNING; PL_parser->expect = XOPERATOR; TOKEN_GETMAD($2,$$,'{'); TOKEN_GETMAD($4,$$,';'); @@ -1163,12 +1253,12 @@ term : termbinop { $$ = $1; } | amper /* &foo; */ { $$ = newUNOP(OP_ENTERSUB, 0, scalar($1)); } - | amper '(' ')' /* &foo() */ + | amper '(' ')' /* &foo() or foo() */ { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar($1)); TOKEN_GETMAD($2,$$,'('); TOKEN_GETMAD($3,$$,')'); } - | amper '(' expr ')' /* &foo(@args) */ + | amper '(' expr ')' /* &foo(@args) or foo(@args) */ { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, $3, scalar($1))); @@ -1179,13 +1269,34 @@ term : termbinop } token_getmad($2,op,'('); token_getmad($4,op,')'); - }) + }); } - | NOAMP WORD optlistexpr /* foo(@args) */ + | NOAMP subname optlistexpr /* foo @args (no parens) */ { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, $3, scalar($2))); TOKEN_GETMAD($1,$$,'o'); } + | term ARROW '$' '*' + { $$ = newSVREF($1); + TOKEN_GETMAD($3,$$,'$'); + } + | term ARROW '@' '*' + { $$ = newAVREF($1); + TOKEN_GETMAD($3,$$,'@'); + } + | term ARROW '%' '*' + { $$ = newHVREF($1); + TOKEN_GETMAD($3,$$,'%'); + } + | term ARROW '&' '*' + { $$ = newUNOP(OP_ENTERSUB, 0, + scalar(newCVREF(IVAL($3),$1))); + TOKEN_GETMAD($3,$$,'&'); + } + | term ARROW '*' '*' %prec '(' + { $$ = newGVREF(0,$1); + TOKEN_GETMAD($3,$$,'*'); + } | LOOPEX /* loop exiting command (goto, last, dump, etc) */ { $$ = newOP(IVAL($1), OPf_SPECIAL); PL_hints |= HINT_BLOCK_SCOPE; @@ -1293,7 +1404,7 @@ myattrterm: MY myterm myattrlist token_getmad($1,$$,'d'); append_madprops($3->op_madprop, $$, 'a'); $3->op_madprop = 0; - ) + ); } | MY myterm { $$ = localize($2,IVAL($1)); @@ -1353,12 +1464,14 @@ scalar : '$' indirob ary : '@' indirob { $$ = newAVREF($2); + if ($$) $$->op_private |= IVAL($1); TOKEN_GETMAD($1,$$,'@'); } ; hsh : '%' indirob { $$ = newHVREF($2); + if ($$) $$->op_private |= IVAL($1); TOKEN_GETMAD($1,$$,'%'); } ; @@ -1367,6 +1480,10 @@ arylen : DOLSHARP indirob { $$ = newAVREF($2); TOKEN_GETMAD($1,$$,'l'); } + | term ARROW DOLSHARP '*' + { $$ = newAVREF($1); + TOKEN_GETMAD($3,$$,'l'); + } ; star : '*' indirob @@ -1375,6 +1492,27 @@ star : '*' indirob } ; +sliceme : ary + | term ARROW '@' + { $$ = newAVREF($1); + TOKEN_GETMAD($3,$$,'@'); + } + ; + +kvslice : hsh + | term ARROW '%' + { $$ = newHVREF($1); + TOKEN_GETMAD($3,$$,'@'); + } + ; + +gelem : star + | term ARROW '*' + { $$ = newGVREF(0,$1); + TOKEN_GETMAD($3,$$,'*'); + } + ; + /* Indirect objects */ indirob : WORD { $$ = scalar($1); }