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 <pa...@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 <pa...@gcc.gnu.org>
PR fortran/57710
* gfortran.dg/same_type_as_3.f03 : New test.
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 <bur...@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
