Re: [Patch, fortran] PR20244, PR25391, PR19362 and 20864 - getting derived types right

[Paul Thomas <paulthomas2 at wanadoo dot fr>]

:ADDPATCH fortran:

Sorry about the repeat - it would help to get white space right in 
messages and attachments.... and to americanize the spelling.

These problems all involve "equating" derived types, according to 4.4.2 
of the standard. gfortran was either building separate tree types for 
structures that should have been "equal", throwing an ICE or no error 
message at all when they were not "equal".
I found that a front-end fix, in resolve_symbol, got more than a little 
bit cumbersome because of the need to worry about reference counting and 
cleaning up of the derived type symbol. I also tried adding a 
gfc_generate_derived_types in trans_decl.c. This got out of hand too and 
I found that it was difficult to prevent it from being short-circuited 
by other declaration builders.

The simplest, by far, was to attack trans-types(gfc_get_derived_type).  
This looks in parent namespaces to see if "equal" derived types have 
been built elsewhere, rather than building afresh in the contained 
namespace. In this way, the frontend symbols do their job and are 
trashed cleanly at the end of the compilation.  As an aid to the 
process, resolve.c(resolve_symbol) is now building a list of derived 
types for each namepace, so that trans_decl does not have to scan the 
entire symtree.  Also, interface.c(gfc_compare_types) has been broken up 
and a new function, gfc_compare_derived_types, made from half of 
gfc_compare_types, so that derived type symbols can be compared in 
trans-types. A missing check, that caused a seg fault(50% of PR19362), 
was added to make sure that derived->module was present, before using it 
in strcmp.  Also, a check is now made for derived types with private 
components.

There are four new test programs that exercise the fixes or other 
aspects of the standard that were broken but not found/reported.

PR20244 is one of the "Most Wanted Bugs" -
http://gcc.gnu.org/wiki/GfortranWanted

There is still a way to go to get derived types completely right but 
this is a start!  I would say that PRs20860, 20889 and 24706 could be 
done pretty easily.  I do not think that PR22571 is do-able, unless we 
build up same file, external procedure interfaces.

Bubblestrapped and regtested with FC3/Athlon.

OK for trunk and 4.1?

Paul

2005-12-20  Paul Thomas  <pault@gcc.gnu.org>

   PR fortran/19362
   PR fortran/20244
   PR fortran/20864
   PR fortran/25391
   *interface.c(gfc_compare_types): Broken into two.
   (gfc_compare_derived_types): Second half of gfc_compare_types with
   corrections for a missing check that module name is non-NULL and
   a check for private components.
   *symbol.c(gfc_free_dt_list): New function.
   (gfc_free_namespace): Call gfc_free_dt_list.
   *resolve.c(resolve_symbol): Build the list of derived types in the
   symbols namespace.
   *gfortran.h: Define the structure type gfc_dt_list.  Add a new field,
   derived_types to gfc_namespace.  Provide a prototye for the new
   function gfc_compare_derived_types.
   *trans_types.c(gfc_get_derived_type): Test for the derived type being
   available by host association. In this case, the host associated 
backend
   declaration is used for the structure and its components.  On exit,
   traverse the namespace's derived types to see if any are equal and
   unbuilt.  If so, copy the derived type and component declarations.
   (find_derived_type, set_derived_types): New functions to look for
   equal derived types or to copy decalrations to other equal types.

2005-12-20  Paul Thomas  <pault@gcc.gnu.org>

   PR fortran/19362
   PR fortran/20244
   PR fortran/20864
   PR fortran/25391
   *gfortran.dg/used_dummy_types_1.f90: New test.
   *gfortran.dg/used_dummy_types_2.f90: New test.
   *gfortran.dg/used_dummy_types_3.f90: New test.
   *gfortran.dg/used_dummy_types_4.f90: New test.

