From 74f588f2e509200e376dc02f2b7f96f67e634202 Mon Sep 17 00:00:00 2001 From: pault Date: Sat, 27 Jan 2007 18:23:14 +0000 Subject: [PATCH] 2007-01-27 Paul Thomas 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 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. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@121235 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 15 +++ gcc/fortran/resolve.c | 14 +++ gcc/fortran/trans-expr.c | 42 ++++++++ gcc/fortran/trans-stmt.c | 36 +++++-- gcc/fortran/trans.h | 3 + gcc/testsuite/ChangeLog | 7 ++ .../gfortran.dg/where_operator_assign_1.f90 | 108 +++++++++++++++++++++ .../gfortran.dg/where_operator_assign_2.f90 | 106 ++++++++++++++++++++ .../gfortran.dg/where_operator_assign_3.f90 | 81 ++++++++++++++++ 9 files changed, 406 insertions(+), 6 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/where_operator_assign_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/where_operator_assign_2.f90 create mode 100644 gcc/testsuite/gfortran.dg/where_operator_assign_3.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index c81de30..75aa23f 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,18 @@ +2007-01-27 Paul Thomas + + 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 Steven G. Kargl diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 526be48..9a06a98 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -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: diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 2dc78b6..487b6a7 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -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 diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 47a846e..6640cf7 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -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); } diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index d16a5df..a3b6f04 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -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); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 426d683..dd50222 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2007-01-27 Paul Thomas + + 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 * lib/target-supports.exp diff --git a/gcc/testsuite/gfortran.dg/where_operator_assign_1.f90 b/gcc/testsuite/gfortran.dg/where_operator_assign_1.f90 new file mode 100644 index 0000000..c2b4abf --- /dev/null +++ b/gcc/testsuite/gfortran.dg/where_operator_assign_1.f90 @@ -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 +!============================================================================== + +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" } } diff --git a/gcc/testsuite/gfortran.dg/where_operator_assign_2.f90 b/gcc/testsuite/gfortran.dg/where_operator_assign_2.f90 new file mode 100644 index 0000000..420103f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/where_operator_assign_2.f90 @@ -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 +!****************************************************************************** +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" } } + diff --git a/gcc/testsuite/gfortran.dg/where_operator_assign_3.f90 b/gcc/testsuite/gfortran.dg/where_operator_assign_3.f90 new file mode 100644 index 0000000..eddbdfc --- /dev/null +++ b/gcc/testsuite/gfortran.dg/where_operator_assign_3.f90 @@ -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 +!****************************************************************************** +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" } } + -- 2.7.4