[perl #123960] sv.c: Fix gp_free -Do output

[perl5.git] / perly.y

diff --git a/perly.y b/perly.y
index 99ee27b..4b73977 100644 (file)
--- a/perly.y
+++ b/perly.y
@@ -45,7 +45,7 @@
 
 %token <ival> GRAMPROG GRAMEXPR GRAMBLOCK GRAMBARESTMT GRAMFULLSTMT GRAMSTMTSEQ
 
-%token <ival> '{' '}' '[' ']' '-' '+' '$' '@' '%' '*' '&' ';' '=' '.'
+%token <ival> '{' '}' '[' ']' '-' '+' '@' '%' '&' '=' '.'
 
 %token <opval> WORD METHOD FUNCMETH THING PMFUNC PRIVATEREF QWLIST
 %token <opval> FUNC0OP FUNC0SUB UNIOPSUB LSTOPSUB
@@ -70,11 +70,11 @@
 %type <opval> expr term subscripted scalar ary hsh arylen star amper sideff
 %type <opval> sliceme kvslice gelem
 %type <opval> listexpr nexpr texpr iexpr mexpr mnexpr miexpr
-%type <opval> optlistexpr optexpr indirob listop method
+%type <opval> optlistexpr optexpr optrepl indirob listop method
 %type <opval> formname subname proto optsubbody cont my_scalar my_var
 %type <opval> refgen_topic formblock
 %type <opval> subattrlist myattrlist myattrterm myterm
-%type <opval> realsubbody subsignature termbinop termunop anonymous termdo
+%type <opval> subsignature termbinop termunop anonymous termdo
 %type <opval> formstmtseq formline formarg
 
 %nonassoc <ival> PREC_LOW
@@ -297,6 +297,45 @@ barestmt:  PLUGSTMT
                          intro_my();
                          parser->parsed_sub = 1;
                        }
+       |       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);
+                         parser->in_my = 0;
+                         parser->in_my_stash = NULL;
+                       }
+               remember subsignature subattrlist '{' stmtseq '}'
+                       {
+                         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)
+                         ;
+                         $$ = (OP*)NULL;
+                         intro_my();
+                         parser->parsed_sub = 1;
+                       }
        |       PACKAGE WORD WORD ';'
                        {
                          package($3);
@@ -599,13 +638,12 @@ myattrlist:       COLONATTR THING
                        { $$ = (OP*)NULL; }
        ;
 
-/* Optional subroutine signature */
-subsignature:  /* NULL */ { $$ = (OP*)NULL; }
-       |       '('
+/* Subroutine signature */
+subsignature:  '('
                        {
-                         if (!FEATURE_SIGNATURES_IS_ENABLED)
-                           Perl_croak(aTHX_ "Experimental "
-                               "subroutine signatures not enabled");
+                         /* We shouldn't get here otherwise */
+                         assert(FEATURE_SIGNATURES_IS_ENABLED);
+
                          Perl_ck_warner_d(aTHX_
                                packWARN(WARN_EXPERIMENTAL__SIGNATURES),
                                "The signatures feature is experimental");
@@ -615,22 +653,12 @@ subsignature:     /* NULL */ { $$ = (OP*)NULL; }
                        {
                          $$ = op_append_list(OP_LINESEQ, $<opval>2,
                                newSTATEOP(0, NULL, sawparens(newNULLLIST())));
-                         parser->expect = XBLOCK;
-                       }
-       ;
-
-/* Subroutine body - block with optional signature */
-realsubbody:   remember subsignature '{' stmtseq '}'
-                       {
-                         if (parser->copline > (line_t)$3)
-                             parser->copline = (line_t)$3;
-                         $$ = block_end($1,
-                               op_append_list(OP_LINESEQ, $2, $4));
+                         parser->expect = XATTRBLOCK;
                        }
        ;
 
 /* Optional subroutine body, for named subroutine declaration */
-optsubbody:    realsubbody { $$ = $1; }
+optsubbody:    block
        |       ';'     { $$ = (OP*)NULL; }
        ;
 
@@ -648,7 +676,7 @@ expr        :       expr ANDOP expr
 listexpr:      listexpr ','
                        { $$ = $1; }
        |       listexpr ',' term
-                       { 
+                       {
                          OP* term = $3;
                          $$ = op_append_elem(OP_LIST, $1, term);
                        }
@@ -801,7 +829,7 @@ termunop : '-' term %prec UMINUS                       /* -$x */
        |       '!' term                               /* !$x */
                        { $$ = newUNOP(OP_NOT, 0, scalar($2)); }
        |       '~' term                               /* ~$x */
-                       { $$ = newUNOP(OP_COMPLEMENT, 0, scalar($2)); }
+                       { $$ = newUNOP($1, 0, scalar($2)); }
        |       term POSTINC                           /* $x++ */
                        { $$ = newUNOP(OP_POSTINC, 0,
                                        op_lvalue(scalar($1), OP_POSTINC)); }
@@ -837,9 +865,19 @@ anonymous: '[' expr ']'
                        { $$ = newANONHASH($2); }
        |       HASHBRACK ';' '}'       %prec '(' /* { } (';' by tokener) */
                        { $$ = newANONHASH((OP*)NULL); }
-       |       ANONSUB startanonsub proto subattrlist realsubbody      %prec '('
+       |       ANONSUB startanonsub proto subattrlist block            %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);
+                       }
 
     ;
 
@@ -857,7 +895,7 @@ term        :       termbinop
        |       term '?' term ':' term
                        { $$ = newCONDOP(0, $1, $3, $5); }
        |       REFGEN term                          /* \$x, \@y, \%z */
-                       { $$ = newUNOP(OP_REFGEN, 0, op_lvalue($2,OP_REFGEN)); }
+                       { $$ = newUNOP(OP_REFGEN, 0, $2); }
        |       myattrterm      %prec UNIOP
                        { $$ = $1; }
        |       LOCAL term      %prec UNIOP
@@ -996,8 +1034,8 @@ term       :       termbinop
                            } else
                                $<ival>$ = 0;
                        }
-                   '(' listexpr ')'
-                       { $$ = pmruntime($1, $4, 1, $<ival>2); }
+                   '(' listexpr optrepl ')'
+                       { $$ = pmruntime($1, $4, $5, 1, $<ival>2); }
        |       WORD
        |       listop
        |       YADAYADA
@@ -1042,6 +1080,12 @@ optexpr: /* NULL */
                        { $$ = $1; }
        ;
 
+optrepl:       /* NULL */
+                       { $$ = (OP*)NULL; }
+       |       '/' expr
+                       { $$ = $2; }
+       ;
+
 /* A little bit of trickery to make "for my $foo (@bar)" actually be
    lexical */
 my_scalar:     scalar