This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
[Patch, fortran] PR38863 - WHERE with multiple elemental defined assignments gives wrong answer
- From: Paul Richard Thomas <paul dot richard dot thomas at gmail dot com>
- To: "fortran at gcc dot gnu dot org" <fortran at gcc dot gnu dot org>
- Date: Fri, 1 May 2009 15:49:42 +0200
- Subject: [Patch, fortran] PR38863 - WHERE with multiple elemental defined assignments gives wrong answer
Dear All,
The above title has become a misnomer because the original bug was
fixed. Instead, this is the patch to fix the bug reported in comment
#1 of the PR.
Here, defined assignments within WHERE blocks of the kind
derived_type = intrinsic type expression
were not giving the correct result when there were dependences and not
all the fields of the derived type were set. The temporary used in
the assignment was not being primed with the original value.
In addition, ordinary assignments were suffering from the same malady.
On top of these problems, the WHERE assignment was not working
correctly in the case where the derived type has a default
initializer; ie. the original value should be overwritten by the
default.
The attached patch fixes these problems and adds appropriate tests.
Note gfortran now behaves in the same way as ifort and g95.
The patch converts gfc_trans_call to handle WHERE assignments and
gfc_conv_elemental_dependencies is corrected to initialize the
temporary for INTENT_OUT derived types.
Bootstrapped and regtested on FC9/x86_64 - OK for trunk?
Cheers
Paul
2009-05-01 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-01 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.
Index: gcc/fortran/trans.c
===================================================================
--- gcc/fortran/trans.c (revision 146870)
+++ gcc/fortran/trans.c (working copy)
@@ -1111,12 +1111,14 @@
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_ASSIGN_CALL:
- res = gfc_trans_call (code, true);
+ res = gfc_trans_call (code, true, NULL_TREE,
+ NULL_TREE, false);
break;
case EXEC_RETURN:
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c (revision 146872)
+++ gcc/fortran/trans-expr.c (working copy)
@@ -1526,48 +1526,6 @@
}
-/* 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, 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);
- gfc_conv_function_val (&se, sym);
- 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
Index: gcc/fortran/trans.h
===================================================================
--- gcc/fortran/trans.h (revision 146870)
+++ gcc/fortran/trans.h (working copy)
@@ -310,9 +310,6 @@
/* 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);
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c (revision 146870)
+++ gcc/fortran/trans-stmt.c (working copy)
@@ -270,9 +270,11 @@
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 @@
/* 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,11 +435,32 @@
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_function_call (&loopse, code->resolved_sym, code->ext.actual,
- NULL_TREE);
- gfc_add_expr_to_block (&loopse.pre, loopse.expr);
+ gfc_conv_function_call (&loopse, code->resolved_sym,
+ code->ext.actual, 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 +3055,7 @@
/* 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 +3250,7 @@
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 +3264,10 @@
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 +3369,8 @@
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 +3637,7 @@
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 +3655,7 @@
tmp = gfc_trans_where_assign (expr1, expr2,
cmask, invert,
count1, count2,
- cnext->resolved_sym);
+ cnext);
gfc_add_expr_to_block (block, tmp);
}
Index: gcc/fortran/trans-stmt.h
===================================================================
--- gcc/fortran/trans-stmt.h (revision 146870)
+++ gcc/fortran/trans-stmt.h (working copy)
@@ -39,7 +39,7 @@
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 *);
Index: gcc/testsuite/gfortran.dg/dependency_23.f90
===================================================================
--- gcc/testsuite/gfortran.dg/dependency_23.f90 (revision 146870)
+++ gcc/testsuite/gfortran.dg/dependency_23.f90 (working copy)
@@ -52,5 +52,6 @@
use rg0045_stuff
call rg0045(1, 2, 3)
end
+! { dg-final { cleanup-modules "rg0045_stuff" } }
Index: gcc/testsuite/gfortran.dg/dependency_24.f90
===================================================================
--- gcc/testsuite/gfortran.dg/dependency_24.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/dependency_24.f90 (revision 0)
@@ -0,0 +1,82 @@
+! { 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" } }
+