gfortran.h (gfc_find_component): Add new arguments.

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

	* gfortran.h (gfc_find_component): Add new arguments.
	* parse.c (parse_derived_contains): Check if the derived-type containing
	the CONTAINS section is SEQUENCE/BIND(C).
	* resolve.c (resolve_typebound_procedure): Check for name collision with
	components.
	(resolve_fl_derived): Check for name collision with inherited
	type-bound procedures.
	* symbol.c (gfc_find_component): New arguments `noaccess' and `silent'.
	(gfc_add_component): Adapt for new arguments.
	* primary.c (match_varspec), (gfc_match_structure_constructor): Ditto.

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

	* gfortran.dg/extends_7.f03: New test.
	* gfortran.dg/typebound_proc_7.f03: New test.
	* gfortran.dg/typebound_proc_8.f03: New test.

From-SVN: r139566

gcc/fortran/ChangeLog

+2008-08-25  Daniel Kraft  <d@domob.eu>
+
+	* gfortran.h (gfc_find_component): Add new arguments.
+	* parse.c (parse_derived_contains): Check if the derived-type containing
+	the CONTAINS section is SEQUENCE/BIND(C).
+	* resolve.c (resolve_typebound_procedure): Check for name collision with
+	components.
+	(resolve_fl_derived): Check for name collision with inherited
+	type-bound procedures.
+	* symbol.c (gfc_find_component): New arguments `noaccess' and `silent'.
+	(gfc_add_component): Adapt for new arguments.
+	* primary.c (match_varspec), (gfc_match_structure_constructor): Ditto.
+
 2008-08-24  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/37201

gcc/fortran/gfortran.h

@@ -2208,7 +2208,7 @@ gfc_try gfc_copy_attr (symbol_attribute *, symbol_attribute *, locus *);
 gfc_try gfc_add_component (gfc_symbol *, const char *, gfc_component **);
 gfc_symbol *gfc_use_derived (gfc_symbol *);
 gfc_symtree *gfc_use_derived_tree (gfc_symtree *);
-gfc_component *gfc_find_component (gfc_symbol *, const char *);
+gfc_component *gfc_find_component (gfc_symbol *, const char *, bool, bool);
 
 gfc_st_label *gfc_get_st_label (int);
 void gfc_free_st_label (gfc_st_label *);

gcc/fortran/parse.c

@@ -1715,8 +1715,19 @@ parse_derived_contains (void)
   bool error_flag = false;
   bool to_finish;
 
-  accept_statement (ST_CONTAINS);
   gcc_assert (gfc_current_state () == COMP_DERIVED);
+  gcc_assert (gfc_current_block ());
+
+  /* Derived-types with SEQUENCE and/or BIND(C) must not have a CONTAINS
+     section.  */
+  if (gfc_current_block ()->attr.sequence)
+    gfc_error ("Derived-type '%s' with SEQUENCE must not have a CONTAINS"
+	       " section at %C", gfc_current_block ()->name);
+  if (gfc_current_block ()->attr.is_bind_c)
+    gfc_error ("Derived-type '%s' with BIND(C) must not have a CONTAINS"
+	       " section at %C", gfc_current_block ()->name);
+
+  accept_statement (ST_CONTAINS);
   push_state (&s, COMP_DERIVED_CONTAINS, NULL);
 
   to_finish = false;

gcc/fortran/primary.c

@@ -1757,7 +1757,7 @@ match_varspec (gfc_expr *primary, int equiv_flag)
       if (m != MATCH_YES)
 	return MATCH_ERROR;
 
-      component = gfc_find_component (sym, name);
+      component = gfc_find_component (sym, name, false, false);
       if (component == NULL)
 	return MATCH_ERROR;
 
@@ -2096,7 +2096,7 @@ gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result, bool parent
 
   where = gfc_current_locus;
 
-  gfc_find_component (sym, NULL);
+  gfc_find_component (sym, NULL, false, true);
 
   /* Match the component list and store it in a list together with the
      corresponding component names.  Check for empty argument list first.  */
@@ -2149,13 +2149,15 @@ gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result, bool parent
 	      strncpy (comp_tail->name, comp->name, GFC_MAX_SYMBOL_LEN + 1);
 	    }
 
-	  /* Find the current component in the structure definition and check its
-	     access is not private.  */
+	  /* Find the current component in the structure definition and check
+	     its access is not private.  */
 	  if (comp)
