+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
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 *);
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;
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;
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. */
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! */
}
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)
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. */
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
}
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);
/* 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;
&& 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;
}
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;
}
}
+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.
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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" }
--- /dev/null
+! { 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" }
OSDN Git Service
