This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[Patch, fortran] PR30407 - Elemental functions in WHERE assignments wrongly rejected
- From: Paul Thomas <paulthomas2 at wanadoo dot fr>
- To: Fortran List <fortran at gcc dot gnu dot org>, gcc-patches <gcc-patches at gcc dot gnu dot org>
- Date: Sun, 21 Jan 2007 22:57:31 +0100
- Subject: [Patch, fortran] PR30407 - Elemental functions in WHERE assignments wrongly rejected
:ADDPATCH fortran:
This patch came about because I got caught on a train that was stopped
by last week's storm... but that is another story.
The problem is that operator assignments where not supported in WHERE
statements nor in WHERE blocks.
The patch adds resolution of the subroutine call in the appropriate
places. Then, the real fun starts. The existing treatment of operator
assignments cannot be applied easily because of the WHERE mask.
Therefore, I wrote a very much reduced version of
gfc_conv_function_call, gfc_conv_operator_assign, to convert the
specific case of an elemental subroutine with two arguments with a
similar interface to gfc_trans_scalar_assign. It is than a
straightforward job to pass the gfc_symbol for the subroutine to
gfc_trans_where_assign, so that the subroutine can be called if the
symbol is present.
This method of rendering the operator assignment has the huge advantage
that the dependency analysis is left as is and works fine in the new
situation. If this patch survives the test of a few+ weeks, I intend to
submit a patch to clean up all operator assignments by making them
consistent with this one.
The two testcases are (i) the reporter's example; and (ii) a meander
through various cases to check that each works.
Regtested on Cygwin_NT/amd64 - OK for trunk?
Paul
PS In writing this, I have realised that there are cases where hidden
string-length arguments will be needed. This is a trivial addition and
will appear in the committed version, together with a further test; eg.
derived(with character component) = character
should be supported.
2007-01-21 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-21 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.
Index: gcc/testsuite/gfortran.dg/where_operator_assign_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/where_operator_assign_1.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/where_operator_assign_1.f90 (revision 0)
***************
*** 0 ****
--- 1,107 ----
+ ! { 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" } }
Index: gcc/testsuite/gfortran.dg/where_operator_assign_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/where_operator_assign_2.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/where_operator_assign_2.f90 (revision 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" } }
+
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 120859)
--- gcc/fortran/trans-expr.c (working copy)
*************** gfc_conv_function_val (gfc_se * se, gfc_
*** 1249,1254 ****
--- 1249,1290 ----
}
+ /* 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);
+
+ args = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (lse->expr));
+ args = gfc_chainon_list (args, build_fold_addr_expr (rse->expr));
+
+ 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
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c (revision 120859)
--- gcc/fortran/trans-stmt.c (working copy)
*************** gfc_evaluate_where_mask (gfc_expr * me,
*** 2854,2860 ****
static tree
gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2,
tree mask, bool invert,
! tree count1, tree count2)
{
gfc_se lse;
gfc_se rse;
--- 2854,2861 ----
static tree
gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2,
tree mask, bool invert,
! tree count1, tree count2,
! gfc_symbol *sym)
{
gfc_se lse;
gfc_se rse;
*************** gfc_trans_where_assign (gfc_expr *expr1,
*** 2968,2975 ****
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);
tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
gfc_add_expr_to_block (&body, tmp);
--- 2969,2980 ----
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 = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
gfc_add_expr_to_block (&body, tmp);
*************** gfc_trans_where_2 (gfc_code * code, tree
*** 3078,3083 ****
--- 3083,3089 ----
tree ppmask = NULL_TREE;
tree cmask = NULL_TREE;
tree pmask = NULL_TREE;
+ gfc_actual_arglist *arg = cnext->ext.actual;
/* the WHERE statement or the WHERE construct statement. */
cblock = code->block;
*************** gfc_trans_where_2 (gfc_code * code, tree
*** 3189,3201 ****
switch (cnext->op)
{
/* WHERE assignment statement. */
case EXEC_ASSIGN:
expr1 = cnext->expr;
expr2 = cnext->expr2;
if (nested_forall_info != NULL)
{
need_temp = gfc_check_dependency (expr1, expr2, 0);
! if (need_temp)
gfc_trans_assign_need_temp (expr1, expr2,
cmask, invert,
nested_forall_info, block);
--- 3195,3223 ----
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 && cnext->op != EXEC_ASSIGN_CALL)
gfc_trans_assign_need_temp (expr1, expr2,
cmask, invert,
nested_forall_info, block);
*************** gfc_trans_where_2 (gfc_code * code, tree
*** 3209,3215 ****
tmp = gfc_trans_where_assign (expr1, expr2,
cmask, invert,
! count1, count2);
tmp = gfc_trans_nested_forall_loop (nested_forall_info,
tmp, 1);
--- 3231,3238 ----
tmp = gfc_trans_where_assign (expr1, expr2,
cmask, invert,
! count1, count2,
! cnext->resolved_sym);
tmp = gfc_trans_nested_forall_loop (nested_forall_info,
tmp, 1);
*************** gfc_trans_where_2 (gfc_code * code, tree
*** 3226,3232 ****
tmp = gfc_trans_where_assign (expr1, expr2,
cmask, invert,
! count1, count2);
gfc_add_expr_to_block (block, tmp);
}
--- 3249,3256 ----
tmp = gfc_trans_where_assign (expr1, expr2,
cmask, invert,
! count1, count2,
! cnext->resolved_sym);
gfc_add_expr_to_block (block, tmp);
}
Index: gcc/fortran/trans.h
===================================================================
*** gcc/fortran/trans.h (revision 120859)
--- gcc/fortran/trans.h (working copy)
*************** void gfc_conv_intrinsic_function (gfc_se
*** 303,308 ****
--- 303,311 ----
/* 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/resolve.c
===================================================================
*** gcc/fortran/resolve.c (revision 120859)
--- gcc/fortran/resolve.c (working copy)
*************** resolve_where (gfc_code *code, gfc_expr
*** 4574,4579 ****
--- 4574,4583 ----
"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);
*************** gfc_resolve_where_code_in_forall (gfc_co
*** 4773,4778 ****
--- 4777,4787 ----
gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
break;
+ /* WHERE assignment statement */
+ case EXEC_ASSIGN_CALL:
+ resolve_call (cnext);
+ break;
+
/* WHERE or WHERE construct is part of a where-body-construct */
case EXEC_WHERE:
gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
*************** gfc_resolve_forall_body (gfc_code *code,
*** 4811,4816 ****
--- 4820,4828 ----
gfc_resolve_assign_in_forall (c, nvar, var_expr);
break;
+ case EXEC_ASSIGN_CALL:
+ resolve_call (c);
+
/* Because the gfc_resolve_blocks() will handle the nested FORALL,
there is no need to handle it here. */
case EXEC_FORALL: