re PR fortran/56650 (Odd error messages with C_SIZEOF for valid code)

2013-03-27  Tobias Burnus  <burnus@net-b.de>

        PR fortran/56650
        PR fortran/36437
        * check.c (gfc_check_sizeof, gfc_check_c_sizeof,
        gfc_check_storage_size): Update checks.
        * intrinsic.texi (SIZEOF): Correct class.
        * intrinsic.h (gfc_simplify_sizeof,
        gfc_simplify_storage_size): New prototypes.
        * intrinsic.c (add_functions): Use them.
        * simplify.c (gfc_simplify_sizeof,
        gfc_simplify_storage_size): New functions.

2013-03-27  Tobias Burnus  <burnus@net-b.de>

        PR fortran/56650
        PR fortran/36437
        * gfortran.dg/sizeof_2.f90: New.
        * gfortran.dg/sizeof_3.f90: New.
        * gfortran.dg/sizeof_proc.f90: Update dg-error.

From-SVN: r197159

1 files changed, 47 insertions, 2 deletions

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 0460bf2..99174bc 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -3617,11 +3617,31 @@ gfc_check_sizeof (gfc_expr *arg)
 {
   if (arg->ts.type == BT_PROCEDURE)
     {
-      gfc_error ("'%s' argument of '%s' intrinsic at %L may not be a procedure",
+      gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be a procedure",
 		 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
 		 &arg->where);
       return FAILURE;
     }
+
+  if (arg->ts.type == BT_ASSUMED)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be TYPE(*)",
+		 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
+		 &arg->where);
+      return FAILURE;
+    }
+
+  if (arg->rank && arg->expr_type == EXPR_VARIABLE
+      && arg->symtree->n.sym->as != NULL
+      && arg->symtree->n.sym->as->type == AS_ASSUMED_SIZE && arg->ref
+      && arg->ref->type == REF_ARRAY && arg->ref->u.ar.type == AR_FULL)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be an "
+		 "assumed-size array", gfc_current_intrinsic_arg[0]->name,
+		 gfc_current_intrinsic, &arg->where);
+      return FAILURE;
+    }
+
   return SUCCESS;
 }
 
@@ -3739,6 +3759,15 @@ gfc_check_c_sizeof (gfc_expr *arg)
       return FAILURE;
     }
 
+  if (arg->ts.type == BT_ASSUMED)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
+		 "TYPE(*)",
+		 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
+		 &arg->where);
+      return FAILURE;
+    }
+
   if (arg->rank && arg->expr_type == EXPR_VARIABLE
       && arg->symtree->n.sym->as != NULL
       && arg->symtree->n.sym->as->type == AS_ASSUMED_SIZE && arg->ref
@@ -5593,8 +5622,24 @@ gfc_check_and (gfc_expr *i, gfc_expr *j)
 
 
 gfc_try
-gfc_check_storage_size (gfc_expr *a ATTRIBUTE_UNUSED, gfc_expr *kind)
+gfc_check_storage_size (gfc_expr *a, gfc_expr *kind)
 {
+  if (a->ts.type == BT_ASSUMED)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be TYPE(*)",
+		 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
+		 &a->where);
+      return FAILURE;
+    }
+
+  if (a->ts.type == BT_PROCEDURE)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be a "
+		 "procedure", gfc_current_intrinsic_arg[0]->name,
+		 gfc_current_intrinsic, &a->where);
+      return FAILURE;
+    }
+
   if (kind == NULL)
     return SUCCESS;