re PR fortran/29600 ([F03] MINLOC and MAXLOC take an optional KIND argument)

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

	PR fortran/29600
	* gfortran.h (gfc_check_f): Replace fm3l with fm4l.
	* intrinsic.h (gfc_resolve_maxloc): Add gfc_expr * to argument
	list in protoytpe.
	(gfc_resolve_minloc): Likewise.
	* check.c (gfc_check_minloc_maxloc): Handle kind argument.
	* intrinsic.c (add_sym_3_ml): Rename to
	(add_sym_4_ml): and handle kind argument.
	(add_function): Replace add_sym_3ml with add_sym_4ml and add
	extra arguments for maxloc and minloc.
	(check_specific): Change use of check.f3ml with check.f4ml.
	* iresolve.c (gfc_resolve_maxloc): Handle kind argument. If
	the kind is smaller than the smallest library version available,
	use gfc_default_integer_kind and convert afterwards.
	(gfc_resolve_minloc): Likewise.

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

	PR fortran/29600
	* gfortran.dg/minmaxloc_8.f90: New test.

From-SVN: r254405

gcc/fortran/ChangeLog

+2017-11-04  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/29600
+	* gfortran.h (gfc_check_f): Replace fm3l with fm4l.
+	* intrinsic.h (gfc_resolve_maxloc): Add gfc_expr * to argument
+	list in protoytpe.
+	(gfc_resolve_minloc): Likewise.
+	* check.c (gfc_check_minloc_maxloc): Handle kind argument.
+	* intrinsic.c (add_sym_3_ml): Rename to
+	(add_sym_4_ml): and handle kind argument.
+	(add_function): Replace add_sym_3ml with add_sym_4ml and add
+	extra arguments for maxloc and minloc.
+	(check_specific): Change use of check.f3ml with check.f4ml.
+	* iresolve.c (gfc_resolve_maxloc): Handle kind argument. If
+	the kind is smaller than the smallest library version available,
+	use gfc_default_integer_kind and convert afterwards.
+	(gfc_resolve_minloc): Likewise.
+
 2017-11-04  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/81735

gcc/fortran/check.c

@@ -3179,7 +3179,7 @@ gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
 bool
 gfc_check_minloc_maxloc (gfc_actual_arglist *ap)
 {
-  gfc_expr *a, *m, *d;
+  gfc_expr *a, *m, *d, *k;
 
   a = ap->expr;
   if (!int_or_real_check (a, 0) || !array_check (a, 0))
@@ -3187,6 +3187,7 @@ gfc_check_minloc_maxloc (gfc_actual_arglist *ap)
 
   d = ap->next->expr;
   m = ap->next->next->expr;
+  k = ap->next->next->next->expr;
 
   if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
       && ap->next->name == NULL)
@@ -3214,6 +3215,9 @@ gfc_check_minloc_maxloc (gfc_actual_arglist *ap)
 				 gfc_current_intrinsic))
     return false;
 
+  if (!kind_check (k, 1, BT_INTEGER))
+    return false;
+
   return true;
 }
 

gcc/fortran/gfortran.h

@@ -1989,7 +1989,7 @@ gfc_intrinsic_arg;
    argument lists of intrinsic functions. fX with X an integer refer
    to check functions of intrinsics with X arguments. f1m is used for
    the MAX and MIN intrinsics which can have an arbitrary number of
-   arguments, f3ml is used for the MINLOC and MAXLOC intrinsics as
+   arguments, f4ml is used for the MINLOC and MAXLOC intrinsics as
    these have special semantics.  */
 
 typedef union
@@ -1999,7 +1999,7 @@ typedef union
   bool (*f1m)(gfc_actual_arglist *);
   bool (*f2)(struct gfc_expr *, struct gfc_expr *);
   bool (*f3)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *);
-  bool (*f3ml)(gfc_actual_arglist *);
+  bool (*f4ml)(gfc_actual_arglist *);
   bool (*f3red)(gfc_actual_arglist *);
   bool (*f4)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *,
 	    struct gfc_expr *);

gcc/fortran/intrinsic.c

@@ -687,27 +687,29 @@ add_sym_3 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt ty
    might have to be reordered.  */
 
 static void
-add_sym_3ml (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type,
+add_sym_4ml (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type,
 	     int kind, int standard,
 	     bool (*check) (gfc_actual_arglist *),
-	     gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *),
-	     void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *),
+	     gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *),
+	     void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *),
 	     const char *a1, bt type1, int kind1, int optional1,
 	     const char *a2, bt type2, int kind2, int optional2,
