re PR fortran/30407 ([4.1 only] Elemental functions in WHERE assignments wrongly rejected)

2007-01-27  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/30407
	* trans-expr.c (gfc_conv_operator_assign): New function.
	* trans.h : Add prototype for gfc_conv_operator_assign.
	* trans-stmt.c (gfc_trans_where_assign): Add a gfc_symbol for
	a potential operator assignment subroutine.  If it is non-NULL
	call gfc_conv_operator_assign instead of the first assignment.
	( gfc_trans_where_2): In the case of an operator assignment,
	extract the argument expressions from the code for the
	subroutine call and pass the symbol to gfc_trans_where_assign.
	resolve.c (resolve_where, gfc_resolve_where_code_in_forall,
	gfc_resolve_forall_body): Resolve the subroutine call for
	operator assignments.

2007-01-27  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/30407
	* gfortran.dg/where_operator_assign_1.f90: New test.
	* gfortran.dg/where_operator_assign_2.f90: New test.
	* gfortran.dg/where_operator_assign_3.f90: New test.

From-SVN: r121235

9 files changed, 406 insertions, 6 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index c81de30..75aa23f 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,18 @@
+2007-01-27  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/30407
+	* trans-expr.c (gfc_conv_operator_assign): New function.
+	* trans.h : Add prototype for gfc_conv_operator_assign.
+	* trans-stmt.c (gfc_trans_where_assign): Add a gfc_symbol for
+	a potential operator assignment subroutine.  If it is non-NULL
+	call gfc_conv_operator_assign instead of the first assignment.
+	( gfc_trans_where_2): In the case of an operator assignment,
+	extract the argument expressions from the code for the
+	subroutine call and pass the symbol to gfc_trans_where_assign.
+	resolve.c (resolve_where, gfc_resolve_where_code_in_forall,
+	gfc_resolve_forall_body): Resolve the subroutine call for
+	operator assignments.
+
 2007-01-26  Steven Bosscher  <stevenb.gcc@gmail.com>
 	    Steven G. Kargl <kargl@gcc.gnu.org>
 
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 526be48..9a06a98 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -4550,6 +4550,11 @@ resolve_where (gfc_code *code, gfc_expr *mask)
 			  "inconsistent shape", &cnext->expr->where);
 	      break;
 
+  
+	    case EXEC_ASSIGN_CALL:
+	      resolve_call (cnext);
+	      break;
+
 	    /* WHERE or WHERE construct is part of a where-body-construct */
 	    case EXEC_WHERE:
 	      resolve_where (cnext, e);
@@ -4750,6 +4755,11 @@ gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
 	    case EXEC_ASSIGN:
 	      gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
 	      break;
+  
+	    /* WHERE operator assignment statement */
+	    case EXEC_ASSIGN_CALL:
+	      resolve_call (cnext);
+	      break;
 
 	    /* WHERE or WHERE construct is part of a where-body-construct */
 	    case EXEC_WHERE:
@@ -4789,6 +4799,10 @@ gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
 	  gfc_resolve_assign_in_forall (c, nvar, var_expr);
 	  break;
 
+	case EXEC_ASSIGN_CALL:
+	  resolve_call (c);
+	  break;
+
 	/* Because the gfc_resolve_blocks() will handle the nested FORALL,
 	   there is no need to handle it here.  */
 	case EXEC_FORALL:
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 2dc78b6..487b6a7 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1249,6 +1249,48 @@ gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
 }
 
 
