re PR fortran/52846 ([F2008] Support submodules)

2015-08-05  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/52846
	* module.c (check_access): Return true if new static flag
	'dump_smod' is true..
	(gfc_dump_module): Rename original 'dump_module' and call from
	new version. Use 'dump_smod' rather than the stack state to
	determine if a submodule is being processed. The new version of
	this procedure sets 'dump_smod' depending on the stack state and
	then writes both the mod and smod files if a module is being
	processed or just the smod for a submodule.
	(gfc_use_module): Eliminate the check for module_name and
	submodule_name being the same.
	* trans-decl.c (gfc_finish_var_decl, gfc_build_qualified_array,
	get_proc_pointer_decl): Set TREE_PUBLIC unconditionally and use
	the conditions to set DECL_VISIBILITY as hidden and to set as
	true DECL_VISIBILITY_SPECIFIED.

2015-08-05  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/52846

	* lib/fortran-modules.exp: Call cleanup-submodules from
	cleanup-modules.
	* gfortran.dg/public_private_module_2.f90: Add two XFAILS to
	cover the cases where private entities are no longer optimized
	away.
	* gfortran.dg/public_private_module_6.f90: Add an XFAIL for the
	same reason.
	* gfortran.dg/submodule_1.f08: Change cleanup module names.
	* gfortran.dg/submodule_5.f08: The same.
	* gfortran.dg/submodule_9.f08: The same.
	* gfortran.dg/submodule_10.f08: New test

From-SVN: r226622

gcc/fortran/ChangeLog

+2015-08-05  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/52846
+	* module.c (check_access): Return true if new static flag
+	'dump_smod' is true..
+	(gfc_dump_module): Rename original 'dump_module' and call from
+	new version. Use 'dump_smod' rather than the stack state to
+	determine if a submodule is being processed. The new version of
+	this procedure sets 'dump_smod' depending on the stack state and
+	then writes both the mod and smod files if a module is being
+	processed or just the smod for a submodule.
+	(gfc_use_module): Eliminate the check for module_name and
+	submodule_name being the same.
+	* trans-decl.c (gfc_finish_var_decl, gfc_build_qualified_array,
+	get_proc_pointer_decl): Set TREE_PUBLIC unconditionally and use
+	the conditions to set DECL_VISIBILITY as hidden and to set as
+	true DECL_VISIBILITY_SPECIFIED.
+
 2015-08-04  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
 
 	PR fortran/64022

gcc/fortran/module.c

@@ -525,9 +525,9 @@ gfc_match_use (void)
   gfc_intrinsic_op op;
   match m;
   gfc_use_list *use_list;
- 
+
   use_list = gfc_get_use_list ();
