X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Ffortran%2Fsimplify.c;h=13a9c5147c0dd824d040d1624ade486af11454c7;hb=ccd3dcb6fb0fb5c9e11e56556c0e6b2233ee8391;hp=4cb29fbfc6780b42aac6d596df1fe1f63fbee61b;hpb=faa9fea4b75802d498535ffbb350933c69d33257;p=pf3gnuchains%2Fgcc-fork.git

diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index 4cb29fbfc67..13a9c5147c0 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -1,6 +1,6 @@
 /* Simplify intrinsic functions at compile-time.
    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
-   2010 Free Software Foundation, Inc.
+   2010, 2011 Free Software Foundation, Inc.
    Contributed by Andy Vaught & Katherine Holcomb
 
 This file is part of GCC.
@@ -27,6 +27,7 @@ along with GCC; see the file COPYING3.  If not see
 #include "intrinsic.h"
 #include "target-memory.h"
 #include "constructor.h"
+#include "version.h"  /* For version_string.  */
 
 
 gfc_expr gfc_bad_expr;
@@ -235,7 +236,8 @@ is_constant_array_expr (gfc_expr *e)
 
   for (c = gfc_constructor_first (e->value.constructor);
        c; c = gfc_constructor_next (c))
-    if (c->expr->expr_type != EXPR_CONSTANT)
+    if (c->expr->expr_type != EXPR_CONSTANT
+	  && c->expr->expr_type != EXPR_STRUCTURE)
       return false;
 
   return true;
@@ -488,11 +490,12 @@ simplify_transformation_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *
      REAL, PARAMETER :: array(n, m) = ...
      REAL, PARAMETER :: s(n) = PROD(array, DIM=1)
 
-  where OP == gfc_multiply().  */
+  where OP == gfc_multiply(). The result might be post processed using post_op. */ 
 
 static gfc_expr *
 simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *dim,
-				  gfc_expr *mask, transformational_op op)
+				  gfc_expr *mask, transformational_op op,
+				  transformational_op post_op)
 {
   mpz_t size;
   int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride;
@@ -514,7 +517,7 @@ simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *d
   gfc_array_size (array, &size);
   arraysize = mpz_get_ui (size);
 
-  arrayvec = (gfc_expr**) gfc_getmem (sizeof (gfc_expr*) * arraysize);
+  arrayvec = XCNEWVEC (gfc_expr*, arraysize);
 
   array_ctor = gfc_constructor_first (array->value.constructor);
   mask_ctor = NULL;
@@ -540,7 +543,7 @@ simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *d
   resultsize = mpz_get_ui (size);
   mpz_clear (size);
 
-  resultvec = (gfc_expr**) gfc_getmem (sizeof (gfc_expr*) * resultsize);
+  resultvec = XCNEWVEC (gfc_expr*, resultsize);
   result_ctor = gfc_constructor_first (result->value.constructor);
   for (i = 0; i < resultsize; ++i)
     {
@@ -606,16 +609,43 @@ simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *d
   result_ctor = gfc_constructor_first (result->value.constructor);
   for (i = 0; i < resultsize; ++i)
     {
-      result_ctor->expr = resultvec[i];
+      if (post_op)
+	result_ctor->expr = post_op (result_ctor->expr, resultvec[i]);
+      else
+	result_ctor->expr = resultvec[i];
       result_ctor = gfc_constructor_next (result_ctor);
     }
 
-  gfc_free (arrayvec);
-  gfc_free (resultvec);
+  free (arrayvec);
+  free (resultvec);
   return result;
 }
 
 
+static gfc_expr *
+simplify_transformation (gfc_expr *array, gfc_expr *dim, gfc_expr *mask,
+			 int init_val, transformational_op op)
+{
+  gfc_expr *result;
+
+  if (!is_constant_array_expr (array)
+      || !gfc_is_constant_expr (dim))
+    return NULL;
+
+  if (mask
+      && !is_constant_array_expr (mask)
+      && mask->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = transformational_result (array, dim, array->ts.type,
+				    array->ts.kind, &array->where);
+  init_result_expr (result, init_val, NULL);
+
+  return !dim || array->rank == 1 ?
+    simplify_transformation_to_scalar (result, array, mask, op) :
+    simplify_transformation_to_array (result, array, dim, mask, op, NULL);
+}
+
 
 /********************** Simplification functions *****************************/
 
@@ -884,19 +914,7 @@ gfc_simplify_aint (gfc_expr *e, gfc_expr *k)
 gfc_expr *
 gfc_simplify_all (gfc_expr *mask, gfc_expr *dim)
 {
-  gfc_expr *result;
-
-  if (!is_constant_array_expr (mask)
-      || !gfc_is_constant_expr (dim))
-    return NULL;
-
-  result = transformational_result (mask, dim, mask->ts.type,
-				    mask->ts.kind, &mask->where);
-  init_result_expr (result, true, NULL);
-
-  return !dim || mask->rank == 1 ?
-    simplify_transformation_to_scalar (result, mask, NULL, gfc_and) :
-    simplify_transformation_to_array (result, mask, dim, NULL, gfc_and);
+  return simplify_transformation (mask, dim, NULL, true, gfc_and);
 }
 
 
@@ -970,19 +988,7 @@ gfc_simplify_and (gfc_expr *x, gfc_expr *y)
 gfc_expr *
 gfc_simplify_any (gfc_expr *mask, gfc_expr *dim)
 {
-  gfc_expr *result;
-
-  if (!is_constant_array_expr (mask)
-      || !gfc_is_constant_expr (dim))
-    return NULL;
-
-  result = transformational_result (mask, dim, mask->ts.type,
-				    mask->ts.kind, &mask->where);
-  init_result_expr (result, false, NULL);
-
-  return !dim || mask->rank == 1 ?
-    simplify_transformation_to_scalar (result, mask, NULL, gfc_or) :
-    simplify_transformation_to_array (result, mask, dim, NULL, gfc_or);
+  return simplify_transformation (mask, dim, NULL, false, gfc_or);
 }
 
 
@@ -1237,7 +1243,7 @@ gfc_simplify_bessel_n2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x,
       if (jn && n1 == 0)
 	{
 	  e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
-	  mpfr_set_ui (e->value.real, 1.0, GFC_RND_MODE);
+	  mpfr_set_ui (e->value.real, 1, GFC_RND_MODE);
 	  gfc_constructor_append_expr (&result->value.constructor, e,
 				       &x->where);
 	  n1++;
@@ -1247,7 +1253,7 @@ gfc_simplify_bessel_n2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x,
 	{
 	  e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
 	  if (jn)
-	    mpfr_set_ui (e->value.real, 0.0, GFC_RND_MODE);
+	    mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
 	  else
 	    mpfr_set_inf (e->value.real, -1);
 	  gfc_constructor_append_expr (&result->value.constructor, e,
@@ -1311,7 +1317,7 @@ gfc_simplify_bessel_n2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x,
       return &gfc_bad_expr;
     }
   if (jn)
-     gfc_constructor_insert_expr (&result->value.constructor, e, &x->where, -2);
+    gfc_constructor_insert_expr (&result->value.constructor, e, &x->where, -2);
   else 
     gfc_constructor_append_expr (&result->value.constructor, e, &x->where);
 
@@ -1460,6 +1466,74 @@ gfc_simplify_btest (gfc_expr *e, gfc_expr *bit)
 }
 
 
+static int
+compare_bitwise (gfc_expr *i, gfc_expr *j)
+{
+  mpz_t x, y;
+  int k, res;
+
+  gcc_assert (i->ts.type == BT_INTEGER);
+  gcc_assert (j->ts.type == BT_INTEGER);
+
+  mpz_init_set (x, i->value.integer);
+  k = gfc_validate_kind (i->ts.type, i->ts.kind, false);
+  convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size);
+
+  mpz_init_set (y, j->value.integer);
+  k = gfc_validate_kind (j->ts.type, j->ts.kind, false);
+  convert_mpz_to_unsigned (y, gfc_integer_kinds[k].bit_size);
+
+  res = mpz_cmp (x, y);
+  mpz_clear (x);
+  mpz_clear (y);
+  return res;
+}
+
+
+gfc_expr *
+gfc_simplify_bge (gfc_expr *i, gfc_expr *j)
+{
+  if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
+			       compare_bitwise (i, j) >= 0);
+}
+
+
+gfc_expr *
+gfc_simplify_bgt (gfc_expr *i, gfc_expr *j)
+{
+  if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
+			       compare_bitwise (i, j) > 0);
+}
+
+
+gfc_expr *
+gfc_simplify_ble (gfc_expr *i, gfc_expr *j)
+{
+  if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
+			       compare_bitwise (i, j) <= 0);
+}
+
+
+gfc_expr *
+gfc_simplify_blt (gfc_expr *i, gfc_expr *j)
+{
+  if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
+			       compare_bitwise (i, j) < 0);
+}
+
+
 gfc_expr *
 gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k)
 {
@@ -1679,7 +1753,7 @@ gfc_simplify_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
      Whenever gfc_count is called, '1' is added to the result.  */
   return !dim || mask->rank == 1 ?
     simplify_transformation_to_scalar (result, mask, mask, gfc_count) :
-    simplify_transformation_to_array (result, mask, dim, mask, gfc_count);
+    simplify_transformation_to_array (result, mask, dim, mask, gfc_count, NULL);
 }
 
 
