re PR fortran/30407 ([4.1 only] Elemental functions in WHERE assignments wrongly rejected)
2007-01-27 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-27 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. * gfortran.dg/where_operator_assign_3.f90: New test. From-SVN: r121235
This commit is contained in:
Paul Thomas
parent
ea6244280b
commit
a00b8d1a38
9 changed files with 406 additions and 6 deletions
|
|
@ -1,3 +1,18 @@
|
|||
2007-01-27 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-26 Steven Bosscher <stevenb.gcc@gmail.com>
|
||||
Steven G. Kargl <kargl@gcc.gnu.org>
|
||||
|
||||
|
|
|
|||
|
|
@ -4550,6 +4550,11 @@ resolve_where (gfc_code *code, gfc_expr *mask)
|
|||
"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);
|
||||
|
|
@ -4750,6 +4755,11 @@ gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
|
|||
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:
|
||||
|
|
@ -4789,6 +4799,10 @@ gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
|
|||
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:
|
||||
|
|
|
|||
|
|
@ -1249,6 +1249,48 @@ 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 = 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
|
||||
|
|
|
|||
|
|
@ -2878,7 +2878,8 @@ gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info,
|
|||
static tree
|
||||
gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2,
|
||||
tree mask, bool invert,
|
||||
tree count1, tree count2)
|
||||
tree count1, tree count2,
|
||||
gfc_symbol *sym)
|
||||
{
|
||||
gfc_se lse;
|
||||
gfc_se rse;
|
||||
|
|
@ -2992,8 +2993,12 @@ 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. */
|
||||
tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
|
||||
loop.temp_ss != NULL, false);
|
||||
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);
|
||||
|
|
@ -3102,6 +3107,7 @@ gfc_trans_where_2 (gfc_code * code, tree mask, bool invert,
|
|||
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;
|
||||
|
|
@ -3213,13 +3219,29 @@ gfc_trans_where_2 (gfc_code * code, tree mask, bool invert,
|
|||
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)
|
||||
if (need_temp && cnext->op != EXEC_ASSIGN_CALL)
|
||||
gfc_trans_assign_need_temp (expr1, expr2,
|
||||
cmask, invert,
|
||||
nested_forall_info, block);
|
||||
|
|
@ -3233,7 +3255,8 @@ gfc_trans_where_2 (gfc_code * code, tree mask, bool invert,
|
|||
|
||||
tmp = gfc_trans_where_assign (expr1, expr2,
|
||||
cmask, invert,
|
||||
count1, count2);
|
||||
count1, count2,
|
||||
cnext->resolved_sym);
|
||||
|
||||
tmp = gfc_trans_nested_forall_loop (nested_forall_info,
|
||||
tmp, 1);
|
||||
|
|
@ -3250,7 +3273,8 @@ gfc_trans_where_2 (gfc_code * code, tree mask, bool invert,
|
|||
|
||||
tmp = gfc_trans_where_assign (expr1, expr2,
|
||||
cmask, invert,
|
||||
count1, count2);
|
||||
count1, count2,
|
||||
cnext->resolved_sym);
|
||||
gfc_add_expr_to_block (block, tmp);
|
||||
|
||||
}
|
||||
|
|
|
|||
|
|
@ -303,6 +303,9 @@ 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,10 @@
|
|||
2007-01-27 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.
|
||||
* gfortran.dg/where_operator_assign_3.f90: New test.
|
||||
|
||||
2007-01-26 Joseph Myers <joseph@codesourcery.com>
|
||||
|
||||
* lib/target-supports.exp
|
||||
|
|
|
|||
108
gcc/testsuite/gfortran.dg/where_operator_assign_1.f90
Normal file
108
gcc/testsuite/gfortran.dg/where_operator_assign_1.f90
Normal file
|
|
@ -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" } }
|
||||
106
gcc/testsuite/gfortran.dg/where_operator_assign_2.f90
Normal file
106
gcc/testsuite/gfortran.dg/where_operator_assign_2.f90
Normal file
|
|
@ -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" } }
|
||||
|
||||
81
gcc/testsuite/gfortran.dg/where_operator_assign_3.f90
Normal file
81
gcc/testsuite/gfortran.dg/where_operator_assign_3.f90
Normal file
|
|
@ -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" } }
|
||||
|
||||
Loading…
Add table
Reference in a new issue