[gcc] GCC 4.5.0=>4.5.1

gcc/gcc/fortran/check.c

Index: gcc/gcc/fortran/check.c
diff --git a/gcc/gcc/fortran/check.c b/gcc/gcc/fortran/check.c
index b967d78cf2af5901ad5fd358b19aa5109b5cc3c5..2d8cfefb79be215c417943a560c8a93d5cf13298 100644
--- a/gcc/gcc/fortran/check.c
+++ b/gcc/gcc/fortran/check.c
@@ -214,6 +214,80 @@ array_check (gfc_expr *e, int n)
 }
 
 
+/* If expr is a constant, then check to ensure that it is greater than
+   of equal to zero.  */
+
+static gfc_try
+nonnegative_check (const char *arg, gfc_expr *expr)
+{
+  int i;
+
+  if (expr->expr_type == EXPR_CONSTANT)
+    {
+      gfc_extract_int (expr, &i);
+      if (i < 0)
+	{
+	  gfc_error ("'%s' at %L must be nonnegative", arg, &expr->where);
+	  return FAILURE;
+	}
+    }
+
+  return SUCCESS;
+}
+
+
+/* If expr2 is constant, then check that the value is less than
+   bit_size(expr1).  */
+
+static gfc_try
+less_than_bitsize1 (const char *arg1, gfc_expr *expr1, const char *arg2,
+	       gfc_expr *expr2)
+{
+  int i2, i3;
+
+  if (expr2->expr_type == EXPR_CONSTANT)
+    {
+      gfc_extract_int (expr2, &i2);
+      i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false);
+      if (i2 >= gfc_integer_kinds[i3].bit_size)
+	{
+	  gfc_error ("'%s' at %L must be less than BIT_SIZE('%s')",
+		     arg2, &expr2->where, arg1);
+	  return FAILURE;
+	}
+    }
+
+  return SUCCESS;
+}
+
+
+/* If expr2 and expr3 are constants, then check that the value is less than
+   or equal to bit_size(expr1).  */
+
+static gfc_try
+less_than_bitsize2 (const char *arg1, gfc_expr *expr1, const char *arg2,
+	       gfc_expr *expr2, const char *arg3, gfc_expr *expr3)
+{
+  int i2, i3;
+
+  if (expr2->expr_type == EXPR_CONSTANT && expr3->expr_type == EXPR_CONSTANT)
+    {
+      gfc_extract_int (expr2, &i2);
+      gfc_extract_int (expr3, &i3);
+      i2 += i3;
+      i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false);
+      if (i2 > gfc_integer_kinds[i3].bit_size)
+	{
+	  gfc_error ("'%s + %s' at %L must be less than or equal "
+		     "to BIT_SIZE('%s')",
+		     arg2, arg3, &expr2->where, arg1);
+	  return FAILURE;
+	}
+    }
+
+  return SUCCESS;
+}
+
 /* Make sure two expressions have the same type.  */
 
 static gfc_try
@@ -339,6 +413,9 @@ dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed)
   gfc_array_ref *ar;
   int rank;
 
+  if (dim == NULL)
+    return SUCCESS;
+
   if (dim->expr_type != EXPR_CONSTANT
       || (array->expr_type != EXPR_VARIABLE
 	  && array->expr_type != EXPR_ARRAY))
@@ -407,20 +484,20 @@ gfc_check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name)
    long len_a, len_b;
    len_a = len_b = -1;
 
-   if (a->ts.cl && a->ts.cl->length
-       && a->ts.cl->length->expr_type == EXPR_CONSTANT)
-     len_a = mpz_get_si (a->ts.cl->length->value.integer);
+   if (a->ts.u.cl && a->ts.u.cl->length
+       && a->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+     len_a = mpz_get_si (a->ts.u.cl->length->value.integer);
    else if (a->expr_type == EXPR_CONSTANT
-	    && (a->ts.cl == NULL || a->ts.cl->length == NULL))
+	    && (a->ts.u.cl == NULL || a->ts.u.cl->length == NULL))
      len_a = a->value.character.length;
    else
      return SUCCESS;
 
-   if (b->ts.cl && b->ts.cl->length
-       && b->ts.cl->length->expr_type == EXPR_CONSTANT)
-     len_b = mpz_get_si (b->ts.cl->length->value.integer);
+   if (b->ts.u.cl && b->ts.u.cl->length
+       && b->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+     len_b = mpz_get_si (b->ts.u.cl->length->value.integer);
    else if (b->expr_type == EXPR_CONSTANT
-	    && (b->ts.cl == NULL || b->ts.cl->length == NULL))
+	    && (b->ts.u.cl == NULL || b->ts.u.cl->length == NULL))
      len_b = b->value.character.length;
    else
      return SUCCESS;
