This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
stop eval "sub{" leaking
[perl5.git] / madly.y
diff --git a/madly.y b/madly.y
index 576319f..0643ff5 100644 (file)
--- a/madly.y
+++ b/madly.y
@@ -14,6 +14,7 @@
 
 /*  Make the parser re-entrant. */
 
+/* FIXME for MAD - is the new mintro on while and until important?  */
 %pure_parser
 
 %start prog
 %token <tkval> LABEL
 %token <tkval> FORMAT SUB ANONSUB PACKAGE USE
 %token <tkval> WHILE UNTIL IF UNLESS ELSE ELSIF CONTINUE FOR
+%token <tkval> GIVEN WHEN DEFAULT
 %token <tkval> LOOPEX DOTDOT
 %token <tkval> FUNC0 FUNC1 FUNC UNIOP LSTOP
 %token <tkval> RELOP EQOP MULOP ADDOP
 %token <tkval> DOLSHARP DO HASHBRACK NOAMP
-%token <tkval> LOCAL MY MYSUB
+%token <tkval> LOCAL MY MYSUB REQUIRE
 %token <tkval> COLONATTR
 
 %type <ival> prog progstart remember mremember savescope
-%type <ival> startsub startanonsub startformsub mintro
+%type <ival>  startsub startanonsub startformsub
+/* FIXME for MAD - are these two ival? */
+%type <ival> mydefsv mintro
 
 %type <tkval> '&' ';'
 
@@ -54,6 +58,7 @@
 %type <opval> formname subname proto subbody cont my_scalar
 %type <opval> subattrlist myattrlist myattrterm myterm
 %type <opval> termbinop termunop anonymous termdo
+%type <opval> switch case
 %type <tkval> label
 
 %nonassoc <tkval> PREC_LOW
@@ -74,6 +79,7 @@
 %nonassoc EQOP
 %nonassoc RELOP
 %nonassoc UNIOP UNIOPSUB
+%nonassoc REQUIRE
 %left <tkval> SHIFTOP
 %left ADDOP
 %left MULOP
@@ -110,6 +116,10 @@ remember:  /* NULL */      /* start a full lexical scope */
                        { $$ = block_start(TRUE); }
        ;
 
