This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[gfortran] PR 14928: Fix two-argument variant of MINLOC/MAXLOC
- From: Tobias Schlüter <tobias dot schlueter at physik dot uni-muenchen dot de>
- To: GCC Fortran mailing list <fortran at gcc dot gnu dot org>,patch <gcc-patches at gcc dot gnu dot org>
- Date: Sat, 05 Jun 2004 15:09:24 +0200
- Subject: [gfortran] PR 14928: Fix two-argument variant of MINLOC/MAXLOC
This is a port from Andy's tree, which fixes an issue where we
erroneously wouldn't accept a statement of the form
c = MAXLOC(b, b>0)
because we would not realize that the second argument is of type LOGICAL
and therefor the mask. In order to do this we have to reorder the
argument list at an unfortunate late point, namely when running the
checks for intrinsic function calls. Without further work we can't do
this elsewhere. This means special casing the treatment of MINLOC and
MAXLOC, which is a little harder than necessary because of our type-safe
mechanisms for adding intrinsics (therefor the casts to void), but as
this code is supposedly not going to change often this doesn't seem to
be much of an issue.
(In case you wonder: yes, MAXLOC and MINLOC are indeed special, our
general treatment is not lacking.)
Compiled and tested on i686-pc-linux. I will add the testcase from the
PR to the compile testsuite. Ok?
Because neither "cvs diff -c3p" nor "cvs diff -up" produced a really
readable diff, here's the new function gfc_check_minloc_maxloc in all
its beauty:
try
gfc_check_minloc_maxloc (gfc_actual_arglist * ap)
{
gfc_expr *a, *m, *d;
a = ap->expr;
if (int_or_real_check (a, 0) == FAILURE
|| array_check (a, 0) == FAILURE)
return FAILURE;
d = ap->next->expr;
m = ap->next->next->expr;
if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
&& ap->next->name[0] == '\0')
{
m = d;
d = NULL;
ap->next->expr = NULL;
ap->next->next->expr = m;
}
if (d != NULL
&& (scalar_check (d, 1) == FAILURE
|| type_check (d, 1, BT_INTEGER) == FAILURE))
return FAILURE;
if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
return FAILURE;
return SUCCESS;
}
- Tobi
2004-06-05 Tobias Schlueter <tobias.schlueter@physik.uni-muenchen.de>
Andrew Vaught <andyv@firstinter.net>
* check.c (gfc_check_minloc_maxloc): Take argument list insted
of individual arguments, reorder if necessary.
* intrinsic.h (gfc_check_minloc_maxloc): ... adapt prototype.
* intrinsic.c (add_functions): Special treatment for MINLOC,
MAXLOC, pass check function as (void *).
(check_specific): Catch special case MINLOC, MAXLOC.
Index: intrinsic.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/intrinsic.h,v
retrieving revision 1.5
diff -u -p -r1.5 intrinsic.h
--- intrinsic.h 22 May 2004 12:47:38 -0000 1.5
+++ intrinsic.h 5 Jun 2004 12:53:31 -0000
@@ -66,7 +66,7 @@ try gfc_check_min_max_real (gfc_actual_a
try gfc_check_min_max_double (gfc_actual_arglist *);
try gfc_check_matmul (gfc_expr *, gfc_expr *);
try gfc_check_merge (gfc_expr *, gfc_expr *, gfc_expr *);
-try gfc_check_minloc_maxloc (gfc_expr *, gfc_expr *, gfc_expr *);
+try gfc_check_minloc_maxloc (gfc_actual_arglist *);
try gfc_check_minval_maxval (gfc_expr *, gfc_expr *, gfc_expr *);
try gfc_check_nearest (gfc_expr *, gfc_expr *);
try gfc_check_null (gfc_expr *);
Index: intrinsic.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/intrinsic.c,v
retrieving revision 1.7
diff -u -p -r1.7 intrinsic.c
--- intrinsic.c 5 Jun 2004 11:34:51 -0000 1.7
+++ intrinsic.c 5 Jun 2004 12:53:32 -0000
@@ -1238,8 +1238,10 @@ add_functions (void)
make_generic ("maxexponent", GFC_ISYM_NONE);
+ /* MAXLOC gets a special treatment because we might have to reorder
+ its argument list. */
add_sym_3 ("maxloc", 0, 1, BT_INTEGER, di,
- gfc_check_minloc_maxloc, NULL, gfc_resolve_maxloc,
+ (void *)gfc_check_minloc_maxloc, NULL, gfc_resolve_maxloc,
ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
msk, BT_LOGICAL, dl, 1);
@@ -1293,8 +1295,10 @@ add_functions (void)
make_generic ("minexponent", GFC_ISYM_NONE);
+ /* MINLOC gets special tretment because we might have to reorder its
+ argument list. */
add_sym_3 ("minloc", 0, 1, BT_INTEGER, di,
- gfc_check_minloc_maxloc, NULL, gfc_resolve_minloc,
+ (void *)gfc_check_minloc_maxloc, NULL, gfc_resolve_minloc,
ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
msk, BT_LOGICAL, dl, 1);
@@ -2255,14 +2259,21 @@ check_specific (gfc_intrinsic_sym * spec
&expr->where) == FAILURE)
return FAILURE;
- if (specific->check.f1 == NULL)
+ if ((void *)specific->check.f3 == (void *)gfc_check_minloc_maxloc)
+ /* This is special because we might have to reorder the argument
+ list. */
+ t = gfc_check_minloc_maxloc (*ap);
+ else
{
- t = check_arglist (ap, specific, error_flag);
- if (t == SUCCESS)
- expr->ts = specific->ts;
+ if (specific->check.f1 == NULL)
+ {
+ t = check_arglist (ap, specific, error_flag);
+ if (t == SUCCESS)
+ expr->ts = specific->ts;
+ }
+ else
+ t = do_check (specific, *ap);
}
- else
- t = do_check (specific, *ap);
/* Check ranks for elemental intrinsics. */
if (t == SUCCESS && specific->elemental)
Index: check.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/check.c,v
retrieving revision 1.5
diff -u -p -r1.5 check.c
--- check.c 23 May 2004 11:06:09 -0000 1.5
+++ check.c 5 Jun 2004 13:08:24 -0000
@@ -1096,54 +1096,41 @@ gfc_check_matmul (gfc_expr * matrix_a, g
MASK NULL
NULL MASK minloc(array, mask=m)
DIM MASK
-*/
-try
-gfc_check_minloc_maxloc (gfc_expr * array, gfc_expr * a2, gfc_expr * a3)
+ 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. */
+
+try
+gfc_check_minloc_maxloc (gfc_actual_arglist * ap)
{
+ gfc_expr *a, *m, *d;
- if (int_or_real_check (array, 0) == FAILURE)
+ a = ap->expr;
+ if (int_or_real_check (a, 0) == FAILURE
+ || array_check (a, 0) == FAILURE)
return FAILURE;
- if (array_check (array, 0) == FAILURE)
- return FAILURE;
+ d = ap->next->expr;
+ m = ap->next->next->expr;
- if (a3 != NULL)
+ if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
+ && ap->next->name[0] == '\0')
{
- if (logical_array_check (a3, 2) == FAILURE)
- return FAILURE;
+ m = d;
+ d = NULL;
- if (a2 != NULL)
- {
- if (scalar_check (a2, 1) == FAILURE)
- return FAILURE;
- if (type_check (a2, 1, BT_INTEGER) == FAILURE)
- return FAILURE;
- }
- }
- else
- {
- if (a2 != NULL)
- {
- switch (a2->ts.type)
- {
- case BT_INTEGER:
- if (scalar_check (a2, 1) == FAILURE)
- return FAILURE;
- break;
-
- case BT_LOGICAL: /* The '2' makes the error message
correct */
- if (logical_array_check (a2, 2) == FAILURE)
- return FAILURE;
- break;
-
- default:
- type_check (a2, 1, BT_INTEGER); /* Guaranteed to fail */
- return FAILURE;
- }
- }
+ ap->next->expr = NULL;
+ ap->next->next->expr = m;
}
+ if (d != NULL
+ && (scalar_check (d, 1) == FAILURE
+ || type_check (d, 1, BT_INTEGER) == FAILURE))
+ return FAILURE;
+
+ if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
+ return FAILURE;
+
return SUCCESS;
}