-  
+
   if (gfc_match (" , ") == MATCH_YES)
     {
       if ((m = gfc_match (" %n ::", module_nature)) == MATCH_YES)
@@ -1080,7 +1080,7 @@ gzopen_included_file_1 (const char *name, gfc_directorylist *list,
   return NULL;
 }
 
-static gzFile 
+static gzFile
 gzopen_included_file (const char *name, bool include_cwd, bool module)
 {
   gzFile f = NULL;
@@ -1660,7 +1660,7 @@ write_atom (atom_type atom, const void *v)
 
     }
 
-  if(p == NULL || *p == '\0') 
+  if(p == NULL || *p == '\0')
      len = 0;
   else
   len = strlen (p);
@@ -1856,7 +1856,7 @@ unquote_string (const char *s)
     {
       if (*p != '\\')
 	continue;
-	
+
       if (p[1] == '\\')
 	p++;
       else if (p[1] == 'U')
@@ -2106,7 +2106,7 @@ mio_symbol_attribute (symbol_attribute *attr)
   attr->proc = MIO_NAME (procedure_type) (attr->proc, procedures);
   attr->if_source = MIO_NAME (ifsrc) (attr->if_source, ifsrc_types);
   attr->save = MIO_NAME (save_state) (attr->save, save_status);
-  
+
   ext_attr = attr->ext_attr;
   mio_integer ((int *) &ext_attr);
   attr->ext_attr = ext_attr;
@@ -2472,7 +2472,7 @@ mio_typespec (gfc_typespec *ts)
   /* Add info for C interop and is_iso_c.  */
   mio_integer (&ts->is_c_interop);
   mio_integer (&ts->is_iso_c);
-  
+
   /* If the typespec is for an identifier either from iso_c_binding, or
      a constant that was initialized to an identifier from it, use the
      f90_type.  Otherwise, use the ts->type, since it shouldn't matter.  */
@@ -2725,7 +2725,7 @@ mio_component (gfc_component *c, int vtype)
   mio_symbol_attribute (&c->attr);
   if (c->ts.type == BT_CLASS)
     c->attr.class_ok = 1;
-  c->attr.access = MIO_NAME (gfc_access) (c->attr.access, access_types); 
+  c->attr.access = MIO_NAME (gfc_access) (c->attr.access, access_types);
 
   if (!vtype || strcmp (c->name, "_final") == 0
       || strcmp (c->name, "_hash") == 0)
@@ -2925,7 +2925,7 @@ mio_symtree_ref (gfc_symtree **stp)
 	    resolve_fixups (p->fixup, p->u.rsym.sym);
 	  p->fixup = NULL;
 	}
-      
+
       if (p->type == P_UNKNOWN)
 	p->type = P_SYMBOL;
 
@@ -3260,7 +3260,7 @@ static const mstring intrinsics[] =
 
 
 /* Remedy a couple of situations where the gfc_expr's can be defective.  */
- 
+
 static void
 fix_mio_expr (gfc_expr *e)
 {
@@ -3830,7 +3830,7 @@ mio_full_typebound_tree (gfc_symtree** root)
 	{
 	  gfc_symtree* st;
 
-	  mio_lparen (); 
+	  mio_lparen ();
 
 	  require_atom (ATOM_STRING);
 	  st = gfc_get_tbp_symtree (root, atom_string);
@@ -3931,7 +3931,7 @@ static void
 mio_full_f2k_derived (gfc_symbol *sym)
 {
   mio_lparen ();
-  
+
   if (iomode == IO_OUTPUT)
     {
       if (sym->f2k_derived)
@@ -4158,7 +4158,7 @@ static void
 mio_symbol (gfc_symbol *sym)
 {
   int intmod = INTMOD_NONE;
-  
+
   mio_lparen ();
 
   mio_symbol_attribute (&sym->attr);
@@ -4219,7 +4219,7 @@ mio_symbol (gfc_symbol *sym)
       else
 	sym->from_intmod = (intmod_id) intmod;
     }
-  
+
   mio_integer (&(sym->intmod_sym_id));
 
   if (sym->attr.flavor == FL_DERIVED)
@@ -4559,7 +4559,7 @@ load_commons (void)
       if (strlen (label))
 	p->binding_label = IDENTIFIER_POINTER (get_identifier (label));
       XDELETEVEC (label);
-      
+
       mio_rparen ();
     }
 
@@ -4805,7 +4805,7 @@ load_needed (pointer_info *p)
       sym->name = dt_lower_string (p->u.rsym.true_name);
       sym->module = gfc_get_string (p->u.rsym.module);
       if (p->u.rsym.binding_label)
-	sym->binding_label = IDENTIFIER_POINTER (get_identifier 
+	sym->binding_label = IDENTIFIER_POINTER (get_identifier
 						 (p->u.rsym.binding_label));
 
       associate_integer_pointer (p, sym);
@@ -4989,7 +4989,7 @@ read_module (void)
 	info->u.rsym.binding_label = bind_label;
       else
 	XDELETEVEC (bind_label);
-      
+
       require_atom (ATOM_INTEGER);
       info->u.rsym.ns = atom_int;
 
@@ -5165,8 +5165,8 @@ read_module (void)
 		  sym->module = gfc_get_string (info->u.rsym.module);
 
 		  if (info->u.rsym.binding_label)
-		    sym->binding_label = 
-		      IDENTIFIER_POINTER (get_identifier 
+		    sym->binding_label =
+		      IDENTIFIER_POINTER (get_identifier
 					  (info->u.rsym.binding_label));
 		}
 
@@ -5279,13 +5279,18 @@ read_module (void)
 
 /* Given an access type that is specific to an entity and the default
    access, return nonzero if the entity is publicly accessible.  If the
-   element is declared as PUBLIC, then it is public; if declared 
+   element is declared as PUBLIC, then it is public; if declared
    PRIVATE, then private, and otherwise it is public unless the default
    access in this context has been declared PRIVATE.  */
 
+static bool dump_smod = false;
+
 static bool
 check_access (gfc_access specific_access, gfc_access default_access)
 {
+  if (dump_smod)
+    return true;
+
   if (specific_access == ACCESS_PUBLIC)
     return TRUE;
   if (specific_access == ACCESS_PRIVATE)
@@ -5359,7 +5364,7 @@ write_common_0 (gfc_symtree *st, bool this_module)
   const char *label;
   struct written_common *w;
   bool write_me = true;
-	      
+
   if (st == NULL)
     return;
 
@@ -5436,8 +5441,8 @@ write_blank_common (void)
   const char * name = BLANK_COMMON_NAME;
   int saved;
   /* TODO: Blank commons are not bind(c).  The F2003 standard probably says
-     this, but it hasn't been checked.  Just making it so for now.  */  
-  int is_bind_c = 0;  
+     this, but it hasn't been checked.  Just making it so for now.  */
+  int is_bind_c = 0;
 
   if (gfc_current_ns->blank_common.head == NULL)
     return;
@@ -5697,8 +5702,8 @@ find_symbols_to_write(sorted_pointer_info **tree, pointer_info *p)
   if (p->type == P_SYMBOL && p->u.wsym.state == NEEDS_WRITE)
     {
       sorted_pointer_info *sp = gfc_get_sorted_pointer_info();
-      sp->p = p; 
- 
+      sp->p = p;
+
       gfc_insert_bbt (tree, sp, compare_sorted_pointer_info);
    }
 
@@ -5724,7 +5729,7 @@ write_symbol1_recursion (sorted_pointer_info *sp)
   p1->u.wsym.state = WRITTEN;
   write_symbol (p1->integer, p1->u.wsym.sym);
   p1->u.wsym.sym->attr.public_used = 1;
- 
+
   write_symbol1_recursion (sp->right);
 }
 
@@ -5945,10 +5950,10 @@ read_crc32_from_module_file (const char* filename, uLong* crc)
   /* Close the file.  */
   fclose (file);
 
-  val = (buf[0] & 0xFF) + ((buf[1] & 0xFF) << 8) + ((buf[2] & 0xFF) << 16) 
+  val = (buf[0] & 0xFF) + ((buf[1] & 0xFF) << 8) + ((buf[2] & 0xFF) << 16)
     + ((buf[3] & 0xFF) << 24);
   *crc = val;
-  
+
   /* For debugging, the CRC value printed in hexadecimal should match
      the CRC printed by "zcat -l -v filename".
      printf("CRC of file %s is %x\n", filename, val); */
@@ -5961,8 +5966,8 @@ read_crc32_from_module_file (const char* filename, uLong* crc)
    processing the module, dump_flag will be set to zero and we delete
    the module file, even if it was already there.  */
 
-void
-gfc_dump_module (const char *name, int dump_flag)
+static void
+dump_module (const char *name, int dump_flag)
 {
   int n;
   char *filename, *filename_tmp;
@@ -5970,13 +5975,13 @@ gfc_dump_module (const char *name, int dump_flag)
 
   module_name = gfc_get_string (name);
 
-  if (gfc_state_stack->state == COMP_SUBMODULE)
+  if (dump_smod)
     {
       name = submodule_name;
       n = strlen (name) + strlen (SUBMODULE_EXTENSION) + 1;
     }
   else
-  n = strlen (name) + strlen (MODULE_EXTENSION) + 1;
+    n = strlen (name) + strlen (MODULE_EXTENSION) + 1;
 
   if (gfc_option.module_dir != NULL)
     {
@@ -5991,7 +5996,7 @@ gfc_dump_module (const char *name, int dump_flag)
       strcpy (filename, name);
     }
 
-  if (gfc_state_stack->state == COMP_SUBMODULE)
+  if (dump_smod)
     strcat (filename, SUBMODULE_EXTENSION);
   else
   strcat (filename, MODULE_EXTENSION);
@@ -6060,6 +6065,27 @@ gfc_dump_module (const char *name, int dump_flag)
 }
 
 
+void
+gfc_dump_module (const char *name, int dump_flag)
+{
+  if (gfc_state_stack->state == COMP_SUBMODULE)
+    dump_smod = true;
+  else
+    dump_smod =false;
+
+  dump_module (name, dump_flag);
+
+  if (dump_smod)
+    return;
+
+  /* Write a submodule file from a module.  The 'dump_smod' flag switches
+     off the check for PRIVATE entities.  */
+  dump_smod = true;
+  submodule_name = module_name;
+  dump_module (name, dump_flag);
+  dump_smod = false;
+}
+
 static void
 create_intrinsic_function (const char *name, int id,
 			   const char *modname, intmod_id module,
@@ -6140,7 +6166,7 @@ import_iso_c_binding_module (void)
       /* symtree doesn't already exist in current namespace.  */
       gfc_get_sym_tree (iso_c_module_name, gfc_current_ns, &mod_symtree,
 			false);
-      
+
       if (mod_symtree != NULL)
 	mod_sym = mod_symtree->n.sym;
       else
@@ -6452,7 +6478,7 @@ create_int_parameter_array (const char *name, int size, gfc_expr *value,
   sym->as->rank = 1;
   sym->as->type = AS_EXPLICIT;
   sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
-  sym->as->upper[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, size); 
+  sym->as->upper[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, size);
 
   sym->value = value;
   sym->value->shape = gfc_get_shape (1);
@@ -6754,13 +6780,12 @@ gfc_use_module (gfc_use_list *module)
 		     "USE statement at %C has no ONLY qualifier");
 
   if (gfc_state_stack->state == COMP_MODULE
-      || module->submodule_name == NULL
-      || strcmp (module_name, module->submodule_name) == 0)
+      || module->submodule_name == NULL)
     {
       filename = XALLOCAVEC (char, strlen (module_name)
 				   + strlen (MODULE_EXTENSION) + 1);
-  strcpy (filename, module_name);
-  strcat (filename, MODULE_EXTENSION);
+      strcpy (filename, module_name);
+      strcat (filename, MODULE_EXTENSION);
     }
   else
     {
@@ -7003,7 +7028,7 @@ gfc_use_modules (void)
 		  r->next = next->rename;
 		  next->rename = seek->rename;
 		}
-	      last->next = seek->next; 
+	      last->next = seek->next;
 	      free (seek);
 	    }
 	  else

gcc/fortran/trans-decl.c

@@ -596,6 +596,11 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym)
 	 both, of course.) (J3/04-007, section 15.3).  */
       TREE_PUBLIC(decl) = 1;
       DECL_COMMON(decl) = 1;
+      if (sym->attr.access == ACCESS_PRIVATE && !sym->attr.public_used)
+	{
+	  DECL_VISIBILITY (decl) = VISIBILITY_HIDDEN;
+	  DECL_VISIBILITY_SPECIFIED (decl) = true;
+	}
     }
 
   /* If a variable is USE associated, it's always external.  */
@@ -609,9 +614,13 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym)
       /* TODO: Don't set sym->module for result or dummy variables.  */
       gcc_assert (current_function_decl == NULL_TREE || sym->result == sym);
 
