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

14 files changed, 349 insertions, 36 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 39b96e6..addfcbee 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,41 @@
+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-28  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
 	PR fortran/35862
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 3ce7fd4..cfd8b81 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -5344,8 +5344,8 @@ set_enum_kind(void)
 
 
 /* Match any of the various end-block statements.  Returns the type of
-   END to the caller.  The END INTERFACE, END IF, END DO and END
-   SELECT statements cannot be replaced by a single END statement.  */
+   END to the caller.  The END INTERFACE, END IF, END DO, END SELECT
+   and END BLOCK statements cannot be replaced by a single END statement.  */
 
 match
 gfc_match_end (gfc_statement *st)
@@ -5366,6 +5366,9 @@ gfc_match_end (gfc_statement *st)
   block_name = gfc_current_block () == NULL
 	     ? NULL : gfc_current_block ()->name;
 
+  if (state == COMP_BLOCK && !strcmp (block_name, "block@"))
+    block_name = NULL;
+
   if (state == COMP_CONTAINS || state == COMP_DERIVED_CONTAINS)
     {
       state = gfc_state_stack->previous->state;
@@ -5419,6 +5422,12 @@ gfc_match_end (gfc_statement *st)
       eos_ok = 0;
       break;
 
+    case COMP_BLOCK:
+      *st = ST_END_BLOCK;
+      target = " block";
+      eos_ok = 0;
+      break;
+
     case COMP_IF:
       *st = ST_ENDIF;
       target = " if";
@@ -5488,10 +5497,10 @@ gfc_match_end (gfc_statement *st)
     {
 
       if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT
-	  && *st != ST_END_FORALL && *st != ST_END_WHERE)
+	  && *st != ST_END_FORALL && *st != ST_END_WHERE && *st != ST_END_BLOCK)
 	return MATCH_YES;
 
