re PR fortran/83683 (eoshift accepts wrong-length boundary)

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

	PR fortran/83683
	PR fortran/45689
	* check.c (gfc_check_eoshift): Check for string length and
	for conformance of boundary.
	* intrinsic.c (add_functions): Add gfc_simplify_eoshift.
	* intrinsic.h: Add prototype for gfc_simplify_eoshift.
	* simplify.c (gfc_simplify_eoshift): New function.

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

	PR fortran/83683
	PR fortran/45689
	* gfortran.dg/eoshift_8.f90: New test.
	* gfortran.dg/simplify_eoshift_1.f90: New test.

From-SVN: r256265

5 files changed, 325 insertions, 16 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 480f36a..7eb453d 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,13 @@
+2018-01-04  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/83683
+	PR fortran/45689
+	* check.c (gfc_check_eoshift): Check for string length and
+	for conformance of boundary.
+	* intrinsic.c (add_functions): Add gfc_simplify_eoshift.
+	* intrinsic.h: Add prototype for gfc_simplify_eoshift.
+	* simplify.c (gfc_simplify_eoshift): New function.
+
 2018-01-03  Richard Sandiford  <richard.sandiford@linaro.org>
 	    Alan Hayward  <alan.hayward@arm.com>
 	    David Sherwood  <david.sherwood@arm.com>
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 9f0f4d5..fccb927 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -2185,6 +2185,8 @@ bool
 gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
 		   gfc_expr *dim)
 {
+  int d;
+
   if (!array_check (array, 0))
     return false;
 
@@ -2197,6 +2199,13 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
   if (!dim_rank_check (dim, array, false))
     return false;
 
+  if (!dim)
+    d = 1;
+  else if (dim->expr_type == EXPR_CONSTANT)
+    gfc_extract_int (dim, &d);
+  else
+    d = -1;
+
   if (array->rank == 1 || shift->rank == 0)
     {
       if (!scalar_check (shift, 1))
@@ -2204,14 +2213,6 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
     }
   else if (shift->rank == array->rank - 1)
     {
-      int d;
-      if (!dim)
-	d = 1;
-      else if (dim->expr_type == EXPR_CONSTANT)
-	gfc_extract_int (dim, &d);
-      else
-	d = -1;
-
       if (d > 0)
 	{
 	  int i, j;
@@ -2246,6 +2247,24 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
       if (!same_type_check (array, 0, boundary, 2))
 	return false;
 
+      /* Reject unequal string lengths and emit a better error message than
+       gfc_check_same_strlen would.  */
+      if (array->ts.type == BT_CHARACTER)
+	{
+	  ssize_t len_a, len_b;
+
+	  len_a = gfc_var_strlen (array);
+	  len_b = gfc_var_strlen (boundary);
+	  if (len_a != -1 && len_b != -1 && len_a != len_b)
+	    {
+	      gfc_error ("%qs must be of same type and kind as %qs at %L in %qs",
+			 gfc_current_intrinsic_arg[2]->name,
+			 gfc_current_intrinsic_arg[0]->name,
+			 &boundary->where, gfc_current_intrinsic);
+	      return false;
+	    }
+	}
+      
       if (array->rank == 1 || boundary->rank == 0)
 	{
 	  if (!scalar_check (boundary, 2))
@@ -2253,13 +2272,27 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
 	}
       else if (boundary->rank == array->rank - 1)
 	{
-	  if (!gfc_check_conformance (shift, boundary,
-				      "arguments '%s' and '%s' for "
-				      "intrinsic %s",
-				      gfc_current_intrinsic_arg[1]->name,
-				      gfc_current_intrinsic_arg[2]->name,
-				      gfc_current_intrinsic))
-	    return false;
+	  if (d > 0)
+	    {
+	      int i,j;
+	      for (i = 0, j = 0; i < array->rank; i++)
+		{
+		  if (i != d - 1)
+		    {
+		      if (!identical_dimen_shape (array, i, boundary, j))
+			{
+			  gfc_error ("%qs argument of %qs intrinsic at %L has "
+				     "invalid shape in dimension %d (%ld/%ld)",
+				     gfc_current_intrinsic_arg[2]->name,
+				     gfc_current_intrinsic, &shift->where, i+1,
+				     mpz_get_si (array->shape[i]),
+				     mpz_get_si (boundary->shape[j]));
+			  return false;
+			}
+		      j += 1;
+		    }
+		}
+	    }
 	}
       else
 	{
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index fa262ce..ed732aa 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -1756,7 +1756,7 @@ add_functions (void)
   make_generic ("dshiftr", GFC_ISYM_DSHIFTR, GFC_STD_F2008);
 
   add_sym_4 ("eoshift", GFC_ISYM_EOSHIFT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
-	     gfc_check_eoshift, NULL, gfc_resolve_eoshift,
+	     gfc_check_eoshift, gfc_simplify_eoshift, gfc_resolve_eoshift,
 	     ar, BT_REAL, dr, REQUIRED, sh, BT_INTEGER, ii, REQUIRED,
 	     bd, BT_REAL, dr, OPTIONAL, dm, BT_INTEGER, ii, OPTIONAL);
 
diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index 9fd8316..a7db830 100644
--- a/gcc/fortran/intrinsic.h
+++ b/gcc/fortran/intrinsic.h
@@ -287,6 +287,7 @@ gfc_expr *gfc_simplify_dot_product (gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_dreal (gfc_expr *);
 gfc_expr *gfc_simplify_dshiftl (gfc_expr *, gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_dshiftr (gfc_expr *, gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_eoshift (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_epsilon (gfc_expr *);
 gfc_expr *gfc_simplify_erf (gfc_expr *);
 gfc_expr *gfc_simplify_erfc (gfc_expr *);
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index 55ae05de..bf8a539 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -2348,6 +2348,271 @@ gfc_simplify_dshiftl (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg)
 
 
 gfc_expr *
+gfc_simplify_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
+		   gfc_expr *dim)
+{
+  bool temp_boundary;
+  gfc_expr *bnd;
+  gfc_expr *result;
+  int which;
+  gfc_expr **arrayvec, **resultvec;
+  gfc_expr **rptr, **sptr;
+  mpz_t size;
+  size_t arraysize, i;
+  gfc_constructor *array_ctor, *shift_ctor, *bnd_ctor;
+  ssize_t shift_val, len;
+  ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
+    sstride[GFC_MAX_DIMENSIONS], a_extent[GFC_MAX_DIMENSIONS],
+    a_stride[GFC_MAX_DIMENSIONS], ss_ex[GFC_MAX_DIMENSIONS];
+  ssize_t rsoffset;
+  int d, n;
+  bool continue_loop;
+  gfc_expr **src, **dest;
+  size_t s_len;
+
+  if (!is_constant_array_expr (array))
+    return NULL;
+
+  if (shift->rank > 0)
+    gfc_simplify_expr (shift, 1);
+
+  if (!gfc_is_constant_expr (shift))
+    return NULL;
+
+  if (boundary)
+    {
+      if (boundary->rank > 0)
+	gfc_simplify_expr (boundary, 1);
+      
+      if (!gfc_is_constant_expr (boundary))
+	  return NULL;
+    }
+
+  if (dim)
+    {
+      if (!gfc_is_constant_expr (dim))
+	return NULL;
+      which = mpz_get_si (dim->value.integer) - 1;
+    }
+  else
+    which = 0;
+
+  s_len = 0;
+  if (boundary == NULL)
+    {
+      temp_boundary = true;
+      switch (array->ts.type)
+	{
+	  
+	case BT_INTEGER:
+	  bnd = gfc_get_int_expr (array->ts.kind, NULL, 0);
+	  break;
+
+	case BT_LOGICAL:
+	  bnd = gfc_get_logical_expr (array->ts.kind, NULL, 0);
+	  break;
+
+	case BT_REAL:
+	  bnd = gfc_get_constant_expr (array->ts.type, array->ts.kind, &gfc_current_locus);
+	  mpfr_set_ui (bnd->value.real, 0, GFC_RND_MODE);
+	  break;
+
+	case BT_COMPLEX:
+	  bnd = gfc_get_constant_expr (array->ts.type, array->ts.kind, &gfc_current_locus);
+	  mpc_set_ui (bnd->value.complex, 0, GFC_RND_MODE);
+	  break;
+
+	case BT_CHARACTER:
+	  s_len = mpz_get_ui (array->ts.u.cl->length->value.integer);
+	  bnd = gfc_get_character_expr (array->ts.kind, &gfc_current_locus, NULL, s_len);
+	  break;
+
+	default:
+	  gcc_unreachable();
+
+	}
+    }
+  else
+    {
+      temp_boundary = false;
+      bnd = boundary;
+    }
+  
+  gfc_array_size (array, &size);
+  arraysize = mpz_get_ui (size);
+  mpz_clear (size);
+
+  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 = array->ts;
+
+  if (arraysize == 0)
+    goto final;
+
+  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);
+    }
+
+  resultvec = XCNEWVEC (gfc_expr *, arraysize);
+
+  extent[0] = 1;
+  count[0] = 0;
+
+  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];
+    }
+
+  if (shift->rank > 0)
+    {
+      shift_ctor = gfc_constructor_first (shift->value.constructor);
+      shift_val = 0;
+    }
+  else
+    {
+      shift_ctor = NULL;
+      shift_val = mpz_get_si (shift->value.integer);
+    }
+
+  if (bnd->rank > 0)
+    bnd_ctor = gfc_constructor_first (bnd->value.constructor);
+  else
+    bnd_ctor = NULL;
+
+  /* Shut up compiler */
+  len = 1;
+  rsoffset = 1;
+
+  n = 0;
+  for (d=0; d < array->rank; d++)
+    {
+      if (d == which)
+	{
+	  rsoffset = a_stride[d];
+	  len = a_extent[d];
+	}
+      else
+	{
+	  count[n] = 0;
+	  extent[n] = a_extent[d];
+	  sstride[n] = a_stride[d];
+	  ss_ex[n] = sstride[n] * extent[n];
+	  n++;
+	}
+    }
+
+  continue_loop = true;
+  d = array->rank;
+  rptr = resultvec;
+  sptr = arrayvec;
+
+  while (continue_loop)
+    {
+      ssize_t sh, delta;
+
+      if (shift_ctor)
+	sh = mpz_get_si (shift_ctor->expr->value.integer);
+      else
+	sh = shift_val;
+
+      if (( sh >= 0 ? sh : -sh ) > len)
+	{
+	  delta = len;
+	  sh = len;
+	}
+      else
+	delta = (sh >= 0) ? sh: -sh;
+
+      if (sh > 0)
+        {
+          src = &sptr[delta * rsoffset];
+          dest = rptr;
+        }
+      else
+        {
+          src = sptr;
+          dest = &rptr[delta * rsoffset];
+        }
+
+      for (n = 0; n < len - delta; n++)
+	{
+	  *dest = *src;
+	  dest += rsoffset;
+	  src += rsoffset;
+	}
+
+      if (sh < 0)
+        dest = rptr;
+
+      n = delta;
+
+      if (bnd_ctor)
+	{
+	  while (n--)
+	    {
+	      *dest = gfc_copy_expr (bnd_ctor->expr);
+	      dest += rsoffset;
+	    }
+	}
+      else
+	{
+	  while (n--)
+	    {
+	      *dest = gfc_copy_expr (bnd);
+	      dest += rsoffset;
+	    }
+	}
+      rptr += sstride[0];
+      sptr += sstride[0];
+      if (shift_ctor)
+	shift_ctor =  gfc_constructor_next (shift_ctor);
+
+      if (bnd_ctor)
+	bnd_ctor = gfc_constructor_next (bnd_ctor);
+      
+      count[0]++;
+      n = 0;
+      while (count[n] == extent[n])
+	{
+	  count[n] = 0;
+	  rptr -= ss_ex[n];
+	  sptr -= ss_ex[n];
+	  n++;
+	  if (n >= d - 1)
+	    {
+	      continue_loop = false;
+	      break;
+	    }
+	  else
+	    {
+	      count[n]++;
+	      rptr += sstride[n];
+	      sptr += sstride[n];
+	    }
+	}
+    }
+
+  for (i = 0; i < arraysize; i++)
+    {
+      gfc_constructor_append_expr (&result->value.constructor,
+				   gfc_copy_expr (resultvec[i]),
+				   NULL);
+    }
+
+ final:
+  if (temp_boundary)
+    gfc_free_expr (bnd);
+
+  return result;
+}
+
+gfc_expr *
 gfc_simplify_erf (gfc_expr *x)
 {
   gfc_expr *result;