[gcc] GCC 4.5.0=>4.5.1

gcc/gcc/fortran/parse.c

Index: gcc/gcc/fortran/parse.c
diff --git a/gcc/gcc/fortran/parse.c b/gcc/gcc/fortran/parse.c
index 64272e2a51eec6da41af4dd437202d8f130d8ee4..63814dadc80278cc02d77435375b1ba6c7a53d28 100644
--- a/gcc/gcc/fortran/parse.c
+++ b/gcc/gcc/fortran/parse.c
@@ -1,5 +1,6 @@
 /* Main parser.
-   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
+   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+   2009, 2010
    Free Software Foundation, Inc.
    Contributed by Andy Vaught
 
@@ -110,7 +111,7 @@ decode_specification_statement (void)
   match ("import", gfc_match_import, ST_IMPORT);
   match ("use", gfc_match_use, ST_USE);
 
-  if (gfc_current_block ()->ts.type != BT_DERIVED)
+  if (gfc_current_block ()->result->ts.type != BT_DERIVED)
     goto end_of_block;
 
   match (NULL, gfc_match_st_function, ST_STATEMENT_FUNCTION);
@@ -128,6 +129,8 @@ decode_specification_statement (void)
     case 'a':
       match ("abstract% interface", gfc_match_abstract_interface,
 	     ST_INTERFACE);
+      match ("allocatable", gfc_match_asynchronous, ST_ATTR_DECL);
+      match ("asynchronous", gfc_match_asynchronous, ST_ATTR_DECL);
       break;
 
     case 'b':
@@ -288,7 +291,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.  */
@@ -308,8 +311,10 @@ 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);
+  match (NULL, gfc_match_select_type, ST_SELECT_TYPE);
 
   /* General statement matching: Instead of testing every possible
      statement, we eliminate most possibilities by peeking at the
@@ -325,6 +330,7 @@ decode_statement (void)
       match ("allocate", gfc_match_allocate, ST_ALLOCATE);
       match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL);
       match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT);
+      match ("asynchronous", gfc_match_asynchronous, ST_ATTR_DECL);
       break;
 
     case 'b':
@@ -341,6 +347,7 @@ decode_statement (void)
       match ("case", gfc_match_case, ST_CASE);
       match ("common", gfc_match_common, ST_COMMON);
       match ("contains", gfc_match_eos, ST_CONTAINS);
+      match ("class", gfc_match_class_is, ST_CLASS_IS);
       break;
 
     case 'd':
@@ -430,6 +437,7 @@ decode_statement (void)
     case 't':
       match ("target", gfc_match_target, ST_ATTR_DECL);
       match ("type", gfc_match_derived_decl, ST_DERIVED_DECL);
+      match ("type is", gfc_match_type_is, ST_TYPE_IS);
       break;
 
     case 'u':
@@ -565,6 +573,34 @@ decode_omp_directive (void)
   return ST_NONE;
 }
 
+static gfc_statement
+decode_gcc_attribute (void)
+{
+  locus old_locus;
+
+#ifdef GFC_DEBUG
+  gfc_symbol_state ();
+#endif
+
+  gfc_clear_error ();	/* Clear any pending errors.  */
+  gfc_clear_warning ();	/* Clear any pending warnings.  */
+  old_locus = gfc_current_locus;
+
+  match ("attributes", gfc_match_gcc_attributes, ST_ATTR_DECL);
+
+  /* All else has failed, so give up.  See if any of the matchers has
+     stored an error message of some sort.  */
+
+  if (gfc_error_check () == 0)
+    gfc_error_now ("Unclassifiable GCC directive at %C");
+
+  reject_statement ();
+
+  gfc_error_recovery ();
+
+  return ST_NONE;
+}
+
 #undef match
 
 
@@ -626,7 +662,7 @@ next_free (void)
 	  if (gfc_match_eos () == MATCH_YES)
 	    {
 	      gfc_warning_now ("Ignoring statement label in empty statement "
-			       "at %C");
+			       "at %L", &label_locus);
 	      gfc_free_st_label (gfc_statement_label);
 	      gfc_statement_label = NULL;
 	      return ST_NONE;