@@ -1810,6 +1884,64 @@ gfc_simplify_dprod (gfc_expr *x, gfc_expr *y)
 }
 
 
+static gfc_expr *
+simplify_dshift (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg,
+		      bool right)
+{
+  gfc_expr *result;
+  int i, k, size, shift;
+
+  if (arg1->expr_type != EXPR_CONSTANT || arg2->expr_type != EXPR_CONSTANT
+      || shiftarg->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  k = gfc_validate_kind (BT_INTEGER, arg1->ts.kind, false);
+  size = gfc_integer_kinds[k].bit_size;
+
+  if (gfc_extract_int (shiftarg, &shift) != NULL)
+    {
+      gfc_error ("Invalid SHIFT argument of DSHIFTL at %L", &shiftarg->where);
+      return &gfc_bad_expr;
+    }
+
+  gcc_assert (shift >= 0 && shift <= size);
+
+  /* DSHIFTR(I,J,SHIFT) = DSHIFTL(I,J,SIZE-SHIFT).  */
+  if (right)
+    shift = size - shift;
+
+  result = gfc_get_constant_expr (BT_INTEGER, arg1->ts.kind, &arg1->where);
+  mpz_set_ui (result->value.integer, 0);
+
+  for (i = 0; i < shift; i++)
+    if (mpz_tstbit (arg2->value.integer, size - shift + i))
+      mpz_setbit (result->value.integer, i);
+
+  for (i = 0; i < size - shift; i++)
+    if (mpz_tstbit (arg1->value.integer, i))
+      mpz_setbit (result->value.integer, shift + i);
+
+  /* Convert to a signed value.  */
+  convert_mpz_to_signed (result->value.integer, size);
+
+  return result;
+}
+
+
+gfc_expr *
+gfc_simplify_dshiftr (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg)
+{
+  return simplify_dshift (arg1, arg2, shiftarg, true);
+}
+
+
+gfc_expr *
+gfc_simplify_dshiftl (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg)
+{
+  return simplify_dshift (arg1, arg2, shiftarg, false);
+}
+
+
 gfc_expr *
 gfc_simplify_erf (gfc_expr *x)
 {
@@ -2070,6 +2202,93 @@ gfc_simplify_float (gfc_expr *a)
 }
 
 
+static bool
+is_last_ref_vtab (gfc_expr *e)
+{
+  gfc_ref *ref;
+  gfc_component *comp = NULL;
+
+  if (e->expr_type != EXPR_VARIABLE)
+    return false;
+
+  for (ref = e->ref; ref; ref = ref->next)
+    if (ref->type == REF_COMPONENT)
+      comp = ref->u.c.component;
+
+  if (!e->ref || !comp)
+    return e->symtree->n.sym->attr.vtab;
+
+  if (comp->name[0] == '_' && strcmp (comp->name, "_vptr") == 0)
+    return true;
+
+  return false;
+}
+
+
+gfc_expr *
+gfc_simplify_extends_type_of (gfc_expr *a, gfc_expr *mold)
+{
+  /* Avoid simplification of resolved symbols.  */
+  if (is_last_ref_vtab (a) || is_last_ref_vtab (mold))
+    return NULL;
+
+  if (a->ts.type == BT_DERIVED && mold->ts.type == BT_DERIVED)
+    return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
+				 gfc_type_is_extension_of (mold->ts.u.derived,
+							   a->ts.u.derived));
+  /* Return .false. if the dynamic type can never be the same.  */
+  if ((a->ts.type == BT_CLASS && mold->ts.type == BT_CLASS
+       && !gfc_type_is_extension_of
+			(mold->ts.u.derived->components->ts.u.derived,
+			 a->ts.u.derived->components->ts.u.derived)
+       && !gfc_type_is_extension_of
+			(a->ts.u.derived->components->ts.u.derived,
+			 mold->ts.u.derived->components->ts.u.derived))
+      || (a->ts.type == BT_DERIVED && mold->ts.type == BT_CLASS
+	  && !gfc_type_is_extension_of
+			(a->ts.u.derived,
+			 mold->ts.u.derived->components->ts.u.derived)
+	  && !gfc_type_is_extension_of
+			(mold->ts.u.derived->components->ts.u.derived,
+			 a->ts.u.derived))
+      || (a->ts.type == BT_CLASS && mold->ts.type == BT_DERIVED
+	  && !gfc_type_is_extension_of
+			(mold->ts.u.derived,
+			 a->ts.u.derived->components->ts.u.derived)))
+    return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false);
+
+  if (mold->ts.type == BT_DERIVED
+      && gfc_type_is_extension_of (mold->ts.u.derived,
+				   a->ts.u.derived->components->ts.u.derived))
+    return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, true);
+
+  return NULL;
+}
+
+
+gfc_expr *
+gfc_simplify_same_type_as (gfc_expr *a, gfc_expr *b)
+{
+  /* Avoid simplification of resolved symbols.  */
+  if (is_last_ref_vtab (a) || is_last_ref_vtab (b))
+    return NULL;
+
+  /* Return .false. if the dynamic type can never be the
+     same.  */
+  if ((a->ts.type == BT_CLASS || b->ts.type == BT_CLASS)
+      && !gfc_type_compatible (&a->ts, &b->ts)
+      && !gfc_type_compatible (&b->ts, &a->ts))
+    return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false);
+
+  if (a->ts.type != BT_DERIVED || b->ts.type != BT_DERIVED)
+     return NULL;
+
+  return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
+			       gfc_compare_derived_types (a->ts.u.derived,
+							  b->ts.u.derived));
+}
+
+
 gfc_expr *
 gfc_simplify_floor (gfc_expr *e, gfc_expr *k)
 {
@@ -2227,6 +2446,44 @@ gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind)
 }
 
 