Index: gcc/fortran/interface.c
===================================================================
*** gcc/fortran/interface.c	(revision 108751)
--- gcc/fortran/interface.c	(working copy)
*************** gfc_match_end_interface (void)
*** 320,362 ****
  }
  
  
! /* Compare two typespecs, recursively if necessary.  */
  
  int
! gfc_compare_types (gfc_typespec * ts1, gfc_typespec * ts2)
  {
    gfc_component *dt1, *dt2;
  
-   if (ts1->type != ts2->type)
-     return 0;
-   if (ts1->type != BT_DERIVED)
-     return (ts1->kind == ts2->kind);
- 
-   /* Compare derived types.  */
-   if (ts1->derived == ts2->derived)
-     return 1;
- 
    /* Special case for comparing derived types across namespaces.  If the
       true names and module names are the same and the module name is
       nonnull, then they are equal.  */
!   if (strcmp (ts1->derived->name, ts2->derived->name) == 0
!       && ((ts1->derived->module == NULL && ts2->derived->module == NULL)
! 	  || (ts1->derived != NULL && ts2->derived != NULL
! 	      && strcmp (ts1->derived->module, ts2->derived->module) == 0)))
      return 1;
  
    /* Compare type via the rules of the standard.  Both types must have
       the SEQUENCE attribute to be equal.  */
  
!   if (strcmp (ts1->derived->name, ts2->derived->name))
      return 0;
  
!   dt1 = ts1->derived->components;
!   dt2 = ts2->derived->components;
  
!   if (ts1->derived->attr.sequence == 0 || ts2->derived->attr.sequence == 0)
      return 0;
  
    /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
       simple test can speed things up.  Otherwise, lots of things have to
       match.  */
--- 320,359 ----
  }
  
  
! /* Compare two derived types using the criteria in 4.4.2 of the standard,
!    recursing through gfc_compare_types for the components.  */
  
  int
! gfc_compare_derived_types (gfc_symbol * derived1, gfc_symbol * derived2)
  {
    gfc_component *dt1, *dt2;
  
    /* Special case for comparing derived types across namespaces.  If the
       true names and module names are the same and the module name is
       nonnull, then they are equal.  */
!   if (strcmp (derived1->name, derived2->name) == 0
!       && ((derived1->ns == NULL && derived2->module == NULL)
! 	  || (derived1 != NULL && derived2 != NULL
! 	      && (derived1->module != NULL && derived2->module != NULL)
! 	      && strcmp (derived1->module, derived2->module) == 0)))
      return 1;
  
    /* Compare type via the rules of the standard.  Both types must have
       the SEQUENCE attribute to be equal.  */
  
!   if (strcmp (derived1->name, derived2->name))
      return 0;
  
!   if (derived1->component_access == ACCESS_PRIVATE
! 	|| derived2->component_access == ACCESS_PRIVATE)
!     return 0;
  
!   if (derived1->attr.sequence == 0 || derived2->attr.sequence == 0)
      return 0;
  
+   dt1 = derived1->components;
+   dt2 = derived2->components;
+ 
    /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
       simple test can speed things up.  Otherwise, lots of things have to
       match.  */
*************** gfc_compare_types (gfc_typespec * ts1, g
*** 389,394 ****
--- 386,409 ----
    return 1;
  }
  
+ /* Compare two typespecs, recursively if necessary.  */
+ 
+ int
+ gfc_compare_types (gfc_typespec * ts1, gfc_typespec * ts2)
+ {
+ 
+   if (ts1->type != ts2->type)
+     return 0;
+   if (ts1->type != BT_DERIVED)
+     return (ts1->kind == ts2->kind);
+ 
+   /* Compare derived types.  */
+   if (ts1->derived == ts2->derived)
+     return 1;
+ 
+   return gfc_compare_derived_types (ts1->derived ,ts2->derived);
+ }
+ 
  
  /* Given two symbols that are formal arguments, compare their ranks
     and types.  Returns nonzero if they have the same rank and type,
Index: gcc/fortran/symbol.c
===================================================================
*** gcc/fortran/symbol.c	(revision 108751)
--- gcc/fortran/symbol.c	(working copy)
*************** free_sym_tree (gfc_symtree * sym_tree)
*** 2307,2312 ****
--- 2307,2327 ----
  }
  
  
+ /* 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 a namespace structure and everything below it.  Interface
     lists associated with intrinsic operators are not freed.  These are
     taken care of when a specific name is freed.  */
*************** gfc_free_namespace (gfc_namespace * ns)
*** 2343,2348 ****
--- 2358,2365 ----
  
    gfc_free_equiv (ns->equiv);
  
+   gfc_free_dt_list (ns->derived_types);
+ 
    for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
      gfc_free_interface (ns->operator[i]);
  
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c	(revision 108751)
--- gcc/fortran/resolve.c	(working copy)
*************** resolve_symbol (gfc_symbol * sym)
*** 4580,4585 ****
--- 4580,4596 ----
  	}
        break;
  
