Fix SIZEOF handling.
I have to admit that I do understand what the current code does,
but do not understand what the previous code did. However, it
still passes the testsuite - and also some code which did ICE
now compiles :-)
While writing the testcase, I did find two issues:
* Passing a CLASS to TYPE(*),dimension(..) will have an
elem_len of the declared type and not of the dynamic type.
https://gcc.gnu.org/bugzilla/show_bug.cgi?id=104844
* var%class_array(1,1)%array will have size(...) == 0
instead of size(... % array).
https://gcc.gnu.org/bugzilla/show_bug.cgi?id=104845
OK for mainline? (Unless you want to hold off until GCC 13)
Tobias
-
Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634
München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas
Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht
München, HRB 106955
Fortran: Fix CLASS handling in SIZEOF intrinsic
gcc/fortran/ChangeLog:
* trans-intrinsic.cc (gfc_conv_intrinsic_sizeof): Fix CLASS handling.
gcc/testsuite/ChangeLog:
* gfortran.dg/sizeof_6.f90: New test.
gcc/fortran/trans-intrinsic.cc | 16 +-
gcc/testsuite/gfortran.dg/sizeof_6.f90 | 437 +
2 files changed, 446 insertions(+), 7 deletions(-)
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index e680de1dbd1..2249723540d 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -8099,12 +8099,14 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
class object. The class object may be a non-pointer object, e.g.
located on the stack, or a memory location pointed to, e.g. a
parameter, i.e., an indirect_ref. */
- if (arg->rank < 0
- || (arg->rank > 0 && !VAR_P (argse.expr)
- && ((INDIRECT_REF_P (TREE_OPERAND (argse.expr, 0))
- && GFC_DECL_CLASS (TREE_OPERAND (
- TREE_OPERAND (argse.expr, 0), 0)))
- || GFC_DECL_CLASS (TREE_OPERAND (argse.expr, 0)
+ if (POINTER_TYPE_P (TREE_TYPE (argse.expr))
+ && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_TYPE (argse.expr
+ byte_size
+ = gfc_class_vtab_size_get (build_fold_indirect_ref (argse.expr));
+ else if (GFC_CLASS_TYPE_P (TREE_TYPE (argse.expr)))
+ byte_size = gfc_class_vtab_size_get (argse.expr);
+ else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (argse.expr))
+ && TREE_CODE (argse.expr) == COMPONENT_REF)
byte_size = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
else if (arg->rank > 0
|| (arg->rank == 0
@@ -8114,7 +8116,7 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
byte_size = gfc_class_vtab_size_get (
GFC_DECL_SAVED_DESCRIPTOR (arg->symtree->n.sym->backend_decl));
else
- byte_size = gfc_class_vtab_size_get (argse.expr);
+ gcc_unreachable ();
}
else
{
diff --git a/gcc/testsuite/gfortran.dg/sizeof_6.f90 b/gcc/testsuite/gfortran.dg/sizeof_6.f90
new file mode 100644
index 000..21b57350dc3
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/sizeof_6.f90
@@ -0,0 +1,437 @@
+! { dg-do run }
+!
+! Check that sizeof is properly handled
+!
+use iso_c_binding
+implicit none (type, external)
+
+type t
+ integer, allocatable :: a(:,:,:), aa
+ integer :: b(5), c
+end type t
+
+type t2
+ class(t), allocatable :: d(:,:), e
+end type t2
+
+type, extends(t2) :: t2e
+ integer :: q(7), z
+end type t2e
+
+type t3
+ class(t2), allocatable :: ct2, ct2a(:,:,:)
+ type(t2), allocatable :: tt2, tt2a(:,:,:)
+ integer, allocatable :: ii, iia(:,:,:)
+end type t3
+
+type(t3) :: var, vara(5)
+type(t3), allocatable :: avar, avara(:)
+class(t3), allocatable :: cvar, cvara(:)
+type(t2), allocatable :: ax, axa(:,:,:)
+class(t2), allocatable :: cx, cxa(:,:,:)
+
+integer(c_size_t) :: n
+
+allocate (t3 :: avar, avara(5))
+allocate (t3 :: cvar, cvara(5))
+
+n = sizeof(var)
+
+! Assume alignment plays no tricks and system has 32bit/64bit.
+! If needed change
+if (n /= 376 .and. n /= 200) error stop
+
+if (n /= sizeof(avar)) error stop
+if (n /= sizeof(cvar)) error stop
+if (n * 5 /= sizeof(vara)) error stop
+if (n * 5 /= sizeof(avara)) error stop
+if (n * 5 /= sizeof(cvara)) error stop
+
+if (n /= sz_ar(var,var,var,var)) error stop
+if (n /= sz_s(var,var)) error stop
+if (n /= sz_t3(var,var,var,var)) error stop
+if (n /= sz_ar(avar,avar,avar,avar)) error stop
+if (n /= sz_s(avar,avar)) error stop
+if (n /= sz_t3(avar,avar,avar,avar)) error stop
+if (n /= sz_t3_at(avar,avar)) error stop
+if (n /= sz_ar(cvar,cvar,cvar,cvar)) error stop
+if (n /= sz_s(cvar,cvar)) error stop
+if (n /= sz_t3(cvar,cvar,cvar,cvar)) error stop
+if (n /= sz_t3_a(cvar,cvar)) error stop
+
+if (n*5 /= sz_ar(vara,vara,vara,vara)) error stop
+if (n*5 /= sz_r1(vara,vara,vara,vara)) error stop
+if (n*5 /= sz_t3(vara,vara,vara,vara)) error stop
+if (n*5 /= sz_ar(avara,avara,avara,avara)) error stop
+if (n*5 /= sz_r1(avara,avara,avara,avara)) error stop
+if (n*5 /=