+mydefsv:       /* NULL */      /* lexicalize $_ */
+                       { $$ = (I32) allocmy("$_"); }
+       ;
+
 progstart:
                {
                    PL_expect = XSTATE; $$ = block_start(TRUE);
@@ -153,6 +163,10 @@ line       :       label cond
                        { $$ = newSTATEOP(0, ($1)->tk_lval.pval, $2);
                          token_getmad($1,((LISTOP*)$$)->op_first,'L'); }
        |       loop    /* loops add their own labels */
+       |       switch  /* ... and so do switches */
+                       { $$ = $1; }
+       |       label case
+                       { $$ = newSTATEOP(0, ($1)->tk_lval.pval, $2); }
        |       label ';'
                        {
                          if (($1)->tk_lval.pval) {
@@ -248,6 +262,14 @@ cond       :       IF '(' remember mexpr ')' mblock else
                        }
        ;
 
+/* Cases for a switch statement */
+case   :       WHEN '(' remember mexpr ')' mblock
+       { $$ = block_end($3,
+               newWHENOP($4, scope($6))); }
+       |       DEFAULT block
+       { $$ = newWHENOP(0, scope($2)); }
+       ;
+
 /* Continue blocks */
 cont   :       /* NULL */
                        { $$ = Nullop; }
@@ -261,7 +283,7 @@ cont        :       /* NULL */
 loop   :       label WHILE '(' remember texpr ')' mintro mblock cont
                        { OP *innerop;
                          PL_copline = (line_t)$2;
-                         $$ = block_end($4,
+                           $$ = block_end($4,
                                   newSTATEOP(0, ($1)->tk_lval.pval,
                                     innerop = newWHILEOP(0, 1, (LOOP*)Nullop,
                                                ($2)->tk_lval.ival, $5, $8, $9, $7)));
@@ -270,12 +292,13 @@ loop      :       label WHILE '(' remember texpr ')' mintro mblock cont
                          token_getmad($3,innerop,'(');
                          token_getmad($6,innerop,')');
                        }
+
        |       label UNTIL '(' remember iexpr ')' mintro mblock cont
                        { OP *innerop;
                          PL_copline = (line_t)$2;
-                         $$ = block_end($4,
+                           $$ = block_end($4,
                                   newSTATEOP(0, ($1)->tk_lval.pval,
-                                    innerop = newWHILEOP(0, 1, (LOOP*)Nullop,
+                                    newWHILEOP(0, 1, (LOOP*)Nullop,
                                                ($2)->tk_lval.ival, $5, $8, $9, $7)));
                          token_getmad($1,innerop,'L');
                          token_getmad($2,innerop,'W');
@@ -311,7 +334,8 @@ loop        :       label WHILE '(' remember texpr ')' mintro mblock cont
                          token_getmad($3,((LISTOP*)innerop)->op_first->op_sibling,'(');
                          token_getmad($6,((LISTOP*)innerop)->op_first->op_sibling,')');
                        }
-       |       label FOR '(' remember mnexpr ';' texpr ';'  mintro mnexpr ')' mblock
+       |       label FOR '(' remember mnexpr ';' texpr ';' mintro mnexpr ')'
+                   mblock
                        /* basically fake up an initialize-while lineseq */
                        { OP *forop;
                          PL_copline = (line_t)($2)->tk_lval.ival;
@@ -334,8 +358,7 @@ loop        :       label WHILE '(' remember texpr ')' mintro mblock cont
                          token_getmad($8,forop,'2');
                          token_getmad($11,forop,')');
                          token_getmad($1,forop,'L');
-                         $$ = block_end($4, forop);
-                       }
+                         $$ = block_end($4, forop); }
        |       label block cont  /* a block is a loop that happens once */
                        { $$ = newSTATEOP(0, ($1)->tk_lval.pval,
                                 newWHILEOP(0, 1, (LOOP*)Nullop,
@@ -343,13 +366,21 @@ loop      :       label WHILE '(' remember texpr ')' mintro mblock cont
                          token_getmad($1,((LISTOP*)$$)->op_first,'L'); }
        ;
 
+/* Switch blocks */
+switch :       label GIVEN '(' remember mydefsv mexpr ')' mblock
+                       { PL_copline = (line_t) $2;
+                           $$ = block_end($4,
+                               newSTATEOP(0, ($1)->tk_lval.pval,
+                                   newGIVENOP($6, scope($8),
+                                       (PADOFFSET) $5) )); }
+       ;
+
 /* determine whether there are any new my declarations */
 mintro :       /* NULL */
                        { $$ = (PL_min_intro_pending &&
                            PL_max_intro_pending >=  PL_min_intro_pending);
                          intro_my(); }
 
-
 /* Normal expression */
 nexpr  :       /* NULL */
                        { $$ = Nullop; }
@@ -412,7 +443,8 @@ peg :       PEG
        ;
 
 format :       FORMAT startformsub formname block
-                       { $$ = newFORM($2, $3, $4);
+                       { SvREFCNT_inc(PL_compcv);
+                         $$ = newFORM($2, $3, $4);
                          prepend_madprops($1->tk_mad, $$, 'F');
                          $1->tk_mad = 0;
                          token_free($1);
@@ -425,14 +457,16 @@ formname: WORD            { $$ = $1; }
 
 /* Unimplemented "my sub foo { }" */
 mysubrout:     MYSUB startsub subname proto subattrlist subbody
-                       { $$ = newMYSUB($2, $3, $4, $5, $6);
+                       { SvREFCNT_inc(PL_compcv);
+                         $$ = newMYSUB($2, $3, $4, $5, $6);
                          token_getmad($1,$$,'d');
                        }
        ;
 
 /* Subroutine definition */
 subrout        :       SUB startsub subname proto subattrlist subbody
-                       { OP* o = newSVOP(OP_ANONCODE, 0,
+                       { SvREFCNT_inc(PL_compcv);
+                         OP* o = newSVOP(OP_ANONCODE, 0,
                            (SV*)newATTRSUB($2, $3, $4, $5, $6));
                          $$ = newOP(OP_NULL,0);
                          op_getmad(o,$$,'&');
@@ -446,19 +480,23 @@ subrout   :       SUB startsub subname proto subattrlist subbody
        ;
 
 startsub:      /* NULL */      /* start a regular subroutine scope */
-                       { $$ = start_subparse(FALSE, 0); }
+                       { $$ = start_subparse(FALSE, 0);
+                           SAVEFREESV(PL_compcv); }
+
        ;
 
 startanonsub:  /* NULL */      /* start an anonymous subroutine scope */
-                       { $$ = start_subparse(FALSE, CVf_ANON); }
+                       { $$ = start_subparse(FALSE, CVf_ANON);
+                           SAVEFREESV(PL_compcv); }
        ;
 
 startformsub:  /* NULL */      /* start a format subroutine scope */
-                       { $$ = start_subparse(TRUE, 0); }
+                       { $$ = start_subparse(TRUE, 0);
+                           SAVEFREESV(PL_compcv); }
        ;
 
 /* Name of a subroutine - must be a bareword, could be special */
-subname        :       WORD    { STRLEN n_a; char *name = SvPV(((SVOP*)$1)->op_sv,n_a);
+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"))
                              CvSPECIAL_on(PL_compcv);
@@ -512,7 +550,8 @@ package :   PACKAGE WORD ';'
 use    :       USE startsub
                        { CvSPECIAL_on(PL_compcv); /* It's a BEGIN {} */ }
                    WORD WORD listexpr ';'
-                       { $$ = utilize(($1)->tk_lval.ival, $2, $4, $5, $6);
+                       { SvREFCNT_inc(PL_compcv);
+                         $$ = utilize(($1)->tk_lval.ival, $2, $4, $5, $6);
                          token_getmad($1,$$,'o');
                          token_getmad($7,$$,';');
                          if (PL_rsfp_filters && AvFILLp(PL_rsfp_filters) >= 0)
@@ -604,7 +643,8 @@ listop      :       LSTOP indirob argexpr          /* print $fh @args */
                          token_getmad($4,$$,')');
                        }
        |       LSTOPSUB startanonsub block          /* map { foo } ... */
-                       { $3 = newANONATTRSUB($2, 0, Nullop, $3); }
+                       { SvREFCNT_inc(PL_compcv);
+                         $3 = newANONATTRSUB($2, 0, Nullop, $3); }
                    listexpr            %prec LSTOP  /* ... @bar */
                        { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED,
                                 append_elem(OP_LIST,
@@ -702,6 +742,20 @@ subscripted:    star '{' expr ';' '}'        /* *main::{something} */
                          token_getmad($2,$$,'(');
                          token_getmad($3,$$,')');
                        }
+       |       '(' expr ')' '[' expr ']'            /* list slice */
+                       { $$ = newSLICEOP(0, $5, $2);
+                         token_getmad($1,$$,'(');
+                         token_getmad($3,$$,')');
+                         token_getmad($4,$$,'[');
+                         token_getmad($6,$$,']');
+                       }
+       |       '(' ')' '[' expr ']'                 /* empty list slice! */
+                       { $$ = newSLICEOP(0, $4, Nullop);
+                         token_getmad($1,$$,'(');
+                         token_getmad($2,$$,')');
+                         token_getmad($3,$$,'[');
+                         token_getmad($5,$$,']');
+                       }
     ;
 
 /* Binary operators between terms */
@@ -837,7 +891,8 @@ anonymous:  '[' expr ']'
                          token_getmad($3,$$,'}');
                        }
        |       ANONSUB startanonsub proto subattrlist block    %prec '('
-                       { $$ = newANONATTRSUB($2, $3, $4, $5);
+                       { SvREFCNT_inc(PL_compcv);
+                         $$ = newANONATTRSUB($2, $3, $4, $5);
                          token_getmad($1,$$,'o');
                          op_getmad($3,$$,'s');
                          op_getmad($4,$$,'a');
@@ -940,20 +995,6 @@ term       :       termbinop
                        { $$ = newUNOP(OP_AV2ARYLEN, 0, ref($1, OP_AV2ARYLEN));}
        |       subscripted
                        { $$ = $1; }
-       |       '(' expr ')' '[' expr ']'            /* list slice */
-                       { $$ = newSLICEOP(0, $5, $2);
-                         token_getmad($1,$$,'(');
-                         token_getmad($3,$$,')');
-                         token_getmad($4,$$,'[');
-                         token_getmad($6,$$,']');
-                       }
-       |       '(' ')' '[' expr ']'                 /* empty list slice! */
-                       { $$ = newSLICEOP(0, $4, Nullop);
-                         token_getmad($1,$$,'(');
-                         token_getmad($2,$$,')');
-                         token_getmad($3,$$,'[');
-                         token_getmad($5,$$,']');
-                       }
        |       ary '[' expr ']'                     /* array slice */
                        { $$ = prepend_elem(OP_ASLICE,
                                newOP(OP_PUSHMARK, 0),
@@ -1024,10 +1065,13 @@ term    :       termbinop
                        { $$ = newUNOP(($1)->tk_lval.ival, 0, $2);
                          token_getmad($1,$$,'o');
                        }
+       |       REQUIRE                              /* require, $_ implied *//* FIMXE for MAD needed? */
+                       { $$ = newOP(OP_REQUIRE, $1 ? OPf_SPECIAL : 0); }
+       |       REQUIRE term                         /* require Foo *//* FIMXE for MAD needed? */
+                       { $$ = newUNOP(OP_REQUIRE, $1 ? OPf_SPECIAL : 0, $2); }
        |       UNIOPSUB term                        /* Sub treated as unop */
                        { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED,
-                           append_elem(OP_LIST, $2, scalar($1)));
-                       }
+                           append_elem(OP_LIST, $2, scalar($1))); }
        |       FUNC0                                /* Nullary operator */
                        { $$ = newOP(($1)->tk_lval.ival, 0);
                          token_getmad($1,$$,'o');