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 178722)
+++ 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 178722)
+++ 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 178722)
+++ gcc/fortran/interface.c (working copy)
@@ -977,6 +977,45 @@ 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. */
+ if (s1->attr.optional != s2->attr.optional)
+ {
+ snprintf (errmsg, err_len, "OPTIONAL mismatch in argument '%s'",
+ s1->name);
+ return FAILURE;
+ }
+
+ /* FIXME: Do more comprehensive testing of dummy characteristics,
+ e.g. array shape, string length and attributes like
+ ALLOCATABLE, POINTER, TARGET, etc. */
+
+ 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 +1098,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 +3498,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 +3667,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 }
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" } }
