This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

[patch, fortran] KIND arguments for MINLOC and MAXLOC


Hello world,

the attached patch allows KIND arguments to MINLOC and MAXLOC.
There was a bit of a choice to make here. Originally, I wanted to
run the calculation using index_type only and convert to another
integer kind if that was required. This ran into the issue that
bounds checking fails for this approach if there is a conversion
( https://gcc.gnu.org/bugzilla/show_bug.cgi?id=82660 ), and I
got regressions for that.

On the other hand, I wanted to avoid adding kind=1 and kind=2 versions
to the library. This approach had been rejected some time ago,
in 2009.

So, I chose a third path by using only pre-existing library
functions for kind=4, kind=8 and kind=16 and by doing a conversion
if the user specified kind=1 or kind=2.

This introduces a bug (array bounds violation not caught) if the user

- specifies bounds checking
- choses kind=1 or kind=2 for minloc or maxloc (it escapes me why
  anybody would want to do that)
- uses an array as return value whose bounds cannot be determined
  at compile-time, and gets the dimension of that array wrong

Frankly, if anybody would do this, the expression "deserves to lose"
comes to mind.

This would not be a regression, because kind=1 and kind=2 are
not supported at the moment.  This bug would be fixed together
with 82660.

Regression-tested. OK for trunk?

Regards

	Thomas

2017-10-28  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-10-28  Thomas Koenig  <tkoenig@gcc.gnu.org>

        PR fortran/29600
        * gfortran.dg/minmaxloc_8.f90: New test.
Index: gfortran.h
===================================================================
--- gfortran.h	(Revision 253768)
+++ gfortran.h	(Arbeitskopie)
@@ -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 *);
Index: intrinsic.h
===================================================================
--- intrinsic.h	(Revision 253768)
+++ intrinsic.h	(Arbeitskopie)
@@ -537,7 +537,7 @@ void gfc_resolve_logical (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
 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 *);
Index: check.c
===================================================================
--- check.c	(Revision 253768)
+++ check.c	(Arbeitskopie)
@@ -3179,7 +3179,7 @@ gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *ma
 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;
 }
 
Index: intrinsic.c
===================================================================
--- intrinsic.c	(Revision 253768)
+++ intrinsic.c	(Arbeitskopie)
@@ -687,27 +687,29 @@ add_sym_3 (const char *name, gfc_isym_id id, enum
    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_e
   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)
Index: iresolve.c
===================================================================
--- iresolve.c	(Revision 253768)
+++ iresolve.c	(Arbeitskopie)
@@ -1691,17 +1691,32 @@ gfc_resolve_max (gfc_expr *f, gfc_actual_arglist *
   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)
     {
       f->rank = 1;
@@ -1740,6 +1755,21 @@ gfc_resolve_maxloc (gfc_expr *f, gfc_expr *array,
   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,14 +1891,26 @@ gfc_resolve_min (gfc_expr *f, gfc_actual_arglist *
 
 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)
     {
       f->rank = 1;
@@ -1907,6 +1949,16 @@ gfc_resolve_minloc (gfc_expr *f, gfc_expr *array,
   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);
+    }
 }
 
 
! { 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

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]