@@ -519,6 +596,9 @@ gfc_check_all_any (gfc_expr *mask, gfc_expr *dim)
   if (dim_check (dim, 1, false) == FAILURE)
     return FAILURE;
 
+  if (dim_rank_check (dim, mask, 0) == FAILURE)
+    return FAILURE;
+
   return SUCCESS;
 }
 
@@ -540,9 +620,6 @@ gfc_check_allocated (gfc_expr *array)
       return FAILURE;
     }
 
-  if (array_check (array, 0) == FAILURE)
-    return FAILURE;
-
   return SUCCESS;
 }
 
@@ -666,6 +743,19 @@ null_arg:
 
 
 gfc_try
+gfc_check_atan_2 (gfc_expr *y, gfc_expr *x)
+{
+  /* gfc_notify_std would be a wast of time as the return value
+     is seemingly used only for the generic resolution.  The error
+     will be: Too many arguments.  */
+  if ((gfc_option.allow_std & GFC_STD_F2008) == 0)
+    return FAILURE;
+
+  return gfc_check_atan2 (y, x);
+}
+
+
+gfc_try
 gfc_check_atan2 (gfc_expr *y, gfc_expr *x)
 {
   if (type_check (y, 0, BT_REAL) == FAILURE)
@@ -693,13 +783,20 @@ gfc_check_besn (gfc_expr *n, gfc_expr *x)
 
 
 gfc_try
-gfc_check_btest (gfc_expr *i, gfc_expr *pos)
+gfc_check_bitfcn (gfc_expr *i, gfc_expr *pos)
 {
   if (type_check (i, 0, BT_INTEGER) == FAILURE)
     return FAILURE;
+
   if (type_check (pos, 1, BT_INTEGER) == FAILURE)
     return FAILURE;
 
+  if (nonnegative_check ("pos", pos) == FAILURE)
+    return FAILURE;
+
+  if (less_than_bitsize1 ("i", i, "pos", pos) == FAILURE)
+    return FAILURE;
+
   return SUCCESS;
 }
 
@@ -861,6 +958,8 @@ gfc_check_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
     return FAILURE;
   if (dim_check (dim, 1, false) == FAILURE)
     return FAILURE;
+  if (dim_rank_check (dim, mask, 0) == FAILURE)
+    return FAILURE;
   if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
     return FAILURE;
   if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
@@ -881,24 +980,56 @@ gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
   if (type_check (shift, 1, BT_INTEGER) == FAILURE)
     return FAILURE;
 
-  if (array->rank == 1)
+  if (dim_check (dim, 2, true) == FAILURE)
+    return FAILURE;
+
+  if (dim_rank_check (dim, array, false) == FAILURE)
+    return FAILURE;
+
+  if (array->rank == 1 || shift->rank == 0)
     {
       if (scalar_check (shift, 1) == FAILURE)
 	return FAILURE;
     }
-  else if (shift->rank != array->rank - 1 && shift->rank != 0)
+  else if (shift->rank == array->rank - 1)
     {
-      gfc_error ("SHIFT argument at %L of CSHIFT must have rank %d or be a "
-		 "scalar", &shift->where, array->rank - 1);
+      int d;
+      if (!dim)
+	d = 1;
+      else if (dim->expr_type == EXPR_CONSTANT)
+	gfc_extract_int (dim, &d);
+      else
+	d = -1;
+
+      if (d > 0)
+	{
+	  int i, j;
+	  for (i = 0, j = 0; i < array->rank; i++)
+	    if (i != d - 1)
+	      {
+		if (!identical_dimen_shape (array, i, shift, j))
+		  {
+		    gfc_error ("'%s' argument of '%s' intrinsic at %L has "
+			       "invalid shape in dimension %d (%ld/%ld)",
+			       gfc_current_intrinsic_arg[1],
+			       gfc_current_intrinsic, &shift->where, i + 1,
+			       mpz_get_si (array->shape[i]),
+			       mpz_get_si (shift->shape[j]));
+		    return FAILURE;
+		  }
+
+		j += 1;
+	      }
+	}
+    }
+  else
+    {
+      gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
+		 "%d or be a scalar", gfc_current_intrinsic_arg[1],
+		 gfc_current_intrinsic, &shift->where, array->rank - 1);
       return FAILURE;
     }
 
