From 96c8b2534d19a0769152cd33e7fccc66a8785389 Mon Sep 17 00:00:00 2001 From: "Steven G. Kargl" Date: Sun, 18 Mar 2018 17:51:57 +0000 Subject: re PR fortran/77414 (ICE in create_function_arglist, at fortran/trans-decl.c:2410) 2018-03-18 Steven G. Kargl PR fortran/77414 * decl.c (get_proc_name): Check for a subroutine re-defined in the contain portion of a subroutine. Change language of existing error message to better describe the issue. While here fix whitespace issues. 2018-03-18 Steven G. Kargl PR fortran/77414 * gfortran.dg/pr77414.f90: New test. * gfortran.dg/internal_references_1.f90: Adjust error message. From-SVN: r258633 --- gcc/fortran/decl.c | 25 ++++++++++++++++--------- 1 file changed, 16 insertions(+), 9 deletions(-) (limited to 'gcc/fortran/decl.c') diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 9ffaa78..f6649cf 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -1172,14 +1172,12 @@ get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry) if (sym->attr.proc == PROC_ST_FUNCTION) return rc; - if (sym->attr.module_procedure - && sym->attr.if_source == IFSRC_IFBODY) + if (sym->attr.module_procedure && sym->attr.if_source == IFSRC_IFBODY) { /* Create a partially populated interface symbol to carry the characteristics of the procedure and the result. */ sym->tlink = gfc_new_symbol (name, sym->ns); - gfc_add_type (sym->tlink, &(sym->ts), - &gfc_current_locus); + gfc_add_type (sym->tlink, &(sym->ts), &gfc_current_locus); gfc_copy_attr (&sym->tlink->attr, &sym->attr, NULL); if (sym->attr.dimension) sym->tlink->as = gfc_copy_array_spec (sym->as); @@ -1244,7 +1242,16 @@ get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry) && sym->attr.access == 0 && !module_fcn_entry) gfc_error_now ("Procedure %qs at %C has an explicit interface " - "and must not have attributes declared at %L", + "from a previous declaration", name); + } + + if (sym && !sym->gfc_new + && sym->attr.flavor != FL_UNKNOWN + && sym->attr.referenced == 0 && sym->attr.subroutine == 1 + && gfc_state_stack->state == COMP_CONTAINS + && gfc_state_stack->previous->state == COMP_SUBROUTINE) + { + gfc_error_now ("Procedure %qs at %C is already defined at %L", name, &sym->declared_at); } @@ -1269,10 +1276,10 @@ get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry) /* See if the procedure should be a module procedure. */ if (((sym->ns->proc_name != NULL - && sym->ns->proc_name->attr.flavor == FL_MODULE - && sym->attr.proc != PROC_MODULE) - || (module_fcn_entry && sym->attr.proc != PROC_MODULE)) - && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL)) + && sym->ns->proc_name->attr.flavor == FL_MODULE + && sym->attr.proc != PROC_MODULE) + || (module_fcn_entry && sym->attr.proc != PROC_MODULE)) + && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL)) rc = 2; return rc; -- cgit v1.1