re PR fortran/44595 (INTENT of arguments to intrinsic procedures not checked)

2010-08-11  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/44595
	* intrinsic.c (gfc_current_intrinsic_arg): Change type from 'char' to
	'gfc_intrinsic_arg'.
	(check_arglist,check_specific): Add reference to 'name' field.
	(init_arglist): Remove reference to 'name' field.
	* intrinsic.h (gfc_current_intrinsic_arg): Modify prototype.
	* check.c (variable_check): Reverse order of checks. Respect intent of
	formal arg.
	(int_or_proc_check): New function.
	(coarray_check): New function.
	(allocatable_check): New function.
	(gfc_check_allocated,gfc_check_move_alloc): Use 'allocatable_check'.
	(gfc_check_complex): Use 'int_or_real_check'.
	(gfc_check_lcobound,gfc_check_image_index,gfc_check_this_image,
	gfc_check_ucobound): Use 'coarray_check'.
	(gfc_check_pack): Use 'real_or_complex_check'.
	(gfc_check_alarm_sub,gfc_check_signal,gfc_check_signal_sub): Use
	'int_or_proc_check'.
	(scalar_check,type_check,numeric_check,int_or_real_check,
	real_or_complex_check,kind_check,double_check,logical_array_check,
	array_check,same_type_check,rank_check,nonoptional_check,
	kind_value_check,gfc_check_a_p,gfc_check_associated,gfc_check_cmplx,
	gfc_check_cshift,gfc_check_dcmplx,gfc_check_dot_product,gfc_check_dprod,
	gfc_check_eoshift,gfc_check_fn_rc2008,gfc_check_index,gfc_check_kind,
	gfc_check_matmul,gfc_check_minloc_maxloc,check_reduction,gfc_check_null,
	gfc_check_present,gfc_check_reshape,gfc_check_same_type_as,
	gfc_check_spread,gfc_check_unpack,gfc_check_random_seed,
	gfc_check_getarg,gfc_check_and,gfc_check_storage_size): Add reference
	to 'name' field.

2010-08-11  Janus Weil  <janus@gcc.gnu.org>
	    Steve Kargl <kargl@gcc.gnu.org>

	PR fortran/44595
	* gfortran.dg/move_alloc_3.f90: New.
	* gfortran.dg/random_seed_2.f90: New.

Co-Authored-By: Steve Kargl <kargl@gcc.gnu.org>

From-SVN: r163096

gcc/fortran/ChangeLog

+2010-08-11  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/44595
+	* intrinsic.c (gfc_current_intrinsic_arg): Change type from 'char' to
+	'gfc_intrinsic_arg'.
+	(check_arglist,check_specific): Add reference to 'name' field.
+	(init_arglist): Remove reference to 'name' field.
+	* intrinsic.h (gfc_current_intrinsic_arg): Modify prototype.
+	* check.c (variable_check): Reverse order of checks. Respect intent of
+	formal arg.
+	(int_or_proc_check): New function.
+	(coarray_check): New function.
+	(allocatable_check): New function.
+	(gfc_check_allocated,gfc_check_move_alloc): Use 'allocatable_check'.
+	(gfc_check_complex): Use 'int_or_real_check'.
+	(gfc_check_lcobound,gfc_check_image_index,gfc_check_this_image,
+	gfc_check_ucobound): Use 'coarray_check'.
+	(gfc_check_pack): Use 'real_or_complex_check'.
+	(gfc_check_alarm_sub,gfc_check_signal,gfc_check_signal_sub): Use
+	'int_or_proc_check'.
+	(scalar_check,type_check,numeric_check,int_or_real_check,
+	real_or_complex_check,kind_check,double_check,logical_array_check,
+	array_check,same_type_check,rank_check,nonoptional_check,
+	kind_value_check,gfc_check_a_p,gfc_check_associated,gfc_check_cmplx,
+	gfc_check_cshift,gfc_check_dcmplx,gfc_check_dot_product,gfc_check_dprod,
+	gfc_check_eoshift,gfc_check_fn_rc2008,gfc_check_index,gfc_check_kind,
+	gfc_check_matmul,gfc_check_minloc_maxloc,check_reduction,gfc_check_null,
+	gfc_check_present,gfc_check_reshape,gfc_check_same_type_as,
+	gfc_check_spread,gfc_check_unpack,gfc_check_random_seed,
+	gfc_check_getarg,gfc_check_and,gfc_check_storage_size): Add reference
+	to 'name' field.
+
 2010-08-10  Daniel Kraft  <d@domob.eu>
 
 	* gfortran.texi (Interoperability with C): Fix ordering in menu

gcc/fortran/check.c

@@ -43,7 +43,8 @@ scalar_check (gfc_expr *e, int n)
     return SUCCESS;
 
   gfc_error ("'%s' argument of '%s' intrinsic at %L must be a scalar",
-	     gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
+	     gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
+	     &e->where);
 
   return FAILURE;
 }
@@ -58,8 +59,8 @@ type_check (gfc_expr *e, int n, bt type)
     return SUCCESS;
 
   gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s",
-	     gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where,
-	     gfc_basic_typename (type));
+	     gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
+	     &e->where, gfc_basic_typename (type));
 
   return FAILURE;
 }
@@ -86,7 +87,8 @@ numeric_check (gfc_expr *e, int n)
     }
 
   gfc_error ("'%s' argument of '%s' intrinsic at %L must be a numeric type",
-	     gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
+	     gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
+	     &e->where);
 
   return FAILURE;
 }
