X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perly.y;h=cbd2f7a8483bfc37f28eb5f0f66d3c39023968f9;hb=33b5f13c2468a991d2b495f02a62b59163be82af;hp=37503ba24a69fd039ae07cac95e7057233f829d3;hpb=2596d9fe3023e9da9e3e000993c9f26fa30909ef;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/perly.y b/perly.y
index 37503ba..cbd2f7a 100644
--- 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,15 +44,16 @@
 %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
 %token <ival> DOLSHARP DO HASHBRACK NOAMP
-%token <ival> LOCAL MY MYSUB
+%token <ival> LOCAL MY MYSUB REQUIRE
 %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 &&
@@ -566,7 +599,7 @@ anonymous:	'[' expr ']'
 
 /* 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() */
@@ -664,6 +697,10 @@ term	:	termbinop
 			{ $$ = newUNOP($1, 0, $2); }
 	|	UNIOP term                           /* Unary op */
 			{ $$ = newUNOP($1, 0, $2); }
+	|	REQUIRE                              /* require, $_ implied */
+			{ $$ = newOP(OP_REQUIRE, $1 ? OPf_SPECIAL : 0); }
+	|	REQUIRE term                         /* require Foo */
+			{ $$ = 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))); }