2007-07-03 Tobias Burnus <burnus@net-b.de>

	PR fortran/30940
	* interface.c (get_sym_storage_size): New function.
	(get_sym_storage_size): New function.
	(compare_actual_formal): Enhance sequence association
	support and improve checking.

2007-07-03  Tobias Burnus  <burnus@net-b.de>

	PR fortran/30940
	* gfortran.dg/argument_checking_1.f90: New.
	* gfortran.dg/argument_checking_2.f90: New.
	* gfortran.dg/argument_checking_3.f90: New.
	* gfortran.dg/argument_checking_4.f90: New.
	* gfortran.dg/argument_checking_5.f90: New.
	* gfortran.fortran-torture/execute/st_function_1.f90: Add dg-warning.
	* gfortran.fortran-torture/execute/st_function.f90: Add dg-warning.



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

11 files changed, 373 insertions, 25 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 1ee186203bf..1bd7a50ac2e 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,11 @@
+2007-07-03  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/30940
+	* interface.c (get_sym_storage_size): New function.
+	(get_sym_storage_size): New function.
+	(compare_actual_formal): Enhance sequence association
+	support and improve checking.
+
 2007-07-03  Janne Blomqvist  <jb@gcc.gnu.org>
 
 	* trans-decl.c (gfc_build_builtin_function_decls): Mark
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 69ab3269d87..558649443a2 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1283,6 +1283,153 @@ compare_parameter_protected (gfc_symbol *formal, gfc_expr *actual)
 }
 
 
+/* Returns the storage size of a symbol (formal argument) or
+   zero if it cannot be determined.  */
+
+static unsigned long
+get_sym_storage_size (gfc_symbol *sym)
+{
+  int i;
+  unsigned long strlen, elements;
+
+  if (sym->ts.type == BT_CHARACTER)
+    {
+      if (sym->ts.cl && sym->ts.cl->length
+          && sym->ts.cl->length->expr_type == EXPR_CONSTANT)
+	strlen = mpz_get_ui (sym->ts.cl->length->value.integer);
+      else
+	return 0;
+    }
+  else
+    strlen = 1; 
+
+  if (symbol_rank (sym) == 0)
+    return strlen;
+
+  elements = 1;
+  if (sym->as->type != AS_EXPLICIT)
+    return 0;
+  for (i = 0; i < sym->as->rank; i++)
+    {
+      if (!sym->as || sym->as->upper[i]->expr_type != EXPR_CONSTANT
+	  || sym->as->lower[i]->expr_type != EXPR_CONSTANT)
+	return 0;
+
+      elements *= mpz_get_ui (sym->as->upper[i]->value.integer)
+		  - mpz_get_ui (sym->as->lower[i]->value.integer) + 1L;
+    }
+
+  return strlen*elements;
+}
+
+
+/* Returns the storage size of an expression (actual argument) or
+   zero if it cannot be determined. For an array element, it returns
+   the remaing size as the element sequence consists of all storage
+   units of the actual argument up to the end of the array.  */
+
+static unsigned long
+get_expr_storage_size (gfc_expr *e)
+{
+  int i;
+  long int strlen, elements;
+  gfc_ref *ref;
+
+  if (e == NULL)
+    return 0;
+  
+  if (e->ts.type == BT_CHARACTER)
+    {
+      if (e->ts.cl && e->ts.cl->length
+          && e->ts.cl->length->expr_type == EXPR_CONSTANT)
+	strlen = mpz_get_si (e->ts.cl->length->value.integer);
+      else if (e->expr_type == EXPR_CONSTANT
+	       && (e->ts.cl == NULL || e->ts.cl->length == NULL))
+	strlen = e->value.character.length;
+      else
+	return 0;
+    }
+  else
+    strlen = 1; /* Length per element.  */
+
+  if (e->rank == 0 && !e->ref)
+    return strlen;
+
+  elements = 1;
+  if (!e->ref)
+    {
+      if (!e->shape)
+	return 0;
+      for (i = 0; i < e->rank; i++)
+	elements *= mpz_get_si (e->shape[i]);
+      return elements*strlen;
+    }
+
+  for (ref = e->ref; ref; ref = ref->next)
+    {
+      if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION
+	  && ref->u.ar.start && ref->u.ar.end && ref->u.ar.stride
+	  && ref->u.ar.as->upper)
+	for (i = 0; i < ref->u.ar.dimen; i++)
+	  {
+	    long int start, end, stride;
+	    stride = 1;
+	    start = 1;
+	    if (ref->u.ar.stride[i])
+	      {
+		if (ref->u.ar.stride[i]->expr_type == EXPR_CONSTANT)
+		  stride = mpz_get_si (ref->u.ar.stride[i]->value.integer);
+		else
+		  return 0;
+	      }
+
+	    if (ref->u.ar.start[i])
+	      {
+		if (ref->u.ar.start[i]->expr_type == EXPR_CONSTANT)
+		  start = mpz_get_si (ref->u.ar.start[i]->value.integer);
+		else
+		  return 0;
+	      }
+
+	    if (ref->u.ar.end[i])
+	      {
+		if (ref->u.ar.end[i]->expr_type == EXPR_CONSTANT)
+		  end = mpz_get_si (ref->u.ar.end[i]->value.integer);
+		else
+		  return 0;
+	      }
+	    else if (ref->u.ar.as->upper[i]
+		     && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
+	      end = mpz_get_si (ref->u.ar.as->upper[i]->value.integer);
+	    else
+	      return 0;
+
+	    elements *= (end - start)/stride + 1L;
+	  }
+      else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_FULL
+	       && ref->u.ar.as->lower && ref->u.ar.as->upper)
+	for (i = 0; i < ref->u.ar.as->rank; i++)
+	  {
+	    if (ref->u.ar.as->lower[i] && ref->u.ar.as->upper[i]
+		&& ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT
+		&& ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
+	      elements *= mpz_get_ui (ref->u.ar.as->upper[i]->value.integer)
+			  - mpz_get_ui (ref->u.ar.as->lower[i]->value.integer)
+			  + 1L;
+	    else
+	      return 0;
+	  }
+      else
+        /* TODO: Determine the number of remaining elements in the element
+           sequence for array element designators.
+           See also get_array_index in data.c.  */
+	return 0;
+    }
+
+  return elements*strlen;
+}
+
+
 /* Given an expression, check whether it is an array section
    which has a vector subscript. If it has, one is returned,
    otherwise zero.  */
