OSDN Git Service

* doc/invoke.texi (Overall Options): Document --help=.
[pf3gnuchains/gcc-fork.git] / gcc / fortran / arith.c
index 5871c55..39bc4b9 100644 (file)
@@ -1,6 +1,6 @@
 /* Compiler arithmetic
-   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation,
-   Inc.
+   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
+   Free Software Foundation, Inc.
    Contributed by Andy Vaught
 
 This file is part of GCC.
@@ -17,13 +17,13 @@ for more details.
 
 You should have received a copy of the GNU General Public License
 along with GCC; see the file COPYING.  If not, write to the Free
-Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA.  */
+Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA.  */
 
 /* Since target arithmetic must be done on the host, there has to
    be some way of evaluating arithmetic expressions as the host
-   would evaluate them.  We use the GNU MP library to do arithmetic,
-   and this file provides the interface.  */
+   would evaluate them.  We use the GNU MP library and the MPFR
+   library to do arithmetic, and this file provides the interface.  */
 
 #include "config.h"
 #include "system.h"
@@ -75,57 +75,6 @@ gfc_set_model (mpfr_t x)
   mpfr_set_default_prec (mpfr_get_prec (x));
 }
 
-/* Calculate atan2 (y, x)
-
-atan2(y, x) = atan(y/x)                                if x > 0,
-             sign(y)*(pi - atan(|y/x|))        if x < 0,
-             0                                 if x = 0 && y == 0,
-             sign(y)*pi/2                      if x = 0 && y != 0.
-*/
-
-void
-arctangent2 (mpfr_t y, mpfr_t x, mpfr_t result)
-{
-  int i;
-  mpfr_t t;
-
-  gfc_set_model (y);
-  mpfr_init (t);
-
-  i = mpfr_sgn (x);
-
-  if (i > 0)
-    {
-      mpfr_div (t, y, x, GFC_RND_MODE);
-      mpfr_atan (result, t, GFC_RND_MODE);
-    }
-  else if (i < 0)
-    {
-      mpfr_const_pi (result, GFC_RND_MODE);
-      mpfr_div (t, y, x, GFC_RND_MODE);
-      mpfr_abs (t, t, GFC_RND_MODE);
-      mpfr_atan (t, t, GFC_RND_MODE);
-      mpfr_sub (result, result, t, GFC_RND_MODE);
-      if (mpfr_sgn (y) < 0)
-       mpfr_neg (result, result, GFC_RND_MODE);
-    }
-  else
-    {
-      if (mpfr_sgn (y) == 0)
-       mpfr_set_ui (result, 0, GFC_RND_MODE);
-      else
-       {
-          mpfr_const_pi (result, GFC_RND_MODE);
-          mpfr_div_ui (result, result, 2, GFC_RND_MODE);
-         if (mpfr_sgn (y) < 0)
-           mpfr_neg (result, result, GFC_RND_MODE);
-       }
-    }
-
-  mpfr_clear (t);
-
-}
-
 
 /* Given an arithmetic error code, return a pointer to a string that
    explains the error.  */
@@ -138,25 +87,26 @@ gfc_arith_error (arith code)
   switch (code)
     {
     case ARITH_OK:
-      p = "Arithmetic OK";
+      p = _("Arithmetic OK at %L");
       break;
     case ARITH_OVERFLOW:
-      p = "Arithmetic overflow";
+      p = _("Arithmetic overflow at %L");
       break;
     case ARITH_UNDERFLOW:
-      p = "Arithmetic underflow";
+      p = _("Arithmetic underflow at %L");
       break;
     case ARITH_NAN:
-      p = "Arithmetic NaN";
+      p = _("Arithmetic NaN at %L");
       break;
     case ARITH_DIV0:
-      p = "Division by zero";
+      p = _("Division by zero at %L");
       break;
     case ARITH_INCOMMENSURATE:
-      p = "Array operands are incommensurate";
+      p = _("Array operands are incommensurate at %L");
       break;
     case ARITH_ASYMMETRIC:
-      p = "Integer outside symmetric range implied by Standard Fortran";
+      p =
+       _("Integer outside symmetric range implied by Standard Fortran at %L");
       break;
     default:
       gfc_internal_error ("gfc_arith_error(): Bad error code");
@@ -181,11 +131,11 @@ gfc_arith_init_1 (void)
   mpfr_init (a);
   mpz_init (r);
 
-  /* Convert the minimum/maximum values for each kind into their
+  /* Convert the minimum and maximum values for each kind into their
      GNU MP representation.  */
   for (int_info = gfc_integer_kinds; int_info->kind != 0; int_info++)
     {
-      /* Huge */
+      /* Huge  */
       mpz_set_ui (r, int_info->radix);
       mpz_pow_ui (r, r, int_info->digits);
 
@@ -193,16 +143,16 @@ gfc_arith_init_1 (void)
       mpz_sub_ui (int_info->huge, r, 1);
 
       /* These are the numbers that are actually representable by the
-         target.  For bases other than two, this needs to be changed.  */
+        target.  For bases other than two, this needs to be changed.  */
       if (int_info->radix != 2)
-        gfc_internal_error ("Fix min_int, max_int calculation");
+       gfc_internal_error ("Fix min_int calculation");
 
       /* See PRs 13490 and 17912, related to integer ranges.
-         The pedantic_min_int exists for range checking when a program
-         is compiled with -pedantic, and reflects the belief that
-         Standard Fortran requires integers to be symmetrical, i.e.
-         every negative integer must have a representable positive
-         absolute value, and vice versa.  */
+        The pedantic_min_int exists for range checking when a program
+        is compiled with -pedantic, and reflects the belief that
+        Standard Fortran requires integers to be symmetrical, i.e.
+        every negative integer must have a representable positive
+        absolute value, and vice versa.  */
 
       mpz_init (int_info->pedantic_min_int);
       mpz_neg (int_info->pedantic_min_int, int_info->huge);
@@ -210,11 +160,7 @@ gfc_arith_init_1 (void)
       mpz_init (int_info->min_int);
       mpz_sub_ui (int_info->min_int, int_info->pedantic_min_int, 1);
 
-      mpz_init (int_info->max_int);
-      mpz_add (int_info->max_int, int_info->huge, int_info->huge);
-      mpz_add_ui (int_info->max_int, int_info->max_int, 1);
-
-      /* Range */
+      /* Range  */
       mpfr_set_z (a, int_info->huge, GFC_RND_MODE);
       mpfr_log10 (a, a, GFC_RND_MODE);
       mpfr_trunc (a, a);
@@ -233,52 +179,61 @@ gfc_arith_init_1 (void)
       mpfr_init (c);
 
       /* huge(x) = (1 - b**(-p)) * b**(emax-1) * b  */
-      /* a = 1 - b**(-p) */
+      /* a = 1 - b**(-p)  */
       mpfr_set_ui (a, 1, GFC_RND_MODE);
       mpfr_set_ui (b, real_info->radix, GFC_RND_MODE);
       mpfr_pow_si (b, b, -real_info->digits, GFC_RND_MODE);
       mpfr_sub (a, a, b, GFC_RND_MODE);
 
-      /* c = b**(emax-1) */
+      /* c = b**(emax-1)  */
       mpfr_set_ui (b, real_info->radix, GFC_RND_MODE);
       mpfr_pow_ui (c, b, real_info->max_exponent - 1, GFC_RND_MODE);
 
-      /* a = a * c = (1 - b**(-p)) * b**(emax-1) */
+      /* a = a * c = (1 - b**(-p)) * b**(emax-1)  */
       mpfr_mul (a, a, c, GFC_RND_MODE);
 
-      /* a = (1 - b**(-p)) * b**(emax-1) * b */
+      /* a = (1 - b**(-p)) * b**(emax-1) * b  */
       mpfr_mul_ui (a, a, real_info->radix, GFC_RND_MODE);
 
       mpfr_init (real_info->huge);
       mpfr_set (real_info->huge, a, GFC_RND_MODE);
 
-      /* tiny(x) = b**(emin-1) */
+      /* tiny(x) = b**(emin-1)  */
       mpfr_set_ui (b, real_info->radix, GFC_RND_MODE);
       mpfr_pow_si (b, b, real_info->min_exponent - 1, GFC_RND_MODE);
 
       mpfr_init (real_info->tiny);
       mpfr_set (real_info->tiny, b, GFC_RND_MODE);
 
-      /* epsilon(x) = b**(1-p) */
+      /* subnormal (x) = b**(emin - digit)  */
+      mpfr_set_ui (b, real_info->radix, GFC_RND_MODE);
+      mpfr_pow_si (b, b, real_info->min_exponent - real_info->digits,
+                  GFC_RND_MODE);
+
+      mpfr_init (real_info->subnormal);
+      mpfr_set (real_info->subnormal, b, GFC_RND_MODE);
+
+      /* epsilon(x) = b**(1-p)  */
       mpfr_set_ui (b, real_info->radix, GFC_RND_MODE);
       mpfr_pow_si (b, b, 1 - real_info->digits, GFC_RND_MODE);
 
       mpfr_init (real_info->epsilon);
       mpfr_set (real_info->epsilon, b, GFC_RND_MODE);
 
-      /* range(x) = int(min(log10(huge(x)), -log10(tiny)) */
+      /* range(x) = int(min(log10(huge(x)), -log10(tiny))  */
       mpfr_log10 (a, real_info->huge, GFC_RND_MODE);
       mpfr_log10 (b, real_info->tiny, GFC_RND_MODE);
       mpfr_neg (b, b, GFC_RND_MODE);
 
+      /* a = min(a, b)  */
       if (mpfr_cmp (a, b) > 0)
-       mpfr_set (a, b, GFC_RND_MODE);          /* a = min(a, b) */
+       mpfr_set (a, b, GFC_RND_MODE);
 
       mpfr_trunc (a, a);
       gfc_mpfr_to_mpz (r, a);
       real_info->range = mpz_get_si (r);
 
-      /* precision(x) = int((p - 1) * log10(b)) + k */
+      /* precision(x) = int((p - 1) * log10(b)) + k  */
       mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
       mpfr_log10 (a, a, GFC_RND_MODE);
 
@@ -287,8 +242,7 @@ gfc_arith_init_1 (void)
       gfc_mpfr_to_mpz (r, a);
       real_info->precision = mpz_get_si (r);
 
-      /* If the radix is an integral power of 10, add one to the
-         precision.  */
+      /* If the radix is an integral power of 10, add one to the precision.  */
       for (i = 10; i <= real_info->radix; i *= 10)
        if (i == real_info->radix)
          real_info->precision++;
@@ -313,7 +267,7 @@ gfc_arith_done_1 (void)
   for (ip = gfc_integer_kinds; ip->kind; ip++)
     {
       mpz_clear (ip->min_int);
-      mpz_clear (ip->max_int);
+      mpz_clear (ip->pedantic_min_int);
       mpz_clear (ip->huge);
     }
 
@@ -322,6 +276,7 @@ gfc_arith_done_1 (void)
       mpfr_clear (rp->epsilon);
       mpfr_clear (rp->huge);
       mpfr_clear (rp->tiny);
+      mpfr_clear (rp->subnormal);
     }
 }
 
