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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@163096 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 63884eb..e34b6ac 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,35 @@
+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

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 7578775..ad040f1 100644 (file)
--- a/gcc/fortran/check.c
+++ b/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;
     }

diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index 121afc0..c9e3833 100644 (file)
--- a/gcc/fortran/intrinsic.c
+++ b/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;
     }

diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index f5da7a0..23272a8 100644 (file)
--- a/gcc/fortran/intrinsic.h
+++ b/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;

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index e8f3744..51fb4a7 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+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):

diff --git a/gcc/testsuite/gfortran.dg/move_alloc_3.f90 b/gcc/testsuite/gfortran.dg/move_alloc_3.f90
new file mode 100644 (file)
index 0000000..3855eed
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/move_alloc_3.f90
@@ -0,0 +1,12 @@
+! { 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

diff --git a/gcc/testsuite/gfortran.dg/random_seed_2.f90 b/gcc/testsuite/gfortran.dg/random_seed_2.f90
new file mode 100644 (file)
index 0000000..52728f8
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/random_seed_2.f90
@@ -0,0 +1,11 @@
+! { 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