@@ -636,21 +672,39 @@ next_free (void)
   else if (c == '!')
     {
       /* Comments have already been skipped by the time we get here,
-	 except for OpenMP directives.  */
-      if (gfc_option.flag_openmp)
+	 except for GCC attributes and OpenMP directives.  */
+
+      gfc_next_ascii_char (); /* Eat up the exclamation sign.  */
+      c = gfc_peek_ascii_char ();
+
+      if (c == 'g')
+	{
+	  int i;
+
+	  c = gfc_next_ascii_char ();
+	  for (i = 0; i < 4; i++, c = gfc_next_ascii_char ())
+	    gcc_assert (c == "gcc$"[i]);
+
+	  gfc_gobble_whitespace ();
+	  return decode_gcc_attribute ();
+
+	}
+      else if (c == '$' && gfc_option.flag_openmp)
 	{
 	  int i;
 
 	  c = gfc_next_ascii_char ();
-	  for (i = 0; i < 5; i++, c = gfc_next_ascii_char ())
-	    gcc_assert (c == "!$omp"[i]);
+	  for (i = 0; i < 4; i++, c = gfc_next_ascii_char ())
+	    gcc_assert (c == "$omp"[i]);
 
 	  gcc_assert (c == ' ' || c == '\t');
 	  gfc_gobble_whitespace ();
 	  return decode_omp_directive ();
 	}
-    }
 
