Dear Fortranners,
the attached patch fixes the handling of the DEC trigonometric intrinsics
for different argument kinds. It is based on the original patch by Steve,
which fixes the lookup for the needed intrinsics.
Regtested on x86_64-pc-linux-gnu. OK for affected branches?
Thanks,
Harald
From e979db00b8e84333c53bc0b8f1c89cd8ce18d72c Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anl...@gmx.de>
Date: Mon, 15 Nov 2021 22:32:17 +0100
Subject: [PATCH] Fortran: fix lookup for gfortran builtin math intrinsics used
by DEC extensions
gcc/fortran/ChangeLog:
PR fortran/99061
* trans-intrinsic.c (gfc_lookup_intrinsic): Helper function for
looking up gfortran builtin intrinsics.
(gfc_conv_intrinsic_atrigd): Use it.
(gfc_conv_intrinsic_cotan): Likewise.
(gfc_conv_intrinsic_cotand): Likewise.
(gfc_conv_intrinsic_atan2d): Likewise.
gcc/testsuite/ChangeLog:
PR fortran/99061
* gfortran.dg/dec_math_5.f90: New test.
---
gcc/fortran/trans-intrinsic.c | 66 ++++++++-------
gcc/testsuite/gfortran.dg/dec_math_5.f90 | 103 +++++++++++++++++++++++
2 files changed, 138 insertions(+), 31 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/dec_math_5.f90
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 3f867911af5..bd67f4f44da 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -4555,6 +4555,18 @@ rad2deg (int kind)
}
+static gfc_intrinsic_map_t *
+gfc_lookup_intrinsic (gfc_isym_id id)
+{
+ gfc_intrinsic_map_t *m = gfc_intrinsic_map;
+ for (; m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
+ if (id == m->id)
+ break;
+ gcc_assert (id == m->id);
+ return m;
+}
+
+
/* 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. */
@@ -4565,20 +4577,27 @@ gfc_conv_intrinsic_atrigd (gfc_se * se, gfc_expr * expr, gfc_isym_id id)
tree arg;
tree atrigd;
tree type;
+ gfc_intrinsic_map_t *m;
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 ();
-
+ switch (id)
+ {
+ case GFC_ISYM_ACOSD:
+ m = gfc_lookup_intrinsic (GFC_ISYM_ACOS);
+ break;
+ case GFC_ISYM_ASIND:
+ m = gfc_lookup_intrinsic (GFC_ISYM_ASIN);
+ break;
+ case GFC_ISYM_ATAND:
+ m = gfc_lookup_intrinsic (GFC_ISYM_ATAN);
+ break;
+ default:
+ gcc_unreachable ();
+ }
+ atrigd = gfc_get_intrinsic_lib_fndecl (m, expr);
atrigd = build_call_expr_loc (input_location, atrigd, 1, arg);
se->expr = fold_build2_loc (input_location, MULT_EXPR, type, atrigd,
@@ -4614,13 +4633,9 @@ gfc_conv_intrinsic_cotan (gfc_se *se, gfc_expr *expr)
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);
+ m = gfc_lookup_intrinsic (GFC_ISYM_TAN);
tan = gfc_get_intrinsic_lib_fndecl (m, expr);
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, type, arg, tmp);
tan = build_call_expr_loc (input_location, tan, 1, tmp);
se->expr = fold_build1_loc (input_location, NEGATE_EXPR, type, tan);
}
@@ -4630,20 +4645,12 @@ gfc_conv_intrinsic_cotan (gfc_se *se, gfc_expr *expr)
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;
-
+ m = gfc_lookup_intrinsic (GFC_ISYM_COS);
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;
-
+ m = gfc_lookup_intrinsic (GFC_ISYM_SIN);
sin = gfc_get_intrinsic_lib_fndecl (m, expr);
sin = build_call_expr_loc (input_location, sin, 1, arg);
@@ -4675,11 +4682,7 @@ gfc_conv_intrinsic_cotand (gfc_se *se, gfc_expr *expr)
mpfr_clear (ninety);
/* Find tand. */
- gfc_intrinsic_map_t *m = gfc_intrinsic_map;
- for (; m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
- if (GFC_ISYM_TAND == m->id)
- break;
-
+ gfc_intrinsic_map_t *m = gfc_lookup_intrinsic (GFC_ISYM_TAND);
tree tand = gfc_get_intrinsic_lib_fndecl (m, expr);
tand = build_call_expr_loc (input_location, tand, 1, arg);
@@ -4699,7 +4702,8 @@ gfc_conv_intrinsic_atan2d (gfc_se *se, gfc_expr *expr)
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);
+ gfc_intrinsic_map_t *m = gfc_lookup_intrinsic (GFC_ISYM_ATAN2);
+ atan2d = gfc_get_intrinsic_lib_fndecl (m, expr);
atan2d = build_call_expr_loc (input_location, atan2d, 2, args[0], args[1]);
se->expr = fold_build2_loc (input_location, MULT_EXPR, type, atan2d,
diff --git a/gcc/testsuite/gfortran.dg/dec_math_5.f90 b/gcc/testsuite/gfortran.dg/dec_math_5.f90
new file mode 100644
index 00000000000..1417a4fed29
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/dec_math_5.f90
@@ -0,0 +1,103 @@
+! { dg-do run }
+! { dg-additional-options "-std=gnu" }
+! { dg-require-effective-target fortran_real_10 }
+! { dg-require-effective-target fortran_real_16 }
+
+program p
+ implicit none
+ real(4) :: a1, e1 = 1.e-5
+ real(8) :: b1, e2 = 1.e-14
+ real(10) :: c1, e3 = 1.e-17
+ real(16) :: d1, e4 = 1.e-30
+
+ a1 = 1; a1 = atand(a1)
+ b1 = 1; b1 = atand(b1)
+ c1 = 1; c1 = atand(c1)
+ d1 = 1; d1 = atand(d1)
+! print '(4(F15.11))', a1, b1, c1, d1
+ if (abs(a1 - 45) > e1) stop 1
+ if (abs(b1 - 45) > e2) stop 2
+ if (abs(c1 - 45) > e3) stop 3
+ if (abs(d1 - 45) > e4) stop 4
+
+ a1 = 1._4 / 2; a1 = asind(a1)
+ b1 = 1._8 / 2; b1 = asind(b1)
+ c1 = 1._10/ 2; c1 = asind(c1)
+ d1 = 1._16/ 2; d1 = asind(d1)
+ if (abs(a1 - 30) > e1) stop 5
+ if (abs(b1 - 30) > e2) stop 6
+ if (abs(c1 - 30) > e3) stop 7
+ if (abs(d1 - 30) > e4) stop 8
+
+ a1 = 1._4 / 2; a1 = acosd(a1)
+ b1 = 1._8 / 2; b1 = acosd(b1)
+ c1 = 1._10/ 2; c1 = acosd(c1)
+ d1 = 1._16/ 2; d1 = acosd(d1)
+ if (abs(a1 - 60) > e1) stop 9
+ if (abs(b1 - 60) > e2) stop 10
+ if (abs(c1 - 60) > e3) stop 11
+ if (abs(d1 - 60) > e4) stop 12
+
+ a1 = 45; a1 = tand(a1)
+ b1 = 45; b1 = tand(b1)
+ c1 = 45; c1 = tand(c1)
+ d1 = 45; d1 = tand(d1)
+ if (abs(a1 - 1) > e1) stop 13
+ if (abs(b1 - 1) > e2) stop 14
+ if (abs(c1 - 1) > e3) stop 15
+ if (abs(d1 - 1) > e4) stop 16
+
+ a1 = 60; a1 = tand(a1)
+ b1 = 60; b1 = tand(b1)
+ c1 = 60; c1 = tand(c1)
+ d1 = 60; d1 = tand(d1)
+ if (abs(a1 - sqrt (3._4) ) > e1) stop 17
+ if (abs(b1 - sqrt (3._8) ) > e2) stop 18
+ if (abs(c1 - sqrt (3._10)) > e3) stop 19
+ if (abs(d1 - sqrt (3._16)) > e4) stop 20
+
+ a1 = 45; a1 = cotand(a1)
+ b1 = 45; b1 = cotand(b1)
+ c1 = 45; c1 = cotand(c1)
+ d1 = 45; d1 = cotand(d1)
+ if (abs(a1 - 1) > e1) stop 21
+ if (abs(b1 - 1) > e2) stop 22
+ if (abs(c1 - 1) > e3) stop 23
+ if (abs(d1 - 1) > e4) stop 24
+
+ a1 = 30; a1 = cotand(a1)
+ b1 = 30; b1 = cotand(b1)
+ c1 = 30; c1 = cotand(c1)
+ d1 = 30; d1 = cotand(d1)
+ if (abs(a1 - sqrt (3._4) ) > e1) stop 25
+ if (abs(b1 - sqrt (3._8) ) > e2) stop 26
+ if (abs(c1 - sqrt (3._10)) > e3) stop 27
+ if (abs(d1 - sqrt (3._16)) > e4) stop 28
+
+ a1 = 1; a1 = atan2d(a1, a1)
+ b1 = 1; b1 = atan2d(b1, b1)
+ c1 = 1; c1 = atan2d(c1, c1)
+ d1 = 1; d1 = atan2d(d1, d1)
+ if (abs(a1 - 45) > e1) stop 29
+ if (abs(b1 - 45) > e2) stop 30
+ if (abs(c1 - 45) > e3) stop 31
+ if (abs(d1 - 45) > e4) stop 32
+
+ a1 = 30; a1 = sind(a1)
+ b1 = 30; b1 = sind(b1)
+ c1 = 30; c1 = sind(c1)
+ d1 = 30; d1 = sind(d1)
+ if (abs(a1 - 0.5) > e1) stop 33
+ if (abs(b1 - 0.5) > e2) stop 34
+ if (abs(c1 - 0.5) > e3) stop 35
+ if (abs(d1 - 0.5) > e4) stop 36
+
+ a1 = 60; a1 = cosd(a1)
+ b1 = 60; b1 = cosd(b1)
+ c1 = 60; c1 = cosd(c1)
+ d1 = 60; d1 = cosd(d1)
+ if (abs(a1 - 0.5) > e1) stop 37
+ if (abs(b1 - 0.5) > e2) stop 38
+ if (abs(c1 - 0.5) > e3) stop 39
+ if (abs(d1 - 0.5) > e4) stop 40
+end program p
--
2.26.2