-	    this_comp = gfc_find_component (sym, comp->name);
+	    this_comp = gfc_find_component (sym, comp->name, false, false);
 	  else
 	    {
-	      this_comp = gfc_find_component (sym, (const char *)comp_tail->name);
+	      this_comp = gfc_find_component (sym,
+					      (const char *)comp_tail->name,
+					      false, false);
 	      comp = NULL; /* Reset needed!  */
 	    }
 

gcc/fortran/resolve.c

@@ -7800,6 +7800,7 @@ resolve_typebound_procedure (gfc_symtree* stree)
   locus where;
   gfc_symbol* me_arg;
   gfc_symbol* super_type;
+  gfc_component* comp;
 
   /* If this is no type-bound procedure, just return.  */
   if (!stree->typebound)
@@ -7898,6 +7899,25 @@ resolve_typebound_procedure (gfc_symtree* stree)
 	goto error;
     }
 
+  /* See if there's a name collision with a component directly in this type.  */
+  for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
+    if (!strcmp (comp->name, stree->name))
+      {
+	gfc_error ("Procedure '%s' at %L has the same name as a component of"
+		   " '%s'",
+		   stree->name, &where, resolve_bindings_derived->name);
+	goto error;
+      }
+
+  /* Try to find a name collision with an inherited component.  */
+  if (super_type && gfc_find_component (super_type, stree->name, true, true))
+    {
+      gfc_error ("Procedure '%s' at %L has the same name as an inherited"
+		 " component of '%s'",
+		 stree->name, &where, resolve_bindings_derived->name);
+      goto error;
+    }
+
   /* FIXME: Remove once typebound-procedures are fully implemented.  */
   {
     /* Output the error only once so we can do reasonable testing.  */
@@ -7954,11 +7974,24 @@ add_dt_to_dt_list (gfc_symbol *derived)
 static gfc_try
 resolve_fl_derived (gfc_symbol *sym)
 {
+  gfc_symbol* super_type;
   gfc_component *c;
   int i;
 
+  super_type = gfc_get_derived_super_type (sym);
+
   for (c = sym->components; c != NULL; c = c->next)
     {
+      /* If this type is an extension, see if this component has the same name
+	 as an inherited type-bound procedure.  */
+      if (super_type && gfc_find_typebound_proc (super_type, c->name))
+	{
+	  gfc_error ("Component '%s' of '%s' at %L has the same name as an"
+		     " inherited type-bound procedure",
+		     c->name, sym->name, &c->loc);
+	  return FAILURE;
+	}
+
       if (c->ts.type == BT_CHARACTER)
 	{
 	 if (c->ts.cl->length == NULL

gcc/fortran/symbol.c

@@ -1722,7 +1722,7 @@ gfc_add_component (gfc_symbol *sym, const char *name,
     }
 
   if (sym->attr.extension
-	&& gfc_find_component (sym->components->ts.derived, name))
+	&& gfc_find_component (sym->components->ts.derived, name, true, true))
     {
       gfc_error ("Component '%s' at %C already in the parent type "
 		 "at %L", name, &sym->components->ts.derived->declared_at);
@@ -1839,10 +1839,12 @@ bad:
 
 /* Given a derived type node and a component name, try to locate the
    component structure.  Returns the NULL pointer if the component is
-   not found or the components are private.  */
+   not found or the components are private.  If noaccess is set, no access
+   checks are done.  */
 
 gfc_component *
-gfc_find_component (gfc_symbol *sym, const char *name)
+gfc_find_component (gfc_symbol *sym, const char *name,
+		    bool noaccess, bool silent)
 {
   gfc_component *p;
 
@@ -1862,22 +1864,24 @@ gfc_find_component (gfc_symbol *sym, const char *name)
 	&& sym->attr.extension
 	&& sym->components->ts.type == BT_DERIVED)
     {
-      p = gfc_find_component (sym->components->ts.derived, name);
+      p = gfc_find_component (sym->components->ts.derived, name,
+			      noaccess, silent);
       /* Do not overwrite the error.  */
       if (p == NULL)
 	return p;
     }
 
-  if (p == NULL)
+  if (p == NULL && !silent)
     gfc_error ("'%s' at %C is not a member of the '%s' structure",
 	       name, sym->name);
 
-  else if (sym->attr.use_assoc)
+  else if (sym->attr.use_assoc && !noaccess)
     {
       if (p->attr.access == ACCESS_PRIVATE)
 	{
-	  gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
-		     name, sym->name);
+	  if (!silent)
+	    gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
+		       name, sym->name);
 	  return NULL;
 	}
 	
@@ -1885,8 +1889,9 @@ gfc_find_component (gfc_symbol *sym, const char *name)
 	 out at this place.  */
       if (p->attr.access != ACCESS_PUBLIC && sym->component_access == ACCESS_PRIVATE)
 	{
-	  gfc_error ("All components of '%s' are PRIVATE in structure"
-		     " constructor at %C", sym->name);
+	  if (!silent)
+	    gfc_error ("All components of '%s' are PRIVATE in structure"
+		       " constructor at %C", sym->name);
 	  return NULL;
 	}
     }

gcc/testsuite/ChangeLog

+2008-08-25  Daniel Kraft  <d@domob.eu>
+
+	* gfortran.dg/extends_7.f03: New test.
+	* gfortran.dg/typebound_proc_7.f03: New test.
+	* gfortran.dg/typebound_proc_8.f03: New test.
+
 2008-08-24  Adam Nemet  <anemet@caviumnetworks.com>
 
 	* gcc.target/mips/octeon-pop-1.c: New test.

gcc/testsuite/gfortran.dg/extends_7.f03

+! { dg-do compile }
+! Check for re-definition of inherited components in the sub-type.
+
+MODULE m1
+  IMPLICIT NONE
+
+  TYPE supert
+    INTEGER :: c1
+    INTEGER, PRIVATE :: c2
+  END TYPE supert
+
+END MODULE m1
+
+MODULE m2
+  USE m1 ! { dg-error "already in the parent type" }
+  IMPLICIT NONE
+
+  TYPE, EXTENDS(supert) :: subt
+    INTEGER :: c1 ! { dg-error "already in the parent type" }
+    INTEGER :: c2 ! { dg-error "already in the parent type" }
+  END TYPE subt
+
+END MODULE m2
+
+! { dg-final { cleanup-modules "m1 m2" } }

gcc/testsuite/gfortran.dg/typebound_proc_7.f03

+! { dg-do compile }
+
+! Type-bound procedures
+! Tests that SEQUENCE and BIND(C) types do not allow a type-bound procedure
+! section.
+
+MODULE testmod
+  USE ISO_C_BINDING
+  IMPLICIT NONE
+
+  TYPE sequencet
+    SEQUENCE
+    INTEGER :: a, b
+  CONTAINS ! { dg-error "SEQUENCE" }
+    PROCEDURE, NOPASS :: proc_noarg
+  END TYPE sequencet
+
+  TYPE, BIND(C) :: bindct
+    INTEGER(c_int) :: a
+    REAL(c_float) :: b
+  CONTAINS ! { dg-error "BIND" }
+    PROCEDURE, NOPASS :: proc_noarg
+  END TYPE bindct
+
+CONTAINS
+
+  SUBROUTINE proc_noarg ()
+  END SUBROUTINE proc_noarg
+
+END MODULE testmod
+
+! { dg-final { cleanup-modules "testmod" } }
+! FIXME: Remove not-yet-implemented error when implemented.
+! { dg-excess-errors "not yet implemented" }

gcc/testsuite/gfortran.dg/typebound_proc_8.f03

+! { dg-do compile }
+
+! Type-bound procedures
+! Test for name collision between type-bound procedures and components.
+
+MODULE testmod
+  IMPLICIT NONE
+
+  TYPE t
+    REAL :: comp
+  CONTAINS
+    PROCEDURE, NOPASS :: comp => proc ! { dg-error "same name as a component" }
+  END TYPE t
+
+  TYPE supert
+    INTEGER :: comp1
+  CONTAINS
+    PROCEDURE, NOPASS :: comp2 => proc
+  END TYPE supert
+
+  TYPE, EXTENDS(supert) :: subt1
+    INTEGER :: comp2 ! { dg-error "same name" }
+  END TYPE subt1
+
+  TYPE, EXTENDS(supert) :: subt2
+  CONTAINS
+    PROCEDURE, NOPASS :: comp1 => proc ! { dg-error "same name as an inherited component" }
+  END TYPE subt2
+
+CONTAINS
+
+  SUBROUTINE proc ()
+  END SUBROUTINE proc
+
+END MODULE testmod
+
+! { dg-final { cleanup-modules "testmod" } }
+! FIXME: Remove not-yet-implemented error when implemented.
+! { dg-excess-errors "not yet implemented" }