OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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

2015-07-02  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/52846
	* decl.c (get_proc_name): Make a partially populated interface
	symbol to carry the characteristics of a module procedure and
	its result.
	(variable_decl): Declarations of dummies or results in the
	abreviated form of module procedure is an error.
	(gfc_match_import): IMPORT is not permitted in the interface
	declaration of module procedures.
	(match_attr_spec): Submodule variables have implicit save
	attribute for F2008 onwards.
	(gfc_match_prefix): Add 'module' as the a prefix and set the
	module_procedure attribute.
	(gfc_match_formal_arglist): For a module procedure keep the
	interface formal_arglist from the interface, match new the
	formal arguments and then compare the number and names of each.
	(gfc_match_procedure): Add case COMP_SUBMODULE.
	(gfc_match_function_decl, gfc_match_subroutine_decl): Set the
	module_procedure attribute.
	(gfc_match_entry, gfc_match_end):  Add case COMP_SUBMODULE. If
	attr abr_modproc_decl is set, switch the message accordingly
	for subroutines and functions.
	(gfc_match_submod_proc): New function to match the abbreviated
	style of submodule declaration.
	* gfortran.h : Add ST_SUBMODULE and ST_END_SUBMODULE. Add the
	attribute bits 'used_in_submodule' and 'module_procedure'. Add
	the bit field 'abr_modproc_decl' to gfc_symbol. Add prototypes
	for 'gfc_copy_dummy_sym', 'gfc_check_dummy_characteristics' and
	'gfc_check_result_characteristics'.
	* interface.c : Add the prefix 'gfc_' to the names of functions
	'check_dummy(result)_characteristics' and all their references.
	* match.h : Add prototype for 'gfc_match_submod_proc' and
	'gfc_match_submodule'.
	(check_sym_interfaces): A module procedure is not an error in
	a module procedure statment in a generic interface.
	* module.c (gfc_match_submodule): New function. Add handling
	for the 'module_procedure' attribute bit.
	(gfc_use_module): Make sure that a submodule cannot use itself.
	* parse.c (decode_statement): Set attr has_'import_set' for
	the interface declaration of module procedures. Handle a match
	occurring in 'gfc_match_submod_proc' and a match for
	'submodule'.
	(gfc_enclosing_unit): Include the state COMP_SUBMODULE.
	(gfc_ascii_statement): Add END SUBMODULE.
	(accept_statement): Add ST_SUBMODULE.
	(parse_spec): Disallow statement functions in a submodule
	specification part.
	(parse_contained): Add ST_END_SUBMODULE and COMP_SUBMODULE
	twice each.
	(get_modproc_result): Copy the result symbol of the interface.
	(parse_progunit): Call it.
	(set_syms_host_assoc): Make symbols from the ancestor module
	and submodules use associated, as required by the standard and
	set all private components public. Module procedures 'external'
	attribute bit is reset and the 'used_in_submodule' bit is set.
	(parse_module): If this is a submodule, use the ancestor module
	and submodules. Traverse the namespace, calling
	'set_syms_host_assoc'. Add ST_END_SUBMODULE and COMP_SUBMODULE.
	* parse.h : Add COMP_SUBMODULE.
	* primary.c (match_variable): Add COMP_SUBMODULE.
	* resolve.c (compare_fsyms): New function to compare the dummy
	characteristics of a module procedure with its interface.
	(resolve_fl_procedure): Compare the procedure, result and dummy
	characteristics of a module_procedure with its interface, using
	'compare_fsyms' for the dummy arguments.
	* symbol.c (gfc_add_procedure): Suppress the check for existing
	procedures in the case of a module procedure.
	(gfc_add_explicit_interface): Skip checks that must fail for
	module procedures.
	(gfc_add_type): Allow a new type to be added to module
	procedures, their results or their dummy arguments.
	(gfc_copy_dummy_sym): New function to generate new dummy args
	and copy the characteristics from the interface.
	* trans-decl.c (gfc_sym_mangled_function_id): Module procedures
	must always have their names mangled as if they are symbols
	coming from a declaration in a module.
	(gfc_get_symbol_decl): Add 'used_in_submodule' to the assert.
	(gfc_finish_var_decl): Symbols with the 'used_in_submodule' bit
	set are set DECL_EXTERNAL as if they were use associated.

2015-07-02  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/52846
	* gfortran.dg/submodule_1.f90: New test
	* gfortran.dg/submodule_2.f90: New test
	* gfortran.dg/submodule_3.f90: New test
	* gfortran.dg/submodule_4.f90: New test
	* gfortran.dg/submodule_5.f90: New test
	* gfortran.dg/submodule_6.f90: New test
	* gfortran.dg/submodule_7.f90: New test

From-SVN: r225354
This commit is contained in:
Paul Thomas 2015-07-02 20:39:56 +00:00
parent fbb22910cf
commit 4668d6f9c0
20 changed files with 1444 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

83
gcc/fortran/ChangeLog
View File

