+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.
}
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? */
/* 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;
}
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)
}
}
+ /* 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;
}
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)
{
warn_unused_fortran_label (ns->st_labels);
gfc_resolve_uops (ns->uop_root);
-
}
}
-/* 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)
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);
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;
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;
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);
}
+/* 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
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]);
}
-/* 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. */
}
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);
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;
}
+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.
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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" } }
--- /dev/null
+! { dg-do compile }\r
+! Tests the fix for a further regression caused by the\r
+! fix for PR28788 and posted as PR28908. The problem was\r
+! caused by the patch preventing interface derived types\r
+! from associating with identical derived types in the\r
+! containing namespaces.\r
+!\r
+! Contributed by HJ Lu <hjl@lucon.org>\r
+!\r
+module bar\r
+ implicit none\r
+ public\r
+ type domain_ptr\r
+ type(domain), POINTER :: ptr\r
+ end type domain_ptr\r
+ type domain\r
+ TYPE(domain_ptr) , DIMENSION( : ) , POINTER :: parents\r
+ TYPE(domain_ptr) , DIMENSION( : ) , POINTER :: nests\r
+ end type domain\r
+end module bar\r
+\r
+module foo\r
+contains\r
+ recursive subroutine integrate (grid)\r
+ use bar\r
+ implicit none\r
+ type(domain), POINTER :: grid\r
+ interface\r
+ subroutine solve_interface (grid)\r
+ use bar\r
+ TYPE (domain) grid\r
+ end subroutine solve_interface\r
+ end interface\r
+ end subroutine integrate\r
+end module foo\r
+! { dg-final { cleanup-modules "foo bar" } }\r
OSDN Git Service
