Ping: Possible patch for fortran/50069 and fortran/55086
Louis Krupp
louis.krupp@zoho.com
Wed Jan 18 11:44:00 GMT 2017
PR fortran/50069
PR fortran/55086
* trans-expr.c (gfc_conv_variable): Don't treat temporary variables
as function arguments.
* trans-stmt.c (forall_make_variable_temp,
generate_loop_for_temp_to_lhs, gfc_trans_assign_need_temp,
gfc_trans_forall_1): Don't adjust offset of forall temporary
for array sections, make forall temporaries work for substring
expressions, improve test coverage by adding -ftest-forall-temp
option to request usage of temporary array in forall code.
* lang.opt: Add -ftest-forall-temp option.
* invoke.texi: Add -ftest-forall-temp option.
There were problems with temporary arrays created to implement forall vs. substring expressions and array sections. One of the files included in PR50069 had problems with a temporary variable used to hold a function result.
There are two goals: Use temporaries as infrequently as possible, and make sure that when they have to be used, they work. To improve test coverage, I added an option, -ftest-forall-temp, to encourage the forall code to use a temporary if at all possible, and I've added a few test files with this option. The idea was to find problems sooner rather than wait for them to be reported later.
At the moment, check-fortran works with this option set by default with the exception of one test, forall_8.f90, whose purpose is to make sure that a particular forall statement doesn't use a temporary. Yes, it took a long time to get to that point.
The option is of course normally turned off.
I left a couple of TODO comments in the code.
Louis Krupp
-------------- next part --------------
Index: gcc/fortran/ChangeLog
===================================================================
--- gcc/fortran/ChangeLog (revision 244569)
+++ gcc/fortran/ChangeLog (working copy)
@@ -1,3 +1,18 @@
+2017-01-17 Louis Krupp <louis.krupp@zoho.com>
+
+ PR fortran/50069
+ PR fortran/55086
+ * trans-expr.c (gfc_conv_variable): Don't treat temporary variables
+ as function arguments.
+ * trans-stmt.c (forall_make_variable_temp,
+ generate_loop_for_temp_to_lhs, gfc_trans_assign_need_temp,
+ gfc_trans_forall_1): Don't adjust offset of forall temporary
+ for array sections, make forall temporaries work for substring
+ expressions, improve test coverage by adding -ftest-forall-temp
+ option to request usage of temporary array in forall code.
+ * lang.opt: Add -ftest-forall-temp option.
+ * invoke.texi: Add -ftest-forall-temp option.
+
2017-01-13 Andre Vehreschild <vehre@gcc.gnu.org>
PR fortran/70697
Index: gcc/fortran/invoke.texi
===================================================================
--- gcc/fortran/invoke.texi (revision 244569)
+++ gcc/fortran/invoke.texi (working copy)
@@ -124,6 +124,7 @@ by type. Explanations are in the following sectio
-fmax-identifier-length -fmodule-private -ffixed-form -fno-range-check @gol
-fopenacc -fopenmp -freal-4-real-10 -freal-4-real-16 -freal-4-real-8 @gol
-freal-8-real-10 -freal-8-real-16 -freal-8-real-4 -std=@var{std}
+-ftest-forall-temp
}
@item Preprocessing Options
@@ -459,6 +460,10 @@ allows the Fortran 2008 standard including the add
Technical Specification (TS) 29113 on Further Interoperability of Fortran
with C and TS 18508 on Additional Parallel Features in Fortran.
+@item -ftest-forall-temp
+@opindex @code{ftest-forall-temp}
+Enhance test coverage by forcing most forall assignments to use temporary.
+
@end table
@node Preprocessing Options
Index: gcc/fortran/lang.opt
===================================================================
--- gcc/fortran/lang.opt (revision 244569)
+++ gcc/fortran/lang.opt (working copy)
@@ -488,6 +488,10 @@ ffixed-form
Fortran RejectNegative
Assume that the source file is fixed form.
+ftest-forall-temp
+Fortran Var(flag_test_forall_temp) Init(0)
+Force creation of temporary to test infrequently-executed forall code
+
finteger-4-integer-8
Fortran RejectNegative Var(flag_integer4_kind,8)
Interpret any INTEGER(4) as an INTEGER(8).
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c (revision 244569)
+++ gcc/fortran/trans-expr.c (working copy)
@@ -2545,8 +2545,10 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
if (se_expr)
se->expr = se_expr;
- /* Procedure actual arguments. */
- else if (sym->attr.flavor == FL_PROCEDURE
+ /* Procedure actual arguments. Look out for temporary variables
+ with the same attributes as function values. */
+ else if (!sym->attr.temporary
+ && sym->attr.flavor == FL_PROCEDURE
&& se->expr != current_function_decl)
{
if (!sym->attr.dummy && !sym->attr.proc_pointer)
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c (revision 244569)
+++ gcc/fortran/trans-stmt.c (working copy)
@@ -3196,7 +3196,7 @@ forall_make_variable_temp (gfc_code *c, stmtblock_
gfc_add_block_to_block (post, &tse.post);
tse.expr = build_fold_indirect_ref_loc (input_location, tse.expr);
- if (e->ts.type != BT_CHARACTER)
+ if (c->expr1->ref->u.ar.type != AR_SECTION)
{
/* Use the variable offset for the temporary. */
tmp = gfc_conv_array_offset (old_sym->backend_decl);
@@ -3526,114 +3526,103 @@ gfc_do_allocate (tree bytesize, tree size, tree *
static tree
generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3,
- tree count1, tree wheremask, bool invert)
+ tree count1,
+ gfc_ss *lss, gfc_ss *rss,
+ tree wheremask, bool invert)
{
- gfc_ss *lss;
- gfc_se lse, rse;
- stmtblock_t block, body;
- gfc_loopinfo loop1;
+ stmtblock_t block, body1;
+ gfc_loopinfo loop;
+ gfc_se lse;
+ gfc_se rse;
tree tmp;
tree wheremaskexpr;
- /* Walk the lhs. */
- lss = gfc_walk_expr (expr);
+ (void) rss; /* TODO: unused. */
+ gfc_start_block (&block);
+
+ gfc_init_se (&rse, NULL);
+ gfc_init_se (&lse, NULL);
+
if (lss == gfc_ss_terminator)
{
- gfc_start_block (&block);
-
- gfc_init_se (&lse, NULL);
-
- /* Translate the expression. */
+ gfc_init_block (&body1);
gfc_conv_expr (&lse, expr);
-
- /* Form the expression for the temporary. */
- tmp = gfc_build_array_ref (tmp1, count1, NULL);
-
- /* Use the scalar assignment as is. */
- gfc_add_block_to_block (&block, &lse.pre);
- gfc_add_modify (&block, lse.expr, tmp);
- gfc_add_block_to_block (&block, &lse.post);
-
- /* Increment the count1. */
- tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1),
- count1, gfc_index_one_node);
- gfc_add_modify (&block, count1, tmp);
-
- tmp = gfc_finish_block (&block);
+ rse.expr = gfc_build_array_ref (tmp1, count1, NULL);
}
else
{
- gfc_start_block (&block);
+ /* Initialize the loop. */
+ gfc_init_loopinfo (&loop);
- gfc_init_loopinfo (&loop1);
- gfc_init_se (&rse, NULL);
- gfc_init_se (&lse, NULL);
+ /* We may need LSS to determine the shape of the expression. */
+ gfc_add_ss_to_loop (&loop, lss);
- /* Associate the lss with the loop. */
- gfc_add_ss_to_loop (&loop1, lss);
+ gfc_conv_ss_startstride (&loop);
+ gfc_conv_loop_setup (&loop, &expr->where);
- /* Calculate the bounds of the scalarization. */
- gfc_conv_ss_startstride (&loop1);
- /* Setup the scalarizing loops. */
- gfc_conv_loop_setup (&loop1, &expr->where);
-
gfc_mark_ss_chain_used (lss, 1);
+ /* Start the loop body. */
+ gfc_start_scalarized_body (&loop, &body1);
- /* Start the scalarized loop body. */
- gfc_start_scalarized_body (&loop1, &body);
-
- /* Setup the gfc_se structures. */
- gfc_copy_loopinfo_to_se (&lse, &loop1);
+ /* Translate the expression. */
+ gfc_copy_loopinfo_to_se (&lse, &loop);
lse.ss = lss;
+ gfc_conv_expr (&lse, expr);
/* Form the expression of the temporary. */
- if (lss != gfc_ss_terminator)
- rse.expr = gfc_build_array_ref (tmp1, count1, NULL);
- /* Translate expr. */
- gfc_conv_expr (&lse, expr);
+ rse.expr = gfc_build_array_ref (tmp1, count1, NULL);
+ }
- /* Use the scalar assignment. */
- rse.string_length = lse.string_length;
- tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, true);
+ /* Use the scalar assignment. */
+ rse.string_length = lse.string_length;
+ tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts,
+ expr->expr_type == EXPR_VARIABLE, false);
- /* Form the mask expression according to the mask tree list. */
- if (wheremask)
- {
- wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
- if (invert)
- wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
- TREE_TYPE (wheremaskexpr),
- wheremaskexpr);
- tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
- wheremaskexpr, tmp,
- build_empty_stmt (input_location));
- }
+ /* Form the mask expression according to the mask tree list. */
+ if (wheremask)
+ {
+ wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
+ if (invert)
+ wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
+ TREE_TYPE (wheremaskexpr),
+ wheremaskexpr);
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ wheremaskexpr, tmp,
+ build_empty_stmt (input_location));
+ }
- gfc_add_expr_to_block (&body, tmp);
+ gfc_add_expr_to_block (&body1, tmp);
- /* Increment count1. */
- tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
- count1, gfc_index_one_node);
- gfc_add_modify (&body, count1, tmp);
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1),
+ count1, gfc_index_one_node);
+ gfc_add_modify (&body1, count1, tmp);
+ if (lss == gfc_ss_terminator)
+ gfc_add_block_to_block (&block, &body1);
+ else
+ {
/* Increment count3. */
if (count3)
{
tmp = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type, count3,
- gfc_index_one_node);
- gfc_add_modify (&body, count3, tmp);
+ gfc_array_index_type,
+ count3, gfc_index_one_node);
+ gfc_add_modify (&body1, count3, tmp);
}
/* Generate the copying loops. */
- gfc_trans_scalarizing_loops (&loop1, &body);
- gfc_add_block_to_block (&block, &loop1.pre);
- gfc_add_block_to_block (&block, &loop1.post);
- gfc_cleanup_loop (&loop1);
+ gfc_trans_scalarizing_loops (&loop, &body1);
- tmp = gfc_finish_block (&block);
+ gfc_add_block_to_block (&block, &loop.pre);
+ gfc_add_block_to_block (&block, &loop.post);
+
+ gfc_cleanup_loop (&loop);
+ /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
+ as tree nodes in SS may not be valid in different scope. */
}
+
+ tmp = gfc_finish_block (&block);
return tmp;
}
@@ -3989,26 +3978,39 @@ gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_
/* Calculate the size of temporary needed in the assignment. Return loop, lss
and rss which are used in function generate_loop_for_rhs_to_temp(). */
- gfc_init_block (&inner_size_body);
- inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body,
- &lss, &rss);
-
/* The type of LHS. Used in function allocate_temp_for_forall_nest */
- if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->length)
+ if (expr1->ts.type == BT_CHARACTER)
{
- if (!expr1->ts.u.cl->backend_decl)
+ type = NULL;
+ if (expr1->ref && expr1->ref->type == REF_SUBSTRING)
{
- gfc_se tse;
- gfc_init_se (&tse, NULL);
- gfc_conv_expr (&tse, expr1->ts.u.cl->length);
- expr1->ts.u.cl->backend_decl = tse.expr;
+ gfc_se ssse;
+ gfc_init_se (&ssse, NULL);
+ gfc_conv_expr (&ssse, expr1);
+ type = gfc_get_character_type_len (gfc_default_character_kind,
+ ssse.string_length);
}
- type = gfc_get_character_type_len (gfc_default_character_kind,
- expr1->ts.u.cl->backend_decl);
+ else
+ {
+ if (!expr1->ts.u.cl->backend_decl)
+ {
+ gfc_se tse;
+ gcc_assert (expr1->ts.u.cl->length);
+ gfc_init_se (&tse, NULL);
+ gfc_conv_expr (&tse, expr1->ts.u.cl->length);
+ expr1->ts.u.cl->backend_decl = tse.expr;
+ }
+ type = gfc_get_character_type_len (gfc_default_character_kind,
+ expr1->ts.u.cl->backend_decl);
+ }
}
else
type = gfc_typenode_for_spec (&expr1->ts);
+ gfc_init_block (&inner_size_body);
+ inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body,
+ &lss, &rss);
+
/* Allocate temporary for nested forall construct according to the
information in nested_forall_info and inner_size. */
tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type, inner_size,
@@ -4030,8 +4032,14 @@ gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_
if (wheremask)
gfc_add_modify (block, count, gfc_index_zero_node);
+ /* TODO: Second call to compute_inner_temp_size to initialize lss and
+ rss; there must be a better way. */
+ inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body,
+ &lss, &rss);
+
/* Generate codes to copy the temporary to lhs. */
tmp = generate_loop_for_temp_to_lhs (expr1, tmp1, count, count1,
+ lss, rss,
wheremask, invert);
/* Generate body and loops according to the information in
@@ -4488,8 +4496,8 @@ gfc_trans_forall_1 (gfc_code * code, forall_info *
/* Temporaries due to array assignment data dependencies introduce
no end of problems. */
- if (need_temp)
- gfc_trans_assign_need_temp (c->expr1, c->expr2, NULL, false,
+ if (need_temp || flag_test_forall_temp)
+ gfc_trans_assign_need_temp (c->expr1, c->expr2, NULL, false,
nested_forall_info, &block);
else
{
@@ -4517,7 +4525,12 @@ gfc_trans_forall_1 (gfc_code * code, forall_info *
/* Pointer assignment inside FORALL. */
case EXEC_POINTER_ASSIGN:
need_temp = gfc_check_dependency (c->expr1, c->expr2, 0);
- if (need_temp)
+ /* Avoid cases where a temporary would never be needed and where
+ the temp code is guaranteed to fail. */
+ if (need_temp
+ || (flag_test_forall_temp
+ && c->expr2->expr_type != EXPR_CONSTANT
+ && c->expr2->expr_type != EXPR_NULL))
gfc_trans_pointer_assign_need_temp (c->expr1, c->expr2,
nested_forall_info, &block);
else
@@ -5125,7 +5138,8 @@ gfc_trans_where_2 (gfc_code * code, tree mask, boo
if (nested_forall_info != NULL)
{
need_temp = gfc_check_dependency (expr1, expr2, 0);
- if (need_temp && cnext->op != EXEC_ASSIGN_CALL)
+ if ((need_temp || flag_test_forall_temp)
+ && cnext->op != EXEC_ASSIGN_CALL)
gfc_trans_assign_need_temp (expr1, expr2,
cmask, invert,
nested_forall_info, block);
Index: gcc/testsuite/ChangeLog
===================================================================
--- gcc/testsuite/ChangeLog (revision 244569)
+++ gcc/testsuite/ChangeLog (working copy)
@@ -1,3 +1,15 @@
+2017-01-17 Louis Krupp <louis.krupp@zoho.com>
+
+ PR fortran/50069
+ PR fortran/55086
+ * gfortran.dg/pr50069_1.f90: New test.
+ * gfortran.dg/pr50069_2.f90: New test.
+ * gfortran.dg/pr55086_1.f90: New test.
+ * gfortran.dg/pr55086_1_tfat.f90: New test.
+ * gfortran.dg/pr55086_2.f90: New test.
+ * gfortran.dg/pr55086_2_tfat.f90: New test.
+ * gfortran.dg/pr55086_aliasing_dummy_4_tfat.f90: New test.
+
2017-01-17 Joe Seymour <joe.s@somniumtech.com>
* gcc.target/msp430/mul_f5_muldef.c: New test.
Index: gcc/testsuite/gfortran.dg/pr50069_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/pr50069_1.f90 (nonexistent)
+++ gcc/testsuite/gfortran.dg/pr50069_1.f90 (working copy)
@@ -0,0 +1,9 @@
+! { dg-do run }
+
+ implicit none
+ integer i
+ character(LEN=6) :: a(1) = "123456"
+ forall (i = 3:4) a(1)(i:i+2) = a(1)(i-2:i)
+ !print *,a ! displays '12@' must be '121234'
+ IF (a(1) .ne. "121234") call abort
+end
Index: gcc/testsuite/gfortran.dg/pr50069_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/pr50069_2.f90 (nonexistent)
+++ gcc/testsuite/gfortran.dg/pr50069_2.f90 (working copy)
@@ -0,0 +1,11 @@
+! { dg-do compile }
+
+function reverse(string)
+implicit none
+character(len=*), intent(in) :: string
+character(len=:),allocatable :: reverse
+integer i
+reverse = string
+forall (i=1:len(reverse)) reverse(i:i) = &
+ reverse(len(reverse)-i+1:len(reverse)-i+1)
+end function reverse
Index: gcc/testsuite/gfortran.dg/pr55086_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/pr55086_1.f90 (nonexistent)
+++ gcc/testsuite/gfortran.dg/pr55086_1.f90 (working copy)
@@ -0,0 +1,63 @@
+! { dg-do run }
+!
+ implicit none
+ character(len=5), pointer :: a(:), b(:)
+ character(len=5), pointer :: c, d
+ allocate (a(2), b(2), c, d)
+ a = [ "abcde", "ABCDE" ]
+ call aloct_pointer_copy_4 (b, a)
+ !print *, b(1)
+ !print *, b(2)
+ if (any (a /= b)) stop 'WRONG'
+
+ call aloct_copy_4 (b, a)
+ !print *, b(1)
+ !print *, b(2)
+ if (any (a /= b)) stop 'WRONG'
+
+ d = '12345'
+ c = "abcde"
+ call test2 (d, c)
+ !print *, d
+ if (d /= '1cb15') stop 'WRONG'
+
+ call test2p (d, c)
+ !print *, d
+ if (d /= '1cb15') stop 'WRONG'
+
+contains
+ subroutine aloct_pointer_copy_4(o, i)
+ character(len=*), pointer :: o(:), i(:)
+ integer :: nl1, nu1
+ integer :: i1
+ nl1 = lbound(i,dim=1)
+ nu1 = ubound(i,dim=1)
+ forall (i1 = nl1:nu1) o(i1) = i(i1)
+ end subroutine aloct_pointer_copy_4
+ subroutine aloct_copy_4(o, i)
+ character(len=*), pointer :: o(:), i(:)
+ integer :: nl1, nu1
+ integer :: i1
+ nl1 = lbound(i,dim=1)
+ nu1 = ubound(i,dim=1)
+ forall (i1 = nl1:nu1) o(i1) = i(i1)
+ end subroutine aloct_copy_4
+ subroutine test2(o, i)
+ character(len=*) :: o, i
+ integer :: nl1, nu1
+ integer :: i1
+ nl1 = 2
+ nu1 = 4
+ forall (i1 = nl1:nu1) o(i1:i1) = i(i1:i1)
+ forall (i1 = nl1:nu1) o(i1:i1) = o(nu1+1-i1:nu1+1-i1)
+ end subroutine test2
+ subroutine test2p(o, i)
+ character(len=*), pointer :: o, i
+ integer :: nl1, nu1
+ integer :: i1
+ nl1 = 2
+ nu1 = 4
+ forall (i1 = nl1:nu1) o(i1:i1) = i(i1:i1) ! <<<< ICE
+ forall (i1 = nl1:nu1) o(i1:i1) = o(nu1+1-i1:nu1+1-i1)
+ end subroutine test2p
+end
Index: gcc/testsuite/gfortran.dg/pr55086_1_tfat.f90
===================================================================
--- gcc/testsuite/gfortran.dg/pr55086_1_tfat.f90 (nonexistent)
+++ gcc/testsuite/gfortran.dg/pr55086_1_tfat.f90 (working copy)
@@ -0,0 +1,64 @@
+! { dg-do run }
+! { dg-options "-ftest-forall-temp" }
+!
+ implicit none
+ character(len=5), pointer :: a(:), b(:)
+ character(len=5), pointer :: c, d
+ allocate (a(2), b(2), c, d)
+ a = [ "abcde", "ABCDE" ]
+ call aloct_pointer_copy_4 (b, a)
+ !print *, b(1)
+ !print *, b(2)
+ if (any (a /= b)) stop 'WRONG'
+
+ call aloct_copy_4 (b, a)
+ !print *, b(1)
+ !print *, b(2)
+ if (any (a /= b)) stop 'WRONG'
+
+ d = '12345'
+ c = "abcde"
+ call test2 (d, c)
+ !print *, d
+ if (d /= '1cb15') stop 'WRONG'
+
+ call test2p (d, c)
+ !print *, d
+ if (d /= '1cb15') stop 'WRONG'
+
+contains
+ subroutine aloct_pointer_copy_4(o, i)
+ character(len=*), pointer :: o(:), i(:)
+ integer :: nl1, nu1
+ integer :: i1
+ nl1 = lbound(i,dim=1)
+ nu1 = ubound(i,dim=1)
+ forall (i1 = nl1:nu1) o(i1) = i(i1)
+ end subroutine aloct_pointer_copy_4
+ subroutine aloct_copy_4(o, i)
+ character(len=*), pointer :: o(:), i(:)
+ integer :: nl1, nu1
+ integer :: i1
+ nl1 = lbound(i,dim=1)
+ nu1 = ubound(i,dim=1)
+ forall (i1 = nl1:nu1) o(i1) = i(i1)
+ end subroutine aloct_copy_4
+ subroutine test2(o, i)
+ character(len=*) :: o, i
+ integer :: nl1, nu1
+ integer :: i1
+ nl1 = 2
+ nu1 = 4
+ forall (i1 = nl1:nu1) o(i1:i1) = i(i1:i1)
+ forall (i1 = nl1:nu1) o(i1:i1) = o(nu1+1-i1:nu1+1-i1)
+ end subroutine test2
+ subroutine test2p(o, i)
+ character(len=*), pointer :: o, i
+ integer :: nl1, nu1
+ integer :: i1
+ nl1 = 2
+ nu1 = 4
+ forall (i1 = nl1:nu1) o(i1:i1) = i(i1:i1) ! <<<< ICE
+ forall (i1 = nl1:nu1) o(i1:i1) = o(nu1+1-i1:nu1+1-i1)
+ end subroutine test2p
+end
Index: gcc/testsuite/gfortran.dg/pr55086_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/pr55086_2.f90 (nonexistent)
+++ gcc/testsuite/gfortran.dg/pr55086_2.f90 (working copy)
@@ -0,0 +1,32 @@
+! { dg-do run }
+!
+ implicit none
+
+ character(len=7), pointer :: u
+ character(len=7), pointer :: v
+
+ character(len=7), target :: a
+ character(len=7), target :: b
+
+ integer :: j
+
+ b = "1234567"
+ a = "abcdefg"
+
+ u => a
+ v => b
+
+ forall (j = 1:2) a(j:j) = b(j:j)
+
+ if (a /= "12cdefg") call abort
+
+ forall (j = 2:3) a(j:j) = v(j:j)
+ if (a /= "123defg") call abort
+
+ forall (j = 3:4) u(j:j) = b(j:j)
+ if (a /= "1234efg") call abort
+
+ forall (j = 4:5) u(j:j) = v(j:j)
+ if (a /= "12345fg") call abort
+
+end
Index: gcc/testsuite/gfortran.dg/pr55086_2_tfat.f90
===================================================================
--- gcc/testsuite/gfortran.dg/pr55086_2_tfat.f90 (nonexistent)
+++ gcc/testsuite/gfortran.dg/pr55086_2_tfat.f90 (working copy)
@@ -0,0 +1,33 @@
+! { dg-do run }
+! { dg-options "-ftest-forall-temp" }
+!
+ implicit none
+
+ character(len=7), pointer :: u
+ character(len=7), pointer :: v
+
+ character(len=7), target :: a
+ character(len=7), target :: b
+
+ integer :: j
+
+ b = "1234567"
+ a = "abcdefg"
+
+ u => a
+ v => b
+
+ forall (j = 1:2) a(j:j) = b(j:j)
+
+ if (a /= "12cdefg") call abort
+
+ forall (j = 2:3) a(j:j) = v(j:j)
+ if (a /= "123defg") call abort
+
+ forall (j = 3:4) u(j:j) = b(j:j)
+ if (a /= "1234efg") call abort
+
+ forall (j = 4:5) u(j:j) = v(j:j)
+ if (a /= "12345fg") call abort
+
+end
Index: gcc/testsuite/gfortran.dg/pr55086_aliasing_dummy_4_tfat.f90
===================================================================
--- gcc/testsuite/gfortran.dg/pr55086_aliasing_dummy_4_tfat.f90 (nonexistent)
+++ gcc/testsuite/gfortran.dg/pr55086_aliasing_dummy_4_tfat.f90 (working copy)
@@ -0,0 +1,40 @@
+! { dg-do run }
+! { dg-options "-ftest-forall-temp" }
+! This is a copy of aliasing_dummy_4.f90, with an option set to improve
+! test coverage by forcing forall code to use a temporary.
+!
+program test_f90
+
+ integer, parameter :: N = 2
+
+ type test_type
+ integer a(N, N)
+ end type
+
+ type (test_type) s(N, N)
+
+ forall (l = 1:N, m = 1:N) &
+ s(l, m)%a(:, :) = reshape ([((i*l + 10*j*m +100, i = 1, N), j = 1, N)], [N, N])
+
+ call test_sub(s%a(1, 1), 1000) ! Test the original problem.
+
+ if ( any (s(1, 1)%a(:, :) /= reshape ([1111, 112, 121, 122], [2, 2]))) call abort ()
+ if ( any (s(1, 2)%a(:, :) /= reshape ([1121, 122, 141, 142], [2, 2]))) call abort ()
+ if ( any (s(2, 1)%a(:, :) /= reshape ([1112, 114, 122, 124], [2, 2]))) call abort ()
+ if ( any (s(2, 2)%a(:, :) /= reshape ([1122, 124, 142, 144], [2, 2]))) call abort ()
+
+ call test_sub(s(1, 1)%a(:, :), 1000) ! Check "normal" references.
+
+ if ( any (s(1, 1)%a(:, :) /= reshape ([2111,1112,1121,1122], [2, 2]))) call abort ()
+ if ( any (s(1, 2)%a(:, :) /= reshape ([1121, 122, 141, 142], [2, 2]))) call abort ()
+ if ( any (s(2, 1)%a(:, :) /= reshape ([1112, 114, 122, 124], [2, 2]))) call abort ()
+ if ( any (s(2, 2)%a(:, :) /= reshape ([1122, 124, 142, 144], [2, 2]))) call abort ()
+contains
+ subroutine test_sub(array, offset)
+ integer array(:, :), offset
+
+ forall (i = 1:N, j = 1:N) &
+ array(i, j) = array(i, j) + offset
+ end subroutine
+end program
+
More information about the Fortran
mailing list