re PR fortran/38863 (WHERE with multiple elemental defined assignments gives wrong answer)

2009-05-10  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/38863
	* trans-expr.c (gfc_conv_operator_assign): Remove function.
	* trans.h : Remove prototype for gfc_conv_operator_assign.
	* trans-stmt.c (gfc_conv_elemental_dependencies): Initialize
	derivde types with intent(out).
	(gfc_trans_call): Add mask, count1 and invert arguments. Add
	code to use mask for WHERE assignments.
	(gfc_trans_forall_1): Use new arguments for gfc_trans_call.
	(gfc_trans_where_assign): The gfc_symbol argument is replaced
	by the corresponding code. If this has a resolved_sym, then
	gfc_trans_call is called. The call to gfc_conv_operator_assign
	is removed.
	(gfc_trans_where_2): Change the last argument in the call to
	gfc_trans_where_assign.
	* trans-stmt.h : Modify prototype for gfc_trans_call.
	* trans.c (gfc_trans_code): Use new args for gfc_trans_call.

2009-05-10  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/38863
	* gfortran.dg/dependency_24.f90: New test.
	* gfortran.dg/dependency_23.f90: Clean up module files.

From-SVN: r147329

gcc/fortran/ChangeLog

+2009-05-10  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/38863
+	* trans-expr.c (gfc_conv_operator_assign): Remove function.
+	* trans.h : Remove prototype for gfc_conv_operator_assign.
+	* trans-stmt.c (gfc_conv_elemental_dependencies): Initialize
+	derivde types with intent(out).
+	(gfc_trans_call): Add mask, count1 and invert arguments. Add
+	code to use mask for WHERE assignments.
+	(gfc_trans_forall_1): Use new arguments for gfc_trans_call.
+	(gfc_trans_where_assign): The gfc_symbol argument is replaced
+	by the corresponding code. If this has a resolved_sym, then
+	gfc_trans_call is called. The call to gfc_conv_operator_assign
+	is removed.
+	(gfc_trans_where_2): Change the last argument in the call to
+	gfc_trans_where_assign.
+	* trans-stmt.h : Modify prototype for gfc_trans_call.
+	* trans.c (gfc_trans_code): Use new args for gfc_trans_call.
+
 2009-05-08  Janus Weil  <janus@gcc.gnu.org>
 
 	PR fortran/39876

gcc/fortran/trans-expr.c

@@ -1529,48 +1529,6 @@ conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
 }
 
 
-/* Translate the call for an elemental subroutine call used in an operator
-   assignment.  This is a simplified version of gfc_conv_procedure_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, gfc_build_addr_expr (NULL_TREE, lse->expr));
-  args = gfc_chainon_list (args, gfc_build_addr_expr (NULL_TREE, 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);
-  conv_function_val (&se, sym, NULL);
-  tmp = TREE_TYPE (TREE_TYPE (TREE_TYPE (se.expr)));
-  tmp = build_call_list (tmp, se.expr, args);
-  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

gcc/fortran/trans-stmt.c

@@ -270,9 +270,11 @@ gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse,
 	  gfc_conv_expr_descriptor (&parmse, e, gfc_walk_expr (e));
 	  gfc_add_block_to_block (&se->pre, &parmse.pre);
 
-	  /* If we've got INTENT(INOUT), initialize the array temporary with
-	     a copy of the values.  */
-	  if (fsym->attr.intent == INTENT_INOUT)
+	  /* If we've got INTENT(INOUT) or a derived type with INTENT(OUT),
+	     initialize the array temporary with a copy of the values.  */
+	  if (fsym->attr.intent == INTENT_INOUT
+		|| (fsym->ts.type ==BT_DERIVED
+		      && fsym->attr.intent == INTENT_OUT))
 	    initial = parmse.expr;
 	  else
 	    initial = NULL_TREE;
@@ -332,12 +334,16 @@ gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse,
 /* Translate the CALL statement.  Builds a call to an F95 subroutine.  */
 
 tree
