2008-10-30 Steven G. Kargl <kargls@comcast.net>

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

diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index 0ceb022..49a4aff 100644 (file)
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -1,5 +1,5 @@
 /* Simplify intrinsic functions at compile-time.
 /* Simplify intrinsic functions at compile-time.

-   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
+   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008

    Free Software Foundation, Inc.
    Contributed by Andy Vaught & Katherine Holcomb
 
    Free Software Foundation, Inc.
    Contributed by Andy Vaught & Katherine Holcomb
 


@@ -7,7 +7,7 @@ This file is part of GCC.
 
 GCC is free software; you can redistribute it and/or modify it under
 the terms of the GNU General Public License as published by the Free
 
 GCC is free software; you can redistribute it and/or modify it under
 the terms of the GNU General Public License as published by the Free

-Software Foundation; either version 2, or (at your option) any later
+Software Foundation; either version 3, or (at your option) any later

 version.
 
 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
 version.
 
 GCC is distributed in the hope that it will be useful, but WITHOUT ANY


@@ -16,9 +16,8 @@ FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
 for more details.
 
 You should have received a copy of the GNU General Public License
 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, 51 Franklin Street, Fifth Floor, Boston, MA
-02110-1301, USA.  */
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */

 
 #include "config.h"
 #include "system.h"
 
 #include "config.h"
 #include "system.h"


@@ -26,6 +25,7 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
 #include "gfortran.h"
 #include "arith.h"
 #include "intrinsic.h"
 #include "gfortran.h"
 #include "arith.h"
 #include "intrinsic.h"

+#include "target-memory.h"

 
 gfc_expr gfc_bad_expr;
 
 
 gfc_expr gfc_bad_expr;
 