-  /* TODO: Add shape conformance check between array (w/o dimension dim)
-     and shift. */
-
-  if (dim_check (dim, 2, true) == FAILURE)
-    return FAILURE;
-
   return SUCCESS;
 }
 
@@ -1055,55 +1186,85 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
   if (type_check (shift, 1, BT_INTEGER) == FAILURE)
     return FAILURE;
 
-  if (array->rank == 1)
+  if (dim_check (dim, 3, true) == FAILURE)
+    return FAILURE;
+
+  if (dim_rank_check (dim, array, false) == FAILURE)
+    return FAILURE;
+
+  if (array->rank == 1 || shift->rank == 0)
     {
-      if (scalar_check (shift, 2) == FAILURE)
+      if (scalar_check (shift, 1) == FAILURE)
 	return FAILURE;
     }
-  else if (shift->rank != array->rank - 1 && shift->rank != 0)
+  else if (shift->rank == array->rank - 1)
+    {
+      int d;
+      if (!dim)
+	d = 1;
+      else if (dim->expr_type == EXPR_CONSTANT)
+	gfc_extract_int (dim, &d);
+      else
+	d = -1;
+
+      if (d > 0)
+	{
+	  int i, j;
+	  for (i = 0, j = 0; i < array->rank; i++)
+	    if (i != d - 1)
+	      {
+		if (!identical_dimen_shape (array, i, shift, j))
+		  {
+		    gfc_error ("'%s' argument of '%s' intrinsic at %L has "
+			       "invalid shape in dimension %d (%ld/%ld)",
+			       gfc_current_intrinsic_arg[1],
+			       gfc_current_intrinsic, &shift->where, i + 1,
+			       mpz_get_si (array->shape[i]),
+			       mpz_get_si (shift->shape[j]));
+		    return FAILURE;
+		  }
+
+		j += 1;
+	      }
+	}
+    }
+  else
     {
-      gfc_error ("SHIFT argument at %L of EOSHIFT must have rank %d or be a "
-		 "scalar", &shift->where, array->rank - 1);
+      gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
+		 "%d or be a scalar", gfc_current_intrinsic_arg[1],
+		 gfc_current_intrinsic, &shift->where, array->rank - 1);
       return FAILURE;
     }
 
-  /* TODO: Add shape conformance check between array (w/o dimension dim)
-     and shift. */
-
   if (boundary != NULL)
     {
       if (same_type_check (array, 0, boundary, 2) == FAILURE)
 	return FAILURE;
 
-      if (array->rank == 1)
+      if (array->rank == 1 || boundary->rank == 0)
 	{
 	  if (scalar_check (boundary, 2) == FAILURE)
 	    return FAILURE;
 	}
-      else if (boundary->rank != array->rank - 1 && boundary->rank != 0)
+      else if (boundary->rank == array->rank - 1)
 	{
-	  gfc_error ("BOUNDARY argument at %L of EOSHIFT must have rank %d or be "
-		     "a scalar", &boundary->where, array->rank - 1);
-	  return FAILURE;
+	  if (gfc_check_conformance (shift, boundary,
+				     "arguments '%s' and '%s' for "
+				     "intrinsic %s",
+				     gfc_current_intrinsic_arg[1],
+				     gfc_current_intrinsic_arg[2],
+				     gfc_current_intrinsic ) == FAILURE)
+	    return FAILURE;
 	}
-
-      if (shift->rank == boundary->rank)
+      else
 	{
-	  int i;
-	  for (i = 0; i < shift->rank; i++)
-	    if (! identical_dimen_shape (shift, i, boundary, i))
-	      {
-		gfc_error ("Different shape in dimension %d for SHIFT and "
-			   "BOUNDARY arguments of EOSHIFT at %L", shift->rank,
-			   &boundary->where);
-		return FAILURE;
-	      }
+	  gfc_error ("'%s' argument of intrinsic '%s' at %L of must have "
+		     "rank %d or be a scalar", gfc_current_intrinsic_arg[1],
+		     gfc_current_intrinsic, &shift->where, array->rank - 1);
+	  return FAILURE;
 	}
     }
 
-  if (dim_check (dim, 4, true) == FAILURE)
-    return FAILURE;
-
   return SUCCESS;
 }
 
