mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-06 02:10:29 +08:00
Code Issues Packages Projects Releases Wiki Activity

re PR fortran/25104 ([F2003] Non-initialization expr. as case-selector)

Browse Source 
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>

        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
This commit is contained in:
Daniel Franke 2009-06-07 12:35:06 -04:00 committed by Tobias Burnus
parent ca8a87956a
commit a16d978fca
10 changed files with 549 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
gcc/fortran/ChangeLog
View File

@ -1,3 +1,27 @@
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.

5
gcc/fortran/check.c
View File

@ -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 "

6
gcc/fortran/expr.c
View File

@ -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;

10
gcc/fortran/intrinsic.c
View File

@ -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);

5
gcc/fortran/intrinsic.h
View File

@ -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 *);

352
gcc/fortran/simplify.c
View File

@ -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)
{

8
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,11 @@
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

15
gcc/testsuite/gfortran.dg/count_init_expr.f03 Normal file
View File

@ -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

66
gcc/testsuite/gfortran.dg/product_init_expr.f03 Normal file
View File

@ -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

66
gcc/testsuite/gfortran.dg/sum_init_expr.f03 Normal file
View File

@ -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