diff options
| -rw-r--r-- | gcc/fortran/simplify.cc | 17 | ||||
| -rw-r--r-- | gcc/fortran/trans-intrinsic.cc | 3 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/merge_1.f90 | 49 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/merge_init_expr_2.f90 | 3 |
4 files changed, 70 insertions, 2 deletions
diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc index 9c2fea8..b618418 100644 --- a/gcc/fortran/simplify.cc +++ b/gcc/fortran/simplify.cc @@ -4913,7 +4913,22 @@ gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask) if (mask->expr_type == EXPR_CONSTANT) { - result = gfc_copy_expr (mask->value.logical ? tsource : fsource); + /* The standard requires evaluation of all function arguments. + Simplify only when the other dropped argument (FSOURCE or TSOURCE) + is a constant expression. */ + if (mask->value.logical) + { + if (!gfc_is_constant_expr (fsource)) + return NULL; + result = gfc_copy_expr (tsource); + } + else + { + if (!gfc_is_constant_expr (tsource)) + return NULL; + result = gfc_copy_expr (fsource); + } + /* Parenthesis is needed to get lower bounds of 1. */ result = gfc_get_parentheses (result); gfc_simplify_expr (result, 1); diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc index bb93802..9342698 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -7557,6 +7557,9 @@ gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr) &se->pre); se->string_length = len; } + tsource = gfc_evaluate_now (tsource, &se->pre); + fsource = gfc_evaluate_now (fsource, &se->pre); + mask = gfc_evaluate_now (mask, &se->pre); type = TREE_TYPE (tsource); se->expr = fold_build3_loc (input_location, COND_EXPR, type, mask, tsource, fold_convert (type, fsource)); diff --git a/gcc/testsuite/gfortran.dg/merge_1.f90 b/gcc/testsuite/gfortran.dg/merge_1.f90 new file mode 100644 index 0000000..abbc227 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/merge_1.f90 @@ -0,0 +1,49 @@ +! { dg-do run } +! PR fortran/107874 - merge not using all its arguments +! Contributed by John Harper + +program testmerge9 + implicit none + integer :: i + logical :: x(2) = (/.true., .false./) + logical :: called(2) + + ! At run-time all arguments shall be evaluated + do i = 1,2 + called = .false. + print *, merge (tstuff(), fstuff(), x(i)) + if (any (.not. called)) stop 1 + end do + + ! Compile-time simplification shall not drop non-constant args + called = .false. + print *, merge (tstuff(),fstuff(),.true.) + if (any (.not. called)) stop 2 + called = .false. + print *, merge (tstuff(),fstuff(),.false.) + if (any (.not. called)) stop 3 + called = .false. + print *, merge (tstuff(),.false.,.true.) + if (any (called .neqv. [.true.,.false.])) stop 4 + called = .false. + print *, merge (tstuff(),.false.,.false.) + if (any (called .neqv. [.true.,.false.])) stop 5 + called = .false. + print *, merge (.true.,fstuff(),.true.) + if (any (called .neqv. [.false.,.true.])) stop 6 + called = .false. + print *, merge (.true.,fstuff(),.false.) + if (any (called .neqv. [.false.,.true.])) stop 7 +contains + logical function tstuff() + print *,'tstuff' + tstuff = .true. + called(1) = .true. + end function tstuff + + logical function fstuff() + print *,'fstuff' + fstuff = .false. + called(2) = .true. + end function fstuff +end program testmerge9 diff --git a/gcc/testsuite/gfortran.dg/merge_init_expr_2.f90 b/gcc/testsuite/gfortran.dg/merge_init_expr_2.f90 index c761a47..f4a8380 100644 --- a/gcc/testsuite/gfortran.dg/merge_init_expr_2.f90 +++ b/gcc/testsuite/gfortran.dg/merge_init_expr_2.f90 @@ -48,7 +48,8 @@ end module m2 subroutine test - character(len=3) :: one, two, three + character(len=3) :: one, three + character(len=3), parameter :: two = "def" logical, parameter :: true = .true. three = merge (one, two, true) end subroutine test |