+2009-06-07 Daniel Franke <franke.daniel@gmail.com>
+
+ 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 <franke.daniel@gmail.com>
* check.c (dim_rank_check): Return SUCCESS if DIM=NULL.
if (dim_check (dim, 1, false) == FAILURE)
return FAILURE;
+ if (dim_rank_check (dim, mask, 0) == FAILURE)
+ return FAILURE;
+
return SUCCESS;
}
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 "
};
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;
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);
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);
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);
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);
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);
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 *);
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 *);
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 *);
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 *);
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 *
}
+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)
{
}
+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)
{
}
+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)
{
}
+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)
{
}
+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)
{
+2009-06-07 Daniel Franke <franke.daniel@gmail.com>
+
+ 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 <franke.daniel@gmail.com>
PR fortran/36874
--- /dev/null
+! { 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
--- /dev/null
+! { 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
+
+
--- /dev/null
+! { 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
+
+
projects / gcc.git / commitdiff