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

re PR fortran/16946 (sum (array, mask) is not accepted) 

fortran/
PR fortran/16946
* check.c (gfc_check_reduction): New function.
(gfc_check_minval_maxval): Removed.
(gfc_check_product): Removed.
(gfc_check_sum): Removed.
* intrinsic.h: Add/remove declarations for these.
* gfortran.h: Add field f3red to union gfc_check_f.
* intrinsic.c (add_sym_3red): New function.
(add_functions): Register maxval, minval, product, and sum intrinsics
through add_sym_3red.
(check_specific): Handle f3red union field.
* iresolve.c: Whitespace change.

testsuite/
PR fortran/16946
* gfortran.dg/reduction.f90: New testcase.

From-SVN: r86255
This commit is contained in:
Erik Schnetter 2004-08-19 15:31:37 +00:00 committed by Tobias Schlüter
parent e281c0f884
commit 7551270e1b
7 changed files with 155 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

84
gcc/fortran/check.c
View File

@ -1135,20 +1135,50 @@ gfc_check_minloc_maxloc (gfc_actual_arglist * ap)
}
/* Similar to minloc/maxloc, the argument list might need to be
reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
difference is that MINLOC/MAXLOC take an additional KIND argument.
The possibilities are:
Arg #2 Arg #3
NULL NULL
DIM NULL
MASK NULL
NULL MASK minval(array, mask=m)
DIM MASK
I.e. in the case of minval(array,mask), mask will be in the second
position of the argument list and we'll have to fix that up. */
try
gfc_check_minval_maxval (gfc_expr * array, gfc_expr * dim, gfc_expr * mask)
gfc_check_reduction (gfc_actual_arglist * ap)
{
gfc_expr *a, *m, *d;
if (array_check (array, 0) == FAILURE)
a = ap->expr;
if (int_or_real_check (a, 0) == FAILURE
|| array_check (a, 0) == FAILURE)
return FAILURE;
if (int_or_real_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 (dim_check (dim, 1, 1) == FAILURE)
return FAILURE;
if (mask != NULL && logical_array_check (mask, 2) == FAILURE)
if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
return FAILURE;
return SUCCESS;
@ -1276,26 +1306,6 @@ gfc_check_present (gfc_expr * a)
}
try
gfc_check_product (gfc_expr * array, gfc_expr * dim, gfc_expr * mask)
{
if (array_check (array, 0) == FAILURE)
return FAILURE;
if (numeric_check (array, 0) == FAILURE)
return FAILURE;
if (dim_check (dim, 1, 1) == FAILURE)
return FAILURE;
if (mask != NULL && logical_array_check (mask, 2) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_radix (gfc_expr * x)
{
@ -1552,26 +1562,6 @@ gfc_check_spread (gfc_expr * source, gfc_expr * dim, gfc_expr * ncopies)
}
try
gfc_check_sum (gfc_expr * array, gfc_expr * dim, gfc_expr * mask)
{
if (array_check (array, 0) == FAILURE)
return FAILURE;
if (numeric_check (array, 0) == FAILURE)
return FAILURE;
if (dim_check (dim, 1, 1) == FAILURE)
return FAILURE;
if (mask != NULL && logical_array_check (mask, 2) == FAILURE)
return FAILURE;
return SUCCESS;
}
try
gfc_check_transfer (gfc_expr * source ATTRIBUTE_UNUSED,
gfc_expr * mold ATTRIBUTE_UNUSED,

1
gcc/fortran/gfortran.h
View File

@ -923,6 +923,7 @@ typedef union
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 (*f3red)(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 *,

73
gcc/fortran/intrinsic.c
View File

@ -506,6 +506,33 @@ static void add_sym_3ml (const char *name, int elemental,
(void*)0);
}
/* MINVAL, MAXVAL, PRODUCT, and SUM also get special treatment because
their argument also might have to be reordered. */
static void add_sym_3red (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.f3red = 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. */
@ -1378,10 +1405,10 @@ add_functions (void)
make_generic ("maxloc", GFC_ISYM_MAXLOC);
add_sym_3 ("maxval", 0, 1, BT_REAL, dr,
gfc_check_minval_maxval, NULL, gfc_resolve_maxval,
ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
msk, BT_LOGICAL, dl, 1);
add_sym_3red ("maxval", 0, 1, BT_REAL, dr,
gfc_check_reduction, NULL, gfc_resolve_maxval,
ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
msk, BT_LOGICAL, dl, 1);
make_generic ("maxval", GFC_ISYM_MAXVAL);
@ -1433,10 +1460,10 @@ add_functions (void)
make_generic ("minloc", GFC_ISYM_MINLOC);
add_sym_3 ("minval", 0, 1, BT_REAL, dr,
gfc_check_minval_maxval, NULL, gfc_resolve_minval,
ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
msk, BT_LOGICAL, dl, 1);
add_sym_3red ("minval", 0, 1, BT_REAL, dr,
gfc_check_reduction, NULL, gfc_resolve_minval,
ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
msk, BT_LOGICAL, dl, 1);
make_generic ("minval", GFC_ISYM_MINVAL);
@ -1506,10 +1533,10 @@ add_functions (void)
make_generic ("present", GFC_ISYM_PRESENT);
add_sym_3 ("product", 0, 1, BT_REAL, dr,
gfc_check_product, NULL, gfc_resolve_product,
ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
msk, BT_LOGICAL, dl, 1);
add_sym_3red ("product", 0, 1, BT_REAL, dr,
gfc_check_reduction, NULL, gfc_resolve_product,
ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
msk, BT_LOGICAL, dl, 1);
make_generic ("product", GFC_ISYM_PRODUCT);
@ -1688,10 +1715,10 @@ add_functions (void)
make_generic ("sqrt", GFC_ISYM_SQRT);
add_sym_3 ("sum", 0, 1, BT_UNKNOWN, 0,
gfc_check_sum, NULL, gfc_resolve_sum,
ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
msk, BT_LOGICAL, dl, 1);
add_sym_3red ("sum", 0, 1, BT_UNKNOWN, 0,
gfc_check_reduction, NULL, gfc_resolve_sum,
ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
msk, BT_LOGICAL, dl, 1);
make_generic ("sum", GFC_ISYM_SUM);
@ -2462,7 +2489,15 @@ check_specific (gfc_intrinsic_sym * specific, gfc_expr * expr, int error_flag)
&expr->where) == FAILURE)
return FAILURE;
if (specific->check.f3ml != gfc_check_minloc_maxloc)
if (specific->check.f3ml == 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_reduction)
/* This is also special because we also might have to reorder the
argument list. */
t = gfc_check_reduction (*ap);
else
{
if (specific->check.f1 == NULL)
{
@ -2473,10 +2508,6 @@ check_specific (gfc_intrinsic_sym * specific, gfc_expr * expr, int error_flag)
else
t = do_check (specific, *ap);
}
else
/* 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)

3
gcc/fortran/intrinsic.h
View File

@ -70,17 +70,16 @@ 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_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 *);
try gfc_check_pack (gfc_expr *, gfc_expr *, gfc_expr *);
try gfc_check_precision (gfc_expr *);
try gfc_check_present (gfc_expr *);
try gfc_check_product (gfc_expr *, gfc_expr *, gfc_expr *);
try gfc_check_radix (gfc_expr *);
try gfc_check_rand (gfc_expr *);
try gfc_check_range (gfc_expr *);
try gfc_check_real (gfc_expr *, gfc_expr *);
try gfc_check_reduction (gfc_actual_arglist *);
try gfc_check_repeat (gfc_expr *, gfc_expr *);
try gfc_check_reshape (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
try gfc_check_scale (gfc_expr *, gfc_expr *);

1
gcc/fortran/iresolve.c
View File

@ -882,6 +882,7 @@ gfc_resolve_minloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
gfc_type_letter (array->ts.type), array->ts.kind);
}
void
gfc_resolve_minval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
gfc_expr * mask)

5
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,8 @@
2004-08-19 Erik Schnetter <schnetter@aei.mpg.de>
PR fortran/16946
* gfortran.dg/reduction.f90: New testcase.
2004-08-19 Tobias Schlueter <tobias.schlueter@physik.uni-muenchen.de>
PR fortran/16520

58
gcc/testsuite/gfortran.dg/reduction.f90 Normal file
View File

@ -0,0 +1,58 @@
! { dg-do run }
! PR 16946
! Not all allowed combinations of arguments for MAXVAL, MINVAL,
! PRODUCT and SUM were supported.
program reduction_mask
implicit none
logical :: equal(3)
integer, parameter :: res(4*9) = (/ 3, 3, 3, 2, 2, 2, 2, 2, 2, 1, 1, 1, 1, &
1, 1, 1, 1, 1, 6, 6, 6, 2, 2, 2, 2, 2, 2, 6, 6, 6, 3, 3, 3, 3, 3, 3 /)
integer :: val(4*9)
equal = (/ .true., .true., .false. /)
! use all combinations of the dim and mask arguments for the
! reduction intrinsics
val( 1) = maxval((/ 1, 2, 3 /))
val( 2) = maxval((/ 1, 2, 3 /), 1)
val( 3) = maxval((/ 1, 2, 3 /), dim=1)
val( 4) = maxval((/ 1, 2, 3 /), equal)
val( 5) = maxval((/ 1, 2, 3 /), mask=equal)
val( 6) = maxval((/ 1, 2, 3 /), 1, equal)
val( 7) = maxval((/ 1, 2, 3 /), 1, mask=equal)
val( 8) = maxval((/ 1, 2, 3 /), dim=1, mask=equal)
val( 9) = maxval((/ 1, 2, 3 /), mask=equal, dim=1)
val(10) = minval((/ 1, 2, 3 /))
val(11) = minval((/ 1, 2, 3 /), 1)
val(12) = minval((/ 1, 2, 3 /), dim=1)
val(13) = minval((/ 1, 2, 3 /), equal)
val(14) = minval((/ 1, 2, 3 /), mask=equal)
val(15) = minval((/ 1, 2, 3 /), 1, equal)
val(16) = minval((/ 1, 2, 3 /), 1, mask=equal)
val(17) = minval((/ 1, 2, 3 /), dim=1, mask=equal)
val(18) = minval((/ 1, 2, 3 /), mask=equal, dim=1)
val(19) = product((/ 1, 2, 3 /))
val(20) = product((/ 1, 2, 3 /), 1)
val(21) = product((/ 1, 2, 3 /), dim=1)
val(22) = product((/ 1, 2, 3 /), equal)
val(23) = product((/ 1, 2, 3 /), mask=equal)
val(24) = product((/ 1, 2, 3 /), 1, equal)
val(25) = product((/ 1, 2, 3 /), 1, mask=equal)
val(26) = product((/ 1, 2, 3 /), dim=1, mask=equal)
val(27) = product((/ 1, 2, 3 /), mask=equal, dim=1)
val(28) = sum((/ 1, 2, 3 /))
val(29) = sum((/ 1, 2, 3 /), 1)
val(30) = sum((/ 1, 2, 3 /), dim=1)
val(31) = sum((/ 1, 2, 3 /), equal)
val(32) = sum((/ 1, 2, 3 /), mask=equal)
val(33) = sum((/ 1, 2, 3 /), 1, equal)
val(34) = sum((/ 1, 2, 3 /), 1, mask=equal)
val(35) = sum((/ 1, 2, 3 /), dim=1, mask=equal)
val(36) = sum((/ 1, 2, 3 /), mask=equal, dim=1)
if (any (val /= res)) call abort
end program reduction_mask