Dear All,
This is the third and final patch to implement submodules in gfortran.
It is the part that deals with private module entities. Unfortunately,
it is the most invasive and I would either like to have strong support
for it to be committed or a bright idea as to how to do it otherwise.
Since all the private entities in a module have to be transmitted to
their descendant submodules, whilst keeping them hidden from normal
use statements, I have chosen to write the module file as usual and
add a second part that contains the private entities. This latter is
only read when processing submodule statements.
I looked into encrypting the second part but could not find a way to
obtain the compression ratios that gzipping the module file affords,
largely from the repetition of attribute keywords. It was tempting to
reform completely the format of module files such that the symbol tree
is represented in binary format rather than in text. However, being
able to gunzip the files is very helpful from the diagnostic point of
view. Perhaps this is a suitable future upgrade for 6.0.0? That said,
I do not regard it as being high priority nor necessarily useful.
The other significant change is in respect of making module variable,
string length and procedure pointer declarations unconditionally
TREE_PUBLIC, whilst recycling the conditions to set DECL_VISIBILITY to
VISIBILITY_HIDDEN. This was a suggestion from Richard Biener, which
seems to do what is needed in libraries. This affects two existing
testcases: public_private_module_[2,6].f90, where xfails have been
added, where assembler symbols should be optimized away. These tests
can be removed if the above changes prove to be robust and acceptable
but I was reluctant to do this right away.
The rest of the patch is concerned with signaling to module.c that a
submodule statement is being processed.
It does cross my mind that all of this part of the submodule
implementation could be subject to the condition that a compiler
option is set. I am struck by the notion that making private module
entities available to submodules is an unnecessary complication and
that it amounts to be an error in the standard. This is why I am
suggesting the possibility of a specific compiler option.
The new testcase submodule_10.f08 is a near verbatim contribution from
Salvatore Filippone, for which thanks are due.
The remaining tasks are to try to fix PR66762, where submodule_6.f08
fails with -fto, and to update the documentation.
Bootstraps and regtests on FC21/x86_64 - OK for trunk?
Cheers
Paul
2015-07-23 Paul Thomas <pa...@gcc.gnu.org>
PR fortran/52846
* match.h : Add bool argument to gfc_use_modules so that it can
signal to module.c that a submodule statement is being
processed.
* module.c (read_module): Add new module_locus, 'end_module'.
Set it at the end of the public part of the module file. Then go
there once the public part has been processed, ready to read
the private part of the module file.
(check_access): Change original to 'check_access1' and call it
from 'check_access'. This latter inverts the result, according
to whether or not static 'invert_access' is true.
(gfc_dump_module): Write the public part of the module file as
before and then follow it with the private part, obtained by
setting 'invert_access' true. Once done, this is reset.
(gfc_use_module): Read the public part of the module file. If
this is a submodule and static 'submodule_stmt' is true, then
read the private part. This permits the private part of module
files to be respected with conventional use statements.
(gfc_use_modules): 'submodule_stmt' set true if the ancestor
module file is being used in processing submodule statement.
* parse.c (use_modules): Introduce 'using_ancestor_modules' as
a boolean argument. All calls set this argument false, except;
(parse_module): Call use_modules with 'using_ancestor_modules'
set true to signal the processing of a submodule statement.
* 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-07-23 Paul Thomas <pa...@gcc.gnu.org>
PR fortran/52846
* gfortran.dg/public_private_module_2.f90: Add two XFAILS.
* gfortran.dg/public_private_module_6.f90: Add an XFAIL.
* gfortran.dg/submodule_10.f08: New test
Index: gcc/fortran/match.h
===================================================================
*** gcc/fortran/match.h (revision 226054)
--- gcc/fortran/match.h (working copy)
*************** match gfc_match_expr (gfc_expr **);
*** 293,299 ****
/* module.c. */
match gfc_match_use (void);
match gfc_match_submodule (void);
! void gfc_use_modules (void);
#endif /* GFC_MATCH_H */
--- 293,299 ----
/* module.c. */
match gfc_match_use (void);
match gfc_match_submodule (void);
! void gfc_use_modules (bool);
#endif /* GFC_MATCH_H */
Index: gcc/fortran/module.c
===================================================================
*** gcc/fortran/module.c (revision 226054)
--- gcc/fortran/module.c (working copy)
*************** check_for_ambiguous (gfc_symtree *st, po
*** 4942,4948 ****
static void
read_module (void)
{
! module_locus operator_interfaces, user_operators, omp_udrs;
const char *p;
char name[GFC_MAX_SYMBOL_LEN + 1];
int i;
--- 4942,4948 ----
static void
read_module (void)
{
! module_locus operator_interfaces, user_operators, omp_udrs, end_module;
const char *p;
char name[GFC_MAX_SYMBOL_LEN + 1];
int i;
*************** read_module (void)
*** 5192,5197 ****
--- 5192,5198 ----
}
mio_rparen ();
+ get_module_locus (&end_module);
/* Load intrinsic operator interfaces. */
set_module_locus (&operator_interfaces);
*************** read_module (void)
*** 5274,5279 ****
--- 5275,5284 ----
to hidden symbols. */
read_cleanup (pi_root);
+
+ /* Go to the end so that we are ready to read the private entities
+ for submodules. */
+ set_module_locus (&end_module);
}
*************** read_module (void)
*** 5282,5290 ****
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
! check_access (gfc_access specific_access, gfc_access default_access)
{
if (specific_access == ACCESS_PUBLIC)
return TRUE;
--- 5287,5296 ----
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 invert_access = false;
static bool
! check_access1 (gfc_access specific_access, gfc_access default_access)
{
if (specific_access == ACCESS_PUBLIC)
return TRUE;
*************** check_access (gfc_access specific_access
*** 5298,5303 ****
--- 5304,5320 ----
}
+ static bool
+ check_access (gfc_access specific_access, gfc_access default_access)
+ {
+ bool res;
+ res = check_access1 (specific_access, default_access);
+ if (invert_access)
+ res = res ? false : true;
+ return res;
+ }
+
+
bool
gfc_check_symbol_access (gfc_symbol *sym)
{
*************** gfc_dump_module (const char *name, int d
*** 6024,6035 ****
/* Write the module itself. */
iomode = IO_OUTPUT;
init_pi_tree ();
-
write_module ();
free_pi_tree (pi_root);
pi_root = NULL;
write_char ('\n');
--- 6041,6061 ----
/* Write the module itself. */
iomode = IO_OUTPUT;
+ /* Write the public part of the module. */
init_pi_tree ();
write_module ();
+ free_pi_tree (pi_root);
+ pi_root = NULL;
+ /* Now write the private part for submodules. */
+ write_char ('\n');
+ write_char ('\n');
+ init_pi_tree ();
+ invert_access = true;
+ write_module ();
free_pi_tree (pi_root);
pi_root = NULL;
+ invert_access = false;
write_char ('\n');
*************** use_iso_fortran_env_module (void)
*** 6732,6737 ****
--- 6758,6764 ----
/* Process a USE directive. */
+ static bool submodule_stmt;
static void
gfc_use_module (gfc_use_list *module)
*************** gfc_use_module (gfc_use_list *module)
*** 6888,6903 ****
gfc_fatal_error ("Can't USE the same %smodule we're building!",
p->state == COMP_SUBMODULE ? "sub" : "");
init_pi_tree ();
init_true_name_tree ();
-
read_module ();
-
free_true_name (true_name_root);
true_name_root = NULL;
free_pi_tree (pi_root);
pi_root = NULL;
XDELETEVEC (module_content);
module_content = NULL;
--- 6915,6941 ----
gfc_fatal_error ("Can't USE the same %smodule we're building!",
p->state == COMP_SUBMODULE ? "sub" : "");
+ /* Do the normal module read. */
init_pi_tree ();
init_true_name_tree ();
read_module ();
free_true_name (true_name_root);
true_name_root = NULL;
+ free_pi_tree (pi_root);
+ pi_root = NULL;
+ /* Read the private entities into submodules. */
+ if (gfc_state_stack->state == COMP_SUBMODULE
+ && submodule_stmt)
+ {
+ init_pi_tree ();
+ init_true_name_tree ();
+ read_module ();
+ free_true_name (true_name_root);
+ true_name_root = NULL;
free_pi_tree (pi_root);
pi_root = NULL;
+ }
XDELETEVEC (module_content);
module_content = NULL;
*************** rename_list_remove_duplicate (gfc_use_re
*** 6936,6948 ****
}
! /* Process all USE directives. */
void
! gfc_use_modules (void)
{
gfc_use_list *next, *seek, *last;
for (next = module_list; next; next = next->next)
{
bool non_intrinsic = next->non_intrinsic;
--- 6974,6990 ----
}
! /* Process all USE directives. 'using_ancestor_modules' flags up that
! the SUBMODULE statement is being processed and so all objects that
! are PRIVATE in the ancestor module must be read. */
void
! gfc_use_modules (bool using_ancestor_modules)
{
gfc_use_list *next, *seek, *last;
+ submodule_stmt = using_ancestor_modules;
+
for (next = module_list; next; next = next->next)
{
bool non_intrinsic = next->non_intrinsic;
Index: gcc/fortran/parse.c
===================================================================
*** gcc/fortran/parse.c (revision 226054)
--- gcc/fortran/parse.c (working copy)
*************** match_word_omp_simd (const char *str, ma
*** 103,118 ****
}
! /* Load symbols from all USE statements encountered in this scoping unit. */
static void
! use_modules (void)
{
gfc_error_buffer old_error;
gfc_push_error (&old_error);
gfc_buffer_error (false);
! gfc_use_modules ();
gfc_buffer_error (true);
gfc_pop_error (&old_error);
gfc_commit_symbols ();
--- 103,121 ----
}
! /* Load symbols from all USE statements encountered in this scoping unit.
! 'using_ancestor_modules' flags up that the SUBMODULE statement is
! being processed and so all objects that are PRIVATE in the ancestor
! module must be read. */
static void
! use_modules (bool using_ancestor_modules)
{
gfc_error_buffer old_error;
gfc_push_error (&old_error);
gfc_buffer_error (false);
! gfc_use_modules (using_ancestor_modules);
gfc_buffer_error (true);
gfc_pop_error (&old_error);
gfc_commit_symbols ();
*************** decode_specification_statement (void)
*** 167,173 ****
{
undo_new_statement ();
if (last_was_use_stmt)
! use_modules ();
}
match ("import", gfc_match_import, ST_IMPORT);
--- 170,176 ----
{
undo_new_statement ();
if (last_was_use_stmt)
! use_modules (false);
}
match ("import", gfc_match_import, ST_IMPORT);
*************** decode_statement (void)
*** 328,334 ****
}
if (last_was_use_stmt)
! use_modules ();
/* Try matching a data declaration or function declaration. The
input "REALFUNCTIONA(N)" can mean several things in different
--- 331,337 ----
}
if (last_was_use_stmt)
! use_modules (false);
/* Try matching a data declaration or function declaration. The
input "REALFUNCTIONA(N)" can mean several things in different
*************** verify_token_free (const char* token, in
*** 923,929 ****
gcc_assert (gfc_is_whitespace(c));
gfc_gobble_whitespace ();
if (last_was_use_stmt)
! use_modules ();
}
/* Get the next statement in free form source. */
--- 926,932 ----
gcc_assert (gfc_is_whitespace(c));
gfc_gobble_whitespace ();
if (last_was_use_stmt)
! use_modules (false);
}
/* Get the next statement in free form source. */
*************** verify_token_fixed (const char *token, i
*** 1077,1083 ****
return false;
}
if (last_was_use_stmt)
! use_modules ();
return true;
}
--- 1080,1086 ----
return false;
}
if (last_was_use_stmt)
! use_modules (false);
return true;
}
*************** parse_module (void)
*** 5321,5327 ****
inherits and to set (most) of the symbols as host associated. */
if (gfc_current_state () == COMP_SUBMODULE)
{
! use_modules ();
gfc_traverse_ns (gfc_current_ns, set_syms_host_assoc);
}
--- 5324,5330 ----
inherits and to set (most) of the symbols as host associated. */
if (gfc_current_state () == COMP_SUBMODULE)
{
! use_modules (true);
gfc_traverse_ns (gfc_current_ns, set_syms_host_assoc);
}
Index: gcc/fortran/trans-decl.c
===================================================================
*** gcc/fortran/trans-decl.c (revision 226054)
--- gcc/fortran/trans-decl.c (working copy)
*************** gfc_finish_var_decl (tree decl, gfc_symb
*** 596,601 ****
--- 596,606 ----
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. */
*************** gfc_finish_var_decl (tree decl, gfc_symb
*** 609,615 ****
/* 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_STATIC (decl) = 1;
}
--- 614,619 ----
*************** gfc_build_qualified_array (tree decl, gf
*** 837,845 ****
else
TREE_STATIC (token) = 1;
! if (sym->attr.use_assoc || sym->attr.access != ACCESS_PRIVATE ||
! sym->attr.public_used)
! TREE_PUBLIC (token) = 1;
}
else
{
--- 841,853 ----
else
TREE_STATIC (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
{
*************** get_proc_pointer_decl (gfc_symbol *sym)
*** 1747,1755 ****
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_STATIC (decl) = 1;
}
--- 1755,1766 ----
else if (sym->module && sym->ns->proc_name->attr.flavor == FL_MODULE)
{
/* This is the declaration of a module variable. */
! 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;
}
Index: gcc/testsuite/gfortran.dg/public_private_module_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/public_private_module_2.f90 (revision
226054)
--- gcc/testsuite/gfortran.dg/public_private_module_2.f90 (working copy)
***************
*** 18,29 ****
integer, bind(C,name='') :: qq
end module mod
! { dg-final { scan-assembler "__mod_MOD_aa" } }
! ! { dg-final { scan-assembler-not "iii" } }
! { 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 "nnn" } }
! { dg-final { scan-assembler "oo" } }
! { dg-final { scan-assembler "__mod_MOD_qq" } }
--- 18,32 ----
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" { xfail *-*-* } } }
! { dg-final { scan-assembler "jj" } }
! { dg-final { scan-assembler "lll" } }
! { dg-final { scan-assembler-not "kk" } }
! ! { dg-final { scan-assembler-not "mmmm" { xfail *-*-* } } }
! { dg-final { scan-assembler "nnn" } }
! { dg-final { scan-assembler "oo" } }
! { dg-final { scan-assembler "__mod_MOD_qq" } }
Index: gcc/testsuite/gfortran.dg/public_private_module_6.f90
===================================================================
*** gcc/testsuite/gfortran.dg/public_private_module_6.f90 (revision
226054)
--- gcc/testsuite/gfortran.dg/public_private_module_6.f90 (working copy)
*************** module m
*** 11,14 ****
integer, save :: aaaa
end module m
! ! { dg-final { scan-assembler-not "aaaa" } }
--- 11,17 ----
integer, save :: aaaa
end module m
! ! 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 *-*-* } } }
Index: gcc/testsuite/gfortran.dg/submodule_10.f08
===================================================================
*** gcc/testsuite/gfortran.dg/submodule_10.f08 (revision 0)
--- gcc/testsuite/gfortran.dg/submodule_10.f08 (working copy)
***************
*** 0 ****
--- 1,170 ----
+ ! { dg-do compile }
+ !
+ ! Checks that PRIVATE enities are visible to submodules.
+ !
+ ! Contributed by Salvatore Filippone <salvatore.filipp...@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
+
+
