Skip to content

R
riscv-gcc-1
Commit 504ed63a by Tobias Burnus Committed by Tobias Burnus
Options

re PR fortran/33197 (Fortran 2008: math functions) 

2009-07-25  Tobias Burnus  <burnus@net-b.de>
            Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>

        PR fortran/33197
        * intrinsic.c (add_functions): Support complex arguments for
        acos,acosh,asin,asinh,atan,atanh.
        * invoke.texi (ACOS,ACOSH,ASIN,ASINH,ATAN,ATANH): Support
        complex arguments.
        * simplify.c (gfc_simplify_acos,gfc_simplify_acosh,
        gfc_simplify_asin,gfc_simplify_asinh,gfc_simplify_atan,
        gfc_simplify_atanh,gfc_simplify_atan,gfc_simplify_asinh,
        gfc_simplify_acosh,gfc_simplify_atanh): Support
        complex arguments.

2009-07-25  Tobias Burnus  <burnus@net-b.de>

        PR fortran/33197
        * intrinsics/c99_functions.c (cacosf,cacos,cacosl,casinf,
        casin,casind,catanf,catan,catanl,cacoshf,cacosh,cacoshl,
        casinhf,casinh,casinhf,catanhf,catanh,catanhl): New functions.
        * c99_protos.h: Add prototypes for those.

2009-07-25  Tobias Burnus  <burnus@net-b.de>

        PR fortran/33197
        * gfortran.dg/complex_intrinsic_5.f90: New test.
        * gfortran.dg/complex_intrinsic_7.f90: New test.


Co-Authored-By: Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>

