From 87f1fed51e01dec7314168966353ce72462a4dcb Mon Sep 17 00:00:00 2001 From: pault Date: Sun, 6 Apr 2008 19:37:45 +0000 Subject: [PATCH] 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 + ! + 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" } } git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@133965 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 8 +++++ gcc/fortran/expr.c | 48 +++++++++++++++++---------- gcc/testsuite/ChangeLog | 5 +++ gcc/testsuite/gfortran.dg/simplify_argN_1.f90 | 26 +++++++++++++++ 4 files changed, 69 insertions(+), 18 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/simplify_argN_1.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 160d602dfd1..12afa21286b 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,11 @@ +2008-04-06 Paul Thomas + + 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 PR fortran/35832 diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 329bc722dba..12e88a07420 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -1702,17 +1702,34 @@ scalarize_intrinsic_call (gfc_expr *e) 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 @@ -1745,14 +1762,11 @@ scalarize_intrinsic_call (gfc_expr *e) 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) { @@ -1786,17 +1800,18 @@ scalarize_intrinsic_call (gfc_expr *e) 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; } @@ -2187,11 +2202,8 @@ check_init_expr (gfc_expr *e) 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) diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 9f9caa65ce5..b5b21556f04 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2008-04-06 Paul Thomas + + PR fortran/35780 + * gfortran.dg/simplify_argN_1.f90: New test. + 2008-04-06 Tobias Schlüter PR fortran/35832 diff --git a/gcc/testsuite/gfortran.dg/simplify_argN_1.f90 b/gcc/testsuite/gfortran.dg/simplify_argN_1.f90 new file mode 100644 index 00000000000..933b1f32af7 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/simplify_argN_1.f90 @@ -0,0 +1,26 @@ +! { dg-do run } +! Tests the fix for PR35780, in which the assignment for C was not +! scalarized in expr.c. +! +! Contributed by Dick Hendrickson +! +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" } } -- 2.11.0