-      if (gfc_current_block () == NULL)
+      if (!block_name)
 	return MATCH_YES;
 
       gfc_error ("Expected block name of '%s' in %s statement at %C",
@@ -5854,6 +5863,13 @@ gfc_match_intent (void)
 {
   sym_intent intent;
 
+  /* This is not allowed within a BLOCK construct!  */
+  if (gfc_current_state () == COMP_BLOCK)
+    {
+      gfc_error ("INTENT is not allowed inside of BLOCK at %C");
+      return MATCH_ERROR;
+    }
+
   intent = match_intent_spec ();
   if (intent == INTENT_UNKNOWN)
     return MATCH_ERROR;
@@ -5879,6 +5895,12 @@ gfc_match_intrinsic (void)
 match
 gfc_match_optional (void)
 {
+  /* This is not allowed within a BLOCK construct!  */
+  if (gfc_current_state () == COMP_BLOCK)
+    {
+      gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
+      return MATCH_ERROR;
+    }
 
   gfc_clear_attr (&current_attr);
   current_attr.optional = 1;
@@ -6362,6 +6384,13 @@ gfc_match_value (void)
   gfc_symbol *sym;
   match m;
 
+  /* This is not allowed within a BLOCK construct!  */
+  if (gfc_current_state () == COMP_BLOCK)
+    {
+      gfc_error ("VALUE is not allowed inside of BLOCK at %C");
+      return MATCH_ERROR;
+    }
+
   if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VALUE statement at %C")
       == FAILURE)
     return MATCH_ERROR;
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index b6ac254..0dce218 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -206,15 +206,17 @@ arith;
 /* Statements.  */
 typedef enum
 {
-  ST_ARITHMETIC_IF, ST_ALLOCATE, ST_ATTR_DECL, ST_BACKSPACE, ST_BLOCK_DATA,
+  ST_ARITHMETIC_IF, ST_ALLOCATE, ST_ATTR_DECL, ST_BACKSPACE,
+  ST_BLOCK, ST_BLOCK_DATA,
   ST_CALL, ST_CASE, ST_CLOSE, ST_COMMON, ST_CONTINUE, ST_CONTAINS, ST_CYCLE,
   ST_DATA, ST_DATA_DECL, ST_DEALLOCATE, ST_DO, ST_ELSE, ST_ELSEIF,
-  ST_ELSEWHERE, ST_END_BLOCK_DATA, ST_ENDDO, ST_IMPLIED_ENDDO,
+  ST_ELSEWHERE, ST_END_BLOCK, ST_END_BLOCK_DATA, ST_ENDDO, ST_IMPLIED_ENDDO,
   ST_END_FILE, ST_FINAL, ST_FLUSH, ST_END_FORALL, ST_END_FUNCTION, ST_ENDIF,
   ST_END_INTERFACE, ST_END_MODULE, ST_END_PROGRAM, ST_END_SELECT,
   ST_END_SUBROUTINE, ST_END_WHERE, ST_END_TYPE, ST_ENTRY, ST_EQUIVALENCE,
   ST_EXIT, ST_FORALL, ST_FORALL_BLOCK, ST_FORMAT, ST_FUNCTION, ST_GOTO,
-  ST_IF_BLOCK, ST_IMPLICIT, ST_IMPLICIT_NONE, ST_IMPORT, ST_INQUIRE, ST_INTERFACE,
+  ST_IF_BLOCK, ST_IMPLICIT, ST_IMPLICIT_NONE, ST_IMPORT,
+  ST_INQUIRE, ST_INTERFACE,
   ST_PARAMETER, ST_MODULE, ST_MODULE_PROC, ST_NAMELIST, ST_NULLIFY, ST_OPEN,
   ST_PAUSE, ST_PRIVATE, ST_PROGRAM, ST_PUBLIC, ST_READ, ST_RETURN, ST_REWIND,
   ST_STOP, ST_SUBROUTINE, ST_TYPE, ST_USE, ST_WHERE_BLOCK, ST_WHERE, ST_WAIT, 
@@ -1278,8 +1280,8 @@ gfc_dt_list;
   /* A list of all derived types.  */
   extern gfc_dt_list *gfc_derived_types;
 
-/* A namespace describes the contents of procedure, module or
-   interface block.  */
+/* A namespace describes the contents of procedure, module, interface block
+   or BLOCK construct.  */
 /* ??? Anything else use these?  */
 
 typedef struct gfc_namespace
@@ -1357,16 +1359,20 @@ typedef struct gfc_namespace
   gfc_use_list *use_stmts;
 
   /* Set to 1 if namespace is a BLOCK DATA program unit.  */
-  int is_block_data;
+  unsigned is_block_data:1;
 
   /* Set to 1 if namespace is an interface body with "IMPORT" used.  */
-  int has_import_set;
+  unsigned has_import_set:1;
 
   /* Set to 1 if resolved has been called for this namespace.  */
-  int resolved;
+  unsigned resolved:1;
 
   /* Set to 1 if code has been generated for this namespace.  */
-  int translated;
+  unsigned translated:1;
+
+  /* Set to 1 if symbols in this namespace should be 'construct entities',
+     i.e. for BLOCK local variables.  */
+  unsigned construct_entities:1;
 }
 gfc_namespace;
 
@@ -1964,7 +1970,7 @@ typedef enum
   EXEC_POINTER_ASSIGN,
   EXEC_GOTO, EXEC_CALL, EXEC_COMPCALL, EXEC_ASSIGN_CALL, EXEC_RETURN,
   EXEC_ENTRY, EXEC_PAUSE, EXEC_STOP, EXEC_CONTINUE, EXEC_INIT_ASSIGN,
-  EXEC_IF, EXEC_ARITHMETIC_IF, EXEC_DO, EXEC_DO_WHILE, EXEC_SELECT,
+  EXEC_IF, EXEC_ARITHMETIC_IF, EXEC_DO, EXEC_DO_WHILE, EXEC_SELECT, EXEC_BLOCK,
   EXEC_FORALL, EXEC_WHERE, EXEC_CYCLE, EXEC_EXIT, EXEC_CALL_PPC,
   EXEC_ALLOCATE, EXEC_DEALLOCATE, EXEC_END_PROCEDURE,
   EXEC_OPEN, EXEC_CLOSE, EXEC_WAIT,
@@ -2015,6 +2021,7 @@ typedef struct gfc_code
     const char *omp_name;
     gfc_namelist *omp_namelist;
     bool omp_bool;
+    gfc_namespace *ns;
   }
   ext;		/* Points to additional structures required by statement */
 
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index ccd1071..919d5d1 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -1705,6 +1705,30 @@ gfc_free_iterator (gfc_iterator *iter, int flag)
 }
 
 