@@ -1155,6 +1316,23 @@ gfc_check_fn_rc (gfc_expr *a)
 
 
 gfc_try
+gfc_check_fn_rc2008 (gfc_expr *a)
+{
+  if (real_or_complex_check (a, 0) == FAILURE)
+    return FAILURE;
+
+  if (a->ts.type == BT_COMPLEX
+      && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: COMPLEX argument '%s' "
+			 "argument of '%s' intrinsic at %L",
+			 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
+			 &a->where) == FAILURE)
+    return FAILURE;
+
+  return SUCCESS;
+}
+
+
+gfc_try
 gfc_check_fnum (gfc_expr *unit)
 {
   if (type_check (unit, 0, BT_INTEGER) == FAILURE)
@@ -1222,19 +1400,6 @@ gfc_check_iand (gfc_expr *i, gfc_expr *j)
 
 
 gfc_try
-gfc_check_ibclr (gfc_expr *i, gfc_expr *pos)
-{
-  if (type_check (i, 0, BT_INTEGER) == FAILURE)
-    return FAILURE;
-
-  if (type_check (pos, 1, BT_INTEGER) == FAILURE)
-    return FAILURE;
-
-  return SUCCESS;
-}
-
-
-gfc_try
 gfc_check_ibits (gfc_expr *i, gfc_expr *pos, gfc_expr *len)
 {
   if (type_check (i, 0, BT_INTEGER) == FAILURE)
@@ -1246,17 +1411,13 @@ gfc_check_ibits (gfc_expr *i, gfc_expr *pos, gfc_expr *len)
   if (type_check (len, 2, BT_INTEGER) == FAILURE)
     return FAILURE;
 
-  return SUCCESS;
-}
-
+  if (nonnegative_check ("pos", pos) == FAILURE)
+    return FAILURE;
 
-gfc_try
-gfc_check_ibset (gfc_expr *i, gfc_expr *pos)
-{
-  if (type_check (i, 0, BT_INTEGER) == FAILURE)
+  if (nonnegative_check ("len", len) == FAILURE)
     return FAILURE;
 
-  if (type_check (pos, 1, BT_INTEGER) == FAILURE)
+  if (less_than_bitsize2 ("i", i, "pos", pos, "len", len) == FAILURE)
     return FAILURE;
 
   return SUCCESS;
@@ -1296,12 +1457,12 @@ gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind)
 	{
 	  /* Check that the argument is length one.  Non-constant lengths
 	     can't be checked here, so assume they are ok.  */
-	  if (c->ts.cl && c->ts.cl->length)
+	  if (c->ts.u.cl && c->ts.u.cl->length)
 	    {
 	      /* If we already have a length for this expression then use it.  */
-	      if (c->ts.cl->length->expr_type != EXPR_CONSTANT)
+	      if (c->ts.u.cl->length->expr_type != EXPR_CONSTANT)
 		return SUCCESS;
-	      i = mpz_get_si (c->ts.cl->length->value.integer);
+	      i = mpz_get_si (c->ts.u.cl->length->value.integer);
 	    }
 	  else 
 	    return SUCCESS;
@@ -1525,14 +1686,11 @@ gfc_check_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
   if (array_check (array, 0) == FAILURE)
     return FAILURE;
 
-  if (dim != NULL)
-    {
-      if (dim_check (dim, 1, false) == FAILURE)
-	return FAILURE;
+  if (dim_check (dim, 1, false) == FAILURE)
+    return FAILURE;
 
-      if (dim_rank_check (dim, array, 1) == FAILURE)
-	return FAILURE;
-    }
+  if (dim_rank_check (dim, array, 1) == FAILURE)
+    return FAILURE;
 
   if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
     return FAILURE;
@@ -1732,13 +1890,11 @@ check_rest (bt type, int kind, gfc_actual_arglist *arglist)
 	}
 
       for (tmp = arglist, m=1; tmp != arg; tmp = tmp->next, m++)
-        {
-	  char buffer[80];
-	  snprintf (buffer, 80, "arguments 'a%d' and 'a%d' for intrinsic '%s'",
-		    m, n, gfc_current_intrinsic);
-	  if (gfc_check_conformance (buffer, tmp->expr, x) == FAILURE)
+	if (gfc_check_conformance (tmp->expr, x,
+				   "arguments 'a%d' and 'a%d' for "
+				   "intrinsic '%s'", m, n,
+				   gfc_current_intrinsic) == FAILURE)
 	    return FAILURE;
-	}
     }
 
   return SUCCESS;