@ -1,3 +1,84 @@
2015-07-02 Paul Thomas <pault@gcc.gnu.org>
PR fortran/52846
* decl.c (get_proc_name): Make a partially populated interface
symbol to carry the characteristics of a module procedure and
its result.
(variable_decl): Declarations of dummies or results in the
abreviated form of module procedure is an error.
(gfc_match_import): IMPORT is not permitted in the interface
declaration of module procedures.
(match_attr_spec): Submodule variables have implicit save
attribute for F2008 onwards.
(gfc_match_prefix): Add 'module' as the a prefix and set the
module_procedure attribute.
(gfc_match_formal_arglist): For a module procedure keep the
interface formal_arglist from the interface, match new the
formal arguments and then compare the number and names of each.
(gfc_match_procedure): Add case COMP_SUBMODULE.
(gfc_match_function_decl, gfc_match_subroutine_decl): Set the
module_procedure attribute.
(gfc_match_entry, gfc_match_end): Add case COMP_SUBMODULE. If
attr abr_modproc_decl is set, switch the message accordingly
for subroutines and functions.
(gfc_match_submod_proc): New function to match the abbreviated
style of submodule declaration.
* gfortran.h : Add ST_SUBMODULE and ST_END_SUBMODULE. Add the
attribute bits 'used_in_submodule' and 'module_procedure'. Add
the bit field 'abr_modproc_decl' to gfc_symbol. Add prototypes
for 'gfc_copy_dummy_sym', 'gfc_check_dummy_characteristics' and
'gfc_check_result_characteristics'.
* interface.c : Add the prefix 'gfc_' to the names of functions
'check_dummy(result)_characteristics' and all their references.
* match.h : Add prototype for 'gfc_match_submod_proc' and
'gfc_match_submodule'.
(check_sym_interfaces): A module procedure is not an error in
a module procedure statment in a generic interface.
* module.c (gfc_match_submodule): New function. Add handling
for the 'module_procedure' attribute bit.
(gfc_use_module): Make sure that a submodule cannot use itself.
* parse.c (decode_statement): Set attr has_'import_set' for
the interface declaration of module procedures. Handle a match
occurring in 'gfc_match_submod_proc' and a match for
'submodule'.
(gfc_enclosing_unit): Include the state COMP_SUBMODULE.
(gfc_ascii_statement): Add END SUBMODULE.
(accept_statement): Add ST_SUBMODULE.
(parse_spec): Disallow statement functions in a submodule
specification part.
(parse_contained): Add ST_END_SUBMODULE and COMP_SUBMODULE
twice each.
(get_modproc_result): Copy the result symbol of the interface.
(parse_progunit): Call it.
(set_syms_host_assoc): Make symbols from the ancestor module
and submodules use associated, as required by the standard and
set all private components public. Module procedures 'external'
attribute bit is reset and the 'used_in_submodule' bit is set.
(parse_module): If this is a submodule, use the ancestor module
and submodules. Traverse the namespace, calling
'set_syms_host_assoc'. Add ST_END_SUBMODULE and COMP_SUBMODULE.
* parse.h : Add COMP_SUBMODULE.
* primary.c (match_variable): Add COMP_SUBMODULE.
* resolve.c (compare_fsyms): New function to compare the dummy
characteristics of a module procedure with its interface.
(resolve_fl_procedure): Compare the procedure, result and dummy
characteristics of a module_procedure with its interface, using
'compare_fsyms' for the dummy arguments.
* symbol.c (gfc_add_procedure): Suppress the check for existing
procedures in the case of a module procedure.
(gfc_add_explicit_interface): Skip checks that must fail for
module procedures.
(gfc_add_type): Allow a new type to be added to module
procedures, their results or their dummy arguments.
(gfc_copy_dummy_sym): New function to generate new dummy args
and copy the characteristics from the interface.
* trans-decl.c (gfc_sym_mangled_function_id): Module procedures
must always have their names mangled as if they are symbols
coming from a declaration in a module.
(gfc_get_symbol_decl): Add 'used_in_submodule' to the assert.
(gfc_finish_var_decl): Symbols with the 'used_in_submodule' bit
set are set DECL_EXTERNAL as if they were use associated.
2015-07-02 Steven G. Kargl <kargl@gcc.gnu.org>
PR fortran/56520
@ -98,7 +179,7 @@
the source expression is an array-constructor which is
fixed to be one-based.
(retrieve_last_ref): Extracted from gfc_array_allocate().
(gfc_array_allocate): Enable allocate(array, source=
(gfc_array_allocate): Enable allocate(array, source=
array_expression) as specified by F2008:C633.
(gfc_conv_expr_descriptor): Add class tree expression
into the saved descriptor for class arrays.

238
gcc/fortran/decl.c
View File

@ -903,7 +903,35 @@ get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry)
sym = *result;
if (sym && !sym->gfc_new && gfc_current_state () != COMP_INTERFACE)
if (sym->attr.module_procedure
&& sym->attr.if_source == IFSRC_IFBODY)
{
/* Create a partially populated interface symbol to carry the
characteristics of the procedure and the result. */
sym->ts.interface = gfc_new_symbol (name, sym->ns);
gfc_add_type (sym->ts.interface, &(sym->ts),
&gfc_current_locus);
gfc_copy_attr (&sym->ts.interface->attr, &sym->attr, NULL);
if (sym->attr.dimension)
sym->ts.interface->as = gfc_copy_array_spec (sym->as);
/* Ideally, at this point, a copy would be made of the formal
arguments and their namespace. However, this does not appear
to be necessary, albeit at the expense of not being able to
use gfc_compare_interfaces directly. */
if (sym->result && sym->result != sym)
{
sym->ts.interface->result = sym->result;
sym->result = NULL;
}
else if (sym->result)
{
sym->ts.interface->result = sym->ts.interface;
}
}
else if (sym && !sym->gfc_new
&& gfc_current_state () != COMP_INTERFACE)
{
/* Trap another encompassed procedure with the same name. All
these conditions are necessary to avoid picking up an entry
@ -1918,6 +1946,23 @@ variable_decl (int elem)
}
}
/* The dummy arguments and result of the abreviated form of MODULE
PROCEDUREs, used in SUBMODULES should not be redefined. */
if (gfc_current_ns->proc_name
&& gfc_current_ns->proc_name->abr_modproc_decl)
{
gfc_find_symbol (name, gfc_current_ns, 1, &sym);
if (sym != NULL && (sym->attr.dummy || sym->attr.result))
{
m = MATCH_ERROR;
gfc_error ("'%s' at %C is a redefinition of the declaration "
"in the corresponding interface for MODULE "
"PROCEDURE '%s'", sym->name,
gfc_current_ns->proc_name->name);
goto cleanup;
}
}
/* If this symbol has already shown up in a Cray Pointer declaration,
and this is not a component declaration,
then we want to set the type & bail out. */
@ -3262,6 +3307,13 @@ gfc_match_import (void)
return MATCH_ERROR;
}
if (gfc_current_ns->proc_name->attr.module_procedure)
{
gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
"in a module procedure interface body");
return MATCH_ERROR;
}
if (!gfc_notify_std (GFC_STD_F2003, "IMPORT statement at %C"))
return MATCH_ERROR;
@ -3925,7 +3977,9 @@ match_attr_spec (void)
}
/* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
if (gfc_current_state () == COMP_MODULE && !current_attr.save
if ((gfc_current_state () == COMP_MODULE
|| gfc_current_state () == COMP_SUBMODULE)
&& !current_attr.save
&& (gfc_option.allow_std & GFC_STD_F2008) != 0)
current_attr.save = SAVE_IMPLICIT;
@ -4513,6 +4567,22 @@ 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;
@ -4550,9 +4620,24 @@ gfc_match_formal_arglist (gfc_symbol *progname, int st_flag, int null_flag)
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_symbol *sym;
match m;
gfc_formal_arglist *formal = NULL;
head = tail = NULL;
/* Keep the interface formal argument list and null it so that the
matching for the new declaration can be done. The numbers and
names of the arguments are checked here. The interface formal
arguments are retained in formal_arglist and the characteristics
are compared in resolve.c(resolve_fl_procedure). See the remark
in get_proc_name about the eventual need to copy the formal_arglist
and populate the formal namespace of the interface symbol. */
if (progname->attr.module_procedure
&& progname->attr.host_assoc)
{
formal = progname->formal;
progname->formal = NULL;
}
if (gfc_match_char ('(') != MATCH_YES)
{
if (null_flag)
@ -4658,6 +4743,24 @@ ok:
goto cleanup;
}
if (formal)
{
for (p = formal, q = head; p && q; p = p->next, q = q->next)
{
if ((p->next != NULL && q->next == NULL)
|| (p->next == NULL && q->next != NULL))
gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
"formal arguments at %C");
else if ((p->sym == NULL && q->sym == NULL)
|| strcmp (p->sym->name, q->sym->name) == 0)
continue;
else
gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
"argument names (%s/%s) at %C",
p->sym->name, q->sym->name);
}
}
return MATCH_YES;
cleanup:
@ -5271,6 +5374,7 @@ gfc_match_procedure (void)
case COMP_NONE:
case COMP_PROGRAM:
case COMP_MODULE:
case COMP_SUBMODULE:
case COMP_SUBROUTINE:
case COMP_FUNCTION:
case COMP_BLOCK:
@ -5309,7 +5413,8 @@ do_warn_intrinsic_shadow (const gfc_symbol* sym, bool func)
bool in_module;
in_module = (gfc_state_stack->previous
&& gfc_state_stack->previous->state == COMP_MODULE);
&& (gfc_state_stack->previous->state == COMP_MODULE
|| gfc_state_stack->previous->state == COMP_SUBMODULE));
gfc_warn_intrinsic_shadow (sym, in_module, func);
}
@ -5348,12 +5453,16 @@ gfc_match_function_decl (void)
gfc_current_locus = old_loc;
return MATCH_NO;
}
if (get_proc_name (name, &sym, false))
return MATCH_ERROR;
if (add_hidden_procptr_result (sym))
sym = sym->result;
if (current_attr.module_procedure)
sym->attr.module_procedure = 1;
gfc_new_block = sym;
m = gfc_match_formal_arglist (sym, 0, 0);
@ -5547,6 +5656,9 @@ gfc_match_entry (void)
case COMP_MODULE:
gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
break;
case COMP_SUBMODULE:
gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
break;
case COMP_BLOCK_DATA:
gfc_error ("ENTRY statement at %C cannot appear within "
"a BLOCK DATA");
@ -5791,6 +5903,9 @@ gfc_match_subroutine (void)
the symbol existed before. */
sym->declared_at = gfc_current_locus;
if (current_attr.module_procedure)
sym->attr.module_procedure = 1;
if (add_hidden_procptr_result (sym))
sym = sym->result;
@ -6114,6 +6229,7 @@ gfc_match_end (gfc_statement *st)
match m;
gfc_namespace *parent_ns, *ns, *prev_ns;
gfc_namespace **nsp;
bool abreviated_modproc_decl;
old_loc = gfc_current_locus;
if (gfc_match ("end") != MATCH_YES)
@ -6142,6 +6258,10 @@ gfc_match_end (gfc_statement *st)
break;
}
abreviated_modproc_decl
= gfc_current_block ()
&& gfc_current_block ()->abr_modproc_decl;
switch (state)
{
case COMP_NONE:
@ -6153,13 +6273,19 @@ gfc_match_end (gfc_statement *st)
case COMP_SUBROUTINE:
*st = ST_END_SUBROUTINE;
if (!abreviated_modproc_decl)
target = " subroutine";
else
target = " procedure";
eos_ok = !contained_procedure ();
break;
case COMP_FUNCTION:
*st = ST_END_FUNCTION;
if (!abreviated_modproc_decl)
target = " function";
else
target = " procedure";
eos_ok = !contained_procedure ();
break;
@ -6175,6 +6301,12 @@ gfc_match_end (gfc_statement *st)
eos_ok = 1;
break;
case COMP_SUBMODULE:
*st = ST_END_SUBMODULE;
target = " submodule";
eos_ok = 1;
break;
case COMP_INTERFACE:
*st = ST_END_INTERFACE;
target = " interface";
@ -6259,7 +6391,8 @@ gfc_match_end (gfc_statement *st)
{
if (!gfc_notify_std (GFC_STD_F2008, "END statement "
"instead of %s statement at %L",
gfc_ascii_statement(*st), &old_loc))
abreviated_modproc_decl ? "END PROCEDURE"
: gfc_ascii_statement(*st), &old_loc))
goto cleanup;
}
else if (!eos_ok)
@ -6276,8 +6409,8 @@ gfc_match_end (gfc_statement *st)
/* Verify that we've got the sort of end-block that we're expecting. */
if (gfc_match (target) != MATCH_YES)
{
gfc_error ("Expecting %s statement at %L", gfc_ascii_statement (*st),
&old_loc);
gfc_error ("Expecting %s statement at %L", abreviated_modproc_decl
? "END PROCEDURE" : gfc_ascii_statement(*st), &old_loc);
goto cleanup;
}
@ -7417,6 +7550,99 @@ syntax:
}
/* Match a module procedure statement in a submodule. */
match
gfc_match_submod_proc (void)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_symbol *sym, *fsym;
match m;
gfc_formal_arglist *formal, *head, *tail;
if (gfc_current_state () != COMP_CONTAINS
|| !(gfc_state_stack->previous
&& gfc_state_stack->previous->state == COMP_SUBMODULE))
return MATCH_NO;
m = gfc_match (" module% procedure% %n", name);
if (m != MATCH_YES)
return m;
if (!gfc_notify_std (GFC_STD_F2008, "MODULE PROCEDURE declaration "
"at %C"))
return MATCH_ERROR;
if (get_proc_name (name, &sym, false))
return MATCH_ERROR;
/* Make sure that the result field is appropriately filled, even though
the result symbol will be replaced later on. */
if (sym->ts.interface->attr.function)
{
if (sym->ts.interface->result
&& sym->ts.interface->result != sym->ts.interface)
sym->result= sym->ts.interface->result;
else
sym->result = sym;
}
/* Set declared_at as it might point to, e.g., a PUBLIC statement, if
the symbol existed before. */
sym->declared_at = gfc_current_locus;
if (!sym->attr.module_procedure)
return MATCH_ERROR;
/* Signal match_end to expect "end procedure". */
sym->abr_modproc_decl = 1;
/* Change from IFSRC_IFBODY coming from the interface declaration. */
sym->attr.if_source = IFSRC_DECL;
gfc_new_block = sym;
/* Make a new formal arglist with the symbols in the procedure
namespace. */
head = tail = NULL;
for (formal = sym->formal; formal && formal->sym; formal = formal->next)
{
if (formal == sym->formal)
head = tail = gfc_get_formal_arglist ();
else
{
tail->next = gfc_get_formal_arglist ();
tail = tail->next;
}
if (gfc_copy_dummy_sym (&fsym, formal->sym, 0))
goto cleanup;
tail->sym = fsym;
gfc_set_sym_referenced (fsym);
}
/* The dummy symbols get cleaned up, when the formal_namespace of the
interface declaration is cleared. This allows us to add the
explicit interface as is done for other type of procedure. */
if (!gfc_add_explicit_interface (sym, IFSRC_DECL, head,
&gfc_current_locus))
return MATCH_ERROR;
if (gfc_match_eos () != MATCH_YES)
{
gfc_syntax_error (ST_MODULE_PROC);
return MATCH_ERROR;
}
return MATCH_YES;
cleanup:
gfc_free_formal_arglist (head);
return MATCH_ERROR;
}
/* Match a module procedure statement. Note that we have to modify
symbols in the parent's namespace because the current one was there
to receive symbols that are in an interface's formal argument list. */

