+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
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)
return NULL;
}
-static gzFile
+static gzFile
gzopen_included_file (const char *name, bool include_cwd, bool module)
{
gzFile f = NULL;
}
- if(p == NULL || *p == '\0')
+ if(p == NULL || *p == '\0')
len = 0;
else
len = strlen (p);
{
if (*p != '\\')
continue;
-
+
if (p[1] == '\\')
p++;
else if (p[1] == 'U')
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;
/* 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. */
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)
resolve_fixups (p->fixup, p->u.rsym.sym);
p->fixup = NULL;
}
-
+
if (p->type == P_UNKNOWN)
p->type = P_SYMBOL;
/* Remedy a couple of situations where the gfc_expr's can be defective. */
-
+
static void
fix_mio_expr (gfc_expr *e)
{
{
gfc_symtree* st;
- mio_lparen ();
+ mio_lparen ();
require_atom (ATOM_STRING);
st = gfc_get_tbp_symtree (root, atom_string);
mio_full_f2k_derived (gfc_symbol *sym)
{
mio_lparen ();
-
+
if (iomode == IO_OUTPUT)
{
if (sym->f2k_derived)
mio_symbol (gfc_symbol *sym)
{
int intmod = INTMOD_NONE;
-
+
mio_lparen ();
mio_symbol_attribute (&sym->attr);
else
sym->from_intmod = (intmod_id) intmod;
}
-
+
mio_integer (&(sym->intmod_sym_id));
if (sym->attr.flavor == FL_DERIVED)
if (strlen (label))
p->binding_label = IDENTIFIER_POINTER (get_identifier (label));
XDELETEVEC (label);
-
+
mio_rparen ();
}
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);
info->u.rsym.binding_label = bind_label;
else
XDELETEVEC (bind_label);
-
+
require_atom (ATOM_INTEGER);
info->u.rsym.ns = atom_int;
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));
}
/* 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)
const char *label;
struct written_common *w;
bool write_me = true;
-
+
if (st == NULL)
return;
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;
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);
}
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);
}
/* 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); */
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;
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)
{
strcpy (filename, name);
}
- if (gfc_state_stack->state == COMP_SUBMODULE)
+ if (dump_smod)
strcat (filename, SUBMODULE_EXTENSION);
else
strcat (filename, MODULE_EXTENSION);
}
+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,
/* 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
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);
"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
{
r->next = next->rename;
next->rename = seek->rename;
}
- last->next = seek->next;
+ last->next = seek->next;
free (seek);
}
else
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. */
/* 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
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
{
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;
}
+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
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" } }
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 *-*-* } } }
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" } }
--- /dev/null
+! { 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" } }
+
end SUBMODULE foo_interface_daughter
end
+! { dg-final { cleanup-submodules "foo_interface@foo_interface_daughter" } }
implicit none
call p()
end program
+! { dg-final { cleanup-submodules "mod_a@b" } }
# 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] {
}
remote_file build delete $m
}
+ cleanup-submodules $modlist
}
# Remove files for specified Fortran submodules.
projects / gcc.git / commitdiff