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

re PR fortran/14928 (minloc intrinsic does not understand mask)

Browse Source 
fortran/
2004-06-05  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
        Andrew Vaught <andyv@firstinter.net>

PR fortran/14928
* gfortran.h (gfc_check_f): Add new field f3ml.
* check.c (gfc_check_minloc_maxloc): Take argument list instead
of individual arguments, reorder if necessary.
* intrinsic.h (gfc_check_minloc_maxloc): ... adapt prototype.
* intrinsic.c (add_sym_3ml): New function.
(add_functions): Change to add_sym_3ml for MINLOC, MAXLOC.
(check_specific): Catch special case MINLOC, MAXLOC.

testsuite/
PR fortran/14928
* gfortran.fortran-torture/compile/mloc.f90: New test.

Co-Authored-By: Andrew Vaught <andyv@firstinter.net>

From-SVN: r83111
This commit is contained in:
Tobias Schlüter 2004-06-14 17:56:50 +02:00 committed by Tobias Schlüter
parent 84b1d82150
commit f3207b37d3
7 changed files with 102 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
gcc/fortran/ChangeLog
View File

@ -1,3 +1,15 @@
2004-06-05 Tobias Schlueter <tobias.schlueter@physik.uni-muenchen.de>
Andrew Vaught <andyv@firstinter.net>
PR fortran/14928
* gfortran.h (gfc_check_f): Add new field f3ml.
* check.c (gfc_check_minloc_maxloc): Take argument list instead
of individual arguments, reorder if necessary.
* intrinsic.h (gfc_check_minloc_maxloc): ... adapt prototype.
* intrinsic.c (add_sym_3ml): New function.
(add_functions): Change to add_sym_3ml for MINLOC, MAXLOC.
(check_specific): Catch special case MINLOC, MAXLOC.
2004-06-14 Paul Brook <paul@codesourcery.com>
* intrinsic.c (add_sym_2s): Use correct function types.

65
gcc/fortran/check.c
View File

@ -1096,53 +1096,40 @@ gfc_check_matmul (gfc_expr * matrix_a, gfc_expr * matrix_b)
MASK NULL
NULL MASK minloc(array, mask=m)
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. */
try
gfc_check_minloc_maxloc (gfc_expr * array, gfc_expr * a2, gfc_expr * a3)
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)
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 (a3 != NULL)
{
if (logical_array_check (a3, 2) == FAILURE)
return FAILURE;
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;
}
}
}
if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
return FAILURE;
return SUCCESS;
}

1
gcc/fortran/gfortran.h
View File

@ -821,6 +821,7 @@ typedef union
try (*f1m)(gfc_actual_arglist *);
try (*f2)(struct gfc_expr *, struct gfc_expr *);
try (*f3)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *);
try (*f3ml)(gfc_actual_arglist *);
try (*f4)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *,
struct gfc_expr *);
try (*f5)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *,

64
gcc/fortran/intrinsic.c
View File

@ -479,6 +479,33 @@ static void add_sym_3 (const char *name, int elemental, int actual_ok, bt type,
(void*)0);
}
/* MINLOC and MAXLOC get special treatment because their argument
might have to be reordered. */
static void add_sym_3ml (const char *name, int elemental,
int actual_ok, bt type, int kind,
try (*check)(gfc_actual_arglist *),
gfc_expr*(*simplify)(gfc_expr *,gfc_expr *,gfc_expr *),
void (*resolve)(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
) {
gfc_check_f cf;
gfc_simplify_f sf;
gfc_resolve_f rf;
cf.f3ml = check;
sf.f3 = simplify;
rf.f3 = resolve;
add_sym (name, elemental, actual_ok, type, kind, cf, sf, rf,
a1, type1, kind1, optional1,
a2, type2, kind2, optional2,
a3, type3, kind3, optional3,
(void*)0);
}
/* Add the name of an intrinsic subroutine with three arguments to the list
of intrinsic names. */
@ -1281,10 +1308,10 @@ add_functions (void)
make_generic ("maxexponent", GFC_ISYM_NONE);
add_sym_3 ("maxloc", 0, 1, BT_INTEGER, di,
gfc_check_minloc_maxloc, NULL, gfc_resolve_maxloc,
ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
msk, BT_LOGICAL, dl, 1);
add_sym_3ml ("maxloc", 0, 1, BT_INTEGER, di,
gfc_check_minloc_maxloc, NULL, gfc_resolve_maxloc,
ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
msk, BT_LOGICAL, dl, 1);
make_generic ("maxloc", GFC_ISYM_MAXLOC);
@ -1336,10 +1363,10 @@ add_functions (void)
make_generic ("minexponent", GFC_ISYM_NONE);
add_sym_3 ("minloc", 0, 1, BT_INTEGER, di,
gfc_check_minloc_maxloc, NULL, gfc_resolve_minloc,
ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
msk, BT_LOGICAL, dl, 1);
add_sym_3ml ("minloc", 0, 1, BT_INTEGER, di,
gfc_check_minloc_maxloc, NULL, gfc_resolve_minloc,
ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
msk, BT_LOGICAL, dl, 1);
make_generic ("minloc", GFC_ISYM_MINLOC);
@ -2331,14 +2358,21 @@ check_specific (gfc_intrinsic_sym * specific, gfc_expr * expr, int error_flag)
&expr->where) == FAILURE)
return FAILURE;
if (specific->check.f1 == NULL)
{
t = check_arglist (ap, specific, error_flag);
if (t == SUCCESS)
expr->ts = specific->ts;
}
if (specific->check.f3ml != gfc_check_minloc_maxloc)
{
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);
/* This is special because we might have to reorder the argument
list. */
t = gfc_check_minloc_maxloc (*ap);
/* Check ranks for elemental intrinsics. */
if (t == SUCCESS && specific->elemental)

2
gcc/fortran/intrinsic.h
View File

@ -69,7 +69,7 @@ try gfc_check_min_max_real (gfc_actual_arglist *);
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 *);

5
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,8 @@
2004-06-14 Tobias Schlueter <tobias.schlueter@physik.uni-muenchen.de>
PR fortran/14928
* gfortran.fortran-torture/compile/mloc.f90: New test.
2004-06-13 Paul Brook <paul@codesourcery.com>
* gfortran.fortran-torture/execute/random_2.f90: New test.

8
gcc/testsuite/gfortran.fortran-torture/compile/mloc.f90 Normal file
View File

@ -0,0 +1,8 @@
! from PR 14928
! we used to not accept the two argument variant of MINLOC and MAXLOC when
! the MASK keyword was omitted.
real b(10)
integer c(1)
c = minloc(b,b<0)
c = maxloc(b,b>0)
end