@@ -70,6 +70,9 @@ gfc_expr gfc_bad_expr;
 static gfc_expr *
 range_check (gfc_expr *result, const char *name)
 {
 static gfc_expr *
 range_check (gfc_expr *result, const char *name)
 {

+  if (result == NULL)
+    return &gfc_bad_expr;
+

   switch (gfc_range_check (result))
     {
       case ARITH_OK:
   switch (gfc_range_check (result))
     {
       case ARITH_OK:


@@ -115,14 +118,12 @@ get_kind (bt type, gfc_expr *k, const char *name, int default_kind)
     {
       gfc_error ("KIND parameter of %s at %L must be an initialization "
                 "expression", name, &k->where);
     {
       gfc_error ("KIND parameter of %s at %L must be an initialization "
                 "expression", name, &k->where);

-

       return -1;
     }
 
   if (gfc_extract_int (k, &kind) != NULL
       || gfc_validate_kind (type, kind, true) < 0)
     {
       return -1;
     }
 
   if (gfc_extract_int (k, &kind) != NULL
       || gfc_validate_kind (type, kind, true) < 0)
     {

-

       gfc_error ("Invalid KIND parameter of %s at %L", name, &k->where);
       return -1;
     }
       gfc_error ("Invalid KIND parameter of %s at %L", name, &k->where);
       return -1;
     }


@@ -131,6 +132,20 @@ get_kind (bt type, gfc_expr *k, const char *name, int default_kind)
 }
 
 
 }
 
 

+/* Helper function to get an integer constant with a kind number given
+   by an integer constant expression.  */
+static gfc_expr *
+int_expr_with_kind (int i, gfc_expr *kind, const char *name)
+{
+  gfc_expr *res = gfc_int_expr (i);
+  res->ts.kind = get_kind (BT_INTEGER, kind, name, gfc_default_integer_kind); 
+  if (res->ts.kind == -1)
+    return NULL;
+  else
+    return res;
+}
+
+

 /* Converts an mpz_t signed variable into an unsigned one, assuming
    two's complement representations and a binary width of bitsize.
    The conversion is a no-op unless x is negative; otherwise, it can
 /* Converts an mpz_t signed variable into an unsigned one, assuming
    two's complement representations and a binary width of bitsize.
    The conversion is a no-op unless x is negative; otherwise, it can


@@ -241,40 +256,73 @@ gfc_simplify_abs (gfc_expr *e)
   return result;
 }
 
   return result;
 }
 

-/* We use the processor's collating sequence, because all
-   sytems that gfortran currently works on are ASCII.  */

 
 

-gfc_expr *
-gfc_simplify_achar (gfc_expr *e)
+static gfc_expr *
+simplify_achar_char (gfc_expr *e, gfc_expr *k, const char *name, bool ascii)

 {
   gfc_expr *result;
 {
   gfc_expr *result;

-  int c;
-  const char *ch;
+  int kind;
+  bool too_large = false;

 
   if (e->expr_type != EXPR_CONSTANT)
     return NULL;
 
 
   if (e->expr_type != EXPR_CONSTANT)
     return NULL;
 

-  ch = gfc_extract_int (e, &c);
-
-  if (ch != NULL)
-    gfc_internal_error ("gfc_simplify_achar: %s", ch);
+  kind = get_kind (BT_CHARACTER, k, name, gfc_default_character_kind);
+  if (kind == -1)
+    return &gfc_bad_expr;

 
 

-  if (gfc_option.warn_surprising && (c < 0 || c > 127))
-    gfc_warning ("Argument of ACHAR function at %L outside of range [0,127]",
+  if (mpz_cmp_si (e->value.integer, 0) < 0)
+    {
+      gfc_error ("Argument of %s function at %L is negative", name,

                 &e->where);
                 &e->where);

+      return &gfc_bad_expr;
+    }

 
 

-  result = gfc_constant_result (BT_CHARACTER, gfc_default_character_kind,
-                               &e->where);
+  if (ascii && gfc_option.warn_surprising
+      && mpz_cmp_si (e->value.integer, 127) > 0)
+    gfc_warning ("Argument of %s function at %L outside of range [0,127]",
+                name, &e->where);

 
 

-  result->value.character.string = gfc_getmem (2);
+  if (kind == 1 && mpz_cmp_si (e->value.integer, 255) > 0)
+    too_large = true;
+  else if (kind == 4)
+    {
+      mpz_t t;
+      mpz_init_set_ui (t, 2);
+      mpz_pow_ui (t, t, 32);
+      mpz_sub_ui (t, t, 1);
+      if (mpz_cmp (e->value.integer, t) > 0)
+       too_large = true;
+      mpz_clear (t);
+    }

 
 

+  if (too_large)
+    {
+      gfc_error ("Argument of %s function at %L is too large for the "
+                "collating sequence of kind %d", name, &e->where, kind);
+      return &gfc_bad_expr;
+    }
+
+  result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
+  result->value.character.string = gfc_get_wide_string (2);

   result->value.character.length = 1;
   result->value.character.length = 1;

-  result->value.character.string[0] = c;
+  result->value.character.string[0] = mpz_get_ui (e->value.integer);

   result->value.character.string[1] = '\0';    /* For debugger */
   return result;
 }
 
 
   result->value.character.string[1] = '\0';    /* For debugger */
   return result;
 }
 
 

+
+/* We use the processor's collating sequence, because all
+   systems that gfortran currently works on are ASCII.  */
+
+gfc_expr *
+gfc_simplify_achar (gfc_expr *e, gfc_expr *k)
+{
+  return simplify_achar_char (e, k, "ACHAR", true);
+}
+
+

 gfc_expr *
 gfc_simplify_acos (gfc_expr *x)
 {
 gfc_expr *
 gfc_simplify_acos (gfc_expr *x)
 {


@@ -325,7 +373,7 @@ gfc_simplify_adjustl (gfc_expr *e)
 {
   gfc_expr *result;
   int count, i, len;
 {
   gfc_expr *result;
   int count, i, len;

-  char ch;
+  gfc_char_t ch;

 
   if (e->expr_type != EXPR_CONSTANT)
     return NULL;
 
   if (e->expr_type != EXPR_CONSTANT)
     return NULL;


@@ -335,7 +383,7 @@ gfc_simplify_adjustl (gfc_expr *e)
   result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
 
   result->value.character.length = len;
   result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
 
   result->value.character.length = len;

-  result->value.character.string = gfc_getmem (len + 1);
+  result->value.character.string = gfc_get_wide_string (len + 1);

 
   for (count = 0, i = 0; i < len; ++i)
     {
 
   for (count = 0, i = 0; i < len; ++i)
     {


@@ -362,7 +410,7 @@ gfc_simplify_adjustr (gfc_expr *e)
 {
   gfc_expr *result;
   int count, i, len;
 {
   gfc_expr *result;
   int count, i, len;

-  char ch;
+  gfc_char_t ch;

 
   if (e->expr_type != EXPR_CONSTANT)
     return NULL;
 
   if (e->expr_type != EXPR_CONSTANT)
     return NULL;


@@ -372,7 +420,7 @@ gfc_simplify_adjustr (gfc_expr *e)
   result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
 
   result->value.character.length = len;
   result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
 
   result->value.character.length = len;

-  result->value.character.string = gfc_getmem (len + 1);
+  result->value.character.string = gfc_get_wide_string (len + 1);

 
   for (count = 0, i = len - 1; i >= 0; --i)
     {
 
   for (count = 0, i = len - 1; i >= 0; --i)
     {


@@ -487,14 +535,14 @@ gfc_simplify_and (gfc_expr *x, gfc_expr *y)
     {
       result = gfc_constant_result (BT_INTEGER, kind, &x->where);
       mpz_and (result->value.integer, x->value.integer, y->value.integer);
     {
       result = gfc_constant_result (BT_INTEGER, kind, &x->where);
       mpz_and (result->value.integer, x->value.integer, y->value.integer);

+      return range_check (result, "AND");

     }
   else /* BT_LOGICAL */
     {
       result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
       result->value.logical = x->value.logical && y->value.logical;
     }
   else /* BT_LOGICAL */
     {
       result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
       result->value.logical = x->value.logical && y->value.logical;

+      return result;

     }
     }

-
-  return range_check (result, "AND");

 }
 
 
 }
 
 


@@ -602,16 +650,15 @@ gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x)
   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
     return NULL;
 
   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
     return NULL;
 

-  result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
-

   if (mpfr_sgn (y->value.real) == 0 && mpfr_sgn (x->value.real) == 0)
     {
       gfc_error ("If first argument of ATAN2 %L is zero, then the "
                 "second argument must not be zero", &x->where);
   if (mpfr_sgn (y->value.real) == 0 && mpfr_sgn (x->value.real) == 0)
     {
       gfc_error ("If first argument of ATAN2 %L is zero, then the "
                 "second argument must not be zero", &x->where);

-      gfc_free_expr (result);

       return &gfc_bad_expr;
     }
 
       return &gfc_bad_expr;
     }
 

+  result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+

   mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE);
 
   return range_check (result, "ATAN2");
   mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE);
 
   return range_check (result, "ATAN2");


@@ -619,6 +666,102 @@ gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x)
 
 
 gfc_expr *
 
 
 gfc_expr *

+gfc_simplify_bessel_j0 (gfc_expr *x ATTRIBUTE_UNUSED)
+{
+  gfc_expr *result;
+
+  if (x->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+  mpfr_j0 (result->value.real, x->value.real, GFC_RND_MODE);
+
+  return range_check (result, "BESSEL_J0");
+}
+
+
+gfc_expr *
+gfc_simplify_bessel_j1 (gfc_expr *x ATTRIBUTE_UNUSED)
+{
+  gfc_expr *result;
+
+  if (x->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+  mpfr_j1 (result->value.real, x->value.real, GFC_RND_MODE);
+
+  return range_check (result, "BESSEL_J1");
+}
+
+
+gfc_expr *
+gfc_simplify_bessel_jn (gfc_expr *order ATTRIBUTE_UNUSED,
+                       gfc_expr *x ATTRIBUTE_UNUSED)
+{
+  gfc_expr *result;
+  long n;
+
+  if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  n = mpz_get_si (order->value.integer);
+  result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+  mpfr_jn (result->value.real, n, x->value.real, GFC_RND_MODE);
+
+  return range_check (result, "BESSEL_JN");
+}
+
+
+gfc_expr *
+gfc_simplify_bessel_y0 (gfc_expr *x ATTRIBUTE_UNUSED)
+{
+  gfc_expr *result;
+
+  if (x->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+  mpfr_y0 (result->value.real, x->value.real, GFC_RND_MODE);
+
+  return range_check (result, "BESSEL_Y0");
+}
+
+
+gfc_expr *
+gfc_simplify_bessel_y1 (gfc_expr *x ATTRIBUTE_UNUSED)
+{
+  gfc_expr *result;
+
+  if (x->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+  mpfr_y1 (result->value.real, x->value.real, GFC_RND_MODE);
+
+  return range_check (result, "BESSEL_Y1");
+}
+
+
+gfc_expr *
+gfc_simplify_bessel_yn (gfc_expr *order ATTRIBUTE_UNUSED,
+                       gfc_expr *x ATTRIBUTE_UNUSED)
+{
+  gfc_expr *result;
+  long n;
+
+  if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  n = mpz_get_si (order->value.integer);
+  result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+  mpfr_yn (result->value.real, n, x->value.real, GFC_RND_MODE);
+
+  return range_check (result, "BESSEL_YN");
+}
+
+
+gfc_expr *

 gfc_simplify_bit_size (gfc_expr *e)
 {
   gfc_expr *result;
 gfc_simplify_bit_size (gfc_expr *e)
 {
   gfc_expr *result;


@@ -665,7 +808,7 @@ gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k)
   ceil = gfc_copy_expr (e);
 
   mpfr_ceil (ceil->value.real, e->value.real);
   ceil = gfc_copy_expr (e);
 
   mpfr_ceil (ceil->value.real, e->value.real);

-  gfc_mpfr_to_mpz (result->value.integer, ceil->value.real);
+  gfc_mpfr_to_mpz (result->value.integer, ceil->value.real, &e->where);

 
   gfc_free_expr (ceil);
 
 
   gfc_free_expr (ceil);
 


@@ -676,35 +819,7 @@ gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k)
 gfc_expr *
 gfc_simplify_char (gfc_expr *e, gfc_expr *k)
 {
 gfc_expr *
 gfc_simplify_char (gfc_expr *e, gfc_expr *k)
 {

-  gfc_expr *result;
-  int c, kind;
-  const char *ch;
-
-  kind = get_kind (BT_CHARACTER, k, "CHAR", gfc_default_character_kind);
-  if (kind == -1)
-    return &gfc_bad_expr;
-
-  if (e->expr_type != EXPR_CONSTANT)
-    return NULL;
-
-  ch = gfc_extract_int (e, &c);
-
-  if (ch != NULL)
-    gfc_internal_error ("gfc_simplify_char: %s", ch);
-
-  if (c < 0 || c > UCHAR_MAX)
-    gfc_error ("Argument of CHAR function at %L outside of range [0,255]",
-              &e->where);
-
-  result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
-
-  result->value.character.length = 1;
-  result->value.character.string = gfc_getmem (2);
-
-  result->value.character.string[0] = c;
-  result->value.character.string[1] = '\0';    /* For debugger */
-
-  return result;
+  return simplify_achar_char (e, k, "CHAR", false);

 }
 
 
 }
 
 


@@ -722,7 +837,8 @@ simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
   switch (x->ts.type)
     {
     case BT_INTEGER:
   switch (x->ts.type)
     {
     case BT_INTEGER:

-      mpfr_set_z (result->value.complex.r, x->value.integer, GFC_RND_MODE);
+      if (!x->is_boz)
+       mpfr_set_z (result->value.complex.r, x->value.integer, GFC_RND_MODE);

       break;
 
     case BT_REAL:
       break;
 
     case BT_REAL:


@@ -743,7 +859,9 @@ simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
       switch (y->ts.type)
        {
        case BT_INTEGER:
       switch (y->ts.type)
        {
        case BT_INTEGER:

-         mpfr_set_z (result->value.complex.i, y->value.integer, GFC_RND_MODE);
+         if (!y->is_boz)
+           mpfr_set_z (result->value.complex.i, y->value.integer,
+                       GFC_RND_MODE);

          break;
 
        case BT_REAL:
          break;
 
        case BT_REAL:


@@ -755,23 +873,67 @@ simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
        }
     }
 
        }
     }
 

+  /* Handle BOZ.  */
+  if (x->is_boz)
+    {
+      gfc_typespec ts;
+      gfc_clear_ts (&ts);
+      ts.kind = result->ts.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);
+    }
+
+  if (y && y->is_boz)
+    {
+      gfc_typespec ts;
+      gfc_clear_ts (&ts);
+      ts.kind = result->ts.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);
+    }
+

   return range_check (result, name);
 }
 
 
   return range_check (result, name);
 }
 
 

+/* Function called when we won't simplify an expression like CMPLX (or
+   COMPLEX or DCMPLX) but still want to convert BOZ arguments.  */
+
+static gfc_expr *
+only_convert_cmplx_boz (gfc_expr *x, gfc_expr *y, int kind)
+{
+  gfc_typespec ts;
+  gfc_clear_ts (&ts);
+  ts.type = BT_REAL;
+  ts.kind = kind;
+
+  if (x->is_boz && !gfc_convert_boz (x, &ts))
+    return &gfc_bad_expr;
+
+  if (y && y->is_boz && !gfc_convert_boz (y, &ts))
+    return &gfc_bad_expr;
+
+  return NULL;
+}
+
+

 gfc_expr *
 gfc_simplify_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *k)
 {
   int kind;
 
 gfc_expr *
 gfc_simplify_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *k)
 {
   int kind;
 

-  if (x->expr_type != EXPR_CONSTANT
-      || (y != NULL && y->expr_type != EXPR_CONSTANT))
-    return NULL;
-

   kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_real_kind);
   if (kind == -1)
     return &gfc_bad_expr;
 
   kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_real_kind);
   if (kind == -1)
     return &gfc_bad_expr;
 

+  if (x->expr_type != EXPR_CONSTANT
+      || (y != NULL && y->expr_type != EXPR_CONSTANT))
+    return only_convert_cmplx_boz (x, y, kind);
+

   return simplify_cmplx ("CMPLX", x, y, kind);
 }
 
   return simplify_cmplx ("CMPLX", x, y, kind);
 }
 


@@ -781,10 +943,6 @@ gfc_simplify_complex (gfc_expr *x, gfc_expr *y)
 {
   int kind;
 
 {
   int kind;
 

-  if (x->expr_type != EXPR_CONSTANT
-      || (y != NULL && y->expr_type != EXPR_CONSTANT))
-    return NULL;
-

   if (x->ts.type == BT_INTEGER)
     {
       if (y->ts.type == BT_INTEGER)
   if (x->ts.type == BT_INTEGER)
     {
       if (y->ts.type == BT_INTEGER)


@@ -800,6 +958,10 @@ gfc_simplify_complex (gfc_expr *x, gfc_expr *y)
        kind = x->ts.kind;
     }
 
        kind = x->ts.kind;
     }
 

+  if (x->expr_type != EXPR_CONSTANT
+      || (y != NULL && y->expr_type != EXPR_CONSTANT))
+    return only_convert_cmplx_boz (x, y, kind);
+

   return simplify_cmplx ("COMPLEX", x, y, kind);
 }
 
   return simplify_cmplx ("COMPLEX", x, y, kind);
 }
 


@@ -849,8 +1011,7 @@ gfc_simplify_cos (gfc_expr *x)
       mpfr_mul (xp, xp, xq, GFC_RND_MODE);
       mpfr_neg (result->value.complex.i, xp, GFC_RND_MODE );
 
       mpfr_mul (xp, xp, xq, GFC_RND_MODE);
       mpfr_neg (result->value.complex.i, xp, GFC_RND_MODE );
 

-      mpfr_clear (xp);
-      mpfr_clear (xq);
+      mpfr_clears (xp, xq, NULL);

       break;
     default:
       gfc_internal_error ("in gfc_simplify_cos(): Bad type");
       break;
     default:
       gfc_internal_error ("in gfc_simplify_cos(): Bad type");


@@ -883,7 +1044,7 @@ gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y)
 
   if (x->expr_type != EXPR_CONSTANT
       || (y != NULL && y->expr_type != EXPR_CONSTANT))
 
   if (x->expr_type != EXPR_CONSTANT
       || (y != NULL && y->expr_type != EXPR_CONSTANT))

-    return NULL;
+    return only_convert_cmplx_boz (x, y, gfc_default_double_kind);

 
   return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind);
 }
 
   return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind);
 }


@@ -892,7 +1053,7 @@ gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y)
 gfc_expr *
 gfc_simplify_dble (gfc_expr *e)
 {
 gfc_expr *
 gfc_simplify_dble (gfc_expr *e)
 {

-  gfc_expr *result;
+  gfc_expr *result = NULL;

 
   if (e->expr_type != EXPR_CONSTANT)
     return NULL;
 
   if (e->expr_type != EXPR_CONSTANT)
     return NULL;


@@ -900,7 +1061,8 @@ gfc_simplify_dble (gfc_expr *e)
   switch (e->ts.type)
     {
     case BT_INTEGER:
   switch (e->ts.type)
     {
     case BT_INTEGER:

-      result = gfc_int2real (e, gfc_default_double_kind);
+      if (!e->is_boz)
+       result = gfc_int2real (e, gfc_default_double_kind);

       break;
 
     case BT_REAL:
       break;
 
     case BT_REAL:


@@ -915,6 +1077,20 @@ gfc_simplify_dble (gfc_expr *e)
       gfc_internal_error ("gfc_simplify_dble(): bad type at %L", &e->where);
     }
 
       gfc_internal_error ("gfc_simplify_dble(): bad type at %L", &e->where);
     }
 

+  if (e->ts.type == BT_INTEGER && e->is_boz)
+    {
+      gfc_typespec ts;
+      gfc_clear_ts (&ts);
+      ts.type = BT_REAL;
+      ts.kind = gfc_default_double_kind;
+      result = gfc_copy_expr (e);
+      if (!gfc_convert_boz (result, &ts))
+       {
+         gfc_free_expr (result);
+         return &gfc_bad_expr;
+       }
+    }
+

   return range_check (result, "DBLE");
 }
 
   return range_check (result, "DBLE");
 }
 


