This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
Re: [Patch, fortran] PR30407 - Elemental functions in WHERE assignments wrongly rejected
Roger,
Here is a corrected version of this patch - it took slightly more than
the "few minutes" mentioned earlier because the patch had suffered
bit-rot in less than a week :-)
Bootstrapped and regtested on Cygwin_NT/amd84
OK for trunk and, after a few weeks, for 4.2?
Paul
PS please see previous mail for an introduction;
http://gcc.gnu.org/ml/fortran/2007-01/msg00503.html
2007-01-23 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-23 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/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 121230)
--- gcc/fortran/trans-expr.c (working copy)
*************** gfc_conv_function_val (gfc_se * se, gfc_
*** 1249,1254 ****
--- 1249,1296 ----
}
+ /* 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
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c (revision 121230)
--- gcc/fortran/trans-stmt.c (working copy)
*************** gfc_evaluate_where_mask (gfc_expr * me,
*** 2878,2884 ****
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;
--- 2878,2885 ----
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,
*** 2992,2999 ****
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);
--- 2993,3004 ----
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
*** 3102,3107 ****
--- 3107,3113 ----
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;
*************** gfc_trans_where_2 (gfc_code * code, tree
*** 3213,3225 ****
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);
--- 3219,3247 ----
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
*** 3233,3239 ****
tmp = gfc_trans_where_assign (expr1, expr2,
cmask, invert,
! count1, count2);
tmp = gfc_trans_nested_forall_loop (nested_forall_info,
tmp, 1);
--- 3255,3262 ----
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
*** 3250,3256 ****
tmp = gfc_trans_where_assign (expr1, expr2,
cmask, invert,
! count1, count2);
gfc_add_expr_to_block (block, tmp);
}
--- 3273,3280 ----
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 121230)
--- 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 121230)
--- gcc/fortran/resolve.c (working copy)
*************** resolve_where (gfc_code *code, gfc_expr
*** 4550,4555 ****
--- 4550,4560 ----
"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
*** 4750,4755 ****
--- 4755,4765 ----
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:
*************** gfc_resolve_forall_body (gfc_code *code,
*** 4789,4794 ****
--- 4799,4808 ----
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:
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,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" } }
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/testsuite/gfortran.dg/where_operator_assign_3.f90
===================================================================
*** gcc/testsuite/gfortran.dg/where_operator_assign_3.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/where_operator_assign_3.f90 (revision 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" } }
+