Skip to content

R
riscv-gcc-1
Commit a16d978f by Daniel Franke Committed by Tobias Burnus
Options

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

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
parent ca8a8795
Showing with 549 additions and 8 deletions
gcc/fortran/ChangeLog
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.
(gfc_check_lbound): Removed (now) redundant check for DIM=NULL.
(gfc_check_minloc_maxloc): Likewise.
......
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 "
......
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;
......
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);
......
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 *);
......
gcc/testsuite/ChangeLog
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
* gfortran.dg/intrinsic_argument_conformance_2.f90: Adjusted error message.
* gfortran.dg/zero_sized_1.f90: Removed checks with incompatible shapes.
......
gcc/testsuite/gfortran.dg/count_init_expr.f03 0 → 100644
! { 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
gcc/testsuite/gfortran.dg/product_init_expr.f03 0 → 100644
! { 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
gcc/testsuite/gfortran.dg/sum_init_expr.f03 0 → 100644
! { 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
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment