From 97f26732675a4a388b79d927876443c92a55c8c7 Mon Sep 17 00:00:00 2001 From: Janus Weil Date: Tue, 4 Oct 2011 20:37:13 +0200 Subject: [PATCH] re PR fortran/35831 ([F95] Shape mismatch check missing for dummy procedure argument) 2011-10-04 Janus Weil PR fortran/35831 * interface.c (check_dummy_characteristics): Check the array shape. 2011-10-04 Janus Weil PR fortran/35831 * gfortran.dg/dummy_procedure_6.f90: New. From-SVN: r179520 --- gcc/fortran/ChangeLog | 5 ++ gcc/fortran/interface.c | 43 ++++++++++- gcc/testsuite/ChangeLog | 5 ++ .../gfortran.dg/dummy_procedure_6.f90 | 71 +++++++++++++++++++ 4 files changed, 123 insertions(+), 1 deletion(-) create mode 100644 gcc/testsuite/gfortran.dg/dummy_procedure_6.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index c6bea2a28f7..23053c41ae4 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,8 @@ +2011-10-04 Janus Weil + + PR fortran/35831 + * interface.c (check_dummy_characteristics): Check the array shape. + 2011-10-01 Janus Weil PR fortran/50585 diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index aa075a90401..43b911376f5 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 3d1372fe443..b6b02a278f4 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2011-10-04 Janus Weil + + PR fortran/35831 + * gfortran.dg/dummy_procedure_6.f90: New. + 2011-10-04 Jakub Jelinek 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 00000000000..fa9ebfe3546 --- /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 + +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" } } -- 2.30.2