@@ -1006,6 +1182,38 @@ gfc_simplify_dprod (gfc_expr *x, gfc_expr *y)
 
 
 gfc_expr *
 
 
 gfc_expr *

+gfc_simplify_erf (gfc_expr *x)
+{
+  gfc_expr *result;
+
+  if (x->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+
+  mpfr_erf (result->value.real, x->value.real, GFC_RND_MODE);
+
+  return range_check (result, "ERF");
+}
+
+
+gfc_expr *
+gfc_simplify_erfc (gfc_expr *x)
+{
+  gfc_expr *result;
+
+  if (x->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+
+  mpfr_erfc (result->value.real, x->value.real, GFC_RND_MODE);
+
+  return range_check (result, "ERFC");
+}
+
+
+gfc_expr *

 gfc_simplify_epsilon (gfc_expr *e)
 {
   gfc_expr *result;
 gfc_simplify_epsilon (gfc_expr *e)
 {
   gfc_expr *result;


@@ -1047,8 +1255,7 @@ gfc_simplify_exp (gfc_expr *x)
       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_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_clear (xp);
-      mpfr_clear (xq);
+      mpfr_clears (xp, xq, NULL);

       break;
 
     default:
       break;
 
     default:


@@ -1093,7 +1300,23 @@ gfc_simplify_float (gfc_expr *a)
   if (a->expr_type != EXPR_CONSTANT)
     return NULL;
 
   if (a->expr_type != EXPR_CONSTANT)
     return NULL;
 

-  result = gfc_int2real (a, gfc_default_real_kind);
+  if (a->is_boz)
+    {
+      gfc_typespec ts;
+      gfc_clear_ts (&ts);
+
+      ts.type = BT_REAL;
+      ts.kind = gfc_default_real_kind;
+
+      result = gfc_copy_expr (a);
+      if (!gfc_convert_boz (result, &ts))
+       {
+         gfc_free_expr (result);
+         return &gfc_bad_expr;
+       }
+    }
+  else
+    result = gfc_int2real (a, gfc_default_real_kind);

   return range_check (result, "FLOAT");
 }
 
   return range_check (result, "FLOAT");
 }
 


@@ -1118,7 +1341,7 @@ gfc_simplify_floor (gfc_expr *e, gfc_expr *k)
   mpfr_init (floor);
   mpfr_floor (floor, e->value.real);
 
   mpfr_init (floor);
   mpfr_floor (floor, e->value.real);
 

-  gfc_mpfr_to_mpz (result->value.integer, floor);
+  gfc_mpfr_to_mpz (result->value.integer, floor, &e->where);

 
   mpfr_clear (floor);
 
 
   mpfr_clear (floor);
 


@@ -1137,14 +1360,13 @@ gfc_simplify_fraction (gfc_expr *x)
 
   result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
 
 
   result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
 

-  gfc_set_model_kind (x->ts.kind);
-

   if (mpfr_sgn (x->value.real) == 0)
     {
       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
       return result;
     }
 
   if (mpfr_sgn (x->value.real) == 0)
     {
       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
       return result;
     }
 

+  gfc_set_model_kind (x->ts.kind);

   mpfr_init (exp);
   mpfr_init (absv);
   mpfr_init (pow2);
   mpfr_init (exp);
   mpfr_init (absv);
   mpfr_init (pow2);


@@ -1159,15 +1381,29 @@ gfc_simplify_fraction (gfc_expr *x)
 
   mpfr_div (result->value.real, absv, pow2, GFC_RND_MODE);
 
 
   mpfr_div (result->value.real, absv, pow2, GFC_RND_MODE);
 

-  mpfr_clear (exp);
-  mpfr_clear (absv);
-  mpfr_clear (pow2);
+  mpfr_clears (exp, absv, pow2, NULL);

 
   return range_check (result, "FRACTION");
 }
 
 
 gfc_expr *
 
   return range_check (result, "FRACTION");
 }
 
 
 gfc_expr *

+gfc_simplify_gamma (gfc_expr *x)
+{
+  gfc_expr *result;
+
+  if (x->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+
+  mpfr_gamma (result->value.real, x->value.real, GFC_RND_MODE);
+
+  return range_check (result, "GAMMA");
+}
+
+
+gfc_expr *

 gfc_simplify_huge (gfc_expr *e)
 {
   gfc_expr *result;
 gfc_simplify_huge (gfc_expr *e)
 {
   gfc_expr *result;


@@ -1194,14 +1430,29 @@ gfc_simplify_huge (gfc_expr *e)
   return result;
 }
 
   return result;
 }
 

+
+gfc_expr *
+gfc_simplify_hypot (gfc_expr *x, gfc_expr *y)
+{
+  gfc_expr *result;
+
+  if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+  mpfr_hypot (result->value.real, x->value.real, y->value.real, GFC_RND_MODE);
+  return range_check (result, "HYPOT");
+}
+
+

 /* We use the processor's collating sequence, because all
 /* We use the processor's collating sequence, because all

-   sytems that gfortran currently works on are ASCII.  */
+   systems that gfortran currently works on are ASCII.  */

 
 gfc_expr *
 
 gfc_expr *

-gfc_simplify_iachar (gfc_expr *e)
+gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind)

 {
   gfc_expr *result;
 {
   gfc_expr *result;

-  int index;
+  gfc_char_t index;

 
   if (e->expr_type != EXPR_CONSTANT)
     return NULL;
 
   if (e->expr_type != EXPR_CONSTANT)
     return NULL;


@@ -1212,13 +1463,15 @@ gfc_simplify_iachar (gfc_expr *e)
       return &gfc_bad_expr;
     }
 
       return &gfc_bad_expr;
     }
 

-  index = (unsigned char) e->value.character.string[0];
+  index = e->value.character.string[0];

 
   if (gfc_option.warn_surprising && index > 127)
     gfc_warning ("Argument of IACHAR function at %L outside of range 0..127",
                 &e->where);
 
 
   if (gfc_option.warn_surprising && index > 127)
     gfc_warning ("Argument of IACHAR function at %L outside of range 0..127",
                 &e->where);
 

-  result = gfc_int_expr (index);
+  if ((result = int_expr_with_kind (index, kind, "IACHAR")) == NULL)
+    return &gfc_bad_expr;
+

   result->where = e->where;
 
   return range_check (result, "IACHAR");
   result->where = e->where;
 
   return range_check (result, "IACHAR");


@@ -1275,7 +1528,7 @@ gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y)
   convert_mpz_to_signed (result->value.integer,
                         gfc_integer_kinds[k].bit_size);
 
   convert_mpz_to_signed (result->value.integer,
                         gfc_integer_kinds[k].bit_size);
 

-  return range_check (result, "IBCLR");
+  return result;

 }
 
 
 }
 
 


@@ -1316,8 +1569,10 @@ gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z)
     }
 
   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
     }
 
   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);

+  convert_mpz_to_unsigned (result->value.integer,
+                          gfc_integer_kinds[k].bit_size);

 
 

-  bits = gfc_getmem (bitsize * sizeof (int));
+  bits = XCNEWVEC (int, bitsize);

 
   for (i = 0; i < bitsize; i++)
     bits[i] = 0;
 
   for (i = 0; i < bitsize; i++)
     bits[i] = 0;


@@ -1337,7 +1592,10 @@ gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z)
 
   gfc_free (bits);
 
 
   gfc_free (bits);
 

-  return range_check (result, "IBITS");
+  convert_mpz_to_signed (result->value.integer,
+                        gfc_integer_kinds[k].bit_size);
+
+  return result;

 }
 
 
 }
 
 


@@ -1375,15 +1633,15 @@ gfc_simplify_ibset (gfc_expr *x, gfc_expr *y)
   convert_mpz_to_signed (result->value.integer,
                         gfc_integer_kinds[k].bit_size);
 
   convert_mpz_to_signed (result->value.integer,
                         gfc_integer_kinds[k].bit_size);
 

-  return range_check (result, "IBSET");
+  return result;

 }
 
 
 gfc_expr *
 }
 
 
 gfc_expr *

-gfc_simplify_ichar (gfc_expr *e)
+gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind)

 {
   gfc_expr *result;
 {
   gfc_expr *result;

-  int index;
+  gfc_char_t index;

 
   if (e->expr_type != EXPR_CONSTANT)
     return NULL;
 
   if (e->expr_type != EXPR_CONSTANT)
     return NULL;


@@ -1394,12 +1652,11 @@ gfc_simplify_ichar (gfc_expr *e)
       return &gfc_bad_expr;
     }
 
       return &gfc_bad_expr;
     }
 

-  index = (unsigned char) e->value.character.string[0];
+  index = e->value.character.string[0];

 
 

-  if (index < 0 || index > UCHAR_MAX)
-    gfc_internal_error("Argument of ICHAR at %L out of range", &e->where);
+  if ((result = int_expr_with_kind (index, kind, "ICHAR")) == NULL)
+    return &gfc_bad_expr;

 
 

-  result = gfc_int_expr (index);

   result->where = e->where;
   return range_check (result, "ICHAR");
 }
   result->where = e->where;
   return range_check (result, "ICHAR");
 }


@@ -1422,13 +1679,14 @@ gfc_simplify_ieor (gfc_expr *x, gfc_expr *y)
 
 
 gfc_expr *
 
 
 gfc_expr *

-gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b)
+gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind)

 {
   gfc_expr *result;
   int back, len, lensub;
   int i, j, k, count, index = 0, start;
 
 {
   gfc_expr *result;
   int back, len, lensub;
   int i, j, k, count, index = 0, start;
 

-  if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
+  if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT 
+      || ( b != NULL && b->expr_type !=  EXPR_CONSTANT))

     return NULL;
 
   if (b != NULL && b->value.logical != 0)
     return NULL;
 
   if (b != NULL && b->value.logical != 0)


@@ -1436,8 +1694,11 @@ gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b)
   else
     back = 0;
 
   else
     back = 0;
 

-  result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
-                               &x->where);
+  k = get_kind (BT_INTEGER, kind, "INDEX", gfc_default_integer_kind); 
+  if (k == -1)
+    return &gfc_bad_expr;
+
+  result = gfc_constant_result (BT_INTEGER, k, &x->where);

 
   len = x->value.character.length;
   lensub = y->value.character.length;
 
   len = x->value.character.length;
   lensub = y->value.character.length;


@@ -1565,7 +1826,7 @@ done:
 gfc_expr *
 gfc_simplify_int (gfc_expr *e, gfc_expr *k)
 {
 gfc_expr *
 gfc_simplify_int (gfc_expr *e, gfc_expr *k)
 {

-  gfc_expr *rpart, *rtrunc, *result;
+  gfc_expr *result = NULL;

   int kind;
 
   kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind);
   int kind;
 
   kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind);


@@ -1575,33 +1836,22 @@ gfc_simplify_int (gfc_expr *e, gfc_expr *k)
   if (e->expr_type != EXPR_CONSTANT)
     return NULL;
 
   if (e->expr_type != EXPR_CONSTANT)
     return NULL;
 