@@ -100,7 +102,7 @@ int_or_real_check (gfc_expr *e, int n)
   if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL)
     {
       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
-		 "or REAL", gfc_current_intrinsic_arg[n],
+		 "or REAL", gfc_current_intrinsic_arg[n]->name,
 		 gfc_current_intrinsic, &e->where);
       return FAILURE;
     }
@@ -117,7 +119,24 @@ real_or_complex_check (gfc_expr *e, int n)
   if (e->ts.type != BT_REAL && e->ts.type != BT_COMPLEX)
     {
       gfc_error ("'%s' argument of '%s' intrinsic at %L must be REAL "
-		 "or COMPLEX", gfc_current_intrinsic_arg[n],
+		 "or COMPLEX", gfc_current_intrinsic_arg[n]->name,
+		 gfc_current_intrinsic, &e->where);
+      return FAILURE;
+    }
+
+  return SUCCESS;
+}
+
+
+/* Check that an expression is INTEGER or PROCEDURE.  */
+
+static gfc_try
+int_or_proc_check (gfc_expr *e, int n)
+{
+  if (e->ts.type != BT_INTEGER && e->ts.type != BT_PROCEDURE)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
+		 "or PROCEDURE", gfc_current_intrinsic_arg[n]->name,
 		 gfc_current_intrinsic, &e->where);
       return FAILURE;
     }
@@ -146,7 +165,7 @@ kind_check (gfc_expr *k, int n, bt type)
   if (k->expr_type != EXPR_CONSTANT)
     {
       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
-		 gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
+		 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
 		 &k->where);
       return FAILURE;
     }
@@ -174,7 +193,7 @@ double_check (gfc_expr *d, int n)
   if (d->ts.kind != gfc_default_double_kind)
     {
       gfc_error ("'%s' argument of '%s' intrinsic at %L must be double "
-		 "precision", gfc_current_intrinsic_arg[n],
+		 "precision", gfc_current_intrinsic_arg[n]->name,
 		 gfc_current_intrinsic, &d->where);
       return FAILURE;
     }
@@ -209,6 +228,21 @@ is_coarray (gfc_expr *e)
 }
 
 
+static gfc_try
+coarray_check (gfc_expr *e, int n)
+{
+  if (!is_coarray (e))
+    {
+      gfc_error ("Expected coarray variable as '%s' argument to the %s "
+                 "intrinsic at %L", gfc_current_intrinsic_arg[n]->name,
+		 gfc_current_intrinsic, &e->where);
+      return FAILURE;
+    }
+
+  return SUCCESS;
+} 
+
+
 /* Make sure the expression is a logical array.  */
 
 static gfc_try
@@ -217,8 +251,8 @@ logical_array_check (gfc_expr *array, int n)
   if (array->ts.type != BT_LOGICAL || array->rank == 0)
     {
       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a logical "
-		 "array", gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
-		 &array->where);
+		 "array", gfc_current_intrinsic_arg[n]->name,
+		 gfc_current_intrinsic, &array->where);
       return FAILURE;
     }
 
@@ -235,7 +269,8 @@ array_check (gfc_expr *e, int n)
     return SUCCESS;
 
   gfc_error ("'%s' argument of '%s' intrinsic at %L must be an array",
-	     gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
+	     gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
+	     &e->where);
 
   return FAILURE;
 }
@@ -324,8 +359,9 @@ same_type_check (gfc_expr *e, int n, gfc_expr *f, int m)
     return SUCCESS;
 
   gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same type "
-	     "and kind as '%s'", gfc_current_intrinsic_arg[m],
-	     gfc_current_intrinsic, &f->where, gfc_current_intrinsic_arg[n]);
+	     "and kind as '%s'", gfc_current_intrinsic_arg[m]->name,
+	     gfc_current_intrinsic, &f->where,
+	     gfc_current_intrinsic_arg[n]->name);
 
   return FAILURE;
 }
@@ -340,7 +376,7 @@ rank_check (gfc_expr *e, int n, int rank)
     return SUCCESS;
 
   gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank %d",
-	     gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
+	     gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
 	     &e->where, rank);
 
   return FAILURE;
@@ -355,7 +391,7 @@ nonoptional_check (gfc_expr *e, int n)
   if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
     {
       gfc_error ("'%s' argument of '%s' intrinsic at %L must not be OPTIONAL",
-		 gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
+		 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
 		 &e->where);
     }
 
@@ -365,6 +401,26 @@ nonoptional_check (gfc_expr *e, int n)
 }
 
 
+/* Check for ALLOCATABLE attribute.  */
+
+static gfc_try
+allocatable_check (gfc_expr *e, int n)
+{
+  symbol_attribute attr;
+
+  attr = gfc_variable_attr (e, NULL);
+  if (!attr.allocatable)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
+		 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
+		 &e->where);
+      return FAILURE;
+    }
+
+  return SUCCESS;
+}
+
+
 /* Check that an expression has a particular kind.  */
 
 static gfc_try
@@ -374,7 +430,7 @@ kind_value_check (gfc_expr *e, int n, int k)
     return SUCCESS;
 
   gfc_error ("'%s' argument of '%s' intrinsic at %L must be of kind %d",
-	     gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
+	     gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
 	     &e->where, k);
 
   return FAILURE;