+     case FL_DERIVED:
+       /* Add derived type to the derived type list.  */
+       {
+ 	gfc_dt_list * dt_list;
+ 	dt_list = gfc_get_dt_list ();
+ 	dt_list->next = sym->ns->derived_types;
+ 	dt_list->derived = sym;
+ 	sym->ns->derived_types = dt_list;
+       }
+       break;
+ 
      default:
  
        /* An external symbol falls through to here if it is not referenced.  */
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h	(revision 108751)
--- gcc/fortran/gfortran.h	(working copy)
*************** typedef struct gfc_symtree
*** 833,838 ****
--- 833,848 ----
  }
  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.  */
*************** typedef struct gfc_namespace
*** 892,897 ****
--- 902,910 ----
    /* 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;
  }
*************** int gfc_is_compile_time_shape (gfc_array
*** 1895,1900 ****
--- 1908,1914 ----
  
  /* interface.c -- FIXME: some of these should be in symbol.c */
  void gfc_free_interface (gfc_interface *);
+ int gfc_compare_derived_types (gfc_symbol *, gfc_symbol *);
  int gfc_compare_types (gfc_typespec *, gfc_typespec *);
  void gfc_check_interfaces (gfc_namespace *);
  void gfc_procedure_use (gfc_symbol *, gfc_actual_arglist **, locus *);
Index: gcc/fortran/trans-types.c
===================================================================
*** gcc/fortran/trans-types.c	(revision 108751)
--- gcc/fortran/trans-types.c	(working copy)
*************** gfc_add_field_to_struct (tree *fieldlist
*** 1394,1401 ****
    return decl;
  }
  
  
! /* Build a tree node for a derived type.  */
  
  static tree
  gfc_get_derived_type (gfc_symbol * derived)
--- 1394,1473 ----
    return decl;
  }
  
+ /* Set all "equal" derived types in ns from the backend_decl of
+    the derived type sym. Equality, in this context, is described
+    in 4.4.2 and resolved by gfc_compare_derived_types.  */
  
