re PR fortran/32616 ("Too short actual argument" for array element storage sequence)

2008-01-18  Tobias Burnus  <burnus@net-b.de>

        PR fortran/32616
        * interface.c (get_expr_storage_size): Return storage size
        for array element designators.
        (compare_actual_formal): Reject unequal string sizes for
        assumed-shape dummy arguments. And fix error message for
        array-sections with vector subscripts.

2008-01-18  Tobias Burnus  <burnus@net-b.de>

        PR fortran/32616
        * gfortran.dg/argument_checking_15.f90: New.
        * gfortran.dg/argument_checking_5.f90: Change TODO into
        dg-warning.

From-SVN: r131643

gcc/fortran/ChangeLog

+2008-01-18  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/32616
+	* interface.c (get_expr_storage_size): Return storage size
+	for array element designators.
+	(compare_actual_formal): Reject unequal string sizes for
+	assumed-shape dummy arguments. And fix error message for
+	array-sections with vector subscripts.
+
 2008-01-17  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
 	PR fortran/34556

gcc/fortran/interface.c

@@ -1639,6 +1639,7 @@ get_expr_storage_size (gfc_expr *e)
   int i;
   long int strlen, elements;
   long int substrlen = 0;
+  bool is_str_storage = false;
   gfc_ref *ref;
 
   if (e == NULL)
@@ -1676,10 +1677,17 @@ get_expr_storage_size (gfc_expr *e)
       if (ref->type == REF_SUBSTRING && ref->u.ss.start
 	  && ref->u.ss.start->expr_type == EXPR_CONSTANT)
 	{
-	  int len = strlen;
-	  if (ref->u.ss.end && ref->u.ss.end->expr_type == EXPR_CONSTANT)
-	    len = mpz_get_ui (ref->u.ss.end->value.integer);
-	  substrlen = len - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
+	  if (is_str_storage)
+	    {
+	      /* The string length is the substring length.
+		 Set now to full string length.  */
+	      if (ref->u.ss.length == NULL
+		  || ref->u.ss.length->length->expr_type != EXPR_CONSTANT)
+		return 0;
+
+	      strlen = mpz_get_ui (ref->u.ss.length->length->value.integer);
+	    }
+	  substrlen = strlen - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
 	  continue;
 	}
 
@@ -1741,21 +1749,46 @@ get_expr_storage_size (gfc_expr *e)
 	      return 0;
 	  }
       else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
-	       && e->expr_type == EXPR_VARIABLE
-	       && (e->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
-                  || e->symtree->n.sym->attr.pointer))
-	elements = 1;
+	       && e->expr_type == EXPR_VARIABLE)
+	{
+	  if (e->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
+	      || e->symtree->n.sym->attr.pointer)
+	    {
+	      elements = 1;
+	      continue;
+	    }
+
+	  /* Determine the number of remaining elements in the element
+	     sequence for array element designators.  */
+	  is_str_storage = true;
+	  for (i = ref->u.ar.dimen - 1; i >= 0; i--)
+	    {
+	      if (ref->u.ar.start[i] == NULL
+		  || ref->u.ar.start[i]->expr_type != EXPR_CONSTANT
+		  || ref->u.ar.as->upper[i] == NULL
+		  || ref->u.ar.as->lower[i] == NULL
+		  || ref->u.ar.as->upper[i]->expr_type != EXPR_CONSTANT
+		  || ref->u.ar.as->lower[i]->expr_type != EXPR_CONSTANT)
+		return 0;
+
+	      elements
+		   = elements
+		     * (mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
+			- mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
+			+ 1L)
+		     - (mpz_get_si (ref->u.ar.start[i]->value.integer)
+			- mpz_get_si (ref->u.ar.as->lower[i]->value.integer));
+	    }
+        }
       else
-        /* TODO: Determine the number of remaining elements in the element
-           sequence for array element designators. See PR 32616.
-           See also get_array_index in data.c.  */
 	return 0;
     }
 
   if (substrlen)
-    return elements*substrlen;
-
-  return elements*strlen;
+    return (is_str_storage) ? substrlen + (elements-1)*strlen
+			    : elements*strlen;
+  else
+    return elements*strlen;
 }
 
 
@@ -1880,23 +1913,34 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 			      is_elemental, where))
 	return 0;
 
