2010-06-28 Paul Thomas <pault@gcc.gnu.org>

	PR fortran/40158
	* interface.c (argument_rank_mismatch): New function.
	(compare_parameter): Call new function instead of generating
	the error directly.

2010-06-28  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/40158
	* gfortran.dg/actual_rank_check_1.f90: New test.

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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 6fbac64..60d1e31 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,10 @@
+2010-06-28  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/40158
+       * interface.c (argument_rank_mismatch): New function.
+       (compare_parameter): Call new function instead of generating
+       the error directly.
+
 2010-06-28  Nathan Froyd  <froydnj@codesourcery.com>
 
        * trans-openmp.c (dovar_init): Define.  Define VECs containing it.

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index ee164fc..587b09c 100644 (file)
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1376,6 +1376,30 @@ compare_pointer (gfc_symbol *formal, gfc_expr *actual)
 }
 
 
+/* Emit clear error messages for rank mismatch.  */
+
+static void
+argument_rank_mismatch (const char *name, locus *where,
+                       int rank1, int rank2)
+{
+  if (rank1 == 0)
+    {
+      gfc_error ("Rank mismatch in argument '%s' at %L "
+                "(scalar and rank-%d)", name, where, rank2);
+    }
+  else if (rank2 == 0)
+    {
+      gfc_error ("Rank mismatch in argument '%s' at %L "
+                "(rank-%d and scalar)", name, where, rank1);
+    }
+  else
+    {    
+      gfc_error ("Rank mismatch in argument '%s' at %L "
+                "(rank-%d and rank-%d)", name, where, rank1, rank2);
+    }
+}
+
+
 /* Given a symbol of a formal argument list and an expression, see if
    the two are compatible as arguments.  Returns nonzero if
    compatible, zero if not compatible.  */
@@ -1559,9 +1583,8 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
          && gfc_is_coindexed (actual)))
     {
       if (where)
-       gfc_error ("Rank mismatch in argument '%s' at %L (%d and %d)",
-                  formal->name, &actual->where, symbol_rank (formal),
-                  actual->rank);
+       argument_rank_mismatch (formal->name, &actual->where,
+                               symbol_rank (formal), actual->rank);
       return 0;
     }
   else if (actual->rank != 0 && (is_elemental || formal->attr.dimension))
@@ -1600,9 +1623,8 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
   else if (ref == NULL && actual->expr_type != EXPR_NULL)
     {
       if (where)
-       gfc_error ("Rank mismatch in argument '%s' at %L (%d and %d)",
-                  formal->name, &actual->where, symbol_rank (formal),
-                  actual->rank);
+       argument_rank_mismatch (formal->name, &actual->where,
+                               symbol_rank (formal), actual->rank);
       return 0;
     }
 

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index ffec3e5..e17bb03 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2010-06-28  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/40158
+       * gfortran.dg/actual_rank_check_1.f90: New test.
+
 2010-06-28  Martin Jambor  <mjambor@suse.cz>
 
        * testsuite/gcc.dg/ipa/ipa-sra-6.c: New test.

diff --git a/gcc/testsuite/gfortran.dg/actual_rank_check_1.f90 b/gcc/testsuite/gfortran.dg/actual_rank_check_1.f90
new file mode 100644 (file)
index 0000000..7167de4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/actual_rank_check_1.f90
@@ -0,0 +1,23 @@
+! { dg-do compile }
+! Test the fix for PR40158, where the errro message was not clear about scalars.
+!
+! Contributed by Tobias Burnus  <burnus@gcc.gnu.org>
+!
+  implicit none
+  integer :: i(4,5),j
+  i = 0
+  call sub1(i)
+  call sub1(j)  ! { dg-error "rank-1 and scalar" }
+  call sub2(i)  ! { dg-error "scalar and rank-2" }
+  call sub2(j)
+  print '(5i0)', i
+contains
+  subroutine sub1(i1)
+    integer :: i1(*)
+    i1(1) = 2
+  end subroutine sub1
+  subroutine sub2(i2)
+    integer :: i2
+    i2 = 2
+  end subroutine sub2
+end