-gfc_trans_call (gfc_code * code, bool dependency_check)
+gfc_trans_call (gfc_code * code, bool dependency_check,
+		tree mask, tree count1, bool invert)
 {
   gfc_se se;
   gfc_ss * ss;
   int has_alternate_specifier;
   gfc_dep_check check_variable;
+  tree index = NULL_TREE;
+  tree maskexpr = NULL_TREE;
+  tree tmp;
 
   /* A CALL starts a new block because the actual arguments may have to
      be evaluated first.  */
@@ -429,10 +435,32 @@ gfc_trans_call (gfc_code * code, bool dependency_check)
       gfc_start_scalarized_body (&loop, &body);
       gfc_init_block (&block);
 
+      if (mask && count1)
+	{
+	  /* Form the mask expression according to the mask.  */
+	  index = count1;
+	  maskexpr = gfc_build_array_ref (mask, index, NULL);
+	  if (invert)
+	    maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr),
+				    maskexpr);
+	}
+
       /* Add the subroutine call to the block.  */
-      gfc_conv_procedure_call (&loopse, code->resolved_sym, code->ext.actual,
-			      code->expr, NULL_TREE);
-      gfc_add_expr_to_block (&loopse.pre, loopse.expr);
+      gfc_conv_procedure_call (&loopse, code->resolved_sym,
+			       code->ext.actual, code->expr,
+			       NULL_TREE);
+
+      if (mask && count1)
+	{
+	  tmp = build3_v (COND_EXPR, maskexpr, loopse.expr,
+			  build_empty_stmt ());
+	  gfc_add_expr_to_block (&loopse.pre, tmp);
+	  tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+			     count1, gfc_index_one_node);
+	  gfc_add_modify (&loopse.pre, count1, tmp);
+	}
+      else
+	gfc_add_expr_to_block (&loopse.pre, loopse.expr);
 
       gfc_add_block_to_block (&block, &loopse.pre);
       gfc_add_block_to_block (&block, &loopse.post);
@@ -3028,7 +3056,7 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
 	/* Explicit subroutine calls are prevented by the frontend but interface
 	   assignments can legitimately produce them.  */
 	case EXEC_ASSIGN_CALL:
-	  assign = gfc_trans_call (c, true);
+	  assign = gfc_trans_call (c, true, NULL_TREE, NULL_TREE, false);
           tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1);
           gfc_add_expr_to_block (&block, tmp);
           break;
@@ -3223,7 +3251,7 @@ static tree
 gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2,
 			tree mask, bool invert,
                         tree count1, tree count2,
-			gfc_symbol *sym)
+			gfc_code *cnext)
 {
   gfc_se lse;
   gfc_se rse;
@@ -3237,6 +3265,10 @@ gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2,
   stmtblock_t body;
   tree index, maskexpr;
 
+  /* A defined assignment. */  
+  if (cnext && cnext->resolved_sym)
+    return gfc_trans_call (cnext, true, mask, count1, invert);
+
 #if 0
   /* TODO: handle this special case.
      Special case a single function returning an array.  */
@@ -3338,11 +3370,8 @@ 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.  */
-  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 = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
+				 loop.temp_ss != NULL, false);
 
   tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
 
@@ -3609,7 +3638,7 @@ gfc_trans_where_2 (gfc_code * code, tree mask, bool invert,
                       tmp = gfc_trans_where_assign (expr1, expr2,
 						    cmask, invert,
 						    count1, count2,
-						    cnext->resolved_sym);
+						    cnext);
 
                       tmp = gfc_trans_nested_forall_loop (nested_forall_info,
                                                           tmp, 1);
@@ -3627,7 +3656,7 @@ gfc_trans_where_2 (gfc_code * code, tree mask, bool invert,
                   tmp = gfc_trans_where_assign (expr1, expr2,
 						cmask, invert,
 						count1, count2,
-						cnext->resolved_sym);
+						cnext);
                   gfc_add_expr_to_block (block, tmp);
 
                 }

gcc/fortran/trans-stmt.h

@@ -40,7 +40,7 @@ tree gfc_trans_goto (gfc_code *);
 tree gfc_trans_entry (gfc_code *);
 tree gfc_trans_pause (gfc_code *);
 tree gfc_trans_stop (gfc_code *);
-tree gfc_trans_call (gfc_code *, bool);
+tree gfc_trans_call (gfc_code *, bool, tree, tree, bool);
 tree gfc_trans_return (gfc_code *);
 tree gfc_trans_if (gfc_code *);
 tree gfc_trans_arithmetic_if (gfc_code *);

gcc/fortran/trans.c

@@ -1111,16 +1111,19 @@ gfc_trans_code (gfc_code * code)
 	    if (code->resolved_isym
 		&& code->resolved_isym->id == GFC_ISYM_MVBITS)
 	      is_mvbits = true;
