re PR fortran/45689 ([F03] Missing transformational intrinsic in the trans_func_f2003 list)

2018-01-02  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/45689
	PR fortran/83650
	* simplify.c (gfc_simplify_cshift): Re-implement to allow full
	range of arguments.

2018-01-02  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/45689
	PR fortran/83650
	* gfortran.dg/simplify_cshift_1.f90: Correct erroneous case.
	* gfortran.dg/simplify_cshift_4.f90: New test.

From-SVN: r256084

gcc/fortran/ChangeLog

+2018-01-02  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/45689
+	PR fortran/83650
+	* simplify.c (gfc_simplify_cshift): Re-implement to allow full
+	range of arguments.
+
 2018-01-01  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/83076

gcc/fortran/simplify.c

@@ -1950,92 +1950,212 @@ gfc_simplify_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
     simplify_transformation_to_array (result, mask, dim, mask, gfc_count, NULL);
 }
 
+/* Simplification routine for cshift. This works by copying the array
+   expressions into a one-dimensional array, shuffling the values into another
+   one-dimensional array and creating the new array expression from this.  The
+   shuffling part is basically taken from the library routine.  */
 
 gfc_expr *
 gfc_simplify_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
 {
-  gfc_expr *a, *result;
-  int dm;
+  gfc_expr *result;
+  int which;
+  gfc_expr **arrayvec, **resultvec;
+  gfc_expr **rptr, **sptr;
+  mpz_t size;
+  size_t arraysize, shiftsize, i;
+  gfc_constructor *array_ctor, *shift_ctor;
+  ssize_t *shiftvec, *hptr;
+  ssize_t shift_val, len;
+  ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
+    hs_ex[GFC_MAX_DIMENSIONS],
+    hstride[GFC_MAX_DIMENSIONS], sstride[GFC_MAX_DIMENSIONS],
+    a_extent[GFC_MAX_DIMENSIONS], a_stride[GFC_MAX_DIMENSIONS],
+    h_extent[GFC_MAX_DIMENSIONS],
+    ss_ex[GFC_MAX_DIMENSIONS];
+  ssize_t rsoffset;
+  int d, n;
+  bool continue_loop;
+  gfc_expr **src, **dest;
+
+  if (!is_constant_array_expr (array))
+    return NULL;
+
+  if (shift->rank > 0)
+    gfc_simplify_expr (shift, 1);
 
-  /* DIM is only useful for rank > 1, but deal with it here as one can
-     set DIM = 1 for rank = 1.  */
+  if (!gfc_is_constant_expr (shift))
+    return NULL;
+
+  /* Make dim zero-based.  */
   if (dim)
     {
       if (!gfc_is_constant_expr (dim))
 	return NULL;
-      dm = mpz_get_si (dim->value.integer);
+      which = mpz_get_si (dim->value.integer) - 1;
     }
   else
-    dm = 1;
+    which = 0;
 
-  /* Copy array into 'a', simplify it, and then test for a constant array.  */
-  a = gfc_copy_expr (array);
-  gfc_simplify_expr (a, 0);
-  if (!is_constant_array_expr (a))
-    {
-      gfc_free_expr (a);
-      return NULL;
-    }
+  gfc_array_size (array, &size);
+  arraysize = mpz_get_ui (size);
+  mpz_clear (size);
 
-  if (a->rank == 1)
-    {
-      gfc_constructor *ca, *cr;
-      mpz_t size;
-      int i, j, shft, sz;
+  result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where);
+  result->shape = gfc_copy_shape (array->shape, array->rank);
+  result->rank = array->rank;
+  result->ts.u.derived = array->ts.u.derived;
 
-      if (!gfc_is_constant_expr (shift))
-	{
-	  gfc_free_expr (a);
-	  return NULL;
-	}
+  if (arraysize == 0)
+    return result;
 
-      shft = mpz_get_si (shift->value.integer);
+  arrayvec = XCNEWVEC (gfc_expr *, arraysize);
+  array_ctor = gfc_constructor_first (array->value.constructor);
+  for (i = 0; i < arraysize; i++)
+    {
+      arrayvec[i] = array_ctor->expr;
+      array_ctor = gfc_constructor_next (array_ctor);
+    }
 
-      /*  Case (i):  If ARRAY has rank one, element i of the result is
-	  ARRAY (1 + MODULO (i + SHIFT - 1, SIZE (ARRAY))).  */
+  resultvec = XCNEWVEC (gfc_expr *, arraysize);
 
-      mpz_init (size);
-      gfc_array_size (a, &size);
-      sz = mpz_get_si (size);
-      mpz_clear (size);
+  extent[0] = 1;
+  count[0] = 0;
 
-      /* Adjust shft to deal with right or left shifts. */
-      shft = shft < 0 ? 1 - shft : shft;
+  for (d=0; d < array->rank; d++)
+    {
+      a_extent[d] = mpz_get_si (array->shape[d]);
+      a_stride[d] = d == 0 ? 1 : a_stride[d-1] * a_extent[d-1];
+    }
 
-      /* Special case: Shift to the original order!  */
-      if (sz == 0 || shft % sz == 0)
-	return a;
+  if (shift->rank > 0)
+    {
+      gfc_array_size (shift, &size);
+      shiftsize = mpz_get_ui (size);
+      mpz_clear (size);
+      shiftvec = XCNEWVEC (ssize_t, shiftsize);
+      shift_ctor = gfc_constructor_first (shift->value.constructor);
+      for (d = 0; d < shift->rank; d++)
+	{
+	  h_extent[d] = mpz_get_si (shift->shape[d]);
+	  hstride[d] = d == 0 ? 1 : hstride[d-1] * h_extent[d-1];
+	}
+    }
+  else
+    shiftvec = NULL;
+  
+  /* Shut up compiler */
+  len = 1;
+  rsoffset = 1;
 
-      result = gfc_copy_expr (a);
-      cr = gfc_constructor_first (result->value.constructor);
-      for (i = 0; i < sz; i++, cr = gfc_constructor_next (cr))
+  n = 0;
+  for (d=0; d < array->rank; d++)
+    {
+      if (d == which)
+	{
+	  rsoffset = a_stride[d];
+	  len = a_extent[d];
+	}
+      else
 	{
-	  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);
+	  count[n] = 0;
+	  extent[n] = a_extent[d];
+	  sstride[n] = a_stride[d];
+	  ss_ex[n] = sstride[n] * extent[n];
+	  if (shiftvec)
+	    hs_ex[n] = hstride[n] * extent[n];
+	  n++;
 	}
+    }
 