@@ -1918,24 +2074,22 @@ gfc_check_minloc_maxloc (gfc_actual_arglist *ap)
       ap->next->next->expr = m;
     }
 
-  if (d && dim_check (d, 1, false) == FAILURE)
+  if (dim_check (d, 1, false) == FAILURE)
     return FAILURE;
 
-  if (d && dim_rank_check (d, a, 0) == FAILURE)
+  if (dim_rank_check (d, a, 0) == FAILURE)
     return FAILURE;
 
   if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
     return FAILURE;
 
-  if (m != NULL)
-    {
-      char buffer[80];
-      snprintf (buffer, 80, "arguments '%s' and '%s' for intrinsic %s",
-		gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[2],
-		gfc_current_intrinsic);
-      if (gfc_check_conformance (buffer, a, m) == FAILURE)
-	return FAILURE;
-    }
+  if (m != NULL
+      && gfc_check_conformance (a, m,
+				"arguments '%s' and '%s' for intrinsic %s",
+				gfc_current_intrinsic_arg[0],
+				gfc_current_intrinsic_arg[2],
+				gfc_current_intrinsic ) == FAILURE)
+    return FAILURE;
 
   return SUCCESS;
 }
@@ -1974,24 +2128,22 @@ check_reduction (gfc_actual_arglist *ap)
       ap->next->next->expr = m;
     }
 
-  if (d && dim_check (d, 1, false) == FAILURE)
+  if (dim_check (d, 1, false) == FAILURE)
     return FAILURE;
 
-  if (d && dim_rank_check (d, a, 0) == FAILURE)
+  if (dim_rank_check (d, a, 0) == FAILURE)
     return FAILURE;
 
   if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
     return FAILURE;
 
-  if (m != NULL)
-    {
-      char buffer[80];
-      snprintf (buffer, 80, "arguments '%s' and '%s' for intrinsic %s",
-		gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[2],
-		gfc_current_intrinsic);
-      if (gfc_check_conformance (buffer, a, m) == FAILURE)
-	return FAILURE;
-    }
+  if (m != NULL
+      && gfc_check_conformance (a, m,
+				"arguments '%s' and '%s' for intrinsic %s",
+				gfc_current_intrinsic_arg[0],
+				gfc_current_intrinsic_arg[2],
+				gfc_current_intrinsic) == FAILURE)
+    return FAILURE;
 
   return SUCCESS;
 }
@@ -2043,9 +2195,6 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
   if (variable_check (from, 0) == FAILURE)
     return FAILURE;
 