-      if (sym->attr.access != ACCESS_PRIVATE || sym->attr.public_used)
-	TREE_PUBLIC (decl) = 1;
+      TREE_PUBLIC (decl) = 1;
       TREE_STATIC (decl) = 1;
+      if (sym->attr.access == ACCESS_PRIVATE && !sym->attr.public_used)
+	{
+	  DECL_VISIBILITY (decl) = VISIBILITY_HIDDEN;
+	  DECL_VISIBILITY_SPECIFIED (decl) = true;
+	}
     }
 
   /* Derived types are a bit peculiar because of the possibility of
@@ -837,9 +846,13 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym)
 	  else
 	    TREE_STATIC (token) = 1;
 
-	  if (sym->attr.use_assoc || sym->attr.access != ACCESS_PRIVATE ||
-	      sym->attr.public_used)
-	    TREE_PUBLIC (token) = 1;
+	  TREE_PUBLIC (token) = 1;
+
+	  if (sym->attr.access == ACCESS_PRIVATE && !sym->attr.public_used)
+	    {
+	      DECL_VISIBILITY (token) = VISIBILITY_HIDDEN;
+	      DECL_VISIBILITY_SPECIFIED (token) = true;
+	    }
 	}
       else
 	{
@@ -1747,9 +1760,12 @@ get_proc_pointer_decl (gfc_symbol *sym)
   else if (sym->module && sym->ns->proc_name->attr.flavor == FL_MODULE)
     {
       /* This is the declaration of a module variable.  */