! static void
! set_derived_types (gfc_symbol * sym)
! {
!   gfc_component *c;
!   gfc_component *cm;
!   gfc_dt_list *dt;
! 
!   gcc_assert (sym->backend_decl != NULL);
! 
!   for (dt = sym->ns->derived_types; dt; dt = dt->next)
!     {
!       if (!dt->derived->backend_decl
! 	    && gfc_compare_derived_types (dt->derived, sym))
! 	{
! 	  dt->derived->backend_decl = sym->backend_decl;
! 
! 	  c = dt->derived->components;
! 	  cm = sym->components;
! 
! 	  for (; c; c = c->next, cm = cm->next)
! 	    c->backend_decl = cm->backend_decl;
! 
! 	  return;
! 	}
!     }
!   return;
! }
! 
! /* Find an "equal" derived type in ns to the derived type sym
!    and, if it has a backend_decl, add this and the component
!    backend_decls to sym.  Equality, in this context, is described
!    in 4.4.2 and resolved by gfc_compare_derived_types.  */
! 
! static void
! find_derived_type (gfc_namespace * ns, gfc_symbol * sym)
! {
!   gfc_component *c;
!   gfc_component *cm;
!   gfc_dt_list *dt;
! 
!   for (dt = ns->derived_types; dt; dt = dt->next)
!     {
!       if (dt->derived->backend_decl == NULL
! 	    && sym->module == NULL
! 	    && gfc_compare_derived_types (dt->derived, sym))
! 	gfc_get_derived_type (dt->derived);
! 
!       if (dt->derived->backend_decl != NULL
! 	    && gfc_compare_derived_types (dt->derived, sym))
! 	{
! 
! 	  sym->backend_decl = dt->derived->backend_decl;
! 
! 	  cm = dt->derived->components;
! 	  c = sym->components;
! 
! 	  for (; c; c = c->next, cm = cm->next)
! 	    c->backend_decl = cm->backend_decl;
! 
! 	  return;
! 	}
!     }
!   return;
! }
! 
! 
! /* 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)
*************** gfc_get_derived_type (gfc_symbol * deriv
*** 1417,1422 ****
--- 1489,1506 ----
      }
    else
      {
+       /* If an equal  derived type is already available by host
+ 	 association, 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.  */
+       gfc_namespace * ns;
+       for (ns = derived->ns->parent; ns; ns = ns->parent)
+ 	{
+ 	  find_derived_type (ns, derived);
+ 	  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);
*************** gfc_get_derived_type (gfc_symbol * deriv
*** 1495,1503 ****
  
    derived->backend_decl = typenode;
  
!   return typenode;
  }
! 
  int
  gfc_return_by_reference (gfc_symbol * sym)
  {
--- 1579,1593 ----
  
    derived->backend_decl = typenode;
  
! other_equal_dts:
!   /* Add this backend_decl to all the other, equal derived types and
!      their components in this namespace.  */
!   set_derived_types (derived);
! 
!   return derived->backend_decl;
  }
