gfortran.h (gfc_typebound_proc): New struct.

2008-08-24  Daniel Kraft  <d@domob.eu>

	* gfortran.h (gfc_typebound_proc):  New struct.
	(gfc_symtree):  New member typebound.
	(gfc_find_typebound_proc):  Prototype for new method.
	(gfc_get_derived_super_type):  Prototype for new method.
	* parse.h (gfc_compile_state):  New state COMP_DERIVED_CONTAINS.
	* decl.c (gfc_match_procedure):  Handle PROCEDURE inside derived-type
	CONTAINS section.
	(gfc_match_end):  Handle new context COMP_DERIVED_CONTAINS.
	(gfc_match_private):  Ditto.
	(match_binding_attributes), (match_procedure_in_type):  New methods.
	(gfc_match_final_decl):  Rewrote to make use of new
	COMP_DERIVED_CONTAINS parser state.
	* parse.c (typebound_default_access):  New global helper variable.
	(set_typebound_default_access):  New callback method.
	(parse_derived_contains):  New method.
	(parse_derived):  Extracted handling of CONTAINS to new parser state
	and parse_derived_contains.
	* resolve.c (resolve_bindings_derived), (resolve_bindings_result):  New.
	(check_typebound_override), (resolve_typebound_procedure):  New methods.
	(resolve_typebound_procedures):  New method.
	(resolve_fl_derived):  Call new resolving method for typebound procs.
	* symbol.c (gfc_new_symtree):  Initialize new member typebound to NULL.
	(gfc_find_typebound_proc):  New method.
	(gfc_get_derived_super_type):  New method.

2008-08-24  Daniel Kraft  <d@domob.eu>

	* gfortran.dg/finalize_5.f03:  Adapted expected error message to changes
	to handling of CONTAINS in derived-type declarations.
	* gfortran.dg/typebound_proc_1.f08:  New test.
	* gfortran.dg/typebound_proc_2.f90:  New test.
	* gfortran.dg/typebound_proc_3.f03:  New test.
	* gfortran.dg/typebound_proc_4.f03:  New test.
	* gfortran.dg/typebound_proc_5.f03:  New test.
	* gfortran.dg/typebound_proc_6.f03:  New test.

From-SVN: r139534

1 files changed, 143 insertions, 49 deletions

diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index f9c3705..4bf1b81 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -1691,13 +1691,143 @@ unexpected_eof (void)
 }
 
 