-      if (sym->ns->proc_name->attr.flavor == FL_MODULE
-	  && (sym->attr.access != ACCESS_PRIVATE || sym->attr.public_used))
-	TREE_PUBLIC (decl) = 1;
+      TREE_PUBLIC (decl) = 1;
+      if (sym->attr.access == ACCESS_PRIVATE && !sym->attr.public_used)
+	{
+	  DECL_VISIBILITY (decl) = VISIBILITY_HIDDEN;
+	  DECL_VISIBILITY_SPECIFIED (decl) = true;
+	}
       TREE_STATIC (decl) = 1;
     }
 

gcc/testsuite/ChangeLog

+2015-08-05  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/52846
+
+	* lib/fortran-modules.exp: Call cleanup-submodules from
+	cleanup-modules.
+	* gfortran.dg/public_private_module_2.f90: Add two XFAILS to
+	cover the cases where private entities are no longer optimized
+	away.
+	* gfortran.dg/public_private_module_6.f90: Add an XFAIL for the
+	same reason.
+	* gfortran.dg/submodule_1.f08: Change cleanup module names.
+	* gfortran.dg/submodule_5.f08: The same.
+	* gfortran.dg/submodule_9.f08: The same.
+	* gfortran.dg/submodule_10.f08: New test.
+
 2015-08-05  Paolo Carlini  <paolo.carlini@oracle.com>
 
 	PR c++/66595

