Caveat 1: Patch is against svn 280157.
Caveat 2: I am no longer subscribed to fortran@. Hit reply-all if you
want to communicate with me.
Caveat 3: I don't do git. This is likely my last patch for GCC.
TL;DR version.
Fix the simplification and handling of the degree trigonometric functions.
This includes fixing a number of ICEs. See PR 93871.
ChangeLog and patch attached.
Long version.
This patch fixes a number of issues with the degree trigonometric functions.
1. The option -fdec-math is a now a NOP. I left the option intact, because
someone may have it in a Makefile or build script. This option sets
the variable flag_dec_math, which is no longer used. The DEC functions
SIND, COSD, TAND, ASIND, ACOSD, ATAND, ATAN2D, COTAN, and COTAND
are now part of the nonstandard intrinsics provided under -std=gnu.
2. The previous special handling of these functions has been removed.
All functions are now handled just like any other intrinsic function
(except for a few special cases with IEEE_ARITHMETIC).
3. Simplification routines do the following mappings:
sind(x) = sin((pi/180) * x) asind(x) = (180/pi) * asin(x)
cosd(x) = cos((pi/180) * x) acosd(x) = (180/pi) * acos(x)
tand(x) = tan((pi/180) * x) atand(x) = (180/pi) * atan(x)
atan2d(y,x) = (180/pi) * atan2(y,x)
cotand(x) = cotan((pi/180) * x)
All computations are carried out by MPFR or MPC.
4. For asind, acosd, atand, atan2d, cotan, and cotand are in-lined.
For example,
function foo(x)
real foo, x
foo = asind(x)
end function foo
produces
foo (real(kind=4) & restrict x)
{
real(kind=4) __result_foo;
__result_foo = __builtin_asinf (*x) * 5.72957763671875e+1;
return __result_foo;
}
At the moment, cotand(x) is transformed into -tan((pi/180)*x + pi/2).
No attempted of doing a range-reduction step (see below) has been done.
For cotan(x) the argument can be real or complex. If x is real, the
function is transformed as cotan(x) = -tan(x + pi/2). If x is complex,
gfortran will produce cotan(x) = cos(x)/sin(x) where cos and sin map
to __builtin_ccos and __builtin_csin, respectively.
5. New functions have been added to libgfortran to handle sind, cosd,
and tand.
For x = +-inf or nan, these functions return nan.
For small x,
sind(x) = sin((pi/180) * x) = (pi/180) * x
tand(x) = tan((pi/180) * x) = (pi/180) * x
cosd(x) = 1 - tiny (where tiny is volatile and should cause INEXACT).
For normal x, a few steps are performed. First, x is replaced by
fmod(x,360) such that the result is now in [0,360]. The functions
are cyclic afterall. Second, [0,360] is folded into the range [0,45]
and the choice of computing sin((pi/180)*x) or cos((pi/180)*x) is then
made. This is required to achieve a small ULP near the zeros of the
functions. A final step uses an FMA where (pi/180) is split into high
and low parts.
--
steve
--
Steve
Fortran Frontend Changes:
* gfortran.h: Add GFC_ISYM_ACOSD, GFC_ISYM_ASIND, GFC_ISYM_ATAN2D,
GFC_ISYM_ATAND, GFC_ISYM_COSD, GFC_ISYM_COTAND, GFC_ISYM_SIND, and
GFC_ISYM_TAND.
* intrinsic.c (add_functions): Remove check for flag_dec_math.
Give degree trig functions simplification and name resolution
functions (e.g., gfc_simplify_atrigd () and gfc_resolve_atrigd ()).
(do_simplify): Remove special casing of degree trig functions.
* intrinsic.h (gfc_simplify_acosd, gfc_simplify_asind,
gfc_simplify_atand, gfc_simplify_cosd, gfc_simplify_cotand,
gfc_simplify_sind, gfc_simplify_tand, gfc_resolve_trigd2): Add new
prototypes.
(gfc_simplify_atrigd, gfc_simplify_trigd, gfc_resolve_cotan,
resolve_atrigd): Remove prototypes of deleted functions.
* iresolve.c (is_trig_resolved, copy_replace_function_shallow,
gfc_resolve_cotan, get_radians, get_degrees, resolve_trig_call,
gfc_resolve_atrigd, gfc_resolve_atan2d): Delete
functions.
(gfc_resolve_trigd, gfc_resolve_trigd2): Set typ-spec and resolve
funciton names.
* simplify.c (rad2deg): Rename degrees_f ().
* simplify.c (rad2deg, gfc_simplify_acosd, gfc_simplify_asind,
gfc_simplify_atand, gfc_simplify_atan2d, gfc_simplify_cosd,
gfc_simplify_sind, gfc_simplify_tand, gfc_simplify_cotand): New
function.
(gfc_simplify_atan2): Fix error message.
(simplify_trig_call, gfc_simplify_trigd, gfc_simplify_atrigd,
radians_f): Delete function.
* trans-intrinsic.c: Add LIB_FUNCTION () for sind, cosd, tand.
(rad2deg, gfc_conv_intrinsic_atrigd, gfc_conv_intrinsic_cotan,
gfc_conv_intrinsic_cotand, gfc_conv_intrinsic_atan2d):
New function
Libgfortran Changes:
* Makefile.am: Add intrinsics/trigd.c to build.
* Makefile.in: Regenerated via --enable-maintainer-mode.
* gfortran.map: Add symbols to shared library symbol map.
* intrinsics/trigd.c: Implementations for sind (), cosd() and tand ().
* intrinsics/trigd_inc.c: Internals for trigd.c.
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 280157)
+++ gcc/fortran/gfortran.h (working copy)
@@ -357,6 +357,7 @@ enum gfc_isym_id
GFC_ISYM_ACCESS,
GFC_ISYM_ACHAR,
GFC_ISYM_ACOS,
+ GFC_ISYM_ACOSD,
GFC_ISYM_ACOSH,
GFC_ISYM_ADJUSTL,
GFC_ISYM_ADJUSTR,
@@ -369,10 +370,13 @@ enum gfc_isym_id
GFC_ISYM_ANINT,
GFC_ISYM_ANY,
GFC_ISYM_ASIN,
+ GFC_ISYM_ASIND,
GFC_ISYM_ASINH,
GFC_ISYM_ASSOCIATED,
GFC_ISYM_ATAN,
GFC_ISYM_ATAN2,
+ GFC_ISYM_ATAN2D,
+ GFC_ISYM_ATAND,
GFC_ISYM_ATANH,
GFC_ISYM_ATOMIC_ADD,
GFC_ISYM_ATOMIC_AND,
@@ -410,8 +414,10 @@ enum gfc_isym_id
GFC_ISYM_CONJG,
GFC_ISYM_CONVERSION,
GFC_ISYM_COS,
+ GFC_ISYM_COSD,
GFC_ISYM_COSH,
GFC_ISYM_COTAN,
+ GFC_ISYM_COTAND,
GFC_ISYM_COUNT,
GFC_ISYM_CPU_TIME,
GFC_ISYM_CSHIFT,
@@ -598,6 +604,7 @@ enum gfc_isym_id
GFC_ISYM_SIGNAL,
GFC_ISYM_SI_KIND,
GFC_ISYM_SIN,
+ GFC_ISYM_SIND,
GFC_ISYM_SINH,
GFC_ISYM_SIZE,
GFC_ISYM_SLEEP,
@@ -618,6 +625,7 @@ enum gfc_isym_id
GFC_ISYM_SYSTEM,
GFC_ISYM_SYSTEM_CLOCK,
GFC_ISYM_TAN,
+ GFC_ISYM_TAND,
GFC_ISYM_TANH,
GFC_ISYM_TEAM_NUMBER,
GFC_ISYM_THIS_IMAGE,
Index: gcc/fortran/intrinsic.c
===================================================================
--- gcc/fortran/intrinsic.c (revision 280157)
+++ gcc/fortran/intrinsic.c (working copy)
@@ -3281,117 +3281,121 @@ add_functions (void)
make_generic ("loc", GFC_ISYM_LOC, GFC_STD_GNU);
- if (flag_dec_math)
- {
- add_sym_1 ("acosd", GFC_ISYM_ACOS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL,
- dr, GFC_STD_GNU,
- gfc_check_fn_r, gfc_simplify_atrigd, gfc_resolve_atrigd,
- x, BT_REAL, dr, REQUIRED);
- add_sym_1 ("dacosd", GFC_ISYM_ACOS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL,
- dd, GFC_STD_GNU,
- gfc_check_fn_d, gfc_simplify_atrigd, gfc_resolve_atrigd,
- x, BT_REAL, dd, REQUIRED);
+ /* The next of intrinsic subprogram are the degree trignometric functions.
+ These were hidden behind the -fdec-math option, but are now simply
+ included as extensions to the set of intrinsic subprograms. */
- make_generic ("acosd", GFC_ISYM_ACOS, GFC_STD_GNU);
+ add_sym_1 ("acosd", GFC_ISYM_ACOSD, CLASS_ELEMENTAL, ACTUAL_YES,
+ BT_REAL, dr, GFC_STD_GNU,
+ gfc_check_fn_r, gfc_simplify_acosd, gfc_resolve_trigd,
+ x, BT_REAL, dr, REQUIRED);
- add_sym_1 ("asind", GFC_ISYM_ASIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL,
- dr, GFC_STD_GNU,
- gfc_check_fn_r, gfc_simplify_atrigd, gfc_resolve_atrigd,
- x, BT_REAL, dr, REQUIRED);
+ 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,
+ x, BT_REAL, dd, REQUIRED);
- add_sym_1 ("dasind", GFC_ISYM_ASIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL,
- dd, GFC_STD_GNU,
- gfc_check_fn_d, gfc_simplify_atrigd, gfc_resolve_atrigd,
- x, BT_REAL, dd, REQUIRED);
+ make_generic ("acosd", GFC_ISYM_ACOSD, GFC_STD_GNU);
- make_generic ("asind", GFC_ISYM_ASIN, GFC_STD_GNU);
+ add_sym_1 ("asind", GFC_ISYM_ASIND, CLASS_ELEMENTAL, ACTUAL_YES,
+ BT_REAL, dr, GFC_STD_GNU,
+ gfc_check_fn_r, gfc_simplify_asind, gfc_resolve_trigd,
+ x, BT_REAL, dr, REQUIRED);
- add_sym_1 ("atand", GFC_ISYM_ATAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL,
- dr, GFC_STD_GNU,
- gfc_check_fn_r, gfc_simplify_atrigd, gfc_resolve_atrigd,
- x, BT_REAL, dr, REQUIRED);
+ 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,
+ x, BT_REAL, dd, REQUIRED);
- add_sym_1 ("datand", GFC_ISYM_ATAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL,
- dd, GFC_STD_GNU,
- gfc_check_fn_d, gfc_simplify_atrigd, gfc_resolve_atrigd,
- x, BT_REAL, dd, REQUIRED);
+ make_generic ("asind", GFC_ISYM_ASIND, GFC_STD_GNU);
- make_generic ("atand", GFC_ISYM_ATAN, GFC_STD_GNU);
+ add_sym_1 ("atand", GFC_ISYM_ATAND, CLASS_ELEMENTAL, ACTUAL_YES,
+ BT_REAL, dr, GFC_STD_GNU,
+ gfc_check_fn_r, gfc_simplify_atand, gfc_resolve_trigd,
+ x, BT_REAL, dr, REQUIRED);
- add_sym_2 ("atan2d",GFC_ISYM_ATAN2,CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL,
- dr, GFC_STD_GNU,
- gfc_check_atan2, gfc_simplify_atan2d, gfc_resolve_atan2d,
- y, BT_REAL, dr, REQUIRED, x, BT_REAL, dr, REQUIRED);
+ 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,
+ x, BT_REAL, dd, REQUIRED);
- add_sym_2 ("datan2d",GFC_ISYM_ATAN2,CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL,
- dd, GFC_STD_GNU,
- gfc_check_datan2, gfc_simplify_atan2d, gfc_resolve_atan2d,
- y, BT_REAL, dd, REQUIRED, x, BT_REAL, dd, REQUIRED);
+ make_generic ("atand", GFC_ISYM_ATAND, GFC_STD_GNU);
- make_generic ("atan2d", GFC_ISYM_ATAN2, GFC_STD_GNU);
+ add_sym_2 ("atan2d", GFC_ISYM_ATAN2D, CLASS_ELEMENTAL, ACTUAL_YES,
+ BT_REAL, dr, GFC_STD_GNU,
+ gfc_check_atan2, gfc_simplify_atan2d, gfc_resolve_trigd2,
+ y, BT_REAL, dr, REQUIRED,
+ x, BT_REAL, dr, REQUIRED);
- add_sym_1 ("cosd", GFC_ISYM_COS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL,
- dr, GFC_STD_GNU,
- gfc_check_fn_r, gfc_simplify_trigd, gfc_resolve_trigd,
- x, BT_REAL, dr, 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_trigd2,
+ y, BT_REAL, dd, REQUIRED,
+ x, BT_REAL, dd, REQUIRED);
- add_sym_1 ("dcosd", GFC_ISYM_COS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL,
- dd, GFC_STD_GNU,
- gfc_check_fn_d, gfc_simplify_trigd, gfc_resolve_trigd,
- x, BT_REAL, dd, REQUIRED);
+ make_generic ("atan2d", GFC_ISYM_ATAN2D, GFC_STD_GNU);
- make_generic ("cosd", GFC_ISYM_COS, GFC_STD_GNU);
+ add_sym_1 ("cosd", GFC_ISYM_COSD, CLASS_ELEMENTAL, ACTUAL_YES,
+ BT_REAL, dr, GFC_STD_GNU,
+ gfc_check_fn_r, gfc_simplify_cosd, 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_cotan,
- x, BT_REAL, dr, REQUIRED);
+ 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,
+ x, BT_REAL, dd, 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_cotan,
- x, BT_REAL, dd, REQUIRED);
+ make_generic ("cosd", GFC_ISYM_COSD, GFC_STD_GNU);
- make_generic ("cotan", GFC_ISYM_COTAN, GFC_STD_GNU);
+ 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 ("cotand", GFC_ISYM_COTAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL,
- dr, GFC_STD_GNU,
- gfc_check_fn_r, gfc_simplify_trigd, gfc_resolve_trigd,
- 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,
+ x, BT_REAL, dd, REQUIRED);
- add_sym_1 ("dcotand",GFC_ISYM_COTAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL,
- dd, GFC_STD_GNU,
- gfc_check_fn_d, gfc_simplify_trigd, gfc_resolve_trigd,
- x, BT_REAL, dd, REQUIRED);
+ make_generic ("cotan", GFC_ISYM_COTAN, GFC_STD_GNU);
- make_generic ("cotand", 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 ("sind", GFC_ISYM_SIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL,
- dr, GFC_STD_GNU,
- gfc_check_fn_r, gfc_simplify_trigd, gfc_resolve_trigd,
- 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 ("dsind", GFC_ISYM_SIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL,
- dd, GFC_STD_GNU,
- gfc_check_fn_d, gfc_simplify_trigd, gfc_resolve_trigd,
- x, BT_REAL, dd, REQUIRED);
+ make_generic ("cotand", GFC_ISYM_COTAND, GFC_STD_GNU);
- make_generic ("sind", GFC_ISYM_SIN, GFC_STD_GNU);
+ add_sym_1 ("sind", GFC_ISYM_SIND, CLASS_ELEMENTAL, ACTUAL_YES,
+ BT_REAL, dr, GFC_STD_GNU,
+ gfc_check_fn_r, gfc_simplify_sind, gfc_resolve_trigd,
+ x, BT_REAL, dr, REQUIRED);
- add_sym_1 ("tand", GFC_ISYM_TAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL,
- dr, GFC_STD_GNU,
- gfc_check_fn_r, gfc_simplify_trigd, gfc_resolve_trigd,
- x, BT_REAL, dr, REQUIRED);
+ 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,
+ x, BT_REAL, dd, REQUIRED);
- add_sym_1 ("dtand", GFC_ISYM_TAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL,
- dd, GFC_STD_GNU,
- gfc_check_fn_d, gfc_simplify_trigd, gfc_resolve_trigd,
- x, BT_REAL, dd, REQUIRED);
+ make_generic ("sind", GFC_ISYM_SIND, GFC_STD_GNU);
- make_generic ("tand", GFC_ISYM_TAN, GFC_STD_GNU);
- }
+ add_sym_1 ("tand", GFC_ISYM_TAND, CLASS_ELEMENTAL, ACTUAL_YES,
+ BT_REAL, dr, GFC_STD_GNU,
+ gfc_check_fn_r, gfc_simplify_tand, gfc_resolve_trigd,
+ x, BT_REAL, dr, REQUIRED);
+ 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,
+ x, BT_REAL, dd, REQUIRED);
+
+ make_generic ("tand", GFC_ISYM_TAND, GFC_STD_GNU);
+
/* The following function is internally used for coarray libray functions.
"make_from_module" makes it inaccessible for external users. */
add_sym_1 (GFC_PREFIX ("caf_get"), GFC_ISYM_CAF_GET, CLASS_IMPURE, ACTUAL_NO,
@@ -4563,15 +4567,6 @@ do_simplify (gfc_intrinsic_sym *specific, gfc_expr *e)
if (specific->simplify.f1 == gfc_simplify_max)
{
result = gfc_simplify_max (e);
- goto finish;
- }
-
- /* Some math intrinsics need to wrap the original expression. */
- if (specific->simplify.f1 == gfc_simplify_trigd
- || specific->simplify.f1 == gfc_simplify_atrigd
- || specific->simplify.f1 == gfc_simplify_cotan)
- {
- result = (*specific->simplify.f1) (e);
goto finish;
}
Index: gcc/fortran/intrinsic.h
===================================================================
--- gcc/fortran/intrinsic.h (revision 280157)
+++ gcc/fortran/intrinsic.h (working copy)
@@ -237,13 +237,14 @@ bool gfc_check_unlink_sub (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_abs (gfc_expr *);
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_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_atrigd (gfc_expr *);
+gfc_expr *gfc_simplify_asind (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 *);
@@ -252,6 +253,7 @@ 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_atand (gfc_expr *);
gfc_expr *gfc_simplify_atanh (gfc_expr *);
gfc_expr *gfc_simplify_atan2 (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_atan2d (gfc_expr *, gfc_expr *);
@@ -277,8 +279,10 @@ gfc_expr *gfc_simplify_compiler_version (void);
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_cosd (gfc_expr *);
gfc_expr *gfc_simplify_cosh (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 *);
gfc_expr *gfc_simplify_cshift (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_dcmplx (gfc_expr *, gfc_expr *);
@@ -404,6 +408,7 @@ gfc_expr *gfc_simplify_shifta (gfc_expr *, gfc_expr *)
gfc_expr *gfc_simplify_shiftl (gfc_expr *, gfc_expr *);
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_size (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_sizeof (gfc_expr *);
@@ -414,13 +419,13 @@ gfc_expr *gfc_simplify_spread (gfc_expr *, 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_tand (gfc_expr *);
gfc_expr *gfc_simplify_tanh (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 *);
gfc_expr *gfc_simplify_transfer (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_transpose (gfc_expr *);
-gfc_expr *gfc_simplify_trigd (gfc_expr *);
gfc_expr *gfc_simplify_trim (gfc_expr *);
gfc_expr *gfc_simplify_ubound (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_ucobound (gfc_expr *, gfc_expr *, gfc_expr *);
@@ -473,7 +478,6 @@ void gfc_resolve_conjg (gfc_expr *, gfc_expr *);
void gfc_resolve_cos (gfc_expr *, gfc_expr *);
void gfc_resolve_cosh (gfc_expr *, gfc_expr *);
void gfc_resolve_count (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
-void gfc_resolve_cotan (gfc_expr *, gfc_expr *);
void gfc_resolve_cshift (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_ctime (gfc_expr *, gfc_expr *);
void gfc_resolve_dble (gfc_expr *, gfc_expr *);
@@ -612,7 +616,7 @@ 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_atrigd (gfc_expr *, gfc_expr *);
+void gfc_resolve_trigd2 (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 *);
Index: gcc/fortran/iresolve.c
===================================================================
--- gcc/fortran/iresolve.c (revision 280157)
+++ gcc/fortran/iresolve.c (working copy)
@@ -686,87 +686,7 @@ gfc_resolve_cosh (gfc_expr *f, gfc_expr *x)
}
-/* Our replacement of elements of a trig call with an EXPR_OP (e.g.
- multiplying the result or operands by a factor to convert to/from degrees)
- will cause the resolve_* function to be invoked again when resolving the
- freshly created EXPR_OP. See gfc_resolve_trigd, gfc_resolve_atrigd,
- gfc_resolve_cotan. We must observe this and avoid recursively creating
- layers of nested EXPR_OP expressions. */
-
-static bool
-is_trig_resolved (gfc_expr *f)
-{
- /* We know we've already resolved the function if we see the lib call
- starting with '__'. */
- return (f->value.function.name != NULL
- && gfc_str_startswith (f->value.function.name, "__"));
-}
-
-/* Return a shallow copy of the function expression f. The original expression
- has its pointers cleared so that it may be freed without affecting the
- shallow copy. This is similar to gfc_copy_expr, but doesn't perform a deep
- copy of the argument list, allowing it to be reused somewhere else,
- setting the expression up nicely for gfc_replace_expr. */
-
-static gfc_expr *
-copy_replace_function_shallow (gfc_expr *f)
-{
- gfc_expr *fcopy;
- gfc_actual_arglist *args;
-
- /* The only thing deep-copied in gfc_copy_expr is args. */
- args = f->value.function.actual;
- f->value.function.actual = NULL;
- fcopy = gfc_copy_expr (f);
- fcopy->value.function.actual = args;
-
- /* Clear the old function so the shallow copy is not affected if the old
- expression is freed. */
- f->value.function.name = NULL;
- f->value.function.isym = NULL;
- f->value.function.actual = NULL;
- f->value.function.esym = NULL;
- f->shape = NULL;
- f->ref = NULL;
-
- return fcopy;
-}
-
-
-/* Resolve cotan = cos / sin. */
-
void
-gfc_resolve_cotan (gfc_expr *f, gfc_expr *x)
-{
- gfc_expr *result, *fcopy, *sin;
- gfc_actual_arglist *sin_args;
-
- if (is_trig_resolved (f))
- return;
-
- /* Compute cotan (x) = cos (x) / sin (x). */
- f->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_COS);
- gfc_resolve_cos (f, x);
-
- sin_args = gfc_get_actual_arglist ();
- sin_args->expr = gfc_copy_expr (x);
-
- sin = gfc_get_expr ();
- sin->ts = f->ts;
- sin->where = f->where;
- sin->expr_type = EXPR_FUNCTION;
- sin->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_SIN);
- sin->value.function.actual = sin_args;
- gfc_resolve_sin (sin, sin_args->expr);
-
- /* Replace f with cos/sin - we do this in place in f for the caller. */
- fcopy = copy_replace_function_shallow (f);
- result = gfc_divide (fcopy, sin);
- gfc_replace_expr (f, result);
-}
-
-
-void
gfc_resolve_count (gfc_expr *f, gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
{
f->ts.type = BT_INTEGER;
@@ -2909,158 +2829,6 @@ gfc_resolve_tanh (gfc_expr *f, gfc_expr *x)
}
-/* Build an expression for converting degrees to radians. */
-
-static gfc_expr *
-get_radians (gfc_expr *deg)
-{
- gfc_expr *result, *factor;
- gfc_actual_arglist *mod_args;
-
- gcc_assert (deg->ts.type == BT_REAL);
-
- /* Set deg = deg % 360 to avoid offsets from large angles. */
- factor = gfc_get_constant_expr (deg->ts.type, deg->ts.kind, °->where);
- mpfr_set_d (factor->value.real, 360.0, GFC_RND_MODE);
-
- mod_args = gfc_get_actual_arglist ();
- mod_args->expr = deg;
- mod_args->next = gfc_get_actual_arglist ();
- mod_args->next->expr = factor;
-
- result = gfc_get_expr ();
- result->ts = deg->ts;
- result->where = deg->where;
- result->expr_type = EXPR_FUNCTION;
- result->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_MOD);
- result->value.function.actual = mod_args;
-
- /* Set factor = pi / 180. */
- factor = gfc_get_constant_expr (deg->ts.type, deg->ts.kind, °->where);
- mpfr_const_pi (factor->value.real, GFC_RND_MODE);
- mpfr_div_ui (factor->value.real, factor->value.real, 180, GFC_RND_MODE);
-
- /* Result is rad = (deg % 360) * (pi / 180). */
- result = gfc_multiply (result, factor);
- return result;
-}
-
-
-/* Build an expression for converting radians to degrees. */
-
-static gfc_expr *
-get_degrees (gfc_expr *rad)
-{
- gfc_expr *result, *factor;
- gfc_actual_arglist *mod_args;
- mpfr_t tmp;
-
- gcc_assert (rad->ts.type == BT_REAL);
-
- /* Set rad = rad % 2pi to avoid offsets from large angles. */
- factor = gfc_get_constant_expr (rad->ts.type, rad->ts.kind, &rad->where);
- mpfr_const_pi (factor->value.real, GFC_RND_MODE);
- mpfr_mul_ui (factor->value.real, factor->value.real, 2, GFC_RND_MODE);
-
- mod_args = gfc_get_actual_arglist ();
- mod_args->expr = rad;
- mod_args->next = gfc_get_actual_arglist ();
- mod_args->next->expr = factor;
-
- result = gfc_get_expr ();
- result->ts = rad->ts;
- result->where = rad->where;
- result->expr_type = EXPR_FUNCTION;
- result->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_MOD);
- result->value.function.actual = mod_args;
-
- /* Set factor = 180 / pi. */
- factor = gfc_get_constant_expr (rad->ts.type, rad->ts.kind, &rad->where);
- mpfr_set_ui (factor->value.real, 180, GFC_RND_MODE);
- mpfr_init (tmp);
- mpfr_const_pi (tmp, GFC_RND_MODE);
- mpfr_div (factor->value.real, factor->value.real, tmp, GFC_RND_MODE);
- mpfr_clear (tmp);
-
- /* Result is deg = (rad % 2pi) * (180 / pi). */
- result = gfc_multiply (result, factor);
- return result;
-}
-
-
-/* Resolve a call to a trig function. */
-
-static void
-resolve_trig_call (gfc_expr *f, gfc_expr *x)
-{
- switch (f->value.function.isym->id)
- {
- case GFC_ISYM_ACOS:
- return gfc_resolve_acos (f, x);
- case GFC_ISYM_ASIN:
- return gfc_resolve_asin (f, x);
- case GFC_ISYM_ATAN:
- return gfc_resolve_atan (f, x);
- case GFC_ISYM_ATAN2:
- /* NB. arg3 is unused for atan2 */
- return gfc_resolve_atan2 (f, x, NULL);
- case GFC_ISYM_COS:
- return gfc_resolve_cos (f, x);
- case GFC_ISYM_COTAN:
- return gfc_resolve_cotan (f, x);
- case GFC_ISYM_SIN:
- return gfc_resolve_sin (f, x);
- case GFC_ISYM_TAN:
- return gfc_resolve_tan (f, x);
- default:
- gcc_unreachable ();
- }
-}
-
-/* Resolve degree trig function as trigd (x) = trig (radians (x)). */
-
-void
-gfc_resolve_trigd (gfc_expr *f, gfc_expr *x)
-{
- if (is_trig_resolved (f))
- return;
-
- x = get_radians (x);
- f->value.function.actual->expr = x;
-
- resolve_trig_call (f, x);
-}
-
-
-/* Resolve degree inverse trig function as atrigd (x) = degrees (atrig (x)). */
-
-void
-gfc_resolve_atrigd (gfc_expr *f, gfc_expr *x)
-{
- gfc_expr *result, *fcopy;
-
- if (is_trig_resolved (f))
- return;
-
- resolve_trig_call (f, x);
-
- fcopy = copy_replace_function_shallow (f);
- result = get_degrees (fcopy);
- gfc_replace_expr (f, result);
-}
-
-
-/* Resolve atan2d(x) = degrees(atan2(x)). */
-
-void
-gfc_resolve_atan2d (gfc_expr *f, gfc_expr *x, gfc_expr *y ATTRIBUTE_UNUSED)
-{
- /* Note that we lose the second arg here - that's okay because it is
- unused in gfc_resolve_atan2 anyway. */
- gfc_resolve_atrigd (f, x);
-}
-
-
/* Resolve failed_images (team, kind). */
void
@@ -3280,7 +3048,7 @@ gfc_resolve_transpose (gfc_expr *f, gfc_expr *matrix)
default:
f->value.function.name = (matrix->ts.type == BT_CHARACTER
? PREFIX ("transpose_char")
- : PREFIX ("transpose"));
+ : "transpose");
break;
}
}
@@ -3292,6 +3060,30 @@ gfc_resolve_trim (gfc_expr *f, gfc_expr *string)
f->ts.type = BT_CHARACTER;
f->ts.kind = string->ts.kind;
f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
+}
+
+
+/* Resolve the degree trignometric 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)
+{
+ f->ts = x->ts;
+ f->value.function.name
+ = gfc_get_string (PREFIX ("%s_%c%d"), f->value.function.isym->name,
+ gfc_type_letter (x->ts.type), x->ts.kind);
+}
+
+
+void
+gfc_resolve_trigd2 (gfc_expr *f, gfc_expr *y, gfc_expr *x)
+{
+ f->ts = y->ts;
+ f->value.function.name
+ = gfc_get_string (PREFIX ("%s_%d"), f->value.function.isym->name,
+ x->ts.kind);
}
Index: gcc/fortran/simplify.c
===================================================================
--- gcc/fortran/simplify.c (revision 280157)
+++ gcc/fortran/simplify.c (working copy)
@@ -1107,7 +1107,92 @@ gfc_simplify_asin (gfc_expr *x)
}
+/* Convert radians to degrees, i.e., x * 180 / pi. */
+
+static void
+rad2deg (mpfr_t x)
+{
+ mpfr_t tmp;
+
+ mpfr_init (tmp);
+ mpfr_const_pi (tmp, GFC_RND_MODE);
+ mpfr_mul_ui (x, x, 180, GFC_RND_MODE);
+ mpfr_div (x, x, tmp, GFC_RND_MODE);
+ mpfr_clear (tmp);
+}
+
+
+/* Simplify ACOSD(X) where the returned value has units of degree. */
+
gfc_expr *
+gfc_simplify_acosd (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 ACOSD 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);
+ mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE);
+ rad2deg (result->value.real);
+
+ return range_check (result, "ACOSD");
+}
+
+
+/* Simplify asind (x) where the returned value has units of degree. */
+
+gfc_expr *
+gfc_simplify_asind (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 ASIND 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);
+ mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE);
+ rad2deg (result->value.real);
+
+ return range_check (result, "ASIND");
+}
+
+
+/* Simplify atand (x) where the returned value has units of degree. */
+
+gfc_expr *
+gfc_simplify_atand (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);
+ mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE);
+ rad2deg (result->value.real);
+
+ return range_check (result, "ATAND");
+}
+
+
+gfc_expr *
gfc_simplify_asinh (gfc_expr *x)
{
gfc_expr *result;
@@ -1208,8 +1293,8 @@ gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x)
if (mpfr_zero_p (y->value.real) && mpfr_zero_p (x->value.real))
{
- gfc_error ("If first argument of ATAN2 %L is zero, then the "
- "second argument must not be zero", &x->where);
+ gfc_error ("If first argument of ATAN2 at %L is zero, then the "
+ "second argument must not be zero", &y->where);
return &gfc_bad_expr;
}
@@ -1736,177 +1821,127 @@ gfc_simplify_conjg (gfc_expr *e)
return range_check (result, "CONJG");
}
-/* Return the simplification of the constant expression in icall, or NULL
- if the expression is not constant. */
-static gfc_expr *
-simplify_trig_call (gfc_expr *icall)
+/* Simplify atan2d (x) where the unit is degree. */
+
+gfc_expr *
+gfc_simplify_atan2d (gfc_expr *y, gfc_expr *x)
{
- gfc_isym_id func = icall->value.function.isym->id;
- gfc_expr *x = icall->value.function.actual->expr;
+ gfc_expr *result;
- /* The actual simplifiers will return NULL for non-constant x. */
- switch (func)
+ 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))
{
- case GFC_ISYM_ACOS:
- return gfc_simplify_acos (x);
- case GFC_ISYM_ASIN:
- return gfc_simplify_asin (x);
- case GFC_ISYM_ATAN:
- return gfc_simplify_atan (x);
- case GFC_ISYM_COS:
- return gfc_simplify_cos (x);
- case GFC_ISYM_COTAN:
- return gfc_simplify_cotan (x);
- case GFC_ISYM_SIN:
- return gfc_simplify_sin (x);
- case GFC_ISYM_TAN:
- return gfc_simplify_tan (x);
- default:
- gfc_internal_error ("in simplify_trig_call(): Bad intrinsic");
+ gfc_error ("If first argument of ATAN2D at %L is zero, then the "
+ "second argument must not be zero", &y->where);
+ return &gfc_bad_expr;
}
-}
-/* Convert a floating-point number from radians to degrees. */
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+ mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE);
+ rad2deg (result->value.real);
-static void
-degrees_f (mpfr_t x, mpfr_rnd_t rnd_mode)
-{
- mpfr_t tmp;
- mpfr_init (tmp);
-
- /* Set x = x % 2pi to avoid offsets with large angles. */
- mpfr_const_pi (tmp, rnd_mode);
- mpfr_mul_ui (tmp, tmp, 2, rnd_mode);
- mpfr_fmod (tmp, x, tmp, rnd_mode);
-
- /* Set x = x * 180. */
- mpfr_mul_ui (x, x, 180, rnd_mode);
-
- /* Set x = x / pi. */
- mpfr_const_pi (tmp, rnd_mode);
- mpfr_div (x, x, tmp, rnd_mode);
-
- mpfr_clear (tmp);
+ return range_check (result, "ATAN2D");
}
-/* Convert a floating-point number from degrees to radians. */
-static void
-radians_f (mpfr_t x, mpfr_rnd_t rnd_mode)
+gfc_expr *
+gfc_simplify_cos (gfc_expr *x)
{
- mpfr_t tmp;
- mpfr_init (tmp);
+ gfc_expr *result;
- /* Set x = x % 360 to avoid offsets with large angles. */
- mpfr_set_ui (tmp, 360, rnd_mode);
- mpfr_fmod (tmp, x, tmp, rnd_mode);
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
- /* Set x = x * pi. */
- mpfr_const_pi (tmp, rnd_mode);
- mpfr_mul (x, x, tmp, rnd_mode);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
- /* Set x = x / 180. */
- mpfr_div_ui (x, x, 180, rnd_mode);
+ switch (x->ts.type)
+ {
+ case BT_REAL:
+ mpfr_cos (result->value.real, x->value.real, GFC_RND_MODE);
+ break;
- mpfr_clear (tmp);
-}
+ case BT_COMPLEX:
+ gfc_set_model_kind (x->ts.kind);
+ mpc_cos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+ break;
+ default:
+ gfc_internal_error ("in gfc_simplify_cos(): Bad type");
+ }
-/* Convert argument to radians before calling a trig function. */
-
-gfc_expr *
-gfc_simplify_trigd (gfc_expr *icall)
-{
- gfc_expr *arg;
-
- arg = icall->value.function.actual->expr;
-
- if (arg->ts.type != BT_REAL)
- gfc_internal_error ("in gfc_simplify_trigd(): Bad type");
-
- if (arg->expr_type == EXPR_CONSTANT)
- /* Convert constant to radians before passing off to simplifier. */
- radians_f (arg->value.real, GFC_RND_MODE);
-
- /* Let the usual simplifier take over - we just simplified the arg. */
- return simplify_trig_call (icall);
+ return range_check (result, "COS");
}
-/* Convert result of an inverse trig function to degrees. */
+/* Simplify COSD(X) where X has the unit of degree. */
+
gfc_expr *
-gfc_simplify_atrigd (gfc_expr *icall)
+gfc_simplify_cosd (gfc_expr *x)
{
+ mpfr_t deg2rad;
gfc_expr *result;
- if (icall->value.function.actual->expr->ts.type != BT_REAL)
- gfc_internal_error ("in gfc_simplify_atrigd(): Bad type");
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
- /* See if another simplifier has work to do first. */
- result = simplify_trig_call (icall);
+ mpfr_init (deg2rad);
+ mpfr_const_pi (deg2rad, GFC_RND_MODE);
+ mpfr_div_ui (deg2rad, deg2rad, 180, GFC_RND_MODE);
+ mpfr_mul (deg2rad, x->value.real, deg2rad, GFC_RND_MODE);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+ mpfr_cos (result->value.real, deg2rad, GFC_RND_MODE);
+ mpfr_clear (deg2rad);
- if (result && result->expr_type == EXPR_CONSTANT)
- {
- /* Convert constant to degrees after passing off to actual simplifier. */
- degrees_f (result->value.real, GFC_RND_MODE);
- return result;
- }
-
- /* Let gfc_resolve_atrigd take care of the non-constant case. */
- return NULL;
+ return range_check (result, "COSD");
}
-/* Convert the result of atan2 to degrees. */
+/* Simplify SIND(X) where X has the unit of degree. */
+
gfc_expr *
-gfc_simplify_atan2d (gfc_expr *y, gfc_expr *x)
+gfc_simplify_sind (gfc_expr *x)
{
+ mpfr_t deg2rad;
gfc_expr *result;
- if (x->ts.type != BT_REAL || y->ts.type != BT_REAL)
- gfc_internal_error ("in gfc_simplify_atan2d(): Bad type");
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
- if (x->expr_type == EXPR_CONSTANT && y->expr_type == EXPR_CONSTANT)
- {
- result = gfc_simplify_atan2 (y, x);
- if (result != NULL)
- {
- degrees_f (result->value.real, GFC_RND_MODE);
- return result;
- }
- }
+ mpfr_init (deg2rad);
+ mpfr_const_pi (deg2rad, GFC_RND_MODE);
+ mpfr_div_ui (deg2rad, deg2rad, 180, GFC_RND_MODE);
+ mpfr_mul (deg2rad, x->value.real, deg2rad, GFC_RND_MODE);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+ mpfr_sin (result->value.real, deg2rad, GFC_RND_MODE);
+ mpfr_clear (deg2rad);
- /* Let gfc_resolve_atan2d take care of the non-constant case. */
- return NULL;
+ return range_check (result, "SIND");
}
+
+/* Simplify TAND(X) where X has the unit of degree. */
+
gfc_expr *
-gfc_simplify_cos (gfc_expr *x)
+gfc_simplify_tand (gfc_expr *x)
{
+ mpfr_t deg2rad;
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
+ mpfr_init (deg2rad);
+ mpfr_const_pi (deg2rad, GFC_RND_MODE);
+ mpfr_div_ui (deg2rad, deg2rad, 180, GFC_RND_MODE);
+ mpfr_mul (deg2rad, x->value.real, deg2rad, GFC_RND_MODE);
result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+ mpfr_tan (result->value.real, deg2rad, GFC_RND_MODE);
+ mpfr_clear (deg2rad);
- switch (x->ts.type)
- {
- case BT_REAL:
- mpfr_cos (result->value.real, x->value.real, GFC_RND_MODE);
- break;
-
- case BT_COMPLEX:
- gfc_set_model_kind (x->ts.kind);
- mpc_cos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
- break;
-
- default:
- gfc_internal_error ("in gfc_simplify_cos(): Bad type");
- }
-
- return range_check (result, "COS");
+ return range_check (result, "TAND");
}
@@ -7779,6 +7814,8 @@ gfc_simplify_sum (gfc_expr *array, gfc_expr *dim, gfc_
}
+/* Simplify COTAN(X) where X has the unit of radian. */
+
gfc_expr *
gfc_simplify_cotan (gfc_expr *x)
{
@@ -7811,6 +7848,29 @@ gfc_simplify_cotan (gfc_expr *x)
}
return range_check (result, "COTAN");
+}
+
+
+/* Simplify COTAND(X) where X has the unit of degree. */
+
+gfc_expr *
+gfc_simplify_cotand (gfc_expr *x)
+{
+ mpfr_t deg2rad;
+ gfc_expr *result;
+
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ mpfr_init (deg2rad);
+ mpfr_const_pi (deg2rad, GFC_RND_MODE);
+ mpfr_div_ui (deg2rad, deg2rad, 180, GFC_RND_MODE);
+ mpfr_mul (deg2rad, x->value.real, deg2rad, GFC_RND_MODE);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+ mpfr_cot (result->value.real, deg2rad, GFC_RND_MODE);
+ mpfr_clear (deg2rad);
+
+ return range_check (result, "COTAND");
}
Index: gcc/fortran/trans-intrinsic.c
===================================================================
--- gcc/fortran/trans-intrinsic.c (revision 280157)
+++ gcc/fortran/trans-intrinsic.c (working copy)
@@ -120,6 +120,9 @@ static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[]
/* Functions in libgfortran. */
LIB_FUNCTION (ERFC_SCALED, "erfc_scaled", false),
+ LIB_FUNCTION (SIND, "sind", false),
+ LIB_FUNCTION (COSD, "cosd", false),
+ LIB_FUNCTION (TAND, "tand", false),
/* End the list. */
LIB_FUNCTION (NONE, NULL, false)
@@ -4385,6 +4388,183 @@ gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * exp
se->expr = resvar;
}
+
+/* Generate the constant 180 / pi, which is used in the conversion
+ of acosd(), asind(), atand(), atan2d(). */
+
+static tree
+rad2deg (int kind)
+{
+ tree retval;
+ mpfr_t pi, t0;
+
+ gfc_set_model_kind (kind);
+ mpfr_init (pi);
+ mpfr_init (t0);
+ mpfr_set_si (t0, 180, GFC_RND_MODE);
+ mpfr_const_pi (pi, GFC_RND_MODE);
+ mpfr_div (t0, t0, pi, GFC_RND_MODE);
+ retval = gfc_conv_mpfr_to_tree (t0, kind, 0);
+ mpfr_clear (t0);
+ mpfr_clear (pi);
+ return retval;
+}
+
+
+/* ACOSD(x) is translated into ACOS(x) * 180 / pi.
+ ASIND(x) is translated into ASIN(x) * 180 / pi.
+ ATAND(x) is translated into ATAN(x) * 180 / pi. */
+
+static void
+gfc_conv_intrinsic_atrigd (gfc_se * se, gfc_expr * expr, gfc_isym_id id)
+{
+ tree arg;
+ tree atrigd;
+ tree type;
+
+ type = gfc_typenode_for_spec (&expr->ts);
+
+ gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+
+ if (id == GFC_ISYM_ACOSD)
+ atrigd = gfc_builtin_decl_for_float_kind (BUILT_IN_ACOS, expr->ts.kind);
+ else if (id == GFC_ISYM_ASIND)
+ atrigd = gfc_builtin_decl_for_float_kind (BUILT_IN_ASIN, expr->ts.kind);
+ else if (id == GFC_ISYM_ATAND)
+ atrigd = gfc_builtin_decl_for_float_kind (BUILT_IN_ATAN, expr->ts.kind);
+ else
+ gcc_unreachable ();
+
+ atrigd = build_call_expr_loc (input_location, atrigd, 1, arg);
+
+ se->expr = fold_build2_loc (input_location, MULT_EXPR, type, atrigd,
+ fold_convert (type, rad2deg (expr->ts.kind)));
+}
+
+
+/* COTAN(X) is translated into -TAN(X+PI/2) for REAL argument and
+ COS(X) / SIN(X) for COMPLEX argument. */
+
+static void
+gfc_conv_intrinsic_cotan (gfc_se *se, gfc_expr *expr)
+{
+ gfc_intrinsic_map_t *m;
+ tree arg;
+ tree type;
+
+ type = gfc_typenode_for_spec (&expr->ts);
+ gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+
+ if (expr->ts.type == BT_REAL)
+ {
+ tree tan;
+ tree tmp;
+ mpfr_t pio2;
+
+ /* Create pi/2. */
+ gfc_set_model_kind (expr->ts.kind);
+ mpfr_init (pio2);
+ mpfr_const_pi (pio2, GFC_RND_MODE);
+ mpfr_div_ui (pio2, pio2, 2, GFC_RND_MODE);
+ tmp = gfc_conv_mpfr_to_tree (pio2, expr->ts.kind, 0);
+ mpfr_clear (pio2);
+
+ /* Find tan builtin function. */
+ m = gfc_intrinsic_map;
+ for (; m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
+ if (GFC_ISYM_TAN == m->id)
+ break;
+
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, type, arg, tmp);
+ tan = gfc_get_intrinsic_lib_fndecl (m, expr);
+ tan = build_call_expr_loc (input_location, tan, 1, tmp);
+ se->expr = fold_build1_loc (input_location, NEGATE_EXPR, type, tan);
+ }
+ else
+ {
+ tree sin;
+ tree cos;
+
+ /* Find cos builtin function. */
+ m = gfc_intrinsic_map;
+ for (; m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
+ if (GFC_ISYM_COS == m->id)
+ break;
+
+ cos = gfc_get_intrinsic_lib_fndecl (m, expr);
+ cos = build_call_expr_loc (input_location, cos, 1, arg);
+
+ /* Find sin builtin function. */
+ m = gfc_intrinsic_map;
+ for (; m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
+ if (GFC_ISYM_SIN == m->id)
+ break;
+
+ sin = gfc_get_intrinsic_lib_fndecl (m, expr);
+ sin = build_call_expr_loc (input_location, sin, 1, arg);
+
+ /* Divide cos by sin. */
+ se->expr = fold_build2_loc (input_location, RDIV_EXPR, type, cos, sin);
+ }
+}
+
+
+/* COTAND(X) is translated into -TAN(X*PI/180+PI/2) for REAL argument. */
+
+static void
+gfc_conv_intrinsic_cotand (gfc_se *se, gfc_expr *expr)
+{
+ tree arg;
+ tree tmp;
+ tree type;
+ mpfr_t pi;
+
+ type = gfc_typenode_for_spec (&expr->ts);
+ gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+
+ /* Build the pi/180 tree and multiply by x. */
+ gfc_set_model_kind (expr->ts.kind);
+ mpfr_init (pi);
+ mpfr_const_pi (pi, GFC_RND_MODE);
+ mpfr_div_ui (pi, pi, 180, GFC_RND_MODE);
+ tmp = gfc_conv_mpfr_to_tree (pi, expr->ts.kind, 0);
+ arg = fold_build2_loc (input_location, MULT_EXPR, type, arg, tmp);
+
+ /* Build the pi/2 tree and add it to arg. */
+ mpfr_init (pi);
+ mpfr_const_pi (pi, GFC_RND_MODE);
+ mpfr_div_ui (pi, pi, 2, GFC_RND_MODE);
+ tmp = gfc_conv_mpfr_to_tree (pi, expr->ts.kind, 0);
+ arg = fold_build2_loc (input_location, PLUS_EXPR, type, arg, tmp);
+ mpfr_clear (pi);
+
+ tmp = gfc_builtin_decl_for_float_kind (BUILT_IN_TAN, expr->ts.kind);
+ tmp = build_call_expr_loc (input_location, tmp, 1, arg);
+
+ se->expr = fold_build1_loc (input_location, NEGATE_EXPR, type, tmp);
+}
+
+
+/* ATAN2D(Y,X) is translated into ATAN2(Y,X) * 180 / PI. */
+
+static void
+gfc_conv_intrinsic_atan2d (gfc_se *se, gfc_expr *expr)
+{
+ tree args[2];
+ tree atan2d;
+ tree type;
+
+ gfc_conv_intrinsic_function_args (se, expr, args, 2);
+ type = TREE_TYPE (args[0]);
+
+ atan2d = gfc_builtin_decl_for_float_kind (BUILT_IN_ATAN2, expr->ts.kind);
+ atan2d = build_call_expr_loc (input_location, atan2d, 2, args[0], args[1]);
+
+ se->expr = fold_build2_loc (input_location, MULT_EXPR, type, atan2d,
+ rad2deg (expr->ts.kind));
+}
+
+
/* COUNT(A) = Number of true elements in A. */
static void
gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
@@ -9896,6 +10076,24 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * e
case GFC_ISYM_ANY:
gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
+ break;
+
+ case GFC_ISYM_ACOSD:
+ case GFC_ISYM_ASIND:
+ case GFC_ISYM_ATAND:
+ gfc_conv_intrinsic_atrigd (se, expr, expr->value.function.isym->id);
+ break;
+
+ case GFC_ISYM_COTAN:
+ gfc_conv_intrinsic_cotan (se, expr);
+ break;
+
+ case GFC_ISYM_COTAND:
+ gfc_conv_intrinsic_cotand (se, expr);
+ break;
+
+ case GFC_ISYM_ATAN2D:
+ gfc_conv_intrinsic_atan2d (se, expr);
break;
case GFC_ISYM_BTEST:
Index: libgfortran/Makefile.am
===================================================================
--- libgfortran/Makefile.am (revision 280157)
+++ libgfortran/Makefile.am (working copy)
@@ -141,6 +141,7 @@ intrinsics/reshape_generic.c \
intrinsics/reshape_packed.c \
intrinsics/selected_int_kind.f90 \
intrinsics/selected_real_kind.f90 \
+intrinsics/trigd.c \
intrinsics/unpack_generic.c \
runtime/in_pack_generic.c \
runtime/in_unpack_generic.c
Index: libgfortran/Makefile.in
===================================================================
--- libgfortran/Makefile.in (revision 280157)
+++ libgfortran/Makefile.in (working copy)
@@ -421,8 +421,9 @@ am__objects_58 = associated.lo abort.lo args.lo cshift
pack_generic.lo selected_char_kind.lo size.lo \
spread_generic.lo string_intrinsics.lo rand.lo random.lo \
reshape_generic.lo reshape_packed.lo selected_int_kind.lo \
- selected_real_kind.lo unpack_generic.lo in_pack_generic.lo \
- in_unpack_generic.lo $(am__objects_56) $(am__objects_57)
+ selected_real_kind.lo trigd.lo unpack_generic.lo \
+ in_pack_generic.lo in_unpack_generic.lo $(am__objects_56) \
+ $(am__objects_57)
@IEEE_SUPPORT_TRUE@am__objects_59 = ieee_arithmetic.lo \
@IEEE_SUPPORT_TRUE@ ieee_exceptions.lo ieee_features.lo
am__objects_60 =
@@ -770,9 +771,9 @@ gfor_helper_src = intrinsics/associated.c intrinsics/a
intrinsics/rand.c intrinsics/random.c \
intrinsics/reshape_generic.c intrinsics/reshape_packed.c \
intrinsics/selected_int_kind.f90 \
- intrinsics/selected_real_kind.f90 intrinsics/unpack_generic.c \
- runtime/in_pack_generic.c runtime/in_unpack_generic.c \
- $(am__append_3) $(am__append_4)
+ intrinsics/selected_real_kind.f90 intrinsics/trigd.c \
+ intrinsics/unpack_generic.c runtime/in_pack_generic.c \
+ runtime/in_unpack_generic.c $(am__append_3) $(am__append_4)
@IEEE_SUPPORT_FALSE@gfor_ieee_src =
@IEEE_SUPPORT_TRUE@gfor_ieee_src = \
@IEEE_SUPPORT_TRUE@ieee/ieee_arithmetic.F90 \
@@ -2251,6 +2252,7 @@ distclean-compile:
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/time.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/transfer.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/transfer128.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/trigd.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/umask.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/unit.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/unix.Plo@am__quote@
@@ -6402,6 +6404,13 @@ reshape_packed.lo: intrinsics/reshape_packed.c
@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='intrinsics/reshape_packed.c' object='reshape_packed.lo' libtool=yes @AMDEPBACKSLASH@
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o reshape_packed.lo `test -f 'intrinsics/reshape_packed.c' || echo '$(srcdir)/'`intrinsics/reshape_packed.c
+
+trigd.lo: intrinsics/trigd.c
+@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT trigd.lo -MD -MP -MF $(DEPDIR)/trigd.Tpo -c -o trigd.lo `test -f 'intrinsics/trigd.c' || echo '$(srcdir)/'`intrinsics/trigd.c
+@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/trigd.Tpo $(DEPDIR)/trigd.Plo
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='intrinsics/trigd.c' object='trigd.lo' libtool=yes @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o trigd.lo `test -f 'intrinsics/trigd.c' || echo '$(srcdir)/'`intrinsics/trigd.c
unpack_generic.lo: intrinsics/unpack_generic.c
@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT unpack_generic.lo -MD -MP -MF $(DEPDIR)/unpack_generic.Tpo -c -o unpack_generic.lo `test -f 'intrinsics/unpack_generic.c' || echo '$(srcdir)/'`intrinsics/unpack_generic.c
Index: libgfortran/gfortran.map
===================================================================
--- libgfortran/gfortran.map (revision 280157)
+++ libgfortran/gfortran.map (working copy)
@@ -1606,4 +1606,16 @@ GFORTRAN_9.2 {
GFORTRAN_10 {
global:
_gfortran_os_error_at;
+ _gfortran_sind_r4;
+ _gfortran_sind_r8;
+ _gfortran_sind_r10;
+ _gfortran_sind_r16;
+ _gfortran_cosd_r4;
+ _gfortran_cosd_r8;
+ _gfortran_cosd_r10;
+ _gfortran_cosd_r16;
+ _gfortran_tand_r4;
+ _gfortran_tand_r8;
+ _gfortran_tand_r10;
+ _gfortran_tand_r16;
} GFORTRAN_9.2;
Index: libgfortran/intrinsics/trigd.c
===================================================================
--- libgfortran/intrinsics/trigd.c (nonexistent)
+++ libgfortran/intrinsics/trigd.c (working copy)
@@ -0,0 +1,229 @@
+/* Implementation of the degree trignometric functions COSD, SIND, TAND.
+ Copyright (C) 2020 Free Software Foundation, Inc.
+ Contributed by Steven G. Kargl <ka...@gcc.gnu.org>
+
+This file is part of the GNU Fortran runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public
+License as published by the Free Software Foundation; either
+version 3 of the License, or (at your option) any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+
+#include <math.h>
+
+/* Build _gfortran_sind_r4, _gfortran_cosd_r4, and _gfortran_tand_r4 */
+
+#define WTYPE GFC_REAL_4
+#define SIND sind_r4
+#define COSD cosd_r4
+#define TAND tand_r4
+
+#define SMALL 0x1.p-7f
+#define HALF 0.5f
+#define COS30 8.66025388e-01f
+#define SIN60 8.66025388e-01f
+
+#define PIO180H 1.74560547e-02f /* high 12 bits. */
+#define PIO180L -2.76216747e-06f /* Next 24 bits. */
+#define PIO180 (PIO180L + PIO180H) /* pi / 180. */
+#define D2R(x) (fmaf((x), PIO180H, (x) * PIO180L))
+#define CPYSGN(x) copysignf(1.f,(x))
+#define FABS(x) fabsf((x))
+#define FMOD(x) fmodf((x), 360.f)
+#define SIN(x) sinf((x))
+#define COS(x) cosf((x))
+#define TAN(x) tanf((x))
+
+#include "trigd_inc.c"
+
+#undef WTYPE
+#undef SMALL
+#undef HALF
+#undef COS30
+#undef SIN60
+#undef PIO180H
+#undef PIO180L
+#undef PIO180
+#undef D2R
+#undef CPYSGN
+#undef FABS
+#undef FMOD
+#undef SIN
+#undef COS
+#undef TAN
+#undef SIND
+#undef COSD
+#undef TAND
+
+
+/* Build _gfortran_sind_r8, _gfortran_cosd_r8, and _gfortran_tand_r8. */
+
+#define WTYPE GFC_REAL_8
+#define SIND sind_r8
+#define COSD cosd_r8
+#define TAND tand_r8
+
+#define SMALL 0x1.p-21
+#define HALF 0.5
+#define COS30 8.6602540378443860e-01
+#define SIN60 8.6602540378443860e-01
+
+#define PIO180H 1.7453283071517944e-02 /* high 21 bits. */
+#define PIO180L 9.4484253514332993e-09 /* Next 53 bits. */
+#define PIO180 (PIO180L + PIO180H) /* pi / 180. */
+#define D2R(x) (fma((x), PIO180H, (x) * PIO180L))
+
+#define CPYSGN(x) copysign(1.,(x))
+#define FABS(x) fabs((x))
+#define FMOD(x) fmod((x), 360.)
+#define SIN(x) sin((x))
+#define COS(x) cos((x))
+#define TAN(x) tan((x))
+
+#include "trigd_inc.c"
+
+#undef WTYPE
+#undef SMALL
+#undef HALF
+#undef COS30
+#undef SIN60
+#undef PIO180H
+#undef PIO180L
+#undef PIO180
+#undef D2R
+#undef CPYSGN
+#undef FABS
+#undef FMOD
+#undef SIN
+#undef COS
+#undef TAN
+#undef SIND
+#undef COSD
+#undef TAND
+
+
+/* Build _gfortran_sind_r10, _gfortran_cosd_r10, and _gfortran_tand_r10. */
+
+#ifdef HAVE_GFC_REAL_10
+
+#define WTYPE GFC_REAL_10
+#define SIND sind_r10
+#define COSD cosd_r10
+#define TAND tand_r10
+
+#define SMALL 0x1.p-27L
+#define HALF 0.5L
+#define COS30 8.66025403784438646787e-01L
+#define SIN60 8.66025403784438646787e-01L
+
+#define PIO180H 1.74532925229868851602e-02L /* high 32 bits */
+#define PIO180L -3.04358939097084072823e-12L /* Next 64 bits */
+#define PIO180 (PIO180L + PIO180H) /* pi / 180 */
+#define D2R(x) (fmal((x), PIO180H, (x) * PIO180L))
+#define CPYSGN(x) copysignl(1.L,(x))
+#define FABS(x) fabsl((x))
+#define FMOD(x) fmodl((x), 360.L)
+#define SIN(x) sinl((x))
+#define COS(x) cosl((x))
+#define TAN(x) tanl((x))
+
+#include "trigd_inc.c"
+#undef WTYPE
+#undef SMALL
+#undef HALF
+#undef COS30
+#undef SIN60
+#undef PIO180H
+#undef PIO180L
+#undef PIO180
+#undef D2R
+#undef CPYSGN
+#undef FABS
+#undef FMOD
+#undef SIN
+#undef COS
+#undef TAN
+#undef SIND
+#undef COSD
+#undef TAND
+#endif
+
+
+/* Build _gfortran_sind_r16, _gfortran_cosd_r16, and _gfortran_tand_r16. */
+
+#ifdef HAVE_GFC_REAL_16
+
+#define WTYPE GFC_REAL_16
+#define SIND sind_r16
+#define COSD cosd_r16
+#define TAND tand_r16
+
+#ifdef GFC_REAL_16_IS_FLOAT128 /* libquadmath. */
+#define SMALL 3.4e-17Q
+#define HALF 0.5Q
+#define COS30 8.66025403784438646763723170752936183e-01Q
+#define SIN60 8.66025403784438646763723170752936183e-01Q
+#define PIO180H 1.74532925199433197605003442731685936e-02Q
+#define PIO180L -2.39912634365882824665106671063098954e-17Q
+#define PIO180 (PIO180L + PIO180H)
+#define D2R(x) (fmaq((x), PIO180H, (x) * PIO180L))
+#define CPYSGN(x) copysignq(1.Q,(x))
+#define FABS(x) fabsq((x))
+#define FMOD(x) fmodq((x), 360.Q)
+#define SIN(x) sinq((x))
+#define COS(x) cosq((x))
+#define TAN(x) tanq((x))
+#else
+#define SMALL 3.4e-17L
+#define HALF 0.5L
+#define COS30 8.66025403784438646763723170752936183e-01L
+#define SIN60 8.66025403784438646763723170752936183e-01L
+#define PIO180H 1.74532925199433197605003442731685936e-02L
+#define PIO180L -2.39912634365882824665106671063098954e-17L
+#define PIO180 (PIO180L + PIO180H)
+#define D2R(x) (fmal((x), PIO180H, (x) * PIO180L))
+#define CPYSGN(x) copysignl(1.L,(x))
+#define FABS(x) fabsl((x))
+#define FMOD(x) fmodl((x), 360.L)
+#define SIN(x) sinl((x))
+#define COS(x) cosl((x))
+#define TAN(x) tanl((x))
+#endif
+
+#include "trigd_inc.c"
+
+#undef WTYPE
+#undef SMALL
+#undef HALF
+#undef COS30
+#undef SIN60
+#undef PIO180H
+#undef PIO180L
+#undef PIO180
+#undef D2R
+#undef CPYSGN
+#undef FABS
+#undef FMOD
+#undef SIN
+#undef COS
+#undef TAN
+#undef SIND
+#undef COSD
+#undef TAND
+#endif
Index: libgfortran/intrinsics/trigd_inc.c
===================================================================
--- libgfortran/intrinsics/trigd_inc.c (nonexistent)
+++ libgfortran/intrinsics/trigd_inc.c (working copy)
@@ -0,0 +1,202 @@
+/* Implementation of the degree trignometric functions COSD, SIND, TAND.
+ Copyright (C) 2020 Free Software Foundation, Inc.
+ Contributed by Steven G. Kargl <ka...@gcc.gnu.org>
+
+This file is part of the GNU Fortran runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public
+License as published by the Free Software Foundation; either
+version 3 of the License, or (at your option) any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
+<http://www.gnu.org/licenses/>. */
+
+
+/* Compute sind(x) = sin(x * pi / 180). */
+
+extern WTYPE SIND (WTYPE *);
+export_proto(SIND);
+
+extern WTYPE COSD (WTYPE *);
+export_proto(COSD);
+
+extern WTYPE TAND (WTYPE *);
+export_proto(TAND);
+
+WTYPE
+SIND (WTYPE *x)
+{
+ int n;
+ WTYPE ax, s;
+
+ if (isfinite(*x))
+ {
+ /* sin(-x) = - sin(x). */
+ s = CPYSGN(*x);
+ ax = FABS(*x);
+
+ /* In radians, sin(x) = x as x -> 0. */
+ if (ax < SMALL)
+ return (*x * PIO180);
+
+ /* Reduce angle to ax in [0,360]. */
+ ax = FMOD(ax);
+
+ /* Special cases. */
+ n = (int)ax;
+ if (n%30 == 0 && ax == n)
+ {
+ if (n%180 == 0)
+ ax = 0;
+ else if (n%90 == 0)
+ ax = n == 90 ? 1 : -1;
+ else if (n%60 == 0)
+ ax = n < 180 ? SIN60 : -SIN60;
+ else
+ ax = n < 180 ? HALF : -HALF;
+ return (s * ax);
+ }
+
+ /* Fold [0,360] into the range [0,45], and compute either SIN() or
+ COS() depending on symmetry of shifting into the [0,45] range. */
+ if (ax <= 180)
+ {
+ if (ax <= 90)
+ ax = (ax <= 45) ? SIN(D2R(ax)) : COS(D2R(90 - ax));
+ else
+ ax = (ax <= 135) ? COS(D2R(ax - 90)) : SIN(D2R(180 - ax));
+ }
+ else if (ax <= 270)
+ ax = (ax <= 225) ? -SIN(D2R(ax - 180)) : -COS(D2R(270 - ax));
+ else
+ ax = (ax <= 315) ? -COS(D2R(ax - 270)) : -SIN(D2R(360 - ax));
+ ax *= s;
+ }
+ else
+ ax = x - x; /* Return NaN for +-Inf and NaN and raise exception. */
+
+ return (ax);
+}
+
+/* Compute cosd(x) = cos(x * pi / 180). */
+
+WTYPE
+COSD (WTYPE *x)
+{
+#ifdef TINYF
+ static const volatile WTYPE tiny = 1.e-30f;
+#elif TINY
+ static const volatile WTYPE tiny = 1.e-300f;
+#else
+ static const volatile WTYPE tiny = 0x1p-10000L;
+#endif
+
+ int n;
+ WTYPE ax;
+
+ if (isfinite(*x))
+ {
+ ax = FABS(*x);
+
+ /* No spurious underflows!. In radians, cos(x) = 1-x*x/2 as x -> 0. */
+ if (ax < SMALL)
+ return (ax == 0 ? 1 : 1 - tiny);
+
+ /* Reduce angle to ax in [0,360]. */
+ ax = FMOD(ax);
+
+ /* Special cases with exact results. */
+ n = (int)ax;
+ if (n%30 == 0 && ax == n)
+ {
+ if (n%180 == 0)
+ ax = n == 270 ? -1 : 1;
+ else if (n%90 == 0)
+ ax = 0;
+ else if (n%60 == 0)
+ ax = (n == 60 || n == 300) ? 0.5f : -0.5f;
+ else
+ ax = (n == 30 || n == 330) ? COS30 : -COS30;
+ return (ax);
+ }
+
+ /* Fold [0,360] into the range [0,45], and compute either SIN() or
+ COS() depending on symmetry of shifting into the [0,45] range. */
+ if (ax <= 180)
+ {
+ if (ax <= 90)
+ ax = (ax <= 45) ? COS(D2R(ax)) : SIN(D2R(90 - ax));
+ else
+ ax = (ax <= 135) ? -SIN(D2R(ax - 90)) : -COS(D2R(180 - ax));
+ }
+ else if (ax <= 270)
+ ax = (ax <= 225) ? -COS(D2R(ax - 180)) : -SIN(D2R(270 - ax));
+ else
+ ax = (ax <= 315) ? SIN(D2R(ax - 270)) : COS(D2R(360 - ax));
+ }
+ else
+ ax = x - x; /* Return NaN for +-Inf and NaN and raise exception. */
+
+ return (ax);
+}
+
+
+/* Compute tand(x) = tan(x * pi / 180). */
+
+WTYPE
+TAND (WTYPE *x)
+{
+ int n;
+ WTYPE ax, s;
+
+ if (isfinite(*x))
+ {
+ /* tan(-x) = - tan(x). */
+ s = CPYSGN(*x);
+ ax = FABS(*x);
+
+ /* In radians, tan(x) = x as x -> 0. */
+ if (ax < SMALL)
+ return (*x * PIO180);
+
+ ax = FMOD(ax);
+
+ /* Special cases with exact results. */
+ n = (int)ax;
+ if (n%45 == 0 && ax == n)
+ {
+ if (n%180 == 0)
+ ax = 0;
+ else if (n%90 == 0)
+ ax = (x - x) / (x - x);
+ else
+ ax = (n == 45 || n == 225) ? 1 : -1;
+ return (s * ax);
+ }
+
+ /* Fold [0,360] into the range [0,90], and compute TAN(). */
+ if (ax <= 180)
+ ax = (ax <= 90) ? TAN(D2R(ax)) : -TAN(D2R(180 - ax));
+ else
+ ax = (ax <= 270) ? TAN(D2R(ax - 180)) : -TAN(D2R(360 - ax));
+
+ ax *= s;
+ }
+ else
+ ax = x - x; /* Return NaN for +-Inf and NaN and raise exception. */
+
+ return (ax);
+}
+
