From 7551270e1b6232a38f772eb9298ddbe0aa970918 Mon Sep 17 00:00:00 2001 From: Erik Schnetter Date: Thu, 19 Aug 2004 15:31:37 +0000 Subject: [PATCH] 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 --- gcc/fortran/check.c | 84 +++++++++++-------------- gcc/fortran/gfortran.h | 1 + gcc/fortran/intrinsic.c | 73 ++++++++++++++------- gcc/fortran/intrinsic.h | 3 +- gcc/fortran/iresolve.c | 1 + gcc/testsuite/ChangeLog | 5 ++ gcc/testsuite/gfortran.dg/reduction.f90 | 58 +++++++++++++++++ 7 files changed, 155 insertions(+), 70 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/reduction.f90 diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 9a82d889371..aff024a5874 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -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, diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 45851610e38..2839b4a995e 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -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 *, diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 14014a007a6..00cdecf87da 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -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) diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index 3a50d05b8c5..0eeeaf96e85 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -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 *); diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index 21fd0150c0b..bfa51c4ea7c 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -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) diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index b3e70dc964a..6ec5172ba1d 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2004-08-19 Erik Schnetter + + PR fortran/16946 + * gfortran.dg/reduction.f90: New testcase. + 2004-08-19 Tobias Schlueter PR fortran/16520 diff --git a/gcc/testsuite/gfortran.dg/reduction.f90 b/gcc/testsuite/gfortran.dg/reduction.f90 new file mode 100644 index 00000000000..f98eb29231f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/reduction.f90 @@ -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