@@ -1321,6 +1468,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
   gfc_formal_arglist *f;
   int i, n, na;
   bool rank_check;
+  unsigned long actual_size, formal_size;
 
   actual = *ap;
 
@@ -1404,8 +1552,23 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 		   && (f->sym->as->type == AS_ASSUMED_SHAPE
 		       || f->sym->as->type == AS_DEFERRED);
 
-      if (!compare_parameter (f->sym, a->expr,
-			      ranks_must_agree || rank_check, is_elemental))
+      if (f->sym->ts.type == BT_CHARACTER && a->expr->ts.type == BT_CHARACTER
+	  && a->expr->rank == 0
+	  && f->sym->as && f->sym->as->type != AS_ASSUMED_SHAPE)
+	{
+	  if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0)
+	    {
+	      gfc_error ("Fortran 2003: Scalar CHARACTER actual argument "
+			 "with array dummy argument '%s' at %L",
+			 f->sym->name, &a->expr->where);
+	      return 0;
+	    }
+	  else if ((gfc_option.allow_std & GFC_STD_F2003) == 0)
+	    return 0;
+
+	}
+      else if (!compare_parameter (f->sym, a->expr,
+				   ranks_must_agree || rank_check, is_elemental))
 	{
 	  if (where)
 	    gfc_error ("Type/rank mismatch in argument '%s' at %L",
@@ -1413,34 +1576,42 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 	  return 0;
 	}
 
-       if (a->expr->ts.type == BT_CHARACTER
+      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)
 	 {
-	   if (mpz_cmp (a->expr->ts.cl->length->value.integer,
-			f->sym->ts.cl->length->value.integer) < 0)
-	     {
-		if (where)
-		  gfc_error ("Character length of actual argument shorter "
-			     "than of dummy argument '%s' at %L",
-			     f->sym->name, &a->expr->where);
-		return 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_error ("Character length mismatch between actual argument "
-			     "and pointer or allocatable dummy argument "
-			     "'%s' at %L", f->sym->name, &a->expr->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;
 	     }
 	 }
 
+      actual_size = get_expr_storage_size(a->expr);
+      formal_size = get_sym_storage_size(f->sym);
+      if (actual_size != 0 && actual_size < formal_size)
+	{
+	  if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where)
+	    gfc_warning ("Character length of actual argument shorter "
+			"than of dummy argument '%s' (%d/%d) at %L",
+			f->sym->name, (int) actual_size,
+			(int) formal_size, &a->expr->where);
+          else if (where)
+	    gfc_warning ("Actual argument contains too few "
+			"elements for dummy argument '%s' (%d/%d) at %L",
+			f->sym->name, (int) actual_size,
+			(int) formal_size, &a->expr->where);
+	  return  0;
+	}
+
       /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
 	 provided for a procedure formal argument.  */
       if (a->expr->ts.type != BT_PROCEDURE
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 92a17bcc6fc..934a38b656e 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,14 @@
+2007-07-03  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/30940
+	* gfortran.dg/argument_checking_1.f90: New.
+	* gfortran.dg/argument_checking_2.f90: New.
+	* gfortran.dg/argument_checking_3.f90: New.
+	* gfortran.dg/argument_checking_4.f90: New.
+	* gfortran.dg/argument_checking_5.f90: New.
+	* gfortran.fortran-torture/execute/st_function_1.f90: Add dg-warning.
+	* gfortran.fortran-torture/execute/st_function.f90: Add dg-warning.
+
 2007-07-03  Uros Bizjak  <ubizjak@gmail.com>
 
 	* gcc.dg/pr32176.c: Add -w to default dg-options.
diff --git a/gcc/testsuite/gfortran.dg/argument_checking_1.f90 b/gcc/testsuite/gfortran.dg/argument_checking_1.f90
new file mode 100644
index 00000000000..b42047ae624
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/argument_checking_1.f90
@@ -0,0 +1,35 @@
+! { dg-do run }
+!
+! PR fortran/30940
+program main
+  implicit none
+  character(len=10) :: digit_string = '123456789', str
+  character :: digit_arr(10)
+  call copy(digit_string, digit_arr)
+  call copy(digit_arr,str)
+  if(str /= '123456789') call abort()
+  digit_string = 'qwertasdf'
+  call copy2(digit_string, digit_arr)
+  call copy2(digit_arr,str)
+  if(str /= 'qwertasdf') call abort()
+  digit_string = '1qayxsw23e'
+  call copy3("1qayxsw23e", digit_arr)
+  call copy3(digit_arr,str)
+  if(str /= '1qayxsw23e') call abort()
+contains
+  subroutine copy(in, out)
+    character, dimension(*)  :: in
+    character, dimension(10) :: out
+    out = in(:10)
+  end subroutine copy
+  subroutine copy2(in, out)
+    character, dimension(2,*)  :: in
+    character, dimension(2,5) :: out
+    out(1:2,1:5) = in(1:2,1:5)
+  end subroutine copy2
+  subroutine copy3(in, out)
+    character(len=2), dimension(5)  :: in
+    character(len=2), dimension(5) :: out
+    out = in
+  end subroutine copy3
+end program main
diff --git a/gcc/testsuite/gfortran.dg/argument_checking_2.f90 b/gcc/testsuite/gfortran.dg/argument_checking_2.f90
new file mode 100644
index 00000000000..ba1dd633a47
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/argument_checking_2.f90
@@ -0,0 +1,31 @@
+! { dg-do compile }
+! { dg-options "-std=f95" }
+!
+! PR fortran/30940
+program main
+  implicit none
+  character(len=10) :: digit_string = '123456789', str
+  character :: digit_arr(10)
+  call copy(digit_string, digit_arr)  ! { dg-error "Scalar CHARACTER actual argument with array dummy argument 'in'" }
+  call copy(digit_arr,str)            ! { dg-error "Scalar CHARACTER actual argument with array dummy argument 'out'" }
+  if(str /= '123456789') call abort()
+  digit_string = 'qwertasdf'
+  call copy2(digit_string, digit_arr) ! { dg-error "Scalar CHARACTER actual argument with array dummy argument 'in'" }
+  call copy2(digit_arr,str) ! { dg-error "Scalar CHARACTER actual argument with array dummy argument 'out'" }
+  if(str /= 'qwertasdf') call abort()
+  digit_string = '1qayxsw23e'
+  call copy('1qayxsw23e', digit_arr) ! { dg-error "Scalar CHARACTER actual argument with array dummy argument 'in'" }
+  call copy(digit_arr,str) ! { dg-error "Scalar CHARACTER actual argument with array dummy argument 'out'" }
+  if(str /= '1qayxsw23e') call abort()
+contains
+  subroutine copy(in, out)
+    character, dimension(*)  :: in
+    character, dimension(10) :: out
+    out = in(:10)
+  end subroutine copy
+  subroutine copy2(in, out)
+    character, dimension(2,*)  :: in
+    character, dimension(2,5) :: out
+    out(1:2,1:5) = in(1:2,1:5)
+  end subroutine copy2
+end program main
diff --git a/gcc/testsuite/gfortran.dg/argument_checking_3.f90 b/gcc/testsuite/gfortran.dg/argument_checking_3.f90
new file mode 100644
index 00000000000..e59a039564b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/argument_checking_3.f90
@@ -0,0 +1,36 @@
+! { dg-do compile }
+!
+! PR fortran/30940
+program test
+implicit none
+interface
+  subroutine foo(a)
+     character(len=1),dimension(:) :: a
+  end subroutine foo
+  subroutine bar(a)
+     character(len=1),dimension(:,:) :: a
+  end subroutine bar
+  subroutine foobar(a)
+     character(len=1),dimension(4) :: a
+  end subroutine foobar
+  subroutine arr(a)
+     character(len=1),dimension(1,2,1,2) :: a
+  end subroutine arr
+end interface
+  character(len=2) :: len2
+  character(len=4) :: len4
+  len2 = '12'
+  len4 = '1234'
+
+  call foo(len2) ! { dg-warning "Type/rank mismatch in argument" }
+  call foo("ca") ! { dg-warning "Type/rank mismatch in argument" }
+  call bar("ca") ! { dg-warning "Type/rank mismatch in argument" }
+  call foobar(len2) ! { dg-warning "contains too few elements" }
+  call foobar(len4)
+  call foobar("bar") ! { dg-warning "contains too few elements" }
+  call foobar("bar33")
+  call arr(len2) ! { dg-warning "contains too few elements" }
+  call arr(len4)
+  call arr("bar") ! { dg-warning "contains too few elements" }
+  call arr("bar33")
+end program test
diff --git a/gcc/testsuite/gfortran.dg/argument_checking_4.f90 b/gcc/testsuite/gfortran.dg/argument_checking_4.f90
new file mode 100644
index 00000000000..a2a56e8dd80
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/argument_checking_4.f90
@@ -0,0 +1,21 @@
+! { dg-do compile }
+!
+! PR fortran/30940
+program test
+implicit none
+interface
+  subroutine foobar(a)
+     character(len=1),dimension(4) :: a
+  end subroutine foobar
+  subroutine arr(a)
+     character(len=1),dimension(1,2,1,2) :: a
+  end subroutine arr
+end interface
+
+  call foobar( [ "bar" ]) ! { dg-warning "contains too few elements" }
+  call foobar( ["ba ","r33"])
+  call arr( [ "bar" ]) ! { dg-warning "contains too few elements" }
+  call arr( reshape(["b","a","r","3"], [2,2]))
+  call arr( reshape(["b","a"], [1,2])) ! { dg-warning "contains too few elements" }
+  call arr( reshape(["b","a"], [2,1])) ! { dg-warning "contains too few elements" }
+end program test
diff --git a/gcc/testsuite/gfortran.dg/argument_checking_5.f90 b/gcc/testsuite/gfortran.dg/argument_checking_5.f90
new file mode 100644
index 00000000000..35a80a06554
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/argument_checking_5.f90
@@ -0,0 +1,35 @@
+! { dg-do compile }
+!
+! PR fortran/30940
+program test
+implicit none
+interface
+  subroutine foobar(x)
+     integer,dimension(4) :: x
+  end subroutine foobar
+  subroutine arr(y)
+     integer,dimension(1,2,1,2) :: y
+  end subroutine arr
+end interface
+
+integer a(3), b(5)
+call foobar(a) ! { dg-warning "contains too few elements" }
+call foobar(b)
+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(reshape(a(1:3),[2,1])) ! { dg-warning "contains too few elements" }
+call foobar(reshape(b(2:5),[2,2]))
+
+call arr(a) ! { dg-warning "contains too few elements" }
+call arr(b)
+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(reshape(a(1:3),[2,1])) ! { dg-warning "contains too few elements" }
+call arr(reshape(b(2:5),[2,2]))
+end program test
diff --git a/gcc/testsuite/gfortran.dg/char_length_3.f90 b/gcc/testsuite/gfortran.dg/char_length_3.f90
index cee55f65f21..97f7fb4c076 100644
--- a/gcc/testsuite/gfortran.dg/char_length_3.f90
+++ b/gcc/testsuite/gfortran.dg/char_length_3.f90
@@ -14,25 +14,25 @@
            character(len=10), allocatable :: alloc1(:)
            character(len=20), allocatable :: alloc2(:)
            character(len=30), allocatable :: alloc3(:)
-           call foo(v) ! { dg-error "actual argument shorter than of dummy" }
-           call foo(x) ! { dg-error "actual argument shorter than of dummy" }
+           call foo(v) ! { dg-warning "actual argument shorter than of dummy" }
+           call foo(x) ! { dg-warning "actual argument shorter than of dummy" }
            call foo(y)
            call foo(z)
            ptr1 => x
-           call foo(ptr1) ! { dg-error "actual argument shorter than of dummy" }
-           call bar(ptr1) ! { dg-error "actual argument shorter than of dummy" }
+           call foo(ptr1) ! { dg-warning "actual argument shorter than of dummy" }
+           call bar(ptr1) ! { dg-warning "Character length mismatch" }
            ptr2 => y
            call foo(ptr2)
            call bar(ptr2)
            ptr3 => z
            call foo(ptr3)
-           call bar(ptr3) ! { dg-error "Character length mismatch" }
+           call bar(ptr3) ! { dg-warning "Character length mismatch" }
            allocate(alloc1(1))
            allocate(alloc2(1))
            allocate(alloc3(1))
-           call arr(alloc1) ! { dg-error "actual argument shorter than of dummy" }
+           call arr(alloc1) ! { dg-warning "Character length mismatch" }
            call arr(alloc2)
-           call arr(alloc3) ! { dg-error "Character length mismatch" }
+           call arr(alloc3) ! { dg-warning "Character length mismatch" }
         contains
         subroutine foo(y)
            character(len=20) :: y
diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/st_function.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/st_function.f90
index 8bde9b2f740..e8788025ad8 100644
--- a/gcc/testsuite/gfortran.fortran-torture/execute/st_function.f90
+++ b/gcc/testsuite/gfortran.fortran-torture/execute/st_function.f90
@@ -33,7 +33,7 @@ contains
       st5 (s1, s2) = s1 // s2
 
       if (st4 (1, 4) .ne. "0123" ) call abort
-      if (st5 ("01", "02") .ne. "01  02    ") call abort
+      if (st5 ("01", "02") .ne. "01  02    ") call abort ! { dg-warning "Character length of actual argument shorter" }
    end subroutine
 
    subroutine with_derived_type_dummy
diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/st_function_1.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/st_function_1.f90
index 0387a5f71c7..b851a942e3d 100644
--- a/gcc/testsuite/gfortran.fortran-torture/execute/st_function_1.f90
+++ b/gcc/testsuite/gfortran.fortran-torture/execute/st_function_1.f90
@@ -8,7 +8,7 @@ program st_function_1
   bar(p) = p // "World"
   
   ! Expression longer than function, actual arg shorter than dummy.
-  call check (foo("Hello"), "Hello Wo")
+  call check (foo("Hello"), "Hello Wo") ! { dg-warning "Character length of actual argument shorter" }
 
   ! Expression shorter than function, actual arg longer than dummy.
   ! Result shorter than type