Index... ...
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c (revision 133728)
--- gcc/fortran/trans-stmt.c (working copy)
*************** gfc_trans_where_2 (gfc_code * code, tree
*** 3540,3547 ****
/* Translate a simple WHERE construct or statement without dependencies.
CBLOCK is the "then" clause of the WHERE statement, where CBLOCK->EXPR
! is the mask condition, and EBLOCK if non-NULL is the "else" clause.
! Currently both CBLOCK and EBLOCK are restricted to single assignments. */
static tree
gfc_trans_where_3 (gfc_code * cblock, gfc_code * eblock)
--- 3540,3550 ----
/* Translate a simple WHERE construct or statement without dependencies.
CBLOCK is the "then" clause of the WHERE statement, where CBLOCK->EXPR
! is the mask condition, and EBLOCK if non-NULL is the "then" clause of
! the ELSWHERE. As required by 7.5.3.2, the WHERE and ELSEWHERE are
! executed with separate loops. It should be noted that the mask expression
! is evaluated for both loops. Currently both CBLOCK and EBLOCK are
! restricted to single assignments. */
static tree
gfc_trans_where_3 (gfc_code * cblock, gfc_code * eblock)
*************** gfc_trans_where_3 (gfc_code * cblock, gf
*** 3561,3566 ****
--- 3564,3570 ----
edst = eblock ? eblock->next->expr : NULL;
esrc = eblock ? eblock->next->expr2 : NULL;
+ /*---------------First do the WHERE part.----------------*/
gfc_start_block (&block);
gfc_init_loopinfo (&loop);
*************** gfc_trans_where_3 (gfc_code * cblock, gf
*** 3584,3619 ****
gfc_add_ss_to_loop (&loop, tdss);
gfc_add_ss_to_loop (&loop, tsss);
- if (eblock)
- {
- /* Handle the else clause. */
- gfc_init_se (&edse, NULL);
- gfc_init_se (&esse, NULL);
- edss = gfc_walk_expr (edst);
- esss = gfc_walk_expr (esrc);
- if (esss == gfc_ss_terminator)
- {
- esss = gfc_get_ss ();
- esss->next = gfc_ss_terminator;
- esss->type = GFC_SS_SCALAR;
- esss->expr = esrc;
- }
- gfc_add_ss_to_loop (&loop, edss);
- gfc_add_ss_to_loop (&loop, esss);
- }
-
gfc_conv_ss_startstride (&loop);
gfc_conv_loop_setup (&loop);
gfc_mark_ss_chain_used (css, 1);
gfc_mark_ss_chain_used (tdss, 1);
gfc_mark_ss_chain_used (tsss, 1);
! if (eblock)
! {
! gfc_mark_ss_chain_used (edss, 1);
! gfc_mark_ss_chain_used (esss, 1);
! }
!
gfc_start_scalarized_body (&loop, &body);
gfc_copy_loopinfo_to_se (&cse, &loop);
--- 3588,3600 ----
gfc_add_ss_to_loop (&loop, tdss);
gfc_add_ss_to_loop (&loop, tsss);
gfc_conv_ss_startstride (&loop);
gfc_conv_loop_setup (&loop);
gfc_mark_ss_chain_used (css, 1);
gfc_mark_ss_chain_used (tdss, 1);
gfc_mark_ss_chain_used (tsss, 1);
!
gfc_start_scalarized_body (&loop, &body);
gfc_copy_loopinfo_to_se (&cse, &loop);
*************** gfc_trans_where_3 (gfc_code * cblock, gf
*** 3622,3637 ****
cse.ss = css;
tdse.ss = tdss;
tsse.ss = tsss;
- if (eblock)
- {
- gfc_copy_loopinfo_to_se (&edse, &loop);
- gfc_copy_loopinfo_to_se (&esse, &loop);
- edse.ss = edss;
- esse.ss = esss;
- }
gfc_conv_expr (&cse, cond);
! gfc_add_block_to_block (&body, &cse.pre);
cexpr = cse.expr;
gfc_conv_expr (&tsse, tsrc);
--- 3603,3611 ----
cse.ss = css;
tdse.ss = tdss;
tsse.ss = tsss;
gfc_conv_expr (&cse, cond);
! gfc_add_block_to_block (&block, &cse.pre);
cexpr = cse.expr;
gfc_conv_expr (&tsse, tsrc);
*************** gfc_trans_where_3 (gfc_code * cblock, gf
*** 3643,3650 ****
--- 3617,3678 ----
else
gfc_conv_expr (&tdse, tdst);
+ /* Make the assignment on condition 'cond'. */
+ tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts, false, false);
+ tmp = build3_v (COND_EXPR, cexpr, tstmt, build_empty_stmt ());
+ gfc_add_expr_to_block (&body, tmp);
+ gfc_add_block_to_block (&body, &cse.post);
+
+ gfc_trans_scalarizing_loops (&loop, &body);
+ gfc_add_block_to_block (&block, &loop.pre);
+ gfc_add_block_to_block (&block, &loop.post);
+ gfc_cleanup_loop (&loop);
+
+ /*---------------Now do the ELSEWHERE.--------------*/
if (eblock)
{
+ gfc_init_loopinfo (&loop);
+
+ /* Handle the condition. */
+ gfc_init_se (&cse, NULL);
+ css = gfc_walk_expr (cond);
+ gfc_add_ss_to_loop (&loop, css);
+
+ /* Handle the then-clause. */
+ gfc_init_se (&edse, NULL);
+ gfc_init_se (&esse, NULL);
+ edss = gfc_walk_expr (edst);
+ esss = gfc_walk_expr (esrc);
+ if (esss == gfc_ss_terminator)
+ {
+ esss = gfc_get_ss ();
+ esss->next = gfc_ss_terminator;
+ esss->type = GFC_SS_SCALAR;
+ esss->expr = esrc;
+ }
+ gfc_add_ss_to_loop (&loop, edss);
+ gfc_add_ss_to_loop (&loop, esss);
+
+ gfc_conv_ss_startstride (&loop);
+ gfc_conv_loop_setup (&loop);
+
+ gfc_mark_ss_chain_used (css, 1);
+ gfc_mark_ss_chain_used (edss, 1);
+ gfc_mark_ss_chain_used (esss, 1);
+
+ gfc_start_scalarized_body (&loop, &body);
+
+ gfc_copy_loopinfo_to_se (&cse, &loop);
+ gfc_copy_loopinfo_to_se (&edse, &loop);
+ gfc_copy_loopinfo_to_se (&esse, &loop);
+ cse.ss = css;
+ edse.ss = edss;
+ esse.ss = esss;
+
+ gfc_conv_expr (&cse, cond);
+ gfc_add_block_to_block (&body, &cse.pre);
+ cexpr = cse.expr;
+
gfc_conv_expr (&esse, esrc);
if (edss != gfc_ss_terminator && loop.temp_ss != NULL)
{
*************** gfc_trans_where_3 (gfc_code * cblock, gf
*** 3653,3672 ****
}
else
gfc_conv_expr (&edse, edst);
}
- tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts, false, false);
- estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts, false, false)
- : build_empty_stmt ();
- tmp = build3_v (COND_EXPR, cexpr, tstmt, estmt);
- gfc_add_expr_to_block (&body, tmp);
- gfc_add_block_to_block (&body, &cse.post);
-
- gfc_trans_scalarizing_loops (&loop, &body);
- gfc_add_block_to_block (&block, &loop.pre);
- gfc_add_block_to_block (&block, &loop.post);
- gfc_cleanup_loop (&loop);
-
return gfc_finish_block (&block);
}
--- 3681,3700 ----
}
else
gfc_conv_expr (&edse, edst);
+
+ /* Make the assignment on condition 'NOT.cond'. */
+ estmt = gfc_trans_scalar_assign (&edse, &esse, edst->ts, false, false);
+ cexpr = fold_build1 (TRUTH_NOT_EXPR, boolean_type_node, cexpr);
+ tmp = build3_v (COND_EXPR, cexpr, estmt, build_empty_stmt ());
+ gfc_add_expr_to_block (&body, tmp);
+ gfc_add_block_to_block (&body, &cse.post);
+
+ gfc_trans_scalarizing_loops (&loop, &body);
+ gfc_add_block_to_block (&block, &loop.pre);
+ gfc_add_block_to_block (&block, &loop.post);
+ gfc_cleanup_loop (&loop);
}
return gfc_finish_block (&block);
}
*************** gfc_trans_where (gfc_code * code)
*** 3698,3708 ****
cblock->next->expr2, 0))
return gfc_trans_where_3 (cblock, NULL);
}
else if (!eblock->expr
&& !eblock->block
&& eblock->next
&& eblock->next->op == EXEC_ASSIGN
! && !eblock->next->next)
{
/* A simple "WHERE (cond) x1 = y1 ELSEWHERE x2 = y2 ENDWHERE"
block is dependence free if cond is not dependent on writes
--- 3726,3739 ----
cblock->next->expr2, 0))
return gfc_trans_where_3 (cblock, NULL);
}
+ /* Since gfc_trans_where_3 evaluates the condition expression
+ twice, do not use it if the condition is not a variable. */
else if (!eblock->expr
&& !eblock->block
&& eblock->next
&& eblock->next->op == EXEC_ASSIGN
! && !eblock->next->next
! && cblock->expr->expr_type == EXPR_VARIABLE)
{
/* A simple "WHERE (cond) x1 = y1 ELSEWHERE x2 = y2 ENDWHERE"
block is dependence free if cond is not dependent on writes
Index: gcc/testsuite/gfortran.dg/where_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/where_1.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/where_1.f90 (revision 0)
***************
*** 0 ****
--- 1,61 ----
+ ! { dg-do run }
+ ! { dg-options "-fdump-tree-original" }
+ ! Tests the fix for PR35759, in which the simple WHERE was logically
+ ! wrong. 7.5.3.2 requires that the WHERE and ELSEWHERE are execute in
+ ! separate loops, whereas gfortran was implementing them as a single
+ ! loop with an 'if' and 'else'. Since the condition expression is
+ ! evaluated twice with the fix, the use of anything other than a
+ ! variable or parameter array for the condition will trigger the more
+ ! comprehensive implementation of WHERE. This is checked by the
+ ! check of the declaration of temp.15 in the 'original' code.
+ !
+ ! Contributed by Dick Hendrickson <dick.hendrickson@gmail.com>
+ !
+ program RG0023
+
+ integer UDA1L(6)
+ integer :: UDA1R(6), expected(6) = (/2,0,5,0,3,0/)
+ LOGICAL LDA(5)
+ LOGICAL, parameter :: PDA(5) = (/ (i/2*2 .ne. I, i=1,5) /)
+
+ UDA1L(1:6) = 0
+ uda1r = (/1,2,3,4,5,6/)
+ lda = pda
+
+ WHERE (lda) ! expected
+ UDA1L(1:5) = UDA1R(2:6) ! uda1l = 2,0,4,0,6,0
+ ELSEWHERE
+ UDA1L(2:6) = UDA1R(6:2:-1) !uda1l = 2,0,5,0,3,0
+ ENDWHERE
+
+ if (any (uda1l /= expected)) call abort ()
+
+ uda1l = 0
+
+ WHERE (pda) ! expected
+ UDA1L(1:5) = UDA1R(2:6) ! uda1l = 2,0,4,0,6,0
+ ELSEWHERE
+ UDA1L(2:6) = UDA1R(6:2:-1) !uda1l = 2,0,5,0,3,0
+ ENDWHERE
+
+ if (any (uda1l /= expected)) call abort ()
+
+ uda1l = 0
+
+ WHERE (lfoo ()) ! expected
+ UDA1L(1:5) = UDA1R(2:6) ! uda1l = 2,0,4,0,6,0
+ ELSEWHERE
+ UDA1L(2:6) = UDA1R(6:2:-1) !uda1l = 2,0,5,0,3,0
+ ENDWHERE
+
+ if (any (uda1l /= expected)) call abort ()
+
+ contains
+
+ function lfoo () result (ltmp)
+ logical ltmp(5)
+ ltmp = lda
+ end function lfoo
+ END
+ ! { dg-final { scan-tree-dump-times "temp.18\\\[5\\\]" 1 "original" } }
+ ! { dg-final { cleanup-tree-dump "original" } }
From-SVN: r133965
679d963737