OSDN Git Service

* dependency.c (gfc_check_dependency): Remove unused vars and nvars
[pf3gnuchains/gcc-fork.git] / gcc / fortran / simplify.c
index 5004b83..894903b 100644 (file)
@@ -1,6 +1,6 @@
 /* Simplify intrinsic functions at compile-time.
-   Copyright (C) 2000, 2001, 2002, 2003, 2004 Free Software Foundation,
-   Inc.
+   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software
+   Foundation, Inc.
    Contributed by Andy Vaught & Katherine Holcomb
 
 This file is part of GCC.
@@ -17,15 +17,12 @@ 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.  */
 
 #include "config.h"
 #include "system.h"
 #include "flags.h"
-
-#include <string.h>
-
 #include "gfortran.h"
 #include "arith.h"
 #include "intrinsic.h"
@@ -266,6 +263,27 @@ gfc_simplify_acos (gfc_expr * x)
   return range_check (result, "ACOS");
 }
 
+gfc_expr *
+gfc_simplify_acosh (gfc_expr * x)
+{
+  gfc_expr *result;
+
+  if (x->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  if (mpfr_cmp_si (x->value.real, 1) < 0)
+    {
+      gfc_error ("Argument of ACOSH at %L must not be less than 1",
+                &x->where);
+      return &gfc_bad_expr;
+    }
+
+  result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+
+  mpfr_acosh (result->value.real, x->value.real, GFC_RND_MODE);
+
+  return range_check (result, "ACOSH");
+}
 
 gfc_expr *
 gfc_simplify_adjustl (gfc_expr * e)
@@ -354,6 +372,7 @@ gfc_simplify_adjustr (gfc_expr * e)
 gfc_expr *
 gfc_simplify_aimag (gfc_expr * e)
 {
+
   gfc_expr *result;
 
   if (e->expr_type != EXPR_CONSTANT)
@@ -412,9 +431,8 @@ gfc_simplify_dint (gfc_expr * e)
 gfc_expr *
 gfc_simplify_anint (gfc_expr * e, gfc_expr * k)
 {
-  gfc_expr *rtrunc, *result;
-  int kind, cmp;
-  mpfr_t half;
+  gfc_expr *result;
+  int kind;
 
   kind = get_kind (BT_REAL, k, "ANINT", e->ts.kind);
   if (kind == -1)
@@ -425,70 +443,48 @@ gfc_simplify_anint (gfc_expr * e, gfc_expr * k)
 
   result = gfc_constant_result (e->ts.type, kind, &e->where);
 
-  rtrunc = gfc_copy_expr (e);
+  mpfr_round (result->value.real, e->value.real);
+
+  return range_check (result, "ANINT");
+}
 
-  cmp = mpfr_cmp_ui (e->value.real, 0);
 
-  gfc_set_model_kind (kind);
-  mpfr_init (half);
-  mpfr_set_str (half, "0.5", 10, GFC_RND_MODE);
+gfc_expr *
+gfc_simplify_and (gfc_expr * x, gfc_expr * y)
+{
+  gfc_expr *result;
+  int kind;
 
-  if (cmp > 0)
+  if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
+  if (x->ts.type == BT_INTEGER)
     {
-      mpfr_add (rtrunc->value.real, e->value.real, half, GFC_RND_MODE);
-      mpfr_trunc (result->value.real, rtrunc->value.real);
+      result = gfc_constant_result (BT_INTEGER, kind, &x->where);
+      mpz_and (result->value.integer, x->value.integer, y->value.integer);
     }
-  else if (cmp < 0)
+  else /* BT_LOGICAL */
     {
-      mpfr_sub (rtrunc->value.real, e->value.real, half, GFC_RND_MODE);
-      mpfr_trunc (result->value.real, rtrunc->value.real);
+      result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
+      result->value.logical = x->value.logical && y->value.logical;
     }
-  else
-    mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
-
-  gfc_free_expr (rtrunc);
-  mpfr_clear (half);
 
-  return range_check (result, "ANINT");
+  return range_check (result, "AND");
 }
 
 
 gfc_expr *
 gfc_simplify_dnint (gfc_expr * e)
 {
-  gfc_expr *rtrunc, *result;
-  int cmp;
-  mpfr_t half;
+  gfc_expr *result;
 
   if (e->expr_type != EXPR_CONSTANT)
     return NULL;
 
-  result =
-    gfc_constant_result (BT_REAL, gfc_default_double_kind, &e->where);
-
-  rtrunc = gfc_copy_expr (e);
-
-  cmp = mpfr_cmp_ui (e->value.real, 0);
-
-  gfc_set_model_kind (gfc_default_double_kind);
-  mpfr_init (half);
-  mpfr_set_str (half, "0.5", 10, GFC_RND_MODE);
-
-  if (cmp > 0)
-    {
-      mpfr_add (rtrunc->value.real, e->value.real, half, GFC_RND_MODE);
-      mpfr_trunc (result->value.real, rtrunc->value.real);
-    }
-  else if (cmp < 0)
-    {
-      mpfr_sub (rtrunc->value.real, e->value.real, half, GFC_RND_MODE);
-      mpfr_trunc (result->value.real, rtrunc->value.real);
-    }
-  else
-    mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
+  result = gfc_constant_result (BT_REAL, gfc_default_double_kind, &e->where);
 
-  gfc_free_expr (rtrunc);
-  mpfr_clear (half);
+  mpfr_round (result->value.real, e->value.real);
 
   return range_check (result, "DNINT");
 }
@@ -518,7 +514,7 @@ gfc_simplify_asin (gfc_expr * x)
 
 
 gfc_expr *
-gfc_simplify_atan (gfc_expr * x)
+gfc_simplify_asinh (gfc_expr * x)
 {
   gfc_expr *result;
 
@@ -527,10 +523,49 @@ gfc_simplify_atan (gfc_expr * x)
 
   result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
 
+  mpfr_asinh(result->value.real, x->value.real, GFC_RND_MODE);
+
+  return range_check (result, "ASINH");
+}
+
+
+gfc_expr *
+gfc_simplify_atan (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_atan(result->value.real, x->value.real, GFC_RND_MODE);
 
   return range_check (result, "ATAN");
+}
+
+
+gfc_expr *
+gfc_simplify_atanh (gfc_expr * x)
+{
+  gfc_expr *result;
+
+  if (x->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  if (mpfr_cmp_si (x->value.real, 1) >= 0 ||
+      mpfr_cmp_si (x->value.real, -1) <= 0)
+    {
+      gfc_error ("Argument of ATANH at %L must be inside the range -1 to 1",
+                &x->where);
+      return &gfc_bad_expr;
+    }
+
+  result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+
+  mpfr_atanh(result->value.real, x->value.real, GFC_RND_MODE);
 
+  return range_check (result, "ATANH");
 }
 
 
@@ -556,7 +591,6 @@ gfc_simplify_atan2 (gfc_expr * y, gfc_expr * x)
   arctangent2 (y->value.real, x->value.real, result->value.real);
 
   return range_check (result, "ATAN2");
-
 }
 
 
@@ -595,7 +629,7 @@ gfc_simplify_ceiling (gfc_expr * e, gfc_expr * k)
   gfc_expr *ceil, *result;
   int kind;
 
-  kind = get_kind (BT_REAL, k, "CEILING", gfc_default_real_kind);
+  kind = get_kind (BT_INTEGER, k, "CEILING", gfc_default_integer_kind);
   if (kind == -1)
     return &gfc_bad_expr;
 
@@ -628,7 +662,7 @@ gfc_simplify_char (gfc_expr * e, gfc_expr * k)
   if (e->expr_type != EXPR_CONSTANT)
     return NULL;
 
-  if (gfc_extract_int (e, &c) != NULL || c < 0 || c > 255)
+  if (gfc_extract_int (e, &c) != NULL || c < 0 || c > UCHAR_MAX)
     {
       gfc_error ("Bad character in CHAR function at %L", &e->where);
       return &gfc_bad_expr;
@@ -715,6 +749,34 @@ gfc_simplify_cmplx (gfc_expr * x, gfc_expr * y, gfc_expr * k)
 
 
 gfc_expr *
+gfc_simplify_complex (gfc_expr * x, gfc_expr * y)
+{
+  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)
+       kind = gfc_default_real_kind;
+      else
+       kind = y->ts.kind;
+    }
+  else
+    {
+      if (y->ts.type == BT_REAL)
+       kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
+      else
+       kind = x->ts.kind;
+    }
+
+  return simplify_cmplx ("COMPLEX", x, y, kind);
+}
+
+
+gfc_expr *
 gfc_simplify_conjg (gfc_expr * e)
 {
   gfc_expr *result;
@@ -858,11 +920,13 @@ gfc_expr *
 gfc_simplify_dim (gfc_expr * x, gfc_expr * y)
 {
   gfc_expr *result;
+  int kind;
 
   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);
+  kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
+  result = gfc_constant_result (x->ts.type, kind, &x->where);
 
   switch (x->ts.type)
     {
@@ -970,6 +1034,7 @@ gfc_simplify_exp (gfc_expr * x)
 gfc_expr *
 gfc_simplify_exponent (gfc_expr * x)
 {
+  int i;
   mpfr_t tmp;
   gfc_expr *result;
 
@@ -994,6 +1059,12 @@ gfc_simplify_exponent (gfc_expr * x)
 
   gfc_mpfr_to_mpz (result->value.integer, tmp);
 
+  /* The model number for tiny(x) is b**(emin - 1) where b is the base and emin
+     is the smallest exponent value.  So, we need to add 1 if x is tiny(x).  */
+  i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
+  if (mpfr_cmp (x->value.real, gfc_real_kinds[i].tiny) == 0)
+    mpz_add_ui (result->value.integer,result->value.integer, 1);
+
   mpfr_clear (tmp);
 
   return range_check (result, "EXPONENT");
@@ -1020,7 +1091,7 @@ gfc_simplify_floor (gfc_expr * e, gfc_expr * k)
   mpfr_t floor;
   int kind;
 
-  kind = get_kind (BT_REAL, k, "FLOOR", gfc_default_real_kind);
+  kind = get_kind (BT_INTEGER, k, "FLOOR", gfc_default_integer_kind);
   if (kind == -1)
     gfc_internal_error ("gfc_simplify_floor(): Bad kind");
 
@@ -1277,6 +1348,9 @@ gfc_simplify_ibset (gfc_expr * x, gfc_expr * y)
   result = gfc_copy_expr (x);
 
   mpz_setbit (result->value.integer, pos);
+
+  twos_complement (result->value.integer, gfc_integer_kinds[k].bit_size);
+
   return range_check (result, "IBSET");
 }
 
@@ -1296,9 +1370,9 @@ gfc_simplify_ichar (gfc_expr * e)
       return &gfc_bad_expr;
     }
 
-  index = (int) e->value.character.string[0];
+  index = (unsigned char) e->value.character.string[0];
 
-  if (index < CHAR_MIN || index > CHAR_MAX)
+  if (index < 0 || index > UCHAR_MAX)
     {
       gfc_error ("Argument of ICHAR at %L out of range of this processor",
                 &e->where);
@@ -1476,7 +1550,7 @@ gfc_simplify_int (gfc_expr * e, gfc_expr * k)
   gfc_expr *rpart, *rtrunc, *result;
   int kind;
 
-  kind = get_kind (BT_REAL, k, "INT", gfc_default_real_kind);
+  kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind);
   if (kind == -1)
     return &gfc_bad_expr;
 
@@ -1769,16 +1843,18 @@ gfc_simplify_kind (gfc_expr * e)
 
 
 static gfc_expr *
-gfc_simplify_bound (gfc_expr * array, gfc_expr * dim, int upper)
+simplify_bound (gfc_expr * array, gfc_expr * dim, int upper)
 {
   gfc_ref *ref;
   gfc_array_spec *as;
-  int i;
+  gfc_expr *e;
+  int d;
 
   if (array->expr_type != EXPR_VARIABLE)
     return NULL;
 
   if (dim == NULL)
+    /* TODO: Simplify constant multi-dimensional bounds.  */
     return NULL;
 
   if (dim->expr_type != EXPR_CONSTANT)
@@ -1786,29 +1862,66 @@ gfc_simplify_bound (gfc_expr * array, gfc_expr * dim, int upper)
 
   /* Follow any component references.  */
   as = array->symtree->n.sym->as;
-  ref = array->ref;
-  while (ref->next != NULL)
+  for (ref = array->ref; ref; ref = ref->next)
     {
-      if (ref->type == REF_COMPONENT)
-       as = ref->u.c.sym->as;
-      ref = ref->next;
+      switch (ref->type)
+       {
+       case REF_ARRAY:
+         switch (ref->u.ar.type)
+           {
+           case AR_ELEMENT:
+             as = NULL;
+             continue;
+
+           case AR_FULL:
+             /* We're done because 'as' has already been set in the
+                previous iteration.  */
+             goto done;
+
+           case AR_SECTION:
+           case AR_UNKNOWN:
+             return NULL;
+           }
+
+         gcc_unreachable ();
+
+       case REF_COMPONENT:
+         as = ref->u.c.component->as;
+         continue;
+
+       case REF_SUBSTRING:
+         continue;
+       }
     }
 
-  if (ref->type != REF_ARRAY || ref->u.ar.type != AR_FULL)
+  gcc_unreachable ();
+
+ done:
+  if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)
     return NULL;
-  
-  i = mpz_get_si (dim->value.integer);
-  if (upper) 
-    return gfc_copy_expr (as->upper[i-1]);
-  else
-    return gfc_copy_expr (as->lower[i-1]);
+
+  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;
+    }
+
+  e = upper ? as->upper[d-1] : as->lower[d-1];
+
+  if (e->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  return gfc_copy_expr (e);
 }
 
 
 gfc_expr *
 gfc_simplify_lbound (gfc_expr * array, gfc_expr * dim)
 {
-  return gfc_simplify_bound (array, dim, 0);
+  return simplify_bound (array, dim, 0);
 }
 
 
@@ -2142,11 +2255,13 @@ gfc_simplify_mod (gfc_expr * a, gfc_expr * p)
 {
   gfc_expr *result;
   mpfr_t quot, iquot, term;
+  int kind;
 
   if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
     return NULL;
 
-  result = gfc_constant_result (a->ts.type, a->ts.kind, &a->where);
+  kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
+  result = gfc_constant_result (a->ts.type, kind, &a->where);
 
   switch (a->ts.type)
     {
@@ -2170,7 +2285,7 @@ gfc_simplify_mod (gfc_expr * a, gfc_expr * p)
          return &gfc_bad_expr;
        }
 
-      gfc_set_model_kind (a->ts.kind);
+      gfc_set_model_kind (kind);
       mpfr_init (quot);
       mpfr_init (iquot);
       mpfr_init (term);
@@ -2198,11 +2313,13 @@ gfc_simplify_modulo (gfc_expr * a, gfc_expr * p)
 {
   gfc_expr *result;
   mpfr_t quot, iquot, term;
+  int kind;
 
   if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
     return NULL;
 
-  result = gfc_constant_result (a->ts.type, a->ts.kind, &a->where);
+  kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
+  result = gfc_constant_result (a->ts.type, kind, &a->where);
 
   switch (a->ts.type)
     {
@@ -2228,7 +2345,7 @@ gfc_simplify_modulo (gfc_expr * a, gfc_expr * p)
          return &gfc_bad_expr;
        }
 
-      gfc_set_model_kind (a->ts.kind);
+      gfc_set_model_kind (kind);
       mpfr_init (quot);
       mpfr_init (iquot);
       mpfr_init (term);
@@ -2236,12 +2353,11 @@ gfc_simplify_modulo (gfc_expr * a, gfc_expr * p)
       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_sub (result->value.real, a->value.real, term, GFC_RND_MODE);
       break;
 
     default:
@@ -2268,64 +2384,71 @@ gfc_expr *
 gfc_simplify_nearest (gfc_expr * x, gfc_expr * s)
 {
   gfc_expr *result;
-  float rval;
-  double val, eps;
-  int p, i, k, match_float;
-
-  /* FIXME: This implementation is dopey and probably not quite right,
-     but it's a start.  */
+  mpfr_t tmp;
+  int direction, sgn;
 
-  if (x->expr_type != EXPR_CONSTANT)
+  if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
     return NULL;
 
-  k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
-
-  result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+  gfc_set_model_kind (x->ts.kind);
+  result = gfc_copy_expr (x);
 
-  val = mpfr_get_d (x->value.real, GFC_RND_MODE);
-  p = gfc_real_kinds[k].digits;
+  direction = mpfr_sgn (s->value.real);
 
-  eps = 1.;
-  for (i = 1; i < p; ++i)
+  if (direction == 0)
     {
-      eps = eps / 2.;
+      gfc_error ("Second argument of NEAREST at %L may not be zero",
+                &s->where);
+      gfc_free (result);
+      return &gfc_bad_expr;
     }
 
-  /* TODO we should make sure that 'float' matches kind 4 */
-  match_float = gfc_real_kinds[k].kind == 4;
-  if (mpfr_cmp_ui (s->value.real, 0) > 0)
+  /* TODO: Use mpfr_nextabove and mpfr_nextbelow once we move to a
+     newer version of mpfr.  */
+
+  sgn = mpfr_sgn (x->value.real);
+
+  if (sgn == 0)
     {
-      if (match_float)
-       {
-         rval = (float) val;
-         rval = rval + eps;
-         mpfr_set_d (result->value.real, rval, GFC_RND_MODE);
-       }
+      int k = gfc_validate_kind (BT_REAL, x->ts.kind, 0);
+
+      if (direction > 0)
+       mpfr_add (result->value.real,
+                 x->value.real, gfc_real_kinds[k].subnormal, GFC_RND_MODE);
       else
-       {
-         val = val + eps;
-         mpfr_set_d (result->value.real, val, GFC_RND_MODE);
-       }
+       mpfr_sub (result->value.real,
+                 x->value.real, gfc_real_kinds[k].subnormal, GFC_RND_MODE);
     }
-  else if (mpfr_cmp_ui (s->value.real, 0) < 0)
+  else
     {
-      if (match_float)
+      if (sgn < 0)
        {
-         rval = (float) val;
-         rval = rval - eps;
-         mpfr_set_d (result->value.real, rval, GFC_RND_MODE);
+         direction = -direction;
+         mpfr_neg (result->value.real, result->value.real, GFC_RND_MODE);
        }
+
+      if (direction > 0)
+       mpfr_add_one_ulp (result->value.real, GFC_RND_MODE);
       else
        {
-         val = val - eps;
-         mpfr_set_d (result->value.real, val, GFC_RND_MODE);
+         /* In this case the exponent can shrink, which makes us skip
+            over one number because we subtract one ulp with the
+            larger exponent.  Thus we need to compensate for this.  */
+         mpfr_init_set (tmp, result->value.real, GFC_RND_MODE);
+
+         mpfr_sub_one_ulp (result->value.real, GFC_RND_MODE);
+         mpfr_add_one_ulp (result->value.real, GFC_RND_MODE);
+
+         /* If we're back to where we started, the spacing is one
+            ulp, and we get the correct result by subtracting.  */
+         if (mpfr_cmp (tmp, result->value.real) == 0)
+           mpfr_sub_one_ulp (result->value.real, GFC_RND_MODE);
+
+         mpfr_clear (tmp);
        }
-    }
-  else
-    {
-      gfc_error ("Invalid second argument of NEAREST at %L", &s->where);
-      gfc_free (result);
-      return &gfc_bad_expr;
+
+      if (sgn < 0)
+       mpfr_neg (result->value.real, result->value.real, GFC_RND_MODE);
     }
 
   return range_check (result, "NEAREST");
@@ -2335,9 +2458,8 @@ gfc_simplify_nearest (gfc_expr * x, gfc_expr * s)
 static gfc_expr *
 simplify_nint (const char *name, gfc_expr * e, gfc_expr * k)
 {
-  gfc_expr *rtrunc, *itrunc, *result;
-  int kind, cmp;
-  mpfr_t half;
+  gfc_expr *itrunc, *result;
+  int kind;
 
   kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind);
   if (kind == -1)
@@ -2348,33 +2470,13 @@ simplify_nint (const char *name, gfc_expr * e, gfc_expr * k)
 
   result = gfc_constant_result (BT_INTEGER, kind, &e->where);
 
-  rtrunc = gfc_copy_expr (e);
   itrunc = gfc_copy_expr (e);
 
-  cmp = mpfr_cmp_ui (e->value.real, 0);
-
-  gfc_set_model (e->value.real);
-  mpfr_init (half);
-  mpfr_set_str (half, "0.5", 10, GFC_RND_MODE);
-
-  if (cmp > 0)
-    {
-      mpfr_add (rtrunc->value.real, e->value.real, half, GFC_RND_MODE);
-      mpfr_trunc (itrunc->value.real, rtrunc->value.real);
-    }
-  else if (cmp < 0)
-    {
-      mpfr_sub (rtrunc->value.real, e->value.real, half, GFC_RND_MODE);
-      mpfr_trunc (itrunc->value.real, rtrunc->value.real);
-    }
-  else
-    mpfr_set_ui (itrunc->value.real, 0, GFC_RND_MODE);
+  mpfr_round(itrunc->value.real, e->value.real);
 
   gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real);
 
   gfc_free_expr (itrunc);
-  gfc_free_expr (rtrunc);
-  mpfr_clear (half);
 
   return range_check (result, name);
 }
@@ -2415,6 +2517,8 @@ gfc_simplify_not (gfc_expr * e)
   mpz_and (result->value.integer, result->value.integer,
           gfc_integer_kinds[i].max_int);
 
+  twos_complement (result->value.integer, gfc_integer_kinds[i].bit_size);
+
   return range_check (result, "NOT");
 }
 
@@ -2440,6 +2544,31 @@ gfc_simplify_null (gfc_expr * mold)
 
 
 gfc_expr *
+gfc_simplify_or (gfc_expr * x, gfc_expr * y)
+{
+  gfc_expr *result;
+  int kind;
+
+  if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
+  if (x->ts.type == BT_INTEGER)
+    {
+      result = gfc_constant_result (BT_INTEGER, kind, &x->where);
+      mpz_ior (result->value.integer, x->value.integer, y->value.integer);
+    }
+  else /* BT_LOGICAL */
+    {
+      result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
+      result->value.logical = x->value.logical || y->value.logical;
+    }
+
+  return range_check (result, "OR");
+}
+
+
+gfc_expr *
 gfc_simplify_precision (gfc_expr * e)
 {
   gfc_expr *result;
@@ -2552,6 +2681,21 @@ gfc_simplify_real (gfc_expr * e, gfc_expr * k)
   return range_check (result, "REAL");
 }
 
+
+gfc_expr *
+gfc_simplify_realpart (gfc_expr * e)
+{
+  gfc_expr *result;
+
+  if (e->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
+  mpfr_set (result->value.real, e->value.complex.r, GFC_RND_MODE);
+
+  return range_check (result, "REALPART");
+}
+
 gfc_expr *
 gfc_simplify_repeat (gfc_expr * e, gfc_expr * n)
 {
@@ -2819,7 +2963,7 @@ inc:
   for (i = 0; i < rank; i++)
     mpz_init_set_ui (e->shape[i], shape[i]);
 
-  e->ts = head->expr->ts;
+  e->ts = source->ts;
   e->rank = rank;
 
   return e;
@@ -3581,7 +3725,7 @@ gfc_simplify_trim (gfc_expr * e)
 gfc_expr *
 gfc_simplify_ubound (gfc_expr * array, gfc_expr * dim)
 {
-  return gfc_simplify_bound (array, dim, 1);
+  return simplify_bound (array, dim, 1);
 }
 
 
@@ -3651,6 +3795,34 @@ gfc_simplify_verify (gfc_expr * s, gfc_expr * set, gfc_expr * b)
   return result;
 }
 
+
+gfc_expr *
+gfc_simplify_xor (gfc_expr * x, gfc_expr * y)
+{
+  gfc_expr *result;
+  int kind;
+
+  if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
+  if (x->ts.type == BT_INTEGER)
+    {
+      result = gfc_constant_result (BT_INTEGER, kind, &x->where);
+      mpz_xor (result->value.integer, x->value.integer, y->value.integer);
+    }
+  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 range_check (result, "XOR");
+}
+
+
+
 /****************** Constant simplification *****************/
 
 /* Master function to convert one constant to another.  While this is
@@ -3678,6 +3850,9 @@ gfc_convert_constant (gfc_expr * e, bt type, int kind)
        case BT_COMPLEX:
          f = gfc_int2complex;
          break;
+       case BT_LOGICAL:
+         f = gfc_int2log;
+         break;
        default:
          goto oops;
        }
@@ -3719,9 +3894,45 @@ gfc_convert_constant (gfc_expr * e, bt type, int kind)
       break;
 
     case BT_LOGICAL:
-      if (type != BT_LOGICAL)
-       goto oops;
-      f = gfc_log2log;
+      switch (type)
+       {
+       case BT_INTEGER:
+         f = gfc_log2int;
+         break;
+       case BT_LOGICAL:
+         f = gfc_log2log;
+         break;
+       default:
+         goto oops;
+       }
+      break;
+
+    case BT_HOLLERITH:
+      switch (type)
+       {
+       case BT_INTEGER:
+         f = gfc_hollerith2int;
+         break;
+
+       case BT_REAL:
+         f = gfc_hollerith2real;
+         break;
+
+       case BT_COMPLEX:
+         f = gfc_hollerith2complex;
+         break;
+
+       case BT_CHARACTER:
+         f = gfc_hollerith2character;
+         break;
+
+       case BT_LOGICAL:
+         f = gfc_hollerith2logical;
+         break;
+
+       default:
+         goto oops;
+       }
       break;
 
     default: