re PR fortran/39626 (Correctly implement details of Fortran 2008 BLOCK construct)

2009-09-29  Daniel Kraft  <d@domob.eu>

	PR fortran/39626
	* gfortran.h (enum gfc_statement): Add ST_BLOCK and ST_END_BLOCK.
	(struct gfc_namespace): Convert flags to bit-fields and add flag
	`construct_entities' for use with BLOCK constructs.
	(enum gfc_exec_code): Add EXEC_BLOCK.
	(struct gfc_code): Add namespace field to union for EXEC_BLOCK.
	* match.h (gfc_match_block): New prototype.
	* parse.h (enum gfc_compile_state): Add COMP_BLOCK.
	* trans.h (gfc_process_block_locals): New prototype.
	(gfc_trans_deferred_vars): Made public, new prototype.
	* trans-stmt.h (gfc_trans_block_construct): New prototype.
	* decl.c (gfc_match_end): Handle END BLOCK correctly.
	(gfc_match_intent): Error if inside of BLOCK.
	(gfc_match_optional), (gfc_match_value): Ditto.
	* match.c (gfc_match_block): New routine.
	* parse.c (decode_statement): Handle BLOCK statement.
	(case_exec_markers): Add ST_BLOCK.
	(case_end): Add ST_END_BLOCK.
	(gfc_ascii_statement): Handle ST_BLOCK and ST_END_BLOCK.
	(parse_spec): Check for statements not allowed inside of BLOCK.
	(parse_block_construct): New routine.
	(parse_executable): Parse BLOCKs.
	(parse_progunit): Disallow CONTAINS in BLOCK constructs.
	* resolve.c (is_illegal_recursion): Find real container procedure and
	don't get confused by BLOCK constructs.
	(resolve_block_construct): New routine.
	(gfc_resolve_blocks), (resolve_code): Handle EXEC_BLOCK.
	* st.c (gfc_free_statement): Handle EXEC_BLOCK statements.
	* trans-decl.c (saved_local_decls): New static variable.
	(add_decl_as_local): New routine.
	(gfc_finish_var_decl): Add variable as local if inside BLOCK.
	(gfc_trans_deferred_vars): Make public.
	(gfc_process_block_locals): New routine.
	* trans-stmt.c (gfc_trans_block_construct): New routine.
	* trans.c (gfc_trans_code): Handle EXEC_BLOCK statements.

2009-09-29  Daniel Kraft  <d@domob.eu>

	PR fortran/39626
	* gfortran.dg/block_1.f08: New test.
	* gfortran.dg/block_2.f08: New test.
	* gfortran.dg/block_3.f90: New test.
	* gfortran.dg/block_4.f08: New test.
	* gfortran.dg/block_5.f08: New test.
	* gfortran.dg/block_6.f08: New test.
	* gfortran.dg/block_7.f08: New test.
	* gfortran.dg/block_8.f08: New test.

From-SVN: r152266

1 files changed, 98 insertions, 11 deletions

diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 93a6cfd..e6b5dbb 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -289,7 +289,7 @@ decode_statement (void)
   gfc_undo_symbols ();
   gfc_current_locus = old_locus;
 
-  /* Check for the IF, DO, SELECT, WHERE and FORALL statements, which
+  /* Check for the IF, DO, SELECT, WHERE, FORALL and BLOCK statements, which
      might begin with a block label.  The match functions for these
      statements are unusual in that their keyword is not seen before
      the matcher is called.  */
@@ -309,6 +309,7 @@ decode_statement (void)
   gfc_undo_symbols ();
   gfc_current_locus = old_locus;
 
+  match (NULL, gfc_match_block, ST_BLOCK);
   match (NULL, gfc_match_do, ST_DO);
   match (NULL, gfc_match_select, ST_SELECT_CASE);
 
@@ -933,7 +934,8 @@ next_statement (void)
 
 /* Statements that mark other executable statements.  */
 
-#define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: case ST_IF_BLOCK: \
+#define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \
+  case ST_IF_BLOCK: case ST_BLOCK: \
   case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_OMP_PARALLEL: \
   case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
   case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
@@ -952,7 +954,8 @@ next_statement (void)
    are detected in gfc_match_end().  */
 
 #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
-		 case ST_END_PROGRAM: case ST_END_SUBROUTINE
+		 case ST_END_PROGRAM: case ST_END_SUBROUTINE: \
+		 case ST_END_BLOCK
 
 
 /* Push a new state onto the stack.  */
@@ -1142,6 +1145,9 @@ gfc_ascii_statement (gfc_statement st)
     case ST_BACKSPACE:
       p = "BACKSPACE";
       break;
+    case ST_BLOCK:
+      p = "BLOCK";
+      break;
     case ST_BLOCK_DATA:
       p = "BLOCK DATA";
       break;
@@ -1190,6 +1196,9 @@ gfc_ascii_statement (gfc_statement st)
     case ST_ELSEWHERE:
       p = "ELSEWHERE";
       break;
+    case ST_END_BLOCK:
+      p = "END BLOCK";
+      break;
     case ST_END_BLOCK_DATA:
       p = "END BLOCK DATA";
       break;
@@ -2391,6 +2400,27 @@ parse_spec (gfc_statement st)
     }
 
 loop:
+
+  /* If we're inside a BLOCK construct, some statements are disallowed.
+     Check this here.  Attribute declaration statements like INTENT, OPTIONAL
+     or VALUE are also disallowed, but they don't have a particular ST_*
+     key so we have to check for them individually in their matcher routine.  */
+  if (gfc_current_state () == COMP_BLOCK)
+    switch (st)
+      {
+	case ST_IMPLICIT:
+	case ST_IMPLICIT_NONE:
+	case ST_NAMELIST:
+	case ST_COMMON:
+	case ST_EQUIVALENCE:
+	case ST_STATEMENT_FUNCTION:
+	  gfc_error ("%s statement is not allowed inside of BLOCK at %C",
+		     gfc_ascii_statement (st));
+	  break;
+
+	default:
+	  break;
+      }
   
   /* If we find a statement that can not be followed by an IMPLICIT statement
      (and thus we can expect to see none any further), type the function result
@@ -2908,6 +2938,58 @@ check_do_closure (void)
 }
 
 
+/* Parse a series of contained program units.  */
+
+static void parse_progunit (gfc_statement);
+
+
+/* Parse a BLOCK construct.  */
+
+static void
+parse_block_construct (void)
+{
+  gfc_namespace* parent_ns;
+  gfc_namespace* my_ns;
+  gfc_state_data s;
+
+  gfc_notify_std (GFC_STD_F2008, "Fortran 2008: BLOCK construct at %C");
+
+  parent_ns = gfc_current_ns;
+  my_ns = gfc_get_namespace (parent_ns, 1);
+  my_ns->construct_entities = 1;
+
+  /* Give the BLOCK a symbol of flavor LABEL; this is later needed for correct
+     code generation (so it must not be NULL).
+     We set its recursive argument if our container procedure is recursive, so
+     that local variables are accordingly placed on the stack when it
+     will be necessary.  */
+  if (gfc_new_block)
+    my_ns->proc_name = gfc_new_block;
+  else
+    {
+      gfc_try t;
+
+      gfc_get_symbol ("block@", my_ns, &my_ns->proc_name);
+      t = gfc_add_flavor (&my_ns->proc_name->attr, FL_LABEL,
+			  my_ns->proc_name->name, NULL);
+      gcc_assert (t == SUCCESS);
+    }
+  my_ns->proc_name->attr.recursive = parent_ns->proc_name->attr.recursive;
+
+  new_st.op = EXEC_BLOCK;
+  new_st.ext.ns = my_ns;
+  accept_statement (ST_BLOCK);
+
+  push_state (&s, COMP_BLOCK, my_ns->proc_name);
+  gfc_current_ns = my_ns;
+
+  parse_progunit (ST_NONE);
+
+  gfc_current_ns = parent_ns;
+  pop_state ();
+}
+
+
 /* Parse a DO loop.  Note that the ST_CYCLE and ST_EXIT statements are
    handled inside of parse_executable(), because they aren't really
    loop statements.  */
@@ -3301,6 +3383,10 @@ parse_executable (gfc_statement st)
 	    return ST_IMPLIED_ENDDO;
 	  break;
 
+	case ST_BLOCK:
+	  parse_block_construct ();
+	  break;
+
 	case ST_IF_BLOCK:
 	  parse_if_block ();
 	  break;
@@ -3359,11 +3445,6 @@ parse_executable (gfc_statement st)
 }
 
 
-/* Parse a series of contained program units.  */
-
-static void parse_progunit (gfc_statement);
-
-
 /* Fix the symbols for sibling functions.  These are incorrectly added to
    the child namespace as the parser didn't know about this procedure.  */
 
@@ -3545,7 +3626,7 @@ parse_contained (int module)
 }
 
 
-/* Parse a PROGRAM, SUBROUTINE or FUNCTION unit.  */
+/* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct.  */
 
 static void
 parse_progunit (gfc_statement st)
@@ -3560,7 +3641,10 @@ parse_progunit (gfc_statement st)
       unexpected_eof ();
 
     case ST_CONTAINS:
-      goto contains;
+      /* This is not allowed within BLOCK!  */
+      if (gfc_current_state () != COMP_BLOCK)
+	goto contains;
+      break;
 
     case_end:
       accept_statement (st);
@@ -3584,7 +3668,10 @@ loop:
 	  unexpected_eof ();
 
 	case ST_CONTAINS:
-	  goto contains;
+	  /* This is not allowed within BLOCK!  */
+	  if (gfc_current_state () != COMP_BLOCK)
+	    goto contains;
+	  break;
 
 	case_end:
 	  accept_statement (st);