From 96e85c1658892428fdec368ca7e6b971e00ba831 Mon Sep 17 00:00:00 2001 From: Yuao Ma Date: Wed, 21 May 2025 00:24:51 +0800 Subject: [PATCH] fortran: add constant input support for trig functions with half-revolutions This patch introduces constant input support for trigonometric functions, including those involving half-revolutions. Both valid and invalid inputs have been thoroughly tested, as have mpfr versions greater than or equal to 4.2 and less than 4.2. Inspired by Steve's previous work, this patch also fixes subtle bugs revealed by newly added test cases. If this patch is merged, I plan to work on middle-end optimization support for previously added GCC built-ins and libgfortran intrinsics. gcc/fortran/ChangeLog: * gfortran.h (enum gfc_isym_id): Add new enum. * intrinsic.cc (add_functions): Register new intrinsics. * intrinsic.h (gfc_simplify_acospi): New. (gfc_simplify_asinpi): New. (gfc_simplify_atanpi): New. (gfc_simplify_atan2pi): New. (gfc_simplify_cospi): New. (gfc_simplify_sinpi): New. (gfc_simplify_tanpi): New. (gfc_resolve_trigd): Rename. (gfc_resolve_trigd2): Rename. (gfc_resolve_trig): Rename. (gfc_resolve_trig2): Rename. * iresolve.cc (gfc_resolve_trigd): Rename. (gfc_resolve_trig): Rename. (gfc_resolve_trigd2): Rename. (gfc_resolve_trig2): Rename. * simplify.cc (gfc_simplify_acospi): New. (gfc_simplify_asinpi): New. (gfc_simplify_atanpi): New. (gfc_simplify_atan2pi): New. (gfc_simplify_cospi): New. (gfc_simplify_sinpi): New. (gfc_simplify_tanpi): New. gcc/testsuite/ChangeLog: * gfortran.dg/dec_math_3.f90: Test invalid input. * gfortran.dg/dec_math_5.f90: Test valid output. Signed-off-by: Yuao Ma Co-authored-by: Steven G. Kargl --- gcc/fortran/gfortran.h | 7 + gcc/fortran/intrinsic.cc | 184 +++++++++-------- gcc/fortran/intrinsic.h | 11 +- gcc/fortran/iresolve.cc | 8 +- gcc/fortran/simplify.cc | 240 +++++++++++++++++++++++ gcc/testsuite/gfortran.dg/dec_math_3.f90 | 15 +- gcc/testsuite/gfortran.dg/dec_math_5.f90 | 63 ++++++ 7 files changed, 441 insertions(+), 87 deletions(-) diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 4740c3676d9..b8a545bf150 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -716,6 +716,13 @@ enum gfc_isym_id GFC_ISYM_Y1, GFC_ISYM_YN, GFC_ISYM_YN2, + GFC_ISYM_ACOSPI, + GFC_ISYM_ASINPI, + GFC_ISYM_ATANPI, + GFC_ISYM_ATAN2PI, + GFC_ISYM_COSPI, + GFC_ISYM_SINPI, + GFC_ISYM_TANPI, /* Add this at the end, so maybe the module format remains compatible. */ diff --git a/gcc/fortran/intrinsic.cc b/gcc/fortran/intrinsic.cc index 908e1dae128..942d23dfef8 100644 --- a/gcc/fortran/intrinsic.cc +++ b/gcc/fortran/intrinsic.cc @@ -3450,131 +3450,110 @@ add_functions (void) is not. So, update GFC_STD_GNU to GFC_STD_F2023 for the generic functions. */ - add_sym_1 ("acosd", GFC_ISYM_ACOSD, CLASS_ELEMENTAL, ACTUAL_YES, - BT_REAL, dr, GFC_STD_F2023, - gfc_check_fn_r, gfc_simplify_acosd, gfc_resolve_trigd, - x, BT_REAL, dr, REQUIRED); + add_sym_1 ("acosd", GFC_ISYM_ACOSD, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, + GFC_STD_F2023, gfc_check_fn_r, gfc_simplify_acosd, + gfc_resolve_trig, x, BT_REAL, dr, REQUIRED); make_generic ("acosd", GFC_ISYM_ACOSD, GFC_STD_F2023); - add_sym_1 ("dacosd", GFC_ISYM_ACOSD, CLASS_ELEMENTAL, ACTUAL_YES, - BT_REAL, dd, GFC_STD_GNU, - gfc_check_fn_d, gfc_simplify_acosd, gfc_resolve_trigd, + add_sym_1 ("dacosd", GFC_ISYM_ACOSD, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, + GFC_STD_GNU, gfc_check_fn_d, gfc_simplify_acosd, gfc_resolve_trig, x, BT_REAL, dd, REQUIRED); - add_sym_1 ("asind", GFC_ISYM_ASIND, CLASS_ELEMENTAL, ACTUAL_YES, - BT_REAL, dr, GFC_STD_F2023, - gfc_check_fn_r, gfc_simplify_asind, gfc_resolve_trigd, - x, BT_REAL, dr, REQUIRED); + add_sym_1 ("asind", GFC_ISYM_ASIND, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, + GFC_STD_F2023, gfc_check_fn_r, gfc_simplify_asind, + gfc_resolve_trig, x, BT_REAL, dr, REQUIRED); make_generic ("asind", GFC_ISYM_ASIND, GFC_STD_F2023); - add_sym_1 ("dasind", GFC_ISYM_ASIND, CLASS_ELEMENTAL, ACTUAL_YES, - BT_REAL, dd, GFC_STD_GNU, - gfc_check_fn_d, gfc_simplify_asind, gfc_resolve_trigd, + add_sym_1 ("dasind", GFC_ISYM_ASIND, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, + GFC_STD_GNU, gfc_check_fn_d, gfc_simplify_asind, gfc_resolve_trig, x, BT_REAL, dd, REQUIRED); - add_sym_1 ("atand", GFC_ISYM_ATAND, CLASS_ELEMENTAL, ACTUAL_YES, - BT_REAL, dr, GFC_STD_F2023, - gfc_check_fn_r, gfc_simplify_atand, gfc_resolve_trigd, - x, BT_REAL, dr, REQUIRED); + add_sym_1 ("atand", GFC_ISYM_ATAND, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, + GFC_STD_F2023, gfc_check_fn_r, gfc_simplify_atand, + gfc_resolve_trig, x, BT_REAL, dr, REQUIRED); /* Two-argument version of atand, equivalent to atan2d. */ - add_sym_2 ("atand", GFC_ISYM_ATAN2D, CLASS_ELEMENTAL, ACTUAL_YES, - BT_REAL, dr, GFC_STD_F2023, - gfc_check_atan2, gfc_simplify_atan2d, gfc_resolve_trigd2, - y, BT_REAL, dr, REQUIRED, - x, BT_REAL, dr, REQUIRED); + add_sym_2 ("atand", GFC_ISYM_ATAN2D, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, + GFC_STD_F2023, gfc_check_atan2, gfc_simplify_atan2d, + gfc_resolve_trig2, y, BT_REAL, dr, REQUIRED, x, BT_REAL, dr, + REQUIRED); make_generic ("atand", GFC_ISYM_ATAND, GFC_STD_F2023); - add_sym_1 ("datand", GFC_ISYM_ATAND, CLASS_ELEMENTAL, ACTUAL_YES, - BT_REAL, dd, GFC_STD_GNU, - gfc_check_fn_d, gfc_simplify_atand, gfc_resolve_trigd, + add_sym_1 ("datand", GFC_ISYM_ATAND, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, + GFC_STD_GNU, gfc_check_fn_d, gfc_simplify_atand, gfc_resolve_trig, x, BT_REAL, dd, REQUIRED); - add_sym_2 ("atan2d", GFC_ISYM_ATAN2D, CLASS_ELEMENTAL, ACTUAL_YES, - BT_REAL, dr, GFC_STD_F2023, - gfc_check_atan2, gfc_simplify_atan2d, gfc_resolve_trigd2, - y, BT_REAL, dr, REQUIRED, - x, BT_REAL, dr, REQUIRED); + add_sym_2 ("atan2d", GFC_ISYM_ATAN2D, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, + dr, GFC_STD_F2023, gfc_check_atan2, gfc_simplify_atan2d, + gfc_resolve_trig2, y, BT_REAL, dr, REQUIRED, x, BT_REAL, dr, + REQUIRED); make_generic ("atan2d", GFC_ISYM_ATAN2D, GFC_STD_F2023); - add_sym_2 ("datan2d", GFC_ISYM_ATAN2D, CLASS_ELEMENTAL, ACTUAL_YES, - BT_REAL, dd, GFC_STD_GNU, - gfc_check_datan2, gfc_simplify_atan2d, gfc_resolve_trigd2, - y, BT_REAL, dd, REQUIRED, - x, BT_REAL, dd, REQUIRED); + add_sym_2 ("datan2d", GFC_ISYM_ATAN2D, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, + dd, GFC_STD_GNU, gfc_check_datan2, gfc_simplify_atan2d, + gfc_resolve_trig2, y, BT_REAL, dd, REQUIRED, x, BT_REAL, dd, + REQUIRED); - add_sym_1 ("cosd", GFC_ISYM_COSD, CLASS_ELEMENTAL, ACTUAL_YES, - BT_REAL, dr, GFC_STD_F2023, - gfc_check_fn_r, gfc_simplify_cosd, gfc_resolve_trigd, + add_sym_1 ("cosd", GFC_ISYM_COSD, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, + GFC_STD_F2023, gfc_check_fn_r, gfc_simplify_cosd, gfc_resolve_trig, x, BT_REAL, dr, REQUIRED); make_generic ("cosd", GFC_ISYM_COSD, GFC_STD_F2023); - add_sym_1 ("dcosd", GFC_ISYM_COSD, CLASS_ELEMENTAL, ACTUAL_YES, - BT_REAL, dd, GFC_STD_GNU, - gfc_check_fn_d, gfc_simplify_cosd, gfc_resolve_trigd, + add_sym_1 ("dcosd", GFC_ISYM_COSD, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, + GFC_STD_GNU, gfc_check_fn_d, gfc_simplify_cosd, gfc_resolve_trig, x, BT_REAL, dd, REQUIRED); - add_sym_1 ("cotan", GFC_ISYM_COTAN, CLASS_ELEMENTAL, ACTUAL_YES, - BT_REAL, dr, GFC_STD_GNU, - gfc_check_fn_rc2008, gfc_simplify_cotan, gfc_resolve_trigd, - x, BT_REAL, dr, REQUIRED); + add_sym_1 ("cotan", GFC_ISYM_COTAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, + GFC_STD_GNU, gfc_check_fn_rc2008, gfc_simplify_cotan, + gfc_resolve_trig, x, BT_REAL, dr, REQUIRED); - add_sym_1 ("dcotan", GFC_ISYM_COTAN, CLASS_ELEMENTAL, ACTUAL_YES, - BT_REAL, dd, GFC_STD_GNU, - gfc_check_fn_d, gfc_simplify_cotan, gfc_resolve_trigd, + add_sym_1 ("dcotan", GFC_ISYM_COTAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, + GFC_STD_GNU, gfc_check_fn_d, gfc_simplify_cotan, gfc_resolve_trig, x, BT_REAL, dd, REQUIRED); - add_sym_1 ("ccotan", GFC_ISYM_COTAN, CLASS_ELEMENTAL, ACTUAL_YES, - BT_COMPLEX, dz, GFC_STD_GNU, - NULL, gfc_simplify_cotan, gfc_resolve_trigd, - x, BT_COMPLEX, dz, REQUIRED); + add_sym_1 ("ccotan", GFC_ISYM_COTAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, + dz, GFC_STD_GNU, NULL, gfc_simplify_cotan, gfc_resolve_trig, x, + BT_COMPLEX, dz, REQUIRED); - add_sym_1 ("zcotan", GFC_ISYM_COTAN, CLASS_ELEMENTAL, ACTUAL_YES, - BT_COMPLEX, dd, GFC_STD_GNU, - NULL, gfc_simplify_cotan, gfc_resolve_trigd, - x, BT_COMPLEX, dd, REQUIRED); + add_sym_1 ("zcotan", GFC_ISYM_COTAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, + dd, GFC_STD_GNU, NULL, gfc_simplify_cotan, gfc_resolve_trig, x, + BT_COMPLEX, dd, REQUIRED); make_generic ("cotan", GFC_ISYM_COTAN, GFC_STD_GNU); - add_sym_1 ("cotand", GFC_ISYM_COTAND, CLASS_ELEMENTAL, ACTUAL_YES, - BT_REAL, dr, GFC_STD_GNU, - gfc_check_fn_r, gfc_simplify_cotand, gfc_resolve_trigd, - x, BT_REAL, dr, REQUIRED); + add_sym_1 ("cotand", GFC_ISYM_COTAND, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, + dr, GFC_STD_GNU, gfc_check_fn_r, gfc_simplify_cotand, + gfc_resolve_trig, x, BT_REAL, dr, REQUIRED); - add_sym_1 ("dcotand", GFC_ISYM_COTAND, CLASS_ELEMENTAL, ACTUAL_YES, - BT_REAL, dd, GFC_STD_GNU, - gfc_check_fn_d, gfc_simplify_cotand, gfc_resolve_trigd, - x, BT_REAL, dd, REQUIRED); + add_sym_1 ("dcotand", GFC_ISYM_COTAND, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, + dd, GFC_STD_GNU, gfc_check_fn_d, gfc_simplify_cotand, + gfc_resolve_trig, x, BT_REAL, dd, REQUIRED); make_generic ("cotand", GFC_ISYM_COTAND, GFC_STD_GNU); - add_sym_1 ("sind", GFC_ISYM_SIND, CLASS_ELEMENTAL, ACTUAL_YES, - BT_REAL, dr, GFC_STD_F2023, - gfc_check_fn_r, gfc_simplify_sind, gfc_resolve_trigd, + add_sym_1 ("sind", GFC_ISYM_SIND, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, + GFC_STD_F2023, gfc_check_fn_r, gfc_simplify_sind, gfc_resolve_trig, x, BT_REAL, dr, REQUIRED); make_generic ("sind", GFC_ISYM_SIND, GFC_STD_F2023); - add_sym_1 ("dsind", GFC_ISYM_SIND, CLASS_ELEMENTAL, ACTUAL_YES, - BT_REAL, dd, GFC_STD_GNU, - gfc_check_fn_d, gfc_simplify_sind, gfc_resolve_trigd, + add_sym_1 ("dsind", GFC_ISYM_SIND, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, + GFC_STD_GNU, gfc_check_fn_d, gfc_simplify_sind, gfc_resolve_trig, x, BT_REAL, dd, REQUIRED); - add_sym_1 ("tand", GFC_ISYM_TAND, CLASS_ELEMENTAL, ACTUAL_YES, - BT_REAL, dr, GFC_STD_F2023, - gfc_check_fn_r, gfc_simplify_tand, gfc_resolve_trigd, + add_sym_1 ("tand", GFC_ISYM_TAND, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, + GFC_STD_F2023, gfc_check_fn_r, gfc_simplify_tand, gfc_resolve_trig, x, BT_REAL, dr, REQUIRED); make_generic ("tand", GFC_ISYM_TAND, GFC_STD_F2023); - add_sym_1 ("dtand", GFC_ISYM_TAND, CLASS_ELEMENTAL, ACTUAL_YES, - BT_REAL, dd, GFC_STD_GNU, - gfc_check_fn_d, gfc_simplify_tand, gfc_resolve_trigd, + add_sym_1 ("dtand", GFC_ISYM_TAND, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, + GFC_STD_GNU, gfc_check_fn_d, gfc_simplify_tand, gfc_resolve_trig, x, BT_REAL, dd, REQUIRED); /* The following function is internally used for coarray libray functions. @@ -3590,6 +3569,57 @@ add_functions (void) REQUIRED, val, BT_INTEGER, di, REQUIRED, i, BT_INTEGER, di, REQUIRED); make_from_module (); + + /* The half-cycle trigonometric functions were added by Fortran 2023. */ + + add_sym_1 ("acospi", GFC_ISYM_ACOSPI, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, + GFC_STD_F2023, gfc_check_fn_r, gfc_simplify_acospi, + gfc_resolve_trig, x, BT_REAL, dr, REQUIRED); + + make_generic ("acospi", GFC_ISYM_ACOSPI, GFC_STD_F2023); + + add_sym_1 ("asinpi", GFC_ISYM_ASINPI, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, + GFC_STD_F2023, gfc_check_fn_r, gfc_simplify_asinpi, + gfc_resolve_trig, x, BT_REAL, dr, REQUIRED); + + make_generic ("asinpi", GFC_ISYM_ASINPI, GFC_STD_F2023); + + add_sym_1 ("atanpi", GFC_ISYM_ATANPI, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, + GFC_STD_F2023, gfc_check_fn_r, gfc_simplify_atanpi, + gfc_resolve_trig, x, BT_REAL, dr, REQUIRED); + + /* Two-argument version of atanpi, equivalent to atan2pi. */ + add_sym_2 ("atanpi", GFC_ISYM_ATAN2PI, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, + dr, GFC_STD_F2023, gfc_check_atan2, gfc_simplify_atan2pi, + gfc_resolve_trig2, y, BT_REAL, dr, REQUIRED, x, BT_REAL, dr, + REQUIRED); + + make_generic ("atanpi", GFC_ISYM_ATANPI, GFC_STD_F2023); + + add_sym_2 ("atan2pi", GFC_ISYM_ATAN2PI, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, + dr, GFC_STD_F2023, gfc_check_atan2, gfc_simplify_atan2pi, + gfc_resolve_trig2, y, BT_REAL, dr, REQUIRED, x, BT_REAL, dr, + REQUIRED); + + make_generic ("atan2pi", GFC_ISYM_ATAN2PI, GFC_STD_F2023); + + add_sym_1 ("cospi", GFC_ISYM_COSPI, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, + GFC_STD_F2023, gfc_check_fn_r, gfc_simplify_cospi, + gfc_resolve_trig, x, BT_REAL, dr, REQUIRED); + + make_generic ("cospi", GFC_ISYM_COSPI, GFC_STD_F2023); + + add_sym_1 ("sinpi", GFC_ISYM_SINPI, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, + GFC_STD_F2023, gfc_check_fn_r, gfc_simplify_sinpi, + gfc_resolve_trig, x, BT_REAL, dr, REQUIRED); + + make_generic ("sinpi", GFC_ISYM_SINPI, GFC_STD_F2023); + + add_sym_1 ("tanpi", GFC_ISYM_TANPI, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, + GFC_STD_F2023, gfc_check_fn_r, gfc_simplify_tanpi, + gfc_resolve_trig, x, BT_REAL, dr, REQUIRED); + + make_generic ("tanpi", GFC_ISYM_TANPI, GFC_STD_F2023); } diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index 767792ceb23..fd54588054f 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -246,6 +246,7 @@ gfc_expr *gfc_simplify_achar (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_acos (gfc_expr *); gfc_expr *gfc_simplify_acosd (gfc_expr *); gfc_expr *gfc_simplify_acosh (gfc_expr *); +gfc_expr *gfc_simplify_acospi (gfc_expr *); gfc_expr *gfc_simplify_adjustl (gfc_expr *); gfc_expr *gfc_simplify_adjustr (gfc_expr *); gfc_expr *gfc_simplify_aimag (gfc_expr *); @@ -259,11 +260,14 @@ 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_asinpi (gfc_expr *); gfc_expr *gfc_simplify_atan (gfc_expr *); gfc_expr *gfc_simplify_atand (gfc_expr *); gfc_expr *gfc_simplify_atanh (gfc_expr *); +gfc_expr *gfc_simplify_atanpi (gfc_expr *); gfc_expr *gfc_simplify_atan2 (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_atan2d (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_atan2pi (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_bessel_j0 (gfc_expr *); gfc_expr *gfc_simplify_bessel_j1 (gfc_expr *); gfc_expr *gfc_simplify_bessel_jn (gfc_expr *, gfc_expr *); @@ -288,6 +292,7 @@ gfc_expr *gfc_simplify_conjg (gfc_expr *); gfc_expr *gfc_simplify_cos (gfc_expr *); gfc_expr *gfc_simplify_cosd (gfc_expr *); gfc_expr *gfc_simplify_cosh (gfc_expr *); +gfc_expr *gfc_simplify_cospi (gfc_expr *); gfc_expr *gfc_simplify_cotan (gfc_expr *); gfc_expr *gfc_simplify_cotand (gfc_expr *); gfc_expr *gfc_simplify_count (gfc_expr *, gfc_expr *, gfc_expr *); @@ -421,6 +426,7 @@ gfc_expr *gfc_simplify_shiftr (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_sin (gfc_expr *); gfc_expr *gfc_simplify_sind (gfc_expr *); gfc_expr *gfc_simplify_sinh (gfc_expr *); +gfc_expr *gfc_simplify_sinpi (gfc_expr *); gfc_expr *gfc_simplify_size (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_sizeof (gfc_expr *); gfc_expr *gfc_simplify_storage_size (gfc_expr *, gfc_expr *); @@ -432,6 +438,7 @@ gfc_expr *gfc_simplify_sum (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_tan (gfc_expr *); gfc_expr *gfc_simplify_tand (gfc_expr *); gfc_expr *gfc_simplify_tanh (gfc_expr *); +gfc_expr *gfc_simplify_tanpi (gfc_expr *); gfc_expr *gfc_simplify_this_image (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_tiny (gfc_expr *); gfc_expr *gfc_simplify_trailz (gfc_expr *); @@ -631,8 +638,8 @@ void gfc_resolve_time (gfc_expr *); void gfc_resolve_time8 (gfc_expr *); void gfc_resolve_transfer (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_transpose (gfc_expr *, gfc_expr *); -void gfc_resolve_trigd (gfc_expr *, gfc_expr *); -void gfc_resolve_trigd2 (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_trig (gfc_expr *, gfc_expr *); +void gfc_resolve_trig2 (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_trim (gfc_expr *, gfc_expr *); void gfc_resolve_ttynam (gfc_expr *, gfc_expr *); void gfc_resolve_ubound (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); diff --git a/gcc/fortran/iresolve.cc b/gcc/fortran/iresolve.cc index 6930e2c3622..10013096c70 100644 --- a/gcc/fortran/iresolve.cc +++ b/gcc/fortran/iresolve.cc @@ -3435,13 +3435,12 @@ gfc_resolve_trim (gfc_expr *f, gfc_expr *string) f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind); } - -/* Resolve the degree trigonometric functions. This amounts to setting +/* Resolve the trigonometric functions. This amounts to setting the function return type-spec from its argument and building a library function names of the form _gfortran_sind_r4. */ void -gfc_resolve_trigd (gfc_expr *f, gfc_expr *x) +gfc_resolve_trig (gfc_expr *f, gfc_expr *x) { f->ts = x->ts; f->value.function.name @@ -3450,9 +3449,8 @@ gfc_resolve_trigd (gfc_expr *f, gfc_expr *x) gfc_type_abi_kind (&x->ts)); } - void -gfc_resolve_trigd2 (gfc_expr *f, gfc_expr *y, gfc_expr *x) +gfc_resolve_trig2 (gfc_expr *f, gfc_expr *y, gfc_expr *x) { f->ts = y->ts; f->value.function.name diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc index 1927097c190..f0e671b7076 100644 --- a/gcc/fortran/simplify.cc +++ b/gcc/fortran/simplify.cc @@ -2151,6 +2151,246 @@ gfc_simplify_cosh (gfc_expr *x) return range_check (result, "COSH"); } +gfc_expr * +gfc_simplify_acospi (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + if (mpfr_cmp_si (x->value.real, 1) > 0 || mpfr_cmp_si (x->value.real, -1) < 0) + { + gfc_error ("Argument of ACOSPI at %L must be between -1 and 1", + &x->where); + return &gfc_bad_expr; + } + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + +#if MPFR_VERSION >= MPFR_VERSION_NUM(4, 2, 0) + mpfr_acospi (result->value.real, x->value.real, GFC_RND_MODE); +#else + mpfr_t pi, tmp; + mpfr_inits2 (2 * mpfr_get_prec (x->value.real), pi, tmp, NULL); + mpfr_const_pi (pi, GFC_RND_MODE); + mpfr_acos (tmp, x->value.real, GFC_RND_MODE); + mpfr_div (result->value.real, tmp, pi, GFC_RND_MODE); + mpfr_clears (pi, tmp, NULL); +#endif + + return range_check (result, "ACOSPI"); +} + +gfc_expr * +gfc_simplify_asinpi (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + if (mpfr_cmp_si (x->value.real, 1) > 0 || mpfr_cmp_si (x->value.real, -1) < 0) + { + gfc_error ("Argument of ASINPI at %L must be between -1 and 1", + &x->where); + return &gfc_bad_expr; + } + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + +#if MPFR_VERSION >= MPFR_VERSION_NUM(4, 2, 0) + mpfr_asinpi (result->value.real, x->value.real, GFC_RND_MODE); +#else + mpfr_t pi, tmp; + mpfr_inits2 (2 * mpfr_get_prec (x->value.real), pi, tmp, NULL); + mpfr_const_pi (pi, GFC_RND_MODE); + mpfr_asin (tmp, x->value.real, GFC_RND_MODE); + mpfr_div (result->value.real, tmp, pi, GFC_RND_MODE); + mpfr_clears (pi, tmp, NULL); +#endif + + return range_check (result, "ASINPI"); +} + +gfc_expr * +gfc_simplify_atanpi (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + +#if MPFR_VERSION >= MPFR_VERSION_NUM(4, 2, 0) + mpfr_atanpi (result->value.real, x->value.real, GFC_RND_MODE); +#else + mpfr_t pi, tmp; + mpfr_inits2 (2 * mpfr_get_prec (x->value.real), pi, tmp, NULL); + mpfr_const_pi (pi, GFC_RND_MODE); + mpfr_atan (tmp, x->value.real, GFC_RND_MODE); + mpfr_div (result->value.real, tmp, pi, GFC_RND_MODE); + mpfr_clears (pi, tmp, NULL); +#endif + + return range_check (result, "ATANPI"); +} + +gfc_expr * +gfc_simplify_atan2pi (gfc_expr *y, gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) + return NULL; + + if (mpfr_zero_p (y->value.real) && mpfr_zero_p (x->value.real)) + { + gfc_error ("If first argument of ATAN2PI at %L is zero, then the " + "second argument must not be zero", + &y->where); + return &gfc_bad_expr; + } + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + +#if MPFR_VERSION >= MPFR_VERSION_NUM(4, 2, 0) + mpfr_atan2pi (result->value.real, y->value.real, x->value.real, GFC_RND_MODE); +#else + mpfr_t pi, tmp; + mpfr_inits2 (2 * mpfr_get_prec (x->value.real), pi, tmp, NULL); + mpfr_const_pi (pi, GFC_RND_MODE); + mpfr_atan2 (tmp, y->value.real, x->value.real, GFC_RND_MODE); + mpfr_div (result->value.real, tmp, pi, GFC_RND_MODE); + mpfr_clears (pi, tmp, NULL); +#endif + + return range_check (result, "ATAN2PI"); +} + +gfc_expr * +gfc_simplify_cospi (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + +#if MPFR_VERSION >= MPFR_VERSION_NUM(4, 2, 0) + mpfr_cospi (result->value.real, x->value.real, GFC_RND_MODE); +#else + mpfr_t cs, n, r; + int s; + + mpfr_inits2 (2 * mpfr_get_prec (x->value.real), cs, n, r, NULL); + + mpfr_abs (r, x->value.real, GFC_RND_MODE); + mpfr_modf (n, r, r, GFC_RND_MODE); + + if (mpfr_cmp_d (r, 0.5) == 0) + { + mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); + return result; + } + + mpfr_fmod_ui (cs, n, 2, GFC_RND_MODE); + s = mpfr_cmp_ui (cs, 0) == 0 ? 1 : -1; + + mpfr_const_pi (cs, GFC_RND_MODE); + mpfr_mul (cs, cs, r, GFC_RND_MODE); + mpfr_cos (cs, cs, GFC_RND_MODE); + mpfr_mul_si (result->value.real, cs, s, GFC_RND_MODE); + + mpfr_clears (cs, n, r, NULL); +#endif + + return range_check (result, "COSPI"); +} + +gfc_expr * +gfc_simplify_sinpi (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + +#if MPFR_VERSION >= MPFR_VERSION_NUM(4, 2, 0) + mpfr_sinpi (result->value.real, x->value.real, GFC_RND_MODE); +#else + mpfr_t sn, n, r; + int s; + + mpfr_inits2 (2 * mpfr_get_prec (x->value.real), sn, n, r, NULL); + + mpfr_abs (r, x->value.real, GFC_RND_MODE); + mpfr_modf (n, r, r, GFC_RND_MODE); + + if (mpfr_cmp_d (r, 0.0) == 0) + { + mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); + return result; + } + + mpfr_fmod_ui (sn, n, 2, GFC_RND_MODE); + s = mpfr_cmp_si (x->value.real, 0) < 0 ? -1 : 1; + s *= mpfr_cmp_ui (sn, 0) == 0 ? 1 : -1; + + mpfr_const_pi (sn, GFC_RND_MODE); + mpfr_mul (sn, sn, r, GFC_RND_MODE); + mpfr_sin (sn, sn, GFC_RND_MODE); + mpfr_mul_si (result->value.real, sn, s, GFC_RND_MODE); + + mpfr_clears (sn, n, r, NULL); +#endif + + return range_check (result, "SINPI"); +} + +gfc_expr * +gfc_simplify_tanpi (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + +#if MPFR_VERSION >= MPFR_VERSION_NUM(4, 2, 0) + mpfr_tanpi (result->value.real, x->value.real, GFC_RND_MODE); +#else + mpfr_t tn, n, r; + int s; + + mpfr_inits2 (2 * mpfr_get_prec (x->value.real), tn, n, r, NULL); + + mpfr_abs (r, x->value.real, GFC_RND_MODE); + mpfr_modf (n, r, r, GFC_RND_MODE); + + if (mpfr_cmp_d (r, 0.0) == 0) + { + mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); + return result; + } + + s = mpfr_cmp_si (x->value.real, 0) < 0 ? -1 : 1; + + mpfr_const_pi (tn, GFC_RND_MODE); + mpfr_mul (tn, tn, r, GFC_RND_MODE); + mpfr_tan (tn, tn, GFC_RND_MODE); + mpfr_mul_si (result->value.real, tn, s, GFC_RND_MODE); + + mpfr_clears (tn, n, r, NULL); +#endif + + return range_check (result, "TANPI"); +} gfc_expr * gfc_simplify_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind) diff --git a/gcc/testsuite/gfortran.dg/dec_math_3.f90 b/gcc/testsuite/gfortran.dg/dec_math_3.f90 index 5bf4398d0f2..ee5df0a50e3 100644 --- a/gcc/testsuite/gfortran.dg/dec_math_3.f90 +++ b/gcc/testsuite/gfortran.dg/dec_math_3.f90 @@ -1,8 +1,17 @@ ! { dg-options "-std=gnu" } ! { dg-do compile } -! Former ICE when simplifying asind, plus wrong function name in error message -real, parameter :: d = asind(1.1) ! { dg-error "Argument of ASIND at.*must be between -1 and 1" } -print *, d +real, parameter :: dacos = acosd(1.1) ! { dg-error "Argument of ACOSD at" } +print *, dacos +real, parameter :: dasin = asind(-1.1) ! { dg-error "Argument of ASIND at" } +print *, dasin +real, parameter :: datan2 = atan2d(0.0, 0.0) ! { dg-error "If first argument of ATAN2D at" } +print *, datan2 +real, parameter :: piacos = acospi(-1.1) ! { dg-error "Argument of ACOSPI at" } +print *, piacos +real, parameter :: piasin = asinpi(1.1) ! { dg-error "Argument of ASINPI at" } +print *, piasin +real, parameter :: piatan2 = atan2pi(0.0, 0.0) ! { dg-error "If first argument of ATAN2PI at" } +print *, piatan2 end diff --git a/gcc/testsuite/gfortran.dg/dec_math_5.f90 b/gcc/testsuite/gfortran.dg/dec_math_5.f90 index dee2de4e06b..a7ff3275236 100644 --- a/gcc/testsuite/gfortran.dg/dec_math_5.f90 +++ b/gcc/testsuite/gfortran.dg/dec_math_5.f90 @@ -101,4 +101,67 @@ program p if (abs(b1 - 0.5) > e2) stop 38 if (abs(c1 - 0.5) > e3) stop 39 if (abs(d1 - 0.5) > e4) stop 40 + + a1 = acospi(0.5) + b1 = acospi(-0.5) + c1 = acospi(0.5) + d1 = acospi(-0.5) + if (abs(a1 - 1.0 / 3) > e1) stop 41 + if (abs(b1 - 2.0 / 3) > e2) stop 42 + if (abs(c1 - 1.0 / 3) > e3) stop 43 + if (abs(d1 - 2.0 / 3) > e4) stop 44 + + a1 = asinpi(0.5) + b1 = asinpi(-0.5) + c1 = asinpi(0.5) + d1 = asinpi(-0.5) + if (abs(a1 - 1.0 / 6) > e1) stop 45 + if (abs(b1 + 1.0 / 6) > e2) stop 46 + if (abs(c1 - 1.0 / 6) > e3) stop 47 + if (abs(d1 + 1.0 / 6) > e4) stop 48 + + a1 = atanpi(1.0) + b1 = atanpi(-1.0) + c1 = atanpi(1.0) + d1 = atanpi(-1.0) + if (abs(a1 - 0.25) > e1) stop 49 + if (abs(b1 + 0.25) > e2) stop 50 + if (abs(c1 - 0.25) > e3) stop 51 + if (abs(d1 + 0.25) > e4) stop 52 + + a1 = atan2pi(1.0, 1.0) + b1 = atan2pi(1.0, 1.0) + c1 = atan2pi(1.0, 1.0) + d1 = atan2pi(1.0, 1.0) + if (abs(a1 - 0.25) > e1) stop 53 + if (abs(b1 - 0.25) > e2) stop 54 + if (abs(c1 - 0.25) > e3) stop 55 + if (abs(d1 - 0.25) > e4) stop 56 + + a1 = cospi(1._4 / 3) + b1 = cospi(-1._8 / 3) + c1 = cospi(4._ep / 3) + d1 = cospi(-4._16 / 3) + if (abs(a1 - 0.5) > e1) stop 57 + if (abs(b1 - 0.5) > e2) stop 58 + if (abs(c1 + 0.5) > e3) stop 59 + if (abs(d1 + 0.5) > e4) stop 60 + + a1 = sinpi(1._4 / 6) + b1 = sinpi(-1._8 / 6) + c1 = sinpi(5._ep / 6) + d1 = sinpi(-7._16 / 6) + if (abs(a1 - 0.5) > e1) stop 61 + if (abs(b1 + 0.5) > e2) stop 62 + if (abs(c1 - 0.5) > e3) stop 63 + if (abs(d1 - 0.5) > e4) stop 64 + + a1 = tanpi(0.25) + b1 = tanpi(-0.25) + c1 = tanpi(1.25) + d1 = tanpi(-1.25) + if (abs(a1 - 1.0) > e1) stop 65 + if (abs(b1 + 1.0) > e2) stop 66 + if (abs(c1 - 1.0) > e3) stop 67 + if (abs(d1 + 1.0) > e4) stop 68 end program p -- 2.43.0