re PR fortran/55362 (ICE with size() on character pointer)

2013-03-10  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/55362
	* check.c (array_check): It is an error if a procedure is
	passed.

2013-03-10  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/55362
	* gfortran.dg/intrinsic_size_4.f90 : New test.

From-SVN: r196583

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 72af533d760d657a1ca2aaf18594dbda74279a1a..728c8e93e1ea6d2122d2d894f5de4fe2937aadd1 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2013-03-10  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/55362
+       * check.c (array_check): It is an error if a procedure is
+       passed.
+
 2013-02-23  Janus Weil  <janus@gcc.gnu.org>
 
        PR fortran/56385

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 4d71e52aef954930297d9ac0ec6efff892711076..190b68efd7af50838498321239ff50eb3f8fa8eb 100644 (file)
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -220,7 +220,7 @@ is_coarray (gfc_expr *e)
       if (ref->type == REF_COMPONENT)
        coarray = ref->u.c.component->attr.codimension;
       else if (ref->type != REF_ARRAY || ref->u.ar.dimen != 0
-              || ref->u.ar.codimen != 0) 
+              || ref->u.ar.codimen != 0)
        coarray = false;
     }
 
@@ -240,7 +240,7 @@ coarray_check (gfc_expr *e, int n)
     }
 
   return SUCCESS;
-} 
+}
 
 
 /* Make sure the expression is a logical array.  */
@@ -265,7 +265,7 @@ logical_array_check (gfc_expr *array, int n)
 static gfc_try
 array_check (gfc_expr *e, int n)
 {
-  if (e->rank != 0)
+  if (e->rank != 0 && e->ts.type != BT_PROCEDURE))
     return SUCCESS;
 
   gfc_error ("'%s' argument of '%s' intrinsic at %L must be an array",
@@ -346,7 +346,7 @@ less_than_bitsizekind (const char *arg, gfc_expr *expr, int k)
 
   if (expr->expr_type != EXPR_CONSTANT)
     return SUCCESS;
- 
+
   i = gfc_validate_kind (BT_INTEGER, k, false);
   gfc_extract_int (expr, &val);
 
@@ -501,7 +501,7 @@ variable_check (gfc_expr *e, int n, bool allow_proc)
                  || (ref->u.c.component->ts.type != BT_CLASS
                      && ref->u.c.component->attr.pointer)))
            break;
-       } 
+       }
 
       if (!ref)
        {
@@ -651,7 +651,7 @@ identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi)
        {
          if (mpz_cmp (a_size, b_size) != 0)
            ret = 0;
-  
+
          mpz_clear (b_size);
        }
       mpz_clear (a_size);
@@ -824,7 +824,7 @@ gfc_check_allocated (gfc_expr *array)
     return FAILURE;
   if (allocatable_check (array, 0) == FAILURE)
     return FAILURE;
-  
+
   return SUCCESS;
 }
 
@@ -1752,7 +1752,7 @@ gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind)
                return SUCCESS;
              i = mpz_get_si (c->ts.u.cl->length->value.integer);
            }
-         else 
+         else
            return SUCCESS;
        }
       else
@@ -1774,7 +1774,7 @@ gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind)
 
   if (i != 1)
     {
-      gfc_error ("Argument of %s at %L must be of length one", 
+      gfc_error ("Argument of %s at %L must be of length one",
                 gfc_current_intrinsic, &c->where);
       return FAILURE;
     }
@@ -3022,7 +3022,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
          if (order_size != shape_size)
            {
              gfc_error ("'%s' argument of '%s' intrinsic at %L "
-                        "has wrong number of elements (%d/%d)", 
+                        "has wrong number of elements (%d/%d)",
                         gfc_current_intrinsic_arg[3]->name,
                         gfc_current_intrinsic, &order->where,
                         order_size, shape_size);
@@ -3040,7 +3040,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
              if (dim < 1 || dim > order_size)
                {
                  gfc_error ("'%s' argument of '%s' intrinsic at %L "
-                            "has out-of-range dimension (%d)", 
+                            "has out-of-range dimension (%d)",
                             gfc_current_intrinsic_arg[3]->name,
                             gfc_current_intrinsic, &e->where, dim);
                  return FAILURE;
@@ -3072,7 +3072,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
          gfc_constructor *c;
          bool test;
 
-         
+
          mpz_init_set_ui (size, 1);
          for (c = gfc_constructor_first (shape->value.constructor);
               c; c = gfc_constructor_next (c))
@@ -3434,7 +3434,7 @@ gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
     return FAILURE;
 
   /* dim_rank_check() does not apply here.  */
-  if (dim 
+  if (dim
       && dim->expr_type == EXPR_CONSTANT
       && (mpz_cmp_ui (dim->value.integer, 1) < 0
          || mpz_cmp_ui (dim->value.integer, source->rank + 1) > 0))
@@ -3886,7 +3886,7 @@ gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
   if (mask->rank != field->rank && field->rank != 0)
     {
       gfc_error ("'%s' argument of '%s' intrinsic at %L must have "
-                "the same rank as '%s' or be a scalar", 
+                "the same rank as '%s' or be a scalar",
                 gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
                 &field->where, gfc_current_intrinsic_arg[1]->name);
       return FAILURE;
@@ -3899,7 +3899,7 @@ gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
        if (! identical_dimen_shape (mask, i, field, i))
        {
          gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L "
-                    "must have identical shape.", 
+                    "must have identical shape.",
                     gfc_current_intrinsic_arg[2]->name,
                     gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
                     &field->where);

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index d4aef859ef9185c5574d362ef5e6253b4a456694..1bda4549af1d5ab7d41a5d3102439a508b1cc26f 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2013-03-10  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/55362
+       * gfortran.dg/intrinsic_size_4.f90 : New test.
+
 2013-02-23  Janus Weil  <janus@gcc.gnu.org>
 
        PR fortran/56385

diff --git a/gcc/testsuite/gfortran.dg/intrinsic_size_4.f90 b/gcc/testsuite/gfortran.dg/intrinsic_size_4.f90
new file mode 100644 (file)
index 0000000..6d8e1c0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/intrinsic_size_4.f90
@@ -0,0 +1,18 @@
+! { dg-do compile }
+! Test the fix for PR55362; the error below was missed and an ICE ensued.
+!
+! ! Contributed by Dominique d'Humieres  <dominiq@lps.ens.fr>
+!
+program ice_test
+  implicit none
+  write(*,*) 'message: ', &
+             size(Error_Msg),Error_Msg()     ! { dg-error "must be an array" }
+  write(*,*) 'message: ', &
+             size(Error_Msg ()),Error_Msg()  ! OK of course
+contains
+  function Error_Msg() result(ErrorMsg)
+    character, dimension(:), pointer :: ErrorMsg
+    character, dimension(1), target :: str = '!'
+    ErrorMsg => str
+  end function Error_Msg
+end program ice_test