[PATCH] (Partial) Implementation of simplificaiton of CSHIFT

[Steve Kargl <sgk@troutmask.apl.washington.edu>]

[-- Attachment #1: Type: text/plain, Size: 1520 bytes --]

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.

-- 
Steve

[-- Attachment #2: cshift.diff --]
[-- Type: text/x-diff, Size: 5109 bytes --]

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,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;
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,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