OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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

Browse Source 
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
This commit is contained in:
Thomas Koenig 2017-11-04 13:20:32 +00:00
parent 77dacf9da6
commit 9a3d38f6dc
8 changed files with 150 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
gcc/fortran/ChangeLog
View File

@ -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

6
gcc/fortran/check.c
View File

@ -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;
}

4
gcc/fortran/gfortran.h
View File

@ -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 *);

26
gcc/fortran/intrinsic.c
View File

@ -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)

4
gcc/fortran/intrinsic.h
View File

@ -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 *);

60
gcc/fortran/iresolve.c
View File

@ -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);
}
}

5
gcc/testsuite/ChangeLog
View File

@ -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

48
gcc/testsuite/gfortran.dg/minmaxloc_8.f90 Normal file
View File

@ -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