2010-02-20 Paul Thomas <pault@gcc.gnu.org>

[pf3gnuchains/gcc-fork.git] / gcc / fortran / simplify.c

diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index 5269e8f..8768cb6 100644 (file)
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -214,26 +214,6 @@ convert_mpz_to_signed (mpz_t x, int bitsize)
     }
 }
 
-/* Helper function to convert to/from mpfr_t & mpc_t and call the
-   supplied mpc function on the respective values.  */
-
-#ifdef HAVE_mpc
-static void
-call_mpc_func (mpfr_ptr result_re, mpfr_ptr result_im,
-              mpfr_srcptr input_re, mpfr_srcptr input_im,
-              int (*func)(mpc_ptr, mpc_srcptr, mpc_rnd_t))
-{
-  mpc_t c;
-  mpc_init2 (c, mpfr_get_default_prec());
-  mpc_set_fr_fr (c, input_re, input_im, GFC_MPC_RND_MODE);
-  func (c, c, GFC_MPC_RND_MODE);
-  mpfr_set (result_re, mpc_realref (c), GFC_RND_MODE);
-  mpfr_set (result_im, mpc_imagref (c), GFC_RND_MODE);
-  mpc_clear (c);
-}
-#endif
-
-
 /* Test that the expression is an constant array.  */
 
 static bool
@@ -303,8 +283,7 @@ init_result_expr (gfc_expr *e, int init, gfc_expr *array)
            break;
 
          case BT_COMPLEX:
-           mpfr_set_si (e->value.complex.r, init, GFC_RND_MODE);
-           mpfr_set_si (e->value.complex.i, 0, GFC_RND_MODE);
+           mpc_set_si (e->value.complex, init, GFC_MPC_RND_MODE);
            break;
 
          case BT_CHARACTER:
@@ -660,8 +639,7 @@ gfc_simplify_abs (gfc_expr *e)
 
       gfc_set_model_kind (e->ts.kind);
 
-      mpfr_hypot (result->value.real, e->value.complex.r, 
-                 e->value.complex.i, GFC_RND_MODE);
+      mpc_abs (result->value.real, e->value.complex, GFC_RND_MODE);
       result = range_check (result, "CABS");
       break;
 
@@ -747,17 +725,27 @@ 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;
+         }
+       result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+       mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE);
+       break;
+      case BT_COMPLEX:
+       result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+       mpc_acos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+       break;
+      default:
+       gfc_internal_error ("in gfc_simplify_acos(): Bad type");
     }
 
-  result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
-
-  mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE);
 
   return range_check (result, "ACOS");
 }
@@ -770,16 +758,26 @@ 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:
+       result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+       mpc_acosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+       break;
+      default:
+       gfc_internal_error ("in gfc_simplify_acosh(): Bad type");
+    }
 
   return range_check (result, "ACOSH");
 }
@@ -867,7 +865,7 @@ gfc_simplify_aimag (gfc_expr *e)
     return NULL;
 
   result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
-  mpfr_set (result->value.real, e->value.complex.i, GFC_RND_MODE);
+  mpfr_set (result->value.real, mpc_imagref (e->value.complex), GFC_RND_MODE);
 
   return range_check (result, "AIMAG");
 }
@@ -1024,18 +1022,27 @@ 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:
+       result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+       mpc_asin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+       break;
+      default:
+       gfc_internal_error ("in gfc_simplify_asin(): 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");
 }
 
@@ -1048,9 +1055,19 @@ 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:
+       result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+       mpc_asinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+       break;
+      default:
+       gfc_internal_error ("in gfc_simplify_asinh(): Bad type");
+    }
 
   return range_check (result, "ASINH");
 }
@@ -1064,9 +1081,19 @@ 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:
+       result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+       mpc_atan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+       break;
+      default:
+       gfc_internal_error ("in gfc_simplify_atan(): Bad type");
+    }
 
   return range_check (result, "ATAN");
 }