+static gfc_expr *
+do_bit_and (gfc_expr *result, gfc_expr *e)
+{
+  gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
+  gcc_assert (result->ts.type == BT_INTEGER
+	      && result->expr_type == EXPR_CONSTANT);
+
+  mpz_and (result->value.integer, result->value.integer, e->value.integer);
+  return result;
+}
+
+
+gfc_expr *
+gfc_simplify_iall (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
+{
+  return simplify_transformation (array, dim, mask, -1, do_bit_and);
+}
+
+
+static gfc_expr *
+do_bit_ior (gfc_expr *result, gfc_expr *e)
+{
+  gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
+  gcc_assert (result->ts.type == BT_INTEGER
+	      && result->expr_type == EXPR_CONSTANT);
+
+  mpz_ior (result->value.integer, result->value.integer, e->value.integer);
+  return result;
+}
+
+
+gfc_expr *
+gfc_simplify_iany (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
+{
+  return simplify_transformation (array, dim, mask, 0, do_bit_ior);
+}
+
+
 gfc_expr *
 gfc_simplify_iand (gfc_expr *x, gfc_expr *y)
 {
@@ -2338,7 +2595,7 @@ gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z)
 	gfc_internal_error ("IBITS: Bad bit");
     }
 
-  gfc_free (bits);
+  free (bits);
 
   convert_mpz_to_signed (result->value.integer,
 			 gfc_integer_kinds[k].bit_size);
@@ -2679,6 +2936,26 @@ gfc_simplify_ior (gfc_expr *x, gfc_expr *y)
 }
 
 