@@ -386,23 +442,25 @@ kind_value_check (gfc_expr *e, int n, int k)
 static gfc_try
 variable_check (gfc_expr *e, int n)
 {
-  if ((e->expr_type == EXPR_VARIABLE
-       && e->symtree->n.sym->attr.flavor != FL_PARAMETER)
-      || (e->expr_type == EXPR_FUNCTION
-	  && e->symtree->n.sym->result == e->symtree->n.sym))
-    return SUCCESS;
-
   if (e->expr_type == EXPR_VARIABLE
-      && e->symtree->n.sym->attr.intent == INTENT_IN)
+      && e->symtree->n.sym->attr.intent == INTENT_IN
+      && (gfc_current_intrinsic_arg[n]->intent == INTENT_OUT
+	  || gfc_current_intrinsic_arg[n]->intent == INTENT_INOUT))
     {
       gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be INTENT(IN)",
-		 gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
+		 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
 		 &e->where);
       return FAILURE;
     }
 
+  if ((e->expr_type == EXPR_VARIABLE
+       && e->symtree->n.sym->attr.flavor != FL_PARAMETER)
+      || (e->expr_type == EXPR_FUNCTION
+	  && e->symtree->n.sym->result == e->symtree->n.sym))
+    return SUCCESS;
+
   gfc_error ("'%s' argument of '%s' intrinsic at %L must be a variable",
-	     gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
+	     gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where);
 
   return FAILURE;
 }
@@ -666,20 +724,11 @@ gfc_check_all_any (gfc_expr *mask, gfc_expr *dim)
 gfc_try
 gfc_check_allocated (gfc_expr *array)
 {
-  symbol_attribute attr;
-
   if (variable_check (array, 0) == FAILURE)
     return FAILURE;
-
-  attr = gfc_variable_attr (array, NULL);
-  if (!attr.allocatable)
-    {
-      gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
-		 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
-		 &array->where);
-      return FAILURE;
-    }
-
+  if (allocatable_check (array, 0) == FAILURE)
+    return FAILURE;
+  
   return SUCCESS;
 }
 
@@ -696,8 +745,8 @@ gfc_check_a_p (gfc_expr *a, gfc_expr *p)
   if (a->ts.type != p->ts.type)
     {
       gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
-		 "have the same type", gfc_current_intrinsic_arg[0],
-		 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
+		 "have the same type", gfc_current_intrinsic_arg[0]->name,
+		 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
 		 &p->where);
       return FAILURE;
     }
@@ -743,7 +792,7 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
   if (!attr1.pointer && !attr1.proc_pointer)
     {
       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
-		 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
+		 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
 		 &pointer->where);
       return FAILURE;
     }
@@ -761,15 +810,16 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
   else
     {
       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer "
-		 "or target VARIABLE or FUNCTION", gfc_current_intrinsic_arg[1],
-		 gfc_current_intrinsic, &target->where);
+		 "or target VARIABLE or FUNCTION",
+		 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
+		 &target->where);
       return FAILURE;
     }
 
   if (attr1.pointer && !attr2.pointer && !attr2.target)
     {
       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER "
-		 "or a TARGET", gfc_current_intrinsic_arg[1],
+		 "or a TARGET", gfc_current_intrinsic_arg[1]->name,
 		 gfc_current_intrinsic, &target->where);
       return FAILURE;
     }
@@ -962,16 +1012,18 @@ gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind)
       if (x->ts.type == BT_COMPLEX)
 	{
 	  gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
-		     "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1],
-		     gfc_current_intrinsic, &y->where);
+		     "present if 'x' is COMPLEX",
+		     gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
+		     &y->where);
 	  return FAILURE;
 	}
 
       if (y->ts.type == BT_COMPLEX)
 	{
 	  gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
-		     "of either REAL or INTEGER", gfc_current_intrinsic_arg[1],
-		     gfc_current_intrinsic, &y->where);
+		     "of either REAL or INTEGER",
+		     gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
+		     &y->where);
 	  return FAILURE;
 	}
 
@@ -987,23 +1039,13 @@ gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind)
 gfc_try
 gfc_check_complex (gfc_expr *x, gfc_expr *y)
 {
-  if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
-    {
-      gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
-		 "or REAL", gfc_current_intrinsic_arg[0],
-		 gfc_current_intrinsic, &x->where);
-      return FAILURE;
-    }
+  if (int_or_real_check (x, 0) == FAILURE)
+    return FAILURE;
   if (scalar_check (x, 0) == FAILURE)
     return FAILURE;
 
-  if (y->ts.type != BT_INTEGER && y->ts.type != BT_REAL)
-    {
-      gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
-		 "or REAL", gfc_current_intrinsic_arg[1],
-		 gfc_current_intrinsic, &y->where);
-      return FAILURE;
-    }
+  if (int_or_real_check (y, 1) == FAILURE)
+    return FAILURE;
   if (scalar_check (y, 1) == FAILURE)
     return FAILURE;
 
@@ -1071,7 +1113,7 @@ gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
 		  {
 		    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_arg[1]->name,
 			       gfc_current_intrinsic, &shift->where, i + 1,
 			       mpz_get_si (array->shape[i]),
 			       mpz_get_si (shift->shape[j]));
@@ -1085,7 +1127,7 @@ gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
   else
     {
       gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
-		 "%d or be a scalar", gfc_current_intrinsic_arg[1],
+		 "%d or be a scalar", gfc_current_intrinsic_arg[1]->name,
 		 gfc_current_intrinsic, &shift->where, array->rank - 1);
       return FAILURE;
     }
