re PR fortran/70031 (Error in recursive module subroutine declaration if declared as "module recursive")

2016-03-12  Paul Thomas  <pault@gcc.gnu.org>

	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  <pault@gcc.gnu.org>

	PR fortran/70031
	* gfortran.dg/submodule_14.f08: New test

	PR fortran/69524
	* gfortran.dg/submodule_15.f08: New test

From-SVN: r234161

7 files changed, 197 insertions, 47 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 54950be..cf0cb6d 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,21 @@
+2016-03-12  Paul Thomas  <pault@gcc.gnu.org>
+
+	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  <tkoenig@gcc.gnu.org>
 
 	PR fortran/68147
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index d3ddda2..80ec39c 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 556c846..55ab2ec 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 4e7129e..4bd7dc4 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 515dbc7..dd470c3 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,11 @@
+2016-03-12  Paul Thomas  <pault@gcc.gnu.org>
+
+	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  <ppalka@gcc.gnu.org>
 
 	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 0000000..0d0806d
--- /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 0000000..499bc66
--- /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  <kyukhin@gcc.gnu.org>
+!
+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