+/* Set the default access attribute for a typebound procedure; this is used
+   as callback for gfc_traverse_symtree.  */
+
+static gfc_access typebound_default_access;
+
+static void
+set_typebound_default_access (gfc_symtree* stree)
+{
+  if (stree->typebound && stree->typebound->access == ACCESS_UNKNOWN)
+    stree->typebound->access = typebound_default_access;
+}
+
+
+/* Parse the CONTAINS section of a derived type definition.  */
+
+static bool
+parse_derived_contains (void)
+{
+  gfc_state_data s;
+  bool seen_private = false;
+  bool seen_comps = false;
+  bool error_flag = false;
+  bool to_finish;
+
+  accept_statement (ST_CONTAINS);
+  gcc_assert (gfc_current_state () == COMP_DERIVED);
+  push_state (&s, COMP_DERIVED_CONTAINS, NULL);
+
+  to_finish = false;
+  while (!to_finish)
+    {
+      gfc_statement st;
+      st = next_statement ();
+      switch (st)
+	{
+	case ST_NONE:
+	  unexpected_eof ();
+	  break;
+
+	case ST_DATA_DECL:
+	  gfc_error ("Components in TYPE at %C must precede CONTAINS");
+	  error_flag = true;
+	  break;
+
+	case ST_PROCEDURE:
+	  if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003:  Type-bound"
+					     " procedure at %C") == FAILURE)
+	    error_flag = true;
+
+	  accept_statement (ST_PROCEDURE);
+	  seen_comps = true;
+	  break;
+
+	case ST_FINAL:
+	  if (gfc_notify_std (GFC_STD_F2003,
+			      "Fortran 2003:  FINAL procedure declaration"
+			      " at %C") == FAILURE)
+	    error_flag = true;
+
+	  accept_statement (ST_FINAL);
+	  seen_comps = true;
+	  break;
+
+	case ST_END_TYPE:
+	  to_finish = true;
+
+	  if (!seen_comps
+	      && (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Derived type "
+				  "definition at %C with empty CONTAINS "
+				  "section") == FAILURE))
+	    error_flag = true;
+
+	  /* ST_END_TYPE is accepted by parse_derived after return.  */
+	  break;
+
+	case ST_PRIVATE:
+	  if (gfc_find_state (COMP_MODULE) == FAILURE)
+	    {
+	      gfc_error ("PRIVATE statement in TYPE at %C must be inside "
+			 "a MODULE");
+	      error_flag = true;
+	      break;
+	    }
+
+	  if (seen_comps)
+	    {
+	      gfc_error ("PRIVATE statement at %C must precede procedure"
+			 " bindings");
+	      error_flag = true;
+	      break;
+	    }
+
+	  if (seen_private)
+	    {
+	      gfc_error ("Duplicate PRIVATE statement at %C");
+	      error_flag = true;
+	    }
+
+	  accept_statement (ST_PRIVATE);
+	  seen_private = true;
+	  break;
+
+	case ST_SEQUENCE:
+	  gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
+	  error_flag = true;
+	  break;
+
+	case ST_CONTAINS:
+	  gfc_error ("Already inside a CONTAINS block at %C");
+	  error_flag = true;
+	  break;
+
+	default:
+	  unexpected_statement (st);
+	  break;
+	}
+    }
+
+  pop_state ();
+  gcc_assert (gfc_current_state () == COMP_DERIVED);
+
+  /* Walk the parsed type-bound procedures and set ACCESS_UNKNOWN attributes
+     to PUBLIC or PRIVATE depending on seen_private.  */
+  typebound_default_access = (seen_private ? ACCESS_PRIVATE : ACCESS_PUBLIC);
+  gfc_traverse_symtree (gfc_current_block ()->f2k_derived->sym_root,
+			&set_typebound_default_access);
+
+  return error_flag;
+}
+
+
 /* Parse a derived type.  */
 
 static void
 parse_derived (void)
 {
   int compiling_type, seen_private, seen_sequence, seen_component, error_flag;
-  int seen_contains, seen_contains_comp;
   gfc_statement st;
   gfc_state_data s;
   gfc_symbol *derived_sym = NULL;
@@ -1713,8 +1843,6 @@ parse_derived (void)
   seen_private = 0;
   seen_sequence = 0;
   seen_component = 0;
-  seen_contains = 0;
-  seen_contains_comp = 0;
 
   compiling_type = 1;
 
@@ -1727,34 +1855,22 @@ parse_derived (void)
 	  unexpected_eof ();
 
 	case ST_DATA_DECL:
-	case ST_PROCEDURE:
-	  if (seen_contains)
-	    {
-	      gfc_error ("Components in TYPE at %C must precede CONTAINS");
-	      error_flag = 1;
-	    }
-
 	  accept_statement (st);
 	  seen_component = 1;
 	  break;
 
-	case ST_FINAL:
-	  if (!seen_contains)
-	    {
-	      gfc_error ("FINAL declaration at %C must be inside CONTAINS");
-	      error_flag = 1;
-	    }
-
-	  if (gfc_notify_std (GFC_STD_F2003,
-			      "Fortran 2003:  FINAL procedure declaration"
-			      " at %C") == FAILURE)
-	    error_flag = 1;
+	case ST_PROCEDURE:
+	  gfc_error ("PROCEDURE binding at %C must be inside CONTAINS");
+	  error_flag = 1;
+	  break;
 
-	  accept_statement (ST_FINAL);
-	  seen_contains_comp = 1;
+	case ST_FINAL:
+	  gfc_error ("FINAL declaration at %C must be inside CONTAINS");
+	  error_flag = 1;
 	  break;
 
 	case ST_END_TYPE:
+endType:
 	  compiling_type = 0;
 
 	  if (!seen_component
@@ -1763,22 +1879,10 @@ parse_derived (void)
 		  == FAILURE))
 	    error_flag = 1;
 
-	  if (seen_contains && !seen_contains_comp
-	      && (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Derived type "
-				 "definition at %C with empty CONTAINS "
-				 "section") == FAILURE))
-	    error_flag = 1;
-
 	  accept_statement (ST_END_TYPE);
 	  break;
 
 	case ST_PRIVATE:
-	  if (seen_contains)
-	    {
-	      gfc_error ("PRIVATE statement at %C must precede CONTAINS");
-	      error_flag = 1;
-	    }
-
 	  if (gfc_find_state (COMP_MODULE) == FAILURE)
 	    {
 	      gfc_error ("PRIVATE statement in TYPE at %C must be inside "
@@ -1802,17 +1906,12 @@ parse_derived (void)
 	    }
 
 	  s.sym->component_access = ACCESS_PRIVATE;
+
 	  accept_statement (ST_PRIVATE);
 	  seen_private = 1;
 	  break;
 
 	case ST_SEQUENCE:
-	  if (seen_contains)
-	    {
-	      gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
-	      error_flag = 1;
-	    }
-
 	  if (seen_component)
 	    {
 	      gfc_error ("SEQUENCE statement at %C must precede "
@@ -1842,15 +1941,10 @@ parse_derived (void)
 			      " definition at %C") == FAILURE)
 	    error_flag = 1;
 
-	  if (seen_contains)
-	    {
-	      gfc_error ("Already inside a CONTAINS block at %C");
-	      error_flag = 1;
-	    }
-
-	  seen_contains = 1;
 	  accept_statement (ST_CONTAINS);
-	  break;
+	  if (parse_derived_contains ())
+	    error_flag = 1;
+	  goto endType;
 
 	default:
 	  unexpected_statement (st);