+/* Match a BLOCK statement.  */
+
+match
+gfc_match_block (void)
+{
+  match m;
+
+  if (gfc_match_label () == MATCH_ERROR)
+    return MATCH_ERROR;
+
+  if (gfc_match (" block") != MATCH_YES)
+    return MATCH_NO;
+
+  /* For this to be a correct BLOCK statement, the line must end now.  */
+  m = gfc_match_eos ();
+  if (m == MATCH_ERROR)
+    return MATCH_ERROR;
+  if (m == MATCH_NO)
+    return MATCH_NO;
+
+  return MATCH_YES;
+}
+
+
 /* Match a DO statement.  */
 
 match
diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index 196115c..a53c7f0 100644
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -69,6 +69,7 @@ match gfc_match_assignment (void);
 match gfc_match_if (gfc_statement *);
 match gfc_match_else (void);
 match gfc_match_elseif (void);
+match gfc_match_block (void);
 match gfc_match_do (void);
 match gfc_match_cycle (void);
 match gfc_match_exit (void);
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);
diff --git a/gcc/fortran/parse.h b/gcc/fortran/parse.h
index 7fe2330..7239c38 100644
--- a/gcc/fortran/parse.h
+++ b/gcc/fortran/parse.h
@@ -29,7 +29,8 @@ along with GCC; see the file COPYING3.  If not see
 typedef enum
 {
   COMP_NONE, COMP_PROGRAM, COMP_MODULE, COMP_SUBROUTINE, COMP_FUNCTION,
-  COMP_BLOCK_DATA, COMP_INTERFACE, COMP_DERIVED, COMP_DERIVED_CONTAINS, COMP_IF,
+  COMP_BLOCK_DATA, COMP_INTERFACE, COMP_DERIVED, COMP_DERIVED_CONTAINS,
+  COMP_BLOCK, COMP_IF,
   COMP_DO, COMP_SELECT, COMP_FORALL, COMP_WHERE, COMP_CONTAINS, COMP_ENUM,
   COMP_OMP_STRUCTURED_BLOCK
 }
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index f208f40..3eec50e 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -1101,6 +1101,7 @@ is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
 {
   gfc_symbol* proc_sym;
   gfc_symbol* context_proc;
+  gfc_namespace* real_context;
 
   gcc_assert (sym->attr.flavor == FL_PROCEDURE);
 
@@ -1114,11 +1115,29 @@ is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
   if (proc_sym->attr.recursive || gfc_option.flag_recursive)
     return false;
 
-  /* Find the context procdure's "real" symbol if it has entries.  */
-  context_proc = (context->entries ? context->entries->sym
-				   : context->proc_name);
-  if (!context_proc)
-    return true;
+  /* Find the context procedure's "real" symbol if it has entries.
+     We look for a procedure symbol, so recurse on the parents if we don't
+     find one (like in case of a BLOCK construct).  */
+  for (real_context = context; ; real_context = real_context->parent)
+    {
+      /* We should find something, eventually!  */
+      gcc_assert (real_context);
+
+      context_proc = (real_context->entries ? real_context->entries->sym
+					    : real_context->proc_name);
+
+      /* In some special cases, there may not be a proc_name, like for this
+	 invalid code:
+	 real(bad_kind()) function foo () ...
+	 when checking the call to bad_kind ().
+	 In these cases, we simply return here and assume that the
+	 call is ok.  */
+      if (!context_proc)
+	return false;
+
+      if (context_proc->attr.flavor != FL_LABEL)
+	break;
+    }
 
   /* A call from sym's body to itself is recursion, of course.  */
   if (context_proc == proc_sym)
@@ -6838,7 +6857,19 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
 }
 
 