From-SVN: r150087
parent 86631ea3
Showing with 593 additions and 72 deletions
gcc/fortran/ChangeLog
2009-07-25 Tobias Burnus <burnus@net-b.de>
Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
PR fortran/33197
* intrinsic.c (add_functions): Support complex arguments for
acos,acosh,asin,asinh,atan,atanh.
* invoke.texi (ACOS,ACOSH,ASIN,ASINH,ATAN,ATANH): Support
complex arguments.
* simplify.c (gfc_simplify_acos,gfc_simplify_acosh,
gfc_simplify_asin,gfc_simplify_asinh,gfc_simplify_atan,
gfc_simplify_atanh,gfc_simplify_atan,gfc_simplify_asinh,
gfc_simplify_acosh,gfc_simplify_atanh): Support
complex arguments.
2009-07-25 Richard Guenther <rguenther@suse.de>
PR fortran/40005
......
gcc/fortran/intrinsic.c
......@@ -1134,7 +1134,7 @@ add_functions (void)
make_generic ("achar", GFC_ISYM_ACHAR, GFC_STD_F95);
add_sym_1 ("acos", GFC_ISYM_ACOS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
gfc_check_fn_r, gfc_simplify_acos, gfc_resolve_acos,
gfc_check_fn_rc2008, gfc_simplify_acos, gfc_resolve_acos,
x, BT_REAL, dr, REQUIRED);
add_sym_1 ("dacos", GFC_ISYM_ACOS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
......@@ -1144,7 +1144,7 @@ add_functions (void)
make_generic ("acos", GFC_ISYM_ACOS, GFC_STD_F77);
add_sym_1 ("acosh", GFC_ISYM_ACOSH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr,
GFC_STD_F2008, gfc_check_fn_r, gfc_simplify_acosh,
GFC_STD_F2008, gfc_check_fn_rc2008, gfc_simplify_acosh,
gfc_resolve_acosh, x, BT_REAL, dr, REQUIRED);
add_sym_1 ("dacosh", GFC_ISYM_ACOSH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU,
......@@ -1217,7 +1217,7 @@ add_functions (void)
make_generic ("any", GFC_ISYM_ANY, GFC_STD_F95);
add_sym_1 ("asin", GFC_ISYM_ASIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
gfc_check_fn_r, gfc_simplify_asin, gfc_resolve_asin,
gfc_check_fn_rc2008, gfc_simplify_asin, gfc_resolve_asin,
x, BT_REAL, dr, REQUIRED);
add_sym_1 ("dasin", GFC_ISYM_ASIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
......@@ -1227,7 +1227,7 @@ add_functions (void)
make_generic ("asin", GFC_ISYM_ASIN, GFC_STD_F77);
add_sym_1 ("asinh", GFC_ISYM_ASINH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr,
GFC_STD_F2008, gfc_check_fn_r, gfc_simplify_asinh,
GFC_STD_F2008, gfc_check_fn_rc2008, gfc_simplify_asinh,
gfc_resolve_asinh, x, BT_REAL, dr, REQUIRED);
add_sym_1 ("dasinh", GFC_ISYM_ASINH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU,
......@@ -1243,7 +1243,7 @@ add_functions (void)
make_generic ("associated", GFC_ISYM_ASSOCIATED, GFC_STD_F95);
add_sym_1 ("atan", GFC_ISYM_ATAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
gfc_check_fn_r, gfc_simplify_atan, gfc_resolve_atan,
gfc_check_fn_rc2008, gfc_simplify_atan, gfc_resolve_atan,
x, BT_REAL, dr, REQUIRED);
add_sym_1 ("datan", GFC_ISYM_ATAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
......@@ -1253,7 +1253,7 @@ add_functions (void)
make_generic ("atan", GFC_ISYM_ATAN, GFC_STD_F77);
add_sym_1 ("atanh", GFC_ISYM_ATANH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr,
GFC_STD_F2008, gfc_check_fn_r, gfc_simplify_atanh,
GFC_STD_F2008, gfc_check_fn_rc2008, gfc_simplify_atanh,
gfc_resolve_atanh, x, BT_REAL, dr, REQUIRED);
add_sym_1 ("datanh", GFC_ISYM_ATANH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU,
......
gcc/fortran/intrinsic.texi
......@@ -531,7 +531,7 @@ and formatted string representations.
@code{ACOS(X)} computes the arccosine of @var{X} (inverse of @code{COS(X)}).
@item @emph{Standard}:
Fortran 77 and later
Fortran 77 and later, for a complex argument Fortran 2008 or later
@item @emph{Class}:
Elemental function
......@@ -541,14 +541,14 @@ Elemental function
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{X} @tab The type shall be @code{REAL} with a magnitude that is
less than or equal to one.
@item @var{X} @tab The type shall either be @code{REAL} with a magnitude that is
less than or equal to one - or the type shall be @code{COMPLEX}.
@end multitable
@item @emph{Return value}:
The return value is of type @code{REAL} and it lies in the
range @math{ 0 \leq \acos(x) \leq \pi}. The return value if of the same
kind as @var{X}.
The return value is of the same type and kind as @var{X}.
The real part of the result is in radians and lies in the range
@math{0 \leq \Re \acos(x) \leq \pi}.
@item @emph{Example}:
@smallexample
......@@ -600,7 +600,9 @@ Elemental function
@end multitable
@item @emph{Return value}:
The return value has the same type and kind as @var{X}
The return value has the same type and kind as @var{X}. If @var{X} is
complex, the imaginary part of the result is in radians and lies between
@math{ 0 \leq \Im \acosh(x) \leq \pi}.
@item @emph{Example}:
@smallexample
......@@ -1170,7 +1172,7 @@ end program test_any
@code{ASIN(X)} computes the arcsine of its @var{X} (inverse of @code{SIN(X)}).
@item @emph{Standard}:
Fortran 77 and later
Fortran 77 and later, for a complex argument Fortran 2008 or later
@item @emph{Class}:
Elemental function
......@@ -1180,14 +1182,14 @@ Elemental function
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{X} @tab The type shall be @code{REAL}, and a magnitude that is
less than or equal to one.
@item @var{X} @tab The type shall be either @code{REAL} and a magnitude that is
less than or equal to one - or be @code{COMPLEX}.
@end multitable
@item @emph{Return value}:
The return value is of type @code{REAL} and it lies in the
range @math{-\pi / 2 \leq \asin (x) \leq \pi / 2}. The kind type
parameter is the same as @var{X}.
The return value is of the same type and kind as @var{X}.
The real part of the result is in radians and lies in the range
@math{-\pi/2 \leq \Re \asin(x) \leq \pi/2}.
@item @emph{Example}:
@smallexample
......@@ -1238,7 +1240,9 @@ Elemental function
@end multitable
@item @emph{Return value}:
The return value is of the same type and kind as @var{X}.
The return value is of the same type and kind as @var{X}. If @var{X} is
complex, the imaginary part of the result is in radians and lies between
@math{-\pi/2 \leq \Im \asinh(x) \leq \pi/2}.
@item @emph{Example}:
@smallexample
......@@ -1349,7 +1353,7 @@ end program test_associated
@code{ATAN(X)} computes the arctangent of @var{X}.
@item @emph{Standard}:
Fortran 77 and later
Fortran 77 and later, for a complex argument Fortran 2008 or later
@item @emph{Class}:
Elemental function
......@@ -1359,12 +1363,13 @@ Elemental function
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{X} @tab The type shall be @code{REAL}.
@item @var{X} @tab The type shall be @code{REAL} or @code{COMPLEX}.
@end multitable
@item @emph{Return value}:
The return value is of type @code{REAL} and it lies in the
range @math{ - \pi / 2 \leq \atan (x) \leq \pi / 2}.
The return value is of the same type and kind as @var{X}.
The real part of the result is in radians and lies in the range
@math{-\pi/2 \leq \Re \atan(x) \leq \pi/2}.
@item @emph{Example}:
@smallexample
......@@ -1470,7 +1475,9 @@ Elemental function
@end multitable
@item @emph{Return value}:
The return value has same type and kind as @var{X}.
The return value has same type and kind as @var{X}. If @var{X} is
complex, the imaginary part of the result is in radians and lies between
@math{-\pi/2 \leq \Im \atanh(x) \leq \pi/2}.
@item @emph{Example}:
@smallexample
......@@ -2635,9 +2642,9 @@ Elemental function
@end multitable
@item @emph{Return value}:
The return value is of type @code{REAL} and it lies in the
range @math{ -1 \leq \cos (x) \leq 1}. The kind type
parameter is the same as @var{X}.
The return value is of the same type and kind as @var{X}. The real part
of the result is in radians. If @var{X} is of the type @code{REAL},
the return value lies in the range @math{ -1 \leq \cos (x) \leq 1}.
@item @emph{Example}:
@smallexample
......
gcc/fortran/simplify.c
......@@ -735,12 +735,21 @@ gfc_simplify_acos (gfc_expr *x)
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)
switch (x->ts.type)
{
gfc_error ("Argument of ACOS at %L must be between -1 and 1",
&x->where);
return &gfc_bad_expr;
case BT_REAL:
if (mpfr_cmp_si (x->value.real, 1) > 0
|| mpfr_cmp_si (x->value.real, -1) < 0)
{
gfc_error ("Argument of ACOS at %L must be between -1 and 1",
&x->where);
return &gfc_bad_expr;
}
break;
case BT_COMPLEX:
return NULL;
default:
gfc_internal_error ("in gfc_simplify_cos(): Bad type");
}
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
......@@ -758,16 +767,24 @@ gfc_simplify_acosh (gfc_expr *x)
if (x->expr_type != EXPR_CONSTANT)
return NULL;
if (mpfr_cmp_si (x->value.real, 1) < 0)
switch (x->ts.type)
{
gfc_error ("Argument of ACOSH at %L must not be less than 1",
&x->where);
return &gfc_bad_expr;
}
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
case BT_REAL:
if (mpfr_cmp_si (x->value.real, 1) < 0)
{
gfc_error ("Argument of ACOSH at %L must not be less than 1",
&x->where);
return &gfc_bad_expr;
}
mpfr_acosh (result->value.real, x->value.real, GFC_RND_MODE);
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
mpfr_acosh (result->value.real, x->value.real, GFC_RND_MODE);
break;
case BT_COMPLEX:
return NULL;
default:
gfc_internal_error ("in gfc_simplify_cos(): Bad type");
}
return range_check (result, "ACOSH");
}
......@@ -1012,18 +1029,25 @@ gfc_simplify_asin (gfc_expr *x)
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)
switch (x->ts.type)
{
gfc_error ("Argument of ASIN at %L must be between -1 and 1",
&x->where);
return &gfc_bad_expr;
case BT_REAL:
if (mpfr_cmp_si (x->value.real, 1) > 0
|| mpfr_cmp_si (x->value.real, -1) < 0)
{
gfc_error ("Argument of ASIN at %L must be between -1 and 1",
&x->where);
return &gfc_bad_expr;
}
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE);
break;
case BT_COMPLEX:
return NULL;
default:
gfc_internal_error ("in gfc_simplify_cos(): Bad type");
}
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "ASIN");
}
......@@ -1036,9 +1060,17 @@ gfc_simplify_asinh (gfc_expr *x)
if (x->expr_type != EXPR_CONSTANT)
return NULL;
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
mpfr_asinh (result->value.real, x->value.real, GFC_RND_MODE);
switch (x->ts.type)
{
case BT_REAL:
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
mpfr_asinh (result->value.real, x->value.real, GFC_RND_MODE);
break;
case BT_COMPLEX:
return NULL;
default:
gfc_internal_error ("in gfc_simplify_cos(): Bad type");
}
return range_check (result, "ASINH");
}
......@@ -1052,9 +1084,17 @@ gfc_simplify_atan (gfc_expr *x)
if (x->expr_type != EXPR_CONSTANT)
return NULL;
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE);
switch (x->ts.type)
{
case BT_REAL:
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE);
break;
case BT_COMPLEX:
return NULL;
default:
gfc_internal_error ("in gfc_simplify_cos(): Bad type");
}
return range_check (result, "ATAN");
}
......@@ -1068,17 +1108,25 @@ gfc_simplify_atanh (gfc_expr *x)
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)
switch (x->ts.type)
{
gfc_error ("Argument of ATANH at %L must be inside the range -1 to 1",
&x->where);
return &gfc_bad_expr;
}
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
case BT_REAL:
if (mpfr_cmp_si (x->value.real, 1) >= 0
|| mpfr_cmp_si (x->value.real, -1) <= 0)
{
gfc_error ("Argument of ATANH at %L must be inside the range -1 "
"to 1", &x->where);
return &gfc_bad_expr;
}
mpfr_atanh (result->value.real, x->value.real, GFC_RND_MODE);
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
mpfr_atanh (result->value.real, x->value.real, GFC_RND_MODE);
break;
case BT_COMPLEX:
return NULL;
default:
gfc_internal_error ("in gfc_simplify_cos(): Bad type");
}
return range_check (result, "ATANH");
}
......@@ -1501,7 +1549,19 @@ gfc_simplify_cosh (gfc_expr *x)
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE);
if (x->ts.type == BT_REAL)
mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE);
else if (x->ts.type == BT_COMPLEX)
{
#if HAVE_mpc
mpc_cosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
#else
gfc_free_expr (result);
return NULL;
#endif
}
else
gcc_unreachable ();
return range_check (result, "COSH");
}
......@@ -5033,7 +5093,20 @@ gfc_simplify_sinh (gfc_expr *x)
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
if (x->ts.type == BT_REAL)
mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
else if (x->ts.type == BT_COMPLEX)
{
#if HAVE_mpc
mpc_sinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
#else
gfc_free_expr (result);
return NULL;
#endif
}
else
gcc_unreachable ();
return range_check (result, "SINH");
}
......@@ -5344,17 +5417,26 @@ gfc_simplify_sum (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
gfc_expr *
gfc_simplify_tan (gfc_expr *x)
{
int i;
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
if (x->ts.type == BT_REAL)
mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
else if (x->ts.type == BT_COMPLEX)
{
#if HAVE_mpc
mpc_tan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
#else
gfc_free_expr (result);
return NULL;
#endif
}
else
gcc_unreachable ();
return range_check (result, "TAN");
}
......@@ -5370,7 +5452,19 @@ gfc_simplify_tanh (gfc_expr *x)
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
if (x->ts.type == BT_REAL)
mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
else if (x->ts.type == BT_COMPLEX)
{
#if HAVE_mpc
mpc_tanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
#else
gfc_free_expr (result);
return NULL;
#endif
}
else
gcc_unreachable ();
return range_check (result, "TANH");
......
gcc/testsuite/ChangeLog
2009-07-25 Tobias Burnus <burnus@net-b.de>
PR fortran/33197
* gfortran.dg/complex_intrinsic_5.f90: New test.
* gfortran.dg/complex_intrinsic_7.f90: New test.
2009-07-25 Martin Jambor <mjambor@suse.cz>
* gcc.c-torture/execute/pr17377.c: Add noclone attribute to function y.
......
gcc/testsuite/gfortran.dg/complex_intrinsic_6.f90 0 → 100644
! { dg-do compile }
! { dg-options "-std=f2003" }
!
! PR fortran/33197
! PR fortran/40728
!
! Complex inverse trigonometric functions
! and complex inverse hyperbolic functions
!
! Argument type check
!
PROGRAM ArcTrigHyp
IMPLICIT NONE
real(4), volatile :: r4
real(8), volatile :: r8
complex(4), volatile :: z4
complex(8), volatile :: z8
r4 = 0.0_4
r8 = 0.0_8
z4 = cmplx(0.0_4, 0.0_4, kind=4)
z8 = cmplx(0.0_8, 0.0_8, kind=8)
r4 = asin(r4)
r8 = asin(r8)
r4 = acos(r4)
r8 = acos(r8)
r4 = atan(r4)
r8 = atan(r8)
! a(sin,cos,tan)h cannot be checked as they are not part of
! Fortran 2003 - not even for real arguments
z4 = asin(z4) ! { dg-error "Fortran 2008: COMPLEX argument" }
z8 = asin(z8) ! { dg-error "Fortran 2008: COMPLEX argument" }
z4 = acos(z4) ! { dg-error "Fortran 2008: COMPLEX argument" }
z8 = acos(z8) ! { dg-error "Fortran 2008: COMPLEX argument" }
z4 = atan(z4) ! { dg-error "Fortran 2008: COMPLEX argument" }
z8 = atan(z8) ! { dg-error "Fortran 2008: COMPLEX argument" }
END PROGRAM ArcTrigHyp
gcc/testsuite/gfortran.dg/complex_intrinsic_7.f90 0 → 100644
! { dg-do compile }
! { dg-require-effective-target mpc }
! { dg-options "-fdump-tree-original" }
!
! PR fortran/33197
!
! Fortran 2008 complex trigonometric functions: tan, cosh, sinh, tanh
!
! Compile-time simplificiations
!
implicit none
real(4), parameter :: pi = 2*acos(0.0_4)
real(8), parameter :: pi8 = 2*acos(0.0_8)
real(4), parameter :: eps = 10*epsilon(0.0_4)
real(8), parameter :: eps8 = 10*epsilon(0.0_8)
complex(4), parameter :: z0_0 = cmplx(0.0_4, 0.0_4, kind=4)
complex(4), parameter :: z1_1 = cmplx(1.0_4, 1.0_4, kind=4)
complex(4), parameter :: zp_p = cmplx(pi, pi, kind=4)
complex(8), parameter :: z80_0 = cmplx(0.0_8, 0.0_8, kind=8)
complex(8), parameter :: z81_1 = cmplx(1.0_8, 1.0_8, kind=8)
complex(8), parameter :: z8p_p = cmplx(pi8, pi8, kind=8)
if (abs(tan(z0_0) - cmplx(0.0,0.0,4)) > eps) call abort()
if (abs(tan(z1_1) - cmplx(0.27175257,1.0839232,4)) > eps) call abort()
if (abs(tan(z80_0) - cmplx(0.0_8,0.0_8,8)) > eps8) call abort()
if (abs(tan(z81_1) - cmplx(0.27175258531951174_8,1.0839233273386946_8,8)) > eps8) call abort()
if (abs(cosh(z0_0) - cmplx(1.0,0.0,4)) > eps) call abort()
if (abs(cosh(z1_1) - cmplx(0.83372992,0.98889768,4)) > eps) call abort()
if (abs(cosh(z80_0) - cmplx(1.0_8,0.0_8,8)) > eps8) call abort()
if (abs(cosh(z81_1) - cmplx(0.83373002513114913_8,0.98889770576286506_8,8)) > eps8) call abort()
if (abs(sinh(z0_0) - cmplx(0.0,0.0,4)) > eps) call abort()
if (abs(sinh(z1_1) - cmplx(0.63496387,1.2984575,4)) > eps) call abort()
if (abs(sinh(z80_0) - cmplx(0.0_8,0.0_8,8)) > eps8) call abort()
if (abs(sinh(z81_1) - cmplx(0.63496391478473613_8,1.2984575814159773_8,8)) > eps8) call abort()
if (abs(tanh(z0_0) - cmplx(0.0,0.0,4)) > eps) call abort()
if (abs(tanh(z1_1) - cmplx(1.0839232,0.27175257,4)) > eps) call abort()
if (abs(tanh(z80_0) - cmplx(0.0_8,0.0_8,8)) > eps8) call abort()
if (abs(tanh(z81_1) - cmplx(1.0839233273386946_8,0.27175258531951174_8,8)) > eps8) call abort()
end
! { dg-final { scan-tree-dump-times "abort" 0 "original" } }
! { dg-final { cleanup-tree-dump "original" } }
libgfortran/ChangeLog
2009-07-25 Tobias Burnus <burnus@net-b.de>
PR fortran/33197
* intrinsics/c99_functions.c (cacosf,cacos,cacosl,casinf,
casin,casind,catanf,catan,catanl,cacoshf,cacosh,cacoshl,
casinhf,casinh,casinhf,catanhf,catanh,catanhl): New functions.
* c99_protos.h: Add prototypes for those.
2009-07-24 Jakub Jelinek <jakub@redhat.com>
PR fortran/40643
......
libgfortran/c99_protos.h
......@@ -498,6 +498,115 @@ extern long double complex ctanl (long double complex);
#endif
/* Complex ACOS. */
#if !defined(HAVE_CACOSF) && defined(HAVE_CLOGF) && defined(HAVE_CSQRTF)
#define HAVE_CACOSF 1
extern complex float cacosf (complex float z);
#endif
#if !defined(HAVE_CACOS) && defined(HAVE_CLOG) && defined(HAVE_CSQRT)
#define HAVE_CACOS 1
extern complex double cacos (complex double z);
#endif
#if !defined(HAVE_CACOSL) && defined(HAVE_CLOGL) && defined(HAVE_CSQRTL)
#define HAVE_CACOSL 1
extern complex long double cacosl (complex long double z);
#endif
/* Complex ASIN. */
#if !defined(HAVE_CASINF) && defined(HAVE_CLOGF) && defined(HAVE_CSQRTF)
#define HAVE_CASINF 1
extern complex float casinf (complex float z);
#endif
#if !defined(HAVE_CASIN) && defined(HAVE_CLOG) && defined(HAVE_CSQRT)
#define HAVE_CASIN 1
extern complex double casin (complex double z);
#endif
#if !defined(HAVE_CASINL) && defined(HAVE_CLOGL) && defined(HAVE_CSQRTL)
#define HAVE_CASINL 1
extern complex long double casinl (complex long double z);
#endif
/* Complex ATAN. */
#if !defined(HAVE_CATANF) && defined(HAVE_CLOGF)
#define HAVE_CATANF 1
extern complex float catanf (complex float z);
#endif
#if !defined(HAVE_CATAN) && defined(HAVE_CLOG)
#define HAVE_CATAN 1
extern complex double catan (complex double z);
#endif
#if !defined(HAVE_CATANL) && defined(HAVE_CLOGL)
#define HAVE_CATANL 1
extern complex long double catanl (complex long double z);
#endif
/* Complex ASINH. */
#if !defined(HAVE_CASINHF) && defined(HAVE_CLOGF) && defined(HAVE_CSQRTF)
#define HAVE_CASINHF 1
extern complex float casinhf (complex float z);
#endif
#if !defined(HAVE_CASINH) && defined(HAVE_CLOG) && defined(HAVE_CSQRT)
#define HAVE_CASINH 1
extern complex double casinh (complex double z);
#endif
#if !defined(HAVE_CASINHL) && defined(HAVE_CLOGL) && defined(HAVE_CSQRTL)
#define HAVE_CASINHL 1
extern complex long double casinhl (complex long double z);
#endif
/* Complex ACOSH. */
#if !defined(HAVE_CACOSHF) && defined(HAVE_CLOGF) && defined(HAVE_CSQRTF)
#define HAVE_CACOSHF 1
extern complex float cacoshf (complex float z);
#endif
#if !defined(HAVE_CACOSH) && defined(HAVE_CLOG) && defined(HAVE_CSQRT)
#define HAVE_CACOSH 1
extern complex double cacosh (complex double z);
#endif
#if !defined(HAVE_CACOSHL) && defined(HAVE_CLOGL) && defined(HAVE_CSQRTL)
#define HAVE_CACOSHL 1
extern complex long double cacoshl (complex long double z);
#endif
/* Complex ATANH. */
#if !defined(HAVE_CATANHF) && defined(HAVE_CLOGF)
#define HAVE_CATANHF 1
extern complex float catanhf (complex float z);
#endif
#if !defined(HAVE_CATANH) && defined(HAVE_CLOG)
#define HAVE_CATANH 1
extern complex double catanh (complex double z);
#endif
#if !defined(HAVE_CATANHL) && defined(HAVE_CLOGL)
#define HAVE_CATANHL 1
extern complex long double catanhl (complex long double z);
#endif
/* Gamma-related prototypes. */
#if !defined(HAVE_TGAMMA)
#define HAVE_TGAMMA 1
......
libgfortran/intrinsics/c99_functions.c
......@@ -1412,6 +1412,203 @@ ctanl (long double complex a)
#endif
/* Complex ASIN. Returns wrongly NaN for infinite arguments.
Algorithm taken from Abramowitz & Stegun. */
#if !defined(HAVE_CASINF) && defined(HAVE_CLOGF) && defined(HAVE_CSQRTF)
#define HAVE_CASINF 1
complex float
casinf (complex float z)
{
return -I*clogf (I*z + csqrtf (1.0f-z*z));
}
#endif
#if !defined(HAVE_CASIN) && defined(HAVE_CLOG) && defined(HAVE_CSQRT)
#define HAVE_CASIN 1
complex double
casin (complex double z)
{
return -I*clog (I*z + csqrt (1.0-z*z));
}
#endif
#if !defined(HAVE_CASINL) && defined(HAVE_CLOGL) && defined(HAVE_CSQRTL)
#define HAVE_CASINL 1
complex long double
casinl (complex long double z)
{
return -I*clogl (I*z + csqrtl (1.0L-z*z));
}
#endif
/* Complex ACOS. Returns wrongly NaN for infinite arguments.
Algorithm taken from Abramowitz & Stegun. */
#if !defined(HAVE_CACOSF) && defined(HAVE_CLOGF) && defined(HAVE_CSQRTF)
#define HAVE_CACOSF 1
complex float
cacosf (complex float z)
{
return -I*clogf (z + I*csqrtf(1.0f-z*z));
}
#endif
complex double
#if !defined(HAVE_CACOS) && defined(HAVE_CLOG) && defined(HAVE_CSQRT)
#define HAVE_CACOS 1
cacos (complex double z)
{
return -I*clog (z + I*csqrt (1.0-z*z));
}
#endif
#if !defined(HAVE_CACOSL) && defined(HAVE_CLOGL) && defined(HAVE_CSQRTL)
#define HAVE_CACOSL 1
complex long double
cacosl (complex long double z)
{
return -I*clogl (z + I*csqrtl (1.0L-z*z));
}
#endif
/* Complex ATAN. Returns wrongly NaN for infinite arguments.
Algorithm taken from Abramowitz & Stegun. */
#if !defined(HAVE_CATANF) && defined(HAVE_CLOGF)
#define HAVE_CACOSF 1
complex float
catanf (complex float z)
{
return I*clogf ((I+z)/(I-z))/2.0f;
}
#endif
#if !defined(HAVE_CATAN) && defined(HAVE_CLOG)
#define HAVE_CACOS 1
complex double
catan (complex double z)
{
return I*clog ((I+z)/(I-z))/2.0;
}
#endif
#if !defined(HAVE_CATANL) && defined(HAVE_CLOGL)
#define HAVE_CACOSL 1
complex long double
catanl (complex long double z)
{
return I*clogl ((I+z)/(I-z))/2.0L;
}
#endif
/* Complex ASINH. Returns wrongly NaN for infinite arguments.
Algorithm taken from Abramowitz & Stegun. */
#if !defined(HAVE_CASINHF) && defined(HAVE_CLOGF) && defined(HAVE_CSQRTF)
#define HAVE_CASINHF 1
complex float
casinhf (complex float z)
{
return clogf (z + csqrtf (z*z+1.0f));
}
#endif
#if !defined(HAVE_CASINH) && defined(HAVE_CLOG) && defined(HAVE_CSQRT)
#define HAVE_CASINH 1
complex double
casinh (complex double z)
{
return clog (z + csqrt (z*z+1.0));
}
#endif
#if !defined(HAVE_CASINHL) && defined(HAVE_CLOGL) && defined(HAVE_CSQRTL)
#define HAVE_CASINHL 1
complex long double
casinhl (complex long double z)
{
return clogl (z + csqrtl (z*z+1.0L));
}
#endif
/* Complex ACOSH. Returns wrongly NaN for infinite arguments.
Algorithm taken from Abramowitz & Stegun. */
#if !defined(HAVE_CACOSHF) && defined(HAVE_CLOGF) && defined(HAVE_CSQRTF)
#define HAVE_CACOSHF 1
complex float
cacoshf (complex float z)
{
return clogf (z + csqrtf (z-1.0f) * csqrtf (z+1.0f));
}
#endif
#if !defined(HAVE_CACOSH) && defined(HAVE_CLOG) && defined(HAVE_CSQRT)
#define HAVE_CACOSH 1
complex double
cacosh (complex double z)
{
return clog (z + csqrt (z-1.0) * csqrt (z+1.0));
}
#endif
#if !defined(HAVE_CACOSHL) && defined(HAVE_CLOGL) && defined(HAVE_CSQRTL)
#define HAVE_CACOSHL 1
complex long double
cacoshl (complex long double z)
{
return clogl (z + csqrtl (z-1.0L) * csqrtl (z+1.0L));
}
#endif
/* Complex ATANH. Returns wrongly NaN for infinite arguments.
Algorithm taken from Abramowitz & Stegun. */
#if !defined(HAVE_CATANHF) && defined(HAVE_CLOGF)
#define HAVE_CATANHF 1
complex float
catanhf (complex float z)
{
return clogf ((1.0f+z)/(1.0f-z))/2.0f;
}
#endif
#if !defined(HAVE_CATANH) && defined(HAVE_CLOG)
#define HAVE_CATANH 1
complex double
catanh (complex double z)
{
return clog ((1.0+z)/(1.0-z))/2.0;
}
#endif
#if !defined(HAVE_CATANHL) && defined(HAVE_CLOGL)
#define HAVE_CATANHL 1
complex long double
catanhl (complex long double z)
{
return clogl ((1.0L+z)/(1.0L-z))/2.0L;
}
#endif
#if !defined(HAVE_TGAMMA)
#define HAVE_TGAMMA 1
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment