re PR fortran/36313 ([F03] {MIN,MAX}{LOC,VAL} should accept character arguments)

2017-11-22  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/36313
	* Makefile.am: Add i_maxloc0s_c, i_maxloc1s_c, i_maxloc2s_c,
	i_minloc0s_c, i_minloc1s_c and i_minloc2s_c.
	* Makefile.in: Regenerated.
        * generated/maxloc0_16_s1.c: New file.
        * generated/maxloc0_16_s4.c: New file.
        * generated/maxloc0_4_s1.c: New file.
        * generated/maxloc0_4_s4.c: New file.
        * generated/maxloc0_8_s1.c: New file.
        * generated/maxloc0_8_s4.c: New file.
        * generated/maxloc1_16_s1.c: New file.
        * generated/maxloc1_16_s4.c: New file.
        * generated/maxloc1_4_s1.c: New file.
        * generated/maxloc1_4_s4.c: New file.
        * generated/maxloc1_8_s1.c: New file.
        * generated/maxloc1_8_s4.c: New file.
        * generated/maxloc2_16_s1.c: New file.
        * generated/maxloc2_16_s4.c: New file.
        * generated/maxloc2_4_s1.c: New file.
        * generated/maxloc2_4_s4.c: New file.
        * generated/maxloc2_8_s1.c: New file.
        * generated/maxloc2_8_s4.c: New file.
        * generated/minloc0_16_s1.c: New file.
        * generated/minloc0_16_s4.c: New file.
        * generated/minloc0_4_s1.c: New file.
        * generated/minloc0_4_s4.c: New file.
        * generated/minloc0_8_s1.c: New file.
        * generated/minloc0_8_s4.c: New file.
        * generated/minloc1_16_s1.c: New file.
        * generated/minloc1_16_s4.c: New file.
        * generated/minloc1_4_s1.c: New file.
        * generated/minloc1_4_s4.c: New file.
        * generated/minloc1_8_s1.c: New file.
        * generated/minloc1_8_s4.c: New file.
        * generated/minloc2_16_s1.c: New file.
        * generated/minloc2_16_s4.c: New file.
        * generated/minloc2_4_s1.c: New file.
        * generated/minloc2_4_s4.c: New file.
        * generated/minloc2_8_s1.c: New file.
        * generated/minloc2_8_s4.c: New file.
        * m4/iforeach-s.m4: New file.
        * m4/ifunction-s.m4: New file.
        * m4/maxloc0s.m4: New file.
        * m4/maxloc1s.m4: New file.
        * m4/maxloc2s.m4: New file.
        * m4/minloc0s.m4: New file.
        * m4/minloc1s.m4: New file.
        * m4/minloc2s.m4: New file.
	* gfortran.map: Add new functions.
	* libgfortran.h: Add gfc_array_s1 and gfc_array_s4.

2017-11-22  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/36313
	* check.c (int_or_real_or_char_check_f2003): New function.
	* iresolve.c (gfc_resolve_maxloc): Add number "2" for
	character arguments and rank-zero return value.
	(gfc_resolve_minloc): Likewise.
	* trans-intrinsic.c (gfc_conv_intrinsic_minmaxloc): Handle case of
	character arguments and rank-zero return value by removing
	unneeded arguments and calling the library function.

2017-11-22  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/36313
	* gfortran.dg/maxloc_string_1.f90: New test.
	* gfortran.dg/minloc_string_1.f90: New test.

From-SVN: r255070

7 files changed, 284 insertions, 5 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 7fc965b..30e033a 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,14 @@
+2017-11-22  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/36313
+	* check.c (int_or_real_or_char_check_f2003): New function.
+	* iresolve.c (gfc_resolve_maxloc): Add number "2" for
+	character arguments and rank-zero return value.
+	(gfc_resolve_minloc): Likewise.
+	* trans-intrinsic.c (gfc_conv_intrinsic_minmaxloc): Handle case of
+	character arguments and rank-zero return value by removing
+	unneeded arguments and calling the library function.
+
 2017-11-22  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/79072
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index a147449..2928172 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -117,6 +117,37 @@ int_or_real_check (gfc_expr *e, int n)
   return true;
 }
 