@@ -1129,16 +1171,18 @@ gfc_check_dcmplx (gfc_expr *x, gfc_expr *y)
       if (x->ts.type == BT_COMPLEX)
 	{
 	  gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
-		     "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1],
-		     gfc_current_intrinsic, &y->where);
+		     "present if 'x' is COMPLEX",
+		     gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
+		     &y->where);
 	  return FAILURE;
 	}
 
       if (y->ts.type == BT_COMPLEX)
 	{
 	  gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
-		     "of either REAL or INTEGER", gfc_current_intrinsic_arg[1],
-		     gfc_current_intrinsic, &y->where);
+		     "of either REAL or INTEGER",
+		     gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
+		     &y->where);
 	  return FAILURE;
 	}
     }
@@ -1186,7 +1230,7 @@ gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
 
     default:
       gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
-		 "or LOGICAL", gfc_current_intrinsic_arg[0],
+		 "or LOGICAL", gfc_current_intrinsic_arg[0]->name,
 		 gfc_current_intrinsic, &vector_a->where);
       return FAILURE;
     }
@@ -1200,8 +1244,8 @@ gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
   if (! identical_dimen_shape (vector_a, 0, vector_b, 0))
     {
       gfc_error ("Different shape for arguments '%s' and '%s' at %L for "
-		 "intrinsic 'dot_product'", gfc_current_intrinsic_arg[0],
-		 gfc_current_intrinsic_arg[1], &vector_a->where);
+		 "intrinsic 'dot_product'", gfc_current_intrinsic_arg[0]->name,
+		 gfc_current_intrinsic_arg[1]->name, &vector_a->where);
       return FAILURE;
     }
 
@@ -1219,7 +1263,7 @@ gfc_check_dprod (gfc_expr *x, gfc_expr *y)
   if (x->ts.kind != gfc_default_real_kind)
     {
       gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
-		 "real", gfc_current_intrinsic_arg[0],
+		 "real", gfc_current_intrinsic_arg[0]->name,
 		 gfc_current_intrinsic, &x->where);
       return FAILURE;
     }
@@ -1227,7 +1271,7 @@ gfc_check_dprod (gfc_expr *x, gfc_expr *y)
   if (y->ts.kind != gfc_default_real_kind)
     {
       gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
-		 "real", gfc_current_intrinsic_arg[1],
+		 "real", gfc_current_intrinsic_arg[1]->name,
 		 gfc_current_intrinsic, &y->where);
       return FAILURE;
     }
@@ -1277,7 +1321,7 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
 		  {
 		    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_arg[1]->name,
 			       gfc_current_intrinsic, &shift->where, i + 1,
 			       mpz_get_si (array->shape[i]),
 			       mpz_get_si (shift->shape[j]));
@@ -1291,7 +1335,7 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
   else
     {
       gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
-		 "%d or be a scalar", gfc_current_intrinsic_arg[1],
+		 "%d or be a scalar", gfc_current_intrinsic_arg[1]->name,
 		 gfc_current_intrinsic, &shift->where, array->rank - 1);
       return FAILURE;
     }
@@ -1311,16 +1355,17 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
 	  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_arg[1]->name,
+				     gfc_current_intrinsic_arg[2]->name,
 				     gfc_current_intrinsic ) == FAILURE)
 	    return FAILURE;
 	}
       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);
+		     "rank %d or be a scalar",
+		     gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
+		     &shift->where, array->rank - 1);
 	  return FAILURE;
 	}
     }
@@ -1397,8 +1442,8 @@ gfc_check_fn_rc2008 (gfc_expr *a)
   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)
+			 gfc_current_intrinsic_arg[0]->name,
+			 gfc_current_intrinsic, &a->where) == FAILURE)
     return FAILURE;
 
   return SUCCESS;
@@ -1619,9 +1664,9 @@ gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back,
   if (string->ts.kind != substring->ts.kind)
     {
       gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same "
-		 "kind as '%s'", gfc_current_intrinsic_arg[1],
+		 "kind as '%s'", gfc_current_intrinsic_arg[1]->name,
 		 gfc_current_intrinsic, &substring->where,
-		 gfc_current_intrinsic_arg[0]);
+		 gfc_current_intrinsic_arg[0]->name);
       return FAILURE;
     }
 
@@ -1744,7 +1789,7 @@ gfc_check_kind (gfc_expr *x)
   if (x->ts.type == BT_DERIVED)
     {
       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a "
-		 "non-derived type", gfc_current_intrinsic_arg[0],
+		 "non-derived type", gfc_current_intrinsic_arg[0]->name,
 		 gfc_current_intrinsic, &x->where);
       return FAILURE;
     }
@@ -1785,12 +1830,8 @@ gfc_check_lcobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind)
       return FAILURE;
     }
 
-  if (!is_coarray (coarray))
-    {
-      gfc_error ("Expected coarray variable as '%s' argument to the LCOBOUND "
-                 "intrinsic at %L", gfc_current_intrinsic_arg[0], &coarray->where);
-      return FAILURE;
-    }
+  if (coarray_check (coarray, 0) == FAILURE)
+    return FAILURE;
 
   if (dim != NULL)
     {
@@ -2076,7 +2117,7 @@ gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
   if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
     {
       gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
-		 "or LOGICAL", gfc_current_intrinsic_arg[0],
+		 "or LOGICAL", gfc_current_intrinsic_arg[0]->name,
 		 gfc_current_intrinsic, &matrix_a->where);
       return FAILURE;
     }
@@ -2084,7 +2125,7 @@ gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
   if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
     {
       gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
-		 "or LOGICAL", gfc_current_intrinsic_arg[1],
+		 "or LOGICAL", gfc_current_intrinsic_arg[1]->name,
 		 gfc_current_intrinsic, &matrix_b->where);
       return FAILURE;
     }
@@ -2108,8 +2149,8 @@ gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
 	{
 	  gfc_error ("Different shape on dimension 1 for arguments '%s' "
 		     "and '%s' at %L for intrinsic matmul",
-		     gfc_current_intrinsic_arg[0],
-		     gfc_current_intrinsic_arg[1], &matrix_a->where);
+		     gfc_current_intrinsic_arg[0]->name,
+		     gfc_current_intrinsic_arg[1]->name, &matrix_a->where);
 	  return FAILURE;
 	}
       break;
@@ -2127,15 +2168,15 @@ gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
 	{
 	  gfc_error ("Different shape on dimension 2 for argument '%s' and "
 		     "dimension 1 for argument '%s' at %L for intrinsic "
-		     "matmul", gfc_current_intrinsic_arg[0],
-		     gfc_current_intrinsic_arg[1], &matrix_a->where);
+		     "matmul", gfc_current_intrinsic_arg[0]->name,
+		     gfc_current_intrinsic_arg[1]->name, &matrix_a->where);
 	  return FAILURE;
 	}
       break;
 
     default:
       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank "
-		 "1 or 2", gfc_current_intrinsic_arg[0],
+		 "1 or 2", gfc_current_intrinsic_arg[0]->name,
 		 gfc_current_intrinsic, &matrix_a->where);
       return FAILURE;
     }
@@ -2191,8 +2232,8 @@ gfc_check_minloc_maxloc (gfc_actual_arglist *ap)
   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_arg[0]->name,
+				gfc_current_intrinsic_arg[2]->name,
 				gfc_current_intrinsic ) == FAILURE)
     return FAILURE;
 
@@ -2245,8 +2286,8 @@ check_reduction (gfc_actual_arglist *ap)
   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_arg[0]->name,
+				gfc_current_intrinsic_arg[2]->name,
 				gfc_current_intrinsic) == FAILURE)
     return FAILURE;
 
@@ -2295,31 +2336,15 @@ gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
 gfc_try
 gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
 {
-  symbol_attribute attr;
-
   if (variable_check (from, 0) == FAILURE)
     return FAILURE;
-
-  attr = gfc_variable_attr (from, NULL);
-  if (!attr.allocatable)
-    {
-      gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
-		 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
-		 &from->where);
-      return FAILURE;
-    }
-
-  if (variable_check (to, 0) == FAILURE)
+  if (allocatable_check (from, 0) == FAILURE)
     return FAILURE;
 
-  attr = gfc_variable_attr (to, NULL);
-  if (!attr.allocatable)
-    {
-      gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
-		 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
-		 &to->where);
-      return FAILURE;
-    }
+  if (variable_check (to, 1) == FAILURE)
+    return FAILURE;
+  if (allocatable_check (to, 1) == FAILURE)
+    return FAILURE;
 
   if (same_type_check (to, 1, from, 0) == FAILURE)
     return FAILURE;
@@ -2327,8 +2352,8 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
   if (to->rank != from->rank)
     {
       gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
-		 "have the same rank %d/%d", gfc_current_intrinsic_arg[0],
-		 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
+		 "have the same rank %d/%d", gfc_current_intrinsic_arg[0]->name,
+		 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
 		 &to->where,  from->rank, to->rank);
       return FAILURE;
     }
@@ -2336,8 +2361,9 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
   if (to->ts.kind != from->ts.kind)
     {
       gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
-		 "be of the same kind %d/%d", gfc_current_intrinsic_arg[0],
-		 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
+		 "be of the same kind %d/%d",
+		 gfc_current_intrinsic_arg[0]->name,
+		 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
 		 &to->where, from->ts.kind, to->ts.kind);
       return FAILURE;
     }
@@ -2385,7 +2411,7 @@ gfc_check_null (gfc_expr *mold)
   if (!attr.pointer && !attr.proc_pointer)
     {
       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
-		 gfc_current_intrinsic_arg[0],
+		 gfc_current_intrinsic_arg[0]->name,
 		 gfc_current_intrinsic, &mold->where);
       return FAILURE;
     }
@@ -2405,8 +2431,8 @@ gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
 
   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_arg[0]->name,
+			     gfc_current_intrinsic_arg[1]->name,
 			     gfc_current_intrinsic) == FAILURE)
     return FAILURE;
 
@@ -2459,8 +2485,9 @@ gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
 	      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],
+			 gfc_current_intrinsic_arg[2]->name,
+			 gfc_current_intrinsic, &vector->where,
+			 gfc_current_intrinsic_arg[1]->name,
 			 mpz_get_si (vector_size), mask_true_values);
 	      return FAILURE;
 	    }
@@ -2479,13 +2506,8 @@ gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
 gfc_try
 gfc_check_precision (gfc_expr *x)
 {
-  if (x->ts.type != BT_REAL && x->ts.type != BT_COMPLEX)
-    {
-      gfc_error ("'%s' argument of '%s' intrinsic at %L must be of type "
-		 "REAL or COMPLEX", gfc_current_intrinsic_arg[0],
-		 gfc_current_intrinsic, &x->where);
-      return FAILURE;
-    }
+  if (real_or_complex_check (x, 0) == FAILURE)
+    return FAILURE;
 
   return SUCCESS;
 }