-  result = gfc_constant_result (BT_INTEGER, kind, &e->where);
-

   switch (e->ts.type)
     {
     case BT_INTEGER:
   switch (e->ts.type)
     {
     case BT_INTEGER:

-      mpz_set (result->value.integer, e->value.integer);
+      result = gfc_int2int (e, kind);

       break;
 
     case BT_REAL:
       break;
 
     case BT_REAL:

-      rtrunc = gfc_copy_expr (e);
-      mpfr_trunc (rtrunc->value.real, e->value.real);
-      gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
-      gfc_free_expr (rtrunc);
+      result = gfc_real2int (e, kind);

       break;
 
     case BT_COMPLEX:
       break;
 
     case BT_COMPLEX:

-      rpart = gfc_complex2real (e, kind);
-      rtrunc = gfc_copy_expr (rpart);
-      mpfr_trunc (rtrunc->value.real, rpart->value.real);
-      gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
-      gfc_free_expr (rpart);
-      gfc_free_expr (rtrunc);
+      result = gfc_complex2int (e, kind);

       break;
 
     default:
       gfc_error ("Argument of INT at %L is not a valid type", &e->where);
       break;
 
     default:
       gfc_error ("Argument of INT at %L is not a valid type", &e->where);

-      gfc_free_expr (result);

       return &gfc_bad_expr;
     }
 
       return &gfc_bad_expr;
     }
 


@@ -1610,40 +1860,29 @@ gfc_simplify_int (gfc_expr *e, gfc_expr *k)
 
 
 static gfc_expr *
 
 
 static gfc_expr *

-gfc_simplify_intconv (gfc_expr *e, int kind, const char *name)
+simplify_intconv (gfc_expr *e, int kind, const char *name)

 {
 {

-  gfc_expr *rpart, *rtrunc, *result;
+  gfc_expr *result = NULL;

 
   if (e->expr_type != EXPR_CONSTANT)
     return NULL;
 
 
   if (e->expr_type != EXPR_CONSTANT)
     return NULL;
 

-  result = gfc_constant_result (BT_INTEGER, kind, &e->where);
-

   switch (e->ts.type)
     {
     case BT_INTEGER:
   switch (e->ts.type)
     {
     case BT_INTEGER:

-      mpz_set (result->value.integer, e->value.integer);
+      result = gfc_int2int (e, kind);

       break;
 
     case BT_REAL:
       break;
 
     case BT_REAL:

-      rtrunc = gfc_copy_expr (e);
-      mpfr_trunc (rtrunc->value.real, e->value.real);
-      gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
-      gfc_free_expr (rtrunc);
+      result = gfc_real2int (e, kind);

       break;
 
     case BT_COMPLEX:
       break;
 
     case BT_COMPLEX:

-      rpart = gfc_complex2real (e, kind);
-      rtrunc = gfc_copy_expr (rpart);
-      mpfr_trunc (rtrunc->value.real, rpart->value.real);
-      gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
-      gfc_free_expr (rpart);
-      gfc_free_expr (rtrunc);
+      result = gfc_complex2int (e, kind);

       break;
 
     default:
       gfc_error ("Argument of %s at %L is not a valid type", name, &e->where);
       break;
 
     default:
       gfc_error ("Argument of %s at %L is not a valid type", name, &e->where);

-      gfc_free_expr (result);

       return &gfc_bad_expr;
     }
 
       return &gfc_bad_expr;
     }
 


@@ -1654,21 +1893,21 @@ gfc_simplify_intconv (gfc_expr *e, int kind, const char *name)
 gfc_expr *
 gfc_simplify_int2 (gfc_expr *e)
 {
 gfc_expr *
 gfc_simplify_int2 (gfc_expr *e)
 {

-  return gfc_simplify_intconv (e, 2, "INT2");
+  return simplify_intconv (e, 2, "INT2");

 }
 
 
 gfc_expr *
 gfc_simplify_int8 (gfc_expr *e)
 {
 }
 
 
 gfc_expr *
 gfc_simplify_int8 (gfc_expr *e)
 {

-  return gfc_simplify_intconv (e, 8, "INT8");
+  return simplify_intconv (e, 8, "INT8");

 }
 
 
 gfc_expr *
 gfc_simplify_long (gfc_expr *e)
 {
 }
 
 
 gfc_expr *
 gfc_simplify_long (gfc_expr *e)
 {

-  return gfc_simplify_intconv (e, 4, "LONG");
+  return simplify_intconv (e, 4, "LONG");

 }
 
 
 }
 
 


@@ -1686,7 +1925,7 @@ gfc_simplify_ifix (gfc_expr *e)
   rtrunc = gfc_copy_expr (e);
 
   mpfr_trunc (rtrunc->value.real, e->value.real);
   rtrunc = gfc_copy_expr (e);
 
   mpfr_trunc (rtrunc->value.real, e->value.real);

-  gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
+  gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);

 
   gfc_free_expr (rtrunc);
   return range_check (result, "IFIX");
 
   gfc_free_expr (rtrunc);
   return range_check (result, "IFIX");


@@ -1707,7 +1946,7 @@ gfc_simplify_idint (gfc_expr *e)
   rtrunc = gfc_copy_expr (e);
 
   mpfr_trunc (rtrunc->value.real, e->value.real);
   rtrunc = gfc_copy_expr (e);
 
   mpfr_trunc (rtrunc->value.real, e->value.real);

-  gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real);
+  gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);

 
   gfc_free_expr (rtrunc);
   return range_check (result, "IDINT");
 
   gfc_free_expr (rtrunc);
   return range_check (result, "IDINT");


@@ -1768,7 +2007,7 @@ gfc_simplify_ishft (gfc_expr *e, gfc_expr *s)
       return range_check (result, "ISHFT");
     }
   
       return range_check (result, "ISHFT");
     }
   

-  bits = gfc_getmem (isize * sizeof (int));
+  bits = XCNEWVEC (int, isize);

 
   for (i = 0; i < isize; i++)
     bits[i] = mpz_tstbit (e->value.integer, i);
 
   for (i = 0; i < isize; i++)
     bits[i] = mpz_tstbit (e->value.integer, i);


@@ -1872,7 +2111,7 @@ gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz)
 
   convert_mpz_to_unsigned (result->value.integer, isize);
 
 
   convert_mpz_to_unsigned (result->value.integer, isize);
 

-  bits = gfc_getmem (ssize * sizeof (int));
+  bits = XCNEWVEC (int, ssize);

 
   for (i = 0; i < ssize; i++)
     bits[i] = mpz_tstbit (e->value.integer, i);
 
   for (i = 0; i < ssize; i++)
     bits[i] = mpz_tstbit (e->value.integer, i);


@@ -1938,20 +2177,63 @@ gfc_simplify_kind (gfc_expr *e)
 
 
 static gfc_expr *
 
 
 static gfc_expr *

-simplify_bound (gfc_expr *array, gfc_expr *dim, int upper)
+simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
+                   gfc_array_spec *as)

 {
 {

-  gfc_ref *ref;
-  gfc_array_spec *as;

   gfc_expr *l, *u, *result;
   gfc_expr *l, *u, *result;

-  int d;
+  int k;

 
 

-  if (dim == NULL)
-    /* TODO: Simplify constant multi-dimensional bounds.  */
-    return NULL;
+  /* The last dimension of an assumed-size array is special.  */
+  if (d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
+    {
+      if (as->lower[d-1]->expr_type == EXPR_CONSTANT)
+       return gfc_copy_expr (as->lower[d-1]);
+      else
+       return NULL;
+    }

 
 

-  if (dim->expr_type != EXPR_CONSTANT)
+  /* Then, we need to know the extent of the given dimension.  */
+  l = as->lower[d-1];
+  u = as->upper[d-1];
+
+  if (l->expr_type != EXPR_CONSTANT || u->expr_type != EXPR_CONSTANT)

     return NULL;
 
     return NULL;
 

+  k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
+               gfc_default_integer_kind); 
+  if (k == -1)
+    return &gfc_bad_expr;
+
+  result = gfc_constant_result (BT_INTEGER, k, &array->where);
+
+  if (mpz_cmp (l->value.integer, u->value.integer) > 0)
+    {
+      /* Zero extent.  */
+      if (upper)
+       mpz_set_si (result->value.integer, 0);
+      else
+       mpz_set_si (result->value.integer, 1);
+    }
+  else
+    {
+      /* Nonzero extent.  */
+      if (upper)
+       mpz_set (result->value.integer, u->value.integer);
+      else
+       mpz_set (result->value.integer, l->value.integer);
+    }
+
+  return range_check (result, upper ? "UBOUND" : "LBOUND");
+}
+
+
+static gfc_expr *
+simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
+{
+  gfc_ref *ref;
+  gfc_array_spec *as;
+  int d;
+

   if (array->expr_type != EXPR_VARIABLE)
     return NULL;
 
   if (array->expr_type != EXPR_VARIABLE)
     return NULL;
 


@@ -1992,103 +2274,174 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, int upper)
   gcc_unreachable ();
 
  done:
   gcc_unreachable ();
 
  done:

+

   if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)
     return NULL;
 
   if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)
     return NULL;
 

-  d = mpz_get_si (dim->value.integer);
-
-  if (d < 1 || d > as->rank
-      || (d == as->rank && as->type == AS_ASSUMED_SIZE && upper))
+  if (dim == NULL)

     {
     {

-      gfc_error ("DIM argument at %L is out of bounds", &dim->where);
-      return &gfc_bad_expr;
-    }
+      /* Multi-dimensional bounds.  */
+      gfc_expr *bounds[GFC_MAX_DIMENSIONS];
+      gfc_expr *e;
+      gfc_constructor *head, *tail;
+      int k;
+
+      /* UBOUND(ARRAY) is not valid for an assumed-size array.  */
+      if (upper && as->type == AS_ASSUMED_SIZE)
+       {
+         /* An error message will be emitted in
+            check_assumed_size_reference (resolve.c).  */
+         return &gfc_bad_expr;
+       }

 
 

-  /* The last dimension of an assumed-size array is special.  */
-  if (d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
-    {
-      if (as->lower[d-1]->expr_type == EXPR_CONSTANT)
-       return gfc_copy_expr (as->lower[d-1]);
-      else
-       return NULL;
-    }
+      /* Simplify the bounds for each dimension.  */
+      for (d = 0; d < array->rank; d++)
+       {
+         bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as);
+         if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
+           {
+             int j;

 
 

-  /* Then, we need to know the extent of the given dimension.  */
-  l = as->lower[d-1];
-  u = as->upper[d-1];
+             for (j = 0; j < d; j++)
+               gfc_free_expr (bounds[j]);
+             return bounds[d];
+           }
+       }

 
 

-  if (l->expr_type != EXPR_CONSTANT || u->expr_type != EXPR_CONSTANT)
-    return NULL;
+      /* Allocate the result expression.  */
+      e = gfc_get_expr ();
+      e->where = array->where;
+      e->expr_type = EXPR_ARRAY;
+      e->ts.type = BT_INTEGER;
+      k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
+                   gfc_default_integer_kind); 
+      if (k == -1)
+       {
+         gfc_free_expr (e);
+         return &gfc_bad_expr;
+       }
+      e->ts.kind = k;

 
 