-	     const char *a3, bt type3, int kind3, int optional3)
+	     const char *a3, bt type3, int kind3, int optional3,
+	     const char *a4, bt type4, int kind4, int optional4)
 {
   gfc_check_f cf;
   gfc_simplify_f sf;
   gfc_resolve_f rf;
 
-  cf.f3ml = check;
-  sf.f3 = simplify;
-  rf.f3 = resolve;
+  cf.f4ml = check;
+  sf.f4 = simplify;
+  rf.f4 = resolve;
 
   add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
 	   a1, type1, kind1, optional1, INTENT_IN,
 	   a2, type2, kind2, optional2, INTENT_IN,
 	   a3, type3, kind3, optional3, INTENT_IN,
+	   a4, type4, kind4, optional4, INTENT_IN,
 	   (void *) 0);
 }
 
@@ -2455,10 +2457,10 @@ add_functions (void)
 
   make_generic ("maxexponent", GFC_ISYM_MAXEXPONENT, GFC_STD_F95);
 
-  add_sym_3ml ("maxloc", GFC_ISYM_MAXLOC, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
+  add_sym_4ml ("maxloc", GFC_ISYM_MAXLOC, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
 	       gfc_check_minloc_maxloc, NULL, gfc_resolve_maxloc,
 	       ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
-	       msk, BT_LOGICAL, dl, OPTIONAL);
+	       msk, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL);
 
   make_generic ("maxloc", GFC_ISYM_MAXLOC, GFC_STD_F95);
 
@@ -2531,10 +2533,10 @@ add_functions (void)
 
   make_generic ("minexponent", GFC_ISYM_MINEXPONENT, GFC_STD_F95);
 
-  add_sym_3ml ("minloc", GFC_ISYM_MINLOC, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
+  add_sym_4ml ("minloc", GFC_ISYM_MINLOC, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
 	       gfc_check_minloc_maxloc, NULL, gfc_resolve_minloc,
 	       ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
-	       msk, BT_LOGICAL, dl, OPTIONAL);
+	       msk, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL);
 
   make_generic ("minloc", GFC_ISYM_MINLOC, GFC_STD_F95);
 
@@ -4498,7 +4500,7 @@ check_specific (gfc_intrinsic_sym *specific, gfc_expr *expr, int error_flag)
   if (!do_ts29113_check (specific, *ap))
     return false;
 
-  if (specific->check.f3ml == gfc_check_minloc_maxloc)
+  if (specific->check.f4ml == gfc_check_minloc_maxloc)
     /* This is special because we might have to reorder the argument list.  */
     t = gfc_check_minloc_maxloc (*ap);
   else if (specific->check.f3red == gfc_check_minval_maxval)

gcc/fortran/intrinsic.h