@@ -1080,17 +1107,27 @@ 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:
+       result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+       mpc_atanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+       break;
+      default:
+       gfc_internal_error ("in gfc_simplify_atanh(): Bad type");
+    }
 
   return range_check (result, "ATANH");
 }
@@ -1286,22 +1323,19 @@ simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
 
   result = gfc_constant_result (BT_COMPLEX, kind, &x->where);
 
-  mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
-
   switch (x->ts.type)
     {
     case BT_INTEGER:
       if (!x->is_boz)
-       mpfr_set_z (result->value.complex.r, x->value.integer, GFC_RND_MODE);
+       mpc_set_z (result->value.complex, x->value.integer, GFC_MPC_RND_MODE);
       break;
 
     case BT_REAL:
-      mpfr_set (result->value.complex.r, x->value.real, GFC_RND_MODE);
+      mpc_set_fr (result->value.complex, x->value.real, GFC_RND_MODE);
       break;
 
     case BT_COMPLEX:
-      mpfr_set (result->value.complex.r, x->value.complex.r, GFC_RND_MODE);
-      mpfr_set (result->value.complex.i, x->value.complex.i, GFC_RND_MODE);
+      mpc_set (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
       break;
 
     default:
@@ -1314,12 +1348,13 @@ simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
        {
        case BT_INTEGER:
          if (!y->is_boz)
-           mpfr_set_z (result->value.complex.i, y->value.integer,
-                       GFC_RND_MODE);
+           mpfr_set_z (mpc_imagref (result->value.complex),
+                       y->value.integer, GFC_RND_MODE);
          break;
 
        case BT_REAL:
-         mpfr_set (result->value.complex.i, y->value.real, GFC_RND_MODE);
+         mpfr_set (mpc_imagref (result->value.complex),
+                   y->value.real, GFC_RND_MODE);
          break;
 
        default:
@@ -1336,7 +1371,8 @@ simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
       ts.type = BT_REAL;
       if (!gfc_convert_boz (x, &ts))
        return &gfc_bad_expr;
-      mpfr_set (result->value.complex.r, x->value.real, GFC_RND_MODE);
+      mpfr_set (mpc_realref (result->value.complex),
+               x->value.real, GFC_RND_MODE);
     }
 
   if (y && y->is_boz)
@@ -1347,7 +1383,8 @@ simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
       ts.type = BT_REAL;
       if (!gfc_convert_boz (y, &ts))
        return &gfc_bad_expr;
-      mpfr_set (result->value.complex.i, y->value.real, GFC_RND_MODE);
+      mpfr_set (mpc_imagref (result->value.complex),
+               y->value.real, GFC_RND_MODE);
     }
 
   return range_check (result, name);
@@ -1429,8 +1466,7 @@ gfc_simplify_conjg (gfc_expr *e)
     return NULL;
 
   result = gfc_copy_expr (e);
-  mpfr_neg (result->value.complex.i, result->value.complex.i, GFC_RND_MODE);
-
+  mpc_conj (result->value.complex, result->value.complex, GFC_MPC_RND_MODE);
   return range_check (result, "CONJG");
 }
 
@@ -1452,27 +1488,7 @@ gfc_simplify_cos (gfc_expr *x)
       break;
     case BT_COMPLEX:
       gfc_set_model_kind (x->ts.kind);
-#ifdef HAVE_mpc
-      call_mpc_func (result->value.complex.r, result->value.complex.i,
-                    x->value.complex.r, x->value.complex.i, mpc_cos);
-#else
-    {
-      mpfr_t xp, xq;
-      mpfr_init (xp);
-      mpfr_init (xq);
-
-      mpfr_cos  (xp, x->value.complex.r, GFC_RND_MODE);
-      mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE);
-      mpfr_mul (result->value.complex.r, xp, xq, GFC_RND_MODE);
-
-      mpfr_sin  (xp, x->value.complex.r, GFC_RND_MODE);
-      mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
-      mpfr_mul (xp, xp, xq, GFC_RND_MODE);
-      mpfr_neg (result->value.complex.i, xp, GFC_RND_MODE );
-
-      mpfr_clears (xp, xq, NULL);
-    }
-#endif
+      mpc_cos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
       break;
     default:
       gfc_internal_error ("in gfc_simplify_cos(): Bad type");
