diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index a14423cc94c..e11523cfad6 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,8 @@ +2013-03-26 Tobias Burnus + + PR fortran/56649 + * simplify.c (gfc_simplify_merge): Simplify more. + 2013-03-25 Tobias Burnus PR fortran/38536 diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index a0909a38349..dc5dad294aa 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -3976,12 +3976,47 @@ gfc_simplify_maskl (gfc_expr *i, gfc_expr *kind_arg) gfc_expr * gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask) { - if (tsource->expr_type != EXPR_CONSTANT - || fsource->expr_type != EXPR_CONSTANT - || mask->expr_type != EXPR_CONSTANT) + gfc_expr * result; + gfc_constructor *tsource_ctor, *fsource_ctor, *mask_ctor; + + if (mask->expr_type == EXPR_CONSTANT) + return gfc_get_parentheses (gfc_copy_expr (mask->value.logical + ? tsource : fsource)); + + if (!mask->rank || !is_constant_array_expr (mask) + || !is_constant_array_expr (tsource) || !is_constant_array_expr (fsource)) return NULL; - return gfc_copy_expr (mask->value.logical ? tsource : fsource); + result = gfc_get_array_expr (tsource->ts.type, tsource->ts.kind, + &tsource->where); + if (tsource->ts.type == BT_DERIVED) + result->ts.u.derived = tsource->ts.u.derived; + else if (tsource->ts.type == BT_CHARACTER) + result->ts.u.cl = tsource->ts.u.cl; + + tsource_ctor = gfc_constructor_first (tsource->value.constructor); + fsource_ctor = gfc_constructor_first (fsource->value.constructor); + mask_ctor = gfc_constructor_first (mask->value.constructor); + + while (mask_ctor) + { + if (mask_ctor->expr->value.logical) + gfc_constructor_append_expr (&result->value.constructor, + gfc_copy_expr (tsource_ctor->expr), + NULL); + else + gfc_constructor_append_expr (&result->value.constructor, + gfc_copy_expr (fsource_ctor->expr), + NULL); + tsource_ctor = gfc_constructor_next (tsource_ctor); + fsource_ctor = gfc_constructor_next (fsource_ctor); + mask_ctor = gfc_constructor_next (mask_ctor); + } + + result->shape = gfc_get_shape (1); + gfc_array_size (result, &result->shape[0]); + + return result; } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 52a1a8d38d7..c1117941e63 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,11 @@ +2013-03-26 Tobias Burnus + + PR fortran/56649 + * gfortran.dg/merge_init_expr_2.f90: New. + * gfortran.dg/merge_char_1.f90: Modify test to + stay a run-time test. + * gfortran.dg/merge_char_3.f90: Ditto. + 2013-03-26 Paolo Carlini * g++.dg/cpp0x/constexpr-friend-2.C: New. diff --git a/gcc/testsuite/gfortran.dg/merge_char_1.f90 b/gcc/testsuite/gfortran.dg/merge_char_1.f90 index 5974e8c06c3..ece939eea06 100644 --- a/gcc/testsuite/gfortran.dg/merge_char_1.f90 +++ b/gcc/testsuite/gfortran.dg/merge_char_1.f90 @@ -4,6 +4,13 @@ ! PR 15327 ! The merge intrinsic didn't work for strings character*2 :: c(2) +logical :: ll(2) + +ll = (/ .TRUE., .FALSE. /) +c = merge( (/ "AA", "BB" /), (/ "CC", "DD" /), ll ) +if (c(1).ne."AA" .or. c(2).ne."DD") call abort () + +c = "" c = merge( (/ "AA", "BB" /), (/ "CC", "DD" /), (/ .TRUE., .FALSE. /) ) if (c(1).ne."AA" .or. c(2).ne."DD") call abort () end diff --git a/gcc/testsuite/gfortran.dg/merge_char_3.f90 b/gcc/testsuite/gfortran.dg/merge_char_3.f90 index 498e3ec73c5..114214136e2 100644 --- a/gcc/testsuite/gfortran.dg/merge_char_3.f90 +++ b/gcc/testsuite/gfortran.dg/merge_char_3.f90 @@ -12,7 +12,8 @@ subroutine foo(a) implicit none character(len=*) :: a character(len=3) :: b -print *, merge(a,b,.true.) ! Unequal character lengths +logical :: ll = .true. +print *, merge(a,b,ll) ! Unequal character lengths end subroutine foo call foo("ab") diff --git a/gcc/testsuite/gfortran.dg/merge_init_expr_2.f90 b/gcc/testsuite/gfortran.dg/merge_init_expr_2.f90 new file mode 100644 index 00000000000..9b20310caf5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/merge_init_expr_2.f90 @@ -0,0 +1,58 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/56649 +! MERGE was not properly compile-time simplified +! +! Contributed by Bill Long +! +module m + implicit none + + integer, parameter :: int32 = 4 + type MPI_Datatype + integer :: i + end type MPI_Datatype + + integer,private,parameter :: dik = kind(0) + type(MPI_Datatype),parameter,private :: MPIx_I4 = MPI_Datatype( 1275069467) + type(MPI_Datatype),parameter,private :: MPIx_I8 = MPI_Datatype( 1275070491) + type(MPI_Datatype),parameter :: MPI_INTEGER = merge(MPIx_I4, MPIx_I8, & + dik==int32) +contains + subroutine foo + integer :: check1 + check1 = MPI_INTEGER%i + end subroutine foo +end module m + +module m2 + implicit none + integer, parameter :: int32 = 4 + type MPI_Datatype + integer :: i + end type MPI_Datatype + + integer,private,parameter :: dik = kind(0) + type(MPI_Datatype),parameter,private :: MPIx_I4 = MPI_Datatype( 1275069467) + type(MPI_Datatype),parameter,private :: MPIx_I8 = MPI_Datatype( 1275070491) + type(MPI_Datatype),parameter :: MPI_INTEGER(1) = merge([MPIx_I4], [MPIx_I8], & + [dik==int32]) +contains + subroutine foo + logical :: check2 + check2 = MPI_INTEGER(1)%i == 1275069467 + end subroutine foo +end module m2 + + +subroutine test + character(len=3) :: one, two, three + logical, parameter :: true = .true. + three = merge (one, two, true) +end subroutine test + +! { dg-final { scan-tree-dump-times "check1 = 1275069467;" 1 "original" } } +! { dg-final { scan-tree-dump-times "check2 = 1;" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_memmove ..void .. &three, .void .. &one, 3.;" 1 "original" } } +! { dg-final { cleanup-tree-dump "original" } }