gcc/testsuite/gfortran.dg/public_private_module_2.f90

@@ -18,12 +18,15 @@
         integer, bind(C,name='') :: qq
       end module mod
 
+! The two xfails below have appeared with the introduction of submodules. 'iii' and
+! 'mmm' now are TREE_PUBLIC but has DECL_VISIBILITY (decl) = VISIBILITY_HIDDEN set.
+
       ! { dg-final { scan-assembler "__mod_MOD_aa" } }
-      ! { dg-final { scan-assembler-not "iii" } }
+      ! { dg-final { scan-assembler-not "iii" { xfail *-*-* } } }
       ! { dg-final { scan-assembler "jj" } }
       ! { dg-final { scan-assembler "lll" } }
       ! { dg-final { scan-assembler-not "kk" } }
-      ! { dg-final { scan-assembler-not "mmmm" } }
+      ! { dg-final { scan-assembler-not "mmmm" { xfail *-*-* } } }
       ! { dg-final { scan-assembler "nnn" } }
       ! { dg-final { scan-assembler "oo" } }
       ! { dg-final { scan-assembler "__mod_MOD_qq" } }

gcc/testsuite/gfortran.dg/public_private_module_6.f90

@@ -11,4 +11,7 @@ module m
   integer, save :: aaaa
 end module m
 
