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. From-SVN: r147345
This commit is contained in:
Paul Thomas
parent
bfdcb9ad09
commit
23c0c8daec
|
|
@ -1,3 +1,23 @@
|
|||
2009-05-10 Paul Thomas <pault@gcc.gnu.org>
|
||||
|
||||
Backport from mainline:
|
||||
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>
|
||||
|
||||
Backport from mainline:
|
||||
|
|
|
|||
|
|
@ -1526,48 +1526,6 @@ 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 = 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
|
||||
|
|
|
|||
|
|
@ -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,31 @@ 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_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);
|
||||
|
|
@ -2981,7 +3008,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;
|
||||
|
|
@ -3176,7 +3203,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;
|
||||
|
|
@ -3190,6 +3217,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. */
|
||||
|
|
@ -3291,11 +3322,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 ());
|
||||
|
||||
|
|
@ -3562,7 +3590,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);
|
||||
|
|
@ -3580,7 +3608,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);
|
||||
|
||||
}
|
||||
|
|
|
|||
|
|
@ -39,7 +39,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 *);
|
||||
|
|
|
|||
|
|
@ -1109,12 +1109,14 @@ 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_ASSIGN_CALL:
|
||||
res = gfc_trans_call (code, true);
|
||||
res = gfc_trans_call (code, true, NULL_TREE,
|
||||
NULL_TREE, false);
|
||||
break;
|
||||
|
||||
case EXEC_RETURN:
|
||||
|
|
|
|||
|
|
@ -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 *);
|
||||
|
||||
/* Also used to CALL subroutines. */
|
||||
int gfc_conv_function_call (gfc_se *, gfc_symbol *, gfc_actual_arglist *,
|
||||
tree);
|
||||
|
|
|
|||
|
|
@ -1,3 +1,9 @@
|
|||
2009-05-10 Paul Thomas <pault@gcc.gnu.org>
|
||||
|
||||
Backport from mainline:
|
||||
PR fortran/38863
|
||||
* gfortran.dg/dependency_24.f90: New test.
|
||||
|
||||
2009-05-10 Paul Thomas <pault@gcc.gnu.org>
|
||||
|
||||
Backport from mainline:
|
||||
|
|
|
|||
|
|
@ -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" } }
|
||||
|
||||
Loading…
Reference in New Issue