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" } }


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@133965 138bc75d-0d04-0410-961f-82ee72b054a4

0 files changed, 0 insertions, 0 deletions