1 files changed, 41 insertions, 7 deletions

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 01775abdd30..171eeaa97bf 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -2135,9 +2135,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)
     {
@@ -2150,9 +2147,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)
     {
@@ -2162,7 +2156,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)
@@ -2647,6 +2641,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)