+static gfc_expr *
+do_bit_xor (gfc_expr *result, gfc_expr *e)
+{
+  gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
+  gcc_assert (result->ts.type == BT_INTEGER
+	      && result->expr_type == EXPR_CONSTANT);
+
+  mpz_xor (result->value.integer, result->value.integer, e->value.integer);
+  return result;
+}
+
+
+gfc_expr *
+gfc_simplify_iparity (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
+{
+  return simplify_transformation (array, dim, mask, 0, do_bit_xor);
+}
+
+
+
 gfc_expr *
 gfc_simplify_is_iostat_end (gfc_expr *x)
 {
@@ -2714,56 +2991,75 @@ gfc_simplify_isnan (gfc_expr *x)
 }
 
 
-gfc_expr *
-gfc_simplify_ishft (gfc_expr *e, gfc_expr *s)
+/* Performs a shift on its first argument.  Depending on the last
+   argument, the shift can be arithmetic, i.e. with filling from the
+   left like in the SHIFTA intrinsic.  */
+static gfc_expr *
+simplify_shift (gfc_expr *e, gfc_expr *s, const char *name,
+		bool arithmetic, int direction)
 {
   gfc_expr *result;
-  int shift, ashift, isize, k, *bits, i;
+  int ashift, *bits, i, k, bitsize, shift;
 
   if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
     return NULL;
-
   if (gfc_extract_int (s, &shift) != NULL)
     {
-      gfc_error ("Invalid second argument of ISHFT at %L", &s->where);
+      gfc_error ("Invalid second argument of %s at %L", name, &s->where);
       return &gfc_bad_expr;
     }
 
   k = gfc_validate_kind (BT_INTEGER, e->ts.kind, false);
+  bitsize = gfc_integer_kinds[k].bit_size;
 
-  isize = gfc_integer_kinds[k].bit_size;
+  result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
 
-  if (shift >= 0)
-    ashift = shift;
-  else
-    ashift = -shift;
+  if (shift == 0)
+    {
+      mpz_set (result->value.integer, e->value.integer);
+      return result;
+    }
 
-  if (ashift > isize)
+  if (direction > 0 && shift < 0)
     {
-      gfc_error ("Magnitude of second argument of ISHFT exceeds bit size "
-		 "at %L", &s->where);
+      /* Left shift, as in SHIFTL.  */
+      gfc_error ("Second argument of %s is negative at %L", name, &e->where);
       return &gfc_bad_expr;
     }
+  else if (direction < 0)
+    {
+      /* Right shift, as in SHIFTR or SHIFTA.  */
+      if (shift < 0)
+	{
+	  gfc_error ("Second argument of %s is negative at %L",
+		     name, &e->where);
+	  return &gfc_bad_expr;
+	}
+
+      shift = -shift;
+    }
 
-  result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
+  ashift = (shift >= 0 ? shift : -shift);
 
-  if (shift == 0)
+  if (ashift > bitsize)
     {
-      mpz_set (result->value.integer, e->value.integer);
-      return range_check (result, "ISHFT");
+      gfc_error ("Magnitude of second argument of %s exceeds bit size "
+		 "at %L", name, &e->where);
+      return &gfc_bad_expr;
     }
-  
-  bits = XCNEWVEC (int, isize);
 
-  for (i = 0; i < isize; i++)
+  bits = XCNEWVEC (int, bitsize);
+
+  for (i = 0; i < bitsize; i++)
     bits[i] = mpz_tstbit (e->value.integer, i);
 
   if (shift > 0)
     {
+      /* Left shift.  */
       for (i = 0; i < shift; i++)
 	mpz_clrbit (result->value.integer, i);
 
-      for (i = 0; i < isize - shift; i++)
+      for (i = 0; i < bitsize - shift; i++)
 	{
 	  if (bits[i] == 0)
 	    mpz_clrbit (result->value.integer, i + shift);
@@ -2773,10 +3069,15 @@ gfc_simplify_ishft (gfc_expr *e, gfc_expr *s)
     }
   else
     {
-      for (i = isize - 1; i >= isize - ashift; i--)
-	mpz_clrbit (result->value.integer, i);
+      /* Right shift.  */
+      if (arithmetic && bits[bitsize - 1])
+	for (i = bitsize - 1; i >= bitsize - ashift; i--)
+	  mpz_setbit (result->value.integer, i);
+      else
+	for (i = bitsize - 1; i >= bitsize - ashift; i--)
+	  mpz_clrbit (result->value.integer, i);
 
-      for (i = isize - 1; i >= ashift; i--)
+      for (i = bitsize - 1; i >= ashift; i--)
 	{
 	  if (bits[i] == 0)
 	    mpz_clrbit (result->value.integer, i - ashift);
@@ -2785,14 +3086,56 @@ gfc_simplify_ishft (gfc_expr *e, gfc_expr *s)
 	}
     }
 
-  convert_mpz_to_signed (result->value.integer, isize);
+  convert_mpz_to_signed (result->value.integer, bitsize);
+  free (bits);
 
-  gfc_free (bits);
   return result;
 }
 
 
 gfc_expr *
+gfc_simplify_ishft (gfc_expr *e, gfc_expr *s)
+{
+  return simplify_shift (e, s, "ISHFT", false, 0);
+}
+
+
+gfc_expr *
+gfc_simplify_lshift (gfc_expr *e, gfc_expr *s)
+{
+  return simplify_shift (e, s, "LSHIFT", false, 1);
+}
+
+
+gfc_expr *
+gfc_simplify_rshift (gfc_expr *e, gfc_expr *s)
+{
+  return simplify_shift (e, s, "RSHIFT", true, -1);
+}
+
+
+gfc_expr *
+gfc_simplify_shifta (gfc_expr *e, gfc_expr *s)
+{
+  return simplify_shift (e, s, "SHIFTA", true, -1);
+}
+
+
+gfc_expr *
+gfc_simplify_shiftl (gfc_expr *e, gfc_expr *s)
+{
+  return simplify_shift (e, s, "SHIFTL", false, 1);
+}
+
+
+gfc_expr *
+gfc_simplify_shiftr (gfc_expr *e, gfc_expr *s)
+{
+  return simplify_shift (e, s, "SHIFTR", false, -1);
+}
+
+
+gfc_expr *
 gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz)
 {
   gfc_expr *result;
@@ -2903,7 +3246,7 @@ gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz)
 
   convert_mpz_to_signed (result->value.integer, isize);
 
-  gfc_free (bits);
+  free (bits);
   return result;
 }
 