@@ -2503,7 +2525,7 @@ gfc_check_present (gfc_expr *a)
   if (!sym->attr.dummy)
     {
       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
-		 "dummy variable", gfc_current_intrinsic_arg[0],
+		 "dummy variable", gfc_current_intrinsic_arg[0]->name,
 		 gfc_current_intrinsic, &a->where);
       return FAILURE;
     }
@@ -2511,8 +2533,9 @@ gfc_check_present (gfc_expr *a)
   if (!sym->attr.optional)
     {
       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
-		 "an OPTIONAL dummy variable", gfc_current_intrinsic_arg[0],
-		 gfc_current_intrinsic, &a->where);
+		 "an OPTIONAL dummy variable",
+		 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
+		 &a->where);
       return FAILURE;
     }
 
@@ -2527,7 +2550,7 @@ gfc_check_present (gfc_expr *a)
 	   && a->ref->u.ar.type == AR_FULL))
     {
       gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a "
-		 "subobject of '%s'", gfc_current_intrinsic_arg[0],
+		 "subobject of '%s'", gfc_current_intrinsic_arg[0]->name,
 		 gfc_current_intrinsic, &a->where, sym->name);
       return FAILURE;
     }
@@ -2662,7 +2685,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
   if (shape_size <= 0)
     {
       gfc_error ("'%s' argument of '%s' intrinsic at %L is empty",
-		 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
+		 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
 		 &shape->where);
       return FAILURE;
     }
@@ -2686,7 +2709,8 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
 	  if (extent < 0)
 	    {
 	      gfc_error ("'%s' argument of '%s' intrinsic at %L has "
-			 "negative element (%d)", gfc_current_intrinsic_arg[1],
+			 "negative element (%d)",
+			 gfc_current_intrinsic_arg[1]->name,
 			 gfc_current_intrinsic, &e->where, extent);
 	      return FAILURE;
 	    }
@@ -2726,7 +2750,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
 	    {
 	      gfc_error ("'%s' argument of '%s' intrinsic at %L "
 			 "has wrong number of elements (%d/%d)", 
-			 gfc_current_intrinsic_arg[3],
+			 gfc_current_intrinsic_arg[3]->name,
 			 gfc_current_intrinsic, &order->where,
 			 order_size, shape_size);
 	      return FAILURE;
@@ -2744,7 +2768,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
 		{
 		  gfc_error ("'%s' argument of '%s' intrinsic at %L "
 			     "has out-of-range dimension (%d)", 
-			     gfc_current_intrinsic_arg[3],
+			     gfc_current_intrinsic_arg[3]->name,
 			     gfc_current_intrinsic, &e->where, dim);
 		  return FAILURE;
 		}
@@ -2753,7 +2777,8 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
 		{
 		  gfc_error ("'%s' argument of '%s' intrinsic at %L has "
 			     "invalid permutation of dimensions (dimension "
-			     "'%d' duplicated)", gfc_current_intrinsic_arg[3],
+			     "'%d' duplicated)",
+			     gfc_current_intrinsic_arg[3]->name,
 			     gfc_current_intrinsic, &e->where, dim);
 		  return FAILURE;
 		}
@@ -2805,32 +2830,36 @@ 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);
+		 "must be of a derived type",
+		 gfc_current_intrinsic_arg[0]->name, 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);
+		 "must be of an extensible type",
+		 gfc_current_intrinsic_arg[0]->name, 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);
+		 "must be of a derived type",
+		 gfc_current_intrinsic_arg[1]->name, 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);
+		 "must be of an extensible type",
+		 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
+		 &b->where);
       return FAILURE;
     }
 
@@ -3051,8 +3080,9 @@ gfc_check_c_sizeof (gfc_expr *arg)
   if (verify_c_interop (&arg->ts) != SUCCESS)
     {
       gfc_error ("'%s' argument of '%s' intrinsic at %L must be be an "
-		 "interoperable data entity", gfc_current_intrinsic_arg[0],
-		 gfc_current_intrinsic, &arg->where);
+		 "interoperable data entity",
+		 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
+		 &arg->where);
       return FAILURE;
     }
   return SUCCESS;
@@ -3092,7 +3122,7 @@ gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
   if (source->rank >= GFC_MAX_DIMENSIONS)
     {
       gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
-		 "than rank %d", gfc_current_intrinsic_arg[0],
+		 "than rank %d", gfc_current_intrinsic_arg[0]->name,
 		 gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS);
 
       return FAILURE;
@@ -3111,7 +3141,7 @@ gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
 	  || 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],
+		 "dimension index", gfc_current_intrinsic_arg[1]->name,
 		 gfc_current_intrinsic, &dim->where);
       return FAILURE;
     }
@@ -3366,17 +3396,13 @@ gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub)
       return FAILURE;
     }
 
-  if (!is_coarray (coarray))
-    {
-      gfc_error ("Expected coarray variable as '%s' argument to IMAGE_INDEX "
-                "intrinsic at %L", gfc_current_intrinsic_arg[0], &coarray->where);
-      return FAILURE;
-    }
+  if (coarray_check (coarray, 0) == FAILURE)
+    return FAILURE;
 
   if (sub->rank != 1)
     {
       gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
-                gfc_current_intrinsic_arg[1], &sub->where);
+                gfc_current_intrinsic_arg[1]->name, &sub->where);
       return FAILURE;
     }
 
