X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/76eba8ab520b5c85d3a1566e1ae17ca49faeccf1..2c6ee1a7a1ce7cff7755f9aa43a65b8278dd82a1:/perly.y

diff --git a/perly.y b/perly.y
index f7e8b63..1047913 100644
--- a/perly.y
+++ b/perly.y
@@ -97,9 +97,9 @@
 %type <opval> sliceme kvslice gelem
 %type <opval> listexpr nexpr texpr iexpr mexpr mnexpr miexpr
 %type <opval> optlistexpr optexpr indirob listop method
-%type <opval> formname subname proto subbody cont my_scalar formblock
+%type <opval> formname subname proto optsubbody cont my_scalar formblock
 %type <opval> subattrlist myattrlist myattrterm myterm
-%type <opval> termbinop termunop anonymous termdo
+%type <opval> realsubbody subsignature termbinop termunop anonymous termdo
 %type <opval> formstmtseq formline formarg
 
 %nonassoc <i_tkval> PREC_LOW
@@ -127,7 +127,7 @@
 %left <i_tkval> MATCHOP
 %right <i_tkval> '!' '~' UMINUS REFGEN
 %right <i_tkval> POWOP
-%nonassoc <i_tkval> PREINC PREDEC POSTINC POSTDEC
+%nonassoc <i_tkval> PREINC PREDEC POSTINC POSTDEC POSTJOIN
 %left <i_tkval> ARROW
 %nonassoc <i_tkval> ')'
 %left <i_tkval> '('
@@ -339,7 +339,7 @@ barestmt:	PLUGSTMT
 			  PL_parser->in_my = 0;
 			  PL_parser->in_my_stash = NULL;
 			}
-		proto subattrlist subbody
+		proto subattrlist optsubbody
 			{
 			  SvREFCNT_inc_simple_void(PL_compcv);
 #ifdef MAD
@@ -728,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");
+			  $<opval>$ = parse_subsignature();
+			}
+		')'
+			{
+			  $$ = op_append_list(OP_LINESEQ, $<opval>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
@@ -1053,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));
@@ -1089,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');
@@ -1108,49 +1152,6 @@ termdo	:       DO term	%prec UNIOP                     /* do $filename */
 			{ $$ = newUNOP(OP_NULL, OPf_SPECIAL, op_scope($2));
 			  TOKEN_GETMAD($1,$$,'D');
 			}
-	|	DO subname '(' ')'                  /* 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 subname '(' 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
@@ -1479,6 +1480,10 @@ arylen	:	DOLSHARP indirob
 			{ $$ = newAVREF($2);
 			  TOKEN_GETMAD($1,$$,'l');
 			}
+	|	term ARROW DOLSHARP '*'
+			{ $$ = newAVREF($1);
+			  TOKEN_GETMAD($3,$$,'l');
+			}
 	;
 
 star	:	'*' indirob