===================================================================
@@ -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);
===================================================================
@@ -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 *);
===================================================================
@@ -1789,6 +1789,88 @@ gfc_simplify_count (gfc_expr *mask, gfc_
gfc_expr *
+gfc_simplify_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
+{
+ gfc_expr *a;
+
+ a = gfc_copy_expr (array);
+
+ switch (a->expr_type)
+ {
+ case EXPR_VARIABLE:
+ case 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))
+ return NULL;
+
+ shft = mpz_get_si (shift->value.integer);
+
+ /* Special case: rank 1 array with no shift! */
+ if (shft == 0)
+ return a;
+
+ /* Case (i): If ARRAY has rank one, element i of the result is
+ ARRAY (1 + MODULO (i + SHIFT 1, SIZE (ARRAY))). */
+
+ result = gfc_copy_expr (a);
+ mpz_init (size);
+ gfc_array_size (a, &size);
+ sz = mpz_get_si (size);
+ mpz_clear (size);
+ shft = shft < 0 ? 1 - shft : shft;
+ 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
+ {
+ int dm;
+
+ if (dim)
+ {
+ if (!gfc_is_constant_expr (dim))
+ return NULL;
+
+ dm = mpz_get_si (dim->value.integer);
+ }
+ else
+ dm = 1;
+
+ 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 +6171,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;
===================================================================
@@ -0,0 +1,38 @@
+! { dg-do compile }
+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
+
+ b = cshift([1, 2, 3, 4, 5], 0)
+ if (any(b /= a)) call abort
+ b = cshift(2*a, 0)
+ if (any(b /= 2*a)) call abort
+
+ 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
The attached patch provides a partial implementation for the simplification for CSHIFT. It is partial in that it only applies to rank 1 arrays. For arrays with rank > 1, gfc_simplify_cshift will issue an error. Here, the intent is that hopefully someone that knows what they are doing with supply a patch for rank > 1. The meat of the patch for rank = 1 may not be the most efficient. It copies the array elements from 'a' to 'result' in the circularly shifted order. It inefficiently always starts with the first element in 'a' to find the candidate element for next 'result' element. 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); } As the values are storied in a splay tree, there may be a more efficient way to split the splay and recombine it into a new. Anyway, I would like to commit the attached patch. Built and tested on x86_64-*-freebsd? 2015-11-19 Steven G. Kargl <kargl@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 <kargl@gcc.gnu.org> * gfortran.dg/simplify_cshift_1.f90: New test.