From 9d1210f47f50fa5a1e397632792aa97668e56e0e Mon Sep 17 00:00:00 2001 From: Daniel Kraft Date: Mon, 25 Aug 2008 19:58:53 +0200 Subject: [PATCH] gfortran.h (gfc_find_component): Add new arguments. 2008-08-25 Daniel Kraft * 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 * 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 | 13 +++++++ gcc/fortran/gfortran.h | 2 +- gcc/fortran/parse.c | 13 ++++++- gcc/fortran/primary.c | 14 ++++--- gcc/fortran/resolve.c | 33 ++++++++++++++++ gcc/fortran/symbol.c | 25 +++++++----- gcc/testsuite/ChangeLog | 6 +++ gcc/testsuite/gfortran.dg/extends_7.f03 | 25 ++++++++++++ .../gfortran.dg/typebound_proc_7.f03 | 34 ++++++++++++++++ .../gfortran.dg/typebound_proc_8.f03 | 39 +++++++++++++++++++ 10 files changed, 186 insertions(+), 18 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/extends_7.f03 create mode 100644 gcc/testsuite/gfortran.dg/typebound_proc_7.f03 create mode 100644 gcc/testsuite/gfortran.dg/typebound_proc_8.f03 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 8c8c679549a..b606361af40 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,16 @@ +2008-08-25 Daniel Kraft + + * 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 PR fortran/37201 diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 322b4a51304..b063474bf14 100644 --- a/gcc/fortran/gfortran.h +++ b/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 *); diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 4bf1b811b19..f12afd5f2fb 100644 --- a/gcc/fortran/parse.c +++ b/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; diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index 4865b7584a2..5d734079d7a 100644 --- a/gcc/fortran/primary.c +++ b/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! */ } diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 9cde4354cdf..6bf538096ff 100644 --- a/gcc/fortran/resolve.c +++ b/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 diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 005086d9451..2eed9fefb0e 100644 --- a/gcc/fortran/symbol.c +++ b/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; } } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 1604c3bcc43..4406270be78 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2008-08-25 Daniel Kraft + + * 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 * gcc.target/mips/octeon-pop-1.c: New test. diff --git a/gcc/testsuite/gfortran.dg/extends_7.f03 b/gcc/testsuite/gfortran.dg/extends_7.f03 new file mode 100644 index 00000000000..ebb2fcc3efb --- /dev/null +++ b/gcc/testsuite/gfortran.dg/extends_7.f03 @@ -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" } } diff --git a/gcc/testsuite/gfortran.dg/typebound_proc_7.f03 b/gcc/testsuite/gfortran.dg/typebound_proc_7.f03 new file mode 100644 index 00000000000..a12b1d25e34 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/typebound_proc_7.f03 @@ -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" } diff --git a/gcc/testsuite/gfortran.dg/typebound_proc_8.f03 b/gcc/testsuite/gfortran.dg/typebound_proc_8.f03 new file mode 100644 index 00000000000..087b11f6855 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/typebound_proc_8.f03 @@ -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" } -- 2.30.2