From 7bd5dad24907ba68a81365932d442d40460e4ed0 Mon Sep 17 00:00:00 2001 From: Louis Krupp Date: Wed, 18 Jan 2017 21:41:48 +0000 Subject: [PATCH] re PR fortran/50069 (FORALL fails on a character array) 2017-01-18 Louis Krupp 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-18 Louis Krupp 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. From-SVN: r244601 --- gcc/fortran/ChangeLog | 15 ++ gcc/fortran/invoke.texi | 5 + gcc/fortran/lang.opt | 4 + gcc/fortran/trans-expr.c | 6 +- gcc/fortran/trans-stmt.c | 198 +++++++++++---------- gcc/testsuite/ChangeLog | 12 ++ gcc/testsuite/gfortran.dg/pr50069_1.f90 | 9 + gcc/testsuite/gfortran.dg/pr50069_2.f90 | 11 ++ gcc/testsuite/gfortran.dg/pr55086_1.f90 | 63 +++++++ gcc/testsuite/gfortran.dg/pr55086_1_tfat.f90 | 64 +++++++ gcc/testsuite/gfortran.dg/pr55086_2.f90 | 32 ++++ gcc/testsuite/gfortran.dg/pr55086_2_tfat.f90 | 33 ++++ .../gfortran.dg/pr55086_aliasing_dummy_4_tfat.f90 | 40 +++++ 13 files changed, 398 insertions(+), 94 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/pr50069_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/pr50069_2.f90 create mode 100644 gcc/testsuite/gfortran.dg/pr55086_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/pr55086_1_tfat.f90 create mode 100644 gcc/testsuite/gfortran.dg/pr55086_2.f90 create mode 100644 gcc/testsuite/gfortran.dg/pr55086_2_tfat.f90 create mode 100644 gcc/testsuite/gfortran.dg/pr55086_aliasing_dummy_4_tfat.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 0c59ced..17c419f 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,18 @@ +2017-01-18 Louis Krupp + + 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-18 Andre Vehreschild * primary.c (caf_variable_attr): Improve figuring whether the current diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi index e0abbf8..2a89647 100644 --- a/gcc/fortran/invoke.texi +++ b/gcc/fortran/invoke.texi @@ -124,6 +124,7 @@ by type. Explanations are in the following sections. -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 additions of the 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 diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt index 9670bf7..bdc621b 100644 --- a/gcc/fortran/lang.opt +++ b/gcc/fortran/lang.opt @@ -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). diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index ee8e15d..138af56 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2544,8 +2544,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) diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 63f3304..113545b 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -3196,7 +3196,7 @@ forall_make_variable_temp (gfc_code *c, stmtblock_t *pre, stmtblock_t *post) 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 * pdata, stmtblock_t * pblock, 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. */ - if (lss == gfc_ss_terminator) - { - gfc_start_block (&block); + gfc_start_block (&block); - gfc_init_se (&lse, NULL); + gfc_init_se (&rse, NULL); + gfc_init_se (&lse, NULL); - /* Translate the expression. */ + if (lss == gfc_ss_terminator) + { + 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); - - gfc_init_loopinfo (&loop1); - gfc_init_se (&rse, NULL); - gfc_init_se (&lse, NULL); + /* Initialize the loop. */ + gfc_init_loopinfo (&loop); - /* Associate the lss with the loop. */ - gfc_add_ss_to_loop (&loop1, lss); + /* We may need LSS to determine the shape of the expression. */ + gfc_add_ss_to_loop (&loop, lss); - /* Calculate the bounds of the scalarization. */ - gfc_conv_ss_startstride (&loop1); - /* Setup the scalarizing loops. */ - gfc_conv_loop_setup (&loop1, &expr->where); + gfc_conv_ss_startstride (&loop); + gfc_conv_loop_setup (&loop, &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); + + gfc_add_block_to_block (&block, &loop.pre); + gfc_add_block_to_block (&block, &loop.post); - tmp = gfc_finish_block (&block); + 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_expr * expr2, /* 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); + } + 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); } - 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_expr * expr2, 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 * nested_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 * nested_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, bool invert, 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); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index bd946aa..9cd63f3 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,15 @@ +2017-01-18 Louis Krupp + + 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-18 Aaron Sawdey * gcc.dg/strcmp-1.c: New test. * gcc.dg/strncmp-1.c: Add test for a bug that escaped. diff --git a/gcc/testsuite/gfortran.dg/pr50069_1.f90 b/gcc/testsuite/gfortran.dg/pr50069_1.f90 new file mode 100644 index 0000000..74890fa --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr50069_1.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/pr50069_2.f90 b/gcc/testsuite/gfortran.dg/pr50069_2.f90 new file mode 100644 index 0000000..a5046d4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr50069_2.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/pr55086_1.f90 b/gcc/testsuite/gfortran.dg/pr55086_1.f90 new file mode 100644 index 0000000..52306d5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr55086_1.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/pr55086_1_tfat.f90 b/gcc/testsuite/gfortran.dg/pr55086_1_tfat.f90 new file mode 100644 index 0000000..45f6e7b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr55086_1_tfat.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/pr55086_2.f90 b/gcc/testsuite/gfortran.dg/pr55086_2.f90 new file mode 100644 index 0000000..d731da4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr55086_2.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/pr55086_2_tfat.f90 b/gcc/testsuite/gfortran.dg/pr55086_2_tfat.f90 new file mode 100644 index 0000000..7d09ed1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr55086_2_tfat.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/pr55086_aliasing_dummy_4_tfat.f90 b/gcc/testsuite/gfortran.dg/pr55086_aliasing_dummy_4_tfat.f90 new file mode 100644 index 0000000..3c45c0a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr55086_aliasing_dummy_4_tfat.f90 @@ -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 + -- 2.7.4