-/* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
+/* Resolve a BLOCK construct statement.  */
+
+static void
+resolve_block_construct (gfc_code* code)
+{
+  /* Eventually, we may want to do some checks here or handle special stuff.
+     But so far the only thing we can do is resolving the local namespace.  */
+
+  gfc_resolve (code->ext.ns);
+}
+
+
+/* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
    DO code nodes.  */
 
 static void resolve_code (gfc_code *, gfc_namespace *);
@@ -6875,6 +6906,10 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
 	  resolve_branch (b->label1, b);
 	  break;
 
+	case EXEC_BLOCK:
+	  resolve_block_construct (b);
+	  break;
+
 	case EXEC_SELECT:
 	case EXEC_FORALL:
 	case EXEC_DO:
@@ -6902,7 +6937,7 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
 	  break;
 
 	default:
-	  gfc_internal_error ("resolve_block(): Bad block type");
+	  gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
 	}
 
       resolve_code (b->next, ns);
@@ -7066,6 +7101,7 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
   return false;
 }
 
+
 /* Given a block of code, recursively resolve everything pointed to by this
    code block.  */
 
@@ -7250,7 +7286,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
 	  break;
 
 	case EXEC_CALL_PPC:
-          resolve_ppc_call (code);
+	  resolve_ppc_call (code);
 	  break;
 
 	case EXEC_SELECT:
@@ -7259,6 +7295,10 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
 	  resolve_select (code);
 	  break;
 
+	case EXEC_BLOCK:
+	  gfc_resolve (code->ext.ns);
+	  break;
+
 	case EXEC_DO:
 	  if (code->ext.iterator != NULL)
 	    {
diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c
index d77ef81..c3c640a 100644
--- a/gcc/fortran/st.c
+++ b/gcc/fortran/st.c
@@ -110,6 +110,10 @@ gfc_free_statement (gfc_code *p)
     case EXEC_ARITHMETIC_IF:
       break;
 
+    case EXEC_BLOCK:
+      gfc_free_namespace (p->ext.ns);
+      break;
+
     case EXEC_COMPCALL:
     case EXEC_CALL_PPC:
     case EXEC_CALL:
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 4e72a23..3d6a5e2 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -64,6 +64,10 @@ static GTY(()) tree saved_parent_function_decls;
 static struct pointer_set_t *nonlocal_dummy_decl_pset;
 static GTY(()) tree nonlocal_dummy_decls;
 
+/* Holds the variable DECLs that are locals.  */
+
+static GTY(()) tree saved_local_decls;
+
 /* The namespace of the module we're currently generating.  Only used while
    outputting decls for module variables.  Do not rely on this being set.  */
 
@@ -180,6 +184,16 @@ gfc_add_decl_to_function (tree decl)
   saved_function_decls = decl;
 }
 
+static void
+add_decl_as_local (tree decl)
+{
+  gcc_assert (decl);
+  TREE_USED (decl) = 1;
+  DECL_CONTEXT (decl) = current_function_decl;
+  TREE_CHAIN (decl) = saved_local_decls;
+  saved_local_decls = decl;
+}
+
 
 /* Build a  backend label declaration.  Set TREE_USED for named labels.
    The context of the label is always the current_function_decl.  All
@@ -504,8 +518,11 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym)
   if (current_function_decl != NULL_TREE)
     {
       if (sym->ns->proc_name->backend_decl == current_function_decl
-          || sym->result == sym)
+	  || sym->result == sym)
 	gfc_add_decl_to_function (decl);
+      else if (sym->ns->proc_name->attr.flavor == FL_LABEL)
+	/* This is a BLOCK construct.  */
+	add_decl_as_local (decl);
       else
 	gfc_add_decl_to_parent_function (decl);
     }