+      /* Special case for character arguments.  For allocatable, pointer
+	 and assumed-shape dummies, the string length needs to match
+	 exactly.  */
       if (a->expr->ts.type == BT_CHARACTER
 	   && a->expr->ts.cl && a->expr->ts.cl->length
 	   && a->expr->ts.cl->length->expr_type == EXPR_CONSTANT
 	   && f->sym->ts.cl && f->sym->ts.cl && f->sym->ts.cl->length
-	   && f->sym->ts.cl->length->expr_type == EXPR_CONSTANT)
+	   && f->sym->ts.cl->length->expr_type == EXPR_CONSTANT
+	   && (f->sym->attr.pointer || f->sym->attr.allocatable
+	       || (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
+	   && (mpz_cmp (a->expr->ts.cl->length->value.integer,
+			f->sym->ts.cl->length->value.integer) != 0))
 	 {
-	   if ((f->sym->attr.pointer || f->sym->attr.allocatable)
-	       && (mpz_cmp (a->expr->ts.cl->length->value.integer,
-			   f->sym->ts.cl->length->value.integer) != 0))
-	     {
-		if (where)
-		  gfc_warning ("Character length mismatch between actual "
-			       "argument and pointer or allocatable dummy "
-			       "argument '%s' at %L",
-			       f->sym->name, &a->expr->where);
-		return 0;
-	     }
+	   if (where && (f->sym->attr.pointer || f->sym->attr.allocatable))
+	     gfc_warning ("Character length mismatch (%ld/%ld) between actual "
+			  "argument and pointer or allocatable dummy argument "
+			  "'%s' at %L",
+			  mpz_get_si (a->expr->ts.cl->length->value.integer),
+			  mpz_get_si (f->sym->ts.cl->length->value.integer),
+			  f->sym->name, &a->expr->where);
+	   else if (where)
+	     gfc_warning ("Character length mismatch (%ld/%ld) between actual "
+			  "argument and assumed-shape dummy argument '%s' "
+			  "at %L",
+			  mpz_get_si (a->expr->ts.cl->length->value.integer),
+			  mpz_get_si (f->sym->ts.cl->length->value.integer),
+			  f->sym->name, &a->expr->where);
+	   return 0;
 	 }
 
       actual_size = get_expr_storage_size (a->expr);
@@ -2001,7 +2045,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 	{
 	  if (where)
 	    gfc_error ("Array-section actual argument with vector subscripts "
-		       "at %L is incompatible with INTENT(IN), INTENT(INOUT) "
+		       "at %L is incompatible with INTENT(OUT), INTENT(INOUT) "
 		       "or VOLATILE attribute of the dummy argument '%s'",
 		       &a->expr->where, f->sym->name);
 	  return 0;

gcc/testsuite/ChangeLog

 2008-01-18  Tobias Burnus  <burnus@net-b.de>
 
+	PR fortran/32616
+	* gfortran.dg/argument_checking_15.f90: New.
+	* gfortran.dg/argument_checking_5.f90: Change TODO into
+	dg-warning.
+
+2008-01-18  Tobias Burnus  <burnus@net-b.de>
+
 	* gfortran.dg/enum_4.f90: Replace dg-excess-errors by dg-error.
 	* gfortran.dg/enum_5.f90: Ditto.
 	* gfortran.dg/enum_6.f90: Ditto.

gcc/testsuite/gfortran.dg/argument_checking_15.f90

+! { dg-do compile }
+!
+! PR fortran/32616
+!
+! Check for to few elements of the actual argument
+! and reject mismatching string lengths for assumed-shape dummies
+!
+implicit none
+external test
+integer :: i(10)
+integer :: j(2,2)
+character(len=4) :: str(2)
+character(len=4) :: str2(2,2)
+
+call test()
+
+call foo(i(8)) ! { dg-warning "too few elements for dummy argument 'a' .3/4." }
+call foo(j(1,1))
+call foo(j(2,1)) ! { dg-warning "too few elements for dummy argument 'a' .3/4." }
+call foo(j(1,2)) ! { dg-warning "too few elements for dummy argument 'a' .2/4." }
+
+str = 'FORT'
+str2 = 'fort'
+call bar(str(:)(1:2)) ! { dg-warning "too few elements for dummy argument 'c' .4/6." }
+call bar(str(1:2)(1:1)) ! { dg-warning "too few elements for dummy argument 'c' .2/6." }
+call bar(str(2)) ! { dg-warning "too few elements for dummy argument 'c' .4/6." }
+call bar(str(1)(2:1)) ! OK
+call bar(str2(2,1)(4:1)) ! OK
+call bar(str2(1,2)(3:4)) ! OK
+call bar(str2(1,2)(4:4)) ! { dg-warning "too few elements for dummy argument 'c' .5/6." }
+contains
+  subroutine foo(a)
+    integer :: a(4)
+  end subroutine foo
+  subroutine bar(c)
+    character(len=2) :: c(3)
+!    print '(3a)', ':',c(1),':'
+!    print '(3a)', ':',c(2),':'
+!    print '(3a)', ':',c(3),':'
+  end subroutine bar
+end
+
+
+subroutine test()
+implicit none
+character(len=5), pointer :: c
+character(len=5) :: str(5)
+call foo(c) ! { dg-error "Character length mismatch" }
+call bar(str) ! { dg-error "Character length mismatch" }
+contains
+  subroutine foo(a)
+    character(len=3), pointer :: a
+  end subroutine
+  subroutine bar(a)
+    character(len=3) :: a(:)
+  end subroutine bar
+end subroutine test

gcc/testsuite/gfortran.dg/argument_checking_5.f90

@@ -19,7 +19,7 @@ call foobar(b(1:3)) ! { dg-warning "contains too few elements" }
 call foobar(b(1:5))
 call foobar(b(1:5:2)) ! { dg-warning "contains too few elements" }
 call foobar(b(2))
-call foobar(b(3)) ! TODO: contains too few elements
+call foobar(b(3)) ! { dg-warning "Actual argument contains too few elements" }
 call foobar(reshape(a(1:3),[2,1])) ! { dg-warning "contains too few elements" }
 call foobar(reshape(b(2:5),[2,2]))
 
@@ -29,7 +29,7 @@ call arr(b(1:3)) ! { dg-warning "contains too few elements" }
 call arr(b(1:5))
 call arr(b(1:5:2)) ! { dg-warning "contains too few elements" }
 call arr(b(2))
-call arr(b(3)) ! TODO: contains too few elements
+call arr(b(3)) ! { dg-warning "contains too few elements" }
 call arr(reshape(a(1:3),[2,1])) ! { dg-warning "contains too few elements" }
 call arr(reshape(b(2:5),[2,2]))
 end program test