-      gfc_free_expr (a);
-      return result;
+  if (shiftvec)
+    {
+      for (i = 0; i < shiftsize; i++)
+	{
+	  ssize_t val;
+	  val = mpz_get_si (shift_ctor->expr->value.integer);
+	  val = val % len;
+	  if (val < 0)
+	    val += len;
+	  shiftvec[i] = val;
+	  shift_ctor = gfc_constructor_next (shift_ctor);
+	}
+      shift_val = 0;
     }
   else
     {
-      /* FIXME: Deal with rank > 1 arrays.  For now, don't leak memory.  */
+      shift_val = mpz_get_si (shift->value.integer);
+      shift_val = shift_val % len;
+      if (shift_val < 0)
+	shift_val += len;
+    }
 
-      /* GCC bootstrap is too stupid to realize that the above code for dm
-	 is correct.  First, dim can be specified for a rank 1 array.  It is
-	 not needed in this nor used here.  Second, the code is simply waiting
-	 for someone to implement rank > 1 simplification.   For now, add a
-	 pessimization to the code that has a zero valid reason to be here.  */
-      if (dm > array->rank)
-	gcc_unreachable ();
+  continue_loop = true;
+  d = array->rank;
+  rptr = resultvec;
+  sptr = arrayvec;
+  hptr = shiftvec;
 
