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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index aa43ff4ebffa3c0fbb6473753d84498284c4191b..0b2ca315605d8872b41fc55f09f41982fb5b41b4 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,21 @@
+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

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 759c15adaecfa03e19abd19a1b787798e3eaf24c..914dbf957fde20a902184e623e2cde94b915934c 100644 (file)
--- a/gcc/fortran/check.c
+++ b/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;
 }
 

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 2c2fc6367081d47d8316170542b77c517b27655e..213c5da56f75736e4d1c345f560a224d8faf180d 100644 (file)
--- a/gcc/fortran/gfortran.h
+++ b/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 *);

diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index da96e8ff30c4f8be4c8053a5a136a4d62278aebd..cb18b21a90d369dc71cdf4596539d58a60fba9b1 100644 (file)
--- a/gcc/fortran/intrinsic.c
+++ b/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)

diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index e8280f6f2ac3826548217ef7aaf25a429db05a4e..62827887b3cd55232a32e7d87ca01befb22dafea 100644 (file)
--- a/gcc/fortran/intrinsic.h
+++ b/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 *);

diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index b784ac339e9642207b5d281e9c97d3c8437815d0..a54ed2295b576a72c2dc636f0723147a5cd9de4a 100644 (file)
--- a/gcc/fortran/iresolve.c
+++ b/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);
+    }
 }
 
 

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 10331b39929f57d84e6a3fa1827086afe155367d..3997311bdd4d312cc8175fb3bdd94ea8285bc627 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+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

diff --git a/gcc/testsuite/gfortran.dg/minmaxloc_8.f90 b/gcc/testsuite/gfortran.dg/minmaxloc_8.f90
new file mode 100644 (file)
index 0000000..e9f37f2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/minmaxloc_8.f90
@@ -0,0 +1,48 @@
+! { 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