+      gcc_unreachable (); 
+    }
+ 
   if (at_bol && c == ';')
     {
       gfc_error_now ("Semicolon at %C needs to be preceded by statement");
@@ -708,12 +762,22 @@ next_fixed (void)
 	  break;
 
 	  /* Comments have already been skipped by the time we get
-	     here, except for OpenMP directives.  */
+	     here, except for GCC attributes and OpenMP directives.  */
+
 	case '*':
-	  if (gfc_option.flag_openmp)
+	  c = gfc_next_char_literal (0);
+	  
+	  if (TOLOWER (c) == 'g')
 	    {
-	      for (i = 0; i < 5; i++, c = gfc_next_char_literal (0))
-		gcc_assert ((char) gfc_wide_tolower (c) == "*$omp"[i]);
+	      for (i = 0; i < 4; i++, c = gfc_next_char_literal (0))
+		gcc_assert (TOLOWER (c) == "gcc$"[i]);
+
+	      return decode_gcc_attribute ();
+	    }
+	  else if (c == '$' && gfc_option.flag_openmp)
+	    {
+	      for (i = 0; i < 4; i++, c = gfc_next_char_literal (0))
+		gcc_assert ((char) gfc_wide_tolower (c) == "$omp"[i]);
 
 	      if (c != ' ' && c != '0')
 		{
@@ -791,7 +855,10 @@ next_fixed (void)
 
 blank_line:
   if (digit_flag)
-    gfc_warning ("Ignoring statement label in empty statement at %C");
+    gfc_warning_now ("Ignoring statement label in empty statement at %L",
+		     &label_locus);
+    
+  gfc_current_locus.lb->truncated = 0;
   gfc_advance_line ();
   return ST_NONE;
 }
@@ -805,6 +872,7 @@ next_statement (void)
 {
   gfc_statement st;
   locus old_locus;
+
   gfc_new_block = NULL;
 
   gfc_current_ns->old_cl_list = gfc_current_ns->cl_list;
@@ -814,14 +882,7 @@ next_statement (void)
       gfc_buffer_error (1);
 
       if (gfc_at_eol ())
-	{
-	  if ((gfc_option.warn_line_truncation || gfc_current_form == FORM_FREE)
-	      && gfc_current_locus.lb
-	      && gfc_current_locus.lb->truncated)
-	    gfc_warning_now ("Line truncated at %C");
-
-	  gfc_advance_line ();
-	}
+	gfc_advance_line ();
 
       gfc_skip_comments ();
 
@@ -879,8 +940,10 @@ next_statement (void)
 
 /* Statements that mark other executable statements.  */
 
-#define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: case ST_IF_BLOCK: \
-  case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_OMP_PARALLEL: \
+#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_SELECT_TYPE: \
+  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: \
   case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
@@ -898,7 +961,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.  */
@@ -1088,6 +1152,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;
@@ -1136,6 +1203,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;
@@ -1297,6 +1367,15 @@ gfc_ascii_statement (gfc_statement st)
     case ST_SELECT_CASE:
       p = "SELECT CASE";
       break;
+    case ST_SELECT_TYPE:
+      p = "SELECT TYPE";
+      break;
+    case ST_TYPE_IS:
+      p = "TYPE IS";
+      break;
+    case ST_CLASS_IS:
+      p = "CLASS IS";
+      break;
     case ST_SEQUENCE:
       p = "SEQUENCE";
       break;
@@ -1464,16 +1543,23 @@ accept_statement (gfc_statement st)
 
       /* If the statement is the end of a block, lay down a special code
 	 that allows a branch to the end of the block from within the
-	 construct.  */
+	 construct.  IF and SELECT are treated differently from DO
+	 (where EXEC_NOP is added inside the loop) for two
+	 reasons:
+         1. END DO has a meaning in the sense that after a GOTO to
+	    it, the loop counter must be increased.
+         2. IF blocks and SELECT blocks can consist of multiple
+	    parallel blocks (IF ... ELSE IF ... ELSE ... END IF).
+	    Putting the label before the END IF would make the jump
+	    from, say, the ELSE IF block to the END IF illegal.  */
 
     case ST_ENDIF:
     case ST_END_SELECT:
       if (gfc_statement_label != NULL)
 	{
-	  new_st.op = EXEC_NOP;
+	  new_st.op = EXEC_END_BLOCK;
 	  add_statement ();
 	}
-
       break;
 
       /* The end-of-program unit statements do not get the special
@@ -1488,6 +1574,11 @@ accept_statement (gfc_statement st)
 	  new_st.op = EXEC_RETURN;
 	  add_statement ();
 	}
+      else
+	{
+	  new_st.op = EXEC_END_PROCEDURE;
+	  add_statement ();
+	}
 
       break;
 
@@ -1572,13 +1663,20 @@ unexpected_statement (gfc_statement st)
 
 */
 
+enum state_order
+{
+  ORDER_START,
+  ORDER_USE,
+  ORDER_IMPORT,
+  ORDER_IMPLICIT_NONE,
+  ORDER_IMPLICIT,
+  ORDER_SPEC,
+  ORDER_EXEC
+};
+
 typedef struct
 {
-  enum
-  { ORDER_START, ORDER_USE, ORDER_IMPORT, ORDER_IMPLICIT_NONE,
-    ORDER_IMPLICIT, ORDER_SPEC, ORDER_EXEC
-  }
-  state;
+  enum state_order state;
   gfc_statement last_statement;
   locus where;
 }
@@ -1845,7 +1943,6 @@ parse_derived (void)
   int compiling_type, seen_private, seen_sequence, seen_component, error_flag;
   gfc_statement st;
   gfc_state_data s;
-  gfc_symbol *derived_sym = NULL;
   gfc_symbol *sym;
   gfc_component *c;
 
@@ -1870,15 +1967,11 @@ parse_derived (void)
 	  unexpected_eof ();
 
 	case ST_DATA_DECL:
+	case ST_PROCEDURE:
 	  accept_statement (st);
 	  seen_component = 1;
 	  break;
 
-	case ST_PROCEDURE:
-	  gfc_error ("PROCEDURE binding at %C must be inside CONTAINS");
-	  error_flag = 1;
-	  break;
-
 	case ST_FINAL:
 	  gfc_error ("FINAL declaration at %C must be inside CONTAINS");
 	  error_flag = 1;
@@ -1970,25 +2063,33 @@ endType:
   /* need to verify that all fields of the derived type are
    * interoperable with C if the type is declared to be bind(c)
    */
-  derived_sym = gfc_current_block();
-
   sym = gfc_current_block ();
   for (c = sym->components; c; c = c->next)
     {
       /* Look for allocatable components.  */
       if (c->attr.allocatable
-	  || (c->ts.type == BT_DERIVED && c->ts.derived->attr.alloc_comp))
+	  || (c->ts.type == BT_CLASS
+	      && c->ts.u.derived->components->attr.allocatable)
+	  || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.alloc_comp))
 	sym->attr.alloc_comp = 1;
 
       /* Look for pointer components.  */
       if (c->attr.pointer
-	  || (c->ts.type == BT_DERIVED && c->ts.derived->attr.pointer_comp))
+	  || (c->ts.type == BT_CLASS
+	      && c->ts.u.derived->components->attr.pointer)
+	  || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pointer_comp))
 	sym->attr.pointer_comp = 1;
 
