Hi Paul,
Am 05.05.24 um 18:48 schrieb Paul Richard Thomas:
Hi Harald,
Please do commit, with or without the extra bit for the function result.
I've committed the attached variant that excludes the case of a scalar
class(*) allocatable function result on the rhs, and added a TODO.
As well as having to get back to pr113363, I have patches in a complete
state for pr84006 and 98534. However they clash with yours. You arrived at
the head of the queue first and so after you :-)
Well, thanks for volunteering to clean up after me... ;-)
Cheers,
Harald
Regards
Paul
From 21e7aa5f3ea44ca2fef8deb8788edffc04901b5c Mon Sep 17 00:00:00 2001
From: Harald Anlauf
Date: Mon, 29 Apr 2024 19:52:52 +0200
Subject: [PATCH] Fortran: fix issues with class(*) assignment [PR114827]
gcc/fortran/ChangeLog:
PR fortran/114827
* trans-array.cc (gfc_alloc_allocatable_for_assignment): Take into
account _len of unlimited polymorphic entities when calculating
the effective element size for allocation size and array span.
Set _len of lhs to _len of rhs.
* trans-expr.cc (trans_class_assignment): Take into account _len
of unlimited polymorphic entities for allocation size.
gcc/testsuite/ChangeLog:
PR fortran/114827
* gfortran.dg/asan/unlimited_polymorphic_34.f90: New test.
---
gcc/fortran/trans-array.cc| 16 +++
gcc/fortran/trans-expr.cc | 13 ++
.../asan/unlimited_polymorphic_34.f90 | 135 ++
3 files changed, 164 insertions(+)
create mode 100644 gcc/testsuite/gfortran.dg/asan/unlimited_polymorphic_34.f90
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 30b84762346..7ec33fb1598 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -11278,6 +11278,19 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
gfc_add_modify (&fblock, linfo->delta[dim], tmp);
}
+ /* Take into account _len of unlimited polymorphic entities, so that span
+ for array descriptors and allocation sizes are computed correctly. */
+ if (UNLIMITED_POLY (expr2))
+{
+ tree len = gfc_class_len_get (TREE_OPERAND (desc2, 0));
+ len = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
+ fold_convert (size_type_node, len),
+ size_one_node);
+ elemsize2 = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, elemsize2,
+ fold_convert (gfc_array_index_type, len));
+}
+
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
gfc_conv_descriptor_span_set (&fblock, desc, elemsize2);
@@ -11324,6 +11337,9 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
gfc_add_modify (&fblock, tmp,
fold_convert (TREE_TYPE (tmp),
TYPE_SIZE_UNIT (type)));
+ else if (UNLIMITED_POLY (expr2))
+ gfc_add_modify (&fblock, tmp,
+ gfc_class_len_get (TREE_OPERAND (desc2, 0)));
else
gfc_add_modify (&fblock, tmp,
build_int_cst (TREE_TYPE (tmp), 0));
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 0280c441ced..bc8eb419cff 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -11991,6 +11991,19 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
old_vptr = build_int_cst (TREE_TYPE (vptr), 0);
size = gfc_vptr_size_get (rhs_vptr);
+
+ /* Take into account _len of unlimited polymorphic entities.
+ TODO: handle class(*) allocatable function results on rhs. */
+ if (UNLIMITED_POLY (rhs) && rhs->expr_type == EXPR_VARIABLE)
+ {
+ tree len = trans_get_upoly_len (block, rhs);
+ len = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
+ fold_convert (size_type_node, len),
+ size_one_node);
+ size = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (size),
+ size, fold_convert (TREE_TYPE (size), len));
+ }
+
tmp = lse->expr;
class_han = GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
? gfc_class_data_get (tmp) : tmp;
diff --git a/gcc/testsuite/gfortran.dg/asan/unlimited_polymorphic_34.f90 b/gcc/testsuite/gfortran.dg/asan/unlimited_polymorphic_34.f90
new file mode 100644
index 000..c69158a1b55
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/asan/unlimited_polymorphic_34.f90
@@ -0,0 +1,135 @@
+! { dg-do run }
+! PR fortran/114827 - issues with class(*) assignment found by valgrind
+!
+! Contributed by Neil Carlson
+
+program main
+ implicit none
+ call run
+ call run1
+ call run2
+contains
+ ! Scalar tests
+ subroutine run ()
+character(*),parameter :: c = 'fubarfubarfubarfubarfubarfu'
+character(*,kind=4), parameter :: d = 4_"abcdef"
+complex, parameter :: z = (1.,2.)
+class(*), allocatable :: y
+
+call foo (c, y)
+select type (y)
+type is (character(*))
+! print *, y(5:6) ! ICE (-> pr114874)
+ if (y /= c) stop 1
+class default
+ stop 2
+end select
+
+call foo (z, y)
+select type (y)
+typ
