From f0ac18b79931a074b5bc88e0b64ea8ef84e40941 Mon Sep 17 00:00:00 2001 From: Daniel Kraft Date: Tue, 23 Sep 2008 16:26:47 +0200 Subject: re PR fortran/37588 (GENERIC type-bound procedure is not resolved) 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. From-SVN: r140594 --- gcc/fortran/interface.c | 46 ++++++++++++++++++++++++++++++---------------- 1 file changed, 30 insertions(+), 16 deletions(-) (limited to 'gcc/fortran/interface.c') 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; -- cgit v1.1