-  if (array_check (from, 0) == FAILURE)
-    return FAILURE;
-
   attr = gfc_variable_attr (from, NULL);
   if (!attr.allocatable)
     {
@@ -2058,9 +2207,6 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
   if (variable_check (to, 0) == FAILURE)
     return FAILURE;
 
-  if (array_check (to, 0) == FAILURE)
-    return FAILURE;
-
   attr = gfc_variable_attr (to, NULL);
   if (!attr.allocatable)
     {
@@ -2070,7 +2216,7 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
       return FAILURE;
     }
 
-  if (same_type_check (from, 0, to, 1) == FAILURE)
+  if (same_type_check (to, 1, from, 0) == FAILURE)
     return FAILURE;
 
   if (to->rank != from->rank)
@@ -2146,29 +2292,78 @@ gfc_check_null (gfc_expr *mold)
 gfc_try
 gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
 {
-  char buffer[80];
-
   if (array_check (array, 0) == FAILURE)
     return FAILURE;
 
   if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
     return FAILURE;
 
-  snprintf (buffer, 80, "arguments '%s' and '%s' for intrinsic '%s'",
-	    gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[1],
-	    gfc_current_intrinsic);
-  if (gfc_check_conformance (buffer, array, mask) == FAILURE)
+  if (gfc_check_conformance (array, mask,
+			     "arguments '%s' and '%s' for intrinsic '%s'",
+			     gfc_current_intrinsic_arg[0],
+			     gfc_current_intrinsic_arg[1],
+			     gfc_current_intrinsic) == FAILURE)
     return FAILURE;
 
   if (vector != NULL)
     {
+      mpz_t array_size, vector_size;
+      bool have_array_size, have_vector_size;
+
       if (same_type_check (array, 0, vector, 2) == FAILURE)
 	return FAILURE;
 
       if (rank_check (vector, 2, 1) == FAILURE)
 	return FAILURE;
 
-      /* TODO: More constraints here.  */
+      /* VECTOR requires at least as many elements as MASK
+         has .TRUE. values.  */
+      have_array_size = gfc_array_size (array, &array_size) == SUCCESS;
+      have_vector_size = gfc_array_size (vector, &vector_size) == SUCCESS;
+
+      if (have_vector_size
+	  && (mask->expr_type == EXPR_ARRAY
+	      || (mask->expr_type == EXPR_CONSTANT
+		  && have_array_size)))
+	{
+	  int mask_true_values = 0;
+
+	  if (mask->expr_type == EXPR_ARRAY)
+	    {
+	      gfc_constructor *mask_ctor = mask->value.constructor;
+	      while (mask_ctor)
+		{
+		  if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
+		    {
+		      mask_true_values = 0;
+		      break;
+		    }
+
+		  if (mask_ctor->expr->value.logical)
+		    mask_true_values++;
+
+		  mask_ctor = mask_ctor->next;
+		}
+	    }
+	  else if (mask->expr_type == EXPR_CONSTANT && mask->value.logical)
+	    mask_true_values = mpz_get_si (array_size);
+
+	  if (mpz_get_si (vector_size) < mask_true_values)
+	    {
+	      gfc_error ("'%s' argument of '%s' intrinsic at %L must "
+			 "provide at least as many elements as there "
+			 "are .TRUE. values in '%s' (%ld/%d)",
+			 gfc_current_intrinsic_arg[2],gfc_current_intrinsic, 
+			 &vector->where, gfc_current_intrinsic_arg[1],
+			 mpz_get_si (vector_size), mask_true_values);
+	      return FAILURE;
+	    }
+	}
+
+      if (have_array_size)
+	mpz_clear (array_size);
+      if (have_vector_size)
+	mpz_clear (vector_size);
     }
 
   return SUCCESS;
@@ -2337,7 +2532,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
 {
   mpz_t size;
   mpz_t nelems;
-  int m;
+  int shape_size;
 
   if (array_check (source, 0) == FAILURE)
     return FAILURE;
@@ -2355,26 +2550,121 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
       return FAILURE;
     }
 
-  m = mpz_cmp_ui (size, GFC_MAX_DIMENSIONS);
+  shape_size = mpz_get_ui (size);
   mpz_clear (size);
 
-  if (m > 0)
+  if (shape_size <= 0)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L is empty",
+		 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
+		 &shape->where);
+      return FAILURE;
+    }
+  else if (shape_size > GFC_MAX_DIMENSIONS)
     {
       gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
 		 "than %d elements", &shape->where, GFC_MAX_DIMENSIONS);
       return FAILURE;
     }
+  else if (shape->expr_type == EXPR_ARRAY)
+    {
+      gfc_expr *e;
+      int i, extent;
+      for (i = 0; i < shape_size; ++i)
+	{
+	  e = gfc_get_array_element (shape, i);
+	  if (e->expr_type != EXPR_CONSTANT)
+	    {
+	      gfc_free_expr (e);
+	      continue;
+	    }
+
+	  gfc_extract_int (e, &extent);
+	  if (extent < 0)
+	    {
+	      gfc_error ("'%s' argument of '%s' intrinsic at %L has "
+			 "negative element (%d)", gfc_current_intrinsic_arg[1],
+			 gfc_current_intrinsic, &e->where, extent);
+	      return FAILURE;
+	    }
+
+	  gfc_free_expr (e);
+	}
+    }
 
   if (pad != NULL)
     {
       if (same_type_check (source, 0, pad, 2) == FAILURE)
 	return FAILURE;
+
       if (array_check (pad, 2) == FAILURE)
 	return FAILURE;
     }
 
