From b1c1d761c1db41d94e6791c0b4f8a476e91fa671 Mon Sep 17 00:00:00 2001 From: "Steven G. Kargl" Date: Sat, 21 Nov 2015 16:25:23 +0000 Subject: [PATCH] simplify.c (gfc_simplify_cshift): Implement simplification of CSHIFT. 2015-11-21 Steven G. Kargl * simplify.c (gfc_simplify_cshift): Implement simplification of CSHIFT. (gfc_simplify_spread): Remove a FIXME and add error condition. * intrinsic.h: Prototype for gfc_simplify_cshift * intrinsic.c (add_functions): Use gfc_simplify_cshift. 2015-11-21 Steven G. Kargl * gfortran.dg/simplify_cshift_1.f90: New test. From-SVN: r230709 --- gcc/fortran/ChangeLog | 8 ++ gcc/fortran/intrinsic.c | 8 +- gcc/fortran/intrinsic.h | 1 + gcc/fortran/simplify.c | 97 ++++++++++++++++++- gcc/testsuite/ChangeLog | 4 + .../gfortran.dg/simplify_cshift_1.f90 | 46 +++++++++ 6 files changed, 157 insertions(+), 7 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/simplify_cshift_1.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index e576570ae77..1d11ae74ff2 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,11 @@ +2015-11-21 Steven G. Kargl + + * simplify.c (gfc_simplify_cshift): Implement simplification of + CSHIFT for rank=1 arrays. + (gfc_simplify_spread): Remove a FIXME and add error condition. + * intrinsic.h: Prototype for gfc_simplify_cshift + * intrinsic.c (add_functions): Use gfc_simplify_cshift. + 2015-11-20 Steven G. Kargl PR fortran/68237 diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 17410925245..4e6a0d0e34a 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -1659,9 +1659,11 @@ add_functions (void) make_generic ("count", GFC_ISYM_COUNT, GFC_STD_F95); - add_sym_3 ("cshift", GFC_ISYM_CSHIFT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, - gfc_check_cshift, NULL, gfc_resolve_cshift, - ar, BT_REAL, dr, REQUIRED, sh, BT_INTEGER, di, REQUIRED, + add_sym_3 ("cshift", GFC_ISYM_CSHIFT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, + BT_REAL, dr, GFC_STD_F95, + gfc_check_cshift, gfc_simplify_cshift, gfc_resolve_cshift, + ar, BT_REAL, dr, REQUIRED, + sh, BT_INTEGER, di, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL); make_generic ("cshift", GFC_ISYM_CSHIFT, GFC_STD_F95); diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index 971cf7c9feb..ca2ad306e0d 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -271,6 +271,7 @@ gfc_expr *gfc_simplify_conjg (gfc_expr *); gfc_expr *gfc_simplify_cos (gfc_expr *); gfc_expr *gfc_simplify_cosh (gfc_expr *); gfc_expr *gfc_simplify_count (gfc_expr *, gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_cshift (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_dcmplx (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_dble (gfc_expr *); gfc_expr *gfc_simplify_digits (gfc_expr *); diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 4df3fe6c5b5..9886d9e20e6 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -1788,6 +1788,94 @@ gfc_simplify_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind) } +gfc_expr * +gfc_simplify_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim) +{ + gfc_expr *a, *result; + int dm; + + /* DIM is only useful for rank > 1, but deal with it here as one can + set DIM = 1 for rank = 1. */ + if (dim) + { + if (!gfc_is_constant_expr (dim)) + return NULL; + dm = mpz_get_si (dim->value.integer); + } + else + dm = 1; + + /* Copy array into 'a', simplify it, and then test for a constant array. + An unexpected expr_type causes an ICE. */ + switch (array->expr_type) + { + case EXPR_VARIABLE: + case EXPR_ARRAY: + a = gfc_copy_expr (array); + gfc_simplify_expr (a, 0); + if (!is_constant_array_expr (a)) + { + gfc_free_expr (a); + return NULL; + } + break; + default: + gcc_unreachable (); + } + + if (a->rank == 1) + { + gfc_constructor *ca, *cr; + mpz_t size; + int i, j, shft, sz; + + if (!gfc_is_constant_expr (shift)) + { + gfc_free_expr (a); + return NULL; + } + + shft = mpz_get_si (shift->value.integer); + + /* Case (i): If ARRAY has rank one, element i of the result is + ARRAY (1 + MODULO (i + SHIFT - 1, SIZE (ARRAY))). */ + + mpz_init (size); + gfc_array_size (a, &size); + sz = mpz_get_si (size); + mpz_clear (size); + + /* Adjust shft to deal with right or left shifts. */ + shft = shft < 0 ? 1 - shft : shft; + + /* Special case: Shift to the original order! */ + if (shft % sz == 0) + return a; + + result = gfc_copy_expr (a); + cr = gfc_constructor_first (result->value.constructor); + for (i = 0; i < sz; i++, cr = gfc_constructor_next (cr)) + { + j = (i + shft) % sz; + ca = gfc_constructor_first (a->value.constructor); + while (j-- > 0) + ca = gfc_constructor_next (ca); + cr->expr = gfc_copy_expr (ca->expr); + } + + gfc_free_expr (a); + return result; + } + else + { + /* FIXME: Deal with rank > 1 arrays. For now, don't leak memory. */ + gfc_free_expr (a); + } + + return NULL; +} + + gfc_expr * gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y) { @@ -6089,10 +6177,11 @@ gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_exp } } else - /* FIXME: Returning here avoids a regression in array_simplify_1.f90. - Replace NULL with gcc_unreachable() after implementing - gfc_simplify_cshift(). */ - return NULL; + { + gfc_error ("Simplification of SPREAD at %L not yet implemented", + &source->where); + return &gfc_bad_expr; + } if (source->ts.type == BT_CHARACTER) result->ts.u.cl = source->ts.u.cl; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 8607e99b2ac..10ef5c28246 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2015-11-21 Steven G. Kargl + + * gfortran.dg/simplify_cshift_1.f90: New test. + 2015-11-21 Nathan Sidwell * gcc.dg/atomic-generic.c: Include . diff --git a/gcc/testsuite/gfortran.dg/simplify_cshift_1.f90 b/gcc/testsuite/gfortran.dg/simplify_cshift_1.f90 new file mode 100644 index 00000000000..dbe67f4c8e9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/simplify_cshift_1.f90 @@ -0,0 +1,46 @@ +! { dg-do run } +program foo + + implicit none + + type t + integer i + end type t + + type(t), parameter :: d(5) = [t(1), t(2), t(3), t(4), t(5)] + type(t) e(5), q(5) + + integer, parameter :: a(5) = [1, 2, 3, 4, 5] + integer i, b(5), c(5), v(5) + + c = [1, 2, 3, 4, 5] + + b = cshift(a, -2) + v = cshift(c, -2) + if (any(b /= v)) call abort + + b = cshift(a, 2) + v = cshift(c, 2) + if (any(b /= v)) call abort + + ! Special cases shift = 0, size(a), 1-size(a) + b = cshift([1, 2, 3, 4, 5], 0) + if (any(b /= a)) call abort + b = cshift([1, 2, 3, 4, 5], size(a)) + if (any(b /= a)) call abort + b = cshift([1, 2, 3, 4, 5], 1-size(a)) + if (any(b /= a)) call abort + + ! simplification of array arg. + b = cshift(2 * a, 0) + if (any(b /= 2 * a)) call abort + + ! An array of derived types works too. + e = [t(1), t(2), t(3), t(4), t(5)] + e = cshift(e, 3) + q = cshift(d, 3) + do i = 1, 5 + if (e(i)%i /= q(i)%i) call abort + end do + +end program foo