Hi all,
here is a patch for a rather long-standing PR. It continues my ongoing
campaign of improving the checks for "procedure characteristics" (cf.
F08 chapter 12.3), which are relevant for dummy procedures, procedure
pointer assignments, overriding of type-bound procedures, etc.
This particular patch checks for the correct shape of array arguments,
in a manner similar to the recently added check for the string length
(PR 49638), namely via 'gfc_dep_compare_expr'.
The hardest thing about this PR was to find out what exactly the
standard requires (cf. c.l.f. thread linked in comment #12): Only the
shape of the argument has to match (i.e. upper minus lower bound), not
the bounds themselves (no matter if the bounds are constant or not).
I also added a FIXME, in order to remind myself of adding the same
check for function results soon.
The patch was regtested on x86_64-unknown-linux-gnu. Ok for trunk?
Cheers,
Janus
2011-10-03 Janus Weil <[email protected]>
PR fortran/35831
* interface.c (check_dummy_characteristics): Check the array shape.
2011-10-03 Janus Weil <[email protected]>
PR fortran/35831
* gfortran.dg/dummy_procedure_6.f90: New.
Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c (revision 179468)
+++ gcc/fortran/interface.c (working copy)
@@ -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_s
/* 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
"of '%s'", name2);
return 0;
}
+
+ /* FIXME: Check array bounds and string length of result. */
}
if (s1->attr.pure && !s2->attr.pure)
! { dg-do compile }
!
! PR 35381: [F95] Shape mismatch check missing for dummy procedure argument
!
! Contributed by Janus Weil <[email protected]>
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" } }
