diff options
| -rw-r--r-- | gcc/fortran/ChangeLog | 23 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.h | 14 | ||||
| -rw-r--r-- | gcc/fortran/resolve.c | 30 | ||||
| -rw-r--r-- | gcc/fortran/symbol.c | 155 | ||||
| -rw-r--r-- | gcc/fortran/trans-types.c | 77 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 7 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/used_types_7.f90 | 39 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/used_types_8.f90 | 46 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/used_types_9.f90 | 36 |
9 files changed, 292 insertions, 135 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 2fbf6a2..d7fbd11 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,26 @@ +2006-09-05 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/28908 + REGRESSION FIX + * gfortran.h : Restore the gfc_dt_list structure and reference + to it in gfc_namespace. + * resolve.c (resolve_fl_derived): Restore the building of the + list of derived types for the current namespace. Modify the + restored code so that a check is made to see if the symbol is + already in the list. + (resolve_fntype): Make sure that the specification block + version of the derived type is used for a module function that + returns that type. + * symbol.c (gfc_free_dt_list): Restore. + (gfc_free_namespace): Restore call to previous. + * trans-types.c (copy_dt_decls_ifequal): Restore. + (gfc_get_derived_type): Restore all the paraphenalia for + association of derived types, including calls to previous. + Modify the restored code such that all derived types are built + if their symbols are found in the parent namespace; not just + non-module types. Add backend_decls to like derived types in + sibling namespaces, as well as that of the derived type. + 2006-08-30 Kazu Hirata <kazu@codesourcery.com> * match.c: Fix a comment typo. diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 14e2ce6..01bcf97 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -927,6 +927,17 @@ typedef struct gfc_symtree } gfc_symtree; +/* A linked list of derived types in the namespace. */ +typedef struct gfc_dt_list +{ + struct gfc_symbol *derived; + struct gfc_dt_list *next; +} +gfc_dt_list; + +#define gfc_get_dt_list() gfc_getmem(sizeof(gfc_dt_list)) + + /* A namespace describes the contents of procedure, module or interface block. */ /* ??? Anything else use these? */ @@ -989,6 +1000,9 @@ typedef struct gfc_namespace /* A list of all alternate entry points to this procedure (or NULL). */ gfc_entry_list *entries; + /* A list of all derived types in this procedure (or NULL). */ + gfc_dt_list *derived_types; + /* Set to 1 if namespace is a BLOCK DATA program unit. */ int is_block_data; } diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index f1606b1..b62a041 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -5368,6 +5368,7 @@ static try resolve_fl_derived (gfc_symbol *sym) { gfc_component *c; + gfc_dt_list * dt_list; int i; for (c = sym->components; c != NULL; c = c->next) @@ -5430,6 +5431,19 @@ resolve_fl_derived (gfc_symbol *sym) } } + /* Add derived type to the derived type list. */ + for (dt_list = sym->ns->derived_types; dt_list; dt_list = dt_list->next) + if (sym == dt_list->derived) + break; + + if (dt_list == NULL) + { + dt_list = gfc_get_dt_list (); + dt_list->next = sym->ns->derived_types; + dt_list->derived = sym; + sym->ns->derived_types = dt_list; + } + return SUCCESS; } @@ -6528,6 +6542,21 @@ resolve_fntype (gfc_namespace * ns) sym->name, &sym->declared_at, sym->ts.derived->name); } + /* Make sure that the type of a module derived type function is in the + module namespace, by copying it from the namespace's derived type + list, if necessary. */ + if (sym->ts.type == BT_DERIVED + && sym->ns->proc_name->attr.flavor == FL_MODULE + && sym->ts.derived->ns + && sym->ns != sym->ts.derived->ns) + { + gfc_dt_list *dt = sym->ns->derived_types; + + for (; dt; dt = dt->next) + if (gfc_compare_derived_types (sym->ts.derived, dt->derived)) + sym->ts.derived = dt->derived; + } + if (ns->entries) for (el = ns->entries->next; el; el = el->next) { @@ -6666,7 +6695,6 @@ resolve_types (gfc_namespace * ns) warn_unused_fortran_label (ns->st_labels); gfc_resolve_uops (ns->uop_root); - } diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 450f7cf..63e45ec 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -1364,37 +1364,8 @@ gfc_add_component (gfc_symbol * sym, const char *name, gfc_component ** componen } -/* Recursive search for a renamed derived type. */ - -static gfc_symbol * -find_renamed_type (gfc_symbol * der, gfc_symtree * st) -{ - gfc_symbol *sym = NULL; - - if (st == NULL) - return NULL; - - sym = find_renamed_type (der, st->left); - if (sym != NULL) - return sym; - - sym = find_renamed_type (der, st->right); - if (sym != NULL) - return sym; - - if (strcmp (der->name, st->n.sym->name) == 0 - && st->n.sym->attr.use_assoc - && st->n.sym->attr.flavor == FL_DERIVED - && gfc_compare_derived_types (der, st->n.sym)) - sym = st->n.sym; - - return sym; -} - -/* Recursive function to switch derived types of all symbols in a - namespace. The formal namespaces contain references to derived - types that can be left hanging by gfc_use_derived, so these must - be switched too. */ +/* Recursive function to switch derived types of all symbol in a + namespace. */ static void switch_types (gfc_symtree * st, gfc_symbol * from, gfc_symbol * to) @@ -1407,9 +1378,6 @@ switch_types (gfc_symtree * st, gfc_symbol * from, gfc_symbol * to) sym = st->n.sym; if (sym->ts.type == BT_DERIVED && sym->ts.derived == from) sym->ts.derived = to; - - if (sym->formal_ns && sym->formal_ns->sym_root) - switch_types (sym->formal_ns->sym_root, from, to); switch_types (st->left, from, to); switch_types (st->right, from, to); @@ -1440,103 +1408,20 @@ gfc_use_derived (gfc_symbol * sym) gfc_symbol *s; gfc_typespec *t; gfc_symtree *st; - gfc_component *c; - gfc_namespace *ns; int i; - if (sym->ns->parent == NULL || sym->ns != gfc_current_ns) - { - /* Already defined in highest possible or sibling namespace. */ - if (sym->components != NULL) - return sym; - - /* There is no scope for finding a definition elsewhere. */ - else - goto bad; - } - else - { - /* This type can only be locally associated. */ - if (!(sym->attr.use_assoc || sym->attr.sequence)) - return sym; + if (sym->components != NULL) + return sym; /* Already defined. */ - /* Derived types must be defined within an interface. */ - if (gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY) - return sym; - } + if (sym->ns->parent == NULL) + goto bad; - /* Look in parent namespace for a derived type of the same name. */ if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s)) { gfc_error ("Symbol '%s' at %C is ambiguous", sym->name); return NULL; } - /* Look in sibling namespaces for a derived type of the same name. */ - if (s == NULL && sym->attr.use_assoc && sym->ns->sibling) - { - ns = sym->ns->sibling; - for (; ns; ns = ns->sibling) - { - s = NULL; - if (sym->ns == ns) - break; - - if (gfc_find_symbol (sym->name, ns, 1, &s)) - { - gfc_error ("Symbol '%s' at %C is ambiguous", sym->name); - return NULL; - } - - if (s != NULL && s->attr.flavor == FL_DERIVED) - break; - } - } - - if (s == NULL || s->attr.flavor != FL_DERIVED) - { - /* Check to see if type has been renamed in parent namespace. */ - s = find_renamed_type (sym, sym->ns->parent->sym_root); - if (s != NULL) - goto return_use_assoc; - - /* See if sym is identical to renamed, use-associated derived - types in sibling namespaces. */ - if (sym->attr.use_assoc - && sym->ns->parent - && sym->ns->parent->contained) - { - ns = sym->ns->parent->contained; - for (; ns; ns = ns->sibling) - { - if (sym->ns == ns) - break; - - s = find_renamed_type (sym, ns->sym_root); - - if (s != NULL) - goto return_use_assoc; - } - } - - /* The local definition is all that there is. */ - if (sym->components != NULL) - { - /* Non-pointer derived type components have already been checked - but pointer types need to be correctly associated. */ - for (c = sym->components; c; c = c->next) - if (c->ts.type == BT_DERIVED && c->pointer) - c->ts.derived = gfc_use_derived (c->ts.derived); - - return sym; - } - } - - /* Although the parent namespace has a derived type of the same name, it is - not an identical derived type and so cannot be used. */ - if (s != NULL && sym->components != NULL && !gfc_compare_derived_types (s, sym)) - return sym; - if (s == NULL || s->attr.flavor != FL_DERIVED) goto bad; @@ -1548,9 +1433,6 @@ gfc_use_derived (gfc_symbol * sym) t->derived = s; } - if (sym->attr.use_assoc) - goto return_use_assoc; - st = gfc_find_symtree (sym->ns->sym_root, sym->name); st->n.sym = s; @@ -1567,14 +1449,6 @@ gfc_use_derived (gfc_symbol * sym) return s; -return_use_assoc: - /* Use associated types are not freed at this stage because some - references remain to 'sym'. We retain the symbol and leave it - to be cleaned up by gfc_free_namespace, at the end of the - compilation. */ - switch_types (sym->ns->sym_root, sym, s); - return s; - bad: gfc_error ("Derived type '%s' at %C is being used before it is defined", sym->name); @@ -2566,6 +2440,21 @@ free_sym_tree (gfc_symtree * sym_tree) } +/* Free a derived type list. */ + +static void +gfc_free_dt_list (gfc_dt_list * dt) +{ + gfc_dt_list *n; + + for (; dt; dt = n) + { + n = dt->next; + gfc_free (dt); + } +} + + /* Free the gfc_equiv_info's. */ static void @@ -2628,6 +2517,8 @@ gfc_free_namespace (gfc_namespace * ns) gfc_free_equiv (ns->equiv); gfc_free_equiv_lists (ns->equiv_lists); + gfc_free_dt_list (ns->derived_types); + for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++) gfc_free_interface (ns->operator[i]); diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 3eb1f2c..4ecf94b 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -1411,15 +1411,59 @@ gfc_add_field_to_struct (tree *fieldlist, tree context, } -/* Build a tree node for a derived type. */ +/* Copy the backend_decl and component backend_decls if + the two derived type symbols are "equal", as described + in 4.4.2 and resolved by gfc_compare_derived_types. */ + +static int +copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to) +{ + gfc_component *to_cm; + gfc_component *from_cm; + + if (from->backend_decl == NULL + || !gfc_compare_derived_types (from, to)) + return 0; + + to->backend_decl = from->backend_decl; + + to_cm = to->components; + from_cm = from->components; + + /* Copy the component declarations. If a component is itself + a derived type, we need a copy of its component declarations. + This is done by recursing into gfc_get_derived_type and + ensures that the component's component declarations have + been built. If it is a character, we need the character + length, as well. */ + for (; to_cm; to_cm = to_cm->next, from_cm = from_cm->next) + { + to_cm->backend_decl = from_cm->backend_decl; + if (from_cm->ts.type == BT_DERIVED) + gfc_get_derived_type (to_cm->ts.derived); + + else if (from_cm->ts.type == BT_CHARACTER) + to_cm->ts.cl->backend_decl = from_cm->ts.cl->backend_decl; + } + + return 1; +} + + +/* Build a tree node for a derived type. If there are equal + derived types, with different local names, these are built + at the same time. If an equal derived type has been built + in a parent namespace, this is used. */ static tree gfc_get_derived_type (gfc_symbol * derived) { tree typenode, field, field_type, fieldlist; gfc_component *c; + gfc_dt_list *dt; + gfc_namespace * ns; - gcc_assert (derived); + gcc_assert (derived && derived->attr.flavor == FL_DERIVED); /* derived->backend_decl != 0 means we saw it before, but its components' backend_decl may have not been built. */ @@ -1433,6 +1477,27 @@ gfc_get_derived_type (gfc_symbol * derived) } else { + /* If an equal derived type is already available in the parent namespace, + use its backend declaration and those of its components, rather than + building anew so that potential dummy and actual arguments use the + same TREE_TYPE. If an equal type is found without a backend_decl, + build the parent version and use it in the current namespace. */ + + for (ns = derived->ns->parent; ns; ns = ns->parent) + { + for (dt = ns->derived_types; dt; dt = dt->next) + { + if (dt->derived->backend_decl == NULL + && gfc_compare_derived_types (dt->derived, derived)) + gfc_get_derived_type (dt->derived); + + if (copy_dt_decls_ifequal (dt->derived, derived)) + break; + } + if (derived->backend_decl) + goto other_equal_dts; + } + /* We see this derived type first time, so build the type node. */ typenode = make_node (RECORD_TYPE); TYPE_NAME (typenode) = get_identifier (derived->name); @@ -1511,6 +1576,14 @@ gfc_get_derived_type (gfc_symbol * derived) derived->backend_decl = typenode; +other_equal_dts: + /* Add this backend_decl to all the other, equal derived types and + their components in this and sibling namespaces. */ + + for (ns = derived->ns->sibling; ns; ns = ns->sibling) + for (dt = ns->derived_types; dt; dt = dt->next) + copy_dt_decls_ifequal (derived, dt->derived); + return derived->backend_decl; } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index df6d0f9..0355796 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2006-09-05 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/28908 + * gfortran.dg/used_types_7.f90: New test. + * gfortran.dg/used_types_8.f90: New test. + * gfortran.dg/used_types_9.f90: New test. + 2006-09-04 Eric Botcazou <ebotcazou@libertysurf.fr> * gcc.c-torture/compile/20060904-1.c: New test. diff --git a/gcc/testsuite/gfortran.dg/used_types_7.f90 b/gcc/testsuite/gfortran.dg/used_types_7.f90 new file mode 100644 index 0000000..9135400 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/used_types_7.f90 @@ -0,0 +1,39 @@ +! { dg-do compile } +! Tests the fix for a further regression caused by the +! fix for PR28788 and posted as PR28908. The problem was +! caused by the patch preventing interface derived types +! from associating with identical derived types in the +! containing namespaces. +! +! Contributed by HJ Lu <hjl@lucon.org> +! +module bar + implicit none + public + type ESMF_Time + integer :: DD + end type +end module bar + +module foo + use bar + implicit none + private + type ESMF_Clock + type(ESMF_Time) :: CurrTime + end type + interface operator (+) + function add (x, y) + use bar + type(ESMF_Time) :: add + type(ESMF_Time), intent(in) :: x + type(ESMF_Time), intent(in) :: y + end function add + end interface +contains + subroutine ESMF_ClockAdvance(clock) + type(ESMF_Clock), intent(inout) :: clock + clock%CurrTime = clock%CurrTime + clock%CurrTime + end subroutine ESMF_ClockAdvance +end module foo +! { dg-final { cleanup-modules "foo bar" } } diff --git a/gcc/testsuite/gfortran.dg/used_types_8.f90 b/gcc/testsuite/gfortran.dg/used_types_8.f90 new file mode 100644 index 0000000..58d2084 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/used_types_8.f90 @@ -0,0 +1,46 @@ +! { dg-do compile } +! Tests the fix for a further regression caused by the +! fix for PR28788 and posted as PR28908. The problem was +! caused by the patch preventing interface derived types +! from associating with identical derived types in the +! containing namespaces. +! +! Contributed by HJ Lu <hjl@lucon.org> +! +module bar + implicit none + public + type ESMF_Time + sequence + integer :: MM + end type + public operator (+) + private add + interface operator (+) + module procedure add + end interface +contains + function add (x, y) + type(ESMF_Time) :: add + type(ESMF_Time), intent(in) :: x + type(ESMF_Time), intent(in) :: y + add = x + end function add +end module bar + +module foo + use bar + implicit none + private + type ESMF_Clock + sequence + type(ESMF_Time) :: CurrTime + end type +contains + subroutine ESMF_ClockAdvance(clock) + use bar + type(ESMF_Clock), intent(inout) :: clock + clock%CurrTime = clock%CurrTime + clock%CurrTime + end subroutine ESMF_ClockAdvance +end module foo +! { dg-final { cleanup-modules "foo bar" } } diff --git a/gcc/testsuite/gfortran.dg/used_types_9.f90 b/gcc/testsuite/gfortran.dg/used_types_9.f90 new file mode 100644 index 0000000..fc09d15 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/used_types_9.f90 @@ -0,0 +1,36 @@ +! { dg-do compile }
+! Tests the fix for a further regression caused by the
+! fix for PR28788 and posted as PR28908. The problem was
+! caused by the patch preventing interface derived types
+! from associating with identical derived types in the
+! containing namespaces.
+!
+! Contributed by HJ Lu <hjl@lucon.org>
+!
+module bar
+ implicit none
+ public
+ type domain_ptr
+ type(domain), POINTER :: ptr
+ end type domain_ptr
+ type domain
+ TYPE(domain_ptr) , DIMENSION( : ) , POINTER :: parents
+ TYPE(domain_ptr) , DIMENSION( : ) , POINTER :: nests
+ end type domain
+end module bar
+
+module foo
+contains
+ recursive subroutine integrate (grid)
+ use bar
+ implicit none
+ type(domain), POINTER :: grid
+ interface
+ subroutine solve_interface (grid)
+ use bar
+ TYPE (domain) grid
+ end subroutine solve_interface
+ end interface
+ end subroutine integrate
+end module foo
+! { dg-final { cleanup-modules "foo bar" } }
|