+/* Translate the call for an elemental subroutine call used in an operator
+   assignment.  This is a simplified version of gfc_conv_function_call.  */
+
+tree
+gfc_conv_operator_assign (gfc_se *lse, gfc_se *rse, gfc_symbol *sym)
+{
+  tree args;
+  tree tmp;
+  gfc_se se;
+  stmtblock_t block;
+
+  /* Only elemental subroutines with two arguments.  */
+  gcc_assert (sym->attr.elemental && sym->attr.subroutine);
+  gcc_assert (sym->formal->next->next == NULL);
+
+  gfc_init_block (&block);
+
+  gfc_add_block_to_block (&block, &lse->pre);
+  gfc_add_block_to_block (&block, &rse->pre);
+
+  /* Build the argument list for the call, including hidden string lengths.  */
+  args = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (lse->expr));
+  args = gfc_chainon_list (args, build_fold_addr_expr (rse->expr));
+  if (lse->string_length != NULL_TREE)
+    args = gfc_chainon_list (args, lse->string_length);
+  if (rse->string_length != NULL_TREE)
+    args = gfc_chainon_list (args, rse->string_length);    
+
+  /* Build the function call.  */
+  gfc_init_se (&se, NULL);
+  gfc_conv_function_val (&se, sym);
+  tmp = TREE_TYPE (TREE_TYPE (TREE_TYPE (se.expr)));
+  tmp = build3 (CALL_EXPR, tmp, se.expr, args, NULL_TREE);
+  gfc_add_expr_to_block (&block, tmp);
+
+  gfc_add_block_to_block (&block, &lse->post);
+  gfc_add_block_to_block (&block, &rse->post);
+
+  return gfc_finish_block (&block);
+}
+
+
 /* Initialize MAPPING.  */
 
 void
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 47a846e..6640cf7 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -2878,7 +2878,8 @@ gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info,
 static tree
 gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2,
 			tree mask, bool invert,
-                        tree count1, tree count2)
+                        tree count1, tree count2,
+			gfc_symbol *sym)
 {
   gfc_se lse;
   gfc_se rse;
@@ -2992,8 +2993,12 @@ gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2,
     maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr), maskexpr);
 
   /* Use the scalar assignment as is.  */
-  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
-				 loop.temp_ss != NULL, false);
+  if (sym == NULL)
+    tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
+				   loop.temp_ss != NULL, false);
+  else
+    tmp = gfc_conv_operator_assign (&lse, &rse, sym);
+
   tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
 
   gfc_add_expr_to_block (&body, tmp);