@@ -3036,7 +3053,7 @@ init_intent_out_dt (gfc_symbol * proc_sym, tree body)
     Initialization and possibly repacking of dummy arrays.
     Initialization of ASSIGN statement auxiliary variable.  */
 
-static tree
+tree
 gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
 {
   locus loc;
@@ -4552,4 +4569,28 @@ gfc_generate_block_data (gfc_namespace * ns)
 }
 
 
+/* Process the local variables of a BLOCK construct.  */
+
+void
+gfc_process_block_locals (gfc_namespace* ns)
+{
+  tree decl;
+
+  gcc_assert (saved_local_decls == NULL_TREE);
+  generate_local_vars (ns);
+
+  decl = saved_local_decls;
+  while (decl)
+    {
+      tree next;
+
+      next = TREE_CHAIN (decl);
+      TREE_CHAIN (decl) = NULL_TREE;
+      pushdecl (decl);
+      decl = next;
+    }
+  saved_local_decls = NULL_TREE;
+}
+
+
 #include "gt-fortran-trans-decl.h"
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 6aed99b..25a5b3b 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -756,6 +756,36 @@ gfc_trans_arithmetic_if (gfc_code * code)
 }
 
 
+/* Translate a BLOCK construct.  This is basically what we would do for a
+   procedure body.  */
+
+tree
+gfc_trans_block_construct (gfc_code* code)
+{
+  gfc_namespace* ns;
+  gfc_symbol* sym;
+  stmtblock_t body;
+  tree tmp;
+
+  ns = code->ext.ns;
+  gcc_assert (ns);
+  sym = ns->proc_name;
+  gcc_assert (sym);
+
+  gcc_assert (!sym->tlink);
+  sym->tlink = sym;
+
+  gfc_start_block (&body);
+  gfc_process_block_locals (ns);
+
+  tmp = gfc_trans_code (ns->code);
+  tmp = gfc_trans_deferred_vars (sym, tmp);
+
+  gfc_add_expr_to_block (&body, tmp);
+  return gfc_finish_block (&body);
+}
+
+
 /* Translate the simple DO construct.  This is where the loop variable has
    integer type and step +-1.  We can't use this in the general case
    because integer overflow and floating point errors could give incorrect
diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h
index d7307df..0b8461c 100644
--- a/gcc/fortran/trans-stmt.h
+++ b/gcc/fortran/trans-stmt.h
@@ -43,6 +43,7 @@ tree gfc_trans_call (gfc_code *, bool, tree, tree, bool);
 tree gfc_trans_return (gfc_code *);
 tree gfc_trans_if (gfc_code *);
 tree gfc_trans_arithmetic_if (gfc_code *);
+tree gfc_trans_block_construct (gfc_code *);
 tree gfc_trans_do (gfc_code *);
 tree gfc_trans_do_while (gfc_code *);
 tree gfc_trans_select (gfc_code *);
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 136987a..f53f75e 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -1157,6 +1157,10 @@ gfc_trans_code (gfc_code * code)
 	  res = gfc_trans_arithmetic_if (code);
 	  break;
 
+	case EXEC_BLOCK:
+	  res = gfc_trans_block_construct (code);
+	  break;
+
 	case EXEC_DO:
 	  res = gfc_trans_do (code);
 	  break;
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 4469023..27b040a 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -498,6 +498,12 @@ void gfc_build_io_library_fndecls (void);
 /* Build a function decl for a library function.  */
 tree gfc_build_library_function_decl (tree, tree, int, ...);
 
+/* Process the local variable decls of a block construct.  */
+void gfc_process_block_locals (gfc_namespace*);
+
+/* Output initialization/clean-up code that was deferred.  */
+tree gfc_trans_deferred_vars (gfc_symbol*, tree);
+
 /* somewhere! */
 tree pushdecl (tree);
 tree pushdecl_top_level (tree);