@@ -3403,12 +3429,8 @@ gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim)
   if (coarray == NULL)
     return SUCCESS;
 
-  if (!is_coarray (coarray))
-    {
-      gfc_error ("Expected coarray variable as '%s' argument to THIS_IMAGE "
-                "intrinsic at %L", gfc_current_intrinsic_arg[0], &coarray->where);
-      return FAILURE;
-    }
+  if (coarray_check (coarray, 0) == FAILURE)
+    return FAILURE;
 
   if (dim != NULL)
     {
@@ -3492,12 +3514,8 @@ gfc_check_ucobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind)
       return FAILURE;
     }
 
-  if (!is_coarray (coarray))
-    {
-      gfc_error ("Expected coarray variable as '%s' argument to the UCOBOUND "
-                "intrinsic at %L", gfc_current_intrinsic_arg[0], &coarray->where);
-      return FAILURE;
-    }
+  if (coarray_check (coarray, 0) == FAILURE)
+    return FAILURE;
 
   if (dim != NULL)
     {
@@ -3557,8 +3575,8 @@ gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
 	  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],
+		     gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
+		     &vector->where, gfc_current_intrinsic_arg[1]->name,
 		     mpz_get_si (vector_size), mask_true_count);
 	  return FAILURE;
 	}
@@ -3570,8 +3588,8 @@ gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
     {
       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]);
+		 gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
+		 &field->where, gfc_current_intrinsic_arg[1]->name);
       return FAILURE;
     }
 
@@ -3583,8 +3601,8 @@ gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
 	{
 	  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,
+		     gfc_current_intrinsic_arg[2]->name,
+		     gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
 		     &field->where);
 	}
     }
@@ -3842,8 +3860,8 @@ gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
 	  && mpz_get_ui (put_size) < kiss_size)
 	gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
 		   "too small (%i/%i)",
-		   gfc_current_intrinsic_arg[1], gfc_current_intrinsic, where, 
-		   (int) mpz_get_ui (put_size), kiss_size);
+		   gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
+		   where, (int) mpz_get_ui (put_size), kiss_size);
     }
 
   if (get != NULL)
@@ -3874,8 +3892,8 @@ gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
  	  && mpz_get_ui (get_size) < kiss_size)
 	gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
 		   "too small (%i/%i)",
-		   gfc_current_intrinsic_arg[2], gfc_current_intrinsic, where, 
-		   (int) mpz_get_ui (get_size), kiss_size);
+		   gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
+		   where, (int) mpz_get_ui (get_size), kiss_size);
     }
 
   /* RANDOM_SEED may not have more than one non-optional argument.  */
@@ -3986,18 +4004,11 @@ gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status)
 {
   if (scalar_check (seconds, 0) == FAILURE)
     return FAILURE;
-
   if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
     return FAILURE;
 
-  if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
-    {
-      gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
-		 "or PROCEDURE", gfc_current_intrinsic_arg[1],
-		 gfc_current_intrinsic, &handler->where);
-      return FAILURE;
-    }
-
+  if (int_or_proc_check (handler, 1) == FAILURE)
+    return FAILURE;
   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
     return FAILURE;
 
@@ -4006,10 +4017,8 @@ gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status)
 
   if (scalar_check (status, 2) == FAILURE)
     return FAILURE;
-
   if (type_check (status, 2, BT_INTEGER) == FAILURE)
     return FAILURE;
-
   if (kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE)
     return FAILURE;
 
@@ -4177,7 +4186,7 @@ gfc_check_getarg (gfc_expr *pos, gfc_expr *value)
     {
       gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a kind "
 		 "not wider than the default kind (%d)",
-		 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
+		 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
 		 &pos->where, gfc_default_integer_kind);
       return FAILURE;
     }
@@ -4463,18 +4472,11 @@ gfc_check_signal (gfc_expr *number, gfc_expr *handler)
 {
   if (scalar_check (number, 0) == FAILURE)
     return FAILURE;
-
   if (type_check (number, 0, BT_INTEGER) == FAILURE)
     return FAILURE;
 
-  if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
-    {
-      gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
-		 "or PROCEDURE", gfc_current_intrinsic_arg[1],
-		 gfc_current_intrinsic, &handler->where);
-      return FAILURE;
-    }
-
+  if (int_or_proc_check (handler, 1) == FAILURE)
+    return FAILURE;
   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
     return FAILURE;
 
@@ -4487,18 +4489,11 @@ gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status)
 {
   if (scalar_check (number, 0) == FAILURE)
     return FAILURE;
-
   if (type_check (number, 0, BT_INTEGER) == FAILURE)
     return FAILURE;
 
-  if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
-    {
-      gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
-		 "or PROCEDURE", gfc_current_intrinsic_arg[1],
-		 gfc_current_intrinsic, &handler->where);
-      return FAILURE;
-    }
-
+  if (int_or_proc_check (handler, 1) == FAILURE)
+    return FAILURE;
   if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
     return FAILURE;
 
@@ -4507,7 +4502,6 @@ gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status)
 
   if (type_check (status, 2, BT_INTEGER) == FAILURE)
     return FAILURE;
-
   if (scalar_check (status, 2) == FAILURE)
     return FAILURE;
 