! 
! 
  int
  gfc_return_by_reference (gfc_symbol * sym)
  {

! { dg-do run }
! This checks the fix for PR20244 in which USE association
! of derived types would cause an ICE, if the derived type
! was also available by host association. This occurred 
! because the backend declarations were different. 
!
! Contributed by Paul Thomas  <pault@gcc.gnu.org>
!==============
module mtyp
  type t1
     integer::a
  end type t1
end module mtyp
!==============
module atest
  use mtyp
  type(t1)::ze
contains
  subroutine test(ze_in )
    use mtyp
    implicit none
    type(t1)::ze_in
    ze_in = ze
  end subroutine test
  subroutine init( )
    implicit none
    ze = t1 (42)
  end subroutine init
end module atest
!==============
  use atest
  type(t1) :: res = t1 (0)
  call init ()
  call test (res)
  if (res%a.ne.42) call abort
end

! { dg-do compile }
! This tests that the fix for PR25391 also fixes PR20244. If
! the USE mod1 in subroutine foo were deleted, the code would
! compile fine.  With the USE statement, the compiler would
! make new TYPEs for T1 and T2 and bomb out in fold-convert.
! This is a slightly more elaborate test than
! used_dummy_types_1.f90 and came from the PR.
!
! Contributed by Jakub Jelinek  <jakubcc.gnu.org>
module mod1
  type t1
    real :: f1
  end type t1
  type t2
    type(t1), pointer :: f2(:)
    real, pointer :: f3(:,:)
  end type t2
end module mod1

module mod2
  use mod1
  type(t1), pointer, save :: v(:)
contains
  subroutine foo (x)
    use mod1
    implicit none
    type(t2) :: x
    integer :: d
    d = size (x%f3, 2)
    v = x%f2(:)
  end subroutine foo
end module mod2

  MODULE T1
    TYPE data_type
      SEQUENCE
  ! private causes the types in T1 and T2 to be different 4.4.2
      PRIVATE
      INTEGER :: I
    END TYPE
  END MODULE

  MODULE T2
    TYPE data_type
      SEQUENCE
      PRIVATE
      INTEGER :: I
    END TYPE

  CONTAINS

    SUBROUTINE TEST(x)
      TYPE(data_type) :: x
    END SUBROUTINE TEST
  END MODULE

    USE T1
    USE T2 , ONLY : TEST
    TYPE(data_type) :: x
    CALL TEST(x)
  END

! { dg-do compile }
! This checks the fix for PR20864 in which same name, USE associated
! derived types from different modules, with private components were
! not recognised to be different.
!
! Contributed by Joost VandVondele  <jv244@cam.ac.uk>
!==============
  MODULE T1
    TYPE data_type
      SEQUENCE
  ! private causes the types in T1 and T2 to be different 4.4.2
      PRIVATE
      INTEGER :: I
    END TYPE
  END MODULE

  MODULE T2
    TYPE data_type
      SEQUENCE
      PRIVATE
      INTEGER :: I
    END TYPE

  CONTAINS

    SUBROUTINE TEST(x)
      TYPE(data_type) :: x
    END SUBROUTINE TEST
  END MODULE

    USE T1
    USE T2 , ONLY : TEST
    TYPE(data_type) :: x
    CALL TEST(x)         ! { dg-error "Type/rank mismatch in argument" }
  END

! { dg-do compile }
! This checks the fix for PR19362 in which types from different scopes
! that are the same, according to 4.4.2, would generate an ICE if one
! were assigned to the other.  As well as the test itself, various
! other requirements of 4.4.2 are tested here.
!
! Contributed by Paul Thomas  <pault@gcc.gnu.org>
!==============
module global

  TYPE :: seq_type1
    sequence
    integer :: i
  end type seq_type1

  TYPE :: nonseq_type1
    integer :: i
  end type nonseq_type1
  type (nonseq_type1) :: ns1

end module global

! Host types with local name != true name
  use global, only: seq_type2=>seq_type1, nonseq_type2=>nonseq_type1, ns1
  type (nonseq_type2) :: ns2

! Host non-sequence types
  type :: different_type
    integer :: i
  end type different_type
  type (different_type)  :: dt1

  type :: same_type
    integer :: i
  end type same_type
  type (same_type)  :: st1

  real :: seq_type1

! Provide a reference to dt1.
  dt1 = different_type (42)
! These share a type declaration.
  ns2 = ns1
! USE associated seq_type1 is renamed.
  seq_type1 = 1.0

! These are different.
  st1 = dt                ! { dg-error "convert REAL" }

  call foo (st1)          ! { dg-error "Type/rank mismatch in argument" }

contains

  subroutine foo (st2)

! Contained type with local name != true name.
! This is the same as seq_type2 in the host.
    use global, only: seq_type3=>seq_type1

! This local declaration is the same as seq_type3 and seq_type2.
    TYPE :: seq_type1
      sequence
      integer :: i
    end type seq_type1

! Host association of renamed type.
    type (seq_type2) :: x
! Locally declared version of the same thing.
    type (seq_type1) :: y
! USE associated renamed type.
    type (seq_type3) :: z

! Contained type that is different to that in the host.
    type :: different_type
      complex :: z
    end type different_type

    type :: same_type
      integer :: i
    end type same_type

    type (different_type)  :: b
    type (same_type)  :: st2

! Error because these are not the same.
    b = dt1               ! { dg-error "convert TYPE" }

! Error in spite of the name - these are non-sequence types and are NOT
! the same.
    st1 = st2             ! { dg-error "convert TYPE" }

    b%z = (2.0,-1.0)

! Check that the references that are correct actually work. These test the
! fix for PR19362.
    x = seq_type1 (1)
    y = x
    y = seq_type3 (99)
  end subroutine foo
END