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
This commit is contained in:
Paul Thomas
parent
8282c8776d
commit
a56ea54ab0
|
|
@ -1,3 +1,21 @@
|
|||
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -1,3 +1,19 @@
|
|||
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
|
||||
|
|
|
|||
|
|
@ -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" } }
|
||||
|
|
|
|||
|
|
@ -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 *-*-* } } }
|
||||
|
|
|
|||
|
|
@ -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" } }
|
||||
|
|
|
|||
|
|
@ -0,0 +1,170 @@
|
|||
! { 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" } }
|
||||
|
||||
|
|
@ -49,3 +49,4 @@ contains
|
|||
end SUBMODULE foo_interface_daughter
|
||||
|
||||
end
|
||||
! { dg-final { cleanup-submodules "foo_interface@foo_interface_daughter" } }
|
||||
|
|
|
|||
|
|
@ -38,3 +38,4 @@ program a_s
|
|||
implicit none
|
||||
call p()
|
||||
end program
|
||||
! { dg-final { cleanup-submodules "mod_a@b" } }
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
Loading…
Reference in New Issue