From a16d978fca0146aebb9e2ec46236d3cd03554695 Mon Sep 17 00:00:00 2001 From: Daniel Franke Date: Sun, 7 Jun 2009 12:35:06 -0400 Subject: [PATCH] re PR fortran/25104 ([F2003] Non-initialization expr. as case-selector) 2009-06-07 Daniel Franke PR fortran/25104 PR fortran/29962 * check.c (gfc_check_all_any): Check rank of DIM. (gfc_check_count): Likewise. * intrinsic.h (gfc_simplify_all): New prototype. (gfc_simplify_any): Likewise. (gfc_simplify_count): Likewise. (gfc_simplify_sum): Likewise. (gfc_simplify_product): Likewise. * intrinsic.c (add_functions): Added new simplifier callbacks. * simplify.c (transformational_result): New. (simplify_transformation_to_scalar): New. (simplify_transformation_to_array): New. (gfc_count): New. (gfc_simplify_all): New. (gfc_simplify_any): New. (gfc_simplify_count): New. (gfc_simplify_sum): New. (gfc_simplify_product): New. * expr.c (check_transformational): Allow additional * transformational intrinsics in initialization expression. 2009-06-07 Daniel Franke PR fortran/25104 PR fortran/29962 * gfortran.dg/count_init_expr.f03 * gfortran.dg/product_init_expr.f03 * gfortran.dg/sum_init_expr.f03 From-SVN: r148249 --- gcc/fortran/ChangeLog | 24 ++ gcc/fortran/check.c | 5 + gcc/fortran/expr.c | 6 +- gcc/fortran/intrinsic.c | 10 +- gcc/fortran/intrinsic.h | 5 + gcc/fortran/simplify.c | 352 ++++++++++++++++++ gcc/testsuite/ChangeLog | 8 + gcc/testsuite/gfortran.dg/count_init_expr.f03 | 15 + .../gfortran.dg/product_init_expr.f03 | 66 ++++ gcc/testsuite/gfortran.dg/sum_init_expr.f03 | 66 ++++ 10 files changed, 549 insertions(+), 8 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/count_init_expr.f03 create mode 100644 gcc/testsuite/gfortran.dg/product_init_expr.f03 create mode 100644 gcc/testsuite/gfortran.dg/sum_init_expr.f03 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index be976690d145..638a9b876105 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,27 @@ +2009-06-07 Daniel Franke + + PR fortran/25104 + PR fortran/29962 + * check.c (gfc_check_all_any): Check rank of DIM. + (gfc_check_count): Likewise. + * intrinsic.h (gfc_simplify_all): New prototype. + (gfc_simplify_any): Likewise. + (gfc_simplify_count): Likewise. + (gfc_simplify_sum): Likewise. + (gfc_simplify_product): Likewise. + * intrinsic.c (add_functions): Added new simplifier callbacks. + * simplify.c (transformational_result): New. + (simplify_transformation_to_scalar): New. + (simplify_transformation_to_array): New. + (gfc_count): New. + (gfc_simplify_all): New. + (gfc_simplify_any): New. + (gfc_simplify_count): New. + (gfc_simplify_sum): New. + (gfc_simplify_product): New. + * expr.c (check_transformational): Allow additional transformational + intrinsics in initialization expression. + 2009-06-07 Daniel Franke * check.c (dim_rank_check): Return SUCCESS if DIM=NULL. diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index eaab309b1b85..c45d5db6b05a 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -522,6 +522,9 @@ gfc_check_all_any (gfc_expr *mask, gfc_expr *dim) if (dim_check (dim, 1, false) == FAILURE) return FAILURE; + if (dim_rank_check (dim, mask, 0) == FAILURE) + return FAILURE; + return SUCCESS; } @@ -859,6 +862,8 @@ gfc_check_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind) return FAILURE; if (dim_check (dim, 1, false) == FAILURE) return FAILURE; + if (dim_rank_check (dim, mask, 0) == FAILURE) + return FAILURE; if (kind_check (kind, 2, BT_INTEGER) == FAILURE) return FAILURE; if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic " diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 71acbd6df3d9..a6a3a3b4ee3a 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -2128,9 +2128,9 @@ check_transformational (gfc_expr *e) }; static const char * const trans_func_f2003[] = { - "dot_product", "matmul", "null", "pack", "repeat", - "reshape", "selected_char_kind", "selected_int_kind", - "selected_real_kind", "transfer", "transpose", "trim", NULL + "all", "any", "count", "dot_product", "matmul", "null", "pack", + "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind", + "selected_real_kind", "sum", "transfer", "transpose", "trim", NULL }; int i; diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index c519f6ee808a..2dbb0cf14149 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -1189,7 +1189,7 @@ add_functions (void) make_generic ("aint", GFC_ISYM_AINT, GFC_STD_F77); add_sym_2 ("all", GFC_ISYM_ALL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95, - gfc_check_all_any, NULL, gfc_resolve_all, + gfc_check_all_any, gfc_simplify_all, gfc_resolve_all, msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL); make_generic ("all", GFC_ISYM_ALL, GFC_STD_F95); @@ -1211,7 +1211,7 @@ add_functions (void) make_generic ("anint", GFC_ISYM_ANINT, GFC_STD_F77); add_sym_2 ("any", GFC_ISYM_ANY, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95, - gfc_check_all_any, NULL, gfc_resolve_any, + gfc_check_all_any, gfc_simplify_any, gfc_resolve_any, msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL); make_generic ("any", GFC_ISYM_ANY, GFC_STD_F95); @@ -1451,7 +1451,7 @@ add_functions (void) add_sym_3 ("count", GFC_ISYM_COUNT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, - gfc_check_count, NULL, gfc_resolve_count, + gfc_check_count, gfc_simplify_count, gfc_resolve_count, msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL); @@ -2228,7 +2228,7 @@ add_functions (void) make_generic ("present", GFC_ISYM_PRESENT, GFC_STD_F95); add_sym_3red ("product", GFC_ISYM_PRODUCT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, - gfc_check_product_sum, NULL, gfc_resolve_product, + gfc_check_product_sum, gfc_simplify_product, gfc_resolve_product, ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, msk, BT_LOGICAL, dl, OPTIONAL); @@ -2466,7 +2466,7 @@ add_functions (void) make_generic ("stat", GFC_ISYM_STAT, GFC_STD_GNU); add_sym_3red ("sum", GFC_ISYM_SUM, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, - gfc_check_product_sum, NULL, gfc_resolve_sum, + gfc_check_product_sum, gfc_simplify_sum, gfc_resolve_sum, ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, msk, BT_LOGICAL, dl, OPTIONAL); diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index 0e6d0f9a408c..b483b11fe984 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -200,10 +200,12 @@ gfc_expr *gfc_simplify_adjustl (gfc_expr *); gfc_expr *gfc_simplify_adjustr (gfc_expr *); gfc_expr *gfc_simplify_aimag (gfc_expr *); gfc_expr *gfc_simplify_aint (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_all (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_dint (gfc_expr *); gfc_expr *gfc_simplify_anint (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_dnint (gfc_expr *); gfc_expr *gfc_simplify_and (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_any (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_asin (gfc_expr *); gfc_expr *gfc_simplify_asinh (gfc_expr *); gfc_expr *gfc_simplify_atan (gfc_expr *); @@ -224,6 +226,7 @@ gfc_expr *gfc_simplify_complex (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_conjg (gfc_expr *); gfc_expr *gfc_simplify_cos (gfc_expr *); gfc_expr *gfc_simplify_cosh (gfc_expr *); +gfc_expr *gfc_simplify_count (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_dcmplx (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_dble (gfc_expr *); gfc_expr *gfc_simplify_digits (gfc_expr *); @@ -293,6 +296,7 @@ gfc_expr *gfc_simplify_not (gfc_expr *); gfc_expr *gfc_simplify_or (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_pack (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_precision (gfc_expr *); +gfc_expr *gfc_simplify_product (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_radix (gfc_expr *); gfc_expr *gfc_simplify_range (gfc_expr *); gfc_expr *gfc_simplify_real (gfc_expr *, gfc_expr *); @@ -315,6 +319,7 @@ gfc_expr *gfc_simplify_size (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_sngl (gfc_expr *); gfc_expr *gfc_simplify_spacing (gfc_expr *); gfc_expr *gfc_simplify_sqrt (gfc_expr *); +gfc_expr *gfc_simplify_sum (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_tan (gfc_expr *); gfc_expr *gfc_simplify_tanh (gfc_expr *); gfc_expr *gfc_simplify_tiny (gfc_expr *); diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index db28d36213a3..dbd7f3d6309e 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -387,6 +387,246 @@ compute_dot_product (gfc_constructor *ctor_a, int stride_a, return result; } + +/* Build a result expression for transformational intrinsics, + depending on DIM. */ + +static gfc_expr * +transformational_result (gfc_expr *array, gfc_expr *dim, bt type, + int kind, locus* where) +{ + gfc_expr *result; + int i, nelem; + + if (!dim || array->rank == 1) + return gfc_constant_result (type, kind, where); + + result = gfc_start_constructor (type, kind, where); + result->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim); + result->rank = array->rank - 1; + + /* gfc_array_size() would count the number of elements in the constructor, + we have not built those yet. */ + nelem = 1; + for (i = 0; i < result->rank; ++i) + nelem *= mpz_get_ui (result->shape[i]); + + for (i = 0; i < nelem; ++i) + { + gfc_expr *e = gfc_constant_result (type, kind, where); + gfc_append_constructor (result, e); + } + + return result; +} + + +typedef gfc_expr* (*transformational_op)(gfc_expr*, gfc_expr*); + +/* Wrapper function, implements 'op1 += 1'. Only called if MASK + of COUNT intrinsic is .TRUE.. + + Interface and implimentation mimics arith functions as + gfc_add, gfc_multiply, etc. */ + +static gfc_expr* gfc_count (gfc_expr *op1, gfc_expr *op2) +{ + gfc_expr *result; + + gcc_assert (op1->ts.type == BT_INTEGER); + gcc_assert (op2->ts.type == BT_LOGICAL); + gcc_assert (op2->value.logical); + + result = gfc_copy_expr (op1); + mpz_add_ui (result->value.integer, result->value.integer, 1); + + gfc_free_expr (op1); + gfc_free_expr (op2); + return result; +} + + +/* Transforms an ARRAY with operation OP, according to MASK, to a + scalar RESULT. E.g. called if + + REAL, PARAMETER :: array(n, m) = ... + REAL, PARAMETER :: s = SUM(array) + + where OP == gfc_add(). */ + +static gfc_expr * +simplify_transformation_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *mask, + transformational_op op) +{ + gfc_expr *a, *m; + gfc_constructor *array_ctor, *mask_ctor; + + /* Shortcut for constant .FALSE. MASK. */ + if (mask + && mask->expr_type == EXPR_CONSTANT + && !mask->value.logical) + return result; + + array_ctor = array->value.constructor; + mask_ctor = NULL; + if (mask && mask->expr_type == EXPR_ARRAY) + mask_ctor = mask->value.constructor; + + while (array_ctor) + { + a = array_ctor->expr; + array_ctor = array_ctor->next; + + /* A constant MASK equals .TRUE. here and can be ignored. */ + if (mask_ctor) + { + m = mask_ctor->expr; + mask_ctor = mask_ctor->next; + if (!m->value.logical) + continue; + } + + result = op (result, gfc_copy_expr (a)); + } + + return result; +} + +/* Transforms an ARRAY with operation OP, according to MASK, to an + array RESULT. E.g. called if + + REAL, PARAMETER :: array(n, m) = ... + REAL, PARAMETER :: s(n) = PROD(array, DIM=1) + + where OP == gfc_multiply(). */ + +static gfc_expr * +simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *dim, + gfc_expr *mask, transformational_op op) +{ + mpz_t size; + int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride; + gfc_expr **arrayvec, **resultvec, **base, **src, **dest; + gfc_constructor *array_ctor, *mask_ctor, *result_ctor; + + int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS], + sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS], + tmpstride[GFC_MAX_DIMENSIONS]; + + /* Shortcut for constant .FALSE. MASK. */ + if (mask + && mask->expr_type == EXPR_CONSTANT + && !mask->value.logical) + return result; + + /* Build an indexed table for array element expressions to minimize + linked-list traversal. Masked elements are set to NULL. */ + gfc_array_size (array, &size); + arraysize = mpz_get_ui (size); + + arrayvec = (gfc_expr**) gfc_getmem (sizeof (gfc_expr*) * arraysize); + + array_ctor = array->value.constructor; + mask_ctor = NULL; + if (mask && mask->expr_type == EXPR_ARRAY) + mask_ctor = mask->value.constructor; + + for (i = 0; i < arraysize; ++i) + { + arrayvec[i] = array_ctor->expr; + array_ctor = array_ctor->next; + + if (mask_ctor) + { + if (!mask_ctor->expr->value.logical) + arrayvec[i] = NULL; + + mask_ctor = mask_ctor->next; + } + } + + /* Same for the result expression. */ + gfc_array_size (result, &size); + resultsize = mpz_get_ui (size); + mpz_clear (size); + + resultvec = (gfc_expr**) gfc_getmem (sizeof (gfc_expr*) * resultsize); + result_ctor = result->value.constructor; + for (i = 0; i < resultsize; ++i) + { + resultvec[i] = result_ctor->expr; + result_ctor = result_ctor->next; + } + + gfc_extract_int (dim, &dim_index); + dim_index -= 1; /* zero-base index */ + dim_extent = 0; + dim_stride = 0; + + for (i = 0, n = 0; i < array->rank; ++i) + { + count[i] = 0; + tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]); + if (i == dim_index) + { + dim_extent = mpz_get_si (array->shape[i]); + dim_stride = tmpstride[i]; + continue; + } + + extent[n] = mpz_get_si (array->shape[i]); + sstride[n] = tmpstride[i]; + dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1]; + n += 1; + } + + done = false; + base = arrayvec; + dest = resultvec; + while (!done) + { + for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n) + if (*src) + *dest = op (*dest, gfc_copy_expr (*src)); + + count[0]++; + base += sstride[0]; + dest += dstride[0]; + + n = 0; + while (!done && count[n] == extent[n]) + { + count[n] = 0; + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + + n++; + if (n < result->rank) + { + count [n]++; + base += sstride[n]; + dest += dstride[n]; + } + else + done = true; + } + } + + /* Place updated expression in result constructor. */ + result_ctor = result->value.constructor; + for (i = 0; i < resultsize; ++i) + { + result_ctor->expr = resultvec[i]; + result_ctor = result_ctor->next; + } + + gfc_free (arrayvec); + gfc_free (resultvec); + return result; +} + + + /********************** Simplification functions *****************************/ gfc_expr * @@ -657,6 +897,25 @@ gfc_simplify_aint (gfc_expr *e, gfc_expr *k) } +gfc_expr * +gfc_simplify_all (gfc_expr *mask, gfc_expr *dim) +{ + gfc_expr *result; + + if (!is_constant_array_expr (mask) + || !gfc_is_constant_expr (dim)) + return NULL; + + result = transformational_result (mask, dim, mask->ts.type, + mask->ts.kind, &mask->where); + init_result_expr (result, true, NULL); + + return !dim || mask->rank == 1 ? + simplify_transformation_to_scalar (result, mask, NULL, gfc_and) : + simplify_transformation_to_array (result, mask, dim, NULL, gfc_and); +} + + gfc_expr * gfc_simplify_dint (gfc_expr *e) { @@ -722,6 +981,25 @@ gfc_simplify_and (gfc_expr *x, gfc_expr *y) } +gfc_expr * +gfc_simplify_any (gfc_expr *mask, gfc_expr *dim) +{ + gfc_expr *result; + + if (!is_constant_array_expr (mask) + || !gfc_is_constant_expr (dim)) + return NULL; + + result = transformational_result (mask, dim, mask->ts.type, + mask->ts.kind, &mask->where); + init_result_expr (result, false, NULL); + + return !dim || mask->rank == 1 ? + simplify_transformation_to_scalar (result, mask, NULL, gfc_or) : + simplify_transformation_to_array (result, mask, dim, NULL, gfc_or); +} + + gfc_expr * gfc_simplify_dnint (gfc_expr *e) { @@ -1221,6 +1499,32 @@ gfc_simplify_cosh (gfc_expr *x) } +gfc_expr * +gfc_simplify_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind) +{ + gfc_expr *result; + + if (!is_constant_array_expr (mask) + || !gfc_is_constant_expr (dim) + || !gfc_is_constant_expr (kind)) + return NULL; + + result = transformational_result (mask, dim, + BT_INTEGER, + get_kind (BT_INTEGER, kind, "COUNT", + gfc_default_integer_kind), + &mask->where); + + init_result_expr (result, 0, NULL); + + /* Passing MASK twice, once as data array, once as mask. + Whenever gfc_count is called, '1' is added to the result. */ + return !dim || mask->rank == 1 ? + simplify_transformation_to_scalar (result, mask, mask, gfc_count) : + simplify_transformation_to_array (result, mask, dim, mask, gfc_count); +} + + gfc_expr * gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y) { @@ -3705,6 +4009,30 @@ gfc_simplify_precision (gfc_expr *e) } +gfc_expr * +gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) +{ + gfc_expr *result; + + if (!is_constant_array_expr (array) + || !gfc_is_constant_expr (dim)) + return NULL; + + if (mask + && !is_constant_array_expr (mask) + && mask->expr_type != EXPR_CONSTANT) + return NULL; + + result = transformational_result (array, dim, array->ts.type, + array->ts.kind, &array->where); + init_result_expr (result, 1, NULL); + + return !dim || array->rank == 1 ? + simplify_transformation_to_scalar (result, array, mask, gfc_multiply) : + simplify_transformation_to_array (result, array, dim, mask, gfc_multiply); +} + + gfc_expr * gfc_simplify_radix (gfc_expr *e) { @@ -4827,6 +5155,30 @@ negative_arg: } +gfc_expr * +gfc_simplify_sum (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) +{ + gfc_expr *result; + + if (!is_constant_array_expr (array) + || !gfc_is_constant_expr (dim)) + return NULL; + + if (mask + && !is_constant_array_expr (mask) + && mask->expr_type != EXPR_CONSTANT) + return NULL; + + result = transformational_result (array, dim, array->ts.type, + array->ts.kind, &array->where); + init_result_expr (result, 0, NULL); + + return !dim || array->rank == 1 ? + simplify_transformation_to_scalar (result, array, mask, gfc_add) : + simplify_transformation_to_array (result, array, dim, mask, gfc_add); +} + + gfc_expr * gfc_simplify_tan (gfc_expr *x) { diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 4b9ac1cf01a8..78cd329f95a5 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,11 @@ +2009-06-07 Daniel Franke + + PR fortran/25104 + PR fortran/29962 + * gfortran.dg/count_init_expr.f03 + * gfortran.dg/product_init_expr.f03 + * gfortran.dg/sum_init_expr.f03 + 2009-06-07 Daniel Franke PR fortran/36874 diff --git a/gcc/testsuite/gfortran.dg/count_init_expr.f03 b/gcc/testsuite/gfortran.dg/count_init_expr.f03 new file mode 100644 index 000000000000..73a8efa95658 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/count_init_expr.f03 @@ -0,0 +1,15 @@ +! { dg-do "run" } + + INTEGER :: i + INTEGER, PARAMETER :: m(4,4) = RESHAPE([ (i, i=1, 16) ], [4, 4] ) + INTEGER, PARAMETER :: sevens = COUNT (m == 7) + INTEGER, PARAMETER :: odd(4) = COUNT (MOD(m, 2) == 1, dim=1) + INTEGER, PARAMETER :: even = COUNT (MOD(m, 2) == 0) + + IF (sevens /= 1) CALL abort() + IF (ANY(odd /= [ 2,2,2,2 ])) CALL abort() + IF (even /= 8) CALL abort() + + ! check the kind parameter + IF (KIND(COUNT (m == 7, KIND=2)) /= 2) CALL abort() +END diff --git a/gcc/testsuite/gfortran.dg/product_init_expr.f03 b/gcc/testsuite/gfortran.dg/product_init_expr.f03 new file mode 100644 index 000000000000..6724eb719f6b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/product_init_expr.f03 @@ -0,0 +1,66 @@ +! { dg-do "run" } +! { dg-options "-fno-inline" } +! +! PRODUCT as initialization expression. +! +! This test compares results of simplifier of PRODUCT +! with the corresponding inlined or library routine(s). +! + + IMPLICIT NONE + + INTEGER, PARAMETER :: imatrix(2,4) = RESHAPE ([ 1, 2, 3, 4, 5, 6, 7, 8 ], [2, 4] ) + INTEGER, PARAMETER :: imatrix_prod = PRODUCT (imatrix) + INTEGER, PARAMETER :: imatrix_prod_d1(4) = PRODUCT (imatrix, dim=1) + INTEGER, PARAMETER :: imatrix_prod_d2(2) = PRODUCT (imatrix, dim=2) + LOGICAL, PARAMETER :: i_equal_prod = ALL ([PRODUCT( imatrix_prod_d1 ) == PRODUCT ( imatrix_prod_d2 ), & + PRODUCT( imatrix_prod_d1 ) == imatrix_prod]) + LOGICAL, PARAMETER :: i_empty_prod = PRODUCT(imatrix, mask=.FALSE.) == 1 + + REAL, PARAMETER :: rmatrix(2,4) = RESHAPE ([ 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0, 8.0 ], [2, 4] ) + REAL, PARAMETER :: rmatrix_prod = PRODUCT (rmatrix) + REAL, PARAMETER :: rmatrix_prod_d1(4) = PRODUCT (rmatrix, dim=1) + REAL, PARAMETER :: rmatrix_prod_d2(2) = PRODUCT (rmatrix, dim=2) + LOGICAL, PARAMETER :: r_equal_prod = ALL ([PRODUCT( rmatrix_prod_d1 ) == PRODUCT ( rmatrix_prod_d2 ), & + PRODUCT( rmatrix_prod_d1 ) == rmatrix_prod]) + LOGICAL, PARAMETER :: r_empty_prod = PRODUCT(rmatrix, mask=.FALSE.) == 1.0 + + IF (.NOT. ALL ([i_equal_prod, i_empty_prod])) CALL abort() + IF (.NOT. ALL ([r_equal_prod, r_empty_prod])) CALL abort() + + CALL ilib (imatrix, imatrix_prod) + CALL ilib_with_dim (imatrix, 1, imatrix_prod_d1) + CALL ilib_with_dim (imatrix, 2, imatrix_prod_d2) + CALL rlib (rmatrix, rmatrix_prod) + CALL rlib_with_dim (rmatrix, 1, rmatrix_prod_d1) + CALL rlib_with_dim (rmatrix, 2, rmatrix_prod_d2) + +CONTAINS + SUBROUTINE ilib (array, result) + INTEGER, DIMENSION(:,:), INTENT(in) :: array + INTEGER, INTENT(in) :: result + IF (PRODUCT(array) /= result) CALL abort() + END SUBROUTINE + + SUBROUTINE ilib_with_dim (array, dim, result) + INTEGER, DIMENSION(:,:), INTENT(in) :: array + INTEGER, INTENT(iN) :: dim + INTEGER, DIMENSION(:), INTENT(in) :: result + IF (ANY (PRODUCT (array, dim=dim) /= result)) CALL abort() + END SUBROUTINE + + SUBROUTINE rlib (array, result) + REAL, DIMENSION(:,:), INTENT(in) :: array + REAL, INTENT(in) :: result + IF (ABS(PRODUCT(array) - result) > 2e-6) CALL abort() + END SUBROUTINE + + SUBROUTINE rlib_with_dim (array, dim, result) + REAL, DIMENSION(:,:), INTENT(in) :: array + INTEGER, INTENT(iN) :: dim + REAL, DIMENSION(:), INTENT(in) :: result + IF (ANY (ABS(PRODUCT (array, dim=dim) - result) > 2e-6)) CALL abort() + END SUBROUTINE +END + + diff --git a/gcc/testsuite/gfortran.dg/sum_init_expr.f03 b/gcc/testsuite/gfortran.dg/sum_init_expr.f03 new file mode 100644 index 000000000000..fc9701ce86d3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/sum_init_expr.f03 @@ -0,0 +1,66 @@ +! { dg-do "run" } +! { dg-options "-fno-inline" } +! +! SUM as initialization expression. +! +! This test compares results of simplifier of SUM +! with the corresponding inlined or library routine(s). +! + + IMPLICIT NONE + + INTEGER, PARAMETER :: imatrix(2,4) = RESHAPE ([ 1, 2, 3, 4, 5, 6, 7, 8 ], [2, 4] ) + INTEGER, PARAMETER :: imatrix_sum = SUM (imatrix) + INTEGER, PARAMETER :: imatrix_sum_d1(4) = SUM (imatrix, dim=1) + INTEGER, PARAMETER :: imatrix_sum_d2(2) = SUM (imatrix, dim=2) + LOGICAL, PARAMETER :: i_equal_sum = ALL ([SUM( imatrix_sum_d1 ) == SUM ( imatrix_sum_d2 ), & + SUM( imatrix_sum_d1 ) == imatrix_sum]) + LOGICAL, PARAMETER :: i_empty_sum = SUM(imatrix, mask=.FALSE.) == 0 + + REAL, PARAMETER :: rmatrix(2,4) = RESHAPE ([ 1.1, 2.2, 3.3, 4.4, 5.5, 6.6, 7.7, 8.8 ], [2, 4] ) + REAL, PARAMETER :: rmatrix_sum = SUM (rmatrix) + REAL, PARAMETER :: rmatrix_sum_d1(4) = SUM (rmatrix, dim=1) + REAL, PARAMETER :: rmatrix_sum_d2(2) = SUM (rmatrix, dim=2) + LOGICAL, PARAMETER :: r_equal_sum = ALL ([SUM( rmatrix_sum_d1 ) == SUM ( rmatrix_sum_d2 ), & + SUM( rmatrix_sum_d1 ) == rmatrix_sum]) + LOGICAL, PARAMETER :: r_empty_sum = SUM(rmatrix, mask=.FALSE.) == 0.0 + + IF (.NOT. ALL ([i_equal_sum, i_empty_sum])) CALL abort() + IF (.NOT. ALL ([r_equal_sum, r_empty_sum])) CALL abort() + + CALL ilib (imatrix, imatrix_sum) + CALL ilib_with_dim (imatrix, 1, imatrix_sum_d1) + CALL ilib_with_dim (imatrix, 2, imatrix_sum_d2) + CALL rlib (rmatrix, rmatrix_sum) + CALL rlib_with_dim (rmatrix, 1, rmatrix_sum_d1) + CALL rlib_with_dim (rmatrix, 2, rmatrix_sum_d2) + +CONTAINS + SUBROUTINE ilib (array, result) + INTEGER, DIMENSION(:,:), INTENT(in) :: array + INTEGER, INTENT(in) :: result + IF (SUM(array) /= result) CALL abort() + END SUBROUTINE + + SUBROUTINE ilib_with_dim (array, dim, result) + INTEGER, DIMENSION(:,:), INTENT(in) :: array + INTEGER, INTENT(iN) :: dim + INTEGER, DIMENSION(:), INTENT(in) :: result + IF (ANY (SUM (array, dim=dim) /= result)) CALL abort() + END SUBROUTINE + + SUBROUTINE rlib (array, result) + REAL, DIMENSION(:,:), INTENT(in) :: array + REAL, INTENT(in) :: result + IF (ABS(SUM(array) - result) > 2e-6) CALL abort() + END SUBROUTINE + + SUBROUTINE rlib_with_dim (array, dim, result) + REAL, DIMENSION(:,:), INTENT(in) :: array + INTEGER, INTENT(iN) :: dim + REAL, DIMENSION(:), INTENT(in) :: result + IF (ANY (ABS(SUM (array, dim=dim) - result) > 2e-6)) CALL abort() + END SUBROUTINE +END + + -- 2.43.5