Parsing fix: it wasn't possible to call a function with a (_) prototype

[p5sagit/p5-mst-13.2.git] / perly.y

diff --git a/perly.y b/perly.y
index e88add1..77caeb6 100644 (file)
--- a/perly.y
+++ b/perly.y
@@ -30,6 +30,9 @@
 %union {
     I32        ival;
     char *pval;
+#ifdef PERL_MAD
+    TOKEN* tkval;
+#endif
     OP *opval;
     GV *gvval;
 }
@@ -41,6 +44,7 @@
 %token <pval> LABEL
 %token <ival> FORMAT SUB ANONSUB PACKAGE USE
 %token <ival> WHILE UNTIL IF UNLESS ELSE ELSIF CONTINUE FOR
+%token <ival> GIVEN WHEN DEFAULT
 %token <ival> LOOPEX DOTDOT
 %token <ival> FUNC0 FUNC1 FUNC UNIOP LSTOP
 %token <ival> RELOP EQOP MULOP ADDOP
@@ -49,7 +53,7 @@
 %token COLONATTR
 
 %type <ival> prog decl format startsub startanonsub startformsub mintro
-%type <ival> progstart remember mremember '&' savescope
+%type <ival> progstart remember mremember '&' savescope mydefsv
 %type <opval> block mblock lineseq line loop cond else
 %type <opval> expr term subscripted scalar ary hsh arylen star amper sideff
 %type <opval> argexpr nexpr texpr iexpr mexpr mnexpr miexpr
@@ -57,6 +61,7 @@
 %type <opval> formname subname proto subbody cont my_scalar
 %type <opval> subattrlist myattrlist mysubrout myattrterm myterm
 %type <opval> termbinop termunop anonymous termdo
+%type <opval> switch case
 %type <pval> label
 
 %nonassoc PREC_LOW
@@ -77,6 +82,7 @@
 %nonassoc EQOP
 %nonassoc RELOP
 %nonassoc UNIOP UNIOPSUB
+%nonassoc REQUIRE
 %left <ival> SHIFTOP
 %left ADDOP
 %left MULOP
@@ -89,6 +95,8 @@
 %left '('
 %left '[' '{'
 
+%token PEG
+
 %% /* RULES */
 
 /* The whole program */
@@ -108,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);
@@ -145,6 +157,10 @@ lineseq    :       /* NULL */
 line   :       label cond
                        { $$ = newSTATEOP(0, $1, $2); }
        |       loop    /* loops add their own labels */
+       |       switch  /* ... and so do switches */
+                       { $$ = $1; }
+       |       label case
+                       { $$ = newSTATEOP(0, $1, $2); }
        |       label ';'
                        { if ($1 != Nullch) {
                              $$ = newSTATEOP(0, $1, newOP(OP_NULL, 0));
@@ -199,6 +215,14 @@ cond       :       IF '(' remember mexpr ')' mblock else
                                   newCONDOP(0, $4, scope($6), $7)); }
        ;
 
+/* 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; }
@@ -252,6 +276,15 @@ loop       :       label WHILE '(' remember texpr ')' mintro mblock cont
                                            NOLINE, Nullop, $2, $3, 0)); }
        ;
 
+/* Switch blocks */
+switch :       label GIVEN '(' remember mydefsv mexpr ')' mblock
+                       { PL_copline = (line_t) $2;
+                           $$ = block_end($4,
+                               newSTATEOP(0, $1,
+                                   newGIVENOP($6, scope($8),
+                                       (PADOFFSET) $5) )); }
+       ;
+
 /* determine whether there are any new my declarations */
 mintro :       /* NULL */
                        { $$ = (PL_min_intro_pending &&
@@ -308,7 +341,8 @@ decl        :       format
        ;
 
 format :       FORMAT startformsub formname block
-                       { newFORM($2, $3, $4); }
+                       { SvREFCNT_inc(PL_compcv);
+                         newFORM($2, $3, $4); }
        ;
 
 formname:      WORD            { $$ = $1; }
@@ -317,30 +351,36 @@ 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); }
        ;
 
 /* Subroutine definition */
 subrout        :       SUB startsub subname proto subattrlist subbody
-                       { newATTRSUB($2, $3, $4, $5, $6); }
+                       { SvREFCNT_inc(PL_compcv);
+                         newATTRSUB($2, $3, $4, $5, $6); }
        ;
 
 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    { const char *const name = SvPV_nolen_const(((SVOP*)$1)->op_sv);
                          if (strEQ(name, "BEGIN") || strEQ(name, "END")
-                             || strEQ(name, "INIT") || strEQ(name, "CHECK"))
+                             || strEQ(name, "INIT") || strEQ(name, "CHECK")
+                             || strEQ(name, "UNITCHECK"))
                              CvSPECIAL_on(PL_compcv);
                          $$ = $1; }
        ;
@@ -379,7 +419,8 @@ package :   PACKAGE WORD ';'
 use    :       USE startsub
                        { CvSPECIAL_on(PL_compcv); /* It's a BEGIN {} */ }
                    WORD WORD listexpr ';'
-                       { utilize($1, $2, $4, $5, $6); }
+                        { SvREFCNT_inc(PL_compcv);
+                          utilize($1, $2, $4, $5, $6); }
        ;
 
 /* Ordinary expressions; logical combinations */
@@ -431,7 +472,8 @@ listop      :       LSTOP indirob argexpr /* map {...} @args or print $fh @args */
        |       FUNC '(' listexprcom ')'             /* print (@args) */
                        { $$ = convert($1, 0, $3); }
        |       LSTOPSUB startanonsub block /* sub f(&@);   f { 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,
@@ -560,13 +602,14 @@ anonymous:        '[' expr ']'
        |       HASHBRACK ';' '}'       %prec '(' /* { } (';' by tokener) */
                        { $$ = newANONHASH(Nullop); }
        |       ANONSUB startanonsub proto subattrlist block    %prec '('
-                       { $$ = newANONATTRSUB($2, $3, $4, $5); }
+                       { SvREFCNT_inc(PL_compcv);
+                         $$ = newANONATTRSUB($2, $3, $4, $5); }
 
     ;
 
 /* Things called with "do" */
 termdo :       DO term %prec UNIOP                     /* do $filename */
-                       { $$ = dofile($2); }
+                       { $$ = dofile($2, $1); }
        |       DO block        %prec '('               /* do { code */
                        { $$ = newUNOP(OP_NULL, OPf_SPECIAL, scope($2)); }
        |       DO WORD '(' ')'                         /* do somesub() */
@@ -668,6 +711,8 @@ term        :       termbinop
                        { $$ = newOP(OP_REQUIRE, $1 ? OPf_SPECIAL : 0); }
        |       REQUIRE term                         /* require Foo */
                        { $$ = newUNOP(OP_REQUIRE, $1 ? OPf_SPECIAL : 0, $2); }
+       |       UNIOPSUB
+                       { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar($1)); }
        |       UNIOPSUB term                        /* Sub treated as unop */
                        { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED,
                            append_elem(OP_LIST, $2, scalar($1))); }