@@ -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
new file mode 100644
@@ -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
This patch is relatively trivial and represents my first foray into gitland. Thus far, it has been... well, "interesting" compared with svn. Class components of derived types are initialized by calls to trans-array.c(gfc_trans_deferred_array) from trans-decl.c(gfc_trans_deferred_vars). The components are nullified in trans-array.c(structure_alloc_comps). The 'same_type_as' intrinsic requires that nullified class components either point to the declared type vtable or, in the case of unlimited polymorphic components, the vptr should be null. See Note 16.28 in the F2018 standard. The attached patch implements that requirement. Regtested on FC31/x86_64 - OK for head? Paul 2020-02-23 Paul Thomas <pault@gcc.gnu.org> PR fortran/57710 * trans-array.c (structure_alloc_comps): When nullifying class components, the vptr must point to the declared type or, in the case of unlimited polymorphic components, it should be null. 2020-02-23 Paul Thomas <pault@gcc.gnu.org> PR fortran/57710 * gfortran.dg/same_type_as_3.f03 : New test.