+/* Check that an expression is integer or real; allow character for
+   F2003 or later.  */
+
+static bool
+int_or_real_or_char_check_f2003 (gfc_expr *e, int n)
+{
+  if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL)
+    {
+      if (e->ts.type == BT_CHARACTER)
+	return gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Character for "
+			       "%qs argument of %qs intrinsic at %L",
+			       gfc_current_intrinsic_arg[n]->name,
+			       gfc_current_intrinsic, &e->where);
+      else
+	{
+	  if (gfc_option.allow_std & GFC_STD_F2003)
+	    gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
+		       "or REAL or CHARACTER",
+		       gfc_current_intrinsic_arg[n]->name,
+		       gfc_current_intrinsic, &e->where);
+	  else
+	    gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
+		       "or REAL", gfc_current_intrinsic_arg[n]->name,
+		       gfc_current_intrinsic, &e->where);
+	}
+      return false;
+    }
+
+  return true;
+}
+
 
 /* Check that an expression is real or complex.  */
 
@@ -3189,7 +3220,7 @@ gfc_check_minloc_maxloc (gfc_actual_arglist *ap)
   gfc_expr *a, *m, *d, *k;
 
   a = ap->expr;
-  if (!int_or_real_check (a, 0) || !array_check (a, 0))
+  if (!int_or_real_or_char_check_f2003 (a, 0) || !array_check (a, 0))
     return false;
 
   d = ap->next->expr;
diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index a54ed22..be1c35b 100644
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -1702,6 +1702,7 @@ gfc_resolve_maxloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
   const char *name;
   int i, j, idim;
   int fkind;
+  int d_num;
 
   f->ts.type = BT_INTEGER;
 
@@ -1752,8 +1753,18 @@ gfc_resolve_maxloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
   else
     name = "maxloc";
 
+  if (dim)
+    {
+      if (array->ts.type != BT_CHARACTER || f->rank != 0)
+	d_num = 1;
+      else
+	d_num = 2;
+    }
+  else
+    d_num = 0;
+
   f->value.function.name
-    = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
+    = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, d_num, f->ts.kind,
 		      gfc_type_letter (array->ts.type), array->ts.kind);
 
   if (kind)
@@ -1896,6 +1907,7 @@ gfc_resolve_minloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
   const char *name;
   int i, j, idim;
   int fkind;
+  int d_num;
 
   f->ts.type = BT_INTEGER;
 
@@ -1946,8 +1958,18 @@ gfc_resolve_minloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
   else
     name = "minloc";
 
+  if (dim)
+    {
+      if (array->ts.type != BT_CHARACTER || f->rank != 0)
+	d_num = 1;
+      else
+	d_num = 2;
+    }
+  else
+    d_num = 0;
+
   f->value.function.name
-    = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
+    = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, d_num, f->ts.kind,
 		      gfc_type_letter (array->ts.type), array->ts.kind);
 
   if (fkind != f->ts.kind)
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index b7c5721..90d5e59 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -4568,14 +4568,41 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
       return;
     }
 
+  actual = expr->value.function.actual;
+  arrayexpr = actual->expr;
+
+  /* Special case for character maxval.  Remove unneeded actual
+     arguments, then call a library function.  */
+  
+  if (arrayexpr->ts.type == BT_CHARACTER)
+    {
+      gfc_actual_arglist *a2, *a3, *a4;
+      a2 = actual->next;
+      a3 = a2->next;
+      a4 = a3->next;
+      a4->next = NULL;
+      if (a3->expr == NULL)
+	{
+	  actual->next = NULL;
+	  gfc_free_actual_arglist (a2);
+	}
+      else
+	{
+	  actual->next = a3;  /* dim */
+	  a3->next = NULL;
+	  a2->next = a4;
+	  gfc_free_actual_arglist (a4);
+	}
+      gfc_conv_intrinsic_funcall (se, expr);
+      return;
+    }
+
   /* Initialize the result.  */
   pos = gfc_create_var (gfc_array_index_type, "pos");
   offset = gfc_create_var (gfc_array_index_type, "offset");
   type = gfc_typenode_for_spec (&expr->ts);
 
   /* Walk the arguments.  */
