This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
Re: [Patch, Fortran] Two minor tweaks for type-bound procedure parsing
- From: Daniel Kraft <d at domob dot eu>
- To: Tobias Burnus <tobias dot burnus at physik dot fu-berlin dot de>
- Cc: gcc-patches at gcc dot gnu dot org, fortran at gcc dot gnu dot org
- Date: Mon, 25 Aug 2008 12:19:21 +0200
- Subject: Re: [Patch, Fortran] Two minor tweaks for type-bound procedure parsing
- References: <20080824210533.GA7602@physik.fu-berlin.de>
Hi,
this is a new patch for these problems; I did implement the name-clash
check also for inherited symbols and also fixed the problem with PRIVATE
components and inheritance posted in another thread.
No regressions on GNU/Linux-x86-32. What do you think, ok to commit?
Or should I take the part about EXTENDS out?
Daniel
--
Done: Arc-Bar-Cav-Sam-Val-Wiz, Dwa-Elf-Gno-Hum-Orc, Law-Neu-Cha, Fem-Mal
To go: Hea-Kni-Mon-Pri-Ran-Rog-Tou
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.
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c (revision 139534)
+++ gcc/fortran/symbol.c (working copy)
@@ -1722,7 +1722,7 @@ gfc_add_component (gfc_symbol *sym, cons
}
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, con
&& 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, con
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;
}
}
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 139534)
+++ gcc/fortran/gfortran.h (working copy)
@@ -2208,7 +2208,7 @@ gfc_try gfc_copy_attr (symbol_attribute
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 *);
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (revision 139534)
+++ gcc/fortran/resolve.c (working copy)
@@ -7800,6 +7800,7 @@ resolve_typebound_procedure (gfc_symtree
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
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
Index: gcc/fortran/parse.c
===================================================================
--- gcc/fortran/parse.c (revision 139534)
+++ gcc/fortran/parse.c (working copy)
@@ -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;
Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c (revision 139534)
+++ gcc/fortran/primary.c (working copy)
@@ -1757,7 +1757,7 @@ match_varspec (gfc_expr *primary, int eq
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_sym
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_sym
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! */
}
Index: gcc/testsuite/gfortran.dg/typebound_proc_8.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_proc_8.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/typebound_proc_8.f03 (revision 0)
@@ -0,0 +1,39 @@
+! { 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" }
Index: gcc/testsuite/gfortran.dg/extends_7.f03
===================================================================
--- gcc/testsuite/gfortran.dg/extends_7.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/extends_7.f03 (revision 0)
@@ -0,0 +1,25 @@
+! { 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" } }
Index: gcc/testsuite/gfortran.dg/typebound_proc_7.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_proc_7.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/typebound_proc_7.f03 (revision 0)
@@ -0,0 +1,34 @@
+! { 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" }