diff options
author | Steven G. Kargl <kargl@gcc.gnu.org> | 2015-11-21 16:25:23 +0000 |
---|---|---|
committer | Steven G. Kargl <kargl@gcc.gnu.org> | 2015-11-21 16:25:23 +0000 |
commit | b1c1d761c1db41d94e6791c0b4f8a476e91fa671 (patch) | |
tree | 6c2e1fd6488ddc49dce31cef0d3fa88c4d1e95f5 /gcc | |
parent | d43e15a4243b9e3436fcfa9f38e4d0df9af63074 (diff) | |
download | gcc-b1c1d761c1db41d94e6791c0b4f8a476e91fa671.zip gcc-b1c1d761c1db41d94e6791c0b4f8a476e91fa671.tar.gz gcc-b1c1d761c1db41d94e6791c0b4f8a476e91fa671.tar.bz2 |
simplify.c (gfc_simplify_cshift): Implement simplification of CSHIFT.
2015-11-21 Steven G. Kargl <kargl@gcc.gnu.org>
* 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 <kargl@gcc.gnu.org>
* gfortran.dg/simplify_cshift_1.f90: New test.
From-SVN: r230709
Diffstat (limited to 'gcc')
-rw-r--r-- | gcc/fortran/ChangeLog | 8 | ||||
-rw-r--r-- | gcc/fortran/intrinsic.c | 8 | ||||
-rw-r--r-- | gcc/fortran/intrinsic.h | 1 | ||||
-rw-r--r-- | gcc/fortran/simplify.c | 97 | ||||
-rw-r--r-- | gcc/testsuite/ChangeLog | 4 | ||||
-rw-r--r-- | gcc/testsuite/gfortran.dg/simplify_cshift_1.f90 | 46 |
6 files changed, 157 insertions, 7 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index e576570..1d11ae7 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,11 @@ +2015-11-21 Steven G. Kargl <kargl@gcc.gnu.org> + + * 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 <kargl@gcc.gnu.org> PR fortran/68237 diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 1741092..4e6a0d0 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 971cf7c..ca2ad30 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 4df3fe6..9886d9e 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -1789,6 +1789,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) { return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind); @@ -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 8607e99..10ef5c2 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2015-11-21 Steven G. Kargl <kargl@gcc.gnu.org> + + * gfortran.dg/simplify_cshift_1.f90: New test. + 2015-11-21 Nathan Sidwell <nathan@acm.org> * gcc.dg/atomic-generic.c: Include <string.h>. 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 0000000..dbe67f4 --- /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 |