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.

Co-authored-by: Steven G. Kargl <kargl@gcc.gnu.org>

diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index c1b51f4da266b31d74564109835be385cc0c954d..909821d3284ede69cb1b429301c624715029aa98 100644 (file)
--- 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 (file)
index 0000000..dee2de4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/dec_math_5.f90
@@ -0,0 +1,104 @@
+! { 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
+  integer, parameter :: ep = selected_real_kind (17) ! real(10)
+  real(4)  :: a1, e1 = 1.e-5
+  real(8)  :: b1, e2 = 1.e-14
+  real(ep) :: 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 = 0.5; a1 = asind(a1)
+  b1 = 0.5; b1 = asind(b1)
+  c1 = 0.5; c1 = asind(c1)
+  d1 = 0.5; 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 = 0.5; a1 = acosd(a1)
+  b1 = 0.5; b1 = acosd(b1)
+  c1 = 0.5; c1 = acosd(c1)
+  d1 = 0.5; 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._ep)) > 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._ep)) > 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