-  result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
-                               &array->where);
+      /* The result is a rank 1 array; its size is the rank of the first
+        argument to {L,U}BOUND.  */
+      e->rank = 1;
+      e->shape = gfc_get_shape (1);
+      mpz_init_set_ui (e->shape[0], array->rank);

 
 

-  if (mpz_cmp (l->value.integer, u->value.integer) > 0)
-    {
-      /* Zero extent.  */
-      if (upper)
-       mpz_set_si (result->value.integer, 0);
-      else
-       mpz_set_si (result->value.integer, 1);
+      /* Create the constructor for this array.  */
+      head = tail = NULL;
+      for (d = 0; d < array->rank; d++)
+       {
+         /* Get a new constructor element.  */
+         if (head == NULL)
+           head = tail = gfc_get_constructor ();
+         else
+           {
+             tail->next = gfc_get_constructor ();
+             tail = tail->next;
+           }
+
+         tail->where = e->where;
+         tail->expr = bounds[d];
+       }
+      e->value.constructor = head;
+
+      return e;

     }
   else
     {
     }
   else
     {

-      /* Nonzero extent.  */
-      if (upper)
-       mpz_set (result->value.integer, u->value.integer);
-      else
-       mpz_set (result->value.integer, l->value.integer);
+      /* A DIM argument is specified.  */
+      if (dim->expr_type != EXPR_CONSTANT)
+       return NULL;
+
+      d = mpz_get_si (dim->value.integer);
+
+      if (d < 1 || d > as->rank
+         || (d == as->rank && as->type == AS_ASSUMED_SIZE && upper))
+       {
+         gfc_error ("DIM argument at %L is out of bounds", &dim->where);
+         return &gfc_bad_expr;
+       }
+
+      return simplify_bound_dim (array, kind, d, upper, as);

     }
     }

+}

 
 

-  return range_check (result, upper ? "UBOUND" : "LBOUND");
+
+gfc_expr *
+gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
+{
+  return simplify_bound (array, dim, kind, 0);

 }
 
 
 gfc_expr *
 }
 
 
 gfc_expr *

-gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim)
+gfc_simplify_leadz (gfc_expr *e)

 {
 {

-  return simplify_bound (array, dim, 0);
+  gfc_expr *result;
+  unsigned long lz, bs;
+  int i;
+
+  if (e->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
+  bs = gfc_integer_kinds[i].bit_size;
+  if (mpz_cmp_si (e->value.integer, 0) == 0)
+    lz = bs;
+  else
+    lz = bs - mpz_sizeinbase (e->value.integer, 2);
+
+  result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, &e->where);
+  mpz_set_ui (result->value.integer, lz);
+
+  return result;

 }
 
 
 gfc_expr *
 }
 
 
 gfc_expr *

-gfc_simplify_len (gfc_expr *e)
+gfc_simplify_len (gfc_expr *e, gfc_expr *kind)

 {
   gfc_expr *result;
 {
   gfc_expr *result;

+  int k = get_kind (BT_INTEGER, kind, "LEN", gfc_default_integer_kind);
+
+  if (k == -1)
+    return &gfc_bad_expr;

 
   if (e->expr_type == EXPR_CONSTANT)
     {
 
   if (e->expr_type == EXPR_CONSTANT)
     {

-      result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
-                                   &e->where);
+      result = gfc_constant_result (BT_INTEGER, k, &e->where);

       mpz_set_si (result->value.integer, e->value.character.length);
       return range_check (result, "LEN");
     }
 
   if (e->ts.cl != NULL && e->ts.cl->length != NULL
       mpz_set_si (result->value.integer, e->value.character.length);
       return range_check (result, "LEN");
     }
 
   if (e->ts.cl != NULL && e->ts.cl->length != NULL

-      && e->ts.cl->length->expr_type == EXPR_CONSTANT)
+      && e->ts.cl->length->expr_type == EXPR_CONSTANT
+      && e->ts.cl->length->ts.type == BT_INTEGER)

     {
     {

-      result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
-                                   &e->where);
+      result = gfc_constant_result (BT_INTEGER, k, &e->where);

       mpz_set (result->value.integer, e->ts.cl->length->value.integer);
       return range_check (result, "LEN");
     }
       mpz_set (result->value.integer, e->ts.cl->length->value.integer);
       return range_check (result, "LEN");
     }

-  
+

   return NULL;
 }
 
 
 gfc_expr *
   return NULL;
 }
 
 
 gfc_expr *

-gfc_simplify_len_trim (gfc_expr *e)
+gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)

 {
   gfc_expr *result;
   int count, len, lentrim, i;
 {
   gfc_expr *result;
   int count, len, lentrim, i;

+  int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind);
+
+  if (k == -1)
+    return &gfc_bad_expr;

 
   if (e->expr_type != EXPR_CONSTANT)
     return NULL;
 
 
   if (e->expr_type != EXPR_CONSTANT)
     return NULL;
 

-  result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
-                               &e->where);
-
+  result = gfc_constant_result (BT_INTEGER, k, &e->where);

   len = e->value.character.length;
 
   for (count = 0, i = 1; i <= len; i++)
   len = e->value.character.length;
 
   for (count = 0, i = 1; i <= len; i++)


@@ -2103,6 +2456,22 @@ gfc_simplify_len_trim (gfc_expr *e)
   return range_check (result, "LEN_TRIM");
 }
 
   return range_check (result, "LEN_TRIM");
 }
 

+gfc_expr *
+gfc_simplify_lgamma (gfc_expr *x ATTRIBUTE_UNUSED)
+{
+  gfc_expr *result;
+  int sg;
+
+  if (x->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+
+  mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODE);
+
+  return range_check (result, "LGAMMA");
+}
+

 
 gfc_expr *
 gfc_simplify_lge (gfc_expr *a, gfc_expr *b)
 
 gfc_expr *
 gfc_simplify_lge (gfc_expr *a, gfc_expr *b)


@@ -2156,7 +2525,6 @@ gfc_simplify_log (gfc_expr *x)
 
   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
 
 
   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
 

-  gfc_set_model_kind (x->ts.kind);

 
   switch (x->ts.type)
     {
 
   switch (x->ts.type)
     {


@@ -2182,6 +2550,7 @@ gfc_simplify_log (gfc_expr *x)
          return &gfc_bad_expr;
        }
 
          return &gfc_bad_expr;
        }
 

+      gfc_set_model_kind (x->ts.kind);

       mpfr_init (xr);
       mpfr_init (xi);
 
       mpfr_init (xr);
       mpfr_init (xi);
 


@@ -2194,8 +2563,7 @@ gfc_simplify_log (gfc_expr *x)
       mpfr_sqrt (xr, xr, GFC_RND_MODE);
       mpfr_log (result->value.complex.r, xr, GFC_RND_MODE);
 
       mpfr_sqrt (xr, xr, GFC_RND_MODE);
       mpfr_log (result->value.complex.r, xr, GFC_RND_MODE);
 

-      mpfr_clear (xr);
-      mpfr_clear (xi);
+      mpfr_clears (xr, xi, NULL);

 
       break;
 
 
       break;
 


@@ -2215,8 +2583,6 @@ gfc_simplify_log10 (gfc_expr *x)
   if (x->expr_type != EXPR_CONSTANT)
     return NULL;
 
   if (x->expr_type != EXPR_CONSTANT)
     return NULL;
 

-  gfc_set_model_kind (x->ts.kind);
-

   if (mpfr_sgn (x->value.real) <= 0)
     {
       gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
   if (mpfr_sgn (x->value.real) <= 0)
     {
       gfc_error ("Argument of LOG10 at %L cannot be less than or equal "


@@ -2289,19 +2655,52 @@ simplify_min_max (gfc_expr *expr, int sign)
          if (mpz_cmp (arg->expr->value.integer,
                       extremum->expr->value.integer) * sign > 0)
            mpz_set (extremum->expr->value.integer, arg->expr->value.integer);
          if (mpz_cmp (arg->expr->value.integer,
                       extremum->expr->value.integer) * sign > 0)
            mpz_set (extremum->expr->value.integer, arg->expr->value.integer);

-

          break;
 
        case BT_REAL:
          break;
 
        case BT_REAL:

-         if (mpfr_cmp (arg->expr->value.real, extremum->expr->value.real)
-             * sign > 0)
-           mpfr_set (extremum->expr->value.real, arg->expr->value.real,
-                     GFC_RND_MODE);
+         /* We need to use mpfr_min and mpfr_max to treat NaN properly.  */
+         if (sign > 0)
+           mpfr_max (extremum->expr->value.real, extremum->expr->value.real,
+                     arg->expr->value.real, GFC_RND_MODE);
+         else
+           mpfr_min (extremum->expr->value.real, extremum->expr->value.real,
+                     arg->expr->value.real, GFC_RND_MODE);
+         break;
+
+       case BT_CHARACTER:
+#define LENGTH(x) ((x)->expr->value.character.length)
+#define STRING(x) ((x)->expr->value.character.string)
+         if (LENGTH(extremum) < LENGTH(arg))
+           {
+             gfc_char_t *tmp = STRING(extremum);
+
+             STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1);
+             memcpy (STRING(extremum), tmp,
+                     LENGTH(extremum) * sizeof (gfc_char_t));
+             gfc_wide_memset (&STRING(extremum)[LENGTH(extremum)], ' ',
+                              LENGTH(arg) - LENGTH(extremum));
+             STRING(extremum)[LENGTH(arg)] = '\0';  /* For debugger  */
+             LENGTH(extremum) = LENGTH(arg);
+             gfc_free (tmp);
+           }

 
 

+         if (gfc_compare_string (arg->expr, extremum->expr) * sign > 0)
+           {
+             gfc_free (STRING(extremum));
+             STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1);
+             memcpy (STRING(extremum), STRING(arg),
+                     LENGTH(arg) * sizeof (gfc_char_t));
+             gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ',
+                              LENGTH(extremum) - LENGTH(arg));
+             STRING(extremum)[LENGTH(extremum)] = '\0';  /* For debugger  */
+           }
+#undef LENGTH
+#undef STRING

          break;
          break;

+             

 
        default:
 
        default:

-         gfc_internal_error ("gfc_simplify_max(): Bad type in arglist");
+         gfc_internal_error ("simplify_min_max(): Bad type in arglist");

        }
 
       /* Delete the extra constant argument.  */
        }
 
       /* Delete the extra constant argument.  */


@@ -2381,7 +2780,7 @@ gfc_expr *
 gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
 {
   gfc_expr *result;
 gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
 {
   gfc_expr *result;

-  mpfr_t quot, iquot, term;
+  mpfr_t tmp;

   int kind;
 
   if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
   int kind;
 
   if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)


@@ -2413,18 +2812,12 @@ gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
        }
 
       gfc_set_model_kind (kind);
        }
 
       gfc_set_model_kind (kind);