-  if (order != NULL && array_check (order, 3) == FAILURE)
-    return FAILURE;
+  if (order != NULL)
+    {
+      if (array_check (order, 3) == FAILURE)
+	return FAILURE;
+
+      if (type_check (order, 3, BT_INTEGER) == FAILURE)
+	return FAILURE;
+
+      if (order->expr_type == EXPR_ARRAY)
+	{
+	  int i, order_size, dim, perm[GFC_MAX_DIMENSIONS];
+	  gfc_expr *e;
+
+	  for (i = 0; i < GFC_MAX_DIMENSIONS; ++i)
+	    perm[i] = 0;
+
+	  gfc_array_size (order, &size);
+	  order_size = mpz_get_ui (size);
+	  mpz_clear (size);
+
+	  if (order_size != shape_size)
+	    {
+	      gfc_error ("'%s' argument of '%s' intrinsic at %L "
+			 "has wrong number of elements (%d/%d)", 
+			 gfc_current_intrinsic_arg[3],
+			 gfc_current_intrinsic, &order->where,
+			 order_size, shape_size);
+	      return FAILURE;
+	    }
+
+	  for (i = 1; i <= order_size; ++i)
+	    {
+	      e = gfc_get_array_element (order, i-1);
+	      if (e->expr_type != EXPR_CONSTANT)
+		{
+		  gfc_free_expr (e);
+		  continue;
+		}
+
+	      gfc_extract_int (e, &dim);
+
+	      if (dim < 1 || dim > order_size)
+		{
+		  gfc_error ("'%s' argument of '%s' intrinsic at %L "
+			     "has out-of-range dimension (%d)", 
+			     gfc_current_intrinsic_arg[3],
+			     gfc_current_intrinsic, &e->where, dim);
+		  return FAILURE;
+		}
+
+	      if (perm[dim-1] != 0)
+		{
+		  gfc_error ("'%s' argument of '%s' intrinsic at %L has "
+			     "invalid permutation of dimensions (dimension "
+			     "'%d' duplicated)", gfc_current_intrinsic_arg[3],
+			     gfc_current_intrinsic, &e->where, dim);
+		  return FAILURE;
+		}
+
+	      perm[dim-1] = 1;
+	      gfc_free_expr (e);
+	    }
+	}
+    }
 
   if (pad == NULL && shape->expr_type == EXPR_ARRAY
       && gfc_is_constant_expr (shape)
@@ -2411,6 +2701,46 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
 
 
 gfc_try
+gfc_check_same_type_as (gfc_expr *a, gfc_expr *b)
+{
+
+  if (a->ts.type != BT_DERIVED && a->ts.type != BT_CLASS)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L "
+		 "must be of a derived type", gfc_current_intrinsic_arg[0],
+		 gfc_current_intrinsic, &a->where);
+      return FAILURE;
+    }
+
+  if (!gfc_type_is_extensible (a->ts.u.derived))
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L "
+		 "must be of an extensible type", gfc_current_intrinsic_arg[0],
+		 gfc_current_intrinsic, &a->where);
+      return FAILURE;
+    }
+
+  if (b->ts.type != BT_DERIVED && b->ts.type != BT_CLASS)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L "
+		 "must be of a derived type", gfc_current_intrinsic_arg[1],
+		 gfc_current_intrinsic, &b->where);
+      return FAILURE;
+    }
+
+  if (!gfc_type_is_extensible (b->ts.u.derived))
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L "
+		 "must be of an extensible type", gfc_current_intrinsic_arg[1],
+		 gfc_current_intrinsic, &b->where);
+      return FAILURE;
+    }
+
+  return SUCCESS;
+}
+
+
+gfc_try
 gfc_check_scale (gfc_expr *x, gfc_expr *i)
 {
   if (type_check (x, 0, BT_REAL) == FAILURE)
@@ -2505,11 +2835,23 @@ gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r)
       return FAILURE;
     }
 
-  if (p != NULL && type_check (p, 0, BT_INTEGER) == FAILURE)
-    return FAILURE;
+  if (p)
+    {
+      if (type_check (p, 0, BT_INTEGER) == FAILURE)
+	return FAILURE;
 
-  if (r != NULL && type_check (r, 1, BT_INTEGER) == FAILURE)
-    return FAILURE;
+      if (scalar_check (p, 0) == FAILURE)
+	return FAILURE;
+    }
+
+  if (r)
+    {
+      if (type_check (r, 1, BT_INTEGER) == FAILURE)
+	return FAILURE;
+
+      if (scalar_check (r, 1) == FAILURE)
+	return FAILURE;
+    }
 
   return SUCCESS;
 }
@@ -2568,14 +2910,11 @@ gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
   if (array_check (array, 0) == FAILURE)
     return FAILURE;
 
-  if (dim != NULL)
-    {
-      if (dim_check (dim, 1, true) == FAILURE)
-	return FAILURE;
+  if (dim_check (dim, 1, true) == FAILURE)
+    return FAILURE;
 
-      if (dim_rank_check (dim, array, 0) == FAILURE)
-	return FAILURE;
-    }
+  if (dim_rank_check (dim, array, 0) == FAILURE)
+    return FAILURE;
 
   if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
     return FAILURE;