-      gfc_free_expr (a);
+  while (continue_loop)
+    {
+      ssize_t sh;
+      if (shiftvec)
+	sh = *hptr;
+      else
+	sh = shift_val;
+
+      src = &sptr[sh * rsoffset];
+      dest = rptr;
+      for (n = 0; n < len - sh; n++)
+	{
+	  *dest = *src;
+	  dest += rsoffset;
+	  src += rsoffset;
+	}
+      src = sptr;
+      for ( n = 0; n < sh; n++)
+	{
+	  *dest = *src;
+	  dest += rsoffset;
+	  src += rsoffset;
+	}
+      rptr += sstride[0];
+      sptr += sstride[0];
+      if (shiftvec)
+	hptr += hstride[0];
+      count[0]++;
+      n = 0;
+      while (count[n] == extent[n])
+	{
+	  count[n] = 0;
+	  rptr -= ss_ex[n];
+	  sptr -= ss_ex[n];
+	  if (shiftvec)
+	    hptr -= hs_ex[n];
+	  n++;
+	  if (n >= d - 1)
+	    {
+	      continue_loop = false;
+	      break;
+	    }
+	  else
+	    {
+	      count[n]++;
+	      rptr += sstride[n];
+	      sptr += sstride[n];
+	      if (shiftvec)
+		hptr += hstride[n];
+	    }
+	}
     }
 
-  return NULL;
+  for (i = 0; i < arraysize; i++)
+    {
+      gfc_constructor_append_expr (&result->value.constructor,
+				   gfc_copy_expr (resultvec[i]),
+				   NULL);
+    }
+  return result;
 }
 
 

gcc/testsuite/ChangeLog

+2018-01-02  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/45689
+	PR fortran/83650
+	* gfortran.dg/simplify_cshift_1.f90: Correct erroneous case.
+	* gfortran.dg/simplify_cshift_4.f90: New test.
+
 2018-01-02  Marek Polacek  <polacek@redhat.com>
 
 	PR c++/81860

gcc/testsuite/gfortran.dg/simplify_cshift_1.f90

@@ -23,12 +23,12 @@ program foo
    v = cshift(c, 2)
    if (any(b /= v)) call abort
 
-   ! Special cases shift = 0, size(a), 1-size(a)
+   ! Special cases shift = 0, size(a), -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))
+   b = cshift([1, 2, 3, 4, 5], -size(a))
    if (any(b /= a)) call abort
 
    ! simplification of array arg.

gcc/testsuite/gfortran.dg/simplify_cshift_4.f90

+! { dg-do  run }
+program main
+  implicit none
+  integer :: i
+  integer, parameter, dimension(3,3) :: a = &
+       reshape([1,2,3,4,5,6,7,8,9], shape(a))
+  integer, dimension(3,3) :: b
+  integer, parameter, dimension(3,4,5) :: c = &
+       reshape([(i**2,i=1,3*4*5)],shape(c))
+  integer, dimension(3,4,5) :: d
+  integer, dimension(4,5), parameter :: sh1 =&
+       reshape([(i**3-12*i**2,i=1,4*5)],shape(sh1))
+  integer, dimension(3,5), parameter :: sh2 = &
+       reshape([(i**3-7*i**2,i=1,3*5)], shape(sh2))
+  integer, dimension(3,4), parameter :: sh3 = &
+       reshape([(i**3-3*i**2,i=1,3*4)], shape(sh3))
+  integer, parameter, dimension(3,4,5) :: c1 = cshift(c,shift=sh1,dim=1)
+  integer, parameter, dimension(3,4,5) :: c2 = cshift(c,shift=sh2,dim=2)
+  integer, parameter, dimension(3,4,5) :: c3 = cshift(c,shift=sh3,dim=3)
+
+  b = a
+  if (any(cshift(a,1) /= cshift(b,1))) call abort
+  if (any(cshift(a,2) /= cshift(b,2))) call abort
+  if (any(cshift(a,1,dim=2) /= cshift(b,1,dim=2))) call abort
+  d = c
+  if (any(cshift(c,1) /= cshift(d,1))) call abort
+  if (any(cshift(c,2) /= cshift(d,2))) call abort
+  if (any(cshift(c,3) /= cshift(d,3))) call abort
+
+  if (any(cshift(c,1,dim=2) /= cshift(d,1,dim=2))) call abort
+  if (any(cshift(c,2,dim=2) /= cshift(d,2,dim=2))) call abort
+  if (any(cshift(c,3,dim=3) /= cshift(d,3,dim=3))) call abort
+
+  if (any(cshift(d,shift=sh1,dim=1) /= c1)) call abort
+  if (any(cshift(d,shift=sh2,dim=2) /= c2)) call abort
+  if (any(cshift(d,shift=sh3,dim=3) /= c3)) call abort
+end program main