-	    res = gfc_trans_call (code, is_mvbits);
+	    res = gfc_trans_call (code, is_mvbits, NULL_TREE,
+				  NULL_TREE, false);
 	  }
 	  break;
 
 	case EXEC_CALL_PPC:
-	  res = gfc_trans_call (code, false);
+	  res = gfc_trans_call (code, false, NULL_TREE,
+				NULL_TREE, false);
 	  break;
 
 	case EXEC_ASSIGN_CALL:
-	  res = gfc_trans_call (code, true);
+	  res = gfc_trans_call (code, true, NULL_TREE,
+				NULL_TREE, false);
 	  break;
 
 	case EXEC_RETURN:

gcc/fortran/trans.h

@@ -310,9 +310,6 @@ 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 *);
-
 /* Used to call ordinary functions/subroutines
    and procedure pointer components.  */
 int gfc_conv_procedure_call (gfc_se *, gfc_symbol *, gfc_actual_arglist *,

gcc/testsuite/ChangeLog

-2009-04-10  David Billinghurst <billingd@gcc.gnu.org>
+2009-05-10  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/38863
+	* gfortran.dg/dependency_24.f90: New test.
+	* gfortran.dg/dependency_23.f90: Clean up module files.
+
+2009-05-10  David Billinghurst <billingd@gcc.gnu.org>
 
 	PR fortran/38956
 	* gfortran.dg/chmod_1.f90: Don't run on *-*-cygwin*.

gcc/testsuite/gfortran.dg/dependency_23.f90

@@ -52,5 +52,6 @@ end module rg0045_stuff
   use rg0045_stuff
   call rg0045(1, 2, 3)
 end
+! { dg-final { cleanup-modules "rg0045_stuff" } }
 
 

gcc/testsuite/gfortran.dg/dependency_23.f90.rej

+***************
+*** 52,56 ****
+    use rg0045_stuff
+    call rg0045(1, 2, 3)
+  end
+  
+  
+--- 52,57 ----
+    use rg0045_stuff
+    call rg0045(1, 2, 3)
+  end
++ ! { dg-final { cleanup-modules "rg0045_stuff" } }
+  
+  

gcc/testsuite/gfortran.dg/dependency_24.f90

+! { dg-do run }
+! Check the fix for PR38863 comment #1, where defined assignment
+! to derived types was not treating components correctly that were
+! not set explicitly.
+!
+! Contributed by Mikael Morin  <mikael@gcc.gnu.org>
+!
+module m
+  type t
+    integer :: i,j
+  end type t
+  type ti
+    integer :: i,j = 99
+  end type ti
+  interface assignment (=)
+    module procedure i_to_t, i_to_ti
+  end interface
+contains 
+  elemental subroutine i_to_ti (p, q)
+    type(ti), intent(out) :: p
+    integer, intent(in)  :: q
+    p%i = q
+  end subroutine
+  elemental subroutine i_to_t (p, q)
+    type(t), intent(out) :: p
+    integer, intent(in)  :: q
+    p%i = q
+  end subroutine
+end module
+
+  use m
+  call test_t  ! Check original problem
+  call test_ti ! Default initializers were treated wrongly
+contains
+  subroutine test_t
+    type(t), target :: a(3)
+    type(t), target  :: b(3)
+    type(t), dimension(:), pointer :: p
+    logical :: l(3)
+
+    a%i = 1
+    a%j = [101, 102, 103]
+    b%i = 3
+    b%j = 4
+
+    p => b
+    l = .true.
+
+    where (l)
+      a = p%i         ! Comment #1 of PR38863 concerned WHERE assignment
+    end where
+    if (any (a%j .ne. [101, 102, 103])) call abort
+
+    a = p%i           ! Ordinary assignment was wrong too.
+    if (any (a%j .ne. [101, 102, 103])) call abort
+  end subroutine
+
+  subroutine test_ti
+    type(ti), target :: a(3)
+    type(ti), target  :: b(3)
+    type(ti), dimension(:), pointer :: p
+    logical :: l(3)
+
+    a%i = 1
+    a%j = [101, 102, 103]
+    b%i = 3
+    b%j = 4
+
+    p => b
+    l = .true.
+
+    where (l)
+      a = p%i
+    end where
+    if (any (a%j .ne. 99)) call abort
+
+    a = p%i
+    if (any (a%j .ne. 99)) call abort
+  end subroutine
+end
+! { dg-final { cleanup-modules "m" } }