@@ -4543,7 +4537,7 @@ gfc_check_and (gfc_expr *i, gfc_expr *j)
   if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL)
     {
       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
-		 "or LOGICAL", gfc_current_intrinsic_arg[0],
+		 "or LOGICAL", gfc_current_intrinsic_arg[0]->name,
 		 gfc_current_intrinsic, &i->where);
       return FAILURE;
     }
@@ -4551,7 +4545,7 @@ gfc_check_and (gfc_expr *i, gfc_expr *j)
   if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
     {
       gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
-		 "or LOGICAL", gfc_current_intrinsic_arg[1],
+		 "or LOGICAL", gfc_current_intrinsic_arg[1]->name,
 		 gfc_current_intrinsic, &j->where);
       return FAILURE;
     }
@@ -4559,8 +4553,8 @@ gfc_check_and (gfc_expr *i, gfc_expr *j)
   if (i->ts.type != j->ts.type)
     {
       gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
-		 "have the same type", gfc_current_intrinsic_arg[0],
-		 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
+		 "have the same type", gfc_current_intrinsic_arg[0]->name,
+		 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
 		 &j->where);
       return FAILURE;
     }
@@ -4590,7 +4584,7 @@ gfc_check_storage_size (gfc_expr *a ATTRIBUTE_UNUSED, gfc_expr *kind)
   if (kind->expr_type != EXPR_CONSTANT)
     {
       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
-		 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
+		 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
 		 &kind->where);
       return FAILURE;
     }

gcc/fortran/intrinsic.c

@@ -36,7 +36,7 @@ bool gfc_init_expr_flag = false;
    checked.  */
 
 const char *gfc_current_intrinsic;
-const char *gfc_current_intrinsic_arg[MAX_INTRINSIC_ARGS];
+gfc_intrinsic_arg *gfc_current_intrinsic_arg[MAX_INTRINSIC_ARGS];
 locus *gfc_current_intrinsic_where;
 
 static gfc_intrinsic_sym *functions, *subroutines, *conversion, *next_sym;
@@ -3390,7 +3390,7 @@ check_arglist (gfc_actual_arglist **ap, gfc_intrinsic_sym *sym,
 	{
 	  if (error_flag)
 	    gfc_error ("Type of argument '%s' in call to '%s' at %L should "
-		       "be %s, not %s", gfc_current_intrinsic_arg[i],
+		       "be %s, not %s", gfc_current_intrinsic_arg[i]->name,
 		       gfc_current_intrinsic, &actual->expr->where,
 		       gfc_typename (&formal->ts),
 		       gfc_typename (&actual->expr->ts));
@@ -3609,7 +3609,7 @@ init_arglist (gfc_intrinsic_sym *isym)
     {
       if (i >= MAX_INTRINSIC_ARGS)
 	gfc_internal_error ("init_arglist(): too many arguments");
-      gfc_current_intrinsic_arg[i++] = formal->name;
+      gfc_current_intrinsic_arg[i++] = formal;
     }
 }
 
@@ -3678,8 +3678,8 @@ check_specific (gfc_intrinsic_sym *specific, gfc_expr *expr, int error_flag)
 	if (gfc_check_conformance (first_expr, arg->expr,
 				   "arguments '%s' and '%s' for "
 				   "intrinsic '%s'",
-				   gfc_current_intrinsic_arg[0],
-				   gfc_current_intrinsic_arg[n],
+				   gfc_current_intrinsic_arg[0]->name,
+				   gfc_current_intrinsic_arg[n]->name,
 				   gfc_current_intrinsic) == FAILURE)
 	  return FAILURE;
     }

gcc/fortran/intrinsic.h

@@ -573,5 +573,5 @@ void gfc_resolve_unlink_sub (gfc_code *);
 #define MAX_INTRINSIC_ARGS 5
 
 extern const char *gfc_current_intrinsic;
-extern const char *gfc_current_intrinsic_arg[MAX_INTRINSIC_ARGS];
+extern gfc_intrinsic_arg *gfc_current_intrinsic_arg[MAX_INTRINSIC_ARGS];
 extern locus *gfc_current_intrinsic_where;

gcc/testsuite/ChangeLog

+2010-08-11  Janus Weil  <janus@gcc.gnu.org>
+	    Steve Kargl <kargl@gcc.gnu.org>
+
+	PR fortran/44595
+	* gfortran.dg/move_alloc_3.f90: New.
+	* gfortran.dg/random_seed_2.f90: New.
+
 2010-08-10  John David Anglin  <dave.anglin@nrc-cnrc.gc.ca>
 
 	* lib/target-supports.exp (check_effective_target_sync_int_long):

gcc/testsuite/gfortran.dg/move_alloc_3.f90

+! { dg-do compile }
+!
+! PR 44595: INTENT of arguments to intrinsic procedures not checked
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+ 
+subroutine test(f)
+  implicit none
+  integer, allocatable, intent(in) :: f
+  integer, allocatable :: t
+  call move_alloc(f,t)        ! { dg-error "cannot be INTENT.IN." }
+end subroutine

gcc/testsuite/gfortran.dg/random_seed_2.f90

+! { dg-do compile }
+!
+! PR 44595: INTENT of arguments to intrinsic procedures not checked
+!
+! Contributed by Steve Kargl <kargl@gcc.gnu.org>
+
+subroutine reset_seed(iseed)
+    implicit none
+    integer, intent(in) :: iseed
+    call random_seed(iseed)        ! { dg-error "cannot be INTENT.IN." }
+end subroutine reset_seed