This fix is straightforward and described by the ChangeLog. Jose Rui
Faustino de Sousa posted the same fix for the ICE on the fortran list
slightly more than three years ago. Thinking that he had commit rights, I
deferred but, regrettably, the patch was never applied. The attached patch
also fixes storage_size and transfer for unlimited polymorphic arguments
with character payloads.
OK for mainline and backporting after a reasonable interval?
Paul
Fortran: Unlimited polymorphic intrinsic function arguments [PR84006]
2024-05-08 Paul Thomas <pa...@gcc.gnu.org>
gcc/fortran
PR fortran/84006
PR fortran/100027
PR fortran/98534
* trans-expr.cc (gfc_resize_class_size_with_len): Use the fold
even if a block is not available in which to fix the result.
(trans_class_assignment): Enable correct assignment of
character expressions to unlimited polymorphic variables using
lhs _len field and rse string_length.
* trans-intrinsic.cc (gfc_conv_intrinsic_storage_size): Extract
the class expression so that the unlimited polymorphic class
expression can be used in gfc_resize_class_size_with_len to
obtain the storage size for character payloads. Guard the use
of GFC_DECL_SAVED_DESCRIPTOR by testing for DECL_LANG_SPECIFIC
to prevent the ICE. Also, invert the order to use the class
expression extracted from the argument.
(gfc_conv_intrinsic_transfer): In same way as 'storage_size',
use the _len field to obtaining the correct length for arg 1.
gcc/testsuite/
PR fortran/84006
PR fortran/100027
* gfortran.dg/storage_size_7.f90: New test.
PR fortran/98534
* gfortran.dg/transfer_class_4.f90: New test.
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index bc8eb419cff..4590aa6edb4 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -317,6 +317,8 @@ gfc_resize_class_size_with_len (stmtblock_t * block, tree class_expr, tree size)
size = gfc_evaluate_now (size, block);
tmp = gfc_evaluate_now (fold_convert (type , tmp), block);
}
+ else
+ tmp = fold_convert (type , tmp);
tmp2 = fold_build2_loc (input_location, MULT_EXPR,
type, size, tmp);
tmp = fold_build2_loc (input_location, GT_EXPR,
@@ -11994,15 +11996,24 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
/* 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)
+ if (UNLIMITED_POLY (rhs))
{
- tree len = trans_get_upoly_len (block, rhs);
+ tree len;
+ if (rhs->expr_type == EXPR_VARIABLE)
+ len = trans_get_upoly_len (block, rhs);
+ else
+ len = gfc_class_len_get (tmp);
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));
}
+ else if (rhs->ts.type == BT_CHARACTER && rse->string_length)
+ size = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_charlen_type_node, size,
+ rse->string_length);
+
tmp = lse->expr;
class_han = GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index 83041183fcb..e18e4d1e183 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -8250,7 +8250,9 @@ gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
{
gfc_expr *arg;
gfc_se argse;
- tree type, result_type, tmp;
+ tree type, result_type, tmp, class_decl = NULL;
+ gfc_symbol *sym;
+ bool unlimited = false;
arg = expr->value.function.actual->expr;
@@ -8261,10 +8263,12 @@ gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
{
if (arg->ts.type == BT_CLASS)
{
+ unlimited = UNLIMITED_POLY (arg);
gfc_add_vptr_component (arg);
gfc_add_size_component (arg);
gfc_conv_expr (&argse, arg);
tmp = fold_convert (result_type, argse.expr);
+ class_decl = gfc_get_class_from_expr (argse.expr);
goto done;
}
@@ -8276,14 +8280,20 @@ gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
{
argse.want_pointer = 0;
gfc_conv_expr_descriptor (&argse, arg);
+ sym = arg->expr_type == EXPR_VARIABLE ? arg->symtree->n.sym : NULL;
if (arg->ts.type == BT_CLASS)
{
- if (arg->rank > 0)
+ unlimited = UNLIMITED_POLY (arg);
+ if (TREE_CODE (argse.expr) == COMPONENT_REF)
+ tmp = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
+ else if (arg->rank > 0 && sym
+ && DECL_LANG_SPECIFIC (sym->backend_decl))
tmp = gfc_class_vtab_size_get (
- GFC_DECL_SAVED_DESCRIPTOR (arg->symtree->n.sym->backend_decl));
+ GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl));
else
- tmp = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
+ gcc_unreachable ();
tmp = fold_convert (result_type, tmp);
+ class_decl = gfc_get_class_from_expr (argse.expr);
goto done;
}
type = gfc_get_element_type (TREE_TYPE (argse.expr));
@@ -8297,6 +8307,9 @@ gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
tmp = fold_convert (result_type, tmp);
done:
+ if (unlimited && class_decl)
+ tmp = gfc_resize_class_size_with_len (NULL, class_decl, tmp);
+
se->expr = fold_build2_loc (input_location, MULT_EXPR, result_type, tmp,
build_int_cst (result_type, BITS_PER_UNIT));
gfc_add_block_to_block (&se->pre, &argse.pre);
@@ -8446,9 +8459,17 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
break;
case BT_CLASS:
if (class_ref != NULL_TREE)
- tmp = gfc_class_vtab_size_get (class_ref);
+ {
+ tmp = gfc_class_vtab_size_get (class_ref);
+ if (UNLIMITED_POLY (source_expr))
+ tmp = gfc_resize_class_size_with_len (NULL, class_ref, tmp);
+ }
else
- tmp = gfc_class_vtab_size_get (argse.expr);
+ {
+ tmp = gfc_class_vtab_size_get (argse.expr);
+ if (UNLIMITED_POLY (source_expr))
+ tmp = gfc_resize_class_size_with_len (NULL, argse.expr, tmp);
+ }
break;
default:
source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
diff --git a/gcc/testsuite/gfortran.dg/storage_size_7.f90 b/gcc/testsuite/gfortran.dg/storage_size_7.f90
new file mode 100644
index 00000000000..e32ca1b6a0e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/storage_size_7.f90
@@ -0,0 +1,91 @@
+! { dg-do run }
+! Fix STORAGE_SIZE intrinsic for polymorphic arguments PR84006 and PR100027.
+! Contributed by Steve Kargl <kar...@comcast.net>
+! and José Rui Faustino de Sousa <jrfso...@gcc.gnu.org>
+program p
+ use, intrinsic :: ISO_FORTRAN_ENV, only: int64
+ type t
+ integer i
+ end type
+ type s
+ class(t), allocatable :: c(:)
+ end type
+ integer :: rslt, class_rslt
+ integer(kind=int64), target :: tgt
+ class(t), allocatable, target :: t_alloc(:)
+ class(s), allocatable, target :: s_alloc(:)
+ character(:), allocatable, target :: chr(:)
+ class(*), pointer :: ptr_s, ptr_a(:)
+
+ allocate (t_alloc(2), source=t(1))
+ rslt = storage_size(t_alloc(1)) ! Scalar arg - the original testcase
+ if (rslt .ne. 32) stop 1
+
+ rslt = storage_size(t_alloc) ! Array arg
+ if (rslt .ne. 32) stop 2
+
+ call pr100027
+
+ allocate (s_alloc(2), source=s([t(1), t(2)]))
+! This, of course, is processor dependent: gfortran gives 576, NAG 448
+! and Intel 1216.
+ class_rslt = storage_size(s_alloc) ! Type with a class component
+ ptr_s => s_alloc(2)
+! However, the unlimited polymorphic result should be the same
+ if (storage_size (ptr_s) .ne. class_rslt) stop 3
+ ptr_a => s_alloc
+ if (storage_size (ptr_a) .ne. class_rslt) stop 4
+
+ rslt = storage_size(s_alloc(1)%c(2)) ! Scalar component arg
+ if (rslt .ne. 32) stop 5
+
+ rslt = storage_size(s_alloc(1)%c) ! Scalar component of array arg
+ if (rslt .ne. 32) stop 6
+
+ ptr_s => tgt
+ rslt = storage_size (ptr_s) ! INTEGER(8) target
+ if (rslt .ne. 64) stop 7
+
+ allocate (chr(2), source = ["abcde", "fghij"])
+ ptr_s => chr(2)
+ rslt = storage_size (ptr_s) ! CHARACTER(5) scalar
+ if (rslt .ne. 40) stop 8
+
+ ptr_a => chr
+ rslt = storage_size (ptr_a) ! CHARACTER(5) array
+ if (rslt .ne. 40) stop 9
+
+ deallocate (t_alloc, s_alloc, chr) ! For valgrind check
+
+contains
+
+! Original testcase from José Rui Faustino de Sousa
+ subroutine pr100027
+ implicit none
+
+ integer, parameter :: n = 11
+
+ type :: foo_t
+ end type foo_t
+
+ type, extends(foo_t) :: bar_t
+ end type bar_t
+
+ class(*), pointer :: apu(:)
+ class(foo_t), pointer :: apf(:)
+ class(bar_t), pointer :: apb(:)
+ type(bar_t), target :: atb(n)
+
+ integer :: m
+
+ apu => atb
+ m = storage_size(apu)
+ if (m .ne. 0) stop 10
+ apf => atb
+ m = storage_size(apf)
+ if (m .ne. 0) stop 11
+ apb => atb
+ m = storage_size(apb)
+ if (m .ne. 0) stop 12
+ end
+end program p
diff --git a/gcc/testsuite/gfortran.dg/transfer_class_4.f90 b/gcc/testsuite/gfortran.dg/transfer_class_4.f90
new file mode 100644
index 00000000000..4babd1f41d9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/transfer_class_4.f90
@@ -0,0 +1,48 @@
+! { dg-do run }
+! Fix TRANSFER intrinsic for unlimited polymorphic arguments - PR98534
+! Contributed by Paul Thomas <pa...@gcc.gnu.org>
+ character(*), parameter :: string = "abcdefgh"
+ class(*), allocatable :: star
+ class(*), allocatable :: star_a(:)
+ character(len=:), allocatable :: chr
+ character(len=5), allocatable :: chr_a(:)
+ integer :: sz, sum1, sum2
+
+! Part 1: worked correctly
+ star = 1.0
+ sz = storage_size (star)/8
+ allocate (character(len=sz) :: chr)
+ chr = transfer (star, chr)
+ sum1 = sum ([(ichar(chr(i:i)), i = 1, sz)])
+ chr = transfer(1.0, chr)
+ sum2 = sum ([(ichar(chr(i:i)), i = 1, sz)])
+
+ if (sz /= kind (1.0)) stop 1
+ if (sum1 /= sum2) stop 2
+
+ deallocate (star) ! The automatic reallocation causes invalid writes
+ ! and memory leaks. Even with this deallocation
+ ! The invalid writes still occur.
+ deallocate (chr)
+
+! Part 2: Got everything wrong because '_len' field of unlimited polymorphic
+! expressions was not used.
+ star = string
+ sz = storage_size (star)/8
+ if (sz /= len (string)) stop 3 ! storage_size failed
+
+ sz = len (string) ! Ignore previous error in storage_size
+ allocate (character(len=sz) :: chr)
+ chr = transfer (star, chr)
+ sum1 = sum ([(ichar(chr(i:i)), i = 1, sz)])
+ chr = transfer(string, chr)
+ sum2 = sum ([(ichar(chr(i:i)), i = 1, sz)])
+ if (sum1 /= sum2) stop 4 ! transfer failed
+
+! Check that arrays are OK for transfer
+ star_a = ['abcde','fghij']
+ allocate (character (len = 5) :: chr_a(2))
+ chr_a = transfer (star_a, chr_a)
+ if (any (chr_a .ne. ['abcde','fghij'])) stop 5
+ deallocate (star, chr, star_a, chr_a)
+end
