From fcf3be37e2200181983c150fa36c2fd2ba249b8e Mon Sep 17 00:00:00 2001 From: Jakub Jelinek Date: Mon, 11 Jul 2005 09:34:33 +0200 Subject: [PATCH] trans-stmt.c (gfc_trans_forall_loop): Clear maskindex before the outermost loop. * trans-stmt.c (gfc_trans_forall_loop): Clear maskindex before the outermost loop. (gfc_trans_assign_need_temp, gfc_trans_pointer_assign_need_temp, gfc_trans_forall_1, gfc_evaluate_where_mask, gfc_trans_where_2): Don't clear maskindexes here. * gfortran.fortran-torture/execute/forall_7.f90: New test. From-SVN: r101865 --- gcc/fortran/ChangeLog | 8 ++ gcc/fortran/trans-stmt.c | 134 +++--------------- gcc/testsuite/ChangeLog | 4 + .../execute/forall_7.f90 | 88 ++++++++++++ 4 files changed, 116 insertions(+), 118 deletions(-) create mode 100644 gcc/testsuite/gfortran.fortran-torture/execute/forall_7.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 4d6a44bd7f4..2ccc249e117 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,11 @@ +2005-07-11 Jakub Jelinek + + * trans-stmt.c (gfc_trans_forall_loop): Clear maskindex before + the outermost loop. + (gfc_trans_assign_need_temp, gfc_trans_pointer_assign_need_temp, + gfc_trans_forall_1, gfc_evaluate_where_mask, gfc_trans_where_2): + Don't clear maskindexes here. + 2005-07-08 Daniel Berlin * trans-decl.c (create_function_arglist): DECL_ARG_TYPE_AS_WRITTEN diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 8fda557de1b..0ec029fa5dd 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -1331,7 +1331,7 @@ gfc_trans_forall_loop (forall_info *forall_tmp, int nvar, tree body, int mask_fl stmtblock_t block; tree exit_label; tree count; - tree var, start, end, step, mask, maskindex; + tree var, start, end, step; iter_info *iter; iter = forall_tmp->this_loop; @@ -1366,17 +1366,14 @@ gfc_trans_forall_loop (forall_info *forall_tmp, int nvar, tree body, int mask_fl /* Advance to the next mask element. Only do this for the innermost loop. */ - if (n == 0 && mask_flag) - { - mask = forall_tmp->mask; - maskindex = forall_tmp->maskindex; - if (mask) - { - tmp = build2 (PLUS_EXPR, gfc_array_index_type, - maskindex, gfc_index_one_node); - gfc_add_modify_expr (&block, maskindex, tmp); - } - } + if (n == 0 && mask_flag && forall_tmp->mask) + { + tree maskindex = forall_tmp->maskindex; + tmp = build2 (PLUS_EXPR, gfc_array_index_type, + maskindex, gfc_index_one_node); + gfc_add_modify_expr (&block, maskindex, tmp); + } + /* Decrement the loop counter. */ tmp = build2 (MINUS_EXPR, TREE_TYPE (var), count, gfc_index_one_node); gfc_add_modify_expr (&block, count, tmp); @@ -1387,6 +1384,12 @@ gfc_trans_forall_loop (forall_info *forall_tmp, int nvar, tree body, int mask_fl gfc_init_block (&block); gfc_add_modify_expr (&block, var, start); + /* Initialize maskindex counter. Only do this before the + outermost loop. */ + if (n == nvar - 1 && mask_flag && forall_tmp->mask) + gfc_add_modify_expr (&block, forall_tmp->maskindex, + gfc_index_zero_node); + /* Initialize the loop counter. */ tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (var), step, start); tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (var), end, tmp); @@ -1930,8 +1933,6 @@ gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, tree wheremask, tree count, count1; tree tmp, tmp1; tree ptemp1; - tree mask, maskindex; - forall_info *forall_tmp; stmtblock_t inner_size_body; /* Create vars. count1 is the current iterator number of the nested @@ -1964,17 +1965,6 @@ gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, tree wheremask, tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type, inner_size, &inner_size_body, block, &ptemp1); - /* Initialize the maskindexes. */ - forall_tmp = nested_forall_info; - while (forall_tmp != NULL) - { - mask = forall_tmp->mask; - maskindex = forall_tmp->maskindex; - if (mask) - gfc_add_modify_expr (block, maskindex, gfc_index_zero_node); - forall_tmp = forall_tmp->next_nest; - } - /* Generate codes to copy rhs to the temporary . */ tmp = generate_loop_for_rhs_to_temp (expr2, tmp1, count, count1, lss, rss, wheremask); @@ -1987,17 +1977,6 @@ gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, tree wheremask, /* Reset count1. */ gfc_add_modify_expr (block, count1, gfc_index_zero_node); - /* Reset maskindexed. */ - forall_tmp = nested_forall_info; - while (forall_tmp != NULL) - { - mask = forall_tmp->mask; - maskindex = forall_tmp->maskindex; - if (mask) - gfc_add_modify_expr (block, maskindex, gfc_index_zero_node); - forall_tmp = forall_tmp->next_nest; - } - /* Reset count. */ if (wheremask) gfc_add_modify_expr (block, count, gfc_index_zero_node); @@ -2040,8 +2019,6 @@ gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, stmtblock_t body; tree count; tree tmp, tmp1, ptemp1; - tree mask, maskindex; - forall_info *forall_tmp; count = gfc_create_var (gfc_array_index_type, "count"); gfc_add_modify_expr (block, count, gfc_index_zero_node); @@ -2075,17 +2052,6 @@ gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, tmp = gfc_finish_block (&body); - /* Initialize the maskindexes. */ - forall_tmp = nested_forall_info; - while (forall_tmp != NULL) - { - mask = forall_tmp->mask; - maskindex = forall_tmp->maskindex; - if (mask) - gfc_add_modify_expr (block, maskindex, gfc_index_zero_node); - forall_tmp = forall_tmp->next_nest; - } - /* Generate body and loops according to the information in nested_forall_info. */ tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1); @@ -2094,16 +2060,6 @@ gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, /* Reset count. */ gfc_add_modify_expr (block, count, gfc_index_zero_node); - /* Reset maskindexes. */ - forall_tmp = nested_forall_info; - while (forall_tmp != NULL) - { - mask = forall_tmp->mask; - maskindex = forall_tmp->maskindex; - if (mask) - gfc_add_modify_expr (block, maskindex, gfc_index_zero_node); - forall_tmp = forall_tmp->next_nest; - } gfc_start_block (&body); gfc_init_se (&lse, NULL); gfc_init_se (&rse, NULL); @@ -2164,17 +2120,6 @@ gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, tmp = gfc_finish_block (&body); - /* Initialize the maskindexes. */ - forall_tmp = nested_forall_info; - while (forall_tmp != NULL) - { - mask = forall_tmp->mask; - maskindex = forall_tmp->maskindex; - if (mask) - gfc_add_modify_expr (block, maskindex, gfc_index_zero_node); - forall_tmp = forall_tmp->next_nest; - } - /* Generate body and loops according to the information in nested_forall_info. */ tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1); @@ -2183,16 +2128,6 @@ gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, /* Reset count. */ gfc_add_modify_expr (block, count, gfc_index_zero_node); - /* Reset maskindexes. */ - forall_tmp = nested_forall_info; - while (forall_tmp != NULL) - { - mask = forall_tmp->mask; - maskindex = forall_tmp->maskindex; - if (mask) - gfc_add_modify_expr (block, maskindex, gfc_index_zero_node); - forall_tmp = forall_tmp->next_nest; - } parm = gfc_build_array_ref (tmp1, count); lss = gfc_walk_expr (expr1); gfc_init_se (&lse, NULL); @@ -2487,10 +2422,6 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info) /* Use the normal assignment copying routines. */ assign = gfc_trans_assignment (c->expr, c->expr2); - /* Reset the mask index. */ - if (mask) - gfc_add_modify_expr (&block, maskindex, gfc_index_zero_node); - /* Generate body and loops. */ tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1, 1); gfc_add_expr_to_block (&block, tmp); @@ -2532,10 +2463,6 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info) /* Use the normal assignment copying routines. */ assign = gfc_trans_pointer_assignment (c->expr, c->expr2); - /* Reset the mask index. */ - if (mask) - gfc_add_modify_expr (&block, maskindex, gfc_index_zero_node); - /* Generate body and loops. */ tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1, 1); @@ -2723,22 +2650,7 @@ gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info, tmp1 = gfc_finish_block (&body); /* If the WHERE construct is inside FORALL, fill the full temporary. */ if (nested_forall_info != NULL) - { - forall_info *forall_tmp; - tree maskindex; - - /* Initialize the maskindexes. */ - forall_tmp = nested_forall_info; - while (forall_tmp != NULL) - { - maskindex = forall_tmp->maskindex; - if (forall_tmp->mask) - gfc_add_modify_expr (block, maskindex, gfc_index_zero_node); - forall_tmp = forall_tmp->next_nest; - } - - tmp1 = gfc_trans_nested_forall_loop (nested_forall_info, tmp1, 1, 1); - } + tmp1 = gfc_trans_nested_forall_loop (nested_forall_info, tmp1, 1, 1); gfc_add_expr_to_block (block, tmp1); @@ -3059,9 +2971,6 @@ gfc_trans_where_2 (gfc_code * code, tree mask, tree pmask, nested_forall_info, block); else { - forall_info *forall_tmp; - tree maskindex; - /* Variables to control maskexpr. */ count1 = gfc_create_var (gfc_array_index_type, "count1"); count2 = gfc_create_var (gfc_array_index_type, "count2"); @@ -3071,17 +2980,6 @@ gfc_trans_where_2 (gfc_code * code, tree mask, tree pmask, tmp = gfc_trans_where_assign (expr1, expr2, mask, count1, count2); - /* Initialize the maskindexes. */ - forall_tmp = nested_forall_info; - while (forall_tmp != NULL) - { - maskindex = forall_tmp->maskindex; - if (forall_tmp->mask) - gfc_add_modify_expr (block, maskindex, - gfc_index_zero_node); - forall_tmp = forall_tmp->next_nest; - } - tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1); gfc_add_expr_to_block (block, tmp); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 3f48f2272e7..6dd712708f3 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2005-07-11 Jakub Jelinek + + * gfortran.fortran-torture/execute/forall_7.f90: New test. + 2005-07-10 Richard Sandiford * gcc.target/mips/mips.exp (is_gp32_flag): New procedure. diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/forall_7.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/forall_7.f90 new file mode 100644 index 00000000000..4a28928109c --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/forall_7.f90 @@ -0,0 +1,88 @@ +! tests FORALL statements with a mask +program forall_7 + real, dimension (5, 5, 5, 5) :: a, b, c, d + + a (:, :, :, :) = 4 + forall (i = 1:5) + a (i, i, 6 - i, i) = 7 + end forall + forall (i = 1:5) + a (i, 6 - i, i, i) = 7 + end forall + forall (i = 1:5) + a (6 - i, i, i, i) = 7 + end forall + forall (i = 1:5:2) + a (1, 2, 3, i) = 0 + end forall + + b = a + c = a + d = a + + forall (i = 1:5, j = 1:5, k = 1:5, ((a (i, j, k, i) .gt. 6) .or. (a (i, j, k, j) .gt. 6))) + forall (l = 1:5, a (1, 2, 3, l) .lt. 2) + a (i, j, k, l) = i - j + k - l + 0.5 + end forall + end forall + + forall (l = 1:5, b (1, 2, 3, l) .lt. 2) + forall (i = 1:5, j = 1:5, k = 1:5, ((b (i, j, k, i) .gt. 6) .or. (b (i, j, k, j) .gt. 6))) + b (i, j, k, l) = i - j + k - l + 0.5 + end forall + end forall + + forall (i = 1:5, j = 1:5, k = 1:5, ((c (i, j, k, i) .gt. 6) .or. (c (i, j, k, j) .gt. 6))) + forall (l = 1:5, c (1, 2, 3, l) .lt. 2) + c (i, j, k, l) = i - j + k - l + 0.5 + c (l, k, j, i) + end forall + end forall + + forall (l = 1:5, d (1, 2, 3, l) .lt. 2) + forall (i = 1:5, j = 1:5, k = 1:5, ((d (i, j, k, i) .gt. 6) .or. (d (i, j, k, j) .gt. 6))) + d (i, j, k, l) = i - j + k - l + 0.5 + d (l, k, j, i) + end forall + end forall + + do i = 1, 5 + do j = 1, 5 + do k = 1, 5 + do l = 1, 5 + r = 4 + if ((i == j .and. k == 6 - i) .or. (i == k .and. j == 6 - i)) then + if (l /= 2 .and. l /= 4) then + r = 1 + elseif (l == i) then + r = 7 + end if + elseif (j == k .and. i == 6 - j) then + if (l /= 2 .and. l /= 4) then + r = 1 + elseif (l == j) then + r = 7 + end if + elseif (i == 1 .and. j == 2 .and. k == 3 .and. l /= 2 .and. l /= 4) then + r = 0 + end if + s = r + if (r == 1) then + r = i - j + k - l + 0.5 + if (((l == k .and. j == 6 - l) .or. (l == j .and. k == 6 - l)) .and. (i == l)) then + s = r + 7 + elseif (k == j .and. l == 6 - k .and. i == k) then + s = r + 7 + elseif (l /= 1 .or. k /= 2 .or. j /= 3 .or. i == 2 .or. i == 4) then + s = r + 4 + else + s = r + end if + end if + if (a (i, j, k, l) /= r) call abort () + if (c (i, j, k, l) /= s) call abort () + end do + end do + end do + end do + + if (any (a /= b .or. c /= d)) call abort () +end -- 2.30.2