On Thu, Nov 19, 2015 at 04:58:36PM -0800, Steve Kargl wrote: > > 2015-11-19 Steven G. Kargl <ka...@gcc.gnu.org> > > * intrinsic.h: Prototype for gfc_simplify_cshift > * intrinsic.c (add_functions): Use gfc_simplify_cshift. > * simplify.c (gfc_simplify_cshift): Implement simplification of CSHIFT. > (gfc_simplify_spread): Remove a FIXME and add error condition. > > 2015-11-19 Steven G. Kargl <ka...@gcc.gnu.org> > > * gfortran.dg/simplify_cshift_1.f90: New test. >
I've attached an updated patch. The changes consists of 1) better/more comments 2) re-organize code to reduce copying of the array. 3) add optimization for a left/right shift that returns the original array. 4) Don't leak memory. -- Steve
Index: gcc/fortran/intrinsic.c =================================================================== --- gcc/fortran/intrinsic.c (revision 230585) +++ gcc/fortran/intrinsic.c (working copy) @@ -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); Index: gcc/fortran/intrinsic.h =================================================================== --- gcc/fortran/intrinsic.h (revision 230585) +++ gcc/fortran/intrinsic.h (working copy) @@ -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 *); Index: gcc/fortran/simplify.c =================================================================== --- gcc/fortran/simplify.c (revision 230585) +++ gcc/fortran/simplify.c (working copy) @@ -1789,6 +1789,99 @@ gfc_simplify_count (gfc_expr *mask, gfc_ gfc_expr * +gfc_simplify_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim) +{ + int dm; + gfc_expr *a; + + /* 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. + Unexpected expr_type cause 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; + gfc_expr *result; + 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); + + /* Special case: rank 1 array with no shift or a complete shift to + the original order! */ + if (shft == 0 || shft == sz || shft == 1 - sz) + return a; + + /* Adjust shft to deal with right or left shifts. */ + shft = shft < 0 ? 1 - shft : shft; + + 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 + and exit with an error message. */ + gfc_free_expr (a); + gfc_error ("Simplification of CSHIFT with an array with rank > 1 " + "no yet support"); + } + + 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 +6182,11 @@ gfc_simplify_spread (gfc_expr *source, g } } 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; Index: gcc/testsuite/gfortran.dg/simplify_cshift_1.f90 =================================================================== --- gcc/testsuite/gfortran.dg/simplify_cshift_1.f90 (nonexistent) +++ gcc/testsuite/gfortran.dg/simplify_cshift_1.f90 (working copy) @@ -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 workd 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