From a9c394015cef46a9dcc55d5b7745911720f527f7 Mon Sep 17 00:00:00 2001 From: pault Date: Tue, 5 Sep 2006 04:26:10 +0000 Subject: [PATCH] 2006-09-05 Paul Thomas 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-09-05 Paul Thomas 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. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@116690 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 23 +++++ gcc/fortran/gfortran.h | 14 +++ gcc/fortran/resolve.c | 30 +++++- gcc/fortran/symbol.c | 155 +++++------------------------ gcc/fortran/trans-types.c | 77 +++++++++++++- gcc/testsuite/ChangeLog | 7 ++ gcc/testsuite/gfortran.dg/used_types_7.f90 | 39 ++++++++ gcc/testsuite/gfortran.dg/used_types_8.f90 | 46 +++++++++ gcc/testsuite/gfortran.dg/used_types_9.f90 | 36 +++++++ 9 files changed, 292 insertions(+), 135 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/used_types_7.f90 create mode 100644 gcc/testsuite/gfortran.dg/used_types_8.f90 create mode 100644 gcc/testsuite/gfortran.dg/used_types_9.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 2fbf6a281a9..d7fbd115e09 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,26 @@ +2006-09-05 Paul Thomas + + 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 * match.c: Fix a comment typo. diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 14e2ce6bdb0..01bcf976e54 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 f1606b19622..b62a0411e9d 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 450f7cf3523..63e45ecb5fe 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 3eb1f2cc06d..4ecf94b4c9f 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 df6d0f9b6ac..0355796a543 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2006-09-05 Paul Thomas + + 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 * 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 00000000000..91354005d21 --- /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 +! +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 00000000000..58d2084f362 --- /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 +! +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 00000000000..fc09d155c0f --- /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 +! +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" } } -- 2.11.0