Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c (revision 133728)
--- gcc/fortran/trans-stmt.c (working copy)
*************** gfc_trans_where_2 (gfc_code * code, tree
*** 3540,3547 ****
/* Translate a simple WHERE construct or statement without dependencies.
CBLOCK is the "then" clause of the WHERE statement, where CBLOCK->EXPR
! is the mask condition, and EBLOCK if non-NULL is the "else" clause.
! Currently both CBLOCK and EBLOCK are restricted to single assignments. */
static tree
gfc_trans_where_3 (gfc_code * cblock, gfc_code * eblock)
--- 3540,3550 ----
/* Translate a simple WHERE construct or statement without dependencies.
CBLOCK is the "then" clause of the WHERE statement, where CBLOCK->EXPR
! is the mask condition, and EBLOCK if non-NULL is the "then" clause of
! the ELSWHERE. As required by 7.5.3.2, the WHERE and ELSEWHERE are
! executed with separate loops. It should be noted that the mask expression
! is evaluated for both loops. Currently both CBLOCK and EBLOCK are
! restricted to single assignments. */
static tree
gfc_trans_where_3 (gfc_code * cblock, gfc_code * eblock)
*************** gfc_trans_where_3 (gfc_code * cblock, gf
*** 3561,3566 ****
--- 3564,3570 ----
edst = eblock ? eblock->next->expr : NULL;
esrc = eblock ? eblock->next->expr2 : NULL;
+ /*---------------First do the WHERE part.----------------*/
gfc_start_block (&block);
gfc_init_loopinfo (&loop);
*************** gfc_trans_where_3 (gfc_code * cblock, gf
*** 3584,3619 ****
gfc_add_ss_to_loop (&loop, tdss);
gfc_add_ss_to_loop (&loop, tsss);
- if (eblock)
- {
- /* Handle the else clause. */
- gfc_init_se (&edse, NULL);
- gfc_init_se (&esse, NULL);
- edss = gfc_walk_expr (edst);
- esss = gfc_walk_expr (esrc);
- if (esss == gfc_ss_terminator)
- {
- esss = gfc_get_ss ();
- esss->next = gfc_ss_terminator;
- esss->type = GFC_SS_SCALAR;
- esss->expr = esrc;
- }
- gfc_add_ss_to_loop (&loop, edss);
- gfc_add_ss_to_loop (&loop, esss);
- }
-
gfc_conv_ss_startstride (&loop);
gfc_conv_loop_setup (&loop);
gfc_mark_ss_chain_used (css, 1);
gfc_mark_ss_chain_used (tdss, 1);
gfc_mark_ss_chain_used (tsss, 1);
! if (eblock)
! {
! gfc_mark_ss_chain_used (edss, 1);
! gfc_mark_ss_chain_used (esss, 1);
! }
!
gfc_start_scalarized_body (&loop, &body);
gfc_copy_loopinfo_to_se (&cse, &loop);
--- 3588,3600 ----
gfc_add_ss_to_loop (&loop, tdss);
gfc_add_ss_to_loop (&loop, tsss);
gfc_conv_ss_startstride (&loop);
gfc_conv_loop_setup (&loop);
gfc_mark_ss_chain_used (css, 1);
gfc_mark_ss_chain_used (tdss, 1);
gfc_mark_ss_chain_used (tsss, 1);
!
gfc_start_scalarized_body (&loop, &body);
gfc_copy_loopinfo_to_se (&cse, &loop);
*************** gfc_trans_where_3 (gfc_code * cblock, gf
*** 3622,3637 ****
cse.ss = css;
tdse.ss = tdss;
tsse.ss = tsss;
- if (eblock)
- {
- gfc_copy_loopinfo_to_se (&edse, &loop);
- gfc_copy_loopinfo_to_se (&esse, &loop);
- edse.ss = edss;
- esse.ss = esss;
- }
gfc_conv_expr (&cse, cond);
! gfc_add_block_to_block (&body, &cse.pre);
cexpr = cse.expr;
gfc_conv_expr (&tsse, tsrc);
--- 3603,3611 ----
cse.ss = css;
tdse.ss = tdss;
tsse.ss = tsss;
gfc_conv_expr (&cse, cond);
! gfc_add_block_to_block (&block, &cse.pre);
cexpr = cse.expr;
gfc_conv_expr (&tsse, tsrc);
*************** gfc_trans_where_3 (gfc_code * cblock, gf
*** 3643,3650 ****
--- 3617,3678 ----
else
gfc_conv_expr (&tdse, tdst);
+ /* Make the assignment on condition 'cond'. */
+ tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts, false, false);
+ tmp = build3_v (COND_EXPR, cexpr, tstmt, build_empty_stmt ());
+ gfc_add_expr_to_block (&body, tmp);
+ gfc_add_block_to_block (&body, &cse.post);
+
+ gfc_trans_scalarizing_loops (&loop, &body);
+ gfc_add_block_to_block (&block, &loop.pre);
+ gfc_add_block_to_block (&block, &loop.post);
+ gfc_cleanup_loop (&loop);
+
+ /*---------------Now do the ELSEWHERE.--------------*/
if (eblock)
{
+ gfc_init_loopinfo (&loop);
+
+ /* Handle the condition. */
+ gfc_init_se (&cse, NULL);
+ css = gfc_walk_expr (cond);
+ gfc_add_ss_to_loop (&loop, css);
+
+ /* Handle the then-clause. */
+ gfc_init_se (&edse, NULL);
+ gfc_init_se (&esse, NULL);
+ edss = gfc_walk_expr (edst);
+ esss = gfc_walk_expr (esrc);
+ if (esss == gfc_ss_terminator)
+ {
+ esss = gfc_get_ss ();
+ esss->next = gfc_ss_terminator;
+ esss->type = GFC_SS_SCALAR;
+ esss->expr = esrc;
+ }
+ gfc_add_ss_to_loop (&loop, edss);
+ gfc_add_ss_to_loop (&loop, esss);
+
+ gfc_conv_ss_startstride (&loop);
+ gfc_conv_loop_setup (&loop);
+
+ gfc_mark_ss_chain_used (css, 1);
+ gfc_mark_ss_chain_used (edss, 1);
+ gfc_mark_ss_chain_used (esss, 1);
+
+ gfc_start_scalarized_body (&loop, &body);
+
+ gfc_copy_loopinfo_to_se (&cse, &loop);
+ gfc_copy_loopinfo_to_se (&edse, &loop);
+ gfc_copy_loopinfo_to_se (&esse, &loop);
+ cse.ss = css;
+ edse.ss = edss;
+ esse.ss = esss;
+
+ gfc_conv_expr (&cse, cond);
+ gfc_add_block_to_block (&body, &cse.pre);
+ cexpr = cse.expr;
+
gfc_conv_expr (&esse, esrc);
if (edss != gfc_ss_terminator && loop.temp_ss != NULL)
{
*************** gfc_trans_where_3 (gfc_code * cblock, gf
*** 3653,3672 ****
}
else
gfc_conv_expr (&edse, edst);
}
- tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts, false, false);
- estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts, false, false)
- : build_empty_stmt ();
- tmp = build3_v (COND_EXPR, cexpr, tstmt, estmt);
- gfc_add_expr_to_block (&body, tmp);
- gfc_add_block_to_block (&body, &cse.post);
-
- gfc_trans_scalarizing_loops (&loop, &body);
- gfc_add_block_to_block (&block, &loop.pre);
- gfc_add_block_to_block (&block, &loop.post);
- gfc_cleanup_loop (&loop);
-
return gfc_finish_block (&block);
}
--- 3681,3700 ----
}
else
gfc_conv_expr (&edse, edst);
+
+ /* Make the assignment on condition 'NOT.cond'. */
+ estmt = gfc_trans_scalar_assign (&edse, &esse, edst->ts, false, false);
+ cexpr = fold_build1 (TRUTH_NOT_EXPR, boolean_type_node, cexpr);
+ tmp = build3_v (COND_EXPR, cexpr, estmt, build_empty_stmt ());
+ gfc_add_expr_to_block (&body, tmp);
+ gfc_add_block_to_block (&body, &cse.post);
+
+ gfc_trans_scalarizing_loops (&loop, &body);
+ gfc_add_block_to_block (&block, &loop.pre);
+ gfc_add_block_to_block (&block, &loop.post);
+ gfc_cleanup_loop (&loop);
}
return gfc_finish_block (&block);
}
*************** gfc_trans_where (gfc_code * code)
*** 3698,3708 ****
cblock->next->expr2, 0))
return gfc_trans_where_3 (cblock, NULL);
}
else if (!eblock->expr
&& !eblock->block
&& eblock->next
&& eblock->next->op == EXEC_ASSIGN
! && !eblock->next->next)
{
/* A simple "WHERE (cond) x1 = y1 ELSEWHERE x2 = y2 ENDWHERE"
block is dependence free if cond is not dependent on writes
--- 3726,3739 ----
cblock->next->expr2, 0))
return gfc_trans_where_3 (cblock, NULL);
}
+ /* Since gfc_trans_where_3 evaluates the condition expression
+ twice, do not use it if the condition is not a variable. */
else if (!eblock->expr
&& !eblock->block
&& eblock->next
&& eblock->next->op == EXEC_ASSIGN
! && !eblock->next->next
! && cblock->expr->expr_type == EXPR_VARIABLE)
{
/* A simple "WHERE (cond) x1 = y1 ELSEWHERE x2 = y2 ENDWHERE"
block is dependence free if cond is not dependent on writes
Index: gcc/testsuite/gfortran.dg/where_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/where_1.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/where_1.f90 (revision 0)
***************
*** 0 ****
--- 1,61 ----
+ ! { dg-do run }
+ ! { dg-options "-fdump-tree-original" }
+ ! Tests the fix for PR35759, in which the simple WHERE was logically
+ ! wrong. 7.5.3.2 requires that the WHERE and ELSEWHERE are execute in
+ ! separate loops, whereas gfortran was implementing them as a single
+ ! loop with an 'if' and 'else'. Since the condition expression is
+ ! evaluated twice with the fix, the use of anything other than a
+ ! variable or parameter array for the condition will trigger the more
+ ! comprehensive implementation of WHERE. This is checked by the
+ ! check of the declaration of temp.15 in the 'original' code.
+ !
+ ! Contributed by Dick Hendrickson <dick.hendrickson@gmail.com>
+ !
+ program RG0023
+
+ integer UDA1L(6)
+ integer :: UDA1R(6), expected(6) = (/2,0,5,0,3,0/)
+ LOGICAL LDA(5)
+ LOGICAL, parameter :: PDA(5) = (/ (i/2*2 .ne. I, i=1,5) /)
+
+ UDA1L(1:6) = 0
+ uda1r = (/1,2,3,4,5,6/)
+ lda = pda
+
+ WHERE (lda) ! expected
+ UDA1L(1:5) = UDA1R(2:6) ! uda1l = 2,0,4,0,6,0
+ ELSEWHERE
+ UDA1L(2:6) = UDA1R(6:2:-1) !uda1l = 2,0,5,0,3,0
+ ENDWHERE
+
+ if (any (uda1l /= expected)) call abort ()
+
+ uda1l = 0
+
+ WHERE (pda) ! expected
+ UDA1L(1:5) = UDA1R(2:6) ! uda1l = 2,0,4,0,6,0
+ ELSEWHERE
+ UDA1L(2:6) = UDA1R(6:2:-1) !uda1l = 2,0,5,0,3,0
+ ENDWHERE
+
+ if (any (uda1l /= expected)) call abort ()
+
+ uda1l = 0
+
+ WHERE (lfoo ()) ! expected
+ UDA1L(1:5) = UDA1R(2:6) ! uda1l = 2,0,4,0,6,0
+ ELSEWHERE
+ UDA1L(2:6) = UDA1R(6:2:-1) !uda1l = 2,0,5,0,3,0
+ ENDWHERE
+
+ if (any (uda1l /= expected)) call abort ()
+
+ contains
+
+ function lfoo () result (ltmp)
+ logical ltmp(5)
+ ltmp = lda
+ end function lfoo
+ END
+ ! { dg-final { scan-tree-dump-times "temp.18\\\[5\\\]" 1 "original" } }
+ ! { dg-final { cleanup-tree-dump "original" } }
From-SVN: r133965
+2008-04-06 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/35780
+ * expr.c (scalarize_intrinsic_call): Identify which argument is
+ an array and use that as the template.
+ (check_init_expr): Remove tests that first argument is an array
+ in the call to scalarize_intrinsic_call.
+
2008-04-06 Tobias Schlüter <tobi@gcc.gnu.org>
PR fortran/35832
gfc_actual_arglist *a, *b;
gfc_constructor *args[5], *ctor, *new_ctor;
gfc_expr *expr, *old;
- int n, i, rank[5];
+ int n, i, rank[5], array_arg;
old = gfc_copy_expr (e);
-/* Assume that the old expression carries the type information and
- that the first arg carries all the shape information. */
- expr = gfc_copy_expr (old->value.function.actual->expr);
+
+ /* Find which, if any, arguments are arrays. Assume that the old
+ expression carries the type information and that the first arg
+ that is an array expression carries all the shape information.*/
+ n = array_arg = 0;
+ a = old->value.function.actual;
+ for (; a; a = a->next)
+ {
+ n++;
+ if (a->expr->expr_type != EXPR_ARRAY)
+ continue;
+ array_arg = n;
+ expr = gfc_copy_expr (a->expr);
+ break;
+ }
+
+ if (!array_arg)
+ goto cleanup;
+
gfc_free_constructor (expr->value.constructor);
expr->value.constructor = NULL;
expr->ts = old->ts;
+ expr->where = old->where;
expr->expr_type = EXPR_ARRAY;
/* Copy the array argument constructors into an array, with nulls
n++;
}
- for (i = 1; i < n; i++)
- if (rank[i] && rank[i] != rank[0])
- goto compliance;
/* Using the first argument as the master, step through the array
calling the function for each element and advancing the array
constructors together. */
- ctor = args[0];
+ ctor = args[array_arg - 1];
new_ctor = NULL;
for (; ctor; ctor = ctor->next)
{
b = b->next;
}
- /* Simplify the function calls. */
- if (gfc_simplify_expr (new_ctor->expr, 0) == FAILURE)
- goto cleanup;
+ /* Simplify the function calls. If the simplification fails, the
+ error will be flagged up down-stream or the library will deal
+ with it. */
+ gfc_simplify_expr (new_ctor->expr, 0);
for (i = 0; i < n; i++)
if (args[i])
args[i] = args[i]->next;
for (i = 1; i < n; i++)
- if (rank[i] && ((args[i] != NULL && args[0] == NULL)
- || (args[i] == NULL && args[0] != NULL)))
+ if (rank[i] && ((args[i] != NULL && args[array_arg - 1] == NULL)
+ || (args[i] == NULL && args[array_arg - 1] != NULL)))
goto compliance;
}
array argument. */
isym = gfc_find_function (e->symtree->n.sym->name);
if (isym && isym->elemental
- && e->value.function.actual->expr->expr_type == EXPR_ARRAY)
- {
- if ((t = scalarize_intrinsic_call (e)) == SUCCESS)
- break;
- }
+ && (t = scalarize_intrinsic_call (e)) == SUCCESS)
+ break;
}
if (m == MATCH_YES)
+2008-04-06 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/35780
+ * gfortran.dg/simplify_argN_1.f90: New test.
+
2008-04-06 Tobias Schlüter <tobi@gcc.gnu.org>
PR fortran/35832
--- /dev/null
+! { dg-do run }
+! Tests the fix for PR35780, in which the assignment for C was not
+! scalarized in expr.c.
+!
+! Contributed by Dick Hendrickson <dick.hendrickson@gmail.com>
+!
+MODULE MODS
+ integer, parameter :: N = 10
+ INTEGER, PARAMETER, DIMENSION(N) :: A = [(i, i = 1, N)]
+ INTEGER, PARAMETER, DIMENSION(N) :: B = [(i - 5, i = 1, N)]
+ INTEGER, PARAMETER, DIMENSION(N) :: C = ISHFTC(3, B, 5) !ICE
+ INTEGER, PARAMETER, DIMENSION(N) :: D = ISHFTC(A, 3, 5) ! OK
+ INTEGER, PARAMETER, DIMENSION(N) :: E = ISHFTC(A, B, 5) ! OK
+
+END MODULE MODS
+
+ use mods
+ integer, dimension(N) :: X = A
+ integer, dimension(N) :: Y = B
+
+! Check the simplifed expressions against the library
+ if (any (ISHFTC(3, Y, 5) /= C)) call abort ()
+ if (any (ISHFTC(X, 3, 5) /= D)) call abort ()
+ if (any (ISHFTC(X, Y, 5) /= E)) call abort ()
+end
+! { dg-final { cleanup-modules "mods" } }
projects / gcc.git / commitdiff