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/class.cc b/gcc/fortran/class.cc
index 59ac0d97e08..64a0e726eeb 100644
--- a/gcc/fortran/class.cc
+++ b/gcc/fortran/class.cc
@@ -884,11 +884,21 @@ static void
add_proc_comp (gfc_symbol *vtype, const char *name, gfc_typebound_proc *tb)
{
gfc_component *c;
-
+ bool is_abstract = false;
c = gfc_find_component (vtype, name, true, true, NULL);
- if (tb->non_overridable && !tb->overridden && c)
+ /* If the present component typebound proc is abstract, the new version
+ should unconditionally be tested if it is a suitable replacement. */
+ if (c && c->tb && c->tb->u.specific
+ && c->tb->u.specific->n.sym->attr.abstract)
+ is_abstract = true;
+
+ /* Pass on the new tb being not overridable if a component is found and
+ either there is not an overridden specific or the present component
+ tb is abstract. This ensures that possible, viable replacements are
+ loaded. */
+ if (tb->non_overridable && !tb->overridden && !is_abstract && c)
return;
if (c == NULL)
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 0d3845f9ce3..afed8db7852 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -3229,8 +3229,8 @@ static bool check_pure_function (gfc_expr *e)
const char *name = NULL;
code_stack *stack;
bool saw_block = false;
-
- /* A BLOCK construct within a DO CONCURRENT construct leads to
+
+ /* A BLOCK construct within a DO CONCURRENT construct leads to
gfc_do_concurrent_flag = 0 when the check for an impure function
occurs. Check the stack to see if the source code has a nested
BLOCK construct. */
@@ -16305,10 +16305,6 @@ resolve_fl_derived (gfc_symbol *sym)
&& sym->ns->proc_name
&& sym->ns->proc_name->attr.flavor == FL_MODULE
&& sym->attr.access != ACCESS_PRIVATE
- && !(sym->attr.extension
- && sym->attr.zero_comp
- && !sym->f2k_derived->tb_sym_root
- && !sym->f2k_derived->tb_uop_root)
&& !(sym->attr.vtype || sym->attr.pdt_template))
{
gfc_symbol *vtab = gfc_find_derived_vtab (sym);
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 <burnus@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 <pault@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
diff --git a/gcc/testsuite/gfortran.dg/pr117768.f90 b/gcc/testsuite/gfortran.dg/pr117768.f90
new file mode 100644
index 00000000000..f9cf46421c1
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr117768.f90
@@ -0,0 +1,76 @@
+! { dg-do compile }
+!
+! Fix a regession caused by the first patch for PR84674.
+!
+! Contributed by Juergen Reuter <juergen.reuter@desy.de>
+!
+module m1
+ implicit none
+ private
+ public :: t1
+ type, abstract :: t1
+ end type t1
+end module m1
+
+module t_base
+ use m1, only: t1
+ implicit none
+ private
+ public :: t_t
+ type, abstract :: t_t
+ contains
+ procedure (t_out), deferred :: output
+ end type t_t
+
+ abstract interface
+ subroutine t_out (t, handle)
+ import
+ class(t_t), intent(inout) :: t
+ class(t1), intent(inout), optional :: handle
+ end subroutine t_out
+ end interface
+
+end module t_base
+
+
+module t_ascii
+ use m1, only: t1
+ use t_base
+ implicit none
+ private
+
+ type, abstract, extends (t_t) :: t1_t
+ contains
+ procedure :: output => t_ascii_output
+ end type t1_t
+ type, extends (t1_t) :: t2_t
+ end type t2_t
+ type, extends (t1_t) :: t3_t
+ logical :: verbose = .true.
+ end type t3_t
+
+ interface
+ module subroutine t_ascii_output &
+ (t, handle)
+ class(t1_t), intent(inout) :: t
+ class(t1), intent(inout), optional :: handle
+ end subroutine t_ascii_output
+ end interface
+end module t_ascii
+
+submodule (t_ascii) t_ascii_s
+ implicit none
+contains
+ module subroutine t_ascii_output &
+ (t, handle)
+ class(t1_t), intent(inout) :: t
+ class(t1), intent(inout), optional :: handle
+ select type (t)
+ type is (t3_t)
+ type is (t2_t)
+ class default
+ return
+ end select
+ end subroutine t_ascii_output
+end submodule t_ascii_s
+
Change.Logs
Description: Binary data