-      mpfr_init (quot);
-      mpfr_init (iquot);
-      mpfr_init (term);
-
-      mpfr_div (quot, a->value.real, p->value.real, GFC_RND_MODE);
-      mpfr_trunc (iquot, quot);
-      mpfr_mul (term, iquot, p->value.real, GFC_RND_MODE);
-      mpfr_sub (result->value.real, a->value.real, term, GFC_RND_MODE);
-
-      mpfr_clear (quot);
-      mpfr_clear (iquot);
-      mpfr_clear (term);
+      mpfr_init (tmp);
+      mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE);
+      mpfr_trunc (tmp, tmp);
+      mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE);
+      mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE);
+      mpfr_clear (tmp);

       break;
 
     default:
       break;
 
     default:


@@ -2439,7 +2832,7 @@ gfc_expr *
 gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
 {
   gfc_expr *result;
 gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
 {
   gfc_expr *result;

-  mpfr_t quot, iquot, term;
+  mpfr_t tmp;

   int kind;
 
   if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
   int kind;
 
   if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)


@@ -2473,18 +2866,12 @@ gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
        }
 
       gfc_set_model_kind (kind);
        }
 
       gfc_set_model_kind (kind);

-      mpfr_init (quot);
-      mpfr_init (iquot);
-      mpfr_init (term);
-
-      mpfr_div (quot, a->value.real, p->value.real, GFC_RND_MODE);
-      mpfr_floor (iquot, quot);
-      mpfr_mul (term, iquot, p->value.real, GFC_RND_MODE);
-      mpfr_sub (result->value.real, a->value.real, term, GFC_RND_MODE);
-
-      mpfr_clear (quot);
-      mpfr_clear (iquot);
-      mpfr_clear (term);
+      mpfr_init (tmp);
+      mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE);
+      mpfr_floor (tmp, tmp);
+      mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE);
+      mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE);
+      mpfr_clear (tmp);

       break;
 
     default:
       break;
 
     default:


@@ -2511,8 +2898,8 @@ gfc_expr *
 gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
 {
   gfc_expr *result;
 gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
 {
   gfc_expr *result;

-  mpfr_t tmp;
-  int sgn;
+  mp_exp_t emin, emax;
+  int kind;

 
   if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
     return NULL;
 
   if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
     return NULL;


@@ -2524,16 +2911,42 @@ gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
       return &gfc_bad_expr;
     }
 
       return &gfc_bad_expr;
     }
 

-  gfc_set_model_kind (x->ts.kind);

   result = gfc_copy_expr (x);
 
   result = gfc_copy_expr (x);
 

-  sgn = mpfr_sgn (s->value.real); 
-  mpfr_init (tmp);
-  mpfr_set_inf (tmp, sgn);
-  mpfr_nexttoward (result->value.real, tmp);
-  mpfr_clear (tmp);
+  /* Save current values of emin and emax.  */
+  emin = mpfr_get_emin ();
+  emax = mpfr_get_emax ();
+
+  /* Set emin and emax for the current model number.  */
+  kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0);
+  mpfr_set_emin ((mp_exp_t) gfc_real_kinds[kind].min_exponent -
+               mpfr_get_prec(result->value.real) + 1);
+  mpfr_set_emax ((mp_exp_t) gfc_real_kinds[kind].max_exponent - 1);
+
+  if (mpfr_sgn (s->value.real) > 0)
+    {
+      mpfr_nextabove (result->value.real);
+      mpfr_subnormalize (result->value.real, 0, GMP_RNDU);
+    }
+  else
+    {
+      mpfr_nextbelow (result->value.real);
+      mpfr_subnormalize (result->value.real, 0, GMP_RNDD);
+    }
+
+  mpfr_set_emin (emin);
+  mpfr_set_emax (emax);
+
+  /* Only NaN can occur. Do not use range check as it gives an
+     error for denormal numbers.  */
+  if (mpfr_nan_p (result->value.real) && gfc_option.flag_range_check)
+    {
+      gfc_error ("Result of NEAREST is NaN at %L", &result->where);
+      gfc_free_expr (result);
+      return &gfc_bad_expr;
+    }

 
 

-  return range_check (result, "NEAREST");
+  return result;

 }
 
 
 }
 
 


@@ -2556,7 +2969,7 @@ simplify_nint (const char *name, gfc_expr *e, gfc_expr *k)
 
   mpfr_round (itrunc->value.real, e->value.real);
 
 
   mpfr_round (itrunc->value.real, e->value.real);
 

-  gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real);
+  gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real, &e->where);

 
   gfc_free_expr (itrunc);
 
 
   gfc_free_expr (itrunc);
 


@@ -2569,13 +2982,8 @@ gfc_simplify_new_line (gfc_expr *e)
 {
   gfc_expr *result;
 
 {
   gfc_expr *result;
 

-  if (e->expr_type != EXPR_CONSTANT)
-    return NULL;
-

   result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
   result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);

-
-  result->value.character.string = gfc_getmem (2);
-
+  result->value.character.string = gfc_get_wide_string (2);

   result->value.character.length = 1;
   result->value.character.string[0] = '\n';
   result->value.character.string[1] = '\0';     /* For debugger */
   result->value.character.length = 1;
   result->value.character.string[0] = '\n';
   result->value.character.string[1] = '\0';     /* For debugger */


@@ -2645,14 +3053,14 @@ gfc_simplify_or (gfc_expr *x, gfc_expr *y)
     {
       result = gfc_constant_result (BT_INTEGER, kind, &x->where);
       mpz_ior (result->value.integer, x->value.integer, y->value.integer);
     {
       result = gfc_constant_result (BT_INTEGER, kind, &x->where);
       mpz_ior (result->value.integer, x->value.integer, y->value.integer);

+      return range_check (result, "OR");

     }
   else /* BT_LOGICAL */
     {
       result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
       result->value.logical = x->value.logical || y->value.logical;
     }
   else /* BT_LOGICAL */
     {
       result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
       result->value.logical = x->value.logical || y->value.logical;

+      return result;

     }
     }

-
-  return range_check (result, "OR");

 }
 
 
 }
 
 


@@ -2733,7 +3141,7 @@ gfc_simplify_range (gfc_expr *e)
 gfc_expr *
 gfc_simplify_real (gfc_expr *e, gfc_expr *k)
 {
 gfc_expr *
 gfc_simplify_real (gfc_expr *e, gfc_expr *k)
 {

-  gfc_expr *result;
+  gfc_expr *result = NULL;

   int kind;
 
   if (e->ts.type == BT_COMPLEX)
   int kind;
 
   if (e->ts.type == BT_COMPLEX)


@@ -2750,7 +3158,8 @@ gfc_simplify_real (gfc_expr *e, gfc_expr *k)
   switch (e->ts.type)
     {
     case BT_INTEGER:
   switch (e->ts.type)
     {
     case BT_INTEGER:

-      result = gfc_int2real (e, kind);
+      if (!e->is_boz)
+       result = gfc_int2real (e, kind);

       break;
 
     case BT_REAL:
       break;
 
     case BT_REAL:


@@ -2766,6 +3175,20 @@ gfc_simplify_real (gfc_expr *e, gfc_expr *k)
       /* Not reached */
     }
 
       /* Not reached */
     }
 

+  if (e->ts.type == BT_INTEGER && e->is_boz)
+    {
+      gfc_typespec ts;
+      gfc_clear_ts (&ts);
+      ts.type = BT_REAL;
+      ts.kind = kind;
+      result = gfc_copy_expr (e);
+      if (!gfc_convert_boz (result, &ts))
+       {
+         gfc_free_expr (result);
+         return &gfc_bad_expr;
+       }
+    }
+

   return range_check (result, "REAL");
 }
 
   return range_check (result, "REAL");
 }
 


@@ -2788,43 +3211,145 @@ gfc_expr *
 gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
 {
   gfc_expr *result;
 gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
 {
   gfc_expr *result;

-  int i, j, len, ncopies, nlen;
+  int i, j, len, ncop, nlen;
+  mpz_t ncopies;
+  bool have_length = false;

 
 

-  if (e->expr_type != EXPR_CONSTANT || n->expr_type != EXPR_CONSTANT)
+  /* If NCOPIES isn't a constant, there's nothing we can do.  */
+  if (n->expr_type != EXPR_CONSTANT)

     return NULL;
 
     return NULL;
 

-  if (n != NULL && (gfc_extract_int (n, &ncopies) != NULL || ncopies < 0))
+  /* If NCOPIES is negative, it's an error.  */
+  if (mpz_sgn (n->value.integer) < 0)

     {
     {

-      gfc_error ("Invalid second argument of REPEAT at %L", &n->where);
+      gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
+                &n->where);

       return &gfc_bad_expr;
     }
 
       return &gfc_bad_expr;
     }
 

+  /* 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)
+    {
+      len = mpz_get_si (e->ts.cl->length->value.integer);
+      have_length = true;
+    }
+  else if (e->expr_type == EXPR_CONSTANT
+            && (e->ts.cl == NULL || e->ts.cl->length == NULL))
+    {
+      len = e->value.character.length;
+    }
+  else
+    return NULL;
+
+  /* If the source length is 0, any value of NCOPIES is valid
+     and everything behaves as if NCOPIES == 0.  */
+  mpz_init (ncopies);
+  if (len == 0)
+    mpz_set_ui (ncopies, 0);
+  else
+    mpz_set (ncopies, n->value.integer);
+
+  /* Check that NCOPIES isn't too large.  */
+  if (len)
+    {
+      mpz_t max, mlen;
+      int i;
+
+      /* Compute the maximum value allowed for NCOPIES: huge(cl) / len.  */
+      mpz_init (max);
+      i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
+
+      if (have_length)
+       {
+         mpz_tdiv_q (max, gfc_integer_kinds[i].huge,
+                     e->ts.cl->length->value.integer);
+       }
+      else
+       {
+         mpz_init_set_si (mlen, len);
+         mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen);
+         mpz_clear (mlen);
+       }
+
+      /* The check itself.  */
+      if (mpz_cmp (ncopies, max) > 0)
+       {
+         mpz_clear (max);
+         mpz_clear (ncopies);
+         gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
+                    &n->where);
+         return &gfc_bad_expr;
+       }
+
+      mpz_clear (max);
+    }
+  mpz_clear (ncopies);
+
+  /* For further simplification, we need the character string to be
+     constant.  */
+  if (e->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  if (len || 
+      (e->ts.cl->length && 
+       mpz_sgn (e->ts.cl->length->value.integer)) != 0)
+    {
+      const char *res = gfc_extract_int (n, &ncop);
+      gcc_assert (res == NULL);
+    }
+  else
+    ncop = 0;
+

   len = e->value.character.length;
   len = e->value.character.length;

-  nlen = ncopies * len;
+  nlen = ncop * len;

 
   result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
 
 
   result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
 

-  if (ncopies == 0)
+  if (ncop == 0)

     {
     {

-      result->value.character.string = gfc_getmem (1);
+      result->value.character.string = gfc_get_wide_string (1);

       result->value.character.length = 0;
       result->value.character.string[0] = '\0';
       return result;
     }
 
   result->value.character.length = nlen;
       result->value.character.length = 0;
       result->value.character.string[0] = '\0';
       return result;
     }
 
   result->value.character.length = nlen;

-  result->value.character.string = gfc_getmem (nlen + 1);
+  result->value.character.string = gfc_get_wide_string (nlen + 1);

 
 

-  for (i = 0; i < ncopies; i++)
+  for (i = 0; i < ncop; i++)

     for (j = 0; j < len; j++)
     for (j = 0; j < len; j++)

-      result->value.character.string[j + i * len]
-      = e->value.character.string[j];
+      result->value.character.string[j+i*len]= e->value.character.string[j];

 
   result->value.character.string[nlen] = '\0'; /* For debugger */
   return result;
 }
 
 
 
   result->value.character.string[nlen] = '\0'; /* For debugger */
   return result;
 }
 
 