@@ -1493,7 +1509,12 @@ 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)
+    mpc_cosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+  else
+    gcc_unreachable ();
 
   return range_check (result, "COSH");
 }
@@ -1897,22 +1918,7 @@ gfc_simplify_exp (gfc_expr *x)
 
     case BT_COMPLEX:
       gfc_set_model_kind (x->ts.kind);
-#ifdef HAVE_mpc
-      call_mpc_func (result->value.complex.r, result->value.complex.i,
-                    x->value.complex.r, x->value.complex.i, mpc_exp);
-#else
-    {
-      mpfr_t xp, xq;
-      mpfr_init (xp);
-      mpfr_init (xq);
-      mpfr_exp (xq, x->value.complex.r, GFC_RND_MODE);
-      mpfr_cos (xp, x->value.complex.i, GFC_RND_MODE);
-      mpfr_mul (result->value.complex.r, xq, xp, GFC_RND_MODE);
-      mpfr_sin (xp, x->value.complex.i, GFC_RND_MODE);
-      mpfr_mul (result->value.complex.i, xq, xp, GFC_RND_MODE);
-      mpfr_clears (xp, xq, NULL);
-    }
-#endif
+      mpc_exp (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
       break;
 
     default:
@@ -3150,12 +3156,12 @@ gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
        }
     }
 
-  if (e->ts.cl != NULL && e->ts.cl->length != NULL
-      && e->ts.cl->length->expr_type == EXPR_CONSTANT
-      && e->ts.cl->length->ts.type == BT_INTEGER)
+  if (e->ts.u.cl != NULL && e->ts.u.cl->length != NULL
+      && e->ts.u.cl->length->expr_type == EXPR_CONSTANT
+      && e->ts.u.cl->length->ts.type == BT_INTEGER)
     {
       result = gfc_constant_result (BT_INTEGER, k, &e->where);
-      mpz_set (result->value.integer, e->ts.cl->length->value.integer);
+      mpz_set (result->value.integer, e->ts.u.cl->length->value.integer);
       if (gfc_range_check (result) == ARITH_OK)
        return result;
       else
@@ -3281,8 +3287,8 @@ gfc_simplify_log (gfc_expr *x)
       break;
 
     case BT_COMPLEX:
-      if ((mpfr_sgn (x->value.complex.r) == 0)
-         && (mpfr_sgn (x->value.complex.i) == 0))
+      if ((mpfr_sgn (mpc_realref (x->value.complex)) == 0)
+         && (mpfr_sgn (mpc_imagref (x->value.complex)) == 0))
        {
          gfc_error ("Complex argument of LOG at %L cannot be zero",
                     &x->where);
@@ -3291,27 +3297,7 @@ gfc_simplify_log (gfc_expr *x)
        }
 
       gfc_set_model_kind (x->ts.kind);
-#ifdef HAVE_mpc
-      call_mpc_func (result->value.complex.r, result->value.complex.i,
-                    x->value.complex.r, x->value.complex.i, mpc_log);
-#else
-    {
-      mpfr_t xr, xi;
-      mpfr_init (xr);
-      mpfr_init (xi);
-
-      mpfr_atan2 (result->value.complex.i, x->value.complex.i,
-                 x->value.complex.r, GFC_RND_MODE);
-
-      mpfr_mul (xr, x->value.complex.r, x->value.complex.r, GFC_RND_MODE);
-      mpfr_mul (xi, x->value.complex.i, x->value.complex.i, GFC_RND_MODE);
-      mpfr_add (xr, xr, xi, GFC_RND_MODE);
-      mpfr_sqrt (xr, xr, GFC_RND_MODE);
-      mpfr_log (result->value.complex.r, xr, GFC_RND_MODE);
-
-      mpfr_clears (xr, xi, NULL);
-    }
-#endif
+      mpc_log (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
       break;
 
     default:
@@ -4036,7 +4022,7 @@ gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
   gfc_array_size (result, &result->shape[0]);
 
   if (array->ts.type == BT_CHARACTER)
-    result->ts.cl = array->ts.cl;
+    result->ts.u.cl = array->ts.u.cl;
 
   return result;
 }
@@ -4204,8 +4190,7 @@ gfc_simplify_realpart (gfc_expr *e)
     return NULL;
 
   result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
-  mpfr_set (result->value.real, e->value.complex.r, GFC_RND_MODE);
-
+  mpc_real (result->value.real, e->value.complex, GFC_RND_MODE);
   return range_check (result, "REALPART");
 }
 
