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

1 files changed, 138 insertions, 44 deletions

diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index c619f14..fa8a32a 100644
--- a/gcc/fortran/simplify.c
+++ b/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");