+      /* Look for procedure pointer components.  */
+      if (c->attr.proc_pointer
+	  || (c->ts.type == BT_DERIVED
+	      && c->ts.u.derived->attr.proc_pointer_comp))
+	sym->attr.proc_pointer_comp = 1;
+
       /* Look for private components.  */
       if (sym->component_access == ACCESS_PRIVATE
 	  || c->attr.access == ACCESS_PRIVATE
-	  || (c->ts.type == BT_DERIVED && c->ts.derived->attr.private_comp))
+	  || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.private_comp))
 	sym->attr.private_comp = 1;
     }
 
@@ -2105,14 +2206,6 @@ loop:
 	  gfc_free_namespace (gfc_current_ns);
 	  goto loop;
 	}
-      if (current_interface.type != INTERFACE_ABSTRACT &&
-	 !gfc_new_block->attr.dummy &&
-	 gfc_add_external (&gfc_new_block->attr, &gfc_current_locus) == FAILURE)
-	{
-	  reject_statement ();
-	  gfc_free_namespace (gfc_current_ns);
-	  goto loop;
-	}
       break;
 
     case ST_PROCEDURE:
@@ -2142,9 +2235,9 @@ loop:
     {
       if (current_state == COMP_NONE)
 	{
-	  if (new_state == COMP_FUNCTION)
+	  if (new_state == COMP_FUNCTION && sym)
 	    gfc_add_function (&sym->attr, sym->name, NULL);
-	  else if (new_state == COMP_SUBROUTINE)
+	  else if (new_state == COMP_SUBROUTINE && sym)
 	    gfc_add_subroutine (&sym->attr, sym->name, NULL);
 
 	  current_state = new_state;
@@ -2205,6 +2298,10 @@ decl:
       goto decl;
     }
 
+  /* Add EXTERNAL attribute to function or subroutine.  */
+  if (current_interface.type != INTERFACE_ABSTRACT && !prog_unit->attr.dummy)
+    gfc_add_external (&prog_unit->attr, &gfc_current_locus);
+
   current_interface = save;
   gfc_add_interface (prog_unit);
   pop_state ();
@@ -2246,7 +2343,7 @@ match_deferred_characteristics (gfc_typespec * ts)
     {
       ts->kind = 0;
 
-      if (!ts->derived || !ts->derived->components)
+      if (!ts->u.derived)
 	m = MATCH_ERROR;
     }
 
@@ -2286,8 +2383,8 @@ check_function_result_typed (void)
 
   /* Check type-parameters, at the moment only CHARACTER lengths possible.  */
   /* TODO:  Extend when KIND type parameters are implemented.  */
-  if (ts->type == BT_CHARACTER && ts->cl && ts->cl->length)
-    gfc_expr_check_typed (ts->cl->length, gfc_current_ns, true);
+  if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length)
+    gfc_expr_check_typed (ts->u.cl->length, gfc_current_ns, true);
 }
 
 
@@ -2320,6 +2417,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
@@ -2466,7 +2584,7 @@ declSt:
 
       gfc_current_block ()->ts.kind = 0;
       /* Keep the derived type; if it's bad, it will be discovered later.  */
-      if (!(ts->type == BT_DERIVED && ts->derived))
+      if (!(ts->type == BT_DERIVED && ts->u.derived))
 	ts->type = BT_UNKNOWN;
     }
 
@@ -2490,10 +2608,10 @@ parse_where_block (void)
   push_state (&s, COMP_WHERE, gfc_new_block);
 
   d = add_statement ();
-  d->expr = top->expr;
+  d->expr1 = top->expr1;
   d->op = EXEC_WHERE;
 
-  top->expr = NULL;
+  top->expr1 = NULL;
   top->block = d;
 
   seen_empty_else = 0;
@@ -2523,12 +2641,12 @@ parse_where_block (void)
 	      break;
 	    }
 
-	  if (new_st.expr == NULL)
+	  if (new_st.expr1 == NULL)
 	    seen_empty_else = 1;
 
 	  d = new_level (gfc_state_stack->head);
 	  d->op = EXEC_WHERE;
-	  d->expr = new_st.expr;
+	  d->expr1 = new_st.expr1;
 
 	  accept_statement (st);
 
@@ -2633,8 +2751,8 @@ parse_if_block (void)
   new_st.op = EXEC_IF;
   d = add_statement ();
 
