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

4 files changed, 69 insertions, 18 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 160d602dfd1..12afa21286b 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,11 @@
+2008-04-06  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/35780
+	* expr.c (scalarize_intrinsic_call): Identify which argument is
+	an array and use that as the template.
+	(check_init_expr): Remove tests that first argument is an array
+	in the call to scalarize_intrinsic_call.
+
 2008-04-06  Tobias Schlüter  <tobi@gcc.gnu.org>
 
 	PR fortran/35832
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 329bc722dba..12e88a07420 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -1702,17 +1702,34 @@ scalarize_intrinsic_call (gfc_expr *e)
   gfc_actual_arglist *a, *b;
   gfc_constructor *args[5], *ctor, *new_ctor;
   gfc_expr *expr, *old;
-  int n, i, rank[5];
+  int n, i, rank[5], array_arg;
 
   old = gfc_copy_expr (e);
 
-/* Assume that the old expression carries the type information and
-   that the first arg carries all the shape information.  */
-  expr = gfc_copy_expr (old->value.function.actual->expr);
+
+  /* Find which, if any, arguments are arrays.  Assume that the old
+     expression carries the type information and that the first arg
+     that is an array expression carries all the shape information.*/
+  n = array_arg = 0;
+  a = old->value.function.actual;
+  for (; a; a = a->next)
+    {
+      n++;
+      if (a->expr->expr_type != EXPR_ARRAY)
+	continue;
+      array_arg = n;
+      expr = gfc_copy_expr (a->expr);
+      break;
+    }
+
+  if (!array_arg)
+    goto cleanup;
+
   gfc_free_constructor (expr->value.constructor);
   expr->value.constructor = NULL;
 
   expr->ts = old->ts;
+  expr->where = old->where;
   expr->expr_type = EXPR_ARRAY;
 
   /* Copy the array argument constructors into an array, with nulls
@@ -1745,14 +1762,11 @@ scalarize_intrinsic_call (gfc_expr *e)
       n++;
     }
 
-  for (i = 1; i < n; i++)
-    if (rank[i] && rank[i] != rank[0])
-      goto compliance;
 
   /* Using the first argument as the master, step through the array
      calling the function for each element and advancing the array
      constructors together.  */
-  ctor = args[0];
+  ctor = args[array_arg - 1];
   new_ctor = NULL;
   for (; ctor; ctor = ctor->next)
     {
@@ -1786,17 +1800,18 @@ scalarize_intrinsic_call (gfc_expr *e)
 	      b = b->next;
 	    }
 
-	  /* Simplify the function calls.  */
-	  if (gfc_simplify_expr (new_ctor->expr, 0) == FAILURE)
-	    goto cleanup;
+	  /* Simplify the function calls.  If the simplification fails, the
+	     error will be flagged up down-stream or the library will deal
+	     with it.  */
+	  gfc_simplify_expr (new_ctor->expr, 0);
 
 	  for (i = 0; i < n; i++)
 	    if (args[i])
 	      args[i] = args[i]->next;
 
 	  for (i = 1; i < n; i++)
-	    if (rank[i] && ((args[i] != NULL && args[0] == NULL)
-			 || (args[i] == NULL && args[0] != NULL)))
+	    if (rank[i] && ((args[i] != NULL && args[array_arg - 1] == NULL)
+			 || (args[i] == NULL && args[array_arg - 1] != NULL)))
 	      goto compliance;
     }
 
@@ -2187,11 +2202,8 @@ check_init_expr (gfc_expr *e)
 	     array argument.  */
 	  isym = gfc_find_function (e->symtree->n.sym->name);
 	  if (isym && isym->elemental
-	      && e->value.function.actual->expr->expr_type == EXPR_ARRAY)
-	    {
-		if ((t = scalarize_intrinsic_call (e)) == SUCCESS)
-		break;
-	    }
+		&& (t = scalarize_intrinsic_call (e)) == SUCCESS)
+	    break;
 	}
 
       if (m == MATCH_YES)
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 9f9caa65ce5..b5b21556f04 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2008-04-06  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/35780
+	* gfortran.dg/simplify_argN_1.f90: New test.
+
 2008-04-06  Tobias Schlüter  <tobi@gcc.gnu.org>
 
 	PR fortran/35832
diff --git a/gcc/testsuite/gfortran.dg/simplify_argN_1.f90 b/gcc/testsuite/gfortran.dg/simplify_argN_1.f90
new file mode 100644
index 00000000000..933b1f32af7
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/simplify_argN_1.f90
@@ -0,0 +1,26 @@
+! { dg-do run }
+! Tests the fix for PR35780, in which the assignment for C was not
+! scalarized in expr.c.
+!
+! Contributed by Dick Hendrickson <dick.hendrickson@gmail.com>
+!
+MODULE MODS
+  integer, parameter :: N = 10
+  INTEGER, PARAMETER, DIMENSION(N) ::  A = [(i, i = 1, N)]
+  INTEGER, PARAMETER, DIMENSION(N) ::  B = [(i - 5, i = 1, N)]
+  INTEGER, PARAMETER, DIMENSION(N)  :: C = ISHFTC(3, B, 5)   !ICE
+  INTEGER, PARAMETER, DIMENSION(N)  :: D = ISHFTC(A, 3, 5)   !  OK
+  INTEGER, PARAMETER, DIMENSION(N)  :: E = ISHFTC(A, B, 5)   !  OK
+
+END MODULE MODS
+
+  use mods
+  integer, dimension(N) :: X = A
+  integer, dimension(N) :: Y = B
+
+! Check the simplifed expressions against the library
+  if (any (ISHFTC(3, Y, 5) /= C)) call abort ()
+  if (any (ISHFTC(X, 3, 5) /= D)) call abort ()
+  if (any (ISHFTC(X, Y, 5) /= E)) call abort ()
+end
+! { dg-final { cleanup-modules "mods" } }