https://gcc.gnu.org/bugzilla/show_bug.cgi?id=99061
--- Comment #4 from Steve Kargl <sgk at troutmask dot apl.washington.edu> ---
Neither Gerhard's original code nor my patch fixed other ICEs.
Here's a test program for x86 systems.
program p
implicit none
real(4) :: a1, e1 = 1.e-6
real(8) :: b1, e2 = 1.e-10
real(10) :: c1, e3 = 1.e-10
real(16) :: d1, e4 = 1.e-16
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)
print '(4(F15.11))', a1, b1, c1, 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)
print '(4(F15.11))', a1, b1, c1, 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)
print '(4(F15.11))', a1, b1, c1, 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 = 45; a1 = cotand(a1)
b1 = 45; b1 = cotand(b1)
c1 = 45; c1 = cotand(c1)
d1 = 45; d1 = cotand(d1)
print '(4(F15.11))', a1, b1, c1, d1
if (abs(a1 - 1) > e1) stop 17
if (abs(b1 - 1) > e2) stop 18
if (abs(c1 - 1) > e3) stop 19
if (abs(d1 - 1) > e4) stop 20
a1 = 1; a1 = atan2d(a1, a1)
b1 = 1; b1 = atan2d(b1, b1)
c1 = 1; c1 = atan2d(c1, c1)
d1 = 1; d1 = atan2d(d1, d1)
print '(4(F15.11))', a1, b1, c1, d1
if (abs(a1 - 45) > e1) stop 21
if (abs(b1 - 45) > e2) stop 22
if (abs(c1 - 45) > e3) stop 23
if (abs(d1 - 45) > e4) stop 24
a1 = 30; a1 = sind(a1)
b1 = 30; b1 = sind(b1)
c1 = 30; c1 = sind(c1)
d1 = 30; d1 = sind(d1)
print '(4(F15.11))', a1, b1, c1, d1
if (abs(a1 - 0.5) > e1) stop 25
if (abs(b1 - 0.5) > e2) stop 26
if (abs(c1 - 0.5) > e3) stop 27
if (abs(d1 - 0.5) > e4) stop 28
a1 = 60; a1 = cosd(a1)
b1 = 60; b1 = cosd(b1)
c1 = 60; c1 = cosd(c1)
d1 = 60; d1 = cosd(d1)
print '(4(F15.11))', a1, b1, c1, d1
if (abs(a1 - 0.5) > e1) stop 25
if (abs(b1 - 0.5) > e2) stop 26
if (abs(c1 - 0.5) > e3) stop 27
if (abs(d1 - 0.5) > e4) stop 28
end program p
Here's the patch.
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 5c9258c65c3..06d06bdc435 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -189,6 +189,19 @@ gfc_builtin_decl_for_float_kind (enum built_in_function
double_built_in,
}
+static gfc_intrinsic_map_t *
+search_for_intrinsic_fcn (enum gfc_isym_id id)
+{
+ gfc_intrinsic_map_t *m;
+
+ m = gfc_intrinsic_map;
+ for (; m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
+ if (id == m->id)
+ break;
+
+ return m;
+}
+
/* Evaluate the arguments to an intrinsic function. The value
of NARGS may be less than the actual number of arguments in EXPR
to allow optional "KIND" arguments that are not included in the
@@ -4587,6 +4600,7 @@ rad2deg (int kind)
static void
gfc_conv_intrinsic_atrigd (gfc_se * se, gfc_expr * expr, gfc_isym_id id)
{
+ gfc_isym_id jd;
tree arg;
tree atrigd;
tree type;
@@ -4595,15 +4609,10 @@ gfc_conv_intrinsic_atrigd (gfc_se * se, gfc_expr *
expr, gfc_isym_id id)
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 ();
-
+ if (id == GFC_ISYM_ATAND) jd = GFC_ISYM_ATAN;
+ if (id == GFC_ISYM_ACOSD) jd = GFC_ISYM_ACOS;
+ if (id == GFC_ISYM_ASIND) jd = GFC_ISYM_ASIN;
+ atrigd = gfc_get_intrinsic_lib_fndecl (search_for_intrinsic_fcn (jd), expr);
atrigd = build_call_expr_loc (input_location, atrigd, 1, arg);
se->expr = fold_build2_loc (input_location, MULT_EXPR, type, atrigd,
@@ -4617,13 +4626,13 @@ gfc_conv_intrinsic_atrigd (gfc_se * se, gfc_expr *
expr, gfc_isym_id id)
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);
+#define GILF gfc_get_intrinsic_lib_fndecl
if (expr->ts.type == BT_REAL)
{
tree tan;
@@ -4638,14 +4647,8 @@ gfc_conv_intrinsic_cotan (gfc_se *se, gfc_expr *expr)
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 = GILF (search_for_intrinsic_fcn (GFC_ISYM_TAN), expr);
tan = build_call_expr_loc (input_location, tan, 1, tmp);
se->expr = fold_build1_loc (input_location, NEGATE_EXPR, type, tan);
}
@@ -4654,27 +4657,15 @@ gfc_conv_intrinsic_cotan (gfc_se *se, gfc_expr *expr)
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 = GILF (search_for_intrinsic_fcn (GFC_ISYM_COS), 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 = GILF (search_for_intrinsic_fcn (GFC_ISYM_SIN), 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);
}
+#undef GILF
}
@@ -4699,13 +4690,9 @@ gfc_conv_intrinsic_cotand (gfc_se *se, gfc_expr *expr)
arg = fold_build2_loc (input_location, PLUS_EXPR, type, arg, ninety_tree);
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;
-
- tree tand = gfc_get_intrinsic_lib_fndecl (m, expr);
+#define GILF gfc_get_intrinsic_lib_fndecl
+ tree tand = GILF (search_for_intrinsic_fcn (GFC_ISYM_TAND), expr);
+#undef GILF
tand = build_call_expr_loc (input_location, tand, 1, arg);
se->expr = fold_build1_loc (input_location, NEGATE_EXPR, type, tand);
@@ -4724,7 +4711,9 @@ 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);
+#define GILF gfc_get_intrinsic_lib_fndecl
+ atan2d = GILF (search_for_intrinsic_fcn (GFC_ISYM_ATAN2), expr);
+#undef GILF
atan2d = build_call_expr_loc (input_location, atan2d, 2, args[0], args[1]);
se->expr = fold_build2_loc (input_location, MULT_EXPR, type, atan2d,
