re PR fortran/35831 ([F95] Shape mismatch check missing for dummy procedure argument)

2011-10-04  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/35831
	* interface.c (check_dummy_characteristics): Check the array shape.


2011-10-04  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/35831
	* gfortran.dg/dummy_procedure_6.f90: New.

From-SVN: r179520

4 files changed, 123 insertions, 1 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index c6bea2a..23053c4 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,8 @@
+2011-10-04  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/35831
+	* interface.c (check_dummy_characteristics): Check the array shape.
+
 2011-10-01  Janus Weil  <janus@gcc.gnu.org>
 
 	PR fortran/50585
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index aa075a9..43b9113 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -69,6 +69,7 @@ along with GCC; see the file COPYING3.  If not see
 #include "system.h"
 #include "gfortran.h"
 #include "match.h"
+#include "arith.h"
 
 /* The current_interface structure holds information about the
    interface currently being parsed.  This structure is saved and
@@ -1071,13 +1072,51 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
   /* Check array shape.  */
   if (s1->as && s2->as)
     {
+      int i, compval;
+      gfc_expr *shape1, *shape2;
+
       if (s1->as->type != s2->as->type)
 	{
 	  snprintf (errmsg, err_len, "Shape mismatch in argument '%s'",
 		    s1->name);
 	  return FAILURE;
 	}
-      /* FIXME: Check exact shape.  */
+
+      if (s1->as->type == AS_EXPLICIT)
+	for (i = 0; i < s1->as->rank + s1->as->corank; i++)
+	  {
+	    shape1 = gfc_subtract (gfc_copy_expr (s1->as->upper[i]),
+				  gfc_copy_expr (s1->as->lower[i]));
+	    shape2 = gfc_subtract (gfc_copy_expr (s2->as->upper[i]),
+				  gfc_copy_expr (s2->as->lower[i]));
+	    compval = gfc_dep_compare_expr (shape1, shape2);
+	    gfc_free_expr (shape1);
+	    gfc_free_expr (shape2);
+	    switch (compval)
+	    {
+	      case -1:
+	      case  1:
+	      case -3:
+		snprintf (errmsg, err_len, "Shape mismatch in dimension %i of "
+			  "argument '%s'", i, s1->name);
+		return FAILURE;
+
+	      case -2:
+		/* FIXME: Implement a warning for this case.
+		gfc_warning ("Possible shape mismatch in argument '%s'",
+			    s1->name);*/
+		break;
+
+	      case 0:
+		break;
+
+	      default:
+		gfc_internal_error ("check_dummy_characteristics: Unexpected "
+				    "result %i of gfc_dep_compare_expr",
+				    compval);
+		break;
+	    }
+	  }
     }
     
   return SUCCESS;
@@ -1131,6 +1170,8 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
 			  "of '%s'", name2);
 	      return 0;
 	    }
+
+	  /* FIXME: Check array bounds and string length of result.  */
 	}
 
       if (s1->attr.pure && !s2->attr.pure)
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 3d1372f..b6b02a2 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2011-10-04  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/35831
+	* gfortran.dg/dummy_procedure_6.f90: New.
+
 2011-10-04  Jakub Jelinek  <jakub@redhat.com>
 
 	PR tree-optimization/50604
diff --git a/gcc/testsuite/gfortran.dg/dummy_procedure_6.f90 b/gcc/testsuite/gfortran.dg/dummy_procedure_6.f90
new file mode 100644
index 0000000..fa9ebfe
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/dummy_procedure_6.f90
@@ -0,0 +1,71 @@
+! { dg-do compile }
+!
+! PR 35381: [F95] Shape mismatch check missing for dummy procedure argument
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+module m
+
+  implicit none
+
+contains
+
+  ! constant array bounds
+
+  subroutine s1(a)
+    integer :: a(1:2)
+  end subroutine
+
+  subroutine s2(a)
+    integer :: a(2:3)
+  end subroutine
+
+  subroutine s3(a)
+    integer :: a(2:4)
+  end subroutine
+
+  ! non-constant array bounds
+
+  subroutine t1(a,b)
+    integer :: b
+    integer :: a(1:b,1:b)
+  end subroutine
+
+  subroutine t2(a,b)
+    integer :: b
+    integer :: a(1:b,2:b+1)
+  end subroutine
+
+  subroutine t3(a,b)
+    integer :: b
+    integer :: a(1:b,1:b+1)
+  end subroutine
+
+end module
+
+
+program test
+  use m
+  implicit none
+
+  call foo(s1)  ! legal
+  call foo(s2)  ! legal
+  call foo(s3)  ! { dg-error "Shape mismatch in dimension" }
+
+  call bar(t1)  ! legal
+  call bar(t2)  ! legal
+  call bar(t3)  ! { dg-error "Shape mismatch in dimension" }
+
+contains
+
+  subroutine foo(f)
+    procedure(s1) :: f
+  end subroutine
+
+  subroutine bar(f)
+    procedure(t1) :: f
+  end subroutine
+
+end program
+
+! { dg-final { cleanup-modules "m" } }