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

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,6 +735,9 @@ gfc_simplify_acos (gfc_expr *x)
   if (x->expr_type != EXPR_CONSTANT)
     return NULL;
 
+  switch (x->ts.type)
+    {
+      case BT_REAL:
 	if (mpfr_cmp_si (x->value.real, 1) > 0
 	    || mpfr_cmp_si (x->value.real, -1) < 0)
 	  {
@@ -742,6 +745,12 @@ gfc_simplify_acos (gfc_expr *x)
 		       &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,6 +767,9 @@ gfc_simplify_acosh (gfc_expr *x)
   if (x->expr_type != EXPR_CONSTANT)
     return NULL;
 
+  switch (x->ts.type)
+    {
+      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",
@@ -766,8 +778,13 @@ gfc_simplify_acosh (gfc_expr *x)
 	  }
 
 	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,6 +1029,9 @@ gfc_simplify_asin (gfc_expr *x)
   if (x->expr_type != EXPR_CONSTANT)
     return NULL;
 
+  switch (x->ts.type)
+    {
+      case BT_REAL:
 	if (mpfr_cmp_si (x->value.real, 1) > 0
 	    || mpfr_cmp_si (x->value.real, -1) < 0)
 	  {
@@ -1019,10 +1039,14 @@ gfc_simplify_asin (gfc_expr *x)
 		       &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");
+    }
 
   return range_check (result, "ASIN");
 }
@@ -1036,9 +1060,17 @@ gfc_simplify_asinh (gfc_expr *x)
   if (x->expr_type != EXPR_CONSTANT)
     return NULL;
 
+  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;
     
+  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;
 
+  switch (x->ts.type)
+    {
+      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);
+	    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);
-
 	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);
 
+  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);
 
+  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);
 
+  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);
 
+  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

+! { 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

+! { 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