+/* Test that the expression is an constant array.  */
+
+static bool
+is_constant_array_expr (gfc_expr *e)
+{
+  gfc_constructor *c;
+
+  if (e == NULL)
+    return true;
+
+  if (e->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (e))
+    return false;
+  
+  if (e->value.constructor == NULL)
+    return false;
+  
+  for (c = e->value.constructor; c; c = c->next)
+    if (c->expr->expr_type != EXPR_CONSTANT)
+      return false;
+
+  return true;
+}
+
+

 /* This one is a bear, but mainly has to do with shuffling elements.  */
 
 gfc_expr *
 /* This one is a bear, but mainly has to do with shuffling elements.  */
 
 gfc_expr *


@@ -2839,22 +3364,21 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
   size_t nsource;
   gfc_expr *e;
 
   size_t nsource;
   gfc_expr *e;
 

-  /* Unpack the shape array.  */
-  if (source->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (source))
+  /* Check that argument expression types are OK.  */
+  if (!is_constant_array_expr (source))

     return NULL;
 
     return NULL;
 

-  if (shape_exp->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (shape_exp))
+  if (!is_constant_array_expr (shape_exp))

     return NULL;
 
     return NULL;
 

-  if (pad != NULL
-      && (pad->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (pad)))
+  if (!is_constant_array_expr (pad))

     return NULL;
 
     return NULL;
 

-  if (order_exp != NULL
-      && (order_exp->expr_type != EXPR_ARRAY
-         || !gfc_is_constant_expr (order_exp)))
+  if (!is_constant_array_expr (order_exp))

     return NULL;
 
     return NULL;
 

+  /* Proceed with simplification, unpacking the array.  */
+

   mpz_init (index);
   rank = 0;
   head = tail = NULL;
   mpz_init (index);
   rank = 0;
   head = tail = NULL;


@@ -2873,13 +3397,11 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
          goto bad_reshape;
        }
 
          goto bad_reshape;
        }
 

-      gfc_free_expr (e);
-

       if (rank >= GFC_MAX_DIMENSIONS)
        {
          gfc_error ("Too many dimensions in shape specification for RESHAPE "
                     "at %L", &e->where);
       if (rank >= GFC_MAX_DIMENSIONS)
        {
          gfc_error ("Too many dimensions in shape specification for RESHAPE "
                     "at %L", &e->where);

-
+         gfc_free_expr (e);

          goto bad_reshape;
        }
 
          goto bad_reshape;
        }
 


@@ -2887,9 +3409,11 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
        {
          gfc_error ("Shape specification at %L cannot be negative",
                     &e->where);
        {
          gfc_error ("Shape specification at %L cannot be negative",
                     &e->where);

+         gfc_free_expr (e);

          goto bad_reshape;
        }
 
          goto bad_reshape;
        }
 

+      gfc_free_expr (e);

       rank++;
     }
 
       rank++;
     }
 


@@ -2929,12 +3453,11 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
              goto bad_reshape;
            }
 
              goto bad_reshape;
            }
 

-         gfc_free_expr (e);
-

          if (order[i] < 1 || order[i] > rank)
            {
              gfc_error ("ORDER parameter of RESHAPE at %L is out of range",
                         &e->where);
          if (order[i] < 1 || order[i] > rank)
            {
              gfc_error ("ORDER parameter of RESHAPE at %L is out of range",
                         &e->where);

+             gfc_free_expr (e);

              goto bad_reshape;
            }
 
              goto bad_reshape;
            }
 


@@ -2944,9 +3467,12 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
            {
              gfc_error ("Invalid permutation in ORDER parameter at %L",
                         &e->where);
            {
              gfc_error ("Invalid permutation in ORDER parameter at %L",
                         &e->where);

+             gfc_free_expr (e);

              goto bad_reshape;
            }
 
              goto bad_reshape;
            }
 

+         gfc_free_expr (e);
+

          x[order[i]] = 1;
        }
     }
          x[order[i]] = 1;
        }
     }


@@ -2986,7 +3512,7 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
        }
 
       if (mpz_cmp_ui (index, INT_MAX) > 0)
        }
 
       if (mpz_cmp_ui (index, INT_MAX) > 0)

-       gfc_internal_error ("Reshaped array too large at %L", &e->where);
+       gfc_internal_error ("Reshaped array too large at %C");

 
       j = mpz_get_ui (index);
 
 
       j = mpz_get_ui (index);
 


@@ -3118,6 +3644,7 @@ gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
       || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
     {
       gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
       || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
     {
       gfc_error ("Result of SCALE overflows its kind at %L", &result->where);

+      gfc_free_expr (result);

       return &gfc_bad_expr;
     }
 
       return &gfc_bad_expr;
     }
 


@@ -3143,20 +3670,68 @@ gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
   else
     mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
 
   else
     mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
 

-  mpfr_clear (scale);
-  mpfr_clear (radix);
+  mpfr_clears (scale, radix, NULL);

 
   return range_check (result, "SCALE");
 }
 
 
 
   return range_check (result, "SCALE");
 }
 
 

+/* Variants of strspn and strcspn that operate on wide characters.  */
+
+static size_t
+wide_strspn (const gfc_char_t *s1, const gfc_char_t *s2)
+{
+  size_t i = 0;
+  const gfc_char_t *c;
+
+  while (s1[i])
+    {
+      for (c = s2; *c; c++)
+       {
+         if (s1[i] == *c)
+           break;
+       }
+      if (*c == '\0')
+       break;
+      i++;
+    }
+
+  return i;
+}
+
+static size_t
+wide_strcspn (const gfc_char_t *s1, const gfc_char_t *s2)
+{
+  size_t i = 0;
+  const gfc_char_t *c;
+
+  while (s1[i])
+    {
+      for (c = s2; *c; c++)
+       {
+         if (s1[i] == *c)
+           break;
+       }
+      if (*c)
+       break;
+      i++;
+    }
+
+  return i;
+}
+
+

 gfc_expr *
 gfc_expr *

-gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b)
+gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind)

 {
   gfc_expr *result;
   int back;
   size_t i;
   size_t indx, len, lenc;
 {
   gfc_expr *result;
   int back;
   size_t i;
   size_t indx, len, lenc;

+  int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind);
+
+  if (k == -1)
+    return &gfc_bad_expr;

 
   if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT)
     return NULL;
 
   if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT)
     return NULL;


@@ -3166,8 +3741,7 @@ gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b)
   else
     back = 0;
 
   else
     back = 0;
 

-  result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
-                               &e->where);
+  result = gfc_constant_result (BT_INTEGER, k, &e->where);

 
   len = e->value.character.length;
   lenc = c->value.character.length;
 
   len = e->value.character.length;
   lenc = c->value.character.length;


@@ -3180,8 +3754,8 @@ gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b)
     {
       if (back == 0)
        {
     {
       if (back == 0)
        {

-         indx = strcspn (e->value.character.string, c->value.character.string)
-              + 1;
+         indx = wide_strcspn (e->value.character.string,
+                              c->value.character.string) + 1;

          if (indx > len)
            indx = 0;
        }
          if (indx > len)
            indx = 0;
        }


@@ -3207,6 +3781,30 @@ gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b)
 
 
 gfc_expr *
 
 
 gfc_expr *

+gfc_simplify_selected_char_kind (gfc_expr *e)
+{
+  int kind;
+  gfc_expr *result;
+
+  if (e->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  if (gfc_compare_with_Cstring (e, "ascii", false) == 0
+      || gfc_compare_with_Cstring (e, "default", false) == 0)
+    kind = 1;
+  else if (gfc_compare_with_Cstring (e, "iso_10646", false) == 0)
+    kind = 4;
+  else
+    kind = -1;
+
+  result = gfc_int_expr (kind);
+  result->where = e->where;
+
+  return result;
+}
+
+
+gfc_expr *

 gfc_simplify_selected_int_kind (gfc_expr *e)
 {
   int i, kind, range;
 gfc_simplify_selected_int_kind (gfc_expr *e)
 {
   int i, kind, range;


@@ -3302,14 +3900,13 @@ gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
 
   result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
 
 
   result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
 

-  gfc_set_model_kind (x->ts.kind);
-

   if (mpfr_sgn (x->value.real) == 0)
     {
       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
       return result;
     }
 
   if (mpfr_sgn (x->value.real) == 0)
     {
       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
       return result;
     }
 

+  gfc_set_model_kind (x->ts.kind);

   mpfr_init (absv);
   mpfr_init (log2);
   mpfr_init (exp);
   mpfr_init (absv);
   mpfr_init (log2);
   mpfr_init (exp);


@@ -3331,10 +3928,7 @@ gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
   exp2 = (unsigned long) mpz_get_d (i->value.integer);
   mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE);
 
   exp2 = (unsigned long) mpz_get_d (i->value.integer);
   mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE);
 

-  mpfr_clear (absv);
-  mpfr_clear (log2);
-  mpfr_clear (pow2);
-  mpfr_clear (frac);
+  mpfr_clears (absv, log2, pow2, frac, NULL);

 
   return range_check (result, "SET_EXPONENT");
 }
 
   return range_check (result, "SET_EXPONENT");
 }


@@ -3347,9 +3941,13 @@ gfc_simplify_shape (gfc_expr *source)
   gfc_expr *result, *e, *f;
   gfc_array_ref *ar;
   int n;
   gfc_expr *result, *e, *f;
   gfc_array_ref *ar;
   int n;

-  try t;
+  gfc_try t;
+
+  if (source->rank == 0)
+    return gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind,
+                                 &source->where);

 
 

-  if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
+  if (source->expr_type != EXPR_VARIABLE)

     return NULL;
 
   result = gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind,
     return NULL;
 
   result = gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind,


