aboutsummaryrefslogtreecommitdiff
path: root/gcc
diff options
context:
space:
mode:
Diffstat (limited to 'gcc')
-rw-r--r--gcc/fortran/ChangeLog28
-rw-r--r--gcc/fortran/check.c25
-rw-r--r--gcc/fortran/gfortran.h4
-rw-r--r--gcc/fortran/intrinsic.c34
-rw-r--r--gcc/fortran/intrinsic.h10
-rw-r--r--gcc/fortran/iresolve.c22
-rw-r--r--gcc/fortran/simplify.c6
-rw-r--r--gcc/fortran/trans-intrinsic.c46
-rw-r--r--gcc/testsuite/ChangeLog7
-rw-r--r--gcc/testsuite/gfortran.dg/minmaxloc_10.f90118
-rw-r--r--gcc/testsuite/gfortran.dg/minmaxloc_11.f909
-rw-r--r--gcc/testsuite/gfortran.dg/minmaxloc_9.f9011
12 files changed, 278 insertions, 42 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 7533171..453dc74 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,29 @@
+2018-01-15 Thomas Koenig <tkoenig@gcc.gnu.org>
+
+ PR fortran/54613
+ * gfortran.h (gfc_check_f): Rename f4ml to f5ml.
+ (gfc_logical_4_kind): New macro
+ * intrinsic.h (gfc_simplify_minloc): Add a gfc_expr *argument.
+ (gfc_simplify_maxloc): Likewise.
+ (gfc_resolve_maxloc): Likewise.
+ (gfc_resolve_minloc): Likewise.
+ * check.c (gfc_check_minloc_maxloc): Add checking for "back"
+ argument; also raise error if it is used (for now). Add it
+ if it isn't present.
+ * intrinsic.c (add_sym_4ml): Rename to
+ (add_sym_5ml), adjust for extra argument.
+ (add_functions): Add "back" constant. Adjust maxloc and minloc
+ for back argument.
+ * iresolve.c (gfc_resolve_maxloc): Add back argument. If back is
+ not of gfc_logical_4_kind, convert.
+ (gfc_resolve_minloc): Likewise.
+ * simplify.c (gfc_simplify_minloc): Add back argument.
+ (gfc_simplify_maxloc): Likewise.
+ * trans-intinsic.c (gfc_conv_intrinsic_minmaxloc): Rename last
+ argument to %VAL to ensure passing by value.
+ (gfc_conv_intrinsic_function): Call gfc_conv_intrinsic_minmaxloc
+ also for library calls.
+
2018-01-13 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR fortran/82007
@@ -6,7 +32,7 @@
format string or format label is present.
* trans-io.c (get_dtio_proc): Likewise. (transfer_expr): Fix
whitespace.
-
+
2018-01-13 Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/83744
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index fccb927..a2c8b52 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -3265,12 +3265,13 @@ gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
DIM MASK
I.e. in the case of minloc(array,mask), mask will be in the second
- position of the argument list and we'll have to fix that up. */
+ position of the argument list and we'll have to fix that up. Also,
+ add the BACK argument if that isn't present. */
bool
gfc_check_minloc_maxloc (gfc_actual_arglist *ap)
{
- gfc_expr *a, *m, *d, *k;
+ gfc_expr *a, *m, *d, *k, *b;
a = ap->expr;
if (!int_or_real_or_char_check_f2003 (a, 0) || !array_check (a, 0))
@@ -3279,6 +3280,26 @@ gfc_check_minloc_maxloc (gfc_actual_arglist *ap)
d = ap->next->expr;
m = ap->next->next->expr;
k = ap->next->next->next->expr;
+ b = ap->next->next->next->next->expr;
+
+ if (b)
+ {
+ if (!type_check (b, 4, BT_LOGICAL) || !scalar_check (b,4))
+ return false;
+
+ /* TODO: Remove this once BACK is actually implemented. */
+ if (b->expr_type != EXPR_CONSTANT || b->value.logical != 0)
+ {
+ gfc_error ("BACK argument to %qs intrinsic not yet "
+ "implemented", gfc_current_intrinsic);
+ return false;
+ }
+ }
+ else
+ {
+ b = gfc_get_logical_expr (gfc_default_logical_kind, NULL, 0);
+ ap->next->next->next->next->expr = b;
+ }
if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
&& ap->next->name == NULL)
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index b3f8e42..6ddf450 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -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 (*f4ml)(gfc_actual_arglist *);
+ bool (*f5ml)(gfc_actual_arglist *);
bool (*f3red)(gfc_actual_arglist *);
bool (*f4)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *,
struct gfc_expr *);
@@ -2915,6 +2915,8 @@ extern int gfc_size_kind;
extern int gfc_numeric_storage_size;
extern int gfc_character_storage_size;
+#define gfc_logical_4_kind 4
+
/* symbol.c */
void gfc_clear_new_implicit (void);
bool gfc_add_new_implicit_range (int, int);
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index ed732aa..4844cee 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -687,29 +687,33 @@ 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_4ml (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type,
+add_sym_5ml (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 *, gfc_expr *),
- void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *),
+ gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *,
+ gfc_expr *, gfc_expr *),
+ void (*resolve) (gfc_expr *, 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 *a4, bt type4, int kind4, int optional4)
+ const char *a4, bt type4, int kind4, int optional4,
+ const char *a5, bt type5, int kind5, int optional5)
{
gfc_check_f cf;
gfc_simplify_f sf;
gfc_resolve_f rf;
- cf.f4ml = check;
- sf.f4 = simplify;
- rf.f4 = resolve;
+ cf.f5ml = check;
+ sf.f5 = simplify;
+ rf.f5 = 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,
+ a5, type5, kind5, optional5, INTENT_IN,
(void *) 0);
}
@@ -1242,7 +1246,7 @@ add_functions (void)
*num = "number", *tm = "time", *nm = "name", *md = "mode",
*vl = "values", *p1 = "path1", *p2 = "path2", *com = "command",
*ca = "coarray", *sub = "sub", *dist = "distance", *failed="failed",
- *c_ptr_1 = "c_ptr_1", *c_ptr_2 = "c_ptr_2";
+ *c_ptr_1 = "c_ptr_1", *c_ptr_2 = "c_ptr_2", *back = "back";
int di, dr, dd, dl, dc, dz, ii;
@@ -2457,10 +2461,11 @@ add_functions (void)
make_generic ("maxexponent", GFC_ISYM_MAXEXPONENT, GFC_STD_F95);
- add_sym_4ml ("maxloc", GFC_ISYM_MAXLOC, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
+ add_sym_5ml ("maxloc", GFC_ISYM_MAXLOC, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
gfc_check_minloc_maxloc, gfc_simplify_maxloc, gfc_resolve_maxloc,
ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
- msk, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL);
+ msk, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL,
+ back, BT_LOGICAL, dl, OPTIONAL);
make_generic ("maxloc", GFC_ISYM_MAXLOC, GFC_STD_F95);
@@ -2533,11 +2538,12 @@ add_functions (void)
make_generic ("minexponent", GFC_ISYM_MINEXPONENT, GFC_STD_F95);
- add_sym_4ml ("minloc", GFC_ISYM_MINLOC, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
+ add_sym_5ml ("minloc", GFC_ISYM_MINLOC, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
gfc_check_minloc_maxloc, gfc_simplify_minloc, gfc_resolve_minloc,
ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
- msk, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL);
-
+ msk, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL,
+ back, BT_LOGICAL, dl, OPTIONAL);
+
make_generic ("minloc", GFC_ISYM_MINLOC, GFC_STD_F95);
add_sym_3red ("minval", GFC_ISYM_MINVAL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
@@ -4500,7 +4506,7 @@ check_specific (gfc_intrinsic_sym *specific, gfc_expr *expr, int error_flag)
if (!do_ts29113_check (specific, *ap))
return false;
- if (specific->check.f4ml == gfc_check_minloc_maxloc)
+ if (specific->check.f5ml == 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 a7db830..7615dd1 100644
--- a/gcc/fortran/intrinsic.h
+++ b/gcc/fortran/intrinsic.h
@@ -348,10 +348,12 @@ gfc_expr *gfc_simplify_maskr (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_merge (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_merge_bits (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_min (gfc_expr *);
-gfc_expr *gfc_simplify_minloc (gfc_expr*, gfc_expr *, gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_minloc (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
+ gfc_expr *);
gfc_expr *gfc_simplify_minval (gfc_expr *, gfc_expr*, gfc_expr*);
gfc_expr *gfc_simplify_max (gfc_expr *);
-gfc_expr *gfc_simplify_maxloc (gfc_expr*, gfc_expr *, gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_maxloc (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
+ gfc_expr *);
gfc_expr *gfc_simplify_maxval (gfc_expr *, gfc_expr*, gfc_expr*);
gfc_expr *gfc_simplify_maxexponent (gfc_expr *);
gfc_expr *gfc_simplify_minexponent (gfc_expr *);
@@ -540,7 +542,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 *, gfc_expr *);
+void gfc_resolve_maxloc (gfc_expr *, 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 *);
@@ -548,7 +550,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 *, gfc_expr *);
+void gfc_resolve_minloc (gfc_expr *, 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 11f2569..9a4e199 100644
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -1697,7 +1697,7 @@ gfc_resolve_max (gfc_expr *f, gfc_actual_arglist *args)
void
gfc_resolve_maxloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
- gfc_expr *mask, gfc_expr *kind)
+ gfc_expr *mask, gfc_expr *kind, gfc_expr *back)
{
const char *name;
int i, j, idim;
@@ -1781,6 +1781,15 @@ gfc_resolve_maxloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
ts.kind = fkind;
gfc_convert_type_warn (f, &ts, 2, 0);
}
+
+ if (back->ts.kind != gfc_logical_4_kind)
+ {
+ gfc_typespec ts;
+ gfc_clear_ts (&ts);
+ ts.type = BT_LOGICAL;
+ ts.kind = gfc_logical_4_kind;
+ gfc_convert_type_warn (back, &ts, 2, 0);
+ }
}
@@ -1907,7 +1916,7 @@ 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 *kind)
+ gfc_expr *mask, gfc_expr *kind, gfc_expr *back)
{
const char *name;
int i, j, idim;
@@ -1986,6 +1995,15 @@ gfc_resolve_minloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
ts.kind = fkind;
gfc_convert_type_warn (f, &ts, 2, 0);
}
+
+ if (back->ts.kind != gfc_logical_4_kind)
+ {
+ gfc_typespec ts;
+ gfc_clear_ts (&ts);
+ ts.type = BT_LOGICAL;
+ ts.kind = gfc_logical_4_kind;
+ gfc_convert_type_warn (back, &ts, 2, 0);
+ }
}
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index 3e5abd4..b7c6b02 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -5343,13 +5343,15 @@ gfc_simplify_minmaxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask,
}
gfc_expr *
-gfc_simplify_minloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, gfc_expr *kind)
+gfc_simplify_minloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, gfc_expr *kind,
+ gfc_expr *back ATTRIBUTE_UNUSED)
{
return gfc_simplify_minmaxloc (array, dim, mask, kind, -1);
}
gfc_expr *
-gfc_simplify_maxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, gfc_expr *kind)
+gfc_simplify_maxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, gfc_expr *kind,
+ gfc_expr *back ATTRIBUTE_UNUSED)
{
return gfc_simplify_minmaxloc (array, dim, mask, kind, 1);
}
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 7fe8286..f4defb0 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -4562,13 +4562,22 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
tree pos;
int n;
+ actual = expr->value.function.actual;
+
+ /* The last argument, BACK, is passed by value. Ensure that
+ by setting its name to %VAL. */
+ for (gfc_actual_arglist *a = actual; a; a = a->next)
+ {
+ if (a->next == NULL)
+ a->name = "%VAL";
+ }
+
if (se->ss)
{
gfc_conv_intrinsic_funcall (se, expr);
return;
}
- actual = expr->value.function.actual;
arrayexpr = actual->expr;
/* Special case for character maxloc. Remove unneeded actual
@@ -4576,22 +4585,19 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
if (arrayexpr->ts.type == BT_CHARACTER)
{
- gfc_actual_arglist *a2, *a3, *a4;
- a2 = actual->next;
- a3 = a2->next;
- a4 = a3->next;
- a4->next = NULL;
- if (a3->expr == NULL)
- {
- actual->next = NULL;
- gfc_free_actual_arglist (a2);
- }
- else
+ gfc_actual_arglist *a, *b;
+ a = actual;
+ while (a->next)
{
- actual->next = a3; /* dim */
- a3->next = NULL;
- a2->next = a4;
- gfc_free_actual_arglist (a4);
+ b = a->next;
+ if (b->expr == NULL || strcmp (b->name, "dim") == 0)
+ {
+ a->next = b->next;
+ b->next = NULL;
+ gfc_free_actual_arglist (b);
+ }
+ else
+ a = b;
}
gfc_conv_intrinsic_funcall (se, expr);
return;
@@ -8647,6 +8653,14 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
conv_generic_with_optional_char_arg (se, expr, 1, 3);
break;
+ case GFC_ISYM_MINLOC:
+ gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
+ break;
+
+ case GFC_ISYM_MAXLOC:
+ gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
+ break;
+
default:
gfc_conv_intrinsic_funcall (se, expr);
break;
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 9f1742e..382ec74 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+2018-01-15 Thomas Koenig <tkoenig@gcc.gnu.org>
+
+ PR fortran/54613
+ * gfortran.dg/minmaxloc_9.f90: New test.
+ * gfortran.dg/minmaxloc_10.f90: New test.
+ * gfortran.dg/minmaxloc_11.f90: New test.
+
2018-01-15 H.J. Lu <hongjiu.lu@intel.com>
PR target/83839
diff --git a/gcc/testsuite/gfortran.dg/minmaxloc_10.f90 b/gcc/testsuite/gfortran.dg/minmaxloc_10.f90
new file mode 100644
index 0000000..932a40b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/minmaxloc_10.f90
@@ -0,0 +1,118 @@
+! { dg-do run }
+! { dg-additional-options "-fdefault-integer-8" }
+! Check max/minloc with eight-bytes logicals.
+!
+program test
+ implicit none
+ integer :: i(1), j(-1:1), res(1)
+ logical, volatile :: m(3), m2(3)
+ m = (/ .false., .false., .false. /)
+ m2 = (/ .false., .true., .false. /)
+ call check(1, 0, MAXLOC((/ 42, 23, 11 /), DIM=1, MASK=.FALSE.))
+ call check(2, 0, MAXLOC((/ 42, 23, 11 /), DIM=1, MASK=m))
+ call check(3, 2, MAXLOC((/ 42, 23, 11 /), DIM=1, MASK=m2))
+ call check(4, 0, MAXLOC(i(1:0), DIM=1, MASK=.TRUE.))
+ call check(5, 0, MAXLOC(i(1:0), DIM=1, MASK=.FALSE.))
+ call check(6, 0, MAXLOC(i(1:0), DIM=1, MASK=m(1:0)))
+ call check(7, 0, MAXLOC(i(1:0), DIM=1))
+ call check(8, 0, MINLOC((/ 42, 23, 11 /), DIM=1, MASK=.FALSE.))
+ call check(9, 0, MINLOC((/ 42, 23, 11 /), DIM=1, MASK=m))
+ call check(10, 0, MINLOC(i(1:0), DIM=1, MASK=.FALSE.))
+ call check(11,0, MINLOC(i(1:0), DIM=1, MASK=m(1:0)))
+ call check(12,0, MINLOC(i(1:0), DIM=1, MASK=.TRUE.))
+ call check(13,0, MINLOC(i(1:0), DIM=1))
+
+ j = (/ 1, 2, 1 /); call check(14, 2, MAXLOC(j, DIM=1))
+ j = (/ 1, 2, 3 /); call check(15, 3, MAXLOC(j, DIM=1))
+ j = (/ 3, 2, 1 /); call check(16, 1, MAXLOC(j, DIM=1))
+ j = (/ 1, 2, 1 /); call check(17, 1, MINLOC(j, DIM=1))
+ j = (/ 1, 2, 3 /); call check(18, 1, MINLOC(j, DIM=1))
+ j = (/ 3, 2, 1 /); call check(19, 3, MINLOC(j, DIM=1))
+
+ j = (/ 1, 2, 1 /); call check(20, 2, MAXLOC(j, DIM=1,mask=.true.))
+ j = (/ 1, 2, 3 /); call check(21, 3, MAXLOC(j, DIM=1,mask=.true.))
+ j = (/ 3, 2, 1 /); call check(22, 1, MAXLOC(j, DIM=1,mask=.true.))
+ j = (/ 1, 2, 1 /); call check(23, 1, MINLOC(j, DIM=1,mask=.true.))
+ j = (/ 1, 2, 3 /); call check(24, 1, MINLOC(j, DIM=1,mask=.true.))
+ j = (/ 3, 2, 1 /); call check(25, 3, MINLOC(j, DIM=1,mask=.true.))
+
+ j = (/ 1, 2, 1 /); call check(26, 0, MAXLOC(j, DIM=1,mask=.false.))
+ j = (/ 1, 2, 3 /); call check(27, 0, MAXLOC(j, DIM=1,mask=.false.))
+ j = (/ 3, 2, 1 /); call check(28, 0, MAXLOC(j, DIM=1,mask=.false.))
+ j = (/ 1, 2, 1 /); call check(29, 0, MINLOC(j, DIM=1,mask=.false.))
+ j = (/ 1, 2, 3 /); call check(30, 0, MINLOC(j, DIM=1,mask=.false.))
+ j = (/ 3, 2, 1 /); call check(31, 0, MINLOC(j, DIM=1,mask=.false.))
+
+ j = (/ 1, 2, 1 /); call check(32, 0, MAXLOC(j, DIM=1,mask=m))
+ j = (/ 1, 2, 3 /); call check(33, 0, MAXLOC(j, DIM=1,mask=m))
+ j = (/ 3, 2, 1 /); call check(34, 0, MAXLOC(j, DIM=1,mask=m))
+ j = (/ 1, 2, 1 /); call check(35, 0, MINLOC(j, DIM=1,mask=m))
+ j = (/ 1, 2, 3 /); call check(36, 0, MINLOC(j, DIM=1,mask=m))
+ j = (/ 3, 2, 1 /); call check(37, 0, MINLOC(j, DIM=1,mask=m))
+
+ j = (/ 1, 2, 1 /); call check(38, 2, MAXLOC(j, DIM=1,mask=m2))
+ j = (/ 1, 2, 3 /); call check(39, 2, MAXLOC(j, DIM=1,mask=m2))
+ j = (/ 3, 2, 1 /); call check(40, 2, MAXLOC(j, DIM=1,mask=m2))
+ j = (/ 1, 2, 1 /); call check(41, 2, MINLOC(j, DIM=1,mask=m2))
+ j = (/ 1, 2, 3 /); call check(42, 2, MINLOC(j, DIM=1,mask=m2))
+ j = (/ 3, 2, 1 /); call check(43, 2, MINLOC(j, DIM=1,mask=m2))
+
+! Check the library minloc and maxloc
+ res = MAXLOC((/ 42, 23, 11 /), MASK=.FALSE.); call check(44, 0, res(1))
+ res = MAXLOC((/ 42, 23, 11 /), MASK=m); call check(45, 0, res(1))
+ res = MAXLOC((/ 42, 23, 11 /), MASK=m2); call check(46, 2, res(1))
+ res = MAXLOC(i(1:0), MASK=.TRUE.); call check(47, 0, res(1))
+ res = MAXLOC(i(1:0), MASK=.FALSE.); call check(48, 0, res(1))
+ res = MAXLOC(i(1:0), MASK=m(1:0)); call check(49, 0, res(1))
+ res = MAXLOC(i(1:0)); call check(50, 0, res(1))
+ res = MINLOC((/ 42, 23, 11 /), MASK=.FALSE.); call check(51, 0, res(1))
+ res = MINLOC((/ 42, 23, 11 /), MASK=m); call check(52, 0, res(1))
+ res = MINLOC(i(1:0), MASK=.FALSE.); call check(53, 0, res(1))
+ res = MINLOC(i(1:0), MASK=m(1:0)); call check(54,0, res(1))
+ res = MINLOC(i(1:0), MASK=.TRUE.); call check(55,0, res(1))
+ res = MINLOC(i(1:0)); call check(56,0, res(1))
+
+ j = (/ 1, 2, 1 /); res = MAXLOC(j); call check(57, 2, res(1))
+ j = (/ 1, 2, 3 /); res = MAXLOC(j); call check(58, 3, res(1))
+ j = (/ 3, 2, 1 /); res = MAXLOC(j); call check(59, 1, res(1))
+ j = (/ 1, 2, 1 /); res = MINLOC(j); call check(60, 1, res(1))
+ j = (/ 1, 2, 3 /); res = MINLOC(j); call check(61, 1, res(1))
+ j = (/ 3, 2, 1 /); res = MINLOC(j); call check(62, 3, res(1))
+
+ j = (/ 1, 2, 1 /); res = MAXLOC(j,mask=.true.); call check(63, 2, res(1))
+ j = (/ 1, 2, 3 /); res = MAXLOC(j,mask=.true.); call check(65, 3, res(1))
+ j = (/ 3, 2, 1 /); res = MAXLOC(j,mask=.true.); call check(66, 1, res(1))
+ j = (/ 1, 2, 1 /); res = MINLOC(j,mask=.true.); call check(67, 1, res(1))
+ j = (/ 1, 2, 3 /); res = MINLOC(j,mask=.true.); call check(68, 1, res(1))
+ j = (/ 3, 2, 1 /); res = MINLOC(j,mask=.true.); call check(69, 3, res(1))
+
+ j = (/ 1, 2, 1 /); res = MAXLOC(j,mask=.false.); call check(70, 0, res(1))
+ j = (/ 1, 2, 3 /); res = MAXLOC(j,mask=.false.); call check(71, 0, res(1))
+ j = (/ 3, 2, 1 /); res = MAXLOC(j,mask=.false.); call check(72, 0, res(1))
+ j = (/ 1, 2, 1 /); res = MINLOC(j,mask=.false.); call check(73, 0, res(1))
+ j = (/ 1, 2, 3 /); res = MINLOC(j,mask=.false.); call check(74, 0, res(1))
+ j = (/ 3, 2, 1 /); res = MINLOC(j,mask=.false.); call check(75, 0, res(1))
+
+ j = (/ 1, 2, 1 /); res = MAXLOC(j,mask=m); call check(76, 0, res(1))
+ j = (/ 1, 2, 3 /); res = MAXLOC(j,mask=m); call check(77, 0, res(1))
+ j = (/ 3, 2, 1 /); res = MAXLOC(j,mask=m); call check(78, 0, res(1))
+ j = (/ 1, 2, 1 /); res = MINLOC(j,mask=m); call check(79, 0, res(1))
+ j = (/ 1, 2, 3 /); res = MINLOC(j,mask=m); call check(80, 0, res(1))
+ j = (/ 3, 2, 1 /); res = MINLOC(j,mask=m);call check(81, 0, res(1))
+
+ j = (/ 1, 2, 1 /); res = MAXLOC(j,mask=m2); call check(82, 2, res(1))
+ j = (/ 1, 2, 3 /); res = MAXLOC(j,mask=m2); call check(83, 2, res(1))
+ j = (/ 3, 2, 1 /); res = MAXLOC(j,mask=m2); call check(84, 2, res(1))
+ j = (/ 1, 2, 1 /); res = MINLOC(j,mask=m2); call check(85, 2, res(1))
+ j = (/ 1, 2, 3 /); res = MINLOC(j,mask=m2); call check(86, 2, res(1))
+ j = (/ 3, 2, 1 /); res = MINLOC(j,mask=m2); call check(87, 2, res(1))
+
+contains
+subroutine check(n, i,j)
+ integer, value, intent(in) :: i,j,n
+ if(i /= j) then
+ call abort()
+! print *, 'ERROR: Test',n,' expected ',i,' received ', j
+ end if
+end subroutine check
+end program
diff --git a/gcc/testsuite/gfortran.dg/minmaxloc_11.f90 b/gcc/testsuite/gfortran.dg/minmaxloc_11.f90
new file mode 100644
index 0000000..1ab8eb1
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/minmaxloc_11.f90
@@ -0,0 +1,9 @@
+! { dg-do run }
+program main
+ character(len=3), dimension(2) :: a
+ a(1) = 'aaa'
+ a(2) = 'bbb'
+ if (maxloc(a,dim=1) /= 2) call abort
+ if (minloc(a,dim=1) /= 1) call abort
+
+end program main
diff --git a/gcc/testsuite/gfortran.dg/minmaxloc_9.f90 b/gcc/testsuite/gfortran.dg/minmaxloc_9.f90
new file mode 100644
index 0000000..badadac
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/minmaxloc_9.f90
@@ -0,0 +1,11 @@
+! { dg-do compile }
+! Check for a few restrictions on the back argument to
+! minloc and maxloc.
+program main
+ integer, dimension(3) :: a
+ a = [1,2,3]
+ print *,minloc(a,back=42) ! { dg-error "must be LOGICAL" }
+ print *,minloc(a,back=[.true.,.false.]) ! { dg-error "must be a scalar" }
+ print *,maxloc(a,back=42) ! { dg-error "must be LOGICAL" }
+ print *,maxloc(a,back=[.true.,.false.]) ! { dg-error "must be a scalar" }
+end program main
generated by cgit v1.1 at 2025-05-22 04:12:19 +0000