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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index c6bea2a28f7fcf798bfaf33bf083207d36a3abc2..23053c41ae433f43ea6d6b18c25c49518de285f1 100644 (file)
--- 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 aa075a9040158425ba76b4173d3cc619b0ae45f2..43b911376f5fbe0d81324c30d6da54faa19378c4 100644 (file)
--- 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 3d1372fe443a33766070c34e42d3ddf3364775ca..b6b02a278f4a9c5c6698f93789787485e52c1abe 100644 (file)
--- 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 (file)
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" } }