+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>
"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);
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_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:
}
+/* 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
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;
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);
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;
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);
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);
tmp = gfc_trans_where_assign (expr1, expr2,
cmask, invert,
- count1, count2);
+ count1, count2,
+ cnext->resolved_sym);
gfc_add_expr_to_block (block, tmp);
}
/* 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);
+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
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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" } }
+
--- /dev/null
+! { 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" } }
+
OSDN Git Service
