From: burnus Date: Fri, 23 Jul 2010 20:07:30 +0000 (+0000) Subject: 2010-07-23 Tobias Burnus X-Git-Url: http://git.sourceforge.jp/view?p=pf3gnuchains%2Fgcc-fork.git;a=commitdiff_plain;h=99e32e8318db8d542eea132c705328930f9dc592 2010-07-23 Tobias Burnus PR fortran/45030 * resolve.c (resolve_global_procedure): Properly handle ENTRY. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@162486 138bc75d-0d04-0410-961f-82ee72b054a4 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index baba9e569e9..0fac55c0002 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,8 @@ +2010-07-23 Tobias Burnus + + PR fortran/45030 + * resolve.c (resolve_global_procedure): Properly handle ENTRY. + 2010-07-23 Jakub Jelinek * trans-types.c (gfc_get_array_descriptor_base, diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 2434be192d7..a938ab36025 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -1824,6 +1824,8 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, && not_in_recursive (sym, gsym->ns) && not_entry_self_reference (sym, gsym->ns)) { + gfc_symbol *def_sym; + /* Resolve the gsymbol namespace if needed. */ if (!gsym->ns->resolved) { @@ -1858,12 +1860,24 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, } } + def_sym = gsym->ns->proc_name; + if (def_sym->attr.entry_master) + { + gfc_entry_list *entry; + for (entry = gsym->ns->entries; entry; entry = entry->next) + if (strcmp (entry->sym->name, sym->name) == 0) + { + def_sym = entry->sym; + break; + } + } + /* Differences in constant character lengths. */ if (sym->attr.function && sym->ts.type == BT_CHARACTER) { long int l1 = 0, l2 = 0; gfc_charlen *cl1 = sym->ts.u.cl; - gfc_charlen *cl2 = gsym->ns->proc_name->ts.u.cl; + gfc_charlen *cl2 = def_sym->ts.u.cl; if (cl1 != NULL && cl1->length != NULL @@ -1883,14 +1897,14 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, /* Type mismatch of function return type and expected type. */ if (sym->attr.function - && !gfc_compare_types (&sym->ts, &gsym->ns->proc_name->ts)) + && !gfc_compare_types (&sym->ts, &def_sym->ts)) gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)", sym->name, &sym->declared_at, gfc_typename (&sym->ts), - gfc_typename (&gsym->ns->proc_name->ts)); + gfc_typename (&def_sym->ts)); - if (gsym->ns->proc_name->formal) + if (def_sym->formal) { - gfc_formal_arglist *arg = gsym->ns->proc_name->formal; + gfc_formal_arglist *arg = def_sym->formal; for ( ; arg; arg = arg->next) if (!arg->sym) continue; @@ -1945,26 +1959,25 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, } } - if (gsym->ns->proc_name->attr.function) + if (def_sym->attr.function) { /* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */ - if (gsym->ns->proc_name->as - && gsym->ns->proc_name->as->rank - && (!sym->as || sym->as->rank != gsym->ns->proc_name->as->rank)) + if (def_sym->as && def_sym->as->rank + && (!sym->as || sym->as->rank != def_sym->as->rank)) gfc_error ("The reference to function '%s' at %L either needs an " "explicit INTERFACE or the rank is incorrect", sym->name, where); /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */ - if (gsym->ns->proc_name->result->attr.pointer - || gsym->ns->proc_name->result->attr.allocatable) + if (def_sym->result->attr.pointer + || def_sym->result->attr.allocatable) gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE " "result must have an explicit interface", sym->name, where); /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */ if (sym->ts.type == BT_CHARACTER - && gsym->ns->proc_name->ts.u.cl->length != NULL) + && def_sym->ts.u.cl->length != NULL) { gfc_charlen *cl = sym->ts.u.cl; @@ -1979,14 +1992,14 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, } /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */ - if (gsym->ns->proc_name->attr.elemental) + if (def_sym->attr.elemental) { gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit " "interface", sym->name, &sym->declared_at); } /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */ - if (gsym->ns->proc_name->attr.is_bind_c) + if (def_sym->attr.is_bind_c) { gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have " "an explicit interface", sym->name, &sym->declared_at); @@ -1997,7 +2010,7 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, && !(gfc_option.warn_std & GFC_STD_GNU))) gfc_errors_to_warnings (1); - gfc_procedure_use (gsym->ns->proc_name, actual, where); + gfc_procedure_use (def_sym, actual, where); gfc_errors_to_warnings (0); }