-! { dg-final { scan-assembler-not "aaaa" } }
+! The xfail below has appeared with the introduction of submodules. 'aaaa'
+! now is TREE_PUBLIC but has DECL_VISIBILITY (decl) = VISIBILITY_HIDDEN set.
+
+! { dg-final { scan-assembler-not "aaaa" { xfail *-*-* } } }

gcc/testsuite/gfortran.dg/submodule_1.f08

@@ -170,6 +170,6 @@
      message2 = ""
    end subroutine
  end program
-! { dg-final { cleanup-submodules "foo_interface_son" } }
-! { dg-final { cleanup-submodules "foo_interface_grandson" } }
-! { dg-final { cleanup-submodules "foo_interface_daughter" } }
+! { dg-final { cleanup-submodules "foo_interface@foo_interface_son" } }
+! { dg-final { cleanup-submodules "foo_interface@foo_interface_grandson" } }
+! { dg-final { cleanup-submodules "foo_interface@foo_interface_daughter" } }

gcc/testsuite/gfortran.dg/submodule_10.f08

+! { dg-do compile }
+!
+! Checks that PRIVATE enities are visible to submodules.
+!
+! Contributed by Salvatore Filippone  <salvatore.filippone@uniroma2.it>
+!
+module const_mod
+  integer, parameter  :: ndig=8
+  integer, parameter  :: ipk_ = selected_int_kind(ndig)
+  integer, parameter  :: longndig=12
+  integer, parameter  :: long_int_k_ = selected_int_kind(longndig)
+  integer, parameter  :: mpik_ = kind(1)
+
+  integer(ipk_), parameter, public :: success_=0
+
+end module const_mod
+
+
+module error_mod
+  use const_mod
+
+  integer(ipk_), parameter, public :: act_ret_=0
+  integer(ipk_), parameter, public :: act_print_=1
+  integer(ipk_), parameter, public :: act_abort_=2
+
+  integer(ipk_), parameter, public ::  no_err_ = 0
+
+  public error, errcomm, get_numerr, &
+       & error_handler, &
+       & ser_error_handler, par_error_handler
+
+
+  interface error_handler
+    module subroutine ser_error_handler(err_act)
+      integer(ipk_), intent(inout) ::  err_act
+    end subroutine ser_error_handler
+    module subroutine par_error_handler(ictxt,err_act)
+      integer(mpik_), intent(in) ::  ictxt
+      integer(ipk_), intent(in) ::  err_act
+    end subroutine par_error_handler
+  end interface
+
+  interface error
+    module subroutine serror()
+    end subroutine serror
+    module subroutine perror(ictxt,abrt)
+      integer(mpik_), intent(in) ::  ictxt
+      logical, intent(in), optional  :: abrt
+    end subroutine perror
+  end interface
+
+
+  interface error_print_stack
+    module subroutine par_error_print_stack(ictxt)
+      integer(mpik_), intent(in) ::  ictxt
+    end subroutine par_error_print_stack
+    module subroutine ser_error_print_stack()
+    end subroutine ser_error_print_stack
+  end interface
+
+  interface errcomm
+    module subroutine errcomm(ictxt, err)
+      integer(mpik_), intent(in)   :: ictxt
+      integer(ipk_), intent(inout):: err
+    end subroutine errcomm
+  end interface errcomm
+
+
+  private
+
+  type errstack_node
+
+    integer(ipk_) ::   err_code=0
+    character(len=20)        ::   routine=''
+    integer(ipk_),dimension(5)     ::   i_err_data=0
+    character(len=40)        ::   a_err_data=''
+    type(errstack_node), pointer :: next
+
+  end type errstack_node
+
+
+  type errstack
+    type(errstack_node), pointer :: top => null()
+    integer(ipk_) :: n_elems=0
+  end type errstack
+
+
+  type(errstack), save  :: error_stack
+  integer(ipk_), save   :: error_status    = no_err_
+  integer(ipk_), save   :: verbosity_level = 1
+  integer(ipk_), save   :: err_action      = act_abort_
+  integer(ipk_), save   :: debug_level     = 0, debug_unit, serial_debug_level=0
+
+contains
+end module error_mod
+
+submodule (error_mod) error_impl_mod
+  use const_mod
+contains
+  ! checks whether an error has occurred on one of the processes in the execution pool
+  subroutine errcomm(ictxt, err)
+    integer(mpik_), intent(in)   :: ictxt
+    integer(ipk_), intent(inout):: err
+
+
+  end subroutine errcomm
+
+  subroutine ser_error_handler(err_act)
+    implicit none
+    integer(ipk_), intent(inout) ::  err_act
+
+    if (err_act /= act_ret_)     &
+         &  call error()
+    if (err_act == act_abort_) stop
+
+    return
+  end subroutine ser_error_handler
+
+  subroutine par_error_handler(ictxt,err_act)
+    implicit none
+    integer(mpik_), intent(in) ::  ictxt
+    integer(ipk_), intent(in) ::  err_act
+
+    if (err_act == act_print_)     &
+         &  call error(ictxt, abrt=.false.)
+    if (err_act == act_abort_)      &
+         &  call error(ictxt, abrt=.true.)
+
+    return
+
+  end subroutine par_error_handler
+
+  subroutine par_error_print_stack(ictxt)
+    integer(mpik_), intent(in) ::  ictxt
+
+    call error(ictxt, abrt=.false.)
+
+  end subroutine par_error_print_stack
+
+  subroutine ser_error_print_stack()
+
+    call error()
+  end subroutine ser_error_print_stack
+
+  subroutine serror()
+
+    implicit none
+
+  end subroutine serror
+
+  subroutine perror(ictxt,abrt)
+    use const_mod
+    implicit none
+    integer(mpik_), intent(in) :: ictxt
+    logical, intent(in), optional  :: abrt
+
+  end subroutine perror
+
+end submodule error_impl_mod
+
+program testlk
+  use error_mod
+  implicit none
+
+  call error()
+
+  stop
+end program testlk
+! { dg-final { cleanup-submodules "error_mod@error_impl_mod" } }
+

gcc/testsuite/gfortran.dg/submodule_5.f08

@@ -49,3 +49,4 @@ contains
 end SUBMODULE foo_interface_daughter
 
 end
+! { dg-final { cleanup-submodules "foo_interface@foo_interface_daughter" } }

gcc/testsuite/gfortran.dg/submodule_9.f08

@@ -38,3 +38,4 @@ program a_s
   implicit none
   call p()
 end program
+! { dg-final { cleanup-submodules "mod_a@b" } }

gcc/testsuite/lib/fortran-modules.exp

@@ -17,6 +17,7 @@
 # helper to deal with fortran modules
 
 # Remove files for specified Fortran modules.
+# This includes both .mod and .smod files.
 proc cleanup-modules { modlist } {
     global clean
     foreach mod [concat $modlist $clean] {
@@ -27,6 +28,7 @@ proc cleanup-modules { modlist } {
 	}
 	remote_file build delete $m
     }
+    cleanup-submodules $modlist
 }
 
 # Remove files for specified Fortran submodules.