-  d->expr = top->expr;
-  top->expr = NULL;
+  d->expr1 = top->expr1;
+  top->expr1 = NULL;
   top->block = d;
 
   do
@@ -2658,7 +2776,7 @@ parse_if_block (void)
 
 	  d = new_level (gfc_state_stack->head);
 	  d->op = EXEC_IF;
-	  d->expr = new_st.expr;
+	  d->expr1 = new_st.expr1;
 
 	  accept_statement (st);
 
@@ -2773,6 +2891,93 @@ parse_select_block (void)
 }
 
 
+/* Pop the current selector from the SELECT TYPE stack.  */
+
+static void
+select_type_pop (void)
+{
+  gfc_select_type_stack *old = select_type_stack;
+  select_type_stack = old->prev;
+  gfc_free (old);
+}
+
+
+/* Parse a SELECT TYPE construct (F03:R821).  */
+
+static void
+parse_select_type_block (void)
+{
+  gfc_statement st;
+  gfc_code *cp;
+  gfc_state_data s;
+
+  accept_statement (ST_SELECT_TYPE);
+
+  cp = gfc_state_stack->tail;
+  push_state (&s, COMP_SELECT_TYPE, gfc_new_block);
+
+  /* Make sure that the next statement is a TYPE IS, CLASS IS, CLASS DEFAULT
+     or END SELECT.  */
+  for (;;)
+    {
+      st = next_statement ();
+      if (st == ST_NONE)
+	unexpected_eof ();
+      if (st == ST_END_SELECT)
+	/* Empty SELECT CASE is OK.  */
+	goto done;
+      if (st == ST_TYPE_IS || st == ST_CLASS_IS)
+	break;
+
+      gfc_error ("Expected TYPE IS, CLASS IS or END SELECT statement "
+		 "following SELECT TYPE at %C");
+
+      reject_statement ();
+    }
+
+  /* At this point, we're got a nonempty select block.  */
+  cp = new_level (cp);
+  *cp = new_st;
+
+  accept_statement (st);
+
+  do
+    {
+      st = parse_executable (ST_NONE);
+      switch (st)
+	{
+	case ST_NONE:
+	  unexpected_eof ();
+
+	case ST_TYPE_IS:
+	case ST_CLASS_IS:
+	  cp = new_level (gfc_state_stack->head);
+	  *cp = new_st;
+	  gfc_clear_new_st ();
+
+	  accept_statement (st);
+	  /* Fall through */
+
+	case ST_END_SELECT:
+	  break;
+
+	/* Can't have an executable statement because of
+	   parse_executable().  */
+	default:
+	  unexpected_statement (st);
+	  break;
+	}
+    }
+  while (st != ST_END_SELECT);
+
+done:
+  pop_state ();
+  accept_statement (st);
+  gfc_current_ns = gfc_current_ns->parent;
+  select_type_pop ();
+}
+
+
 /* Given a symbol, make sure it is not an iteration variable for a DO
    statement.  This subroutine is called when the symbol is seen in a
    context that causes it to become redefined.  If the symbol is an
@@ -2816,7 +3021,6 @@ check_do_closure (void)
 
   if (p->ext.end_do_label == gfc_statement_label)
     {
-
       if (p == gfc_state_stack)
 	return 1;
 
@@ -2838,6 +3042,71 @@ check_do_closure (void)
 }
 
 
+/* Parse a series of contained program units.  */
+
+static void parse_progunit (gfc_statement);
+
+
+/* Set up the local namespace for a BLOCK construct.  */
+
+gfc_namespace*
+gfc_build_block_ns (gfc_namespace *parent_ns)
+{
+  gfc_namespace* my_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);
+    }
+
+  if (parent_ns->proc_name)
+    my_ns->proc_name->attr.recursive = parent_ns->proc_name->attr.recursive;
+
+  return my_ns;
+}
+
+
+/* Parse a BLOCK construct.  */
+
+static void
+parse_block_construct (void)
+{
+  gfc_namespace* my_ns;
+  gfc_state_data s;
+
+  gfc_notify_std (GFC_STD_F2008, "Fortran 2008: BLOCK construct at %C");
+
+  my_ns = gfc_build_block_ns (gfc_current_ns);
+
+  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 = gfc_current_ns->parent;
+  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.  */
@@ -2850,7 +3119,7 @@ parse_do_block (void)
   gfc_state_data s;
   gfc_symtree *stree;
 
-  s.ext.end_do_label = new_st.label;
+  s.ext.end_do_label = new_st.label1;
 
   if (new_st.ext.iterator != NULL)
     stree = new_st.ext.iterator->var->symtree;
@@ -2894,7 +3163,7 @@ loop:
 	name, but in that case we must have seen ST_ENDDO first).
 	We only complain about this in pedantic mode.  */
      if (gfc_current_block () != NULL)