@@ -330,7 +285,7 @@ gfc_arith_done_1 (void)
    the range of the kind.  Returns ARITH_OK, ARITH_ASYMMETRIC or
    ARITH_OVERFLOW.  */
 
-static arith
+arith
 gfc_check_integer_range (mpz_t p, int kind)
 {
   arith result;
@@ -342,11 +297,15 @@ gfc_check_integer_range (mpz_t p, int kind)
   if (pedantic)
     {
       if (mpz_cmp (p, gfc_integer_kinds[i].pedantic_min_int) < 0)
-        result = ARITH_ASYMMETRIC;
+       result = ARITH_ASYMMETRIC;
     }
 
+
+  if (gfc_option.flag_range_check == 0)
+    return result;
+
   if (mpz_cmp (p, gfc_integer_kinds[i].min_int) < 0
-      || mpz_cmp (p, gfc_integer_kinds[i].max_int) > 0)
+      || mpz_cmp (p, gfc_integer_kinds[i].huge) > 0)
     result = ARITH_OVERFLOW;
 
   return result;
@@ -370,12 +329,63 @@ gfc_check_real_range (mpfr_t p, int kind)
   mpfr_init (q);
   mpfr_abs (q, p, GFC_RND_MODE);
 
-  if (mpfr_sgn (q) == 0)
+  if (mpfr_inf_p (p))
+    {
+      if (gfc_option.flag_range_check == 0)
+       retval = ARITH_OK;
+      else
+       retval = ARITH_OVERFLOW;
+    }
+  else if (mpfr_nan_p (p))
+    {
+      if (gfc_option.flag_range_check == 0)
+       retval = ARITH_OK;
+      else
+       retval = ARITH_NAN;
+    }
+  else if (mpfr_sgn (q) == 0)
     retval = ARITH_OK;
   else if (mpfr_cmp (q, gfc_real_kinds[i].huge) > 0)
-      retval = ARITH_OVERFLOW;
+    {
+      if (gfc_option.flag_range_check == 0)
+       retval = ARITH_OK;
+      else
+       retval = ARITH_OVERFLOW;
+    }
+  else if (mpfr_cmp (q, gfc_real_kinds[i].subnormal) < 0)
+    {
+      if (gfc_option.flag_range_check == 0)
+       retval = ARITH_OK;
+      else
+       retval = ARITH_UNDERFLOW;
+    }
   else if (mpfr_cmp (q, gfc_real_kinds[i].tiny) < 0)
-    retval = ARITH_UNDERFLOW;
+    {
+      mp_exp_t emin, emax;
+      int en;
+
+      /* Save current values of emin and emax.  */
+      emin = mpfr_get_emin ();
+      emax = mpfr_get_emax ();
+
+      /* Set emin and emax for the current model number.  */
+      en = gfc_real_kinds[i].min_exponent - gfc_real_kinds[i].digits + 1;
+      mpfr_set_emin ((mp_exp_t) en);
+      mpfr_set_emax ((mp_exp_t) gfc_real_kinds[i].max_exponent);
+      mpfr_subnormalize (q, 0, GFC_RND_MODE);
+
+      /* Reset emin and emax.  */
+      mpfr_set_emin (emin);
+      mpfr_set_emax (emax);
+
+      /* Copy sign if needed.  */
+      if (mpfr_sgn (p) < 0)
+       mpfr_neg (p, q, GMP_RNDN);
+      else
+       mpfr_set (p, q, GMP_RNDN);
+
+      retval = ARITH_OK;
+    }
   else
     retval = ARITH_OK;
 
@@ -385,17 +395,15 @@ gfc_check_real_range (mpfr_t p, int kind)
 }
 
 
-/* Function to return a constant expression node of a given type and
-   kind.  */
+/* Function to return a constant expression node of a given type and kind.  */
 
 gfc_expr *