@@ -3102,6 +3107,7 @@ gfc_trans_where_2 (gfc_code * code, tree mask, bool invert,
   tree ppmask = NULL_TREE;
   tree cmask = NULL_TREE;
   tree pmask = NULL_TREE;
+  gfc_actual_arglist *arg;
 
   /* the WHERE statement or the WHERE construct statement.  */
   cblock = code->block;
@@ -3213,13 +3219,29 @@ gfc_trans_where_2 (gfc_code * code, tree mask, bool invert,
           switch (cnext->op)
             {
             /* WHERE assignment statement.  */
+	    case EXEC_ASSIGN_CALL:
+
+	      arg = cnext->ext.actual;
+	      expr1 = expr2 = NULL;
+	      for (; arg; arg = arg->next)
+		{
+		  if (!arg->expr)
+		    continue;
+		  if (expr1 == NULL)
+		    expr1 = arg->expr;
+		  else
+		    expr2 = arg->expr;
+		}
+	      goto evaluate;
+
             case EXEC_ASSIGN:
               expr1 = cnext->expr;
               expr2 = cnext->expr2;
+    evaluate:
               if (nested_forall_info != NULL)
                 {
                   need_temp = gfc_check_dependency (expr1, expr2, 0);
-                  if (need_temp)
+                  if (need_temp && cnext->op != EXEC_ASSIGN_CALL)
                     gfc_trans_assign_need_temp (expr1, expr2,
 						cmask, invert,
                                                 nested_forall_info, block);
@@ -3233,7 +3255,8 @@ gfc_trans_where_2 (gfc_code * code, tree mask, bool invert,
 
                       tmp = gfc_trans_where_assign (expr1, expr2,
 						    cmask, invert,
-						    count1, count2);
+						    count1, count2,
+						    cnext->resolved_sym);
 
                       tmp = gfc_trans_nested_forall_loop (nested_forall_info,
                                                           tmp, 1);
@@ -3250,7 +3273,8 @@ gfc_trans_where_2 (gfc_code * code, tree mask, bool invert,
 
                   tmp = gfc_trans_where_assign (expr1, expr2,
 						cmask, invert,
-						count1, count2);
+						count1, count2,
+						cnext->resolved_sym);
                   gfc_add_expr_to_block (block, tmp);
 
                 }
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index d16a5df..a3b6f04 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -303,6 +303,9 @@ void gfc_conv_intrinsic_function (gfc_se *, gfc_expr *);
 /* Does an intrinsic map directly to an external library call.  */
 int gfc_is_intrinsic_libcall (gfc_expr *);
 
+/* Used to call the elemental subroutines used in operator assignments.  */
+tree gfc_conv_operator_assign (gfc_se *, gfc_se *, gfc_symbol *);
+
 /* Also used to CALL subroutines.  */
 int gfc_conv_function_call (gfc_se *, gfc_symbol *, gfc_actual_arglist *,
 			    tree);
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 426d683..dd50222 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+2007-01-27  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/30407
+	* gfortran.dg/where_operator_assign_1.f90: New test.
+	* gfortran.dg/where_operator_assign_2.f90: New test.
+	* gfortran.dg/where_operator_assign_3.f90: New test.
+
 2007-01-26  Joseph Myers  <joseph@codesourcery.com>
 
 	* lib/target-supports.exp
diff --git a/gcc/testsuite/gfortran.dg/where_operator_assign_1.f90 b/gcc/testsuite/gfortran.dg/where_operator_assign_1.f90
new file mode 100644
index 0000000..c2b4abf
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/where_operator_assign_1.f90
@@ -0,0 +1,108 @@
+! { dg-do compile }
+! Tests the fix for PR30407, in which operator assignments did not work
+! in WHERE blocks or simple WHERE statements.  This is the test provided
+! by the reporter.
+!
+! Contributed by Dominique d'Humieres <dominiq@lps.ens.fr>
+!==============================================================================
+
+MODULE kind_mod
+
+   IMPLICIT NONE
+
+   PRIVATE
+
+   INTEGER, PUBLIC, PARAMETER :: I4=SELECTED_INT_KIND(9)
+   INTEGER, PUBLIC, PARAMETER :: TF=KIND(.TRUE._I4)
+
+END MODULE kind_mod
+
+!==============================================================================
+
+MODULE pointer_mod
+
+   USE kind_mod, ONLY : I4
+
+   IMPLICIT NONE
+
+   PRIVATE
+
+   TYPE, PUBLIC :: pvt
+      INTEGER(I4), POINTER, DIMENSION(:) :: vect
+   END TYPE pvt
+
+   INTERFACE ASSIGNMENT(=)
+      MODULE PROCEDURE p_to_p
+   END INTERFACE
+
+   PUBLIC :: ASSIGNMENT(=)
+
+CONTAINS
+
+   !---------------------------------------------------------------------------
+
+   PURE ELEMENTAL SUBROUTINE p_to_p(a1, a2)
+      IMPLICIT NONE
+      TYPE(pvt), INTENT(OUT) :: a1
+      TYPE(pvt), INTENT(IN) :: a2
+      a1%vect = a2%vect
+   END SUBROUTINE p_to_p
+
+   !---------------------------------------------------------------------------
+
+END MODULE pointer_mod
+
+!==============================================================================
+
+PROGRAM test_prog
+
+   USE pointer_mod, ONLY : pvt, ASSIGNMENT(=)
+
+   USE kind_mod, ONLY : I4, TF
+
+   IMPLICIT NONE
+
+   INTEGER(I4), DIMENSION(12_I4), TARGET :: ia
+   LOGICAL(TF), DIMENSION(2_I4,3_I4) :: la
+   TYPE(pvt), DIMENSION(6_I4) :: pv
+   INTEGER(I4) :: i
+
+   ! Initialisation...
+   la(:,1_I4:3_I4:2_I4)=.TRUE._TF
+   la(:,2_I4)=.FALSE._TF
+
+   DO i=1_I4,6_I4
+      pv(i)%vect => ia((2_I4*i-1_I4):(2_I4*i))
+   END DO
+
+   ia=0_I4
+
+   DO i=1_I4,3_I4
+      WHERE(la((/1_I4,2_I4/),i))
+         pv((2_I4*i-1_I4):(2_I4*i))= iaef((/(2_I4*i-1_I4),(2_I4*i)/))
+      ELSEWHERE
+         pv((2_I4*i-1_I4):(2_I4*i))= iaef((/0_I4,0_I4/))
+      END WHERE
+   END DO
+
+   if (any (ia .ne. (/1,-1,2,-2,0,0,0,0,5,-5,6,-6/))) call abort ()
+
+CONTAINS
+
+   TYPE(pvt) ELEMENTAL FUNCTION iaef(index) RESULT(ans)
+
+      USE kind_mod, ONLY :  I4
+      USE pointer_mod, ONLY : pvt, ASSIGNMENT(=)
+
+      IMPLICIT NONE
+
+      INTEGER(I4), INTENT(IN) :: index
+
+      ALLOCATE(ans%vect(2_I4))
+      ans%vect=(/index,-index/)
+
+   END FUNCTION iaef
+
+END PROGRAM test_prog
+
+! { dg-final { cleanup-modules "kind_mod pointer_mod" } }
diff --git a/gcc/testsuite/gfortran.dg/where_operator_assign_2.f90 b/gcc/testsuite/gfortran.dg/where_operator_assign_2.f90
new file mode 100644
index 0000000..420103f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/where_operator_assign_2.f90
@@ -0,0 +1,106 @@
+! { dg-do compile }
+! Tests the fix for PR30407, in which operator assignments did not work
+! in WHERE blocks or simple WHERE statements.
+!
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+!******************************************************************************
+module global
+  type :: a
+    integer :: b
+    integer :: c
+  end type a
+  interface assignment(=)
+    module procedure a_to_a
+  end interface
+  interface operator(.ne.)
+    module procedure a_ne_a
+  end interface
+
+  type(a) :: x(4), y(4), z(4), u(4, 4)
+  logical :: l1(4), t = .true., f= .false.
+contains
+!******************************************************************************
+  elemental subroutine a_to_a (m, n)
+    type(a), intent(in) :: n
+    type(a), intent(out) :: m
+    m%b = n%b + 1
+    m%c = n%c
+  end subroutine a_to_a
+!******************************************************************************
+  elemental logical function a_ne_a (m, n)
+    type(a), intent(in) :: n
+    type(a), intent(in) :: m
+    a_ne_a = (m%b .ne. n%b) .or. (m%c .ne. n%c)
+  end function a_ne_a
+!******************************************************************************
+  elemental function foo (m)
+    type(a) :: foo
+    type(a), intent(in) :: m
+    foo%b = 0
+    foo%c = m%c
+  end function foo  
+end module global
+!******************************************************************************
+program test
+  use global
+  x = (/a (0, 1),a (0, 2),a (0, 3),a (0, 4)/)
+  y = x
+  z = x
+  l1 = (/t, f, f, t/)
+
+  call test_where_1
+  if (any (y .ne. (/a (2, 1),a (2, 2),a (2, 3),a (2, 4)/))) call abort ()
+
+  call test_where_2
+  if (any (y .ne. (/a (1, 0),a (2, 2),a (2, 3),a (1, 0)/))) call abort ()
+  if (any (z .ne. (/a (3, 4),a (1, 0),a (1, 0),a (3, 1)/))) call abort ()
+
+  call test_where_3
+  if (any (y .ne. (/a (1, 0),a (1, 2),a (1, 3),a (1, 0)/))) call abort ()
+
+  y = x
+  call test_where_forall_1
+  if (any (u(4, :) .ne. (/a (1, 4),a (2, 2),a (2, 3),a (1, 4)/))) call abort ()
+
+  l1 = (/t, f, t, f/)
+  call test_where_4
+  if (any (x .ne. (/a (1, 1),a (2, 1),a (1, 3),a (2, 3)/))) call abort ()
+
+contains
+!******************************************************************************
+  subroutine test_where_1        ! Test a simple WHERE
+    where (l1) y = x
+  end subroutine test_where_1
+!******************************************************************************
+  subroutine test_where_2        ! Test a WHERE blocks
+    where (l1)
+      y = a (0, 0)
+      z = z(4:1:-1)
+    elsewhere
+      y = x
+      z = a (0, 0)
+    end where
+  end subroutine test_where_2
+!******************************************************************************
+  subroutine test_where_3        ! Test a simple WHERE with a function assignment
+    where (.not. l1) y = foo (x)
+  end subroutine test_where_3
+!******************************************************************************
+  subroutine test_where_forall_1 ! Test a WHERE in a FORALL block
+    forall (i = 1:4)
+      where (.not. l1)
+        u(i, :) = x
+      elsewhere
+        u(i, :) = a(0, i)
+      endwhere
+    end forall
+  end subroutine test_where_forall_1
+!******************************************************************************
+  subroutine test_where_4       ! Test a WHERE assignment with dependencies
+    where (l1(1:3))
+      x(2:4) = x(1:3)
+    endwhere
+  end subroutine test_where_4
+end program test 
+! { dg-final { cleanup-modules "global" } }
+
diff --git a/gcc/testsuite/gfortran.dg/where_operator_assign_3.f90 b/gcc/testsuite/gfortran.dg/where_operator_assign_3.f90
new file mode 100644
index 0000000..eddbdfc
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/where_operator_assign_3.f90
@@ -0,0 +1,81 @@
+! { dg-do compile }
+! Tests the fix for PR30407, in which operator assignments did not work
+! in WHERE blocks or simple WHERE statements. This tests that the character
+! lengths are transmitted OK.
+!
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+!******************************************************************************
+module global
+  type :: a
+    integer :: b
+    character(8):: c
+  end type a
+  interface assignment(=)
+    module procedure a_to_a, c_to_a, a_to_c
+  end interface
+  interface operator(.ne.)
+    module procedure a_ne_a
+  end interface
+
+  type(a) :: x(4), y(4)
+  logical :: l1(4), t = .true., f= .false.
+contains
+!******************************************************************************
+  elemental subroutine a_to_a (m, n)
+    type(a), intent(in) :: n
+    type(a), intent(out) :: m
+    m%b = len ( trim(n%c))
+    m%c = n%c
+  end subroutine a_to_a
+  elemental subroutine c_to_a (m, n)
+    character(8), intent(in) :: n
+    type(a), intent(out) :: m
+    m%b = m%b + 1
+    m%c = n
+  end subroutine c_to_a
+  elemental subroutine a_to_c (m, n)
+    type(a), intent(in) :: n
+    character(8), intent(out) :: m
+    m = n%c
+  end subroutine a_to_c
+!******************************************************************************
+  elemental logical function a_ne_a (m, n)
+    type(a), intent(in) :: n
+    type(a), intent(in) :: m
+    a_ne_a = (m%b .ne. n%b) .or. (m%c .ne. n%c)
+  end function a_ne_a
+!******************************************************************************
+  elemental function foo (m)
+    type(a) :: foo
+    type(a), intent(in) :: m
+    foo%b = 0
+    foo%c = m%c
+  end function foo  
+end module global
+!******************************************************************************
+program test
+  use global
+  x = (/a (0, "one"),a (0, "two"),a (0, "three"),a (0, "four")/)
+  y = x
+  l1 = (/t,f,f,t/)
+
+  call test_where_char1
+  call test_where_char2
+  if (any(y .ne. &
+    (/a(4, "null"), a(8, "non-null"), a(8, "non-null"), a(4, "null")/))) call abort ()
+contains
+  subroutine test_where_char1   ! Test a WHERE blocks
+    where (l1)
+      y = a (0, "null")
+    elsewhere
+      y = x
+    end where
+  end subroutine test_where_char1
+  subroutine test_where_char2   ! Test a WHERE blocks
+    where (y%c .ne. "null")
+      y = a (99, "non-null")
+    endwhere
+  end subroutine test_where_char2
+end program test 
+! { dg-final { cleanup-modules "global" } }
+