43
gcc/fortran/gfortran.h
View File

@ -201,19 +201,19 @@ typedef enum
ST_CALL, ST_CASE, ST_CLOSE, ST_COMMON, ST_CONTINUE, ST_CONTAINS, ST_CYCLE,
ST_DATA, ST_DATA_DECL, ST_DEALLOCATE, ST_DO, ST_ELSE, ST_ELSEIF,
ST_ELSEWHERE, ST_END_ASSOCIATE, ST_END_BLOCK, ST_END_BLOCK_DATA,
ST_ENDDO, ST_IMPLIED_ENDDO,
ST_END_FILE, ST_FINAL, ST_FLUSH, ST_END_FORALL, ST_END_FUNCTION, ST_ENDIF,
ST_END_INTERFACE, ST_END_MODULE, ST_END_PROGRAM, ST_END_SELECT,
ST_END_SUBROUTINE, ST_END_WHERE, ST_END_TYPE, ST_ENTRY, ST_EQUIVALENCE,
ST_ERROR_STOP, ST_EXIT, ST_FORALL, ST_FORALL_BLOCK, ST_FORMAT, ST_FUNCTION,
ST_GOTO, ST_IF_BLOCK, ST_IMPLICIT, ST_IMPLICIT_NONE, ST_IMPORT,
ST_INQUIRE, ST_INTERFACE, ST_SYNC_ALL, ST_SYNC_MEMORY, ST_SYNC_IMAGES,
ST_PARAMETER, ST_MODULE, ST_MODULE_PROC, ST_NAMELIST, ST_NULLIFY, ST_OPEN,
ST_PAUSE, ST_PRIVATE, ST_PROGRAM, ST_PUBLIC, ST_READ, ST_RETURN, ST_REWIND,
ST_STOP, ST_SUBROUTINE, ST_TYPE, ST_USE, ST_WHERE_BLOCK, ST_WHERE, ST_WAIT,
ST_WRITE, ST_ASSIGNMENT, ST_POINTER_ASSIGNMENT, ST_SELECT_CASE, ST_SEQUENCE,
ST_SIMPLE_IF, ST_STATEMENT_FUNCTION, ST_DERIVED_DECL, ST_LABEL_ASSIGNMENT,
ST_ENUM, ST_ENUMERATOR, ST_END_ENUM, ST_SELECT_TYPE, ST_TYPE_IS, ST_CLASS_IS,
ST_ENDDO, ST_IMPLIED_ENDDO, ST_END_FILE, ST_FINAL, ST_FLUSH, ST_END_FORALL,
ST_END_FUNCTION, ST_ENDIF, ST_END_INTERFACE, ST_END_MODULE, ST_END_SUBMODULE,
ST_END_PROGRAM, ST_END_SELECT, ST_END_SUBROUTINE, ST_END_WHERE, ST_END_TYPE,
ST_ENTRY, ST_EQUIVALENCE, ST_ERROR_STOP, ST_EXIT, ST_FORALL, ST_FORALL_BLOCK,
ST_FORMAT, ST_FUNCTION, ST_GOTO, ST_IF_BLOCK, ST_IMPLICIT, ST_IMPLICIT_NONE,
ST_IMPORT, ST_INQUIRE, ST_INTERFACE, ST_SYNC_ALL, ST_SYNC_MEMORY,
ST_SYNC_IMAGES, ST_PARAMETER, ST_MODULE, ST_SUBMODULE, ST_MODULE_PROC,
ST_NAMELIST, ST_NULLIFY, ST_OPEN, ST_PAUSE, ST_PRIVATE, ST_PROGRAM, ST_PUBLIC,
ST_READ, ST_RETURN, ST_REWIND, ST_STOP, ST_SUBROUTINE, ST_TYPE, ST_USE,
ST_WHERE_BLOCK, ST_WHERE, ST_WAIT, ST_WRITE, ST_ASSIGNMENT,
ST_POINTER_ASSIGNMENT, ST_SELECT_CASE, ST_SEQUENCE, ST_SIMPLE_IF,
ST_STATEMENT_FUNCTION, ST_DERIVED_DECL, ST_LABEL_ASSIGNMENT, ST_ENUM,
ST_ENUMERATOR, ST_END_ENUM, ST_SELECT_TYPE, ST_TYPE_IS, ST_CLASS_IS,
ST_OACC_PARALLEL_LOOP, ST_OACC_END_PARALLEL_LOOP, ST_OACC_PARALLEL,
ST_OACC_END_PARALLEL, ST_OACC_KERNELS, ST_OACC_END_KERNELS, ST_OACC_DATA,
ST_OACC_END_DATA, ST_OACC_HOST_DATA, ST_OACC_END_HOST_DATA, ST_OACC_LOOP,
@ -751,6 +751,9 @@ typedef struct
unsigned data:1, /* Symbol is named in a DATA statement. */
is_protected:1, /* Symbol has been marked as protected. */
use_assoc:1, /* Symbol has been use-associated. */
used_in_submodule:1, /* Symbol has been use-associated in a
submodule. Needed since these entities must
be set host associated to be compliant. */
use_only:1, /* Symbol has been use-associated, with ONLY. */
use_rename:1, /* Symbol has been use-associated and renamed. */
imported:1, /* Symbol has been associated by IMPORT. */
@ -779,6 +782,11 @@ typedef struct
unsigned sequence:1, elemental:1, pure:1, recursive:1;
unsigned unmaskable:1, masked:1, contained:1, mod_proc:1, abstract:1;
/* Set if this is a module function or subroutine. Note that it is an
attribute because it appears as a prefix in the declaration like
PURE, etc.. */
unsigned module_procedure:1;
/* Set if a (public) symbol [e.g. generic name] exposes this symbol,
which is relevant for private module procedures. */
unsigned public_used:1;
@ -1459,6 +1467,9 @@ typedef struct gfc_symbol
unsigned forall_index:1;
/* Used to avoid multiple resolutions of a single symbol. */
unsigned resolved:1;
/* Set if this is a module function or subroutine with the
abreviated declaration in a submodule. */
unsigned abr_modproc_decl:1;
int refs;
struct gfc_namespace *ns; /* namespace containing this symbol */
@ -2786,7 +2797,7 @@ bool gfc_add_type (gfc_symbol *, gfc_typespec *, locus *);
void gfc_clear_attr (symbol_attribute *);
bool gfc_missing_attr (symbol_attribute *, locus *);
bool gfc_copy_attr (symbol_attribute *, symbol_attribute *, locus *);
int gfc_copy_dummy_sym (gfc_symbol **, gfc_symbol *, int);
bool gfc_add_component (gfc_symbol *, const char *, gfc_component **);
gfc_symbol *gfc_use_derived (gfc_symbol *);
gfc_symtree *gfc_use_derived_tree (gfc_symtree *);
@ -3087,6 +3098,10 @@ bool gfc_ref_dimen_size (gfc_array_ref *, int dimen, mpz_t *, mpz_t *);
void gfc_free_interface (gfc_interface *);
int gfc_compare_derived_types (gfc_symbol *, gfc_symbol *);
int gfc_compare_types (gfc_typespec *, gfc_typespec *);
bool gfc_check_dummy_characteristics (gfc_symbol *, gfc_symbol *,
bool, char *, int);
bool gfc_check_result_characteristics (gfc_symbol *, gfc_symbol *,
char *, int);
int gfc_compare_interfaces (gfc_symbol*, gfc_symbol*, const char *, int, int,
char *, int, const char *, const char *);
void gfc_check_interfaces (gfc_namespace *);