@@ -4230,14 +4215,14 @@ gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
     }
 
   /* If we don't know the character length, we can do no more.  */
-  if (e->ts.cl && e->ts.cl->length
-       && e->ts.cl->length->expr_type == EXPR_CONSTANT)
+  if (e->ts.u.cl && e->ts.u.cl->length
+       && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
     {
-      len = mpz_get_si (e->ts.cl->length->value.integer);
+      len = mpz_get_si (e->ts.u.cl->length->value.integer);
       have_length = true;
     }
   else if (e->expr_type == EXPR_CONSTANT
-            && (e->ts.cl == NULL || e->ts.cl->length == NULL))
+            && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
     {
       len = e->value.character.length;
     }
@@ -4265,7 +4250,7 @@ gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
       if (have_length)
        {
          mpz_tdiv_q (max, gfc_integer_kinds[i].huge,
-                     e->ts.cl->length->value.integer);
+                     e->ts.u.cl->length->value.integer);
        }
       else
        {
@@ -4294,8 +4279,8 @@ gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
     return NULL;
 
   if (len || 
-      (e->ts.cl->length && 
-       mpz_sgn (e->ts.cl->length->value.integer)) != 0)
+      (e->ts.u.cl->length && 
+       mpz_sgn (e->ts.u.cl->length->value.integer)) != 0)
     {
       const char *res = gfc_extract_int (n, &ncop);
       gcc_assert (res == NULL);
@@ -4947,16 +4932,15 @@ gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
       mpz_abs (result->value.integer, x->value.integer);
       if (mpz_sgn (y->value.integer) < 0)
        mpz_neg (result->value.integer, result->value.integer);
-
       break;
 
     case BT_REAL:
-      /* TODO: Handle -0.0 and +0.0 correctly on machines that support
-        it.  */
-      mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
-      if (mpfr_sgn (y->value.real) < 0)
-       mpfr_neg (result->value.real, result->value.real, GFC_RND_MODE);
-
+      if (gfc_option.flag_sign_zero)
+       mpfr_copysign (result->value.real, x->value.real, y->value.real,
+                      GFC_RND_MODE);
+      else
+       mpfr_setsign (result->value.real, x->value.real,
+                     mpfr_sgn (y->value.real) < 0 ? 1 : 0, GFC_RND_MODE);
       break;
 
     default:
@@ -4985,26 +4969,7 @@ gfc_simplify_sin (gfc_expr *x)
 
     case BT_COMPLEX:
       gfc_set_model (x->value.real);
-#ifdef HAVE_mpc
-      call_mpc_func (result->value.complex.r, result->value.complex.i,
-                    x->value.complex.r, x->value.complex.i, mpc_sin);
-#else
-    {
-      mpfr_t xp, xq;
-      mpfr_init (xp);
-      mpfr_init (xq);
-
-      mpfr_sin  (xp, x->value.complex.r, GFC_RND_MODE);
-      mpfr_cosh (xq, x->value.complex.i, GFC_RND_MODE);
-      mpfr_mul (result->value.complex.r, xp, xq, GFC_RND_MODE);
-
-      mpfr_cos  (xp, x->value.complex.r, GFC_RND_MODE);
-      mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
-      mpfr_mul (result->value.complex.i, xp, xq, GFC_RND_MODE);
-
-      mpfr_clears (xp, xq, NULL);
-    }
-#endif
+      mpc_sin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
       break;
 
     default:
@@ -5025,7 +4990,13 @@ 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)
+    mpc_sinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+  else
+    gcc_unreachable ();
+
 
   return range_check (result, "SINH");
 }