-  actual = expr->value.function.actual;
-  arrayexpr = actual->expr;
   arrayss = gfc_walk_expr (arrayexpr);
   gcc_assert (arrayss != gfc_ss_terminator);
 
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 737424b..573a97a4 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2017-11-22  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/36313
+	* gfortran.dg/maxloc_string_1.f90: New test.
+	* gfortran.dg/minloc_string_1.f90: New test.
+
 2017-11-22  Marc Glisse  <marc.glisse@inria.fr>
 
 	PR tree-optimization/83104
diff --git a/gcc/testsuite/gfortran.dg/maxloc_string_1.f90 b/gcc/testsuite/gfortran.dg/maxloc_string_1.f90
new file mode 100644
index 0000000..a551162
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/maxloc_string_1.f90
@@ -0,0 +1,91 @@
+! { dg-do run }
+! Test maxloc for strings for different code paths
+
+program main
+  implicit none
+  integer, parameter :: n=4
+  character(len=4), dimension(n,n) :: c
+  integer, dimension(n,n) :: a
+  integer, dimension(2) :: res1, res2
+  real, dimension(n,n) :: r
+  logical, dimension(n,n) :: amask
+  logical(kind=8) :: smask
+  integer :: i,j
+  integer, dimension(n) :: q1, q2
+  character(len=4,kind=4), dimension(n,n) :: c4
+  character(len=4), dimension(n*n) :: e
+  integer, dimension(n*n) :: f
+  logical, dimension(n*n) :: cmask
+
+  call random_number (r)
+  a = int(r*100)
+  do j=1,n
+     do i=1,n
+        write (unit=c(i,j),fmt='(I4.4)') a(i,j)
+        write (unit=c4(i,j),fmt='(I4.4)') a(i,j)
+     end do
+  end do
+  res1 = maxloc(c)
+  res2 = maxloc(a)
+
+  if (any(res1 /= res2)) call abort
+  res1 = maxloc(c4)
+  if (any(res1 /= res2)) call abort
+
+  amask = a < 50
+  res1 = maxloc(c,mask=amask)
+  res2 = maxloc(a,mask=amask)
+
+ if (any(res1 /= res2)) call abort
+
+ amask = .false.
+ res1 = maxloc(c,mask=amask)
+ if (any(res1 /= 0)) call abort
+
+ amask(2,3) = .true.
+ res1 = maxloc(c,mask=amask)
+ if (any(res1 /= [2,3])) call abort
+
+ res1 = maxloc(c,mask=.false.)
+ if (any(res1 /= 0)) call abort
+
+ res2 = maxloc(a)
+ res1 = maxloc(c,mask=.true.)
+ if (any(res1 /= res2)) call abort
+
+ q1 = maxloc(c, dim=1)
+ q2 = maxloc(a, dim=1)
+ if (any(q1 /= q2)) call abort
+
+ q1 = maxloc(c, dim=2)
+ q2 = maxloc(a, dim=2)
+ if (any(q1 /= q2)) call abort
+
+ q1 = maxloc(c, dim=1, mask=amask)
+ q2 = maxloc(a, dim=1, mask=amask)
+ if (any(q1 /= q2)) call abort
+
+ q1 = maxloc(c, dim=2, mask=amask)
+ q2 = maxloc(a, dim=2, mask=amask)
+ if (any(q1 /= q2)) call abort
+
+  amask = a < 50
+
+ q1 = maxloc(c, dim=1, mask=amask)
+ q2 = maxloc(a, dim=1, mask=amask)
+ if (any(q1 /= q2)) call abort
+
+ q1 = maxloc(c, dim=2, mask=amask)
+ q2 = maxloc(a, dim=2, mask=amask)
+ if (any(q1 /= q2)) call abort
+
+ e = reshape(c, shape(e))
+ f = reshape(a, shape(f))
+ if (maxloc(e,dim=1) /= maxloc(f,dim=1)) call abort
+
+ cmask = .false.
+ if (maxloc(e,dim=1,mask=cmask) /= 0) call abort
+
+ cmask = f > 50
+ if ( maxloc(e, dim=1, mask=cmask) /= maxloc (f, dim=1, mask=cmask)) call abort
+end program main
diff --git a/gcc/testsuite/gfortran.dg/minloc_string_1.f90 b/gcc/testsuite/gfortran.dg/minloc_string_1.f90
new file mode 100644
index 0000000..88847cc
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/minloc_string_1.f90
@@ -0,0 +1,91 @@
+! { dg-do run }
+! Test minloc for strings for different code paths
+
+program main
+  implicit none
+  integer, parameter :: n=4
+  character(len=4), dimension(n,n) :: c
+  integer, dimension(n,n) :: a
+  integer, dimension(2) :: res1, res2
+  real, dimension(n,n) :: r
+  logical, dimension(n,n) :: amask
+  logical(kind=8) :: smask
+  integer :: i,j
+  integer, dimension(n) :: q1, q2
+  character(len=4,kind=4), dimension(n,n) :: c4
+  character(len=4), dimension(n*n) :: e
+  integer, dimension(n*n) :: f
+  logical, dimension(n*n) :: cmask
+
+  call random_number (r)
+  a = int(r*100)
+  do j=1,n
+     do i=1,n
+        write (unit=c(i,j),fmt='(I4.4)') a(i,j)
+        write (unit=c4(i,j),fmt='(I4.4)') a(i,j)
+     end do
+  end do
+  res1 = minloc(c)
+  res2 = minloc(a)
+
+  if (any(res1 /= res2)) call abort
+  res1 = minloc(c4)
+  if (any(res1 /= res2)) call abort
+
+  amask = a < 50
+  res1 = minloc(c,mask=amask)
+  res2 = minloc(a,mask=amask)
+
+ if (any(res1 /= res2)) call abort
+
+ amask = .false.
+ res1 = minloc(c,mask=amask)
+ if (any(res1 /= 0)) call abort
+
+ amask(2,3) = .true.
+ res1 = minloc(c,mask=amask)
+ if (any(res1 /= [2,3])) call abort
+
+ res1 = minloc(c,mask=.false.)
+ if (any(res1 /= 0)) call abort
+
+ res2 = minloc(a)
+ res1 = minloc(c,mask=.true.)
+ if (any(res1 /= res2)) call abort
+
+ q1 = minloc(c, dim=1)
+ q2 = minloc(a, dim=1)
+ if (any(q1 /= q2)) call abort
+
+ q1 = minloc(c, dim=2)
+ q2 = minloc(a, dim=2)
+ if (any(q1 /= q2)) call abort
+
+ q1 = minloc(c, dim=1, mask=amask)
+ q2 = minloc(a, dim=1, mask=amask)
+ if (any(q1 /= q2)) call abort
+
+ q1 = minloc(c, dim=2, mask=amask)
+ q2 = minloc(a, dim=2, mask=amask)
+ if (any(q1 /= q2)) call abort
+
+  amask = a < 50
+
+ q1 = minloc(c, dim=1, mask=amask)
+ q2 = minloc(a, dim=1, mask=amask)
+ if (any(q1 /= q2)) call abort
+
+ q1 = minloc(c, dim=2, mask=amask)
+ q2 = minloc(a, dim=2, mask=amask)
+ if (any(q1 /= q2)) call abort
+
+ e = reshape(c, shape(e))
+ f = reshape(a, shape(f))
+ if (minloc(e,dim=1) /= minloc(f,dim=1)) call abort
+
+ cmask = .false.
+ if (minloc(e,dim=1,mask=cmask) /= 0) call abort
+
+ cmask = f > 50
+ if ( minloc(e, dim=1, mask=cmask) /= minloc (f, dim=1, mask=cmask)) call abort
+end program main