Update: Here is an extended version of the patch, which adds a few
additional checks:
* a simple check for the array shape (not complete yet, but fixing at
least comment #0 of PR 35831)
* a check for the string length, as recently implemented for
character results (PR49638)
* furthermore it checks more of the attributes listed in 12.3.2 (I
did not add test cases for those, and I would argue that we don't
really need a test case for every single attribute)
The patch still regtests cleanly. Ok for trunk? Or should I rather
commit the simple version first?
Cheers,
Janus
2011-09-11 Janus Weil <ja...@gcc.gnu.org>
PR fortran/35831
PR fortran/47978
* interface.c (check_dummy_characteristics): New function to check the
characteristics of dummy arguments.
(gfc_compare_interfaces,gfc_check_typebound_override): Call it here.
2011-09-11 Janus Weil <ja...@gcc.gnu.org>
PR fortran/35831
PR fortran/47978
* gfortran.dg/dynamic_dispatch_5.f03: Fix invalid test case.
* gfortran.dg/typebound_proc_6.f03: Changed wording in error message.
* gfortran.dg/proc_decl_26.f90: New.
* gfortran.dg/typebound_override_2.f90: New.
2011/9/9 Janus Weil <ja...@gcc.gnu.org>:
> Hi all,
>
> here is another small patch for an accepts-invalid OOP problem: When
> overriding a type-bound procedure, we need to check that the intents
> of the formal args agree (or more general: their 'characteristics', as
> defined in chapter 12.3.2 of the F08 standard). For now I'm only
> checking type+rank as well as the INTENT and OPTIONAL attributes, but
> I added a FIXME for more comprehensive checking (which could be added
> in a follow-up patch).
>
> On the technical side of things, I'm adding a new function
> 'check_dummy_characteristics', which is called in two places:
> * gfc_compare_interfaces and
> * gfc_check_typebound_override.
>
> A slight subtlety is given by the fact that for the PASS argument, the
> type of the argument does not have to agree when overriding.
>
> The improved checking also caught an invalid test case in the
> testsuite (dynamic_dispatch_5), for another one the error message
> changed slightly (typebound_proc_6).
>
> Regtested on x86_64-unknown-linux-gnu. Ok for trunk?
>
> Cheers,
> Janus
>
>
> 2011-09-09 Janus Weil <ja...@gcc.gnu.org>
>
> PR fortran/47978
> * interface.c (check_dummy_characteristics): New function to check the
> characteristics of dummy arguments.
> (gfc_compare_interfaces,gfc_check_typebound_override): Call it here.
>
>
> 2011-09-09 Janus Weil <ja...@gcc.gnu.org>
>
> PR fortran/47978
> * gfortran.dg/dynamic_dispatch_5.f03: Fix invalid test case.
> * gfortran.dg/typebound_proc_6.f03: Changed wording in error message.
> * gfortran.dg/typebound_override_1.f90: New.
>
Index: gcc/testsuite/gfortran.dg/dynamic_dispatch_5.f03
===================================================================
--- gcc/testsuite/gfortran.dg/dynamic_dispatch_5.f03 (revision 178757)
+++ gcc/testsuite/gfortran.dg/dynamic_dispatch_5.f03 (working copy)
@@ -56,7 +56,7 @@ module s_base_mat_mod
contains
subroutine s_scals(d,a,info)
implicit none
- class(s_base_sparse_mat), intent(in) :: a
+ class(s_base_sparse_mat), intent(inout) :: a
real(spk_), intent(in) :: d
integer, intent(out) :: info
@@ -73,7 +73,7 @@ contains
subroutine s_scal(d,a,info)
implicit none
- class(s_base_sparse_mat), intent(in) :: a
+ class(s_base_sparse_mat), intent(inout) :: a
real(spk_), intent(in) :: d(:)
integer, intent(out) :: info
Index: gcc/testsuite/gfortran.dg/typebound_proc_6.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_proc_6.f03 (revision 178757)
+++ gcc/testsuite/gfortran.dg/typebound_proc_6.f03 (working copy)
@@ -89,7 +89,7 @@ MODULE testmod
! For corresponding dummy arguments.
PROCEDURE, PASS :: corresp1 => proc_tmeint ! Ok.
PROCEDURE, PASS :: corresp2 => proc_tmeintx ! { dg-error "should be named 'a'" }
- PROCEDURE, PASS :: corresp3 => proc_tmereal ! { dg-error "Types mismatch for dummy argument 'a'" }
+ PROCEDURE, PASS :: corresp3 => proc_tmereal ! { dg-error "Type/rank mismatch in argument 'a'" }
END TYPE t
Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c (revision 178757)
+++ gcc/fortran/interface.c (working copy)
@@ -977,6 +977,113 @@ generic_correspondence (gfc_formal_arglist *f1, gf
}
+/* Check if the characteristics of two dummy arguments match,
+ cf. F08:12.3.2. */
+
+static gfc_try
+check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
+ bool type_must_agree, char *errmsg, int err_len)
+{
+ /* Check type and rank. */
+ if (type_must_agree && !compare_type_rank (s2, s1))
+ {
+ if (errmsg != NULL)
+ snprintf (errmsg, err_len, "Type/rank mismatch in argument '%s'",
+ s1->name);
+ return FAILURE;
+ }
+
+ /* Check INTENT. */
+ if (s1->attr.intent != s2->attr.intent)
+ {
+ snprintf (errmsg, err_len, "INTENT mismatch in argument '%s'",
+ s1->name);
+ return FAILURE;
+ }
+
+ /* Check OPTIONAL attribute. */
+ if (s1->attr.optional != s2->attr.optional)
+ {
+ snprintf (errmsg, err_len, "OPTIONAL mismatch in argument '%s'",
+ s1->name);
+ return FAILURE;
+ }
+
+ /* Check ALLOCATABLE attribute. */
+ if (s1->attr.allocatable != s2->attr.allocatable)
+ {
+ snprintf (errmsg, err_len, "ALLOCATABLE mismatch in argument '%s'",
+ s1->name);
+ return FAILURE;
+ }
+
+ /* Check POINTER attribute. */
+ if (s1->attr.pointer != s2->attr.pointer)
+ {
+ snprintf (errmsg, err_len, "POINTER mismatch in argument '%s'",
+ s1->name);
+ return FAILURE;
+ }
+
+ /* Check TARGET attribute. */
+ if (s1->attr.target != s2->attr.target)
+ {
+ snprintf (errmsg, err_len, "TARGET mismatch in argument '%s'",
+ s1->name);
+ return FAILURE;
+ }
+
+ /* FIXME: Do more comprehensive testing of attributes, like e.g.
+ ASYNCHRONOUS, CONTIGUOUS, VALUE, VOLATILE, etc. */
+
+ /* Check string length. */
+ if (s1->ts.type == BT_CHARACTER
+ && s1->ts.u.cl && s1->ts.u.cl->length
+ && s2->ts.u.cl && s2->ts.u.cl->length)
+ {
+ int compval = gfc_dep_compare_expr (s1->ts.u.cl->length,
+ s2->ts.u.cl->length);
+ switch (compval)
+ {
+ case -1:
+ case 1:
+ case -3:
+ snprintf (errmsg, err_len, "Character length mismatch "
+ "in argument '%s'", s1->name);
+ return FAILURE;
+
+ case -2:
+ /* FIXME: Implement a warning for this case.
+ gfc_warning ("Possible character length 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;
+ }
+ }
+
+ /* Check array shape. */
+ if (s1->as && s2->as)
+ {
+ if (s1->as->type != s2->as->type)
+ {
+ snprintf (errmsg, err_len, "Shape mismatch in argument '%s'",
+ s1->name);
+ return FAILURE;
+ }
+ /* FIXME: Check exact shape. */
+ }
+
+ return SUCCESS;
+}
+
+
/* 'Compare' two formal interfaces associated with a pair of symbols.
We return nonzero if there exists an actual argument list that
would be ambiguous between the two interfaces, zero otherwise.
@@ -1059,31 +1166,22 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol
return 0;
}
- /* Check type and rank. */
- if (!compare_type_rank (f2->sym, f1->sym))
+ if (intent_flag)
{
+ /* Check all characteristics. */
+ if (check_dummy_characteristics (f1->sym, f2->sym,
+ true, errmsg, err_len) == FAILURE)
+ return 0;
+ }
+ else if (!compare_type_rank (f2->sym, f1->sym))
+ {
+ /* Only check type and rank. */
if (errmsg != NULL)
snprintf (errmsg, err_len, "Type/rank mismatch in argument '%s'",
f1->sym->name);
return 0;
}
- /* Check INTENT. */
- if (intent_flag && (f1->sym->attr.intent != f2->sym->attr.intent))
- {
- snprintf (errmsg, err_len, "INTENT mismatch in argument '%s'",
- f1->sym->name);
- return 0;
- }
-
- /* Check OPTIONAL. */
- if (intent_flag && (f1->sym->attr.optional != f2->sym->attr.optional))
- {
- snprintf (errmsg, err_len, "OPTIONAL mismatch in argument '%s'",
- f1->sym->name);
- return 0;
- }
-
f1 = f1->next;
f2 = f2->next;
}
@@ -3468,18 +3566,18 @@ gfc_free_formal_arglist (gfc_formal_arglist *p)
}
-/* Check that it is ok for the typebound procedure proc to override the
- procedure old. */
+/* Check that it is ok for the type-bound procedure 'proc' to override the
+ procedure 'old', cf. F08:4.5.7.3. */
gfc_try
gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
{
locus where;
- const gfc_symbol* proc_target;
- const gfc_symbol* old_target;
+ const gfc_symbol *proc_target, *old_target;
unsigned proc_pass_arg, old_pass_arg, argpos;
- gfc_formal_arglist* proc_formal;
- gfc_formal_arglist* old_formal;
+ gfc_formal_arglist *proc_formal, *old_formal;
+ bool check_type;
+ char err[200];
/* This procedure should only be called for non-GENERIC proc. */
gcc_assert (!proc->n.tb->is_generic);
@@ -3637,15 +3735,12 @@ gfc_check_typebound_override (gfc_symtree* proc, g
return FAILURE;
}
- /* Check that the types correspond if neither is the passed-object
- argument. */
- /* FIXME: Do more comprehensive testing here. */
- if (proc_pass_arg != argpos && old_pass_arg != argpos
- && !gfc_compare_types (&proc_formal->sym->ts, &old_formal->sym->ts))
+ check_type = proc_pass_arg != argpos && old_pass_arg != argpos;
+ if (check_dummy_characteristics (proc_formal->sym, old_formal->sym,
+ check_type, err, sizeof(err)) == FAILURE)
{
- gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L "
- "in respect to the overridden procedure",
- proc_formal->sym->name, proc->name, &where);
+ gfc_error (strcat (err, " of '%s' at %L with respect to the "
+ "overridden procedure"), proc->name, &where);
return FAILURE;
}
! { dg-do compile }
!
! PR 35831: [F95] Shape mismatch check missing for dummy procedure argument
!
! Contributed by Tobias Burnus <bur...@gcc.gnu.org>
program test
implicit none
interface
subroutine one(a)
integer a(:)
end subroutine
subroutine two(a)
integer a(2)
end subroutine
end interface
call foo(two) ! { dg-error "Shape mismatch in argument" }
call bar(two) ! { dg-error "Shape mismatch in argument" }
contains
subroutine foo(f1)
procedure(one) :: f1
end subroutine foo
subroutine bar(f2)
interface
subroutine f2(a)
integer a(:)
end subroutine
end interface
end subroutine bar
end program
! { dg-do compile }
module foo_mod
type foo
contains
procedure, pass(f) :: bar => base_bar
end type foo
contains
subroutine base_bar(f,j)
class(foo), intent(inout) :: f
integer, intent(in) :: j
end subroutine base_bar
end module foo_mod
module extfoo_mod
use foo_mod
type, extends(foo) :: extfoo
contains
procedure, pass(f) :: bar => ext_bar ! { dg-error "INTENT mismatch in argument" }
end type extfoo
contains
subroutine ext_bar(f,j)
class(extfoo), intent(inout) :: f
integer, intent(inout) :: j
end subroutine ext_bar
end module extfoo_mod
! { dg-final { cleanup-modules "foo_mod extfoo_mod" } }
