From e979db00b8e84333c53bc0b8f1c89cd8ce18d72c Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@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
@@ -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,
new file mode 100644
@@ -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