-	gfc_error_now ("named block DO at %L requires matching ENDDO name",
+	gfc_error_now ("Named block DO at %L requires matching ENDDO name",
 		       &gfc_current_block()->declared_at);
 
       break;
@@ -3231,6 +3500,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;
@@ -3239,6 +3512,10 @@ parse_executable (gfc_statement st)
 	  parse_select_block ();
 	  break;
 
+	case ST_SELECT_TYPE:
+	  parse_select_type_block();
+	  break;
+
 	case ST_DO:
 	  parse_do_block ();
 	  if (check_do_closure () == 1)
@@ -3289,11 +3566,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.  */
 
@@ -3307,7 +3579,7 @@ gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings)
   sym->attr.referenced = 1;
   for (ns = siblings; ns; ns = ns->sibling)
     {
-      gfc_find_sym_tree (sym->name, ns, 0, &st);
+      st = gfc_find_symtree (ns->sym_root, sym->name);
 
       if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns))
 	goto fixup_contained;
@@ -3322,6 +3594,7 @@ gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings)
 		  || (old_sym->ts.type != BT_UNKNOWN
 			&& !old_sym->attr.implicit_type)
 		  || old_sym->attr.flavor == FL_PARAMETER
+		  || old_sym->attr.use_assoc
 		  || old_sym->attr.in_common
 		  || old_sym->attr.in_equivalence
 		  || old_sym->attr.data
@@ -3475,7 +3748,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)
@@ -3490,7 +3763,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);
@@ -3514,7 +3790,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);
@@ -3687,6 +3966,8 @@ loop:
       st = next_statement ();
       goto loop;
     }
+
+  s->ns = gfc_current_ns;
 }
 
 
@@ -3708,6 +3989,7 @@ add_global_procedure (int sub)
       s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
       s->where = gfc_current_locus;
       s->defined = 1;
+      s->ns = gfc_current_ns;
     }
 }
 
@@ -3730,7 +4012,78 @@ add_global_program (void)
       s->type = GSYM_PROGRAM;
       s->where = gfc_current_locus;
       s->defined = 1;
+      s->ns = gfc_current_ns;
+    }
+}
+
+
+/* Resolve all the program units when whole file scope option
+   is active. */
+static void
+resolve_all_program_units (gfc_namespace *gfc_global_ns_list)
+{
+  gfc_free_dt_list ();
+  gfc_current_ns = gfc_global_ns_list;
+  for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
+    {
+      gfc_current_locus = gfc_current_ns->proc_name->declared_at;
+      gfc_resolve (gfc_current_ns);
+      gfc_current_ns->derived_types = gfc_derived_types;
+      gfc_derived_types = NULL;
+    }
+}
+
+
+static void
+clean_up_modules (gfc_gsymbol *gsym)
+{
+  if (gsym == NULL)
+    return;
+
+  clean_up_modules (gsym->left);
+  clean_up_modules (gsym->right);
+
+  if (gsym->type != GSYM_MODULE || !gsym->ns)
+    return;
+
+  gfc_current_ns = gsym->ns;
+  gfc_derived_types = gfc_current_ns->derived_types;
+  gfc_done_2 ();
+  gsym->ns = NULL;
+  return;
+}
+
+
+/* Translate all the program units when whole file scope option
+   is active. This could be in a different order to resolution if
+   there are forward references in the file.  */
+static void
+translate_all_program_units (gfc_namespace *gfc_global_ns_list)
+{
+  int errors;
+
+  gfc_current_ns = gfc_global_ns_list;
+  gfc_get_errors (NULL, &errors);
+
+  for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
+    {
+      gfc_current_locus = gfc_current_ns->proc_name->declared_at;
+      gfc_derived_types = gfc_current_ns->derived_types;
+      gfc_generate_code (gfc_current_ns);
+      gfc_current_ns->translated = 1;
+    }
+
+  /* Clean up all the namespaces after translation.  */
+  gfc_current_ns = gfc_global_ns_list;
+  for (;gfc_current_ns;)
+    {
+      gfc_namespace *ns = gfc_current_ns->sibling;
+      gfc_derived_types = gfc_current_ns->derived_types;
+      gfc_done_2 ();
+      gfc_current_ns = ns;
     }
+
+  clean_up_modules (gfc_gsym_root);
 }
 
 