@@ -2955,7 +3298,8 @@ simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
 
   /* The last dimension of an assumed-size array is special.  */
   if ((!coarray && d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
-      || (coarray && d == as->rank + as->corank))
+      || (coarray && d == as->rank + as->corank
+	  && (!upper || gfc_option.coarray == GFC_FCOARRAY_SINGLE)))
     {
       if (as->lower[d-1]->expr_type == EXPR_CONSTANT)
 	{
@@ -3289,16 +3633,7 @@ gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
 gfc_expr *
 gfc_simplify_lcobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
 {
-  gfc_expr *e;
-  /* return simplify_cobound (array, dim, kind, 0);*/
-
-  e = simplify_cobound (array, dim, kind, 0);
-  if (e != NULL)
-    return e;
-
-  gfc_error ("Not yet implemented: LCOBOUND for coarray with non-constant "
-	     "cobounds at %L", &array->where);
-  return &gfc_bad_expr;
+  return simplify_cobound (array, dim, kind, 0);
 }
 
 gfc_expr *
@@ -3595,6 +3930,73 @@ gfc_simplify_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
 
 
 gfc_expr *
+gfc_simplify_maskr (gfc_expr *i, gfc_expr *kind_arg)
+{
+  gfc_expr *result;
+  int kind, arg, k;
+  const char *s;
+
+  if (i->expr_type != EXPR_CONSTANT)
+    return NULL;
+ 
+  kind = get_kind (BT_INTEGER, kind_arg, "MASKR", gfc_default_integer_kind);
+  if (kind == -1)
+    return &gfc_bad_expr;
+  k = gfc_validate_kind (BT_INTEGER, kind, false);
+
+  s = gfc_extract_int (i, &arg);
+  gcc_assert (!s);
+
+  result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where);
+
+  /* MASKR(n) = 2^n - 1 */
+  mpz_set_ui (result->value.integer, 1);
+  mpz_mul_2exp (result->value.integer, result->value.integer, arg);
+  mpz_sub_ui (result->value.integer, result->value.integer, 1);
+
+  convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size);
+
+  return result;
+}
+
+
+gfc_expr *
+gfc_simplify_maskl (gfc_expr *i, gfc_expr *kind_arg)
+{
+  gfc_expr *result;
+  int kind, arg, k;
+  const char *s;
+  mpz_t z;
+
+  if (i->expr_type != EXPR_CONSTANT)
+    return NULL;
+ 
+  kind = get_kind (BT_INTEGER, kind_arg, "MASKL", gfc_default_integer_kind);
+  if (kind == -1)
+    return &gfc_bad_expr;
+  k = gfc_validate_kind (BT_INTEGER, kind, false);
+
+  s = gfc_extract_int (i, &arg);
+  gcc_assert (!s);
+
+  result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where);
+
+  /* MASKL(n) = 2^bit_size - 2^(bit_size - n) */
+  mpz_init_set_ui (z, 1);
+  mpz_mul_2exp (z, z, gfc_integer_kinds[k].bit_size);
+  mpz_set_ui (result->value.integer, 1);
+  mpz_mul_2exp (result->value.integer, result->value.integer,
+		gfc_integer_kinds[k].bit_size - arg);
+  mpz_sub (result->value.integer, z, result->value.integer);
+  mpz_clear (z);
+
+  convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size);
+
+  return result;
+}
+
+
+gfc_expr *
 gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
 {
   if (tsource->expr_type != EXPR_CONSTANT
@@ -3606,7 +4008,38 @@ gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
 }
 
 
-/* Selects bewteen current value and extremum for simplify_min_max
+gfc_expr *
+gfc_simplify_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask_expr)
+{
+  mpz_t arg1, arg2, mask;
+  gfc_expr *result;
+
+  if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT
+      || mask_expr->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_get_constant_expr (BT_INTEGER, i->ts.kind, &i->where);
+
+  /* Convert all argument to unsigned.  */
+  mpz_init_set (arg1, i->value.integer);
+  mpz_init_set (arg2, j->value.integer);
+  mpz_init_set (mask, mask_expr->value.integer);
+
+  /* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))).  */
+  mpz_and (arg1, arg1, mask);
+  mpz_com (mask, mask);
+  mpz_and (arg2, arg2, mask);
+  mpz_ior (result->value.integer, arg1, arg2);
+
+  mpz_clear (arg1);
+  mpz_clear (arg2);
+  mpz_clear (mask);
+
+  return result;
+}
+
+
+/* Selects between current value and extremum for simplify_min_max
    and simplify_minval_maxval.  */
 static void
 min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign)
@@ -3643,12 +4076,12 @@ min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign)
 			       LENGTH(arg) - LENGTH(extremum));
 	    STRING(extremum)[LENGTH(arg)] = '\0';  /* For debugger  */
 	    LENGTH(extremum) = LENGTH(arg);
-	    gfc_free (tmp);
+	    free (tmp);
 	  }
 
 	if (gfc_compare_string (arg, extremum) * sign > 0)
 	  {
-	    gfc_free (STRING(extremum));
+	    free (STRING(extremum));
 	    STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1);
 	    memcpy (STRING(extremum), STRING(arg),
 		      LENGTH(arg) * sizeof (gfc_char_t));