@@ -5090,6 +5061,7 @@ gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_exp
 {
   gfc_expr *result = 0L;
   int i, j, dim, ncopies;
+  mpz_t size;
 
   if ((!gfc_is_constant_expr (source)
        && !is_constant_array_expr (source))
@@ -5105,6 +5077,19 @@ gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_exp
   gfc_extract_int (ncopies_expr, &ncopies);
   ncopies = MAX (ncopies, 0);
 
+  /* Do not allow the array size to exceed the limit for an array
+     constructor.  */
+  if (source->expr_type == EXPR_ARRAY)
+    {
+      if (gfc_array_size (source, &size) == FAILURE)
+       gfc_internal_error ("Failure getting length of a constant array.");
+    }
+  else
+    mpz_init_set_ui (size, 1);
+
+  if (mpz_get_si (size)*ncopies > gfc_option.flag_max_array_constructor)
+    return NULL;
+
   if (source->expr_type == EXPR_CONSTANT)
     {
       gcc_assert (dim == 0);
@@ -5172,7 +5157,7 @@ gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_exp
     return NULL;
 
   if (source->ts.type == BT_CHARACTER)
-    result->ts.cl = source->ts.cl;
+    result->ts.u.cl = source->ts.u.cl;
 
   return result;
 }
@@ -5199,88 +5184,7 @@ gfc_simplify_sqrt (gfc_expr *e)
 
     case BT_COMPLEX:
       gfc_set_model (e->value.real);
-#ifdef HAVE_mpc
-      call_mpc_func (result->value.complex.r, result->value.complex.i,
-                    e->value.complex.r, e->value.complex.i, mpc_sqrt);
-#else
-    {
-      /* Formula taken from Numerical Recipes to avoid over- and
-        underflow.  */
-
-      mpfr_t ac, ad, s, t, w;
-      mpfr_init (ac);
-      mpfr_init (ad);
-      mpfr_init (s);
-      mpfr_init (t);
-      mpfr_init (w);
-
-      if (mpfr_cmp_ui (e->value.complex.r, 0) == 0
-         && mpfr_cmp_ui (e->value.complex.i, 0) == 0)
-       {
-         mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
-         mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
-         break;
-       }
-
-      mpfr_abs (ac, e->value.complex.r, GFC_RND_MODE);
-      mpfr_abs (ad, e->value.complex.i, GFC_RND_MODE);
-
-      if (mpfr_cmp (ac, ad) >= 0)
-       {
-         mpfr_div (t, e->value.complex.i, e->value.complex.r, GFC_RND_MODE);
-         mpfr_mul (t, t, t, GFC_RND_MODE);
-         mpfr_add_ui (t, t, 1, GFC_RND_MODE);
-         mpfr_sqrt (t, t, GFC_RND_MODE);
-         mpfr_add_ui (t, t, 1, GFC_RND_MODE);
-         mpfr_div_ui (t, t, 2, GFC_RND_MODE);
-         mpfr_sqrt (t, t, GFC_RND_MODE);
-         mpfr_sqrt (s, ac, GFC_RND_MODE);
-         mpfr_mul (w, s, t, GFC_RND_MODE);
-       }
-      else
-       {
-         mpfr_div (s, e->value.complex.r, e->value.complex.i, GFC_RND_MODE);
-         mpfr_mul (t, s, s, GFC_RND_MODE);
-         mpfr_add_ui (t, t, 1, GFC_RND_MODE);
-         mpfr_sqrt (t, t, GFC_RND_MODE);
-         mpfr_abs (s, s, GFC_RND_MODE);
-         mpfr_add (t, t, s, GFC_RND_MODE);
-         mpfr_div_ui (t, t, 2, GFC_RND_MODE);
-         mpfr_sqrt (t, t, GFC_RND_MODE);
-         mpfr_sqrt (s, ad, GFC_RND_MODE);
-         mpfr_mul (w, s, t, GFC_RND_MODE);
-       }
-
-      if (mpfr_cmp_ui (w, 0) != 0 && mpfr_cmp_ui (e->value.complex.r, 0) >= 0)
-       {
-         mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
-         mpfr_div (result->value.complex.i, e->value.complex.i, t, GFC_RND_MODE);
-         mpfr_set (result->value.complex.r, w, GFC_RND_MODE);
-       }
-      else if (mpfr_cmp_ui (w, 0) != 0
-              && mpfr_cmp_ui (e->value.complex.r, 0) < 0
-              && mpfr_cmp_ui (e->value.complex.i, 0) >= 0)
-       {
-         mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
-         mpfr_div (result->value.complex.r, e->value.complex.i, t, GFC_RND_MODE);
-         mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
-       }
-      else if (mpfr_cmp_ui (w, 0) != 0
-              && mpfr_cmp_ui (e->value.complex.r, 0) < 0
-              && mpfr_cmp_ui (e->value.complex.i, 0) < 0)
-       {
-         mpfr_mul_ui (t, w, 2, GFC_RND_MODE);
-         mpfr_div (result->value.complex.r, ad, t, GFC_RND_MODE);
-         mpfr_neg (w, w, GFC_RND_MODE);
-         mpfr_set (result->value.complex.i, w, GFC_RND_MODE);
-       }
-      else
-       gfc_internal_error ("invalid complex argument of SQRT at %L",
-                           &e->where);
-
-      mpfr_clears (s, t, ac, ad, w, NULL);
-    }
-#endif
+      mpc_sqrt (result->value.complex, e->value.complex, GFC_MPC_RND_MODE);
       break;
 
     default:
@@ -5323,17 +5227,19 @@ 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)
+    mpc_tan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+  else
+    gcc_unreachable ();
 
   return range_check (result, "TAN");
 }
@@ -5349,7 +5255,12 @@ 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)
+    mpc_tanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+  else
+    gcc_unreachable ();
 
   return range_check (result, "TANH");
 
@@ -5508,7 +5419,7 @@ gfc_simplify_transpose (gfc_expr *matrix)
   mpz_set (result->shape[1], matrix->shape[0]);
 
   if (matrix->ts.type == BT_CHARACTER)
-    result->ts.cl = matrix->ts.cl;
+    result->ts.u.cl = matrix->ts.u.cl;
 
   matrix_rows = mpz_get_si (matrix->shape[0]);
   matrix_ctor = matrix->value.constructor;
@@ -5591,7 +5502,7 @@ gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
   result->shape = gfc_copy_shape (mask->shape, mask->rank);
 
   if (vector->ts.type == BT_CHARACTER)
-    result->ts.cl = vector->ts.cl;
+    result->ts.u.cl = vector->ts.u.cl;
 
   vector_ctor = vector->value.constructor;
   mask_ctor = mask->value.constructor;
@@ -5972,7 +5883,7 @@ gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind)
       result->shape = gfc_copy_shape (e->shape, e->rank);
       result->where = e->where;
       result->rank = e->rank;
-      result->ts.cl = e->ts.cl;
+      result->ts.u.cl = e->ts.u.cl;
 
       return result;
     }