@@ -3743,6 +4096,7 @@ gfc_parse_file (void)
   gfc_state_data top, s;
   gfc_statement st;
   locus prog_locus;
+  gfc_namespace *next;
 
   gfc_start_source_files ();
 
@@ -3761,6 +4115,10 @@ gfc_parse_file (void)
   if (setjmp (eof_buf))
     return FAILURE;	/* Come here on unexpected EOF */
 
+  /* Prepare the global namespace that will contain the
+     program units.  */
+  gfc_global_ns_list = next = NULL;
+
   seen_program = 0;
 
   /* Exit early for empty files.  */
@@ -3787,6 +4145,8 @@ loop:
       accept_statement (st);
       add_global_program ();
       parse_progunit (ST_NONE);
+      if (gfc_option.flag_whole_file)
+	goto prog_units;
       break;
 
     case ST_SUBROUTINE:
@@ -3794,6 +4154,8 @@ loop:
       push_state (&s, COMP_SUBROUTINE, gfc_new_block);
       accept_statement (st);
       parse_progunit (ST_NONE);
+      if (gfc_option.flag_whole_file)
+	goto prog_units;
       break;
 
     case ST_FUNCTION:
@@ -3801,6 +4163,8 @@ loop:
       push_state (&s, COMP_FUNCTION, gfc_new_block);
       accept_statement (st);
       parse_progunit (ST_NONE);
+      if (gfc_option.flag_whole_file)
+	goto prog_units;
       break;
 
     case ST_BLOCK_DATA:
@@ -3827,9 +4191,12 @@ loop:
       push_state (&s, COMP_PROGRAM, gfc_new_block);
       main_program_symbol (gfc_current_ns, "MAIN__");
       parse_progunit (st);
+      if (gfc_option.flag_whole_file)
+	goto prog_units;
       break;
     }
 
+  /* Handle the non-program units.  */
   gfc_current_ns->code = s.head;
 
   gfc_resolve (gfc_current_ns);
@@ -3844,18 +4211,64 @@ loop:
       gfc_dump_module (s.sym->name, errors_before == errors);
       if (errors == 0)
 	gfc_generate_module_code (gfc_current_ns);
+      pop_state ();
+      if (!gfc_option.flag_whole_file)
+	gfc_done_2 ();
+      else
+	{
+	  gfc_current_ns->derived_types = gfc_derived_types;
+	  gfc_derived_types = NULL;
+	  gfc_current_ns = NULL;
+	}
     }
   else
     {
       if (errors == 0)
 	gfc_generate_code (gfc_current_ns);
+      pop_state ();
+      gfc_done_2 ();
     }
 
+  goto loop;
+
+prog_units:
+  /* The main program and non-contained procedures are put
+     in the global namespace list, so that they can be processed
+     later and all their interfaces resolved.  */
+  gfc_current_ns->code = s.head;
+  if (next)
+    next->sibling = gfc_current_ns;
+  else
+    gfc_global_ns_list = gfc_current_ns;
+
+  next = gfc_current_ns;
+
   pop_state ();
-  gfc_done_2 ();
   goto loop;
 
-done:
+  done:
+
+  if (!gfc_option.flag_whole_file)
+    goto termination;
+
+  /* Do the resolution.  */
+  resolve_all_program_units (gfc_global_ns_list);
+
+  /* Do the parse tree dump.  */ 
+  gfc_current_ns
+	= gfc_option.dump_parse_tree ? gfc_global_ns_list : NULL;
+
+  for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
+    {
+      gfc_dump_parse_tree (gfc_current_ns, stdout);
+      fputs ("------------------------------------------\n\n", stdout);
+    }
+
+  /* Do the translation.  */
+  translate_all_program_units (gfc_global_ns_list);
+
+termination:
+
   gfc_end_source_files ();
   return SUCCESS;