From e3154a0596af0c9ed26c9be292fbd75fe4f40c64 Mon Sep 17 00:00:00 2001 From: domob Date: Tue, 23 Sep 2008 14:26:47 +0000 Subject: [PATCH] 2008-09-23 Daniel Kraft PR fortran/37588 * gfortran.h (gfc_compare_actual_formal): Removed, made private. (gfc_arglist_matches_symbol): New method. * interface.c (compare_actual_formal): Made static. (gfc_procedure_use): Use new name of compare_actual_formal. (gfc_arglist_matches_symbol): New method. (gfc_search_interface): Moved code partially to new gfc_arglist_matches_symbol. * resolve.c (resolve_typebound_generic_call): Resolve actual arglist before checking against formal and use new gfc_arglist_matches_symbol for checking. (resolve_compcall): Set type-spec of generated expression. 2008-09-23 Daniel Kraft PR fortran/37588 * gfortran.dg/typebound_generic_4.f03: New test. * gfortran.dg/typebound_generic_5.f03: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@140594 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 15 ++++++ gcc/fortran/gfortran.h | 3 +- gcc/fortran/interface.c | 46 +++++++++++------- gcc/fortran/resolve.c | 6 ++- gcc/testsuite/ChangeLog | 6 +++ gcc/testsuite/gfortran.dg/typebound_generic_4.f03 | 57 +++++++++++++++++++++++ gcc/testsuite/gfortran.dg/typebound_generic_5.f03 | 55 ++++++++++++++++++++++ 7 files changed, 168 insertions(+), 20 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/typebound_generic_4.f03 create mode 100644 gcc/testsuite/gfortran.dg/typebound_generic_5.f03 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 5d1ad31..1210d39 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,18 @@ +2008-09-23 Daniel Kraft + + PR fortran/37588 + * gfortran.h (gfc_compare_actual_formal): Removed, made private. + (gfc_arglist_matches_symbol): New method. + * interface.c (compare_actual_formal): Made static. + (gfc_procedure_use): Use new name of compare_actual_formal. + (gfc_arglist_matches_symbol): New method. + (gfc_search_interface): Moved code partially to new + gfc_arglist_matches_symbol. + * resolve.c (resolve_typebound_generic_call): Resolve actual arglist + before checking against formal and use new gfc_arglist_matches_symbol + for checking. + (resolve_compcall): Set type-spec of generated expression. + 2008-09-23 Tobias Burnus PR fortran/37580 diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index fa3f865..4e9959e 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2517,8 +2517,7 @@ gfc_try gfc_add_interface (gfc_symbol *); gfc_interface *gfc_current_interface_head (void); void gfc_set_current_interface_head (gfc_interface *); gfc_symtree* gfc_find_sym_in_symtree (gfc_symbol*); -int gfc_compare_actual_formal (gfc_actual_arglist**, gfc_formal_arglist*, - int, int, locus*); +bool gfc_arglist_matches_symbol (gfc_actual_arglist**, gfc_symbol*); /* io.c */ extern gfc_st_label format_asterisk; diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 9df24ff..17f7033 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -1818,9 +1818,9 @@ has_vector_subscript (gfc_expr *e) errors when things don't match instead of just returning the status code. */ -int -gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, - int ranks_must_agree, int is_elemental, locus *where) +static int +compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, + int ranks_must_agree, int is_elemental, locus *where) { gfc_actual_arglist **new_arg, *a, *actual, temp; gfc_formal_arglist *f; @@ -2448,8 +2448,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where) return; } - if (!gfc_compare_actual_formal (ap, sym->formal, 0, - sym->attr.elemental, where)) + if (!compare_actual_formal (ap, sym->formal, 0, sym->attr.elemental, where)) return; check_intents (sym->formal, *ap); @@ -2458,6 +2457,30 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where) } +/* Try if an actual argument list matches the formal list of a symbol, + respecting the symbol's attributes like ELEMENTAL. This is used for + GENERIC resolution. */ + +bool +gfc_arglist_matches_symbol (gfc_actual_arglist** args, gfc_symbol* sym) +{ + bool r; + + gcc_assert (sym->attr.flavor == FL_PROCEDURE); + + r = !sym->attr.elemental; + if (compare_actual_formal (args, sym->formal, r, !r, NULL)) + { + check_intents (sym->formal, *args); + if (gfc_option.warn_aliasing) + check_some_aliasing (sym->formal, *args); + return true; + } + + return false; +} + + /* Given an interface pointer and an actual argument list, search for a formal argument list that matches the actual. If found, returns a pointer to the symbol of the correct interface. Returns NULL if @@ -2467,8 +2490,6 @@ gfc_symbol * gfc_search_interface (gfc_interface *intr, int sub_flag, gfc_actual_arglist **ap) { - int r; - for (; intr; intr = intr->next) { if (sub_flag && intr->sym->attr.function) @@ -2476,15 +2497,8 @@ gfc_search_interface (gfc_interface *intr, int sub_flag, if (!sub_flag && intr->sym->attr.subroutine) continue; - r = !intr->sym->attr.elemental; - - if (gfc_compare_actual_formal (ap, intr->sym->formal, r, !r, NULL)) - { - check_intents (intr->sym->formal, *ap); - if (gfc_option.warn_aliasing) - check_some_aliasing (intr->sym->formal, *ap); - return intr->sym; - } + if (gfc_arglist_matches_symbol (ap, intr->sym)) + return intr->sym; } return NULL; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index a7c62c3..d682e10 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -4510,10 +4510,11 @@ resolve_typebound_generic_call (gfc_expr* e) args = update_arglist_pass (args, po, g->specific->pass_arg_num); } + resolve_actual_arglist (args, target->attr.proc, + is_external_proc (target) && !target->formal); /* Check if this arglist matches the formal. */ - matches = gfc_compare_actual_formal (&args, target->formal, 1, - target->attr.elemental, NULL); + matches = gfc_arglist_matches_symbol (&args, target); /* Clean up and break out of the loop if we've found it. */ gfc_free_actual_arglist (args); @@ -4606,6 +4607,7 @@ resolve_compcall (gfc_expr* e) e->value.function.isym = NULL; e->value.function.esym = NULL; e->symtree = target; + e->ts = target->n.sym->ts; e->expr_type = EXPR_FUNCTION; return gfc_resolve_expr (e); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 715ffef..e3215bd 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2008-09-23 Daniel Kraft + + PR fortran/37588 + * gfortran.dg/typebound_generic_4.f03: New test. + * gfortran.dg/typebound_generic_5.f03: New test. + 2008-09-23 Eric Botcazou * gcc.dg/pragma-init-fini.c: Use dg-warning in lieu of dg-error. diff --git a/gcc/testsuite/gfortran.dg/typebound_generic_4.f03 b/gcc/testsuite/gfortran.dg/typebound_generic_4.f03 new file mode 100644 index 0000000..edd62be --- /dev/null +++ b/gcc/testsuite/gfortran.dg/typebound_generic_4.f03 @@ -0,0 +1,57 @@ +! { dg-do run } + +! FIXME: Remove -w once the TYPE/CLASS issue is resolved +! { dg-options "-w" } + +! PR fortran/37588 +! This test used to not resolve the GENERIC binding. + +! Contributed by Salvatore Filippone + +module bar_mod + + type foo + integer :: i + + contains + procedure, pass(a) :: foo_v => foo_v_inner + procedure, pass(a) :: foo_m => foo_m_inner + generic, public :: foo => foo_v, foo_m + end type foo + + private foo_v_inner, foo_m_inner + +contains + + subroutine foo_v_inner(x,a) + real :: x(:) + type(foo) :: a + + a%i = int(x(1)) + WRITE (*,*) "Vector" + end subroutine foo_v_inner + + subroutine foo_m_inner(x,a) + real :: x(:,:) + type(foo) :: a + + a%i = int(x(1,1)) + WRITE (*,*) "Matrix" + end subroutine foo_m_inner +end module bar_mod + +program foobar + use bar_mod + type(foo) :: dat + real :: x1(10), x2(10,10) + + x1=1 + x2=2 + + call dat%foo(x1) + call dat%foo(x2) + +end program foobar + +! { dg-output "Vector.*Matrix" } +! { dg-final { cleanup-modules "bar_mod" } } diff --git a/gcc/testsuite/gfortran.dg/typebound_generic_5.f03 b/gcc/testsuite/gfortran.dg/typebound_generic_5.f03 new file mode 100644 index 0000000..3fd94b1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/typebound_generic_5.f03 @@ -0,0 +1,55 @@ +! { dg-do run } + +! Check that generic bindings targetting ELEMENTAL procedures work. + +MODULE m + IMPLICIT NONE + + TYPE :: t + CONTAINS + PROCEDURE, NOPASS :: double + PROCEDURE, NOPASS :: double_here + GENERIC :: double_it => double + GENERIC :: double_inplace => double_here + END TYPE t + +CONTAINS + + ELEMENTAL INTEGER FUNCTION double (val) + IMPLICIT NONE + INTEGER, INTENT(IN) :: val + double = 2 * val + END FUNCTION double + + ELEMENTAL SUBROUTINE double_here (val) + IMPLICIT NONE + INTEGER, INTENT(INOUT) :: val + val = 2 * val + END SUBROUTINE double_here + +END MODULE m + +PROGRAM main + USE m + IMPLICIT NONE + + TYPE(t) :: obj + INTEGER :: arr(42), arr2(42), arr3(42), arr4(42) + INTEGER :: i + + arr = (/ (i, i = 1, 42) /) + + arr2 = obj%double (arr) + arr3 = obj%double_it (arr) + + arr4 = arr + CALL obj%double_inplace (arr4) + + IF (ANY (arr2 /= 2 * arr) .OR. & + ANY (arr3 /= 2 * arr) .OR. & + ANY (arr4 /= 2 * arr)) THEN + CALL abort () + END IF +END PROGRAM main + +! { dg-final { cleanup-modules "m" } } -- 2.7.4