-gfc_constant_result (bt type, int kind, locus * where)
+gfc_constant_result (bt type, int kind, locus *where)
 {
   gfc_expr *result;
 
   if (!where)
-    gfc_internal_error
-      ("gfc_constant_result(): locus 'where' cannot be NULL");
+    gfc_internal_error ("gfc_constant_result(): locus 'where' cannot be NULL");
 
   result = gfc_get_expr ();
 
@@ -436,7 +444,7 @@ gfc_constant_result (bt type, int kind, locus * where)
    zero raised to the zero, etc.  */
 
 static arith
-gfc_arith_not (gfc_expr * op1, gfc_expr ** resultp)
+gfc_arith_not (gfc_expr *op1, gfc_expr **resultp)
 {
   gfc_expr *result;
 
@@ -449,7 +457,7 @@ gfc_arith_not (gfc_expr * op1, gfc_expr ** resultp)
 
 
 static arith
-gfc_arith_and (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
+gfc_arith_and (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
 {
   gfc_expr *result;
 
@@ -463,7 +471,7 @@ gfc_arith_and (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
 
 
 static arith
-gfc_arith_or (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
+gfc_arith_or (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
 {
   gfc_expr *result;
 
@@ -477,7 +485,7 @@ gfc_arith_or (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
 
 
 static arith
-gfc_arith_eqv (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
+gfc_arith_eqv (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
 {
   gfc_expr *result;
 
@@ -491,7 +499,7 @@ gfc_arith_eqv (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
 
 
 static arith
-gfc_arith_neqv (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
+gfc_arith_neqv (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
 {
   gfc_expr *result;
 
@@ -509,7 +517,7 @@ gfc_arith_neqv (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
    but that one deals with the intrinsic RANGE function.  */
 
 arith
-gfc_range_check (gfc_expr * e)
+gfc_range_check (gfc_expr *e)
 {
   arith rc;
 
@@ -522,20 +530,29 @@ gfc_range_check (gfc_expr * e)
     case BT_REAL:
       rc = gfc_check_real_range (e->value.real, e->ts.kind);
       if (rc == ARITH_UNDERFLOW)
-        mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
+       mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
+      if (rc == ARITH_OVERFLOW)
+       mpfr_set_inf (e->value.real, mpfr_sgn (e->value.real));
+      if (rc == ARITH_NAN)
+       mpfr_set_nan (e->value.real);
       break;
 
     case BT_COMPLEX:
       rc = gfc_check_real_range (e->value.complex.r, e->ts.kind);
       if (rc == ARITH_UNDERFLOW)
-        mpfr_set_ui (e->value.complex.r, 0, GFC_RND_MODE);
-      if (rc == ARITH_OK || rc == ARITH_UNDERFLOW)
-        {
-          rc = gfc_check_real_range (e->value.complex.i, e->ts.kind);
-          if (rc == ARITH_UNDERFLOW)
-            mpfr_set_ui (e->value.complex.i, 0, GFC_RND_MODE);
-        }
+       mpfr_set_ui (e->value.complex.r, 0, GFC_RND_MODE);
+      if (rc == ARITH_OVERFLOW)
+       mpfr_set_inf (e->value.complex.r, mpfr_sgn (e->value.complex.r));
+      if (rc == ARITH_NAN)
+       mpfr_set_nan (e->value.complex.r);
 
+      rc = gfc_check_real_range (e->value.complex.i, e->ts.kind);
+      if (rc == ARITH_UNDERFLOW)
+       mpfr_set_ui (e->value.complex.i, 0, GFC_RND_MODE);
+      if (rc == ARITH_OVERFLOW)
+       mpfr_set_inf (e->value.complex.i, mpfr_sgn (e->value.complex.i));
+      if (rc == ARITH_NAN)
+       mpfr_set_nan (e->value.complex.i);
       break;
 
     default:
@@ -550,23 +567,29 @@ gfc_range_check (gfc_expr * e)
    check the validity of the result.  Encapsulate the checking here.  */
 
 static arith
-check_result (arith rc, gfc_expr * x, gfc_expr * r, gfc_expr ** rp)
+check_result (arith rc, gfc_expr *x, gfc_expr *r, gfc_expr **rp)
 {
-  if (rc != ARITH_OK)
-    gfc_free_expr (r);
-  else
-    {
-      if (rc == ARITH_UNDERFLOW && gfc_option.warn_underflow)
-        gfc_warning ("%s at %L", gfc_arith_error (rc), &x->where);
+  arith val = rc;
 
-      if (rc == ARITH_ASYMMETRIC)
-       gfc_warning ("%s at %L", gfc_arith_error (rc), &x->where);
+  if (val == ARITH_UNDERFLOW)
+    {
+      if (gfc_option.warn_underflow)
+       gfc_warning (gfc_arith_error (val), &x->where);
+      val = ARITH_OK;
+    }
 
-      rc = ARITH_OK;
-      *rp = r;
+  if (val == ARITH_ASYMMETRIC)
+    {
+      gfc_warning (gfc_arith_error (val), &x->where);
+      val = ARITH_OK;
     }
 
-  return rc;
+  if (val != ARITH_OK)
+    gfc_free_expr (r);
+  else
+    *rp = r;
+
+  return val;
 }
 
 
@@ -575,7 +598,7 @@ check_result (arith rc, gfc_expr * x, gfc_expr * r, gfc_expr ** rp)
    in the code elsewhere.  */
 
 static arith
-gfc_arith_uplus (gfc_expr * op1, gfc_expr ** resultp)
+gfc_arith_uplus (gfc_expr *op1, gfc_expr **resultp)
 {
   *resultp = gfc_copy_expr (op1);
   return ARITH_OK;
@@ -583,7 +606,7 @@ gfc_arith_uplus (gfc_expr * op1, gfc_expr ** resultp)
 
 
 static arith
-gfc_arith_uminus (gfc_expr * op1, gfc_expr ** resultp)
+gfc_arith_uminus (gfc_expr *op1, gfc_expr **resultp)
 {
   gfc_expr *result;
   arith rc;
@@ -616,7 +639,7 @@ gfc_arith_uminus (gfc_expr * op1, gfc_expr ** resultp)
 
 
 static arith
-gfc_arith_plus (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
+gfc_arith_plus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
 {
   gfc_expr *result;
   arith rc;
@@ -631,15 +654,15 @@ gfc_arith_plus (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
 
     case BT_REAL:
       mpfr_add (result->value.real, op1->value.real, op2->value.real,
-               GFC_RND_MODE);
+              GFC_RND_MODE);
       break;
 
     case BT_COMPLEX:
       mpfr_add (result->value.complex.r, op1->value.complex.r,
-              op2->value.complex.r, GFC_RND_MODE);
+               op2->value.complex.r, GFC_RND_MODE);
 
       mpfr_add (result->value.complex.i, op1->value.complex.i,
-              op2->value.complex.i, GFC_RND_MODE);
+               op2->value.complex.i, GFC_RND_MODE);
       break;
 
     default:
@@ -653,7 +676,7 @@ gfc_arith_plus (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
 
 
 static arith
-gfc_arith_minus (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
+gfc_arith_minus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
 {
   gfc_expr *result;
   arith rc;
@@ -668,15 +691,15 @@ gfc_arith_minus (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
 
     case BT_REAL:
       mpfr_sub (result->value.real, op1->value.real, op2->value.real,
-                GFC_RND_MODE);
+               GFC_RND_MODE);
       break;
 
     case BT_COMPLEX:
       mpfr_sub (result->value.complex.r, op1->value.complex.r,
-              op2->value.complex.r, GFC_RND_MODE);
+               op2->value.complex.r, GFC_RND_MODE);
 
       mpfr_sub (result->value.complex.i, op1->value.complex.i,
-              op2->value.complex.i, GFC_RND_MODE);
+               op2->value.complex.i, GFC_RND_MODE);
       break;
 
     default:
@@ -690,7 +713,7 @@ gfc_arith_minus (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
 
 
 static arith
-gfc_arith_times (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
+gfc_arith_times (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
 {
   gfc_expr *result;
   mpfr_t x, y;
@@ -706,13 +729,10 @@ gfc_arith_times (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
 
     case BT_REAL:
       mpfr_mul (result->value.real, op1->value.real, op2->value.real,
-               GFC_RND_MODE);
+              GFC_RND_MODE);
       break;
 
     case BT_COMPLEX:
-
-      /* FIXME:  possible numericals problem.  */
-
       gfc_set_model (op1->value.complex.r);
       mpfr_init (x);
       mpfr_init (y);
@@ -727,7 +747,6 @@ gfc_arith_times (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
 
       mpfr_clear (x);
       mpfr_clear (y);
-
       break;
 
     default:
@@ -741,7 +760,7 @@ gfc_arith_times (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
 
 
 static arith
-gfc_arith_divide (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
+gfc_arith_divide (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
 {
   gfc_expr *result;
   mpfr_t x, y, div;
@@ -765,21 +784,20 @@ gfc_arith_divide (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
       break;
 
     case BT_REAL:
-      /* FIXME: MPFR correctly generates NaN.  This may not be needed.  */
-      if (mpfr_sgn (op2->value.real) == 0)
+      if (mpfr_sgn (op2->value.real) == 0 && gfc_option.flag_range_check == 1)
        {
          rc = ARITH_DIV0;
          break;
        }
 
       mpfr_div (result->value.real, op1->value.real, op2->value.real,
-               GFC_RND_MODE);
+              GFC_RND_MODE);
       break;
 
     case BT_COMPLEX:
-      /* FIXME: MPFR correctly generates NaN.  This may not be needed.  */
       if (mpfr_sgn (op2->value.complex.r) == 0
-         && mpfr_sgn (op2->value.complex.i) == 0)
+         && mpfr_sgn (op2->value.complex.i) == 0
+         && gfc_option.flag_range_check == 1)
        {
          rc = ARITH_DIV0;
          break;
@@ -790,7 +808,6 @@ gfc_arith_divide (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
       mpfr_init (y);
       mpfr_init (div);
 
-      /* FIXME: possible numerical problems.  */
       mpfr_mul (x, op2->value.complex.r, op2->value.complex.r, GFC_RND_MODE);
       mpfr_mul (y, op2->value.complex.i, op2->value.complex.i, GFC_RND_MODE);
       mpfr_add (div, x, y, GFC_RND_MODE);
@@ -799,18 +816,17 @@ gfc_arith_divide (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
       mpfr_mul (y, op1->value.complex.i, op2->value.complex.i, GFC_RND_MODE);
       mpfr_add (result->value.complex.r, x, y, GFC_RND_MODE);
       mpfr_div (result->value.complex.r, result->value.complex.r, div,
-                GFC_RND_MODE);
+               GFC_RND_MODE);
 
       mpfr_mul (x, op1->value.complex.i, op2->value.complex.r, GFC_RND_MODE);
       mpfr_mul (y, op1->value.complex.r, op2->value.complex.i, GFC_RND_MODE);
       mpfr_sub (result->value.complex.i, x, y, GFC_RND_MODE);
       mpfr_div (result->value.complex.i, result->value.complex.i, div,
-                GFC_RND_MODE);
+               GFC_RND_MODE);
 
       mpfr_clear (x);
       mpfr_clear (y);
       mpfr_clear (div);
-
       break;
 
     default:
@@ -827,7 +843,7 @@ gfc_arith_divide (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
 /* Compute the reciprocal of a complex number (guaranteed nonzero).  */
 
 static void
-complex_reciprocal (gfc_expr * op)
+complex_reciprocal (gfc_expr *op)
 {
   mpfr_t mod, a, re, im;
 
@@ -837,7 +853,6 @@ complex_reciprocal (gfc_expr * op)
   mpfr_init (re);
   mpfr_init (im);
 
-  /* FIXME:  another possible numerical problem.  */
   mpfr_mul (mod, op->value.complex.r, op->value.complex.r, GFC_RND_MODE);
   mpfr_mul (a, op->value.complex.i, op->value.complex.i, GFC_RND_MODE);
   mpfr_add (mod, mod, a, GFC_RND_MODE);
@@ -860,7 +875,7 @@ complex_reciprocal (gfc_expr * op)
 /* Raise a complex number to positive power.  */
 
 static void
-complex_pow_ui (gfc_expr * base, int power, gfc_expr * result)
+complex_pow_ui (gfc_expr *base, int power, gfc_expr *result)
 {
   mpfr_t re, im, a;
 
@@ -875,15 +890,15 @@ complex_pow_ui (gfc_expr * base, int power, gfc_expr * result)
   for (; power > 0; power--)
     {
       mpfr_mul (re, base->value.complex.r, result->value.complex.r,
-                GFC_RND_MODE);
+               GFC_RND_MODE);
       mpfr_mul (a, base->value.complex.i, result->value.complex.i,
-                GFC_RND_MODE);
+               GFC_RND_MODE);
       mpfr_sub (re, re, a, GFC_RND_MODE);
 
       mpfr_mul (im, base->value.complex.r, result->value.complex.i,
-                GFC_RND_MODE);
+               GFC_RND_MODE);
       mpfr_mul (a, base->value.complex.i, result->value.complex.r,
-                GFC_RND_MODE);
+               GFC_RND_MODE);
       mpfr_add (im, im, a, GFC_RND_MODE);
 
       mpfr_set (result->value.complex.r, re, GFC_RND_MODE);
@@ -899,7 +914,7 @@ complex_pow_ui (gfc_expr * base, int power, gfc_expr * result)
 /* Raise a number to an integer power.  */
 
 static arith
-gfc_arith_power (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
+gfc_arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
 {
   int power, apower;
   gfc_expr *result;
@@ -956,20 +971,19 @@ gfc_arith_power (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
                          result->value.integer);
              mpz_clear (unity_z);
            }
-
          break;
 
        case BT_REAL:
          mpfr_pow_ui (result->value.real, op1->value.real, apower,
-                       GFC_RND_MODE);
+                      GFC_RND_MODE);
 
          if (power < 0)
            {
-              gfc_set_model (op1->value.real);
+             gfc_set_model (op1->value.real);
              mpfr_init (unity_f);
              mpfr_set_ui (unity_f, 1, GFC_RND_MODE);
              mpfr_div (result->value.real, unity_f, result->value.real,
-                        GFC_RND_MODE);
+                       GFC_RND_MODE);
              mpfr_clear (unity_f);
            }
          break;
@@ -995,7 +1009,7 @@ gfc_arith_power (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
 /* Concatenate two string constants.  */
 
 static arith
-gfc_arith_concat (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
+gfc_arith_concat (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
 {
   gfc_expr *result;
   int len;
@@ -1026,7 +1040,7 @@ gfc_arith_concat (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
    contain two constants of the same type.  */
 
 int
-gfc_compare_expr (gfc_expr * op1, gfc_expr * op2)
+gfc_compare_expr (gfc_expr *op1, gfc_expr *op2)
 {
   int rc;
 
@@ -1041,7 +1055,7 @@ gfc_compare_expr (gfc_expr * op1, gfc_expr * op2)
       break;
 
     case BT_CHARACTER:
-      rc = gfc_compare_string (op1, op2, NULL);
+      rc = gfc_compare_string (op1, op2);
       break;
 
     case BT_LOGICAL:
@@ -1058,23 +1072,22 @@ gfc_compare_expr (gfc_expr * op1, gfc_expr * op2)
 
 
 /* Compare a pair of complex numbers.  Naturally, this is only for
-   equality/nonequality.  */
+   equality and nonequality.  */
 
 static int
-compare_complex (gfc_expr * op1, gfc_expr * op2)
+compare_complex (gfc_expr *op1, gfc_expr *op2)
 {
   return (mpfr_cmp (op1->value.complex.r, op2->value.complex.r) == 0
          && mpfr_cmp (op1->value.complex.i, op2->value.complex.i) == 0);
 }
 
 
-/* Given two constant strings and the inverse collating sequence,
-   compare the strings.  We return -1 for a<b, 0 for a==b and 1 for
-   a>b.  If the xcoll_table is NULL, we use the processor's default
-   collating sequence.  */
+/* Given two constant strings and the inverse collating sequence, compare the
+   strings.  We return -1 for a < b, 0 for a == b and 1 for a > b. 
+   We use the processor's default collating sequence.  */
 
 int
-gfc_compare_string (gfc_expr * a, gfc_expr * b, const int *xcoll_table)
+gfc_compare_string (gfc_expr *a, gfc_expr *b)
 {
   int len, alen, blen, i, ac, bc;
 
@@ -1085,14 +1098,10 @@ gfc_compare_string (gfc_expr * a, gfc_expr * b, const int *xcoll_table)
 
   for (i = 0; i < len; i++)
     {
-      ac = (i < alen) ? a->value.character.string[i] : ' ';
-      bc = (i < blen) ? b->value.character.string[i] : ' ';
-
-      if (xcoll_table != NULL)
-       {
-         ac = xcoll_table[ac];
-         bc = xcoll_table[bc];
-       }
+      /* We cast to unsigned char because default char, if it is signed,
+        would lead to ac < 0 for string[i] > 127.  */
+      ac = (unsigned char) ((i < alen) ? a->value.character.string[i] : ' ');
+      bc = (unsigned char) ((i < blen) ? b->value.character.string[i] : ' ');
 
       if (ac < bc)
        return -1;
@@ -1109,14 +1118,15 @@ gfc_compare_string (gfc_expr * a, gfc_expr * b, const int *xcoll_table)
 /* Specific comparison subroutines.  */
 
 static arith
-gfc_arith_eq (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
+gfc_arith_eq (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
 {
   gfc_expr *result;
 
   result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
                                &op1->where);
-  result->value.logical = (op1->ts.type == BT_COMPLEX) ?
-    compare_complex (op1, op2) : (gfc_compare_expr (op1, op2) == 0);
+  result->value.logical = (op1->ts.type == BT_COMPLEX)
+                       ? compare_complex (op1, op2)
+                       : (gfc_compare_expr (op1, op2) == 0);
 
   *resultp = result;
   return ARITH_OK;
@@ -1124,14 +1134,15 @@ gfc_arith_eq (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
 
 
 static arith
-gfc_arith_ne (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
+gfc_arith_ne (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
 {
   gfc_expr *result;
 
   result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
                                &op1->where);
-  result->value.logical = (op1->ts.type == BT_COMPLEX) ?
-    !compare_complex (op1, op2) : (gfc_compare_expr (op1, op2) != 0);
+  result->value.logical = (op1->ts.type == BT_COMPLEX)
+                       ? !compare_complex (op1, op2)
+                       : (gfc_compare_expr (op1, op2) != 0);
 
   *resultp = result;
   return ARITH_OK;
@@ -1139,7 +1150,7 @@ gfc_arith_ne (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
 
 
 static arith
-gfc_arith_gt (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
+gfc_arith_gt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
 {
   gfc_expr *result;
 
@@ -1153,7 +1164,7 @@ gfc_arith_gt (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
 
 
 static arith
-gfc_arith_ge (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
+gfc_arith_ge (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
 {
   gfc_expr *result;
 
@@ -1167,7 +1178,7 @@ gfc_arith_ge (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
 
 
 static arith
-gfc_arith_lt (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
+gfc_arith_lt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
 {
   gfc_expr *result;
 
@@ -1181,7 +1192,7 @@ gfc_arith_lt (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
 
 
 static arith
-gfc_arith_le (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
+gfc_arith_le (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
 {
   gfc_expr *result;
 
@@ -1195,8 +1206,8 @@ gfc_arith_le (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
 
 
 static arith
-reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr * op,
-             gfc_expr ** result)
+reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr *op,
+             gfc_expr **result)
 {
   gfc_constructor *c, *head;
   gfc_expr *r;
@@ -1239,8 +1250,7 @@ reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr * op,
 
 static arith
 reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
-                 gfc_expr * op1, gfc_expr * op2,
-                 gfc_expr ** result)
+                 gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
 {
   gfc_constructor *c, *head;
   gfc_expr *r;
@@ -1280,8 +1290,7 @@ reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
 
 static arith
 reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
-                 gfc_expr * op1, gfc_expr * op2,
-                 gfc_expr ** result)
+                 gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
 {
   gfc_constructor *c, *head;
   gfc_expr *r;
@@ -1321,8 +1330,7 @@ reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
 
 static arith
 reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
-                 gfc_expr * op1, gfc_expr * op2,
-                 gfc_expr ** result)
+                 gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
 {
   gfc_constructor *c, *d, *head;
   gfc_expr *r;
@@ -1338,7 +1346,6 @@ reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
     rc = ARITH_INCOMMENSURATE;
   else
     {
-
       for (c = head; c; c = c->next, d = d->next)
        {
          if (d == NULL)
@@ -1380,8 +1387,7 @@ reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
 
 static arith
 reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
-              gfc_expr * op1, gfc_expr * op2,
-              gfc_expr ** result)
+              gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
 {
   if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_CONSTANT)
     return eval (op1, op2, result);
@@ -1415,7 +1421,7 @@ eval_f;
 
 static gfc_expr *
 eval_intrinsic (gfc_intrinsic_op operator,
-               eval_f eval, gfc_expr * op1, gfc_expr * op2)
+               eval_f eval, gfc_expr *op1, gfc_expr *op2)
 {
   gfc_expr temp, *result;
   int unary;
@@ -1425,17 +1431,17 @@ eval_intrinsic (gfc_intrinsic_op operator,
 
   switch (operator)
     {
-    case INTRINSIC_NOT:        /* Logical unary */
+    /* Logical unary  */
+    case INTRINSIC_NOT:
       if (op1->ts.type != BT_LOGICAL)
        goto runtime;
 
       temp.ts.type = BT_LOGICAL;
       temp.ts.kind = gfc_default_logical_kind;
-
       unary = 1;
       break;
 
-      /* Logical binary operators */
+    /* Logical binary operators  */
     case INTRINSIC_OR:
     case INTRINSIC_AND:
     case INTRINSIC_NEQV:
@@ -1445,23 +1451,28 @@ eval_intrinsic (gfc_intrinsic_op operator,
 
       temp.ts.type = BT_LOGICAL;
       temp.ts.kind = gfc_default_logical_kind;
-
       unary = 0;
       break;
 
+    /* Numeric unary  */
     case INTRINSIC_UPLUS:
-    case INTRINSIC_UMINUS:     /* Numeric unary */
+    case INTRINSIC_UMINUS:
       if (!gfc_numeric_ts (&op1->ts))
        goto runtime;
 
       temp.ts = op1->ts;
+      unary = 1;
+      break;
 
+    case INTRINSIC_PARENTHESES:
+      temp.ts = op1->ts;
       unary = 1;
       break;
 
+    /* Additional restrictions for ordering relations.  */
     case INTRINSIC_GE:
-    case INTRINSIC_LT:         /* Additional restrictions  */
-    case INTRINSIC_LE:          /* for ordering relations.  */
+    case INTRINSIC_LT:
+    case INTRINSIC_LE:
     case INTRINSIC_GT:
       if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
        {
@@ -1470,8 +1481,7 @@ eval_intrinsic (gfc_intrinsic_op operator,
          goto runtime;
        }
 
-      /* else fall through */
-
+    /* Fall through  */
     case INTRINSIC_EQ:
     case INTRINSIC_NE:
       if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
@@ -1482,17 +1492,18 @@ eval_intrinsic (gfc_intrinsic_op operator,
          break;
        }
 
-      /* else fall through */
-
+    /* Fall through  */
+    /* Numeric binary  */
     case INTRINSIC_PLUS:
     case INTRINSIC_MINUS:
     case INTRINSIC_TIMES:
     case INTRINSIC_DIVIDE:
-    case INTRINSIC_POWER:      /* Numeric binary */
+    case INTRINSIC_POWER:
       if (!gfc_numeric_ts (&op1->ts) || !gfc_numeric_ts (&op2->ts))
        goto runtime;
 
-      /* Insert any necessary type conversions to make the operands compatible.  */
+      /* Insert any necessary type conversions to make the operands
+        compatible.  */
 
       temp.expr_type = EXPR_OP;
       gfc_clear_ts (&temp.ts);
@@ -1514,13 +1525,13 @@ eval_intrinsic (gfc_intrinsic_op operator,
       unary = 0;
       break;
 
-    case INTRINSIC_CONCAT:     /* Character binary */
+    /* Character binary  */
+    case INTRINSIC_CONCAT:
       if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER)
        goto runtime;
 
       temp.ts.type = BT_CHARACTER;
       temp.ts.kind = gfc_default_character_kind;
-
       unary = 0;
       break;
 
@@ -1535,17 +1546,17 @@ eval_intrinsic (gfc_intrinsic_op operator,
   if (operator == INTRINSIC_POWER && op2->ts.type != BT_INTEGER)
     goto runtime;
 
-  if (op1->expr_type != EXPR_CONSTANT
-      && (op1->expr_type != EXPR_ARRAY
-         || !gfc_is_constant_expr (op1)
-         || !gfc_expanded_ac (op1)))
+  if (op1->from_H
+      || (op1->expr_type != EXPR_CONSTANT
+         && (op1->expr_type != EXPR_ARRAY
+             || !gfc_is_constant_expr (op1) || !gfc_expanded_ac (op1))))
     goto runtime;
 
   if (op2 != NULL
-      && op2->expr_type != EXPR_CONSTANT
-      && (op2->expr_type != EXPR_ARRAY
-         || !gfc_is_constant_expr (op2)
-         || !gfc_expanded_ac (op2)))
+      && (op2->from_H
+         || (op2->expr_type != EXPR_CONSTANT
+             && (op2->expr_type != EXPR_ARRAY
+                 || !gfc_is_constant_expr (op2) || !gfc_expanded_ac (op2)))))
     goto runtime;
 
   if (unary)
@@ -1554,8 +1565,8 @@ eval_intrinsic (gfc_intrinsic_op operator,
     rc = reduce_binary (eval.f3, op1, op2, &result);
 
   if (rc != ARITH_OK)
-    {                          /* Something went wrong */
-      gfc_error ("%s at %L", gfc_arith_error (rc), &op1->where);
+    { /* Something went wrong.  */
+      gfc_error (gfc_arith_error (rc), &op1->where);
       return NULL;
     }
 
@@ -1564,7 +1575,7 @@ eval_intrinsic (gfc_intrinsic_op operator,
   return result;
 
 runtime:
-  /* Create a run-time expression */
+  /* Create a run-time expression */
   result = gfc_get_expr ();
   result->ts = temp.ts;
 
@@ -1581,6 +1592,7 @@ runtime:
 
 
 /* Modify type of expression for zero size array.  */
+
 static gfc_expr *
 eval_type_intrinsic0 (gfc_intrinsic_op operator, gfc_expr *op)
 {
@@ -1610,7 +1622,7 @@ eval_type_intrinsic0 (gfc_intrinsic_op operator, gfc_expr *op)
 /* Return nonzero if the expression is a zero size array.  */
 
 static int
-gfc_zero_size_array (gfc_expr * e)
+gfc_zero_size_array (gfc_expr *e)
 {
   if (e->expr_type != EXPR_ARRAY)
     return 0;
@@ -1624,7 +1636,7 @@ gfc_zero_size_array (gfc_expr * e)
    operands is a zero-length array.  */
 
 static gfc_expr *
-reduce_binary0 (gfc_expr * op1, gfc_expr * op2)
+reduce_binary0 (gfc_expr *op1, gfc_expr *op2)
 {
   if (gfc_zero_size_array (op1))
     {
@@ -1645,7 +1657,7 @@ reduce_binary0 (gfc_expr * op1, gfc_expr * op2)
 static gfc_expr *
 eval_intrinsic_f2 (gfc_intrinsic_op operator,
                   arith (*eval) (gfc_expr *, gfc_expr **),
-                  gfc_expr * op1, gfc_expr * op2)
+                  gfc_expr *op1, gfc_expr *op2)
 {
   gfc_expr *result;
   eval_f f;
@@ -1670,7 +1682,7 @@ eval_intrinsic_f2 (gfc_intrinsic_op operator,
 static gfc_expr *
 eval_intrinsic_f3 (gfc_intrinsic_op operator,
                   arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
-                  gfc_expr * op1, gfc_expr * op2)
+                  gfc_expr *op1, gfc_expr *op2)
 {
   gfc_expr *result;
   eval_f f;
@@ -1684,117 +1696,134 @@ eval_intrinsic_f3 (gfc_intrinsic_op operator,
 }
 
 
-
 gfc_expr *
-gfc_uplus (gfc_expr * op)
+gfc_uplus (gfc_expr *op)
 {
   return eval_intrinsic_f2 (INTRINSIC_UPLUS, gfc_arith_uplus, op, NULL);
 }
 
+
 gfc_expr *
-gfc_uminus (gfc_expr * op)
+gfc_uminus (gfc_expr *op)
 {
   return eval_intrinsic_f2 (INTRINSIC_UMINUS, gfc_arith_uminus, op, NULL);
 }
 
+
 gfc_expr *
-gfc_add (gfc_expr * op1, gfc_expr * op2)
+gfc_add (gfc_expr *op1, gfc_expr *op2)
 {
   return eval_intrinsic_f3 (INTRINSIC_PLUS, gfc_arith_plus, op1, op2);
 }
 
+
 gfc_expr *
-gfc_subtract (gfc_expr * op1, gfc_expr * op2)
+gfc_subtract (gfc_expr *op1, gfc_expr *op2)
 {
   return eval_intrinsic_f3 (INTRINSIC_MINUS, gfc_arith_minus, op1, op2);
 }
 
+
 gfc_expr *
-gfc_multiply (gfc_expr * op1, gfc_expr * op2)
+gfc_multiply (gfc_expr *op1, gfc_expr *op2)
 {
   return eval_intrinsic_f3 (INTRINSIC_TIMES, gfc_arith_times, op1, op2);
 }
 
+
 gfc_expr *
-gfc_divide (gfc_expr * op1, gfc_expr * op2)
+gfc_divide (gfc_expr *op1, gfc_expr *op2)
 {
   return eval_intrinsic_f3 (INTRINSIC_DIVIDE, gfc_arith_divide, op1, op2);
 }
 
+
 gfc_expr *
-gfc_power (gfc_expr * op1, gfc_expr * op2)
+gfc_power (gfc_expr *op1, gfc_expr *op2)
 {
   return eval_intrinsic_f3 (INTRINSIC_POWER, gfc_arith_power, op1, op2);
 }
 
+
 gfc_expr *
-gfc_concat (gfc_expr * op1, gfc_expr * op2)
+gfc_concat (gfc_expr *op1, gfc_expr *op2)
 {
   return eval_intrinsic_f3 (INTRINSIC_CONCAT, gfc_arith_concat, op1, op2);
 }
 
+
 gfc_expr *
-gfc_and (gfc_expr * op1, gfc_expr * op2)
+gfc_and (gfc_expr *op1, gfc_expr *op2)
 {
   return eval_intrinsic_f3 (INTRINSIC_AND, gfc_arith_and, op1, op2);
 }
 
+
 gfc_expr *
-gfc_or (gfc_expr * op1, gfc_expr * op2)
+gfc_or (gfc_expr *op1, gfc_expr *op2)
 {
   return eval_intrinsic_f3 (INTRINSIC_OR, gfc_arith_or, op1, op2);
 }
 
+
 gfc_expr *
-gfc_not (gfc_expr * op1)
+gfc_not (gfc_expr *op1)
 {
   return eval_intrinsic_f2 (INTRINSIC_NOT, gfc_arith_not, op1, NULL);
 }
 
+
 gfc_expr *
-gfc_eqv (gfc_expr * op1, gfc_expr * op2)
+gfc_eqv (gfc_expr *op1, gfc_expr *op2)
 {
   return eval_intrinsic_f3 (INTRINSIC_EQV, gfc_arith_eqv, op1, op2);
 }
 
+
 gfc_expr *
-gfc_neqv (gfc_expr * op1, gfc_expr * op2)
+gfc_neqv (gfc_expr *op1, gfc_expr *op2)
 {
   return eval_intrinsic_f3 (INTRINSIC_NEQV, gfc_arith_neqv, op1, op2);
 }
 
+
 gfc_expr *
-gfc_eq (gfc_expr * op1, gfc_expr * op2)
+gfc_eq (gfc_expr *op1, gfc_expr *op2)
 {
   return eval_intrinsic_f3 (INTRINSIC_EQ, gfc_arith_eq, op1, op2);
 }
 
+
 gfc_expr *
-gfc_ne (gfc_expr * op1, gfc_expr * op2)
+gfc_ne (gfc_expr *op1, gfc_expr *op2)
 {
   return eval_intrinsic_f3 (INTRINSIC_NE, gfc_arith_ne, op1, op2);
 }
 
+
 gfc_expr *
-gfc_gt (gfc_expr * op1, gfc_expr * op2)
+gfc_gt (gfc_expr *op1, gfc_expr *op2)
 {
   return eval_intrinsic_f3 (INTRINSIC_GT, gfc_arith_gt, op1, op2);
 }
 
+
 gfc_expr *
-gfc_ge (gfc_expr * op1, gfc_expr * op2)
+gfc_ge (gfc_expr *op1, gfc_expr *op2)
 {
   return eval_intrinsic_f3 (INTRINSIC_GE, gfc_arith_ge, op1, op2);
 }
 
+
 gfc_expr *
-gfc_lt (gfc_expr * op1, gfc_expr * op2)
+gfc_lt (gfc_expr *op1, gfc_expr *op2)
 {
   return eval_intrinsic_f3 (INTRINSIC_LT, gfc_arith_lt, op1, op2);
 }
 
+
 gfc_expr *
-gfc_le (gfc_expr * op1, gfc_expr * op2)
+gfc_le (gfc_expr *op1, gfc_expr *op2)
 {
   return eval_intrinsic_f3 (INTRINSIC_LE, gfc_arith_le, op1, op2);
 }
@@ -1803,13 +1832,13 @@ gfc_le (gfc_expr * op1, gfc_expr * op2)
 /* Convert an integer string to an expression node.  */
 
 gfc_expr *
-gfc_convert_integer (const char *buffer, int kind, int radix, locus * where)
+gfc_convert_integer (const char *buffer, int kind, int radix, locus *where)
 {
   gfc_expr *e;
   const char *t;
 
   e = gfc_constant_result (BT_INTEGER, kind, where);
-  /* a leading plus is allowed, but not by mpz_set_str */
+  /* A leading plus is allowed, but not by mpz_set_str.  */
   if (buffer[0] == '+')
     t = buffer + 1;
   else
@@ -1823,7 +1852,7 @@ gfc_convert_integer (const char *buffer, int kind, int radix, locus * where)
 /* Convert a real string to an expression node.  */
 
 gfc_expr *
-gfc_convert_real (const char *buffer, int kind, locus * where)
+gfc_convert_real (const char *buffer, int kind, locus *where)
 {
   gfc_expr *e;
 
@@ -1838,7 +1867,7 @@ gfc_convert_real (const char *buffer, int kind, locus * where)
    complex expression node.  */
 
 gfc_expr *
-gfc_convert_complex (gfc_expr * real, gfc_expr * imag, int kind)
+gfc_convert_complex (gfc_expr *real, gfc_expr *imag, int kind)
 {
   gfc_expr *e;
 
@@ -1856,19 +1885,52 @@ gfc_convert_complex (gfc_expr * real, gfc_expr * imag, int kind)
 /* Deal with an arithmetic error.  */
 
 static void
-arith_error (arith rc, gfc_typespec * from, gfc_typespec * to, locus * where)
+arith_error (arith rc, gfc_typespec *from, gfc_typespec *to, locus *where)
 {
-  gfc_error ("%s converting %s to %s at %L", gfc_arith_error (rc),
-            gfc_typename (from), gfc_typename (to), where);
+  switch (rc)
+    {
+    case ARITH_OK:
+      gfc_error ("Arithmetic OK converting %s to %s at %L",
+                gfc_typename (from), gfc_typename (to), where);
+      break;
+    case ARITH_OVERFLOW:
+      gfc_error ("Arithmetic overflow converting %s to %s at %L",
+                gfc_typename (from), gfc_typename (to), where);
+      break;
+    case ARITH_UNDERFLOW:
+      gfc_error ("Arithmetic underflow converting %s to %s at %L",
+                gfc_typename (from), gfc_typename (to), where);
+      break;
+    case ARITH_NAN:
+      gfc_error ("Arithmetic NaN converting %s to %s at %L",
+                gfc_typename (from), gfc_typename (to), where);
+      break;
+    case ARITH_DIV0:
+      gfc_error ("Division by zero converting %s to %s at %L",
+                gfc_typename (from), gfc_typename (to), where);
+      break;
+    case ARITH_INCOMMENSURATE:
+      gfc_error ("Array operands are incommensurate converting %s to %s at %L",
+                gfc_typename (from), gfc_typename (to), where);
+      break;
+    case ARITH_ASYMMETRIC:
+      gfc_error ("Integer outside symmetric range implied by Standard Fortran"
+                " converting %s to %s at %L",
+                gfc_typename (from), gfc_typename (to), where);
+      break;
+    default:
+      gfc_internal_error ("gfc_arith_error(): Bad error code");
+    }
 
   /* TODO: Do something about the error, ie, throw exception, return
      NaN, etc.  */
 }
 
+
 /* Convert integers to integers.  */
 
 gfc_expr *
-gfc_int2int (gfc_expr * src, int kind)
+gfc_int2int (gfc_expr *src, int kind)
 {
   gfc_expr *result;
   arith rc;
@@ -1877,19 +1939,18 @@ gfc_int2int (gfc_expr * src, int kind)
 
   mpz_set (result->value.integer, src->value.integer);
 
-  if ((rc = gfc_check_integer_range (result->value.integer, kind))
-      != ARITH_OK)
+  if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
     {
       if (rc == ARITH_ASYMMETRIC)
-        {
-          gfc_warning ("%s at %L", gfc_arith_error (rc), &src->where);
-        }
+       {
+         gfc_warning (gfc_arith_error (rc), &src->where);
+       }
       else
-        {
-          arith_error (rc, &src->ts, &result->ts, &src->where);
-          gfc_free_expr (result);
-          return NULL;
-        }
+       {
+         arith_error (rc, &src->ts, &result->ts, &src->where);
+         gfc_free_expr (result);
+         return NULL;
+       }
     }
 
   return result;
@@ -1899,7 +1960,7 @@ gfc_int2int (gfc_expr * src, int kind)
 /* Convert integers to reals.  */
 
 gfc_expr *
-gfc_int2real (gfc_expr * src, int kind)
+gfc_int2real (gfc_expr *src, int kind)
 {
   gfc_expr *result;
   arith rc;
@@ -1922,7 +1983,7 @@ gfc_int2real (gfc_expr * src, int kind)
 /* Convert default integer to default complex.  */
 
 gfc_expr *
-gfc_int2complex (gfc_expr * src, int kind)
+gfc_int2complex (gfc_expr *src, int kind)
 {
   gfc_expr *result;
   arith rc;
@@ -1946,7 +2007,7 @@ gfc_int2complex (gfc_expr * src, int kind)
 /* Convert default real to default integer.  */
 
 gfc_expr *
-gfc_real2int (gfc_expr * src, int kind)
+gfc_real2int (gfc_expr *src, int kind)
 {
   gfc_expr *result;
   arith rc;
@@ -1955,8 +2016,7 @@ gfc_real2int (gfc_expr * src, int kind)
 
   gfc_mpfr_to_mpz (result->value.integer, src->value.real);
 
-  if ((rc = gfc_check_integer_range (result->value.integer, kind))
-      != ARITH_OK)
+  if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
     {
       arith_error (rc, &src->ts, &result->ts, &src->where);
       gfc_free_expr (result);
@@ -1970,7 +2030,7 @@ gfc_real2int (gfc_expr * src, int kind)
 /* Convert real to real.  */
 
 gfc_expr *
-gfc_real2real (gfc_expr * src, int kind)
+gfc_real2real (gfc_expr *src, int kind)
 {
   gfc_expr *result;
   arith rc;
@@ -1984,7 +2044,7 @@ gfc_real2real (gfc_expr * src, int kind)
   if (rc == ARITH_UNDERFLOW)
     {
       if (gfc_option.warn_underflow)
-        gfc_warning ("%s at %L", gfc_arith_error (rc), &src->where);
+       gfc_warning (gfc_arith_error (rc), &src->where);
       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
     }
   else if (rc != ARITH_OK)
@@ -2001,7 +2061,7 @@ gfc_real2real (gfc_expr * src, int kind)
 /* Convert real to complex.  */
 
 gfc_expr *
-gfc_real2complex (gfc_expr * src, int kind)
+gfc_real2complex (gfc_expr *src, int kind)
 {
   gfc_expr *result;
   arith rc;
@@ -2016,7 +2076,7 @@ gfc_real2complex (gfc_expr * src, int kind)
   if (rc == ARITH_UNDERFLOW)
     {
       if (gfc_option.warn_underflow)
-        gfc_warning ("%s at %L", gfc_arith_error (rc), &src->where);
+       gfc_warning (gfc_arith_error (rc), &src->where);
       mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
     }
   else if (rc != ARITH_OK)
@@ -2033,7 +2093,7 @@ gfc_real2complex (gfc_expr * src, int kind)
 /* Convert complex to integer.  */
 
 gfc_expr *
-gfc_complex2int (gfc_expr * src, int kind)
+gfc_complex2int (gfc_expr *src, int kind)
 {
   gfc_expr *result;
   arith rc;
@@ -2042,8 +2102,7 @@ gfc_complex2int (gfc_expr * src, int kind)
 
   gfc_mpfr_to_mpz (result->value.integer, src->value.complex.r);
 
-  if ((rc = gfc_check_integer_range (result->value.integer, kind))
-      != ARITH_OK)
+  if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
     {
       arith_error (rc, &src->ts, &result->ts, &src->where);
       gfc_free_expr (result);
@@ -2057,7 +2116,7 @@ gfc_complex2int (gfc_expr * src, int kind)
 /* Convert complex to real.  */
 
 gfc_expr *
-gfc_complex2real (gfc_expr * src, int kind)
+gfc_complex2real (gfc_expr *src, int kind)
 {
   gfc_expr *result;
   arith rc;
@@ -2071,7 +2130,7 @@ gfc_complex2real (gfc_expr * src, int kind)
   if (rc == ARITH_UNDERFLOW)
     {
       if (gfc_option.warn_underflow)
-        gfc_warning ("%s at %L", gfc_arith_error (rc), &src->where);
+       gfc_warning (gfc_arith_error (rc), &src->where);
       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
     }
   if (rc != ARITH_OK)
@@ -2088,7 +2147,7 @@ gfc_complex2real (gfc_expr * src, int kind)
 /* Convert complex to complex.  */
 
 gfc_expr *
-gfc_complex2complex (gfc_expr * src, int kind)
+gfc_complex2complex (gfc_expr *src, int kind)
 {
   gfc_expr *result;
   arith rc;
@@ -2103,7 +2162,7 @@ gfc_complex2complex (gfc_expr * src, int kind)
   if (rc == ARITH_UNDERFLOW)
     {
       if (gfc_option.warn_underflow)
-        gfc_warning ("%s at %L", gfc_arith_error (rc), &src->where);
+       gfc_warning (gfc_arith_error (rc), &src->where);
       mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
     }
   else if (rc != ARITH_OK)
@@ -2118,7 +2177,7 @@ gfc_complex2complex (gfc_expr * src, int kind)
   if (rc == ARITH_UNDERFLOW)
     {
       if (gfc_option.warn_underflow)
-        gfc_warning ("%s at %L", gfc_arith_error (rc), &src->where);
+       gfc_warning (gfc_arith_error (rc), &src->where);
       mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
     }
   else if (rc != ARITH_OK)
@@ -2135,7 +2194,7 @@ gfc_complex2complex (gfc_expr * src, int kind)
 /* Logical kind conversion.  */
 
 gfc_expr *
-gfc_log2log (gfc_expr * src, int kind)
+gfc_log2log (gfc_expr *src, int kind)
 {
   gfc_expr *result;
 
@@ -2144,3 +2203,238 @@ gfc_log2log (gfc_expr * src, int kind)
 
   return result;
 }
+
+
+/* Convert logical to integer.  */
+
+gfc_expr *
+gfc_log2int (gfc_expr *src, int kind)
+{
+  gfc_expr *result;
+
+  result = gfc_constant_result (BT_INTEGER, kind, &src->where);
+  mpz_set_si (result->value.integer, src->value.logical);
+
+  return result;
+}
+
+
+/* Convert integer to logical.  */
+
+gfc_expr *
+gfc_int2log (gfc_expr *src, int kind)
+{
+  gfc_expr *result;
+
+  result = gfc_constant_result (BT_LOGICAL, kind, &src->where);
+  result->value.logical = (mpz_cmp_si (src->value.integer, 0) != 0);
+
+  return result;
+}
+
+
+/* Convert Hollerith to integer. The constant will be padded or truncated.  */
+
+gfc_expr *
+gfc_hollerith2int (gfc_expr *src, int kind)
+{
+  gfc_expr *result;
+  int len;
+
+  len = src->value.character.length;
+
+  result = gfc_get_expr ();
+  result->expr_type = EXPR_CONSTANT;
+  result->ts.type = BT_INTEGER;
+  result->ts.kind = kind;
+  result->where = src->where;
+  result->from_H = 1;
+
+  if (len > kind)
+    {
+      gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
+                  &src->where, gfc_typename(&result->ts));
+    }
+  result->value.character.string = gfc_getmem (kind + 1);
+  memcpy (result->value.character.string, src->value.character.string,
+       MIN (kind, len));
+
+  if (len < kind)
+    memset (&result->value.character.string[len], ' ', kind - len);
+
+  result->value.character.string[kind] = '\0'; /* For debugger  */
+  result->value.character.length = kind;
+
+  return result;
+}
+
+
+/* Convert Hollerith to real. The constant will be padded or truncated.  */
+
+gfc_expr *
+gfc_hollerith2real (gfc_expr *src, int kind)
+{
+  gfc_expr *result;
+  int len;
+
+  len = src->value.character.length;
+
+  result = gfc_get_expr ();
+  result->expr_type = EXPR_CONSTANT;
+  result->ts.type = BT_REAL;
+  result->ts.kind = kind;
+  result->where = src->where;
+  result->from_H = 1;
+
+  if (len > kind)
+    {
+      gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
+                  &src->where, gfc_typename(&result->ts));
+    }
+  result->value.character.string = gfc_getmem (kind + 1);
+  memcpy (result->value.character.string, src->value.character.string,
+       MIN (kind, len));
+
+  if (len < kind)
+    memset (&result->value.character.string[len], ' ', kind - len);
+
+  result->value.character.string[kind] = '\0'; /* For debugger.  */
+  result->value.character.length = kind;
+
+  return result;
+}
+
+
+/* Convert Hollerith to complex. The constant will be padded or truncated.  */
+
+gfc_expr *
+gfc_hollerith2complex (gfc_expr *src, int kind)
+{
+  gfc_expr *result;
+  int len;
+
+  len = src->value.character.length;
+
+  result = gfc_get_expr ();
+  result->expr_type = EXPR_CONSTANT;
+  result->ts.type = BT_COMPLEX;
+  result->ts.kind = kind;
+  result->where = src->where;
+  result->from_H = 1;
+
+  kind = kind * 2;
+
+  if (len > kind)
+    {
+      gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
+                  &src->where, gfc_typename(&result->ts));
+    }
+  result->value.character.string = gfc_getmem (kind + 1);
+  memcpy (result->value.character.string, src->value.character.string,
+         MIN (kind, len));
+
+  if (len < kind)
+    memset (&result->value.character.string[len], ' ', kind - len);
+
+  result->value.character.string[kind] = '\0'; /* For debugger  */
+  result->value.character.length = kind;
+
+  return result;
+}
+
+
+/* Convert Hollerith to character. */
+
+gfc_expr *
+gfc_hollerith2character (gfc_expr *src, int kind)
+{
+  gfc_expr *result;
+
+  result = gfc_copy_expr (src);
+  result->ts.type = BT_CHARACTER;
+  result->ts.kind = kind;
+  result->from_H = 1;
+
+  return result;
+}
+
+
+/* Convert Hollerith to logical. The constant will be padded or truncated.  */
+
+gfc_expr *
+gfc_hollerith2logical (gfc_expr *src, int kind)
+{
+  gfc_expr *result;
+  int len;
+
+  len = src->value.character.length;
+
+  result = gfc_get_expr ();
+  result->expr_type = EXPR_CONSTANT;
+  result->ts.type = BT_LOGICAL;
+  result->ts.kind = kind;
+  result->where = src->where;
+  result->from_H = 1;
+
+  if (len > kind)
+    {
+      gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
+                  &src->where, gfc_typename(&result->ts));
+    }
+  result->value.character.string = gfc_getmem (kind + 1);
+  memcpy (result->value.character.string, src->value.character.string,
+       MIN (kind, len));
+
+  if (len < kind)
+    memset (&result->value.character.string[len], ' ', kind - len);
+
+  result->value.character.string[kind] = '\0'; /* For debugger  */
+  result->value.character.length = kind;
+
+  return result;
+}
+
+
+/* Returns an initializer whose value is one higher than the value of the
+   LAST_INITIALIZER argument.  If the argument is NULL, the
+   initializers value will be set to zero.  The initializer's kind
+   will be set to gfc_c_int_kind.
+
+   If -fshort-enums is given, the appropriate kind will be selected
+   later after all enumerators have been parsed.  A warning is issued
+   here if an initializer exceeds gfc_c_int_kind.  */
+
+gfc_expr *
+gfc_enum_initializer (gfc_expr *last_initializer, locus where)
+{
+  gfc_expr *result;
+
+  result = gfc_get_expr ();
+  result->expr_type = EXPR_CONSTANT;
+  result->ts.type = BT_INTEGER;
+  result->ts.kind = gfc_c_int_kind;
+  result->where = where;
+
+  mpz_init (result->value.integer);
+
+  if (last_initializer != NULL)
+    {
+      mpz_add_ui (result->value.integer, last_initializer->value.integer, 1);
+      result->where = last_initializer->where;
+
+      if (gfc_check_integer_range (result->value.integer,
+            gfc_c_int_kind) != ARITH_OK)
+       {
+         gfc_error ("Enumerator exceeds the C integer type at %C");
+         return NULL;
+       }
+    }
+  else
+    {
+      /* Control comes here, if it's the very first enumerator and no
+        initializer has been given.  It will be initialized to zero.  */
+      mpz_set_si (result->value.integer, 0);
+    }
+
+  return result;
+}