From: Mikael Morin <[email protected]>
Fortran-tested on aarch64-unknown-linux-gnu. OK for mainline?
-- >8 --
When associating a polymorphic scalar with a polymorphic assumed-rank dummy,
make sure that the type size is guessed from the declared type and not the
class descriptor type, to initialize the array descriptor elem_len field.
Before this change, the size was set to that of the class descriptor,
causing the intrinsic SIZEOF to return a wrong value. Fortunately, I
couldn't find any observable effect except for this (non-standard)
intrinsic.
The use of the declared type as source of type size makes it possible to
have void that comes out as source, in the unlimited polymorphic case. This
causes the dtype value construction to trip on an assert because it's not
prepared for a void type, as there's no size that can be guessed from it.
This is corrected by skipping the element length initialization if the input
type is void.
PR fortran/122521
gcc/fortran/ChangeLog:
* trans-descriptor.cc (gfc_build_dtype_constructor): Accept NULL
size argument. Don't build any initialization of the elem_len field
if size is NULL.
* trans-types.cc (get_class_declared_type): New function.
(gfc_get_dtype_rank_type): Clear the size by default. Don't set it
if the input type is void. If the type is a class container type,
use the data target type to guess the size.
gcc/testsuite/ChangeLog:
* gfortran.dg/sizeof_7.f90: New test.
---
gcc/fortran/trans-descriptor.cc | 18 +++++-----
gcc/fortran/trans-types.cc | 46 +++++++++++++++++++++++---
gcc/testsuite/gfortran.dg/sizeof_7.f90 | 30 +++++++++++++++++
3 files changed, 82 insertions(+), 12 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/sizeof_7.f90
diff --git a/gcc/fortran/trans-descriptor.cc b/gcc/fortran/trans-descriptor.cc
index 2139cd9fc31..fc467c99d15 100644
--- a/gcc/fortran/trans-descriptor.cc
+++ b/gcc/fortran/trans-descriptor.cc
@@ -646,15 +646,17 @@ gfc_build_dtype_constructor (tree size, int type, int
rank)
tree field;
vec<constructor_elt, va_gc> *v = NULL;
- gcc_assert (size);
-
- STRIP_NOPS (size);
- size = fold_convert (size_type_node, size);
tree dtype_type_node = get_dtype_type_node ();
- field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node),
- GFC_DTYPE_ELEM_LEN);
- CONSTRUCTOR_APPEND_ELT (v, field,
- fold_convert (TREE_TYPE (field), size));
+ if (size)
+ {
+ STRIP_NOPS (size);
+ size = fold_convert (size_type_node, size);
+ field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node),
+ GFC_DTYPE_ELEM_LEN);
+ CONSTRUCTOR_APPEND_ELT (v, field,
+ fold_convert (TREE_TYPE (field), size));
+ }
+
field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node),
GFC_DTYPE_VERSION);
CONSTRUCTOR_APPEND_ELT (v, field,
diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc
index ef80cd8feab..c0debdd1de9 100644
--- a/gcc/fortran/trans-types.cc
+++ b/gcc/fortran/trans-types.cc
@@ -1698,6 +1698,35 @@ gfc_get_desc_dim_type (void)
}
+/* Return the type that will be inherited by any entity accessible through a
+ class container of type CLASS_TYPE. In other words, given class(foo),
return
+ foo. */
+
+static tree
+get_class_declared_type (tree class_type)
+{
+ gcc_assert (GFC_CLASS_TYPE_P (class_type));
+ tree data_field = TYPE_FIELDS (class_type);
+ gcc_checking_assert (TREE_CODE (data_field) == FIELD_DECL
+ && DECL_NAME (data_field)
+ && strcmp (IDENTIFIER_POINTER (DECL_NAME (data_field)),
+ "_data")
+ == 0);
+
+ tree data_type = TREE_TYPE (data_field);
+ tree declared_type;
+ if (GFC_DESCRIPTOR_TYPE_P (data_type))
+ declared_type = gfc_get_element_type (data_type);
+ else
+ {
+ gcc_assert (POINTER_TYPE_P (data_type));
+ declared_type = TREE_TYPE (data_type);
+ }
+
+ return declared_type;
+}
+
+
/* Return the DTYPE for an array. This describes the type and type parameters
of the array. */
/* TODO: Only call this when the value is actually used, and make all the
@@ -1707,7 +1736,6 @@ tree
gfc_get_dtype_rank_type (int rank, tree etype)
{
tree ptype;
- tree size;
int n;
ptype = etype;
@@ -1749,7 +1777,10 @@ gfc_get_dtype_rank_type (int rank, tree etype)
case RECORD_TYPE:
if (GFC_CLASS_TYPE_P (etype))
- n = BT_CLASS;
+ {
+ n = BT_CLASS;
+ etype = get_class_declared_type (etype);
+ }
else
n = BT_DERIVED;
break;
@@ -1765,6 +1796,7 @@ gfc_get_dtype_rank_type (int rank, tree etype)
gcc_unreachable ();
}
+ tree size = NULL_TREE;
switch (n)
{
case BT_CHARACTER:
@@ -1772,9 +1804,15 @@ gfc_get_dtype_rank_type (int rank, tree etype)
size = gfc_get_character_len_in_bytes (ptype);
break;
case BT_VOID:
- gcc_assert (TREE_CODE (ptype) == POINTER_TYPE);
- size = size_in_bytes (ptype);
+ if (TREE_CODE (ptype) == POINTER_TYPE)
+ size = size_in_bytes (ptype);
break;
+ case BT_CLASS:
+ if (VOID_TYPE_P (etype))
+ break;
+ /* For classes, the element length isn't a known constant, we set it to
+ the declared type length instead if possible. */
+ /* Fall through. */
default:
size = size_in_bytes (etype);
break;
diff --git a/gcc/testsuite/gfortran.dg/sizeof_7.f90
b/gcc/testsuite/gfortran.dg/sizeof_7.f90
new file mode 100644
index 00000000000..47b77c2ac80
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/sizeof_7.f90
@@ -0,0 +1,30 @@
+! { dg-do run }
+!
+! Check the element length value set in a scalar descriptor associated with a
+! polymorphic assumed-rank dummy. The value set in the descriptor passed to s1
+! used to be that of the class descriptor, instead of that of the type t,
+! causing failure in s2.
+
+program prog
+ implicit none
+ type :: t
+ integer :: c1
+ end type
+ type(t) :: x
+ class(t), allocatable :: y
+ x = t(5)
+ y = x
+ call s1(y, sizeof(x))
+contains
+ subroutine s1(a, e)
+ class(t), intent(in) :: a(..)
+ integer(kind=8), intent(in) :: e
+ call s2(a, e)
+ end subroutine
+ subroutine s2(a, e)
+ type(*), intent(in) :: a(..)
+ integer(kind=8), intent(in) :: e
+ !print *, sizeof(a), e
+ if (sizeof(a) /= e) error stop 1
+ end subroutine
+end program
--
2.53.0