@@ -3373,7 +3971,7 @@ gfc_simplify_shape (gfc_expr *source)
        {
          mpz_set_ui (e->value.integer, n + 1);
 
        {
          mpz_set_ui (e->value.integer, n + 1);
 

-         f = gfc_simplify_size (source, e);
+         f = gfc_simplify_size (source, e, NULL);

          gfc_free_expr (e);
          if (f == NULL)
            {
          gfc_free_expr (e);
          if (f == NULL)
            {


@@ -3394,11 +3992,15 @@ gfc_simplify_shape (gfc_expr *source)
 
 
 gfc_expr *
 
 
 gfc_expr *

-gfc_simplify_size (gfc_expr *array, gfc_expr *dim)
+gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)

 {
   mpz_t size;
   gfc_expr *result;
   int d;
 {
   mpz_t size;
   gfc_expr *result;
   int d;

+  int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind);
+
+  if (k == -1)
+    return &gfc_bad_expr;

 
   if (dim == NULL)
     {
 
   if (dim == NULL)
     {


@@ -3415,11 +4017,8 @@ gfc_simplify_size (gfc_expr *array, gfc_expr *dim)
        return NULL;
     }
 
        return NULL;
     }
 

-  result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
-                               &array->where);
-
+  result = gfc_constant_result (BT_INTEGER, k, &array->where);

   mpz_set (result->value.integer, size);
   mpz_set (result->value.integer, size);

-

   return result;
 }
 
   return result;
 }
 


@@ -3490,8 +4089,7 @@ gfc_simplify_sin (gfc_expr *x)
       mpfr_sinh (xq, x->value.complex.i, GFC_RND_MODE);
       mpfr_mul (result->value.complex.i, xp, xq, 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_clear (xp);
-      mpfr_clear (xq);
+      mpfr_clears (xp, xq, NULL);

       break;
 
     default:
       break;
 
     default:


@@ -3667,11 +4265,7 @@ gfc_simplify_sqrt (gfc_expr *e)
        gfc_internal_error ("invalid complex argument of SQRT at %L",
                            &e->where);
 
        gfc_internal_error ("invalid complex argument of SQRT at %L",
                            &e->where);
 

-      mpfr_clear (s);
-      mpfr_clear (t);
-      mpfr_clear (ac);
-      mpfr_clear (ad);
-      mpfr_clear (w);
+      mpfr_clears (s, t, ac, ad, w, NULL);

 
       break;
 
 
       break;
 


@@ -3740,14 +4334,119 @@ gfc_simplify_tiny (gfc_expr *e)
 
 
 gfc_expr *
 
 
 gfc_expr *

+gfc_simplify_trailz (gfc_expr *e)
+{
+  gfc_expr *result;
+  unsigned long tz, bs;
+  int i;
+
+  if (e->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
+  bs = gfc_integer_kinds[i].bit_size;
+  tz = mpz_scan1 (e->value.integer, 0);
+
+  result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, &e->where);
+  mpz_set_ui (result->value.integer, MIN (tz, bs));
+
+  return result;
+}
+
+
+gfc_expr *

 gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
 {
 gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
 {

-  /* Reference mold and size to suppress warning.  */
-  if (gfc_init_expr && (mold || size))
-    gfc_error ("TRANSFER intrinsic not implemented for initialization at %L",
-              &source->where);
+  gfc_expr *result;
+  gfc_expr *mold_element;
+  size_t source_size;
+  size_t result_size;
+  size_t result_elt_size;
+  size_t buffer_size;
+  mpz_t tmp;
+  unsigned char *buffer;
+
+  if (!gfc_is_constant_expr (source)
+       || (gfc_init_expr && !gfc_is_constant_expr (mold))
+       || !gfc_is_constant_expr (size))
+    return NULL;

 
 

-  return NULL;
+  if (source->expr_type == EXPR_FUNCTION)
+    return NULL;
+
+  /* Calculate the size of the source.  */
+  if (source->expr_type == EXPR_ARRAY
+      && gfc_array_size (source, &tmp) == FAILURE)
+    gfc_internal_error ("Failure getting length of a constant array.");
+
+  source_size = gfc_target_expr_size (source);
+
+  /* Create an empty new expression with the appropriate characteristics.  */
+  result = gfc_constant_result (mold->ts.type, mold->ts.kind,
+                               &source->where);
+  result->ts = mold->ts;
+
+  mold_element = mold->expr_type == EXPR_ARRAY
+                ? mold->value.constructor->expr
+                : mold;
+
+  /* Set result character length, if needed.  Note that this needs to be
+     set even for array expressions, in order to pass this information into 
+     gfc_target_interpret_expr.  */
+  if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element))
+    result->value.character.length = mold_element->value.character.length;
+  
+  /* Set the number of elements in the result, and determine its size.  */
+  result_elt_size = gfc_target_expr_size (mold_element);
+  if (result_elt_size == 0)
+    {
+      gfc_free_expr (result);
+      return NULL;
+    }
+
+  if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
+    {
+      int result_length;
+
+      result->expr_type = EXPR_ARRAY;
+      result->rank = 1;
+
+      if (size)
+       result_length = (size_t)mpz_get_ui (size->value.integer);
+      else
+       {
+         result_length = source_size / result_elt_size;
+         if (result_length * result_elt_size < source_size)
+           result_length += 1;
+       }
+
+      result->shape = gfc_get_shape (1);
+      mpz_init_set_ui (result->shape[0], result_length);
+
+      result_size = result_length * result_elt_size;
+    }
+  else
+    {
+      result->rank = 0;
+      result_size = result_elt_size;
+    }
+
+  if (gfc_option.warn_surprising && source_size < result_size)
+    gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: "
+               "source size %ld < result size %ld", &source->where,
+               (long) source_size, (long) result_size);
+
+  /* Allocate the buffer to store the binary version of the source.  */
+  buffer_size = MAX (source_size, result_size);
+  buffer = (unsigned char*)alloca (buffer_size);
+
+  /* Now write source to the buffer.  */
+  gfc_target_encode_expr (source, buffer, buffer_size);
+
+  /* And read the buffer back into the new expression.  */
+  gfc_target_interpret_expr (buffer, buffer_size, result);
+
+  return result;

 }
 
 
 }
 
 


@@ -3775,7 +4474,7 @@ gfc_simplify_trim (gfc_expr *e)
   lentrim = len - count;
 
   result->value.character.length = lentrim;
   lentrim = len - count;
 
   result->value.character.length = lentrim;

-  result->value.character.string = gfc_getmem (lentrim + 1);
+  result->value.character.string = gfc_get_wide_string (lentrim + 1);

 
   for (i = 0; i < lentrim; i++)
     result->value.character.string[i] = e->value.character.string[i];
 
   for (i = 0; i < lentrim; i++)
     result->value.character.string[i] = e->value.character.string[i];


@@ -3787,19 +4486,23 @@ gfc_simplify_trim (gfc_expr *e)
 
 
 gfc_expr *
 
 
 gfc_expr *

-gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim)
+gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)

 {
 {

-  return simplify_bound (array, dim, 1);
+  return simplify_bound (array, dim, kind, 1);

 }
 
 
 gfc_expr *
 }
 
 
 gfc_expr *

-gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b)
+gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind)

 {
   gfc_expr *result;
   int back;
   size_t index, len, lenset;
   size_t i;
 {
   gfc_expr *result;
   int back;
   size_t index, len, lenset;
   size_t i;

+  int k = get_kind (BT_INTEGER, kind, "VERIFY", gfc_default_integer_kind);
+
+  if (k == -1)
+    return &gfc_bad_expr;

 
   if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT)
     return NULL;
 
   if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT)
     return NULL;


@@ -3809,8 +4512,7 @@ gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b)
   else
     back = 0;
 
   else
     back = 0;
 

-  result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
-                               &s->where);
+  result = gfc_constant_result (BT_INTEGER, k, &s->where);

 
   len = s->value.character.length;
   lenset = set->value.character.length;
 
   len = s->value.character.length;
   lenset = set->value.character.length;


@@ -3829,8 +4531,8 @@ gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b)
          return result;
        }
 
          return result;
        }
 

-      index = strspn (s->value.character.string, set->value.character.string)
-           + 1;
+      index = wide_strspn (s->value.character.string,
+                          set->value.character.string) + 1;

       if (index > len)
        index = 0;
 
       if (index > len)
        index = 0;
 


@@ -3874,15 +4576,16 @@ gfc_simplify_xor (gfc_expr *x, gfc_expr *y)
     {
       result = gfc_constant_result (BT_INTEGER, kind, &x->where);
       mpz_xor (result->value.integer, x->value.integer, y->value.integer);
     {
       result = gfc_constant_result (BT_INTEGER, kind, &x->where);
       mpz_xor (result->value.integer, x->value.integer, y->value.integer);

+      return range_check (result, "XOR");

     }
   else /* BT_LOGICAL */
     {
       result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
       result->value.logical = (x->value.logical && !y->value.logical)
                              || (!x->value.logical && y->value.logical);
     }
   else /* BT_LOGICAL */
     {
       result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
       result->value.logical = (x->value.logical && !y->value.logical)
                              || (!x->value.logical && y->value.logical);

+      return result;

     }
 
     }
 

-  return range_check (result, "XOR");

 }
 
 
 }
 
 


@@ -4064,3 +4767,87 @@ gfc_convert_constant (gfc_expr *e, bt type, int kind)
 
   return result;
 }
 
   return result;
 }

+
+
+/* Function for converting character constants.  */
+gfc_expr *
+gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind)
+{
+  gfc_expr *result;
+  int i;
+
+  if (!gfc_is_constant_expr (e))
+    return NULL;
+
+  if (e->expr_type == EXPR_CONSTANT)
+    {
+      /* Simple case of a scalar.  */
+      result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
+      if (result == NULL)
+       return &gfc_bad_expr;
+
+      result->value.character.length = e->value.character.length;
+      result->value.character.string
+       = gfc_get_wide_string (e->value.character.length + 1);
+      memcpy (result->value.character.string, e->value.character.string,
+             (e->value.character.length + 1) * sizeof (gfc_char_t));
+
+      /* Check we only have values representable in the destination kind.  */
+      for (i = 0; i < result->value.character.length; i++)
+       if (!gfc_check_character_range (result->value.character.string[i],
+                                       kind))
+         {
+           gfc_error ("Character '%s' in string at %L cannot be converted "
+                      "into character kind %d",
+                      gfc_print_wide_char (result->value.character.string[i]),
+                      &e->where, kind);
+           return &gfc_bad_expr;
+         }
+
+      return result;
+    }
+  else if (e->expr_type == EXPR_ARRAY)
+    {
+      /* For an array constructor, we convert each constructor element.  */
+      gfc_constructor *head = NULL, *tail = NULL, *c;
+
+      for (c = e->value.constructor; c; c = c->next)
+       {
+         if (head == NULL)
+           head = tail = gfc_get_constructor ();
+         else
+           {
+             tail->next = gfc_get_constructor ();
+             tail = tail->next;
+           }
+
+         tail->where = c->where;
+         tail->expr = gfc_convert_char_constant (c->expr, type, kind);
+         if (tail->expr == &gfc_bad_expr)
+           {
+             tail->expr = NULL;
+             return &gfc_bad_expr;
+           }
+
+         if (tail->expr == NULL)
+           {
+             gfc_free_constructor (head);
+             return NULL;
+           }
+       }
+
+      result = gfc_get_expr ();
+      result->ts.type = type;
+      result->ts.kind = kind;
+      result->expr_type = EXPR_ARRAY;
+      result->value.constructor = head;
+      result->shape = gfc_copy_shape (e->shape, e->rank);
+      result->where = e->where;
+      result->rank = e->rank;
+      result->ts.cl = e->ts.cl;
+
+      return result;
+    }
+  else
+    return NULL;
+}