@@ -4048,6 +4481,65 @@ gfc_simplify_idnint (gfc_expr *e)
 }
 
 
+static gfc_expr *
+add_squared (gfc_expr *result, gfc_expr *e)
+{
+  mpfr_t tmp;
+
+  gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT);
+  gcc_assert (result->ts.type == BT_REAL
+	      && result->expr_type == EXPR_CONSTANT);
+
+  gfc_set_model_kind (result->ts.kind);
+  mpfr_init (tmp);
+  mpfr_pow_ui (tmp, e->value.real, 2, GFC_RND_MODE);
+  mpfr_add (result->value.real, result->value.real, tmp,
+	    GFC_RND_MODE);
+  mpfr_clear (tmp);
+
+  return result;
+}
+
+
+static gfc_expr *
+do_sqrt (gfc_expr *result, gfc_expr *e)
+{
+  gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT);
+  gcc_assert (result->ts.type == BT_REAL
+	      && result->expr_type == EXPR_CONSTANT);
+
+  mpfr_set (result->value.real, e->value.real, GFC_RND_MODE);
+  mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE);
+  return result;
+}
+
+
+gfc_expr *
+gfc_simplify_norm2 (gfc_expr *e, gfc_expr *dim)
+{
+  gfc_expr *result;
+
+  if (!is_constant_array_expr (e)
+      || (dim != NULL && !gfc_is_constant_expr (dim)))
+    return NULL;
+
+  result = transformational_result (e, dim, e->ts.type, e->ts.kind, &e->where);
+  init_result_expr (result, 0, NULL);
+
+  if (!dim || e->rank == 1)
+    {
+      result = simplify_transformation_to_scalar (result, e, NULL,
+						  add_squared);
+      mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE);
+    }
+  else
+    result = simplify_transformation_to_array (result, e, dim, NULL,
+					       add_squared, &do_sqrt);
+
+  return result;
+}
+
+
 gfc_expr *
 gfc_simplify_not (gfc_expr *e)
 {
@@ -4091,6 +4583,9 @@ gfc_simplify_num_images (void)
       return &gfc_bad_expr;
     }
 
+  if (gfc_option.coarray != GFC_FCOARRAY_SINGLE)
+    return NULL;
+
   /* FIXME: gfc_current_locus is wrong.  */
   result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
 				  &gfc_current_locus);
@@ -4139,6 +4634,8 @@ gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
     return NULL;
 
   result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where);
+  if (array->ts.type == BT_DERIVED)
+    result->ts.u.derived = array->ts.u.derived;
 
   array_ctor = gfc_constructor_first (array->value.constructor);
   vector_ctor = vector
@@ -4198,36 +4695,80 @@ gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
 }
 
 
+static gfc_expr *
+do_xor (gfc_expr *result, gfc_expr *e)
+{
+  gcc_assert (e->ts.type == BT_LOGICAL && e->expr_type == EXPR_CONSTANT);
+  gcc_assert (result->ts.type == BT_LOGICAL
+	      && result->expr_type == EXPR_CONSTANT);
+
+  result->value.logical = result->value.logical != e->value.logical;
+  return result;
+}
+
+
+
 gfc_expr *
-gfc_simplify_precision (gfc_expr *e)
+gfc_simplify_parity (gfc_expr *e, gfc_expr *dim)
 {
-  int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
-  return gfc_get_int_expr (gfc_default_integer_kind, &e->where,
-			   gfc_real_kinds[i].precision);
+  return simplify_transformation (e, dim, NULL, 0, do_xor);
 }
 
 
 gfc_expr *
-gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
+gfc_simplify_popcnt (gfc_expr *e)
 {
-  gfc_expr *result;
+  int res, k;
+  mpz_t x;
 
-  if (!is_constant_array_expr (array)
-      || !gfc_is_constant_expr (dim))
+  if (e->expr_type != EXPR_CONSTANT)
     return NULL;
 
-  if (mask
-      && !is_constant_array_expr (mask)
-      && mask->expr_type != EXPR_CONSTANT)
+  k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
+
+  /* Convert argument to unsigned, then count the '1' bits.  */
+  mpz_init_set (x, e->value.integer);
+  convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size);
+  res = mpz_popcount (x);
+  mpz_clear (x);
+
+  return gfc_get_int_expr (gfc_default_integer_kind, &e->where, res);
+}
+
+
+gfc_expr *
+gfc_simplify_poppar (gfc_expr *e)
+{
+  gfc_expr *popcnt;
+  const char *s;
+  int i;
+
+  if (e->expr_type != EXPR_CONSTANT)
     return NULL;
 
-  result = transformational_result (array, dim, array->ts.type,
-				    array->ts.kind, &array->where);
-  init_result_expr (result, 1, NULL);
+  popcnt = gfc_simplify_popcnt (e);
+  gcc_assert (popcnt);
 
-  return !dim || array->rank == 1 ?
-    simplify_transformation_to_scalar (result, array, mask, gfc_multiply) :
-    simplify_transformation_to_array (result, array, dim, mask, gfc_multiply);
+  s = gfc_extract_int (popcnt, &i);
+  gcc_assert (!s);
+
+  return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i % 2);
+}
+
+
+gfc_expr *
+gfc_simplify_precision (gfc_expr *e)
+{
+  int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
+  return gfc_get_int_expr (gfc_default_integer_kind, &e->where,
+			   gfc_real_kinds[i].precision);
+}
+
+
+gfc_expr *
+gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
+{
+  return simplify_transformation (array, dim, mask, 1, gfc_multiply);
 }
 
 
