From 76e207a91aed824957bb6829bade8ba71aba6977 Mon Sep 17 00:00:00 2001 From: pault Date: Sat, 12 Mar 2016 13:59:10 +0000 Subject: [PATCH] 2016-03-12 Paul Thomas PR fortran/70031 * decl.c (gfc_match_prefix): Treat the 'module' prefix in the same way as the others, rather than fixing it to come last. (gfc_match_function_decl, gfc_match_subroutine): After errors in 'copy_prefix', emit them immediately in the case of module procedures to prevent a later ICE. PR fortran/69524 * decl.c (gfc_match_submod_proc): Permit 'module procedure' declarations within the contains section of modules as well as submodules. * resolve.c (resolve_fl_procedure): Likewise. *trans-decl.c (build_function_decl): Change the gcc_assert to allow all forms of module procedure declarations within module contains sections. 2016-03-12 Paul Thomas PR fortran/70031 * gfortran.dg/submodule_14.f08: New test PR fortran/69524 * gfortran.dg/submodule_15.f08: New test git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@234161 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 18 +++++ gcc/fortran/decl.c | 102 ++++++++++++++++------------- gcc/fortran/resolve.c | 2 +- gcc/fortran/trans-decl.c | 7 +- gcc/testsuite/ChangeLog | 8 +++ gcc/testsuite/gfortran.dg/submodule_14.f08 | 49 ++++++++++++++ gcc/testsuite/gfortran.dg/submodule_15.f08 | 58 ++++++++++++++++ 7 files changed, 197 insertions(+), 47 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/submodule_14.f08 create mode 100644 gcc/testsuite/gfortran.dg/submodule_15.f08 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 54950beffd2..cf0cb6d09c0 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,21 @@ +2016-03-12 Paul Thomas + + PR fortran/70031 + * decl.c (gfc_match_prefix): Treat the 'module' prefix in the + same way as the others, rather than fixing it to come last. + (gfc_match_function_decl, gfc_match_subroutine): After errors + in 'copy_prefix', emit them immediately in the case of module + procedures to prevent a later ICE. + + PR fortran/69524 + * decl.c (gfc_match_submod_proc): Permit 'module procedure' + declarations within the contains section of modules as well as + submodules. + * resolve.c (resolve_fl_procedure): Likewise. + *trans-decl.c (build_function_decl): Change the gcc_assert to + allow all forms of module procedure declarations within module + contains sections. + 2016-02-28 Thomas Koenig PR fortran/68147 diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index d3ddda2d5f5..80ec39cb86b 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -764,7 +764,7 @@ char_len_param_value (gfc_expr **expr, bool *deferred) gfc_reduce_init_expr (e); if ((e->ref && e->ref->type == REF_ARRAY - && e->ref->u.ar.type != AR_ELEMENT) + && e->ref->u.ar.type != AR_ELEMENT) || (!e->ref && e->expr_type == EXPR_ARRAY)) { gfc_free_expr (e); @@ -1183,8 +1183,8 @@ gfc_verify_c_interop_param (gfc_symbol *sym) else if (sym->attr.optional == 1 && !gfc_notify_std (GFC_STD_F2008_TS, "Variable %qs " "at %L with OPTIONAL attribute in " - "procedure %qs which is BIND(C)", - sym->name, &(sym->declared_at), + "procedure %qs which is BIND(C)", + sym->name, &(sym->declared_at), sym->ns->proc_name->name)) retval = false; @@ -1195,8 +1195,8 @@ gfc_verify_c_interop_param (gfc_symbol *sym) && !gfc_notify_std (GFC_STD_F2008_TS, "Assumed-shape array %qs " "at %L as dummy argument to the BIND(C) " "procedure %qs at %L", sym->name, - &(sym->declared_at), - sym->ns->proc_name->name, + &(sym->declared_at), + sym->ns->proc_name->name, &(sym->ns->proc_name->declared_at))) retval = false; } @@ -1286,7 +1286,7 @@ build_sym (const char *name, gfc_charlen *cl, bool cl_deferred, { /* Set the binding label and verify that if a NAME= was specified then only one identifier was in the entity-decl-list. */ - if (!set_binding_label (&sym->binding_label, sym->name, + if (!set_binding_label (&sym->binding_label, sym->name, num_idents_on_line)) return false; } @@ -1505,7 +1505,7 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus) else if (init->value.constructor) { gfc_constructor *c; - c = gfc_constructor_first (init->value.constructor); + c = gfc_constructor_first (init->value.constructor); clen = c->expr->value.character.length; } else @@ -1570,7 +1570,7 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus) lower = sym->as->lower[dim]; - /* If the lower bound is an array element from another + /* If the lower bound is an array element from another parameterized array, then it is marked with EXPR_VARIABLE and is an initialization expression. Try to reduce it. */ if (lower->expr_type == EXPR_VARIABLE) @@ -1998,7 +1998,7 @@ variable_decl (int elem) as->type = AS_IMPLIED_SHAPE; if (as->type == AS_IMPLIED_SHAPE - && !gfc_notify_std (GFC_STD_F2008, "Implied-shape array at %L", + && !gfc_notify_std (GFC_STD_F2008, "Implied-shape array at %L", &var_locus)) { m = MATCH_ERROR; @@ -2314,8 +2314,8 @@ gfc_match_old_kind_spec (gfc_typespec *ts) return MATCH_ERROR; } - if (!gfc_notify_std (GFC_STD_GNU, - "Nonstandard type declaration %s*%d at %C", + if (!gfc_notify_std (GFC_STD_GNU, + "Nonstandard type declaration %s*%d at %C", gfc_basic_typename(ts->type), original_kind)) return MATCH_ERROR; @@ -2918,7 +2918,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) /* This is essential to force the construction of unlimited polymorphic component class containers. */ upe->attr.zero_comp = 1; - if (!gfc_add_flavor (&upe->attr, FL_DERIVED, NULL, + if (!gfc_add_flavor (&upe->attr, FL_DERIVED, NULL, &gfc_current_locus)) return MATCH_ERROR; } @@ -3938,7 +3938,7 @@ match_attr_spec (void) && gfc_state_stack->previous->state == COMP_MODULE) { if (!gfc_notify_std (GFC_STD_F2003, "Attribute %s " - "at %L in a TYPE definition", attr, + "at %L in a TYPE definition", attr, &seen_at[d])) { m = MATCH_ERROR; @@ -4345,7 +4345,7 @@ set_verify_bind_c_com_block (gfc_common_head *com_block, int num_idents) bool retval = true; /* destLabel, common name, typespec (which may have binding label). */ - if (!set_binding_label (&com_block->binding_label, com_block->name, + if (!set_binding_label (&com_block->binding_label, com_block->name, num_idents)) return false; @@ -4606,6 +4606,19 @@ gfc_match_prefix (gfc_typespec *ts) { found_prefix = false; + /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a + corresponding attribute seems natural and distinguishes these + procedures from procedure types of PROC_MODULE, which these are + as well. */ + if (gfc_match ("module% ") == MATCH_YES) + { + if (!gfc_notify_std (GFC_STD_F2008, "MODULE prefix at %C")) + goto error; + + current_attr.module_procedure = 1; + found_prefix = true; + } + if (!seen_type && ts != NULL && gfc_match_decl_type_spec (ts, 0) == MATCH_YES && gfc_match_space () == MATCH_YES) @@ -4670,21 +4683,6 @@ gfc_match_prefix (gfc_typespec *ts) /* At this point, the next item is not a prefix. */ gcc_assert (gfc_matching_prefix); - /* MODULE should be the last prefix before FUNCTION or SUBROUTINE. - Since this is a prefix like PURE, ELEMENTAL, etc., having a - corresponding attribute seems natural and distinguishes these - procedures from procedure types of PROC_MODULE, which these are - as well. */ - if ((gfc_current_state () == COMP_INTERFACE - || gfc_current_state () == COMP_CONTAINS) - && gfc_match ("module% ") == MATCH_YES) - { - if (!gfc_notify_std (GFC_STD_F2008, "MODULE prefix at %C")) - goto error; - else - current_attr.module_procedure = 1; - } - gfc_matching_prefix = false; return MATCH_YES; @@ -5142,7 +5140,7 @@ match_procedure_interface (gfc_symbol **proc_if) if ((*proc_if)->attr.flavor == FL_UNKNOWN && (*proc_if)->ts.type == BT_UNKNOWN - && !gfc_add_flavor (&(*proc_if)->attr, FL_PROCEDURE, + && !gfc_add_flavor (&(*proc_if)->attr, FL_PROCEDURE, (*proc_if)->name, NULL)) return MATCH_ERROR; } @@ -5639,10 +5637,17 @@ gfc_match_function_decl (void) if (!gfc_add_function (&sym->attr, sym->name, NULL)) goto cleanup; - if (!gfc_missing_attr (&sym->attr, NULL) - || !copy_prefix (&sym->attr, &sym->declared_at)) + if (!gfc_missing_attr (&sym->attr, NULL)) goto cleanup; + if (!copy_prefix (&sym->attr, &sym->declared_at)) + { + if(!sym->attr.module_procedure) + goto cleanup; + else + gfc_error_check (); + } + /* Delay matching the function characteristics until after the specification block by signalling kind=-1. */ sym->declared_at = old_loc; @@ -5666,6 +5671,7 @@ gfc_match_function_decl (void) sym->result = result; } + /* Warn if this procedure has the same name as an intrinsic. */ do_warn_intrinsic_shadow (sym, true); @@ -5890,7 +5896,7 @@ gfc_match_entry (void) gfc_error ("Missing required parentheses before BIND(C) at %C"); return MATCH_ERROR; } - if (!gfc_add_is_bind_c (&(entry->attr), entry->name, + if (!gfc_add_is_bind_c (&(entry->attr), entry->name, &(entry->declared_at), 1)) return MATCH_ERROR; } @@ -6096,7 +6102,7 @@ gfc_match_subroutine (void) gfc_error ("Missing required parentheses before BIND(C) at %C"); return MATCH_ERROR; } - if (!gfc_add_is_bind_c (&(sym->attr), sym->name, + if (!gfc_add_is_bind_c (&(sym->attr), sym->name, &(sym->declared_at), 1)) return MATCH_ERROR; } @@ -6108,7 +6114,12 @@ gfc_match_subroutine (void) } if (!copy_prefix (&sym->attr, &sym->declared_at)) - return MATCH_ERROR; + { + if(!sym->attr.module_procedure) + return MATCH_ERROR; + else + gfc_error_check (); + } /* Warn if it has the same name as an intrinsic. */ do_warn_intrinsic_shadow (sym, false); @@ -6516,7 +6527,7 @@ gfc_match_end (gfc_statement *st) if (!eos_ok && (*st == ST_END_SUBROUTINE || *st == ST_END_FUNCTION)) { if (!gfc_notify_std (GFC_STD_F2008, "END statement " - "instead of %s statement at %L", + "instead of %s statement at %L", abreviated_modproc_decl ? "END PROCEDURE" : gfc_ascii_statement(*st), &old_loc)) goto cleanup; @@ -7148,16 +7159,16 @@ access_attr_decl (gfc_statement st) if (gfc_get_symbol (name, NULL, &sym)) goto done; - if (!gfc_add_access (&sym->attr, - (st == ST_PUBLIC) - ? ACCESS_PUBLIC : ACCESS_PRIVATE, + if (!gfc_add_access (&sym->attr, + (st == ST_PUBLIC) + ? ACCESS_PUBLIC : ACCESS_PRIVATE, sym->name, NULL)) return MATCH_ERROR; if (sym->attr.generic && (dt_sym = gfc_find_dt_in_generic (sym)) - && !gfc_add_access (&dt_sym->attr, - (st == ST_PUBLIC) - ? ACCESS_PUBLIC : ACCESS_PRIVATE, + && !gfc_add_access (&dt_sym->attr, + (st == ST_PUBLIC) + ? ACCESS_PUBLIC : ACCESS_PRIVATE, sym->name, NULL)) return MATCH_ERROR; @@ -7481,7 +7492,7 @@ gfc_match_save (void) switch (m) { case MATCH_YES: - if (!gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name, + if (!gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name, &gfc_current_locus)) return MATCH_ERROR; goto next_item; @@ -7697,7 +7708,8 @@ gfc_match_submod_proc (void) if (gfc_current_state () != COMP_CONTAINS || !(gfc_state_stack->previous - && gfc_state_stack->previous->state == COMP_SUBMODULE)) + && (gfc_state_stack->previous->state == COMP_SUBMODULE + || gfc_state_stack->previous->state == COMP_MODULE))) return MATCH_NO; m = gfc_match (" module% procedure% %n", name); @@ -8127,7 +8139,7 @@ gfc_match_derived_decl (void) return MATCH_ERROR; else if (sym->attr.access == ACCESS_UNKNOWN && gensym->attr.access != ACCESS_UNKNOWN - && !gfc_add_access (&sym->attr, gensym->attr.access, + && !gfc_add_access (&sym->attr, gensym->attr.access, sym->name, NULL)) return MATCH_ERROR; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 556c8469d28..55ab2ecfceb 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -11905,7 +11905,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) "in %qs at %L", sym->name, &sym->declared_at); return false; } - if (sym->attr.external && sym->attr.function + if (sym->attr.external && sym->attr.function && !sym->attr.module_procedure && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure) || sym->attr.contained)) { diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 4e7129e150a..4bd7dc4e853 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -2062,7 +2062,12 @@ build_function_decl (gfc_symbol * sym, bool global) tree result_decl; gfc_formal_arglist *f; - gcc_assert (!sym->attr.external); + bool module_procedure = sym->attr.module_procedure + && sym->ns + && sym->ns->proc_name + && sym->ns->proc_name->attr.flavor == FL_MODULE; + + gcc_assert (!sym->attr.external || module_procedure); if (sym->backend_decl) return; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 515dbc75d2f..dd470c3a1b8 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,11 @@ +2016-03-12 Paul Thomas + + PR fortran/70031 + * gfortran.dg/submodule_14.f08: New test + + PR fortran/69524 + * gfortran.dg/submodule_15.f08: New test + 2016-03-12 Patrick Palka PR c++/70106 diff --git a/gcc/testsuite/gfortran.dg/submodule_14.f08 b/gcc/testsuite/gfortran.dg/submodule_14.f08 new file mode 100644 index 00000000000..0d0806d686d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/submodule_14.f08 @@ -0,0 +1,49 @@ +! { dg-do compile } +! +! Check the fix for PR70031, where the 'module' prefix had to preceed +! 'function/subroutine' in the interface (or in the CONTAINS section. +! +! As reported by "Bulova" on +! https://groups.google.com/forum/#!topic/comp.lang.fortran/hE8LkVMhghQ +! +module test + Interface + Module Recursive Subroutine sub1 (x) + Integer, Intent (InOut) :: x + End Subroutine sub1 + module recursive function fcn1 (x) result(res) + integer, intent (inout) :: x + integer :: res + end function + End Interface +end module test + +submodule(test) testson + integer :: n = 10 +contains + Module Procedure sub1 + If (x < n) Then + x = x + 1 + Call sub1 (x) + End If + End Procedure sub1 + module function fcn1 (x) result(res) + integer, intent (inout) :: x + integer :: res + res = x - 1 + if (x > 0) then + x = fcn1 (res) + else + res = x + end if + end function +end submodule testson + + use test + integer :: x = 5 + call sub1(x) + if (x .ne. 10) call abort + x = 10 + if (fcn1 (x) .ne. 0) call abort +end + diff --git a/gcc/testsuite/gfortran.dg/submodule_15.f08 b/gcc/testsuite/gfortran.dg/submodule_15.f08 new file mode 100644 index 00000000000..499bc66d5ac --- /dev/null +++ b/gcc/testsuite/gfortran.dg/submodule_15.f08 @@ -0,0 +1,58 @@ +! { dg-do run } +! +! Check the fix for PR69524, where module procedures were not permitted +! in a module CONTAINS section. +! +! Reorted by Kirill Yukhin +! +module A + implicit none + interface + module subroutine A1(i) + integer, intent(inout) :: i + end subroutine A1 + module subroutine A2(i) + integer, intent(inout) :: i + end subroutine A2 + integer module function A3(i) + integer, intent(inout) :: i + end function A3 + module subroutine B1(i) + integer, intent(inout) :: i + end subroutine B1 + end interface + integer :: incr ! Make sure that everybody can access a module variable +contains + module subroutine A1(i) ! Full declaration + integer, intent(inout) :: i + call b1 (i) ! Call the submodule procedure + incr = incr + 1 + end subroutine A1 + + module PROCEDURE A2 ! Abreviated declaration + call b1 (i) ! Call the submodule procedure + incr = incr + 1 + end procedure A2 + + module PROCEDURE A3 ! Abreviated declaration + call a1 (i) ! Call the module procedure in the module + call a2 (i) ! ditto + call b1 (i) ! Call the submodule procedure + incr = incr + 1 + a3 = i + incr + end procedure A3 +end module A + +submodule (A) a_son + implicit none +contains + module procedure b1 + i = i + incr + end procedure +end submodule + + use A + integer :: i = 1 + incr = 1 + if (a3(i) .ne. 11) call abort +end -- 2.11.4.GIT