24
gcc/fortran/interface.c
View File

@ -1066,9 +1066,10 @@ symbol_rank (gfc_symbol *sym)
/* Check if the characteristics of two dummy arguments match,
cf. F08:12.3.2. */
static bool
check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
bool type_must_agree, char *errmsg, int err_len)
bool
gfc_check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
bool type_must_agree, char *errmsg,
int err_len)
{
if (s1 == NULL || s2 == NULL)
return s1 == s2 ? true : false;
@ -1275,8 +1276,8 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
/* Check if the characteristics of two function results match,
cf. F08:12.3.3. */
static bool
check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2,
bool
gfc_check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2,
char *errmsg, int err_len)
{
gfc_symbol *r1, *r2;
@ -1472,8 +1473,8 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
if (s1->attr.function && s2->attr.function)
{
/* If both are functions, check result characteristics. */
if (!check_result_characteristics (s1, s2, errmsg, err_len)
|| !check_result_characteristics (s2, s1, errmsg, err_len))
if (!gfc_check_result_characteristics (s1, s2, errmsg, err_len)
|| !gfc_check_result_characteristics (s2, s1, errmsg, err_len))
return 0;
}
@ -1533,7 +1534,7 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
if (strict_flag)
{
/* Check all characteristics. */
if (!check_dummy_characteristics (f1->sym, f2->sym, true,
if (!gfc_check_dummy_characteristics (f1->sym, f2->sym, true,
errmsg, err_len))
return 0;
}
@ -1710,6 +1711,7 @@ check_sym_interfaces (gfc_symbol *sym)
for (p = sym->generic; p; p = p->next)
{
if (p->sym->attr.mod_proc
&& !p->sym->attr.module_procedure
&& (p->sym->attr.if_source != IFSRC_DECL
|| p->sym->attr.procedure))
{
@ -4241,8 +4243,8 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
return false;
}
if (!check_result_characteristics (proc_target, old_target, err,
sizeof(err)))
if (!gfc_check_result_characteristics (proc_target, old_target,
err, sizeof(err)))
{
gfc_error ("Result mismatch for the overriding procedure "
"%qs at %L: %s", proc->name, &where, err);
@ -4293,7 +4295,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
}
check_type = proc_pass_arg != argpos && old_pass_arg != argpos;
if (!check_dummy_characteristics (proc_formal->sym, old_formal->sym,
if (!gfc_check_dummy_characteristics (proc_formal->sym, old_formal->sym,
check_type, err, sizeof(err)))
{
gfc_error ("Argument mismatch for the overriding procedure "

2
gcc/fortran/match.h
View File

@ -203,6 +203,7 @@ match gfc_match_generic (void);
match gfc_match_function_decl (void);
match gfc_match_entry (void);
match gfc_match_subroutine (void);
match gfc_match_submod_proc (void);
match gfc_match_derived_decl (void);
match gfc_match_final_decl (void);
@ -291,6 +292,7 @@ match gfc_match_expr (gfc_expr **);
/* module.c. */
match gfc_match_use (void);
match gfc_match_submodule (void);
void gfc_use_modules (void);
#endif /* GFC_MATCH_H */

75
gcc/fortran/module.c
View File

@ -716,6 +716,67 @@ cleanup:
}
/* Match a SUBMODULE statement. */
match
gfc_match_submodule (void)
{
match m;
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_use_list *use_list;
if (!gfc_notify_std (GFC_STD_F2008, "SUBMODULE declaration at %C"))
return MATCH_ERROR;
gfc_new_block = NULL;
gcc_assert (module_list == NULL);
if (gfc_match_char ('(') != MATCH_YES)
goto syntax;
while (1)
{
m = gfc_match (" %n", name);
if (m != MATCH_YES)
goto syntax;
use_list = gfc_get_use_list ();
use_list->module_name = gfc_get_string (name);
use_list->where = gfc_current_locus;
if (module_list)
{
gfc_use_list *last = module_list;
while (last->next)
last = last->next;
last->next = use_list;
}
else
module_list = use_list;
if (gfc_match_char (')') == MATCH_YES)
break;
if (gfc_match_char (':') != MATCH_YES)
goto syntax;
}
m = gfc_match (" %s%t", &gfc_new_block);
if (m != MATCH_YES)
goto syntax;
if (!gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
gfc_new_block->name, NULL))
return MATCH_ERROR;
return MATCH_YES;
syntax:
gfc_error ("Syntax error in SUBMODULE statement at %C");
return MATCH_ERROR;
}
/* Given a name and a number, inst, return the inst name
under which to load this symbol. Returns NULL if this
symbol shouldn't be loaded. If inst is zero, returns
@ -1887,7 +1948,7 @@ typedef enum
AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION,
AB_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_CONTIGUOUS, AB_CLASS_POINTER,
AB_IMPLICIT_PURE, AB_ARTIFICIAL, AB_UNLIMITED_POLY, AB_OMP_DECLARE_TARGET,
AB_ARRAY_OUTER_DEPENDENCY
AB_ARRAY_OUTER_DEPENDENCY, AB_MODULE_PROCEDURE
}
ab_attribute;
@ -1944,6 +2005,7 @@ static const mstring attr_bits[] =
minit ("UNLIMITED_POLY", AB_UNLIMITED_POLY),
minit ("OMP_DECLARE_TARGET", AB_OMP_DECLARE_TARGET),
minit ("ARRAY_OUTER_DEPENDENCY", AB_ARRAY_OUTER_DEPENDENCY),
minit ("MODULE_PROCEDURE", AB_MODULE_PROCEDURE),
minit (NULL, -1)
};
@ -2126,6 +2188,8 @@ mio_symbol_attribute (symbol_attribute *attr)
MIO_NAME (ab_attribute) (AB_OMP_DECLARE_TARGET, attr_bits);
if (attr->array_outer_dependency)
MIO_NAME (ab_attribute) (AB_ARRAY_OUTER_DEPENDENCY, attr_bits);
if (attr->module_procedure)
MIO_NAME (ab_attribute) (AB_MODULE_PROCEDURE, attr_bits);
mio_rparen ();
@ -2295,6 +2359,9 @@ mio_symbol_attribute (symbol_attribute *attr)
case AB_ARRAY_OUTER_DEPENDENCY:
attr->array_outer_dependency =1;
break;
case AB_MODULE_PROCEDURE:
attr->module_procedure =1;
break;
}
}
}
@ -6757,8 +6824,10 @@ gfc_use_module (gfc_use_list *module)
/* Make sure we're not reading the same module that we may be building. */
for (p = gfc_state_stack; p; p = p->previous)
if (p->state == COMP_MODULE && strcmp (p->sym->name, module_name) == 0)
gfc_fatal_error ("Can't USE the same module we're building!");
if ((p->state == COMP_MODULE || p->state == COMP_SUBMODULE)
&& strcmp (p->sym->name, module_name) == 0)
gfc_fatal_error ("Can't USE the same %smodule we're building!",
p->state == COMP_SUBMODULE ? "sub" : "");
init_pi_tree ();
init_true_name_tree ();

120
gcc/fortran/parse.c
View File

@ -369,6 +369,16 @@ decode_statement (void)
gfc_undo_symbols ();
gfc_current_locus = old_locus;
if (gfc_match_submod_proc () == MATCH_YES)
{
if (gfc_new_block->attr.subroutine)
return ST_SUBROUTINE;
else if (gfc_new_block->attr.function)
return ST_FUNCTION;
}
gfc_undo_symbols ();
gfc_current_locus = old_locus;
/* Check for the IF, DO, SELECT, WHERE, FORALL, CRITICAL, BLOCK and ASSOCIATE
statements, which might begin with a block label. The match functions for
these statements are unusual in that their keyword is not seen before
@ -522,6 +532,7 @@ decode_statement (void)
match ("sequence", gfc_match_eos, ST_SEQUENCE);
match ("stop", gfc_match_stop, ST_STOP);
match ("save", gfc_match_save, ST_ATTR_DECL);
match ("submodule", gfc_match_submodule, ST_SUBMODULE);
match ("sync all", gfc_match_sync_all, ST_SYNC_ALL);
match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES);
match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY);
@ -1534,8 +1545,8 @@ gfc_enclosing_unit (gfc_compile_state * result)
for (p = gfc_state_stack; p; p = p->previous)
if (p->state == COMP_FUNCTION || p->state == COMP_SUBROUTINE
|| p->state == COMP_MODULE || p->state == COMP_BLOCK_DATA
|| p->state == COMP_PROGRAM)
|| p->state == COMP_MODULE || p->state == COMP_SUBMODULE
|| p->state == COMP_BLOCK_DATA || p->state == COMP_PROGRAM)
{
if (result != NULL)
@ -1660,6 +1671,9 @@ gfc_ascii_statement (gfc_statement st)
case ST_END_MODULE:
p = "END MODULE";
break;
case ST_END_SUBMODULE:
p = "END SUBMODULE";
break;
case ST_END_PROGRAM:
p = "END PROGRAM";
break;
@ -1742,6 +1756,9 @@ gfc_ascii_statement (gfc_statement st)
case ST_MODULE:
p = "MODULE";
break;
case ST_SUBMODULE:
p = "SUBMODULE";
break;
case ST_PAUSE:
p = "PAUSE";
break;
@ -2186,6 +2203,7 @@ accept_statement (gfc_statement st)
case ST_FUNCTION:
case ST_SUBROUTINE:
case ST_MODULE:
case ST_SUBMODULE:
gfc_current_ns->proc_name = gfc_new_block;
break;
@ -2931,6 +2949,10 @@ loop:
gfc_free_namespace (gfc_current_ns);
goto loop;
}
/* F2008 C1210 forbids the IMPORT statement in module procedure
interface bodies and the flag is set to import symbols. */
if (gfc_new_block->attr.module_procedure)
gfc_current_ns->has_import_set = 1;
break;
case ST_PROCEDURE:
@ -3280,7 +3302,8 @@ declSt:
break;
case ST_STATEMENT_FUNCTION:
if (gfc_current_state () == COMP_MODULE)
if (gfc_current_state () == COMP_MODULE
|| gfc_current_state () == COMP_SUBMODULE)
{
unexpected_statement (st);
break;
@ -4983,6 +5006,7 @@ parse_contained (int module)
/* These statements are associated with the end of the host unit. */
case ST_END_FUNCTION:
case ST_END_MODULE:
case ST_END_SUBMODULE:
case ST_END_PROGRAM:
case ST_END_SUBROUTINE:
accept_statement (st);
@ -4999,7 +5023,8 @@ parse_contained (int module)
}
}
while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE
&& st != ST_END_MODULE && st != ST_END_PROGRAM);
&& st != ST_END_MODULE && st != ST_END_SUBMODULE
&& st != ST_END_PROGRAM);
/* The first namespace in the list is guaranteed to not have
anything (worthwhile) in it. */
@ -5019,6 +5044,35 @@ parse_contained (int module)
}
/* The result variable in a MODULE PROCEDURE needs to be created and
its characteristics copied from the interface since it is neither
declared in the procedure declaration nor in the specification
part. */
static void
get_modproc_result (void)
{
gfc_symbol *proc;
if (gfc_state_stack->previous
&& gfc_state_stack->previous->state == COMP_CONTAINS
&& gfc_state_stack->previous->previous->state == COMP_SUBMODULE)
{
proc = gfc_current_ns->proc_name ? gfc_current_ns->proc_name : NULL;
if (proc != NULL
&& proc->attr.function
&& proc->ts.interface
&& proc->ts.interface->result
&& proc->ts.interface->result != proc->ts.interface)
{
gfc_copy_dummy_sym (&proc->result, proc->ts.interface->result, 1);
gfc_set_sym_referenced (proc->result);
proc->result->attr.if_source = IFSRC_DECL;
gfc_commit_symbol (proc->result);
}
}
}
/* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct. */
static void
@ -5027,6 +5081,11 @@ parse_progunit (gfc_statement st)
gfc_state_data *p;
int n;
if (gfc_new_block
&& gfc_new_block->abr_modproc_decl
&& gfc_new_block->attr.function)
get_modproc_result ();
st = parse_spec (st);
switch (st)
{
@ -5086,7 +5145,8 @@ contains:
if (p->state == COMP_CONTAINS)
n++;
if (gfc_find_state (COMP_MODULE) == true)
if (gfc_find_state (COMP_MODULE) == true
|| gfc_find_state (COMP_SUBMODULE) == true)
n--;
if (n > 0)
@ -5207,6 +5267,36 @@ parse_block_data (void)
}
/* Following the association of the ancestor (sub)module symbols, they
must be set host rather than use associated and all must be public.
They are flagged up by 'used_in_submodule' so that they can be set
DECL_EXTERNAL in trans_decl.c(gfc_finish_var_decl). Otherwise the
linker chokes on multiple symbol definitions. */
static void
set_syms_host_assoc (gfc_symbol *sym)
{
gfc_component *c;
if (sym == NULL)
return;
if (sym->attr.module_procedure)
sym->attr.external = 0;
/* sym->attr.access = ACCESS_PUBLIC; */
sym->attr.use_assoc = 0;
sym->attr.host_assoc = 1;
sym->attr.used_in_submodule =1;
if (sym->attr.flavor == FL_DERIVED)
{
for (c = sym->components; c; c = c->next)
c->attr.access = ACCESS_PUBLIC;
}
}
/* Parse a module subprogram. */
static void
@ -5226,6 +5316,15 @@ parse_module (void)
s->defined = 1;
}
/* Something is nulling the module_list after this point. This is good
since it allows us to 'USE' the parent modules that the submodule
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);
}
st = parse_spec (ST_NONE);
error = false;
@ -5240,6 +5339,7 @@ loop:
break;
case ST_END_MODULE:
case ST_END_SUBMODULE:
accept_statement (st);
break;
@ -5535,6 +5635,14 @@ loop:
parse_module ();
break;
case ST_SUBMODULE:
push_state (&s, COMP_SUBMODULE, gfc_new_block);
accept_statement (st);
gfc_get_errors (NULL, &errors_before);
parse_module ();
break;
/* Anything else starts a nameless main program block. */
default:
if (seen_program)
@ -5559,7 +5667,7 @@ loop:
gfc_dump_parse_tree (gfc_current_ns, stdout);
gfc_get_errors (NULL, &errors);
if (s.state == COMP_MODULE)
if (s.state == COMP_MODULE || s.state == COMP_SUBMODULE)
{
gfc_dump_module (s.sym->name, errors_before == errors);
gfc_current_ns->derived_types = gfc_derived_types;

6
gcc/fortran/parse.h
View File

@ -25,9 +25,9 @@ along with GCC; see the file COPYING3. If not see
/* Enum for what the compiler is currently doing. */
typedef enum
{
COMP_NONE, COMP_PROGRAM, COMP_MODULE, COMP_SUBROUTINE, COMP_FUNCTION,
COMP_BLOCK_DATA, COMP_INTERFACE, COMP_DERIVED, COMP_DERIVED_CONTAINS,
COMP_BLOCK, COMP_ASSOCIATE, COMP_IF,
COMP_NONE, COMP_PROGRAM, COMP_MODULE, COMP_SUBMODULE, COMP_SUBROUTINE,
COMP_FUNCTION, COMP_BLOCK_DATA, COMP_INTERFACE, COMP_DERIVED,
COMP_DERIVED_CONTAINS, COMP_BLOCK, COMP_ASSOCIATE, COMP_IF,
COMP_DO, COMP_SELECT, COMP_FORALL, COMP_WHERE, COMP_CONTAINS, COMP_ENUM,
COMP_SELECT_TYPE, COMP_OMP_STRUCTURED_BLOCK, COMP_CRITICAL, COMP_DO_CONCURRENT
}

4
gcc/fortran/primary.c
View File

@ -2964,7 +2964,8 @@ gfc_match_rvalue (gfc_expr **result)
st = gfc_enclosing_unit (NULL);
if (st != NULL && st->state == COMP_FUNCTION
if (st != NULL
&& st->state == COMP_FUNCTION
&& st->sym == sym
&& !sym->attr.recursive)
{
@ -3268,6 +3269,7 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag)
of keywords, such as 'end', being turned into variables by
failed matching to assignments for, e.g., END INTERFACE. */
if (gfc_current_state () == COMP_MODULE
|| gfc_current_state () == COMP_SUBMODULE
|| gfc_current_state () == COMP_INTERFACE
|| gfc_current_state () == COMP_CONTAINS)
host_flag = 0;

91
gcc/fortran/resolve.c
View File

@ -11431,6 +11431,32 @@ no_init_error:
}
/* Compare the dummy characteristics of a module procedure interface
declaration with the corresponding declaration in a submodule. */
static gfc_formal_arglist *new_formal;
static char errmsg[200];
static void
compare_fsyms (gfc_symbol *sym)
{
gfc_symbol *fsym;
if (sym == NULL || new_formal == NULL)
return;
fsym = new_formal->sym;
if (sym == fsym)
return;
if (strcmp (sym->name, fsym->name) == 0)
{
if (!gfc_check_dummy_characteristics (fsym, sym, true, errmsg, 200))
gfc_error ("%s at %L", errmsg, &fsym->declared_at);
}
}
/* Resolve a procedure. */
static bool
@ -11695,6 +11721,71 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
if (sym->attr.if_source != IFSRC_DECL)
sym->attr.array_outer_dependency = 1;
/* Compare the characteristics of a module procedure with the
interface declaration. Ideally this would be done with
gfc_compare_interfaces but, at present, the formal interface
cannot be copied to the ts.interface. */
if (sym->attr.module_procedure
&& sym->attr.if_source == IFSRC_DECL)
{
gfc_symbol *iface;
/* Stop the dummy characteristics test from using the interface
symbol instead of 'sym'. */
iface = sym->ts.interface;
sym->ts.interface = NULL;
if (iface == NULL)
goto check_formal;
/* Check the procedure characteristics. */
if (sym->attr.pure != iface->attr.pure)
{
gfc_error ("Mismatch in PURE attribute between MODULE "
"PROCEDURE at %L and its interface in %s",
&sym->declared_at, iface->module);
return false;
}
if (sym->attr.elemental != iface->attr.elemental)
{
gfc_error ("Mismatch in ELEMENTAL attribute between MODULE "
"PROCEDURE at %L and its interface in %s",
&sym->declared_at, iface->module);
return false;
}
if (sym->attr.recursive != iface->attr.recursive)
{
gfc_error ("Mismatch in RECURSIVE attribute between MODULE "
"PROCEDURE at %L and its interface in %s",
&sym->declared_at, iface->module);
return false;
}
/* Check the result characteristics. */
if (!gfc_check_result_characteristics (sym, iface, errmsg, 200))
{
gfc_error ("%s between the MODULE PROCEDURE declaration "
"in module %s and the declaration at %L in "
"SUBMODULE %s", errmsg, iface->module,
&sym->declared_at, sym->ns->proc_name->name);
return false;
}
check_formal:
/* Check the charcateristics of the formal arguments. */
if (sym->formal && sym->formal_ns)
{
for (arg = sym->formal; arg && arg->sym; arg = arg->next)
{
new_formal = arg;
gfc_traverse_ns (sym->formal_ns, compare_fsyms);
}
}
sym->ts.interface = iface;
}
return true;
}

53
gcc/fortran/symbol.c
View File

@ -1539,7 +1539,7 @@ gfc_add_procedure (symbol_attribute *attr, procedure_type t,
if (where == NULL)
where = &gfc_current_locus;
if (attr->proc != PROC_UNKNOWN)
if (attr->proc != PROC_UNKNOWN && !attr->module_procedure)
{
gfc_error ("%s procedure at %L is already declared as %s procedure",
gfc_code2string (procedures, t), where,
@ -1655,10 +1655,15 @@ bool
gfc_add_explicit_interface (gfc_symbol *sym, ifsrc source,
gfc_formal_arglist * formal, locus *where)
{
if (check_used (&sym->attr, sym->name, where))
return false;
/* Skip the following checks in the case of a module_procedures in a
submodule since they will manifestly fail. */
if (sym->attr.module_procedure == 1
&& source == IFSRC_DECL)
goto finish;
if (where == NULL)
where = &gfc_current_locus;
@ -1677,6 +1682,7 @@ gfc_add_explicit_interface (gfc_symbol *sym, ifsrc source,
return false;
}
finish:
sym->formal = formal;
sym->attr.if_source = source;
@ -1703,7 +1709,10 @@ gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where)
if (sym->attr.result && type == BT_UNKNOWN && sym->ns->proc_name)
type = sym->ns->proc_name->ts.type;
if (type != BT_UNKNOWN && !(sym->attr.function && sym->attr.implicit_type))
if (type != BT_UNKNOWN && !(sym->attr.function && sym->attr.implicit_type)
&& !(gfc_state_stack->previous && gfc_state_stack->previous->previous
&& gfc_state_stack->previous->previous->state == COMP_SUBMODULE)
&& !sym->attr.module_procedure)
{
if (sym->attr.use_assoc)
gfc_error ("Symbol %qs at %L conflicts with symbol from module %qs, "
@ -1876,6 +1885,44 @@ fail:
}
/* A function to generate a dummy argument symbol using that from the
interface declaration. Can be used for the result symbol as well if
the flag is set. */
int
gfc_copy_dummy_sym (gfc_symbol **dsym, gfc_symbol *sym, int result)
{
int rc;
rc = gfc_get_symbol (sym->name, NULL, dsym);
if (rc)
return rc;
if (!gfc_add_type (*dsym, &(sym->ts), &gfc_current_locus))
return 1;
if (!gfc_copy_attr (&(*dsym)->attr, &(sym->attr),
&gfc_current_locus))
return 1;
if ((*dsym)->attr.dimension)
(*dsym)->as = gfc_copy_array_spec (sym->as);
(*dsym)->attr.class_ok = sym->attr.class_ok;
if ((*dsym) != NULL && !result
&& (!gfc_add_dummy(&(*dsym)->attr, (*dsym)->name, NULL)
|| !gfc_missing_attr (&(*dsym)->attr, NULL)))
return 1;
else if ((*dsym) != NULL && result
&& (!gfc_add_result(&(*dsym)->attr, (*dsym)->name, NULL)
|| !gfc_missing_attr (&(*dsym)->attr, NULL)))
return 1;
return 0;
}
/************** Component name management ************/
/* Component names of a derived type form their own little namespaces

6
gcc/fortran/trans-decl.c
View File

@ -377,9 +377,10 @@ gfc_sym_mangled_function_id (gfc_symbol * sym)
/* use the binding label rather than the mangled name */
return get_identifier (sym->binding_label);
if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
if ((sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
|| (sym->module != NULL && (sym->attr.external
|| sym->attr.if_source == IFSRC_IFBODY)))
&& !sym->attr.module_procedure)
{
/* Main program is mangled into MAIN__. */
if (sym->attr.is_main_program)
@ -599,7 +600,7 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym)
}
/* If a variable is USE associated, it's always external. */
if (sym->attr.use_assoc)
if (sym->attr.use_assoc || sym->attr.used_in_submodule)
{
DECL_EXTERNAL (decl) = 1;
TREE_PUBLIC (decl) = 1;
@ -1319,6 +1320,7 @@ gfc_get_symbol_decl (gfc_symbol * sym)
gcc_assert (sym->attr.referenced
|| sym->attr.flavor == FL_PROCEDURE
|| sym->attr.use_assoc
|| sym->attr.used_in_submodule
|| sym->ns->proc_name->attr.if_source == IFSRC_IFBODY
|| (sym->module && sym->attr.if_source != IFSRC_DECL
&& sym->backend_decl));

11
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,14 @@
2015-07-02 Paul Thomas <pault@gcc.gnu.org>
PR fortran/52846
* gfortran.dg/submodule_1.f90: New test
* gfortran.dg/submodule_2.f90: New test
* gfortran.dg/submodule_3.f90: New test
* gfortran.dg/submodule_4.f90: New test
* gfortran.dg/submodule_5.f90: New test
* gfortran.dg/submodule_6.f90: New test
* gfortran.dg/submodule_7.f90: New test
2015-07-02 Paolo Carlini <paolo.carlini@oracle.com>
PR c++/53690

172
gcc/testsuite/gfortran.dg/submodule_1.f90 Normal file
View File

@ -0,0 +1,172 @@
! { dg-do run }
!
! Basic test of submodule functionality.
!
! Contributed by Paul Thomas <pault@gcc.gnu.org>
!
module foo_interface
implicit none
character(len = 100) :: message
character(len = 100) :: message2
type foo
character(len=15) :: greeting = "Hello, world! "
character(len=15), private :: byebye = "adieu, world! "
contains
procedure :: greet => say_hello
procedure :: farewell => bye
procedure, private :: adieu => byebye
end type foo
interface
module subroutine say_hello(this)
class(foo), intent(in) :: this
end subroutine
module subroutine bye(this)
class(foo), intent(in) :: this
end subroutine
module subroutine byebye(this, that)
class(foo), intent(in) :: this
class(foo), intent(inOUT), allocatable :: that
end subroutine
module function realf (arg) result (res)
real :: arg, res
end function
integer module function intf (arg)
integer :: arg
end function
real module function realg (arg)
real :: arg
end function
integer module function intg (arg)
integer :: arg
end function
end interface
integer :: factor = 5
contains
subroutine smurf
class(foo), allocatable :: this
allocate (this)
message = "say_hello from SMURF --->"
call say_hello (this)
end subroutine
end module
!
SUBMODULE (foo_interface) foo_interface_son
!
contains
! Test module procedure with conventional specification part for dummies
module subroutine say_hello(this)
class(foo), intent(in) :: this
class(foo), allocatable :: that
allocate (that, source = this)
! call this%farewell ! NOTE WELL: This compiles and causes a crash in run-time
! due to recursion through the call to this procedure from
! say hello.
message = that%greeting
! Check that descendant module procedure is correctly processed
if (intf (77) .ne. factor*77) call abort
end subroutine
module function realf (arg) result (res)
real :: arg, res
res = 2*arg
end function
end SUBMODULE foo_interface_son
!
! Check that multiple generations of submodules are OK
SUBMODULE (foo_interface:foo_interface_son) foo_interface_grandson
!
contains
module procedure intf
intf = factor*arg
end PROCEDURE
end SUBMODULE foo_interface_grandson
!
SUBMODULE (foo_interface) foo_interface_daughter
!
contains
! Test module procedure with abbreviated declaration and no specification of dummies
module procedure bye
class(foo), allocatable :: that
call say_hello (this)
! check access to a PRIVATE procedure pointer that accesses a private component
call this%adieu (that)
message2 = that%greeting
end PROCEDURE
! Test module procedure pointed to by PRIVATE component of foo
module procedure byebye
allocate (that, source = this)
! Access a PRIVATE component of foo
that%greeting = that%byebye
end PROCEDURE
module procedure intg
intg = 3*arg
end PROCEDURE
module procedure realg
realg = 3*arg
end PROCEDURE
end SUBMODULE foo_interface_daughter
!
program try
use foo_interface
implicit none
type(foo) :: bar
call clear_messages
call bar%greet ! typebound call
if (trim (message) .ne. "Hello, world!") call abort
call clear_messages
bar%greeting = "G'day, world!"
call say_hello(bar) ! Checks use association of 'say_hello'
if (trim (message) .ne. "G'day, world!") call abort
call clear_messages
bar%greeting = "Hi, world!"
call bye(bar) ! Checks use association in another submodule
if (trim (message) .ne. "Hi, world!") call abort
if (trim (message2) .ne. "adieu, world!") call abort
call clear_messages
call smurf ! Checks host association of 'say_hello'
if (trim (message) .ne. "Hello, world!") call abort
call clear_messages
bar%greeting = "farewell "
call bar%farewell
if (trim (message) .ne. "farewell") call abort
if (trim (message2) .ne. "adieu, world!") call abort
if (realf(2.0) .ne. 4.0) call abort ! Check module procedure with explicit result
if (intf(2) .ne. 10) call abort ! ditto
if (realg(3.0) .ne. 9.0) call abort ! Check module procedure with function declaration result
if (intg(3) .ne. 9) call abort ! ditto
contains
subroutine clear_messages
message = ""
message2 = ""
end subroutine
end program

100
gcc/testsuite/gfortran.dg/submodule_2.f90 Normal file
View File

@ -0,0 +1,100 @@
! { dg-do run }
!
! Test dummy and result arrays in module procedures
!
! Contributed by Paul Thomas <pault@gcc.gnu.org>
!
module foo_interface
implicit none
type foo
character(len=16) :: greeting = "Hello, world! "
character(len=16), private :: byebye = "adieu, world! "
end type foo
interface
module function array1(this) result (that)
type(foo), intent(in), dimension(:) :: this
type(foo), allocatable, dimension(:) :: that
end function
character(16) module function array2(this, that)
type(foo), intent(in), dimension(:) :: this
type(foo), allocatable, dimension(:) :: that
end function
module subroutine array3(this, that)
type(foo), intent(in), dimension(:) :: this
type(foo), intent(inOUT), allocatable, dimension(:) :: that
end subroutine
module subroutine array4(this, that)
type(foo), intent(in), dimension(:) :: this
type(foo), intent(inOUT), allocatable, dimension(:) :: that
end subroutine
end interface
end module
!
SUBMODULE (foo_interface) foo_interface_son
!
contains
! Test array characteristics for dummy and result are OK
module function array1 (this) result(that)
type(foo), intent(in), dimension(:) :: this
type(foo), allocatable, dimension(:) :: that
allocate (that(size(this)), source = this)
that%greeting = that%byebye
end function
! Test array characteristics for dummy and result are OK for
! abbreviated module procedure declaration.
module procedure array2
allocate (that(size(this)), source = this)
that%greeting = that%byebye
array2 = trim (that(size (that))%greeting(1:5))//", people!"
end PROCEDURE
end SUBMODULE foo_interface_son
!
SUBMODULE (foo_interface) foo_interface_daughter
!
contains
! Test array characteristics for dummies are OK
module subroutine array3(this, that)
type(foo), intent(in), dimension(:) :: this
type(foo), intent(inOUT), allocatable, dimension(:) :: that
allocate (that(size(this)), source = this)
that%greeting = that%byebye
end subroutine
! Test array characteristics for dummies are OK for
! abbreviated module procedure declaration.
module procedure array4
integer :: i
allocate (that(size(this)), source = this)
that%greeting = that%byebye
do i = 1, size (that)
that(i)%greeting = trim (that(i)%greeting(1:5))//", people!"
end do
end PROCEDURE
end SUBMODULE foo_interface_daughter
!
program try
use foo_interface
implicit none
type(foo), dimension(2) :: bar
type (foo), dimension(:), allocatable :: arg
arg = array1(bar) ! typebound call
if (any (arg%greeting .ne. ["adieu, world! ", "adieu, world! "])) call abort
deallocate (arg)
if (trim (array2 (bar, arg)) .ne. "adieu, people!") call abort
deallocate (arg)
call array3 (bar, arg) ! typebound call
if (any (arg%greeting .ne. ["adieu, world! ", "adieu, world! "])) call abort
deallocate (arg)
call array4 (bar, arg) ! typebound call
if (any (arg%greeting .ne. ["adieu, people!", "adieu, people!"])) call abort
contains
end program

37
gcc/testsuite/gfortran.dg/submodule_3.f90 Normal file
View File

@ -0,0 +1,37 @@
! { dg-do compile }
! { dg-options "-std=f2003" }
!
! Check enforcement of F2008 standard for MODULE PROCEDURES and SUBMODULES
! This is rather bare-bones to reduce the number of error messages too the
! essential minimum.
!
! Contributed by Paul Thomas <pault@gcc.gnu.org>
!
module foo_interface
implicit none
interface
module function array1(this) result (that) ! { dg-error "MODULE prefix" }
end function ! { dg-error "Expecting END INTERFACE" }
character(16) module function array2(this, that) ! { dg-error "MODULE prefix" }
end function ! { dg-error "Expecting END INTERFACE" }
end interface
end module
!
SUBMODULE (foo_interface) foo_interface_son ! { dg-error "SUBMODULE declaration" }
!
contains
module function array1 (this) result(that) ! { dg-error "MODULE prefix" }
end function ! { dg-error "Expecting END PROGRAM" }
! Test array characteristics for dummy and result are OK for
! abbreviated module procedure declaration.
module procedure array2 ! { dg-error "must be in a generic module interface" }
end PROCEDURE ! { dg-error "Expecting END PROGRAM" }
end SUBMODULE foo_interface_son ! { dg-error "Expecting END PROGRAM" }
end ! { dg-error "CONTAINS statement without FUNCTION or SUBROUTINE" }

140
gcc/testsuite/gfortran.dg/submodule_4.f90 Normal file
View File

@ -0,0 +1,140 @@
! { dg-do compile }
!
! Tests comparisons of MODULE PROCEDURE characteristics and
! the characteristics of their dummies. Also tests the error
! arising from redefining dummies and results in MODULE
! procedures.
!
! Contributed by Paul Thomas <pault@gcc.gnu.org>
!
module foo_interface
implicit none
type foo
character(len=16) :: greeting = "Hello, world! "
character(len=16), private :: byebye = "adieu, world! "
end type foo
interface
module function array1(this) result (that)
type(foo), intent(in), dimension(:) :: this
type(foo), allocatable, dimension(:) :: that
end function
character(16) module function array2(this, that)
type(foo), intent(in), dimension(:) :: this
type(foo), allocatable, dimension(:) :: that
end function
module subroutine array3(this, that)
type(foo), intent(in), dimension(:) :: this
type(foo), intent(inOUT), allocatable, dimension(:) :: that
end subroutine
module subroutine array4(this, that)
type(foo), intent(in), dimension(:) :: this
type(foo), intent(inOUT), allocatable, dimension(:) :: that
end subroutine
integer module function scalar1 (arg)
real, intent(in) :: arg
end function
module function scalar2 (arg) result(res)
real, intent(in) :: arg
real :: res
end function
module function scalar3 (arg) result(res)
real, intent(in) :: arg
real :: res
end function
module function scalar4 (arg) result(res)
real, intent(in) :: arg
complex :: res
end function
module function scalar5 (arg) result(res)
real, intent(in) :: arg
real, allocatable :: res
end function
module function scalar6 (arg) result(res)
real, intent(in) :: arg
real, allocatable :: res
end function
module function scalar7 (arg) result(res)
real, intent(in) :: arg
real, allocatable :: res
end function
end interface
end module
!
SUBMODULE (foo_interface) foo_interface_son
!
contains
module function array1 (this) result(that) ! { dg-error "Rank mismatch in function result" }
type(foo), intent(in), dimension(:) :: this
type(foo), allocatable :: that
end function
character(16) module function array2(this) ! { dg-error "Mismatch in number of MODULE PROCEDURE formal arguments" }
type(foo), intent(in), dimension(:) :: this
type(foo), allocatable, dimension(:) :: that
allocate (that(2), source = this(1))
that%greeting = that%byebye
array2 = trim (that(size (that))%greeting(1:5))//", people!"
end function
module subroutine array3(thiss, that) ! { dg-error "Mismatch in MODULE PROCEDURE formal argument names" }
type(foo), intent(in), dimension(:) :: thiss
type(foo), intent(inOUT), allocatable, dimension(:) :: that
allocate (that(size(thiss)), source = thiss)
that%greeting = that%byebye
end subroutine
module subroutine array4(this, that, the_other) ! { dg-error "Mismatch in number of MODULE PROCEDURE formal arguments" }
type(foo), intent(in), dimension(:) :: this
type(foo), intent(inOUT), allocatable, dimension(:) :: that, the_other
integer :: i
allocate (that(size(this)), source = this)
that%greeting = that%byebye
do i = 1, size (that)
that(i)%greeting = trim (that(i)%greeting(1:5))//", people!"
end do
end subroutine
recursive module function scalar1 (arg) ! { dg-error "Mismatch in RECURSIVE" }
real, intent(in) :: arg
end function
pure module function scalar2 (arg) result(res) ! { dg-error "Mismatch in PURE" }
real, intent(in) :: arg
real :: res
end function
module procedure scalar7
real, intent(in) :: arg ! { dg-error "redefinition of the declaration" }
real, allocatable :: res ! { dg-error "redefinition of the declaration" }
end function ! { dg-error "Expecting END PROCEDURE statement" }
end procedure ! This prevents a cascade of errors.
end SUBMODULE foo_interface_son
!
SUBMODULE (foo_interface) foo_interface_daughter
!
contains
module function scalar3 (arg) result(res) ! { dg-error "Type mismatch in argument" }
integer, intent(in) :: arg
real :: res
end function
module function scalar4 (arg) result(res) ! { dg-error "Type mismatch in function result" }
real, intent(in) :: arg
real :: res
end function
module function scalar5 (arg) result(res) ! { dg-error "ALLOCATABLE attribute mismatch in function result " }
real, intent(in) :: arg
real :: res
end function
module function scalar6 (arg) result(res) ! { dg-error "Rank mismatch in argument" }
real, intent(in), dimension(2) :: arg
real, allocatable :: res
end function
end SUBMODULE foo_interface_daughter

51
gcc/testsuite/gfortran.dg/submodule_5.f90 Normal file
View File

@ -0,0 +1,51 @@
! { dg-do compile }
!
! Checks that PRIVATE/PUBLIC not allowed in submodules. Also, IMPORT
! is not allowed in a module procedure interface body.
!
! Contributed by Paul Thomas <pault@gcc.gnu.org>
!
module foo_interface
implicit none
type foo
character(len=16), private :: byebye = "adieu, world! "
end type foo
end module
module foo_interface_brother
use foo_interface
implicit none
interface
module subroutine array3(this, that)
import ! { dg-error "not permitted in a module procedure interface body" }
type(foo), intent(in), dimension(:) :: this
type(foo), intent(inOUT), allocatable, dimension(:) :: that
end subroutine
end interface
end module
SUBMODULE (foo_interface) foo_interface_son
private ! { dg-error "PRIVATE statement" }
public ! { dg-error "PUBLIC statement" }
integer, public :: i ! { dg-error "PUBLIC attribute" }
integer, private :: j ! { dg-error "PRIVATE attribute" }
type :: bar
private ! { dg-error "PRIVATE statement" }
public ! { dg-error "PUBLIC statement" }
integer, private :: i ! { dg-error "PRIVATE attribute" }
integer, public :: j ! { dg-error "PUBLIC attribute" }
end type bar
contains
!
end submodule foo_interface_son
SUBMODULE (foo_interface) foo_interface_daughter
!
contains
subroutine foobar (arg)
type(foo) :: arg
arg%byebye = "hello, world! " ! Access to private component is OK
end subroutine
end SUBMODULE foo_interface_daughter
end

91
gcc/testsuite/gfortran.dg/submodule_6.f90 Normal file
View File

@ -0,0 +1,91 @@
! { dg-do run }
!
! Checks that the results of module procedures have the correct characteristics.
!
! Contributed by Reinhold Bader <reinhold.bader@lrz.de>
!
module mod_a
implicit none
type, abstract :: t_a
end type t_a
interface
module subroutine p_a(this, q)
class(t_a), intent(inout) :: this
class(*), intent(in) :: q
end subroutine
module function create_a() result(r)
class(t_a), allocatable :: r
end function
module subroutine print(this)
class(t_a), intent(in) :: this
end subroutine
end interface
end module mod_a
module mod_b
implicit none
type t_b
integer, allocatable :: I(:)
end type t_b
interface
module function create_b(i) result(r)
type(t_b) :: r
integer :: i(:)
end function
end interface
end module mod_b
submodule(mod_b) imp_create
contains
module procedure create_b
if (allocated(r%i)) deallocate(r%i)
allocate(r%i, source=i)
end procedure
end submodule imp_create
submodule(mod_a) imp_p_a
use mod_b
type, extends(t_a) :: t_imp
type(t_b) :: b
end type t_imp
integer, parameter :: ii(2) = [1,2]
contains
module procedure create_a
type(t_b) :: b
b = create_b(ii)
allocate(r, source=t_imp(b))
end procedure
module procedure p_a
select type (this)
type is (t_imp)
select type (q)
type is (t_b)
this%b = q
class default
call abort
end select
class default
call abort
end select
end procedure p_a
module procedure print
select type (this)
type is (t_imp)
if (any (this%b%i .ne. [3,4,5])) call abort
class default
call abort
end select
end procedure
end submodule imp_p_a
program p
use mod_a
use mod_b
implicit none
class(t_a), allocatable :: a
allocate(a, source=create_a())
call p_a(a, create_b([3,4,5]))
call print(a)
end program p

147
gcc/testsuite/gfortran.dg/submodule_7.f90 Normal file
View File

@ -0,0 +1,147 @@
! { dg-do run }
!
! Example in F2008 C.8.4 to demonstrate submodules
!
module color_points
type color_point
private
real :: x, y
integer :: color
end type color_point
interface
! Interfaces for procedures with separate
! bodies in the submodule color_points_a
module subroutine color_point_del ( p ) ! Destroy a color_point object
type(color_point), allocatable :: p
end subroutine color_point_del
! Distance between two color_point objects
real module function color_point_dist ( a, b )
type(color_point), intent(in) :: a, b
end function color_point_dist
module subroutine color_point_draw ( p ) ! Draw a color_point object
type(color_point), intent(in) :: p
end subroutine color_point_draw
module subroutine color_point_new ( p ) ! Create a color_point object
type(color_point), allocatable :: p
end subroutine color_point_new
module subroutine verify_cleanup ( p1, p2 ) ! Check cleanup of color_point objects
type(color_point), allocatable :: p1, p2
end subroutine verify_cleanup
end interface
end module color_points
module palette_stuff
type :: palette ;
!...
end type palette
contains
subroutine test_palette ( p )
! Draw a color wheel using procedures from the color_points module
use color_points ! This does not cause a circular dependency because
! the "use palette_stuff" that is logically within
! color_points is in the color_points_a submodule.
type(palette), intent(in) :: p
end subroutine test_palette
end module palette_stuff
submodule ( color_points ) color_points_a ! Submodule of color_points
integer :: instance_count = 0
interface
! Interface for a procedure with a separate
! body in submodule color_points_b
module subroutine inquire_palette ( pt, pal )
use palette_stuff
! palette_stuff, especially submodules
! thereof, can reference color_points by use
! association without causing a circular
! dependence during translation because this
! use is not in the module. Furthermore,
! changes in the module palette_stuff do not
! affect the translation of color_points.
type(color_point), intent(in) :: pt
type(palette), intent(out) :: pal
end subroutine inquire_palette
end interface
contains
! Invisible bodies for public separate module procedures
! declared in the module
module subroutine color_point_del ( p )
type(color_point), allocatable :: p
instance_count = instance_count - 1
deallocate ( p )
end subroutine color_point_del
real module function color_point_dist ( a, b ) result ( dist )
type(color_point), intent(in) :: a, b
dist = sqrt( (b%x - a%x)**2 + (b%y - a%y)**2 )
end function color_point_dist
module subroutine color_point_new ( p )
type(color_point), allocatable :: p
instance_count = instance_count + 1
allocate ( p )
! Added to example so that it does something.
p%x = real (instance_count) * 1.0
p%y = real (instance_count) * 2.0
p%color = instance_count
end subroutine color_point_new
end submodule color_points_a
submodule ( color_points:color_points_a ) color_points_b ! Subsidiary**2 submodule
contains
! Invisible body for interface declared in the ancestor module
module subroutine color_point_draw ( p )
use palette_stuff, only: palette
type(color_point), intent(in) :: p
type(palette) :: MyPalette
call inquire_palette ( p, MyPalette )
! Added to example so that it does something.
if (abs (p%x - real (p%color) * 1.0) .gt. 1.0e-6) call abort
if (abs (p%y - real (p%color) * 2.0) .gt. 1.0e-6) call abort
end subroutine color_point_draw
! Invisible body for interface declared in the parent submodule
module procedure inquire_palette
!... implementation of inquire_palette
end procedure inquire_palette
module procedure verify_cleanup
if (allocated (p1) .or. allocated (p2)) call abort
if (instance_count .ne. 0) call abort
end procedure
subroutine private_stuff ! not accessible from color_points_a
!...
end subroutine private_stuff
end submodule color_points_b
program main
use color_points
! "instance_count" and "inquire_palette" are not accessible here
! because they are not declared in the "color_points" module.
! "color_points_a" and "color_points_b" cannot be referenced by
! use association.
interface draw
! just to demonstrate it’s possible
module procedure color_point_draw
end interface
type(color_point), allocatable :: C_1, C_2
real :: RC
!...
call color_point_new (c_1)
call color_point_new (c_2)
! body in color_points_a, interface in color_points
!...
call draw (c_1)
! body in color_points_b, specific interface
! in color_points, generic interface here.
!...
rc = color_point_dist (c_1, c_2) ! body in color_points_a, interface in color_points
if (abs (rc - 2.23606801) .gt. 1.0e-6) call abort
!...
call color_point_del (c_1)
call color_point_del (c_2)
! body in color_points_a, interface in color_points
call verify_cleanup (c_1, c_2)
!...
end program main