@@ -4281,6 +4822,13 @@ gfc_simplify_range (gfc_expr *e)
 
 
 gfc_expr *
+gfc_simplify_rank (gfc_expr *e)
+{
+  return gfc_get_int_expr (gfc_default_integer_kind, &e->where, e->rank);
+}
+
+
+gfc_expr *
 gfc_simplify_real (gfc_expr *e, gfc_expr *k)
 {
   gfc_expr *result = NULL;
@@ -4527,6 +5075,8 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
 
   result = gfc_get_array_expr (source->ts.type, source->ts.kind,
 			       &source->where);
+  if (source->ts.type == BT_DERIVED)
+    result->ts.u.derived = source->ts.u.derived;
   result->rank = rank;
   result->shape = gfc_get_shape (rank);
   for (i = 0; i < rank; i++)
@@ -4948,20 +5498,19 @@ gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
 
 
 gfc_expr *
-gfc_simplify_shape (gfc_expr *source)
+gfc_simplify_shape (gfc_expr *source, gfc_expr *kind)
 {
   mpz_t shape[GFC_MAX_DIMENSIONS];
   gfc_expr *result, *e, *f;
   gfc_array_ref *ar;
   int n;
   gfc_try t;
+  int k = get_kind (BT_INTEGER, kind, "SHAPE", gfc_default_integer_kind);
 
-  if (source->rank == 0)
-    return gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind,
-			       &source->where);
+  result = gfc_get_array_expr (BT_INTEGER, k, &source->where);
 
-  result = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind,
-			       &source->where);
+  if (source->rank == 0)
+    return result;
 
   if (source->expr_type == EXPR_VARIABLE)
     {
@@ -4982,8 +5531,7 @@ gfc_simplify_shape (gfc_expr *source)
 
   for (n = 0; n < source->rank; n++)
     {
-      e = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
-				 &source->where);
+      e = gfc_get_constant_expr (BT_INTEGER, k, &source->where);
 
       if (t == SUCCESS)
 	{
@@ -5016,6 +5564,7 @@ gfc_expr *
 gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
 {
   mpz_t size;
+  gfc_expr *return_value;
   int d;
   int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind);
 
@@ -5087,7 +5636,9 @@ gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
 	return NULL;
     }
 
-  return gfc_get_int_expr (k, &array->where, mpz_get_si (size));
+  return_value = gfc_get_int_expr (k, &array->where, mpz_get_si (size));
+  mpz_clear (size);
+  return return_value;
 }
 
 
@@ -5277,6 +5828,8 @@ gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_exp
 
       result = gfc_get_array_expr (source->ts.type, source->ts.kind,
 				   &source->where);
+      if (source->ts.type == BT_DERIVED)
+	result->ts.u.derived = source->ts.u.derived;
       result->rank = 1;
       result->shape = gfc_get_shape (result->rank);
       mpz_init_set_si (result->shape[0], ncopies);
@@ -5295,6 +5848,8 @@ gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_exp
 
       result = gfc_get_array_expr (source->ts.type, source->ts.kind,
 				   &source->where);
+      if (source->ts.type == BT_DERIVED)
+	result->ts.u.derived = source->ts.u.derived;
       result->rank = source->rank + 1;
       result->shape = gfc_get_shape (result->rank);
 
@@ -5373,24 +5928,7 @@ gfc_simplify_sqrt (gfc_expr *e)
 gfc_expr *
 gfc_simplify_sum (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
 {
-  gfc_expr *result;
-
-  if (!is_constant_array_expr (array)
-      || !gfc_is_constant_expr (dim))
-    return NULL;
-
-  if (mask
-      && !is_constant_array_expr (mask)
-      && mask->expr_type != EXPR_CONSTANT)
-    return NULL;
-
-  result = transformational_result (array, dim, array->ts.type,
-				    array->ts.kind, &array->where);
-  init_result_expr (result, 0, NULL);
-
-  return !dim || array->rank == 1 ?
-    simplify_transformation_to_scalar (result, array, mask, gfc_add) :
-    simplify_transformation_to_array (result, array, dim, mask, gfc_add);
+  return simplify_transformation (array, dim, mask, 0, gfc_add);
 }
 
 
@@ -5490,17 +6028,19 @@ gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
   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;
+  size_t result_length;
+
 
   if (!gfc_is_constant_expr (source)
 	|| (gfc_init_expr_flag && !gfc_is_constant_expr (mold))
 	|| !gfc_is_constant_expr (size))
     return NULL;
 
-  if (source->expr_type == EXPR_FUNCTION)
+  if (gfc_calculate_transfer_sizes (source, mold, size, &source_size,
+				    &result_size, &result_length) == FAILURE)
     return NULL;
 
   /* Calculate the size of the source.  */
@@ -5508,8 +6048,6 @@ gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
       && 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_get_constant_expr (mold->ts.type, mold->ts.kind,
 				  &source->where);
@@ -5526,44 +6064,16 @@ gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
     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);
+    result->rank = 0;
 
   /* Allocate the buffer to store the binary version of the source.  */
   buffer_size = MAX (source_size, result_size);
@@ -5574,7 +6084,7 @@ gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
   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);
+  gfc_target_interpret_expr (buffer, buffer_size, result, false);
 
   return result;
 }
@@ -5600,6 +6110,8 @@ gfc_simplify_transpose (gfc_expr *matrix)
 
   if (matrix->ts.type == BT_CHARACTER)
     result->ts.u.cl = matrix->ts.u.cl;
+  else if (matrix->ts.type == BT_DERIVED)
+    result->ts.u.derived = matrix->ts.u.derived;
 
   matrix_rows = mpz_get_si (matrix->shape[0]);
   matrix_cols = mpz_get_si (matrix->shape[1]);
