From: Paul Thomas <pault@pc30.home>
Date: Sun, 23 Feb 2020 10:27:37 +0000 (+0000)
Subject: Patch for PR57710
X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=61c8d9e4e5f540501eaa98aae1d6c74bde7d4299;p=gcc.git

Patch for PR57710
---

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 66598161fd8..0449d281bf7 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -8827,7 +8827,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 
 	  cdesc = gfc_create_var (cdesc, "cdesc");
 	  DECL_ARTIFICIAL (cdesc) = 1;
-  
+
 	  gfc_add_modify (&tmpblock, gfc_conv_descriptor_dtype (cdesc),
 	  		  gfc_get_dtype_rank_type (1, tmp));
 	  gfc_conv_descriptor_lbound_set (&tmpblock, cdesc,
@@ -8838,7 +8838,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 					  gfc_index_one_node);
 	  gfc_conv_descriptor_ubound_set (&tmpblock, cdesc,
 					  gfc_index_zero_node, ubound);
-  
+
 	  if (attr->dimension)
 	    comp = gfc_conv_descriptor_data_get (comp);
 	  else
@@ -9116,10 +9116,14 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 	      && (CLASS_DATA (c)->attr.allocatable
 		  || CLASS_DATA (c)->attr.class_pointer))
 	    {
+	      tree vptr_decl;
+
 	      /* Allocatable CLASS components.  */
 	      comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
 				      decl, cdecl, NULL_TREE);
 
+	      vptr_decl = gfc_class_vptr_get (comp);
+
 	      comp = gfc_class_data_get (comp);
 	      if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
 		gfc_conv_descriptor_data_set (&fnblock, comp,
@@ -9131,6 +9135,24 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 					 build_int_cst (TREE_TYPE (comp), 0));
 		  gfc_add_expr_to_block (&fnblock, tmp);
 		}
+
+	      /* The dynamic type of a disassociated pointer or unallocated
+		 allocatable variable is its declared type. An unlimited
+		 polymorphic entity has no declared type.  */
+	      if (!UNLIMITED_POLY (c))
+		{
+		  vtab = gfc_find_derived_vtab (c->ts.u.derived);
+		  if (!vtab->backend_decl)
+		     gfc_get_symbol_decl (vtab);
+		  tmp = gfc_build_addr_expr (NULL_TREE, vtab->backend_decl);
+		}
+	      else
+		tmp = build_int_cst (TREE_TYPE (vptr_decl), 0);
+
+	      tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+					 void_type_node, vptr_decl, tmp);
+	      gfc_add_expr_to_block (&fnblock, tmp);
+
 	      cmp_has_alloc_comps = false;
 	    }
 	  /* Coarrays need the component to be nulled before the api-call
diff --git a/gcc/testsuite/gfortran.dg/same_type_as_3.f03 b/gcc/testsuite/gfortran.dg/same_type_as_3.f03
new file mode 100644
index 00000000000..3a81e749763
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/same_type_as_3.f03
@@ -0,0 +1,27 @@
+! { dg-do run }
+!
+! Test the fix for PR57710.
+!
+! Contributed by Tobias Burnus  <burnus@gcc.gnu.org>
+!
+module m
+  type t
+  end type t
+  type t2
+    integer :: ii
+    class(t), allocatable :: x
+  end type t2
+contains
+  subroutine fini(x)
+     type(t) :: x
+  end subroutine fini
+end module m
+
+use m
+block
+  type(t) :: z
+  type(t2) :: y
+  y%ii = 123
+  if (.not. same_type_as(y%x, z)) call abort ()
+end block
+end