From 9795c59419d1802b7332bdd766750da46741a440 Mon Sep 17 00:00:00 2001 From: Janus Weil Date: Sun, 11 Sep 2011 22:12:24 +0200 Subject: [PATCH] re PR fortran/35831 ([F95] Shape mismatch check missing for dummy procedure argument) 2011-09-11 Janus Weil 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 PR fortran/35831 PR fortran/47978 * gfortran.dg/dynamic_dispatch_5.f03: Fix invalid test case. * gfortran.dg/proc_decl_26.f90: New. * gfortran.dg/typebound_override_2.f90: New. * gfortran.dg/typebound_proc_6.f03: Changed wording in error message. From-SVN: r178767 --- gcc/fortran/ChangeLog | 8 + gcc/fortran/interface.c | 159 ++++++++++++++---- gcc/testsuite/ChangeLog | 9 + .../gfortran.dg/dynamic_dispatch_5.f03 | 4 +- gcc/testsuite/gfortran.dg/proc_decl_26.f90 | 37 ++++ .../gfortran.dg/typebound_override_2.f90 | 32 ++++ .../gfortran.dg/typebound_proc_6.f03 | 2 +- 7 files changed, 216 insertions(+), 35 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/proc_decl_26.f90 create mode 100644 gcc/testsuite/gfortran.dg/typebound_override_2.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index e3ae236b2cb..96af79e04f8 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,11 @@ +2011-09-11 Janus Weil + + 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-08 Mikael Morin * trans-array.c (gfc_trans_constant_array_constructor): Remove diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index c6626972bb7..a9b3d702727 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -977,6 +977,113 @@ generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2) } +/* 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 *s2, const char *name2, 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, gfc_symtree* old) 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 ("Argument mismatch for the overriding procedure " + "'%s' at %L: %s", proc->name, &where, err); return FAILURE; } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 3544a279972..2a5096970bc 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,12 @@ +2011-09-11 Janus Weil + + PR fortran/35831 + PR fortran/47978 + * gfortran.dg/dynamic_dispatch_5.f03: Fix invalid test case. + * gfortran.dg/proc_decl_26.f90: New. + * gfortran.dg/typebound_override_2.f90: New. + * gfortran.dg/typebound_proc_6.f03: Changed wording in error message. + 2011-09-11 Eric Botcazou * gnat.dg/cond_expr2.ad[sb]: New test. diff --git a/gcc/testsuite/gfortran.dg/dynamic_dispatch_5.f03 b/gcc/testsuite/gfortran.dg/dynamic_dispatch_5.f03 index 036c20092d5..9cc16bc1c09 100644 --- a/gcc/testsuite/gfortran.dg/dynamic_dispatch_5.f03 +++ b/gcc/testsuite/gfortran.dg/dynamic_dispatch_5.f03 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/proc_decl_26.f90 b/gcc/testsuite/gfortran.dg/proc_decl_26.f90 new file mode 100644 index 00000000000..be983f8b022 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_decl_26.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } +! +! PR 35831: [F95] Shape mismatch check missing for dummy procedure argument +! +! Contributed by Tobias Burnus + +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 diff --git a/gcc/testsuite/gfortran.dg/typebound_override_2.f90 b/gcc/testsuite/gfortran.dg/typebound_override_2.f90 new file mode 100644 index 00000000000..98146b68141 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/typebound_override_2.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! +! PR 47978: [OOP] Invalid INTENT in overriding TBP not detected +! +! Contributed by Salvatore Filippone + +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" } } diff --git a/gcc/testsuite/gfortran.dg/typebound_proc_6.f03 b/gcc/testsuite/gfortran.dg/typebound_proc_6.f03 index 266cc02314a..36dc9b1ca86 100644 --- a/gcc/testsuite/gfortran.dg/typebound_proc_6.f03 +++ b/gcc/testsuite/gfortran.dg/typebound_proc_6.f03 @@ -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