@@ -5656,7 +6168,7 @@ gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
   int d;
 
   if (!is_constant_array_expr (sub))
-    goto not_implemented; /* return NULL;*/
+    return NULL;
 
   /* Follow any component references.  */
   as = coarray->symtree->n.sym->as;
@@ -5665,7 +6177,7 @@ gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
       as = ref->u.ar.as;
 
   if (as->type == AS_DEFERRED)
-    goto not_implemented; /* return NULL;*/
+    return NULL;
 
   /* "valid sequence of cosubscripts" are required; thus, return 0 unless
      the cosubscript addresses the first image.  */
@@ -5678,17 +6190,12 @@ gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
       gfc_expr *ca_bound;
       int cmp;
 
-      if (sub_cons == NULL)
-	{
-	  gfc_error ("Too few elements in expression for SUB= argument at %L",
-		     &sub->where);
-	  return &gfc_bad_expr;
-	}
+      gcc_assert (sub_cons != NULL);
 
       ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as,
 				     NULL, true);
       if (ca_bound == NULL)
-	goto not_implemented; /* return NULL */
+	return NULL;
 
       if (ca_bound == &gfc_bad_expr)
 	return ca_bound;
@@ -5745,12 +6252,10 @@ gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
       sub_cons = gfc_constructor_next (sub_cons);
     }
 
-  if (sub_cons != NULL)
-    {
-      gfc_error ("Too many elements in expression for SUB= argument at %L",
-		 &sub->where);
-      return &gfc_bad_expr;
-    }
+  gcc_assert (sub_cons == NULL);
+
+  if (gfc_option.coarray != GFC_FCOARRAY_SINGLE && !first_image)
+    return NULL;
 
   result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
 				  &gfc_current_locus);
@@ -5760,11 +6265,6 @@ gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
     mpz_set_si (result->value.integer, 0);
 
   return result;
-
-not_implemented:
-  gfc_error ("Not yet implemented: IMAGE_INDEX for coarray with non-constant "
-	     "cobounds at %L", &coarray->where);
-  return &gfc_bad_expr;
 }
 
 
@@ -5775,6 +6275,9 @@ gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim)
   gfc_array_spec *as;
   int d;
 
+  if (gfc_option.coarray != GFC_FCOARRAY_SINGLE)
+    return NULL;
+
   if (coarray == NULL)
     {
       gfc_expr *result;
@@ -5794,7 +6297,7 @@ gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim)
       as = ref->u.ar.as;
 
   if (as->type == AS_DEFERRED)
-    goto not_implemented; /* return NULL;*/
+    return NULL;
 
   if (dim == NULL)
     {
@@ -5813,8 +6316,7 @@ gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim)
 
 	      for (j = 0; j < d; j++)
 		gfc_free_expr (bounds[j]);
-	      if (bounds[d] == NULL)
-		goto not_implemented;
+
 	      return bounds[d];
 	    }
 	}
@@ -5839,10 +6341,9 @@ gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim)
     }
   else
     {
-      gfc_expr *e;
       /* A DIM argument is specified.  */
       if (dim->expr_type != EXPR_CONSTANT)
-	goto not_implemented; /*return NULL;*/
+	return NULL;
 
       d = mpz_get_si (dim->value.integer);
 
@@ -5852,18 +6353,9 @@ gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim)
 	  return &gfc_bad_expr;
 	}
 
-      /*return simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true);*/
-      e = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true);
-      if (e != NULL)
-	return e;
-      else
-	goto not_implemented;
+      return simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL,
+				 true);
    }
-
-not_implemented:
-  gfc_error ("Not yet implemented: THIS_IMAGE for coarray with non-constant "
-	     "cobounds at %L", &coarray->where);
-  return &gfc_bad_expr;
 }
 
 
@@ -5876,16 +6368,7 @@ gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
 gfc_expr *
 gfc_simplify_ucobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
 {
-  gfc_expr *e;
-  /* return simplify_cobound (array, dim, kind, 1);*/
-
-  e = simplify_cobound (array, dim, kind, 1);
-  if (e != NULL)
-    return e;
-
-  gfc_error ("Not yet implemented: UCOBOUND for coarray with non-constant "
-	     "cobounds at %L", &array->where);
-  return &gfc_bad_expr;
+  return simplify_cobound (array, dim, kind, 1);
 }
 
 
@@ -5903,6 +6386,8 @@ gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
 
   result = gfc_get_array_expr (vector->ts.type, vector->ts.kind,
 			       &vector->where);
+  if (vector->ts.type == BT_DERIVED)
+    result->ts.u.derived = vector->ts.u.derived;
   result->rank = mask->rank;
   result->shape = gfc_copy_shape (mask->shape, mask->rank);
 
@@ -6282,3 +6767,31 @@ gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind)
   else
     return NULL;
 }
+
+
+gfc_expr *
+gfc_simplify_compiler_options (void)
+{
+  char *str;
+  gfc_expr *result;
+
+  str = gfc_get_option_string ();
+  result = gfc_get_character_expr (gfc_default_character_kind,
+				   &gfc_current_locus, str, strlen (str));
+  free (str);
+  return result;
+}
+
+
+gfc_expr *
+gfc_simplify_compiler_version (void)
+{
+  char *buffer;
+  size_t len;
+
+  len = strlen ("GCC version ") + strlen (version_string);
+  buffer = XALLOCAVEC (char, len + 1);
+  snprintf (buffer, len + 1, "GCC version %s", version_string);
+  return gfc_get_character_expr (gfc_default_character_kind,
+                                &gfc_current_locus, buffer, len);
+}