Hi Harald,
Sorry about that - it was the standard HEAD versus HEAD~ mistake.
Thanks for pointing it out.
Paul
On Fri, 29 Nov 2024 at 17:31, Harald Anlauf <anl...@gmx.de> wrote:
> Hi Paul,
>
> the patch seems to contain stuff that has already been pushed
> (gcc/testsuite/gfortran.dg/pr117768.f90, and the chunks in
> class.cc and resolve.cc). Can you please check?
>
> Cheers,
> Harald
>
> Am 29.11.24 um 17:34 schrieb Paul Richard Thomas:
> > Hi All,
> >
> > This patch was originally pushed as r15-2739. Subsequently memory faults
> > were found and so the patch was reverted. At the time, I could find where
> > the problem lay. This morning I had another look and found it almost
> > immediately :-)
> >
> > The fix is the 'gfc_resize_class_size_with_len' in the chunk '@@ -1595,14
> > +1629,51 @@ gfc_trans_create_temp_array '. Without it,, half as much
> memory
> > as needed was being provided by the allocation and so accesses were
> > occurring outside the allocated space. Valgrind now reports no errors.
> >
> > Regression tests with flying colours - OK for mainline?
> >
> > Paul
> >
>
>
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index a458af322ce..870f2920ddc 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1325,23 +1325,28 @@ get_array_ref_dim_for_loop_dim (gfc_ss *ss, int loop_dim)
is a class expression. */
static tree
-get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype)
+get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype,
+ gfc_ss **fcnss)
{
+ gfc_ss *loop_ss = ss->loop->ss;
gfc_ss *lhs_ss;
gfc_ss *rhs_ss;
+ gfc_ss *fcn_ss = NULL;
tree tmp;
tree tmp2;
tree vptr;
- tree rhs_class_expr = NULL_TREE;
+ tree class_expr = NULL_TREE;
tree lhs_class_expr = NULL_TREE;
bool unlimited_rhs = false;
bool unlimited_lhs = false;
bool rhs_function = false;
+ bool unlimited_arg1 = false;
gfc_symbol *vtab;
+ tree cntnr = NULL_TREE;
/* The second element in the loop chain contains the source for the
- temporary; ie. the rhs of the assignment. */
- rhs_ss = ss->loop->ss->loop_chain;
+ class temporary created in gfc_trans_create_temp_array. */
+ rhs_ss = loop_ss->loop_chain;
if (rhs_ss != gfc_ss_terminator
&& rhs_ss->info
@@ -1350,28 +1355,58 @@ get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype)
&& rhs_ss->info->data.array.descriptor)
{
if (rhs_ss->info->expr->expr_type != EXPR_VARIABLE)
- rhs_class_expr
+ class_expr
= gfc_get_class_from_expr (rhs_ss->info->data.array.descriptor);
else
- rhs_class_expr = gfc_get_class_from_gfc_expr (rhs_ss->info->expr);
+ class_expr = gfc_get_class_from_gfc_expr (rhs_ss->info->expr);
unlimited_rhs = UNLIMITED_POLY (rhs_ss->info->expr);
if (rhs_ss->info->expr->expr_type == EXPR_FUNCTION)
rhs_function = true;
}
+ /* Usually, ss points to the function. When the function call is an actual
+ argument, it is instead rhs_ss because the ss chain is shifted by one. */
+ *fcnss = fcn_ss = rhs_function ? rhs_ss : ss;
+
+ /* If this is a transformational function with a class result, the info
+ class_container field points to the class container of arg1. */
+ if (class_expr != NULL_TREE
+ && fcn_ss->info && fcn_ss->info->expr
+ && fcn_ss->info->expr->expr_type == EXPR_FUNCTION
+ && fcn_ss->info->expr->value.function.isym
+ && fcn_ss->info->expr->value.function.isym->transformational)
+ {
+ cntnr = ss->info->class_container;
+ unlimited_arg1
+ = UNLIMITED_POLY (fcn_ss->info->expr->value.function.actual->expr);
+ }
+
/* For an assignment the lhs is the next element in the loop chain.
If we have a class rhs, this had better be a class variable
- expression! */
+ expression! Otherwise, the class container from arg1 can be used
+ to set the vptr and len fields of the result class container. */
lhs_ss = rhs_ss->loop_chain;
- if (lhs_ss != gfc_ss_terminator
- && lhs_ss->info
- && lhs_ss->info->expr
+ if (lhs_ss && lhs_ss != gfc_ss_terminator
+ && lhs_ss->info && lhs_ss->info->expr
&& lhs_ss->info->expr->expr_type ==EXPR_VARIABLE
&& lhs_ss->info->expr->ts.type == BT_CLASS)
{
tmp = lhs_ss->info->data.array.descriptor;
unlimited_lhs = UNLIMITED_POLY (rhs_ss->info->expr);
}
+ else if (cntnr != NULL_TREE)
+ {
+ tmp = gfc_class_vptr_get (class_expr);
+ gfc_add_modify (pre, tmp, fold_convert (TREE_TYPE (tmp),
+ gfc_class_vptr_get (cntnr)));
+ if (unlimited_rhs)
+ {
+ tmp = gfc_class_len_get (class_expr);
+ if (unlimited_arg1)
+ gfc_add_modify (pre, tmp, gfc_class_len_get (cntnr));
+ }
+ tmp = NULL_TREE;
+ }
else
tmp = NULL_TREE;
@@ -1379,35 +1414,33 @@ get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype)
if (tmp != NULL_TREE && lhs_ss->loop_chain == gfc_ss_terminator)
lhs_class_expr = gfc_get_class_from_expr (tmp);
else
- return rhs_class_expr;
+ return class_expr;
gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (lhs_class_expr)));
/* Set the lhs vptr and, if necessary, the _len field. */
- if (rhs_class_expr)
+ if (class_expr)
{
/* Both lhs and rhs are class expressions. */
tmp = gfc_class_vptr_get (lhs_class_expr);
gfc_add_modify (pre, tmp,
fold_convert (TREE_TYPE (tmp),
- gfc_class_vptr_get (rhs_class_expr)));
+ gfc_class_vptr_get (class_expr)));
if (unlimited_lhs)
{
+ gcc_assert (unlimited_rhs);
tmp = gfc_class_len_get (lhs_class_expr);
- if (unlimited_rhs)
- tmp2 = gfc_class_len_get (rhs_class_expr);
- else
- tmp2 = build_int_cst (TREE_TYPE (tmp), 0);
+ tmp2 = gfc_class_len_get (class_expr);
gfc_add_modify (pre, tmp, tmp2);
}
if (rhs_function)
{
- tmp = gfc_class_data_get (rhs_class_expr);
+ tmp = gfc_class_data_get (class_expr);
gfc_conv_descriptor_offset_set (pre, tmp, gfc_index_zero_node);
}
}
- else
+ else if (rhs_ss->info->data.array.descriptor)
{
/* lhs is class and rhs is intrinsic or derived type. */
*eltype = TREE_TYPE (rhs_ss->info->data.array.descriptor);
@@ -1435,7 +1468,7 @@ get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype)
}
}
- return rhs_class_expr;
+ return class_expr;
}
@@ -1476,6 +1509,7 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
tree or_expr;
tree elemsize;
tree class_expr = NULL_TREE;
+ gfc_ss *fcn_ss = NULL;
int n, dim, tmp_dim;
int total_dim = 0;
@@ -1495,7 +1529,7 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
The descriptor can be obtained from the ss->info and then converted
to the class object. */
if (class_expr == NULL_TREE && GFC_CLASS_TYPE_P (eltype))
- class_expr = get_class_info_from_ss (pre, ss, &eltype);
+ class_expr = get_class_info_from_ss (pre, ss, &eltype, &fcn_ss);
/* If the dynamic type is not available, use the declared type. */
if (eltype && GFC_CLASS_TYPE_P (eltype))
@@ -1595,14 +1629,51 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
gfc_add_expr_to_block (pre, build1 (DECL_EXPR,
arraytype, TYPE_NAME (arraytype)));
- if (class_expr != NULL_TREE)
+ if (class_expr != NULL_TREE
+ || (fcn_ss && fcn_ss->info && fcn_ss->info->class_container))
{
tree class_data;
tree dtype;
+ gfc_expr *expr1 = fcn_ss ? fcn_ss->info->expr : NULL;
- /* Create a class temporary. */
- tmp = gfc_create_var (TREE_TYPE (class_expr), "ctmp");
- gfc_add_modify (pre, tmp, class_expr);
+ /* Create a class temporary for the result using the lhs class object. */
+ if (class_expr != NULL_TREE)
+ {
+ tmp = gfc_create_var (TREE_TYPE (class_expr), "ctmp");
+ gfc_add_modify (pre, tmp, class_expr);
+ }
+ else
+ {
+ tree vptr;
+ class_expr = fcn_ss->info->class_container;
+ gcc_assert (expr1);
+
+ /* Build a new class container using the arg1 class object. The class
+ typespec must be rebuilt because the rank might have changed. */
+ gfc_typespec ts = CLASS_DATA (expr1)->ts;
+ symbol_attribute attr = CLASS_DATA (expr1)->attr;
+ gfc_change_class (&ts, &attr, NULL, expr1->rank, 0);
+ tmp = gfc_create_var (gfc_typenode_for_spec (&ts), "ctmp");
+ fcn_ss->info->class_container = tmp;
+
+ /* Set the vptr and obtain the element size. */
+ vptr = gfc_class_vptr_get (tmp);
+ gfc_add_modify (pre, vptr,
+ fold_convert (TREE_TYPE (vptr),
+ gfc_class_vptr_get (class_expr)));
+ elemsize = gfc_class_vtab_size_get (class_expr);
+
+ /* Set the _len field, if necessary. */
+ if (UNLIMITED_POLY (expr1))
+ {
+ gfc_add_modify (pre, gfc_class_len_get (tmp),
+ gfc_class_len_get (class_expr));
+ elemsize = gfc_resize_class_size_with_len (pre, class_expr,
+ elemsize);
+ }
+
+ elemsize = gfc_evaluate_now (elemsize, pre);
+ }
/* Assign the new descriptor to the _data field. This allows the
vptr _copy to be used for scalarized assignment since the class
@@ -1612,11 +1683,25 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
TREE_TYPE (desc), desc);
gfc_add_modify (pre, class_data, tmp);
- /* Take the dtype from the class expression. */
- dtype = gfc_conv_descriptor_dtype (gfc_class_data_get (class_expr));
- tmp = gfc_conv_descriptor_dtype (class_data);
- gfc_add_modify (pre, tmp, dtype);
+ if (expr1 && expr1->expr_type == EXPR_FUNCTION
+ && expr1->value.function.isym
+ && (expr1->value.function.isym->id == GFC_ISYM_RESHAPE
+ || expr1->value.function.isym->id == GFC_ISYM_UNPACK))
+ {
+ /* Take the dtype from the class expression. */
+ dtype = gfc_conv_descriptor_dtype (gfc_class_data_get (class_expr));
+ tmp = gfc_conv_descriptor_dtype (class_data);
+ gfc_add_modify (pre, tmp, dtype);
+ /* Transformational functions reshape and reduce can change the rank. */
+ if (fcn_ss && fcn_ss->info && fcn_ss->info->class_container)
+ {
+ tmp = gfc_conv_descriptor_rank (class_data);
+ gfc_add_modify (pre, tmp,
+ build_int_cst (TREE_TYPE (tmp), ss->loop->dimen));
+ fcn_ss->info->class_container = NULL_TREE;
+ }
+ }
/* Point desc to the class _data field. */
desc = class_data;
}
@@ -6073,6 +6158,14 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
tmp = gfc_conv_descriptor_dtype (descriptor);
gfc_add_modify (pblock, tmp, gfc_conv_descriptor_dtype (expr3_desc));
}
+ else if (expr->ts.type == BT_CLASS
+ && expr3 && expr3->ts.type != BT_CLASS
+ && expr3_elem_size != NULL_TREE && expr3_desc == NULL_TREE)
+ {
+ tmp = gfc_conv_descriptor_elem_len (descriptor);
+ gfc_add_modify (pblock, tmp,
+ fold_convert (TREE_TYPE (tmp), expr3_elem_size));
+ }
else
{
tmp = gfc_conv_descriptor_dtype (descriptor);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 41d06a99f75..3718b0e645b 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -1242,6 +1242,21 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
stmtblock_t block;
bool full_array = false;
+ /* Class transformational function results are the data field of a class
+ temporary and so the class expression can be obtained directly. */
+ if (e->expr_type == EXPR_FUNCTION
+ && e->value.function.isym
+ && e->value.function.isym->transformational
+ && TREE_CODE (parmse->expr) == COMPONENT_REF
+ && !GFC_CLASS_TYPE_P (TREE_TYPE (parmse->expr)))
+ {
+ parmse->expr = TREE_OPERAND (parmse->expr, 0);
+ if (!VAR_P (parmse->expr))
+ parmse->expr = gfc_evaluate_now (parmse->expr, &parmse->pre);
+ parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
+ return;
+ }
+
gfc_init_block (&block);
class_ref = NULL;
@@ -6490,7 +6505,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
gfc_component *comp = NULL;
int arglen;
unsigned int argc;
-
+ tree arg1_cntnr = NULL_TREE;
arglist = NULL;
retargs = NULL;
stringargs = NULL;
@@ -6498,6 +6513,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
var = NULL_TREE;
len = NULL_TREE;
gfc_clear_ts (&ts);
+ gfc_intrinsic_sym *isym = expr && expr->rank ?
+ expr->value.function.isym : NULL;
comp = gfc_get_proc_ptr_comp (expr);
@@ -7601,6 +7618,19 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
e->representation.length);
}
+ /* Make the class container for the first argument available with class
+ valued transformational functions. */
+ if (argc == 0 && e && e->ts.type == BT_CLASS
+ && isym && isym->transformational
+ && se->ss && se->ss->info)
+ {
+ arg1_cntnr = parmse.expr;
+ if (POINTER_TYPE_P (TREE_TYPE (arg1_cntnr)))
+ arg1_cntnr = build_fold_indirect_ref_loc (input_location, arg1_cntnr);
+ arg1_cntnr = gfc_get_class_from_expr (arg1_cntnr);
+ se->ss->info->class_container = arg1_cntnr;
+ }
+
if (fsym && e)
{
/* Obtain the character length of an assumed character length
@@ -8211,6 +8241,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
/* Set the type of the array. */
tmp = gfc_typenode_for_spec (&ts);
+ tmp = arg1_cntnr ? TREE_TYPE (arg1_cntnr) : tmp;
gcc_assert (se->ss->dimen == se->loop->dimen);
/* Evaluate the bounds of the result, if known. */
@@ -8495,8 +8526,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
argument is actually given. */
arg = expr->value.function.actual;
if (result && arg && expr->rank
- && expr->value.function.isym
- && expr->value.function.isym->transformational
+ && isym && isym->transformational
&& arg->expr
&& arg->expr->ts.type == BT_DERIVED
&& arg->expr->ts.u.derived->attr.alloc_comp)
@@ -11495,7 +11525,7 @@ realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
result to the original descriptor. */
static void
-fcncall_realloc_result (gfc_se *se, int rank)
+fcncall_realloc_result (gfc_se *se, int rank, tree dtype)
{
tree desc;
tree res_desc;
@@ -11514,7 +11544,10 @@ fcncall_realloc_result (gfc_se *se, int rank)
/* Unallocated, the descriptor does not have a dtype. */
tmp = gfc_conv_descriptor_dtype (desc);
- gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
+ if (dtype != NULL_TREE)
+ gfc_add_modify (&se->pre, tmp, dtype);
+ else
+ gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
res_desc = gfc_evaluate_now (desc, &se->pre);
gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
@@ -11731,7 +11764,19 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
ss->is_alloc_lhs = 1;
}
else
- fcncall_realloc_result (&se, expr1->rank);
+ {
+ tree dtype = NULL_TREE;
+ tree type = gfc_typenode_for_spec (&expr2->ts);
+ if (expr1->ts.type == BT_CLASS)
+ {
+ tmp = gfc_class_vptr_get (sym->backend_decl);
+ tree tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts));
+ tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2);
+ gfc_add_modify (&se.pre, tmp, tmp2);
+ dtype = gfc_get_dtype_rank_type (expr1->rank,type);
+ }
+ fcncall_realloc_result (&se, expr1->rank, dtype);
+ }
}
gfc_conv_function_expr (&se, expr2);
diff --git a/gcc/testsuite/gfortran.dg/class_transformational_1.f90 b/gcc/testsuite/gfortran.dg/class_transformational_1.f90
new file mode 100644
index 00000000000..42e30926a05
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_transformational_1.f90
@@ -0,0 +1,206 @@
+! { dg-do run }
+!
+! Test transformational intrinsics with class results - PR102689
+!
+! Contributed by Tobias Burnus <bur...@gcc.gnu.org>
+!
+module tests
+ type t
+ integer :: i
+ end type t
+ type, extends(t) :: s
+ integer :: j
+ end type
+
+contains
+
+ subroutine class_bar(x)
+ class(*), intent(in) :: x(..)
+ integer :: checksum
+
+ if (product (shape (x)) .ne. 10) stop 1
+ select rank (x)
+ rank (1)
+ select type (x)
+ type is (s)
+ if (sum(x%i) .ne. 55) stop 2
+ if ((sum(x%j) .ne. 550) .and. (sum(x%j) .ne. 110)) stop 3
+ type is (character(*))
+ checksum = sum(ichar(x(:)(1:1)) + ichar(x(:)(2:2)))
+ if ((checksum .ne. 1490) .and. (checksum .ne. 2130)) stop 4
+ class default
+ stop
+ end select
+ rank (2)
+ select type (x)
+ type is (s)
+ if (sum(x%i) .ne. 55) stop 5
+ if (sum(x%j) .ne. 550) stop 6
+ type is (character(*));
+ checksum = sum(ichar(x(:,:)(1:1)) + ichar(x(:,:)(2:2)))
+ if ((checksum .ne. 1490) .and. (checksum .ne. 2130)) stop 7
+ class default
+ stop 8
+ end select
+ rank (3)
+ select type (x)
+ type is (s)
+ if (sum(x%i) .ne. 55) stop 9
+ if ((sum(x%j) .ne. 550) .and. (sum(x%j) .ne. 110)) stop 10
+ type is (character(*))
+ checksum = sum(ichar(x(:,:,:)(1:1)) + ichar(x(:,:,:)(2:2)))
+ if ((checksum .ne. 1490) .and. (checksum .ne. 2130)) stop 11
+ class default
+ stop 12
+ end select
+ end select
+ end
+end module tests
+
+Module class_tests
+ use tests
+ implicit none
+ private
+ public :: test_class
+
+ integer :: j
+ integer :: src(10)
+ type (s), allocatable :: src3 (:,:,:)
+ class(t), allocatable :: B(:,:,:), D(:)
+
+! gfortran gave type(t) for D for all these test cases.
+contains
+
+ subroutine test_class
+
+ src3 = reshape ([(s(j,j*10), j=1,10)], [1,10,1])
+ call test1 ! Now D OK for gfc15. B OK back to gfc10
+ call foo
+
+ call class_rebar(reshape(B, [10])) ! This is the original failure - run time segfault
+
+ deallocate (B, D)
+
+ allocate(B(2,1,5), source = s(1,11)) ! B was OK but descriptor elem_len = 4 so....
+ src = [(j, j=1,10)]
+ call test2 ! D%j was type(t) and filled with B[1:5]
+ call foo
+ deallocate (B,D)
+
+ call test3 ! B is set to type(t) and filled with [s(1,11)..s(5,50)]
+ call foo
+ deallocate (B,D)
+
+ B = src3 ! Now D was like B in test3. B OK back to gfc10
+ call foo
+ deallocate (B, D)
+ if (allocated (src3)) deallocate (src3)
+ end
+
+ subroutine class_rebar (arg)
+ class(t) :: arg(:)
+ call class_bar (arg)
+ end
+
+ subroutine test1
+ allocate(B, source = src3)
+ end
+
+ subroutine test2
+ B%i = RESHAPE(src, shape(B))
+ end
+
+ subroutine test3
+ B = reshape ([(s(j,j*10), j=1,10)], shape(B))
+ end
+
+ subroutine foo
+ D = reshape(B, [10])
+ call class_bar(B)
+ call class_bar(D)
+ end
+end module class_tests
+
+module unlimited_tests
+ use tests
+ implicit none
+ private
+ public :: test_unlimited
+
+ integer :: j
+ integer :: src(10)
+ character(len = 2, kind = 1) :: chr(10)
+ character(len = 2, kind = 1) :: chr3(5, 2, 1)
+ type (s), allocatable :: src3 (:,:,:)
+ class(*), allocatable :: B(:,:,:), D(:)
+
+contains
+ subroutine test_unlimited
+ call test1
+ call foo
+
+ call unlimited_rebar(reshape(B, [10])) ! Unlimited version of the original failure
+
+ deallocate (B, D)
+
+ call test3
+ call foo
+ deallocate (B,D)
+
+ B = src3
+ call foo
+ deallocate (B, D)
+
+ B = reshape ([(char(64 + 2*j - 1)//char(64 + 2*j), j = 1,10)], [5, 1, 2])
+ call foo
+ deallocate (B, D)
+
+ chr = [(char(96 + 2*j - 1)//char(96 + 2*j), j = 1,10)]
+ B = reshape (chr, [5, 1, 2])
+ call foo
+
+ call unlimited_rebar(reshape(B, [10])) ! Unlimited/ character version of the original failure
+
+ deallocate (B, D)
+
+ chr3 = reshape (chr, shape(chr3))
+ B = chr3
+ call foo
+ deallocate (B, D)
+ if (allocated (src3)) deallocate (src3)
+ end
+
+ subroutine unlimited_rebar (arg)
+ class(*) :: arg(:)
+ call class_bar (arg)
+ end
+
+ subroutine test1
+ src3 = reshape ([(s(j,j*10), j=1,10)], [2,1,5])
+ allocate(B, source = src3)
+ end
+
+ subroutine test3
+ B = reshape ([(s(j,j*10), j=1,10)], shape(B))
+ end
+
+ subroutine foo
+ D = reshape(B, [10])
+ call class_bar(B)
+ call class_bar(D)
+ end
+
+end module unlimited_tests
+
+ call t1
+ call t2
+contains
+ subroutine t1
+ use class_tests
+ call test_class
+ end
+ subroutine t2
+ use unlimited_tests
+ call test_unlimited
+ end
+end
diff --git a/gcc/testsuite/gfortran.dg/class_transformational_2.f90 b/gcc/testsuite/gfortran.dg/class_transformational_2.f90
new file mode 100644
index 00000000000..01d04a4700d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_transformational_2.f90
@@ -0,0 +1,104 @@
+! { dg-do run }
+!
+! Test transformational intrinsics other than reshape with class results.
+! This emerged from PR102689, for which class_transformational_1.f90 tests
+! class-valued reshape.
+!
+! Contributed by Paul Thomas <pa...@gcc.gnu.org>
+!
+ type t
+ integer :: i
+ end type t
+ type, extends(t) :: s
+ integer :: j
+ end type
+ class(t), allocatable :: scalar, a(:), aa(:), b(:,:), c(:,:,:), field(:,:,:)
+ integer, allocatable :: ishape(:), ii(:), ij(:)
+ logical :: la(2), lb(2,2), lc (4,2,2)
+ integer :: j, stop_flag
+
+ call check_spread
+ call check_pack
+ call check_unpack
+ call check_eoshift
+ call check_eoshift_dep
+ deallocate (a, aa, b, c, field, ishape, ii, ij)
+contains
+ subroutine check_result_a (shift)
+ type (s), allocatable :: ss(:)
+ integer :: shift
+ select type (aa)
+ type is (s)
+ ss = eoshift (aa, shift = shift, boundary = aa(1), dim = 1)
+ ishape = shape (aa);
+ ii = ss%i
+ ij = ss%j
+ end select
+ if (any (ishape .ne. shape (a))) stop stop_flag + 1
+ select type (a)
+ type is (s)
+ if (any (a%i .ne. ii)) stop stop_flag + 2
+ if (any (a%j .ne. ij)) stop stop_flag + 3
+ end select
+ end
+
+ subroutine check_result
+ if (any (shape (c) .ne. ishape)) stop stop_flag + 1
+ select type (a)
+ type is (s)
+ if (any (a%i .ne. ii)) stop stop_flag + 2
+ if (any (a%j .ne. ij)) stop stop_flag + 3
+ end select
+ end
+
+ subroutine check_spread
+ stop_flag = 10
+ a = [(s(j,10*j), j = 1,2)]
+ b = spread (a, dim = 2, ncopies = 2)
+ c = spread (b, dim = 1, ncopies = 4)
+ a = reshape (c, [size (c)])
+ ishape = [4,2,2]
+ ii = [1,1,1,1,2,2,2,2,1,1,1,1,2,2,2,2]
+ ij = 10*[1,1,1,1,2,2,2,2,1,1,1,1,2,2,2,2]
+ call check_result
+ end
+
+ subroutine check_pack
+ stop_flag = 20
+ la = [.false.,.true.]
+ lb = spread (la, dim = 2, ncopies = 2)
+ lc = spread (lb, dim = 1, ncopies = 4)
+ a = pack (c, mask = lc)
+ ishape = shape (lc)
+ ii = [2,2,2,2,2,2,2,2]
+ ij = 10*[2,2,2,2,2,2,2,2]
+ call check_result
+ end
+
+ subroutine check_unpack
+ stop_flag = 30
+ a = [(s(j,10*j), j = 1,16)]
+ field = reshape ([(s(100*j,1000*j), j = 1,16)], shape(lc))
+ c = unpack (a, mask = lc, field = field)
+ a = reshape (c, [product (shape (lc))])
+ ishape = shape (lc)
+ ii = [100,200,300,400,1,2,3,4,900,1000,1100,1200,5,6,7,8]
+ ij = [1000,2000,3000,4000,10,20,30,40,9000,10000, 11000,12000,50,60,70,80]
+ call check_result
+ end
+
+ subroutine check_eoshift
+ type (s), allocatable :: ss(:)
+ stop_flag = 40
+ aa = a
+ a = eoshift (aa, shift = 3, boundary = aa(1), dim = 1)
+ call check_result_a (3)
+ end
+
+ subroutine check_eoshift_dep
+ stop_flag = 50
+ aa = a
+ a = eoshift (a, shift = -3, boundary = a(1), dim = 1)
+ call check_result_a (-3)
+ end
+end
