X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/a9f5ab8de62884067808d6b114a8c2df780fb054..d33c0cb5873af9140aa5c05ab0a6daabd94c6a07:/perly.y diff --git a/perly.y b/perly.y index 3440dcb..0325d66 100644 --- a/perly.y +++ b/perly.y @@ -43,15 +43,15 @@ GV *gvval; } -%token GRAMPROG GRAMEXPR GRAMBLOCK GRAMBARESTMT GRAMFULLSTMT GRAMSTMTSEQ +%token GRAMPROG GRAMEXPR GRAMBLOCK GRAMBARESTMT GRAMFULLSTMT GRAMSTMTSEQ GRAMSUBSIGNATURE %token '{' '}' '[' ']' '-' '+' '@' '%' '&' '=' '.' %token BAREWORD METHOD FUNCMETH THING PMFUNC PRIVATEREF QWLIST %token FUNC0OP FUNC0SUB UNIOPSUB LSTOPSUB %token PLUGEXPR PLUGSTMT -%token LABEL -%token FORMAT SUB ANONSUB PACKAGE USE +%token LABEL +%token FORMAT SUB SIGSUB ANONSUB ANON_SIGSUB PACKAGE USE %token WHILE UNTIL IF UNLESS ELSE ELSIF CONTINUE FOR %token GIVEN WHEN DEFAULT %token LOOPEX DOTDOT YADAYADA @@ -60,6 +60,7 @@ %token DOLSHARP DO HASHBRACK NOAMP %token LOCAL MY REQUIRE %token COLONATTR FORMLBRACK FORMRBRACK +%token SUBLEXSTART SUBLEXEND %type grammar remember mremember %type startsub startanonsub startformsub @@ -71,13 +72,14 @@ %type sliceme kvslice gelem %type listexpr nexpr texpr iexpr mexpr mnexpr %type optlistexpr optexpr optrepl indirob listop method -%type formname subname proto optsubbody cont my_scalar my_var +%type formname subname proto cont my_scalar my_var %type refgen_topic formblock %type subattrlist myattrlist myattrterm myterm %type termbinop termunop anonymous termdo %type sigslurpsigil %type sigvarname sigdefault sigscalarelem sigslurpelem -%type sigelem siglist siglistornull subsignature +%type sigelem siglist siglistornull subsigguts subsignature optsubsignature +%type subbody optsubbody sigsubbody optsigsubbody %type formstmtseq formline formarg %nonassoc PREC_LOW @@ -90,7 +92,7 @@ %left ',' %right ASSIGNOP %right '?' ':' -%nonassoc DOTDOT YADAYADA +%nonassoc DOTDOT %left OROR DORDOR %left ANDAND %left BITOROP @@ -117,6 +119,7 @@ grammar : GRAMPROG { parser->expect = XSTATE; + $$ = 0; } remember stmtseq { @@ -127,6 +130,7 @@ grammar : GRAMPROG | GRAMEXPR { parser->expect = XTERM; + $$ = 0; } optexpr { @@ -136,6 +140,7 @@ grammar : GRAMPROG | GRAMBLOCK { parser->expect = XBLOCK; + $$ = 0; } block { @@ -143,11 +148,12 @@ grammar : GRAMPROG PL_eval_root = $3; $$ = 0; yyunlex(); - parser->yychar = YYEOF; + parser->yychar = yytoken = YYEOF; } | GRAMBARESTMT { parser->expect = XSTATE; + $$ = 0; } barestmt { @@ -155,11 +161,12 @@ grammar : GRAMPROG PL_eval_root = $3; $$ = 0; yyunlex(); - parser->yychar = YYEOF; + parser->yychar = yytoken = YYEOF; } | GRAMFULLSTMT { parser->expect = XSTATE; + $$ = 0; } fullstmt { @@ -167,17 +174,28 @@ grammar : GRAMPROG PL_eval_root = $3; $$ = 0; yyunlex(); - parser->yychar = YYEOF; + parser->yychar = yytoken = YYEOF; } | GRAMSTMTSEQ { parser->expect = XSTATE; + $$ = 0; } stmtseq { PL_eval_root = $3; $$ = 0; } + | GRAMSUBSIGNATURE + { + parser->expect = XSTATE; + $$ = 0; + } + subsigguts + { + PL_eval_root = $3; + $$ = 0; + } ; /* An ordinary block */ @@ -246,11 +264,17 @@ fullstmt: barestmt labfullstmt: LABEL barestmt { - $$ = newSTATEOP(SVf_UTF8 * $1[strlen($1)+1], $1, $2); + SV *label = cSVOPx_sv($1); + $$ = newSTATEOP(SvFLAGS(label) & SVf_UTF8, + savepv(SvPVX_const(label)), $2); + op_free($1); } | LABEL labfullstmt { - $$ = newSTATEOP(SVf_UTF8 * $1[strlen($1)+1], $1, $2); + SV *label = cSVOPx_sv($1); + $$ = newSTATEOP(SvFLAGS(label) & SVf_UTF8, + savepv(SvPVX_const(label)), $2); + op_free($1); } ; @@ -268,28 +292,14 @@ barestmt: PLUGSTMT parser->parsed_sub = 1; } | SUB subname startsub + /* sub declaration or definition not within scope + of 'use feature "signatures"'*/ { - 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); + init_named_cv(PL_compcv, $2); parser->in_my = 0; parser->in_my_stash = NULL; } - proto subattrlist optsubbody + proto subattrlist optsubbody { SvREFCNT_inc_simple_void(PL_compcv); $2->op_type == OP_CONST @@ -300,40 +310,22 @@ barestmt: PLUGSTMT intro_my(); parser->parsed_sub = 1; } - | SUB subname startsub + | SIGSUB subname startsub + /* sub declaration or definition under 'use feature + * "signatures"'. (Note that a signature isn't + * allowed in a declaration) + */ { - 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); + init_named_cv(PL_compcv, $2); parser->in_my = 0; parser->in_my_stash = NULL; } - remember subsignature subattrlist '{' stmtseq '}' + subattrlist optsigsubbody { - OP *body; - if (parser->copline > (line_t)$8) - parser->copline = (line_t)$8; - body = block_end($5, - op_append_list(OP_LINESEQ, $6, $9)); - SvREFCNT_inc_simple_void(PL_compcv); $2->op_type == OP_CONST - ? newATTRSUB($3, $2, NULL, $7, body) - : newMYSUB($3, $2, NULL, $7, body) + ? newATTRSUB($3, $2, NULL, $5, $6) + : newMYSUB( $3, $2, NULL, $5, $6) ; $$ = NULL; intro_my(); @@ -475,6 +467,11 @@ barestmt: PLUGSTMT { $$ = $1; } + | YADAYADA ';' + { + $$ = newLISTOP(OP_DIE, 0, newOP(OP_PUSHMARK, 0), + newSVOP(OP_CONST, 0, newSVpvs("Unimplemented"))); + } | ';' { $$ = NULL; @@ -769,8 +766,17 @@ siglistornull: /* NULL */ | siglist { $$ = $1; } +/* optional subroutine signature */ +optsubsignature: /* NULL */ + { $$ = NULL; } + | subsignature + { $$ = $1; } + /* Subroutine signature */ -subsignature: '(' +subsignature: '(' subsigguts ')' + { $$ = $2; } + +subsigguts: { ENTER; SAVEIV(parser->sig_elems); @@ -782,50 +788,94 @@ subsignature: '(' parser->in_my = KEY_sigvar; } siglistornull - ')' { - OP *sigops = $3; - UNOP_AUX_item *aux; + OP *sigops = $2; + struct op_argcheck_aux *aux; OP *check; - if (!parser->error_count) { - assert(FEATURE_SIGNATURES_IS_ENABLED); - } + if (!FEATURE_SIGNATURES_IS_ENABLED) + Perl_croak(aTHX_ "Experimental " + "subroutine signatures not enabled"); /* We shouldn't get here otherwise */ Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__SIGNATURES), "The signatures feature is experimental"); - aux = (UNOP_AUX_item*)PerlMemShared_malloc( - sizeof(UNOP_AUX_item) * 3); - aux[0].iv = parser->sig_elems; - aux[1].iv = parser->sig_optelems; - aux[2].iv = parser->sig_slurpy; - check = newUNOP_AUX(OP_ARGCHECK, 0, NULL, aux); + aux = (struct op_argcheck_aux*) + PerlMemShared_malloc( + sizeof(struct op_argcheck_aux)); + aux->params = parser->sig_elems; + aux->opt_params = parser->sig_optelems; + aux->slurpy = parser->sig_slurpy; + check = newUNOP_AUX(OP_ARGCHECK, 0, NULL, + (UNOP_AUX_item *)aux); sigops = op_prepend_elem(OP_LINESEQ, check, sigops); sigops = op_prepend_elem(OP_LINESEQ, newSTATEOP(0, NULL, NULL), sigops); /* a nextstate at the end handles context * correctly for an empty sub body */ - $$ = op_append_elem(OP_LINESEQ, + sigops = op_append_elem(OP_LINESEQ, sigops, newSTATEOP(0, NULL, NULL)); + /* wrap the list of arg ops in a NULL aux op. + This serves two purposes. First, it makes + the arg list a separate subtree from the + body of the sub, and secondly the null op + may in future be upgraded to an OP_SIGNATURE + when implemented. For now leave it as + ex-argcheck */ + $$ = newUNOP_AUX(OP_ARGCHECK, 0, sigops, NULL); + op_null($$); parser->in_my = 0; + /* tell the toker that attrributes can follow + * this sig, but only so that the toker + * can skip through any (illegal) trailing + * attribute text then give a useful error + * message about "attributes before sig", + * rather than falling over ina mess at + * unrecognised syntax. + */ parser->expect = XATTRBLOCK; + parser->sig_seen = TRUE; LEAVE; } ; +/* Optional subroutine body (for named subroutine declaration) */ +optsubbody: subbody { $$ = $1; } + | ';' { $$ = NULL; } + ; -/* Optional subroutine body, for named subroutine declaration */ -optsubbody: block - | ';' { $$ = NULL; } +/* Subroutine body (without signature) */ +subbody: remember '{' stmtseq '}' + { + if (parser->copline > (line_t)$2) + parser->copline = (line_t)$2; + $$ = block_end($1, $3); + } ; + +/* optional [ Subroutine body with optional signature ] (for named + * subroutine declaration) */ +optsigsubbody: sigsubbody { $$ = $1; } + | ';' { $$ = NULL; } + +/* Subroutine body with optional signature */ +sigsubbody: remember optsubsignature '{' stmtseq '}' + { + if (parser->copline > (line_t)$3) + parser->copline = (line_t)$3; + $$ = block_end($1, + op_append_list(OP_LINESEQ, $2, $4)); + } + ; + + /* Ordinary expressions; logical combinations */ expr : expr ANDOP expr { $$ = newLOGOP(OP_AND, 0, $1, $3); } @@ -883,6 +933,8 @@ listop : LSTOP indirob listexpr /* map {...} @args or print $fh @args */ { $$ = op_convert_list($1, 0, $2); } | FUNC '(' optexpr ')' /* print (@args) */ { $$ = op_convert_list($1, 0, $3); } + | FUNC SUBLEXSTART optexpr SUBLEXEND /* uc($arg) from "\U..." */ + { $$ = op_convert_list($1, 0, $3); } | LSTOPSUB startanonsub block /* sub f(&@); f { foo } ... */ { SvREFCNT_inc_simple_void(PL_compcv); $$ = newANONATTRSUB($2, 0, NULL, $3); } @@ -929,19 +981,31 @@ subscripted: gelem '{' expr ';' '}' /* *main::{something} */ jmaybe($3)); } | term ARROW '(' ')' /* $subref->() */ { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, - newCVREF(0, scalar($1))); } + newCVREF(0, scalar($1))); + if (parser->expect == XBLOCK) + parser->expect = XOPERATOR; + } | term ARROW '(' expr ')' /* $subref->(@args) */ { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, $4, - newCVREF(0, scalar($1)))); } + newCVREF(0, scalar($1)))); + if (parser->expect == XBLOCK) + parser->expect = XOPERATOR; + } | subscripted '(' expr ')' /* $foo->{bar}->(@args) */ { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, $3, - newCVREF(0, scalar($1)))); } + newCVREF(0, scalar($1)))); + if (parser->expect == XBLOCK) + parser->expect = XOPERATOR; + } | subscripted '(' ')' /* $foo->{bar}->() */ { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, - newCVREF(0, scalar($1))); } + newCVREF(0, scalar($1))); + if (parser->expect == XBLOCK) + parser->expect = XOPERATOR; + } | '(' expr ')' '[' expr ']' /* list slice */ { $$ = newSLICEOP(0, $5, $2); } | QWLIST '[' expr ']' /* list literal slice */ @@ -951,7 +1015,7 @@ subscripted: gelem '{' expr ';' '}' /* *main::{something} */ ; /* Binary operators between terms */ -termbinop: term ASSIGNOP term /* $x = $y */ +termbinop: term ASSIGNOP term /* $x = $y, $x += $y */ { $$ = newASSIGNOP(OPf_STACKED, $1, $2, $3); } | term POWOP term /* $x ** $y */ { $$ = newBINOP($2, 0, scalar($1), scalar($3)); } @@ -1029,20 +1093,12 @@ anonymous: '[' expr ']' { $$ = newANONHASH($2); } | HASHBRACK ';' '}' %prec '(' /* { } (';' by tokener) */ { $$ = newANONHASH(NULL); } - | ANONSUB startanonsub proto subattrlist block %prec '(' + | ANONSUB startanonsub proto subattrlist subbody %prec '(' { SvREFCNT_inc_simple_void(PL_compcv); $$ = newANONATTRSUB($2, $3, $4, $5); } - | ANONSUB startanonsub remember subsignature subattrlist '{' stmtseq '}' %prec '(' - { - OP *body; - if (parser->copline > (line_t)$6) - parser->copline = (line_t)$6; - body = block_end($3, - op_append_list(OP_LINESEQ, $4, $7)); - SvREFCNT_inc_simple_void(PL_compcv); - $$ = newANONATTRSUB($2, NULL, $5, body); - } - + | ANON_SIGSUB startanonsub subattrlist sigsubbody %prec '(' + { SvREFCNT_inc_simple_void(PL_compcv); + $$ = newANONATTRSUB($2, NULL, $3, $4); } ; /* Things called with "do" */ @@ -1200,15 +1256,10 @@ term : termbinop } else $$ = 0; } - '(' listexpr optrepl ')' + SUBLEXSTART listexpr optrepl SUBLEXEND { $$ = pmruntime($1, $4, $5, 1, $2); } | BAREWORD | listop - | YADAYADA - { - $$ = newLISTOP(OP_DIE, 0, newOP(OP_PUSHMARK, 0), - newSVOP(OP_CONST, 0, newSVpvs("Unimplemented"))); - } | PLUGEXPR ;