aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gcc/fortran/ChangeLog18
-rw-r--r--gcc/fortran/check.c6
-rw-r--r--gcc/fortran/gfortran.h4
-rw-r--r--gcc/fortran/intrinsic.c26
-rw-r--r--gcc/fortran/intrinsic.h4
-rw-r--r--gcc/fortran/iresolve.c60
-rw-r--r--gcc/testsuite/ChangeLog5
-rw-r--r--gcc/testsuite/gfortran.dg/minmaxloc_8.f9048
8 files changed, 150 insertions, 21 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index aa43ff4..0b2ca315 100644
--- 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 759c15a..914dbf9 100644
--- 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 2c2fc63..213c5da 100644
--- 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 da96e8ff..cb18b21 100644
--- 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 e8280f6..6282788 100644
--- 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 b784ac3..a54ed22 100644
--- 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 10331b3..3997311 100644
--- 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
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
generated by cgit v1.1 at 2024-10-21 00:01:20 +0000