OSDN Git Service

2006-09-05 Paul Thomas <pault@gcc.gnu.org>
authorpault <pault@138bc75d-0d04-0410-961f-82ee72b054a4>
Tue, 5 Sep 2006 04:26:10 +0000 (04:26 +0000)
committerpault <pault@138bc75d-0d04-0410-961f-82ee72b054a4>
Tue, 5 Sep 2006 04:26:10 +0000 (04:26 +0000)
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 <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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@116690 138bc75d-0d04-0410-961f-82ee72b054a4

gcc/fortran/ChangeLog
gcc/fortran/gfortran.h
gcc/fortran/resolve.c
gcc/fortran/symbol.c
gcc/fortran/trans-types.c
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/used_types_7.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/used_types_8.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/used_types_9.f90 [new file with mode: 0644]

index 2fbf6a2..d7fbd11 100644 (file)
@@ -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.
index 14e2ce6..01bcf97 100644 (file)
@@ -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;
 }
index f1606b1..b62a041 100644 (file)
@@ -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);
-    
 }
 
 
index 450f7cf..63e45ec 100644 (file)
@@ -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]);
 
index 3eb1f2c..4ecf94b 100644 (file)
@@ -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;
 }
 
index df6d0f9..0355796 100644 (file)
@@ -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 (file)
index 0000000..9135400
--- /dev/null
@@ -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 (file)
index 0000000..58d2084
--- /dev/null
@@ -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 (file)
index 0000000..fc09d15
--- /dev/null
@@ -0,0 +1,36 @@
+! { 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