@@ -537,7 +537,7 @@ void gfc_resolve_logical (gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_lstat (gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_matmul (gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_max (gfc_expr *, gfc_actual_arglist *);
-void gfc_resolve_maxloc (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_maxloc (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_maxval (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_mclock (gfc_expr *);
 void gfc_resolve_mclock8 (gfc_expr *);
@@ -545,7 +545,7 @@ void gfc_resolve_mask (gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_merge (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_merge_bits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_min (gfc_expr *, gfc_actual_arglist *);
-void gfc_resolve_minloc (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_minloc (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_minval (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_mod (gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_modulo (gfc_expr *, gfc_expr *, gfc_expr *);

gcc/fortran/iresolve.c

@@ -1691,16 +1691,31 @@ gfc_resolve_max (gfc_expr *f, gfc_actual_arglist *args)
   gfc_resolve_minmax ("__max_%c%d", f, args);
 }
 
+/* The smallest kind for which a minloc and maxloc implementation exists.  */
+
+#define MINMAXLOC_MIN_KIND 4
 
 void
 gfc_resolve_maxloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
-		    gfc_expr *mask)
+		    gfc_expr *mask, gfc_expr *kind)
 {
   const char *name;
   int i, j, idim;
+  int fkind;
 
   f->ts.type = BT_INTEGER;
-  f->ts.kind = gfc_default_integer_kind;
+
+  /* The library versions only exist for kinds 4, 8 and 16. For smaller kinds,
+     we do a type conversion further down.  */
+  if (kind)
+    fkind = mpz_get_si (kind->value.integer);
+  else
+    fkind = gfc_default_integer_kind;
+
+  if (fkind < MINMAXLOC_MIN_KIND)
+    f->ts.kind = MINMAXLOC_MIN_KIND;
+  else
+    f->ts.kind = fkind;
 
   if (dim == NULL)
     {
@@ -1740,6 +1755,21 @@ gfc_resolve_maxloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
   f->value.function.name
     = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
 		      gfc_type_letter (array->ts.type), array->ts.kind);
+
+  if (kind)
+    fkind = mpz_get_si (kind->value.integer);
+  else
+    fkind = gfc_default_integer_kind;
+
+  if (fkind != f->ts.kind)
+    {
+      gfc_typespec ts;
+      gfc_clear_ts (&ts);
+
+      ts.type = BT_INTEGER;
+      ts.kind = fkind;
+      gfc_convert_type_warn (f, &ts, 2, 0);
+    }
 }
 
 
@@ -1861,13 +1891,25 @@ gfc_resolve_min (gfc_expr *f, gfc_actual_arglist *args)
 
 void
 gfc_resolve_minloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
-		    gfc_expr *mask)
+		    gfc_expr *mask, gfc_expr *kind)
 {
   const char *name;
   int i, j, idim;
+  int fkind;
 
   f->ts.type = BT_INTEGER;
-  f->ts.kind = gfc_default_integer_kind;
+
+  /* The library versions only exist for kinds 4, 8 and 16. For smaller kinds,
+     we do a type conversion further down.  */
+  if (kind)
+    fkind = mpz_get_si (kind->value.integer);
+  else
+    fkind = gfc_default_integer_kind;
+
+  if (fkind < MINMAXLOC_MIN_KIND)
+    f->ts.kind = MINMAXLOC_MIN_KIND;
+  else
+    f->ts.kind = fkind;
 
   if (dim == NULL)
     {
@@ -1907,6 +1949,16 @@ gfc_resolve_minloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
   f->value.function.name
     = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind,
 		      gfc_type_letter (array->ts.type), array->ts.kind);
+
+  if (fkind != f->ts.kind)
+    {
+      gfc_typespec ts;
+      gfc_clear_ts (&ts);
+
+      ts.type = BT_INTEGER;
+      ts.kind = fkind;
+      gfc_convert_type_warn (f, &ts, 2, 0);
+    }
 }
 
 

gcc/testsuite/ChangeLog

+2017-11-04  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/29600
+	* gfortran.dg/minmaxloc_8.f90: New test.
+
 2017-11-04  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/81735

gcc/testsuite/gfortran.dg/minmaxloc_8.f90

+! { dg-do  run }
+! { dg-options "-fdump-tree-original" }
+! Test that minloc and maxloc using KINDs return the right
+! kind, by using unformatted I/O for a specific kind.
+program main
+  implicit none
+  real, dimension(3) :: a
+  integer :: r1, r2, r4, r8
+  integer :: k
+  character(len=30) :: l1, l2
+
+  ! Check via I/O if the KIND is used correctly
+  a = [ 1.0, 3.0, 2.0]
+  write (unit=l1,fmt=*) 2_1
+  write (unit=l2,fmt=*) maxloc(a,kind=1)
+  if (l1 /= l2) call abort
+
+  write (unit=l1,fmt=*) 2_2
+  write (unit=l2,fmt=*) maxloc(a,kind=2)
+  if (l1 /= l2) call abort
+
+  write (unit=l1,fmt=*) 2_4
+  write (unit=l2,fmt=*) maxloc(a,kind=4)
+  if (l1 /= l2) call abort
+
+  write (unit=l1,fmt=*) 2_8
+  write (unit=l2,fmt=*) maxloc(a,kind=8)
+  if (l1 /= l2) call abort
+
+  a = [ 3.0, -1.0, 2.0]
+
+  write (unit=l1,fmt=*) 2_1
+  write (unit=l2,fmt=*) minloc(a,kind=1)
+  if (l1 /= l2) call abort
+
+  write (unit=l1,fmt=*) 2_2
+  write (unit=l2,fmt=*) minloc(a,kind=2)
+  if (l1 /= l2) call abort
+
+  write (unit=l1,fmt=*) 2_4
+  write (unit=l2,fmt=*) minloc(a,kind=4)
+  if (l1 /= l2) call abort
+
+  write (unit=l1,fmt=*) 2_8
+  write (unit=l2,fmt=*) minloc(a,kind=8)
+  if (l1 /= l2) call abort
+
+end program main