@@ -2627,6 +2966,18 @@ gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
   if (dim_check (dim, 1, false) == FAILURE)
     return FAILURE;
 
+  /* dim_rank_check() does not apply here.  */
+  if (dim 
+      && dim->expr_type == EXPR_CONSTANT
+      && (mpz_cmp_ui (dim->value.integer, 1) < 0
+	  || mpz_cmp_ui (dim->value.integer, source->rank + 1) > 0))
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L is not a valid "
+		 "dimension index", gfc_current_intrinsic_arg[1],
+		 gfc_current_intrinsic, &dim->where);
+      return FAILURE;
+    }
+
   if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
     return FAILURE;
 
@@ -2911,14 +3262,11 @@ gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
   if (array_check (array, 0) == FAILURE)
     return FAILURE;
 
-  if (dim != NULL)
-    {
-      if (dim_check (dim, 1, false) == FAILURE)
-	return FAILURE;
+  if (dim_check (dim, 1, false) == FAILURE)
+    return FAILURE;
 
-      if (dim_rank_check (dim, array, 0) == FAILURE)
-	return FAILURE;
-    }
+  if (dim_rank_check (dim, array, 0) == FAILURE)
+    return FAILURE;
 
   if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
     return FAILURE;
@@ -2934,6 +3282,8 @@ gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
 gfc_try
 gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
 {
+  mpz_t vector_size;
+
   if (rank_check (vector, 0, 1) == FAILURE)
     return FAILURE;
 
@@ -2946,10 +3296,45 @@ gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
   if (same_type_check (vector, 0, field, 2) == FAILURE)
     return FAILURE;
 
+  if (mask->expr_type == EXPR_ARRAY
+      && gfc_array_size (vector, &vector_size) == SUCCESS)
+    {
+      int mask_true_count = 0;
+      gfc_constructor *mask_ctor = mask->value.constructor;
+      while (mask_ctor)
+	{
+	  if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
+	    {
+	      mask_true_count = 0;
+	      break;
+	    }
+
+	  if (mask_ctor->expr->value.logical)
+	    mask_true_count++;
+
+	  mask_ctor = mask_ctor->next;
+	}
+
+      if (mpz_get_si (vector_size) < mask_true_count)
+	{
+	  gfc_error ("'%s' argument of '%s' intrinsic at %L must "
+		     "provide at least as many elements as there "
+		     "are .TRUE. values in '%s' (%ld/%d)",
+		     gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
+		     &vector->where, gfc_current_intrinsic_arg[1],
+		     mpz_get_si (vector_size), mask_true_count);
+	  return FAILURE;
+	}
+
+      mpz_clear (vector_size);
+    }
+
   if (mask->rank != field->rank && field->rank != 0)
     {
-      gfc_error ("FIELD argument at %L of UNPACK must have the same rank as "
-		 "MASK or be a scalar", &field->where);
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must have "
+		 "the same rank as '%s' or be a scalar", 
+		 gfc_current_intrinsic_arg[2], gfc_current_intrinsic,
+		 &field->where, gfc_current_intrinsic_arg[1]);
       return FAILURE;
     }
 
@@ -2959,9 +3344,11 @@ gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
       for (i = 0; i < field->rank; i++)
 	if (! identical_dimen_shape (mask, i, field, i))
 	{
-	  gfc_error ("Different shape in dimension %d for MASK and FIELD "
-		     "arguments of UNPACK at %L", mask->rank, &field->where);
-	  return FAILURE;
+	  gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L "
+		     "must have identical shape.", 
+		     gfc_current_intrinsic_arg[2],
+		     gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
+		     &field->where);
 	}
     }
 
@@ -3127,6 +3514,22 @@ gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len,
   if (type_check (topos, 4, BT_INTEGER) == FAILURE)
     return FAILURE;
 
+  if (nonnegative_check ("frompos", frompos) == FAILURE)
+    return FAILURE;
+
+  if (nonnegative_check ("topos", topos) == FAILURE)
+    return FAILURE;
+
+  if (nonnegative_check ("len", len) == FAILURE)
+    return FAILURE;
+
+  if (less_than_bitsize2 ("from", from, "frompos", frompos, "len", len)
+      == FAILURE)
+    return FAILURE;
+
+  if (less_than_bitsize2 ("to", to, "topos", topos, "len", len) == FAILURE)
+    return FAILURE;
+
   return SUCCESS;
 }