%token <opval> BAREWORD METHOD FUNCMETH THING PMFUNC PRIVATEREF QWLIST
%token <opval> FUNC0OP FUNC0SUB UNIOPSUB LSTOPSUB
%token <opval> PLUGEXPR PLUGSTMT
-%token <pval> LABEL
-%token <ival> FORMAT SUB ANONSUB PACKAGE USE
+%token <opval> LABEL
+%token <ival> FORMAT SUB SIGSUB ANONSUB ANON_SIGSUB PACKAGE USE
%token <ival> WHILE UNTIL IF UNLESS ELSE ELSIF CONTINUE FOR
-%token <ival> GIVEN WHERESO
+%token <ival> GIVEN WHEN DEFAULT
%token <ival> LOOPEX DOTDOT YADAYADA
%token <ival> FUNC0 FUNC1 FUNC UNIOP LSTOP
%token <ival> RELOP EQOP MULOP ADDOP
%type <opval> sliceme kvslice gelem
%type <opval> listexpr nexpr texpr iexpr mexpr mnexpr
%type <opval> optlistexpr optexpr optrepl indirob listop method
-%type <opval> formname subname proto optsubbody cont my_scalar my_var
+%type <opval> formname subname proto cont my_scalar my_var
%type <opval> refgen_topic formblock
%type <opval> subattrlist myattrlist myattrterm myterm
%type <opval> termbinop termunop anonymous termdo
%type <ival> sigslurpsigil
%type <opval> sigvarname sigdefault sigscalarelem sigslurpelem
-%type <opval> sigelem siglist siglistornull subsignature
+%type <opval> sigelem siglist siglistornull subsignature optsubsignature
+%type <opval> subbody optsubbody sigsubbody optsigsubbody
%type <opval> formstmtseq formline formarg
%nonassoc <ival> PREC_LOW
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);
}
;
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
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();
$$ = block_end($3, newGIVENOP($4, op_scope($6), 0));
parser->copline = (line_t)$1;
}
- | WHERESO '(' remember mexpr ')' mblock
- { $$ = block_end($3, newWHERESOOP($4, op_scope($6))); }
+ | WHEN '(' remember mexpr ')' mblock
+ { $$ = block_end($3, newWHENOP($4, op_scope($6))); }
+ | DEFAULT block
+ { $$ = newWHENOP(0, op_scope($2)); }
| WHILE '(' remember texpr ')' mintro mblock cont
{
$$ = block_end($3,
| expr FOR expr
{ $$ = newFOROP(0, NULL, $3, $1, NULL);
parser->copline = (line_t)$2; }
- | expr WHERESO expr
- { $$ = newWHERESOOP($3, op_scope($1)); }
+ | expr WHEN expr
+ { $$ = newWHENOP($3, op_scope($1)); }
;
/* else and elsif blocks */
| siglist
{ $$ = $1; }
+/* optional subroutine signature */
+optsubsignature: /* NULL */
+ { $$ = NULL; }
+ | subsignature
+ { $$ = $1; }
+
/* Subroutine signature */
subsignature: '('
{
UNOP_AUX_item *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_
newSTATEOP(0, NULL, 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); }
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 */
{ $$ = 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" */
https://perl5.git.perl.org / perl5.git / blobdiff