* [Patch, fortran] PR52846 - [F2008] Support submodules
@ 2015-06-22 12:41 Paul Richard Thomas
2015-06-25 15:29 ` Paul Richard Thomas
0 siblings, 1 reply; 7+ messages in thread
From: Paul Richard Thomas @ 2015-06-22 12:41 UTC (permalink / raw)
To: fortran, gcc-patches; +Cc: Damian Rouson, Tobias Burnus, salvatore.filippone
[-- Attachment #1: Type: text/plain, Size: 6310 bytes --]
Dear All,
This patch enables submodule support in gfortran. Submodules are a
feature of F2008 but are fully described in ISO/IEC TR 19767:2004(E).
The patch has one significant non-conformance (that I know about,
anyway!); whilst private derived type components are correctly dealt
with, symbols whose access is private within the parent module are
not. They should effectively be host associated in descendant
submodules. At present gfortran handles private access at the module
write stage. This means that when a submodule reads the module file,
there is no information present about symbols whose access was
private. Since this modification might cause significant fall-out to
existing code, I propose to submit a separate patch later on to sort
out the non-conformance. However, as required private and public
statements are not allowed in submodules.
The patch makes maximum possible leverage of existing code to handle
modules. Once the submodule is matched, the ancestor module and
submodules are first "used" and then all the symbols are set host
associated and private derived type components set public.
Most of the work involved matching module procedures, with both the
traditional form of declaration and the abbreviated one. I have chosen
to treat MODULE as a prefix like PURE or ELEMENTAL. This is logical
both because of the form of the declaration and because the
identification of module procedures is most easily done with an
attribute bit. With traditional procedure declarations, the procedure,
result and dummy characteristics are compared with those of the
interface declaration. The comparison of the dummy characteristics is
a bit cobbled together and might be better done by copying the
formal_namespace and it's contents to the new symbol and retaining the
old for the interface symbol. This patch leaves the old dummy symbols
in the formal namespace in the new ones in the formal arglist. I have
checked that cleanup occurs for all objects.
Note the comment in submodule_1.f90 about the possibility of
undetected recursion between procedures in different submodules. I am
not at all sure that I know how to deal with this and am open to
suggestions.
In addition, it should be noted that collisions between the names of
entities and procedures, other than module procedures are detected by
the linker at present.
Apart from this, all is very straightforward and follows the the ChangeLogs.
Thanks for testing of an early version of the patch by Damian Rouson,
Salvatore Filippone and Tobias Burnus.
Bootstrapped and regtested on FC21/x86_64 - OK for trunk?
Cheers
Paul
2015-06-22 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.
(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.
(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
prototypes for the functions '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'.
* module.c (gfc_match_submodule): New function. Add handling
for the 'module_procedure' attribute bit.
* parse.c (decode_statement): 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.
(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.
* 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_finish_var_decl): Symbols with the 'used_in_submodule' bit
set are set DECL_EXTERNAL as if they were use associated.
2015-06-22 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
[-- Attachment #2: submit.diff --]
[-- Type: text/plain, Size: 58346 bytes --]
Index: gcc/fortran/decl.c
===================================================================
*** gcc/fortran/decl.c (revision 224724)
--- gcc/fortran/decl.c (working copy)
*************** get_proc_name (const char *name, gfc_sym
*** 903,909 ****
sym = *result;
! 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
--- 903,937 ----
sym = *result;
! 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
*************** match_attr_spec (void)
*** 3925,3931 ****
}
/* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
! if (gfc_current_state () == COMP_MODULE && !current_attr.save
&& (gfc_option.allow_std & GFC_STD_F2008) != 0)
current_attr.save = SAVE_IMPLICIT;
--- 3953,3961 ----
}
/* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
! 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;
*************** gfc_match_prefix (gfc_typespec *ts)
*** 4513,4518 ****
--- 4543,4564 ----
/* 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;
*************** gfc_match_formal_arglist (gfc_symbol *pr
*** 4550,4558 ****
--- 4596,4619 ----
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)
*************** ok:
*** 4658,4663 ****
--- 4719,4742 ----
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:
*************** gfc_match_procedure (void)
*** 5271,5276 ****
--- 5350,5356 ----
case COMP_NONE:
case COMP_PROGRAM:
case COMP_MODULE:
+ case COMP_SUBMODULE:
case COMP_SUBROUTINE:
case COMP_FUNCTION:
case COMP_BLOCK:
*************** do_warn_intrinsic_shadow (const gfc_symb
*** 5309,5315 ****
bool in_module;
in_module = (gfc_state_stack->previous
! && gfc_state_stack->previous->state == COMP_MODULE);
gfc_warn_intrinsic_shadow (sym, in_module, func);
}
--- 5389,5396 ----
bool in_module;
in_module = (gfc_state_stack->previous
! && (gfc_state_stack->previous->state == COMP_MODULE
! || gfc_state_stack->previous->state == COMP_SUBMODULE));
gfc_warn_intrinsic_shadow (sym, in_module, func);
}
*************** gfc_match_function_decl (void)
*** 5348,5359 ****
--- 5429,5444 ----
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);
*************** gfc_match_entry (void)
*** 5547,5552 ****
--- 5632,5640 ----
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");
*************** gfc_match_subroutine (void)
*** 5791,5796 ****
--- 5879,5887 ----
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;
*************** gfc_match_end (gfc_statement *st)
*** 6175,6180 ****
--- 6266,6277 ----
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";
*************** syntax:
*** 7417,7422 ****
--- 7514,7625 ----
}
+ /* 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;
+ int rc;
+
+ 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;
+
+ if (sym->ts.interface->attr.function
+ && sym->ts.interface->result
+ && sym->ts.interface->result != sym->ts.interface)
+ sym->result= sym->ts.interface->result;
+ else if (sym->ts.interface->attr.function
+ && sym->ts.interface->result)
+ 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;
+
+ /* 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;
+ }
+
+ rc = gfc_get_symbol (formal->sym->name, NULL, &fsym);
+ if (rc)
+ goto cleanup;
+
+ if (!gfc_add_type (fsym, &(formal->sym->ts), &gfc_current_locus))
+ goto cleanup;
+
+ if (!gfc_copy_attr (&(fsym->attr), &(formal->sym->attr),
+ &gfc_current_locus))
+ goto cleanup;
+
+ if (fsym->attr.dimension)
+ fsym->as = gfc_copy_array_spec (formal->sym->as);
+
+ fsym->attr.class_ok = formal->sym->attr.class_ok;
+
+ if (fsym != NULL
+ && (!gfc_add_dummy(&fsym->attr, fsym->name, NULL)
+ || !gfc_missing_attr (&fsym->attr, NULL)))
+ 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. */
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h (revision 224724)
--- gcc/fortran/gfortran.h (working copy)
*************** typedef enum
*** 201,219 ****
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_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,
--- 201,219 ----
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_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,
*************** typedef struct
*** 751,756 ****
--- 751,759 ----
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. */
*************** typedef struct
*** 778,783 ****
--- 781,790 ----
/* Function/subroutine attributes */
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. */
*************** bool gfc_ref_dimen_size (gfc_array_ref *
*** 3087,3092 ****
--- 3094,3103 ----
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 *);
Index: gcc/fortran/interface.c
===================================================================
*** gcc/fortran/interface.c (revision 224724)
--- gcc/fortran/interface.c (working copy)
*************** symbol_rank (gfc_symbol *sym)
*** 1066,1074 ****
/* 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)
{
if (s1 == NULL || s2 == NULL)
return s1 == s2 ? true : false;
--- 1066,1075 ----
/* Check if the characteristics of two dummy arguments match,
cf. F08:12.3.2. */
! 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;
*************** check_dummy_characteristics (gfc_symbol
*** 1275,1282 ****
/* 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,
char *errmsg, int err_len)
{
gfc_symbol *r1, *r2;
--- 1276,1283 ----
/* Check if the characteristics of two function results match,
cf. F08:12.3.3. */
! bool
! gfc_check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2,
char *errmsg, int err_len)
{
gfc_symbol *r1, *r2;
*************** gfc_compare_interfaces (gfc_symbol *s1,
*** 1472,1479 ****
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))
return 0;
}
--- 1473,1480 ----
if (s1->attr.function && s2->attr.function)
{
/* If both are functions, check result characteristics. */
! if (!gfc_check_result_characteristics (s1, s2, errmsg, err_len)
! || !gfc_check_result_characteristics (s2, s1, errmsg, err_len))
return 0;
}
*************** gfc_compare_interfaces (gfc_symbol *s1,
*** 1533,1539 ****
if (strict_flag)
{
/* Check all characteristics. */
! if (!check_dummy_characteristics (f1->sym, f2->sym, true,
errmsg, err_len))
return 0;
}
--- 1534,1540 ----
if (strict_flag)
{
/* Check all characteristics. */
! if (!gfc_check_dummy_characteristics (f1->sym, f2->sym, true,
errmsg, err_len))
return 0;
}
*************** gfc_check_typebound_override (gfc_symtre
*** 4241,4248 ****
return false;
}
! if (!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);
--- 4242,4249 ----
return false;
}
! 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);
*************** gfc_check_typebound_override (gfc_symtre
*** 4293,4299 ****
}
check_type = proc_pass_arg != argpos && old_pass_arg != argpos;
! if (!check_dummy_characteristics (proc_formal->sym, old_formal->sym,
check_type, err, sizeof(err)))
{
gfc_error ("Argument mismatch for the overriding procedure "
--- 4294,4300 ----
}
check_type = proc_pass_arg != argpos && old_pass_arg != argpos;
! if (!gfc_check_dummy_characteristics (proc_formal->sym, old_formal->sym,
check_type, err, sizeof(err)))
{
gfc_error ("Argument mismatch for the overriding procedure "
Index: gcc/fortran/match.h
===================================================================
*** gcc/fortran/match.h (revision 224724)
--- gcc/fortran/match.h (working copy)
*************** match gfc_match_generic (void);
*** 203,208 ****
--- 203,209 ----
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);
*************** match gfc_match_expr (gfc_expr **);
*** 291,296 ****
--- 292,298 ----
/* module.c. */
match gfc_match_use (void);
+ match gfc_match_submodule (void);
void gfc_use_modules (void);
#endif /* GFC_MATCH_H */
Index: gcc/fortran/module.c
===================================================================
*** gcc/fortran/module.c (revision 224724)
--- gcc/fortran/module.c (working copy)
*************** cleanup:
*** 716,721 ****
--- 716,782 ----
}
+ /* 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
*************** typedef enum
*** 1887,1893 ****
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_attribute;
--- 1948,1954 ----
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_MODULE_PROCEDURE
}
ab_attribute;
*************** static const mstring attr_bits[] =
*** 1944,1949 ****
--- 2005,2011 ----
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)
};
*************** mio_symbol_attribute (symbol_attribute *
*** 2126,2131 ****
--- 2188,2195 ----
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 ();
*************** mio_symbol_attribute (symbol_attribute *
*** 2295,2300 ****
--- 2359,2367 ----
case AB_ARRAY_OUTER_DEPENDENCY:
attr->array_outer_dependency =1;
break;
+ case AB_MODULE_PROCEDURE:
+ attr->module_procedure =1;
+ break;
}
}
}
*************** gfc_use_module (gfc_use_list *module)
*** 6757,6764 ****
/* 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!");
init_pi_tree ();
init_true_name_tree ();
--- 6824,6833 ----
/* 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 || 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 ();
Index: gcc/fortran/parse.c
===================================================================
*** gcc/fortran/parse.c (revision 224724)
--- gcc/fortran/parse.c (working copy)
*************** decode_statement (void)
*** 369,374 ****
--- 369,384 ----
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
*************** decode_statement (void)
*** 522,527 ****
--- 532,538 ----
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);
*************** gfc_enclosing_unit (gfc_compile_state *
*** 1534,1541 ****
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)
{
if (result != NULL)
--- 1545,1552 ----
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_SUBMODULE
! || p->state == COMP_BLOCK_DATA || p->state == COMP_PROGRAM)
{
if (result != NULL)
*************** gfc_ascii_statement (gfc_statement st)
*** 1660,1665 ****
--- 1671,1679 ----
case ST_END_MODULE:
p = "END MODULE";
break;
+ case ST_END_SUBMODULE:
+ p = "END SUBMODULE";
+ break;
case ST_END_PROGRAM:
p = "END PROGRAM";
break;
*************** gfc_ascii_statement (gfc_statement st)
*** 1742,1747 ****
--- 1756,1764 ----
case ST_MODULE:
p = "MODULE";
break;
+ case ST_SUBMODULE:
+ p = "SUBMODULE";
+ break;
case ST_PAUSE:
p = "PAUSE";
break;
*************** accept_statement (gfc_statement st)
*** 2186,2191 ****
--- 2203,2209 ----
case ST_FUNCTION:
case ST_SUBROUTINE:
case ST_MODULE:
+ case ST_SUBMODULE:
gfc_current_ns->proc_name = gfc_new_block;
break;
*************** declSt:
*** 3280,3286 ****
break;
case ST_STATEMENT_FUNCTION:
! if (gfc_current_state () == COMP_MODULE)
{
unexpected_statement (st);
break;
--- 3298,3305 ----
break;
case ST_STATEMENT_FUNCTION:
! if (gfc_current_state () == COMP_MODULE
! || gfc_current_state () == COMP_SUBMODULE)
{
unexpected_statement (st);
break;
*************** parse_contained (int module)
*** 4903,4908 ****
--- 4922,4928 ----
/* 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);
*************** parse_contained (int module)
*** 4919,4925 ****
}
}
while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE
! && st != ST_END_MODULE && st != ST_END_PROGRAM);
/* The first namespace in the list is guaranteed to not have
anything (worthwhile) in it. */
--- 4939,4946 ----
}
}
while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE
! && 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. */
*************** contains:
*** 5006,5012 ****
if (p->state == COMP_CONTAINS)
n++;
! if (gfc_find_state (COMP_MODULE) == true)
n--;
if (n > 0)
--- 5027,5034 ----
if (p->state == COMP_CONTAINS)
n++;
! if (gfc_find_state (COMP_MODULE) == true
! || gfc_find_state (COMP_SUBMODULE) == true)
n--;
if (n > 0)
*************** done:
*** 5024,5029 ****
--- 5046,5052 ----
gfc_current_ns->code = gfc_state_stack->head;
if (gfc_state_stack->state == COMP_PROGRAM
|| gfc_state_stack->state == COMP_MODULE
+ || gfc_state_stack->state == COMP_SUBMODULE
|| gfc_state_stack->state == COMP_SUBROUTINE
|| gfc_state_stack->state == COMP_FUNCTION
|| gfc_state_stack->state == COMP_BLOCK)
*************** parse_block_data (void)
*** 5127,5132 ****
--- 5150,5185 ----
}
+ /* 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
*************** parse_module (void)
*** 5146,5151 ****
--- 5199,5213 ----
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;
*************** loop:
*** 5160,5165 ****
--- 5222,5228 ----
break;
case ST_END_MODULE:
+ case ST_END_SUBMODULE:
accept_statement (st);
break;
*************** loop:
*** 5455,5460 ****
--- 5518,5531 ----
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)
*************** loop:
*** 5479,5485 ****
gfc_dump_parse_tree (gfc_current_ns, stdout);
gfc_get_errors (NULL, &errors);
! if (s.state == COMP_MODULE)
{
gfc_dump_module (s.sym->name, errors_before == errors);
gfc_current_ns->derived_types = gfc_derived_types;
--- 5550,5556 ----
gfc_dump_parse_tree (gfc_current_ns, stdout);
gfc_get_errors (NULL, &errors);
! 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;
Index: gcc/fortran/parse.h
===================================================================
*** gcc/fortran/parse.h (revision 224724)
--- gcc/fortran/parse.h (working copy)
*************** along with GCC; see the file COPYING3.
*** 25,33 ****
/* 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_DO, COMP_SELECT, COMP_FORALL, COMP_WHERE, COMP_CONTAINS, COMP_ENUM,
COMP_SELECT_TYPE, COMP_OMP_STRUCTURED_BLOCK, COMP_CRITICAL, COMP_DO_CONCURRENT
}
--- 25,33 ----
/* Enum for what the compiler is currently doing. */
typedef enum
{
! 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
}
Index: gcc/fortran/primary.c
===================================================================
*** gcc/fortran/primary.c (revision 224724)
--- gcc/fortran/primary.c (working copy)
*************** match_variable (gfc_expr **result, int e
*** 3264,3269 ****
--- 3264,3270 ----
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;
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c (revision 224724)
--- gcc/fortran/resolve.c (working copy)
*************** no_init_error:
*** 11301,11306 ****
--- 11301,11332 ----
}
+ /* 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
*************** resolve_fl_procedure (gfc_symbol *sym, i
*** 11565,11570 ****
--- 11591,11661 ----
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;
}
Index: gcc/fortran/symbol.c
===================================================================
*** gcc/fortran/symbol.c (revision 224724)
--- gcc/fortran/symbol.c (working copy)
*************** gfc_add_procedure (symbol_attribute *att
*** 1539,1545 ****
if (where == NULL)
where = &gfc_current_locus;
! if (attr->proc != PROC_UNKNOWN)
{
gfc_error ("%s procedure at %L is already declared as %s procedure",
gfc_code2string (procedures, t), where,
--- 1539,1545 ----
if (where == NULL)
where = &gfc_current_locus;
! 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,
*************** bool
*** 1655,1664 ****
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;
if (where == NULL)
where = &gfc_current_locus;
--- 1655,1669 ----
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;
*************** gfc_add_explicit_interface (gfc_symbol *
*** 1677,1682 ****
--- 1682,1688 ----
return false;
}
+ finish:
sym->formal = formal;
sym->attr.if_source = source;
*************** gfc_add_type (gfc_symbol *sym, gfc_types
*** 1703,1709 ****
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 (sym->attr.use_assoc)
gfc_error ("Symbol %qs at %L conflicts with symbol from module %qs, "
--- 1709,1718 ----
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)
! && !(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, "
Index: gcc/fortran/trans-decl.c
===================================================================
*** gcc/fortran/trans-decl.c (revision 224724)
--- gcc/fortran/trans-decl.c (working copy)
*************** gfc_sym_mangled_function_id (gfc_symbol
*** 379,387 ****
/* use the binding label rather than the mangled name */
return get_identifier (sym->binding_label);
! if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
|| (sym->module != NULL && (sym->attr.external
|| sym->attr.if_source == IFSRC_IFBODY)))
{
/* Main program is mangled into MAIN__. */
if (sym->attr.is_main_program)
--- 379,388 ----
/* use the binding label rather than the mangled name */
return get_identifier (sym->binding_label);
! 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)
*************** gfc_finish_var_decl (tree decl, gfc_symb
*** 601,607 ****
}
/* If a variable is USE associated, it's always external. */
! if (sym->attr.use_assoc)
{
DECL_EXTERNAL (decl) = 1;
TREE_PUBLIC (decl) = 1;
--- 602,608 ----
}
/* If a variable is USE associated, it's always external. */
! if (sym->attr.use_assoc || sym->attr.used_in_submodule)
{
DECL_EXTERNAL (decl) = 1;
TREE_PUBLIC (decl) = 1;
Index: gcc/testsuite/gfortran.dg/submodule_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/submodule_1.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/submodule_1.f90 (working copy)
***************
*** 0 ****
--- 1,177 ----
+ ! { 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)
+ import foo
+ class(foo), intent(in) :: this
+ end subroutine
+
+ module subroutine bye(this)
+ import foo
+ class(foo), intent(in) :: this
+ end subroutine
+
+ module subroutine byebye(this, that)
+ import foo
+ 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 function
+
+ 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 subroutine
+
+ ! 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 subroutine
+
+ module procedure intg
+ intg = 3*arg
+ end function
+
+ module procedure realg
+ realg = 3*arg
+ end function
+
+ 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
+ !
+
Index: gcc/testsuite/gfortran.dg/submodule_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/submodule_2.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/submodule_2.f90 (working copy)
***************
*** 0 ****
--- 1,106 ----
+ ! { 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)
+ import foo
+ type(foo), intent(in), dimension(:) :: this
+ type(foo), allocatable, dimension(:) :: that
+ end function
+ character(16) module function array2(this, that)
+ import foo
+ type(foo), intent(in), dimension(:) :: this
+ type(foo), allocatable, dimension(:) :: that
+ end function
+ module subroutine array3(this, that)
+ import foo
+ type(foo), intent(in), dimension(:) :: this
+ type(foo), intent(inOUT), allocatable, dimension(:) :: that
+ end subroutine
+ module subroutine array4(this, that)
+ import foo
+ 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 function
+
+ 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 subroutine
+
+ 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
+ !
Index: gcc/testsuite/gfortran.dg/submodule_3.f90
===================================================================
*** gcc/testsuite/gfortran.dg/submodule_3.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/submodule_3.f90 (working copy)
***************
*** 0 ****
--- 1,36 ----
+ ! { 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 function ! { dg-error "Expecting END PROGRAM" }
+
+ end SUBMODULE foo_interface_son ! { dg-error "Expecting END PROGRAM" }
+
+ end ! { dg-error "CONTAINS statement without FUNCTION or SUBROUTINE" }
Index: gcc/testsuite/gfortran.dg/submodule_4.f90
===================================================================
*** gcc/testsuite/gfortran.dg/submodule_4.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/submodule_4.f90 (working copy)
***************
*** 0 ****
--- 1,139 ----
+ ! { dg-do compile }
+ !
+ ! Tests comparisons of MODULE PROCEDURE characteristics and
+ ! the characteristics of their dummies.
+ !
+ ! 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)
+ import foo
+ type(foo), intent(in), dimension(:) :: this
+ type(foo), allocatable, dimension(:) :: that
+ end function
+ character(16) module function array2(this, that)
+ import foo
+ type(foo), intent(in), dimension(:) :: this
+ type(foo), allocatable, dimension(:) :: that
+ end function
+ module subroutine array3(this, that)
+ import foo
+ type(foo), intent(in), dimension(:) :: this
+ type(foo), intent(inOUT), allocatable, dimension(:) :: that
+ end subroutine
+ module subroutine array4(this, that)
+ import foo
+ 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
+ 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
+
+ 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
+
+ !
+ program try
+ use foo_interface
+ end program
+ !
Index: gcc/testsuite/gfortran.dg/submodule_5.f90
===================================================================
*** gcc/testsuite/gfortran.dg/submodule_5.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/submodule_5.f90 (working copy)
***************
*** 0 ****
--- 1,38 ----
+ ! { dg-do compile }
+ !
+ ! Checks that PRIVATE/PUBLIC not allowed in submodules.
+ !
+ ! 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
+
+ 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
^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: [Patch, fortran] PR52846 - [F2008] Support submodules
2015-06-22 12:41 [Patch, fortran] PR52846 - [F2008] Support submodules Paul Richard Thomas
@ 2015-06-25 15:29 ` Paul Richard Thomas
2015-06-25 21:23 ` AW: " Bader, Reinhold
2015-06-30 12:36 ` Paul Richard Thomas
0 siblings, 2 replies; 7+ messages in thread
From: Paul Richard Thomas @ 2015-06-25 15:29 UTC (permalink / raw)
To: fortran, gcc-patches
Cc: Damian Rouson, Tobias Burnus, salvatore.filippone, Bader, Reinhold
[-- Attachment #1: Type: text/plain, Size: 11567 bytes --]
Dear All,
Please find attached an updated version of the submodule patch.
Reinhold Bader uncovered a couple of bugs, which have now been fixed:
(i) IMPORT is no longer permitted in module_procedure interface
bodies, as required by F2008(C1210). Instead, import occurs
automatically; and
(ii) The end statement for the abreviated module procedure declaration
was wrong; should have been END PROCEDURE. I started introducing
COMP_MODPROC_FUNC/SUBR in the parser to fix this. However, many of the
if statement became impossibly torturous considering that there was
only one place where it matters. Therefore, I decided to add a bit
field to gfc_symbol as the least invasive way of dealing with the
problem.
The testcases were modified accordingly.
Bootstraps and regtests on FC21/x86_64 - OK for trunk?
Thanks Reinhold!
Paul
2015-06-25 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.
(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
prototypes for the functions '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'.
* module.c (gfc_match_submodule): New function. Add handling
for the 'module_procedure' attribute bit.
* 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.
(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.
* 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_finish_var_decl): Symbols with the 'used_in_submodule' bit
set are set DECL_EXTERNAL as if they were use associated.
2015-06-25 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
On 22 June 2015 at 14:39, Paul Richard Thomas
<paul.richard.thomas@gmail.com> wrote:
> Dear All,
>
> This patch enables submodule support in gfortran. Submodules are a
> feature of F2008 but are fully described in ISO/IEC TR 19767:2004(E).
>
> The patch has one significant non-conformance (that I know about,
> anyway!); whilst private derived type components are correctly dealt
> with, symbols whose access is private within the parent module are
> not. They should effectively be host associated in descendant
> submodules. At present gfortran handles private access at the module
> write stage. This means that when a submodule reads the module file,
> there is no information present about symbols whose access was
> private. Since this modification might cause significant fall-out to
> existing code, I propose to submit a separate patch later on to sort
> out the non-conformance. However, as required private and public
> statements are not allowed in submodules.
>
> The patch makes maximum possible leverage of existing code to handle
> modules. Once the submodule is matched, the ancestor module and
> submodules are first "used" and then all the symbols are set host
> associated and private derived type components set public.
>
> Most of the work involved matching module procedures, with both the
> traditional form of declaration and the abbreviated one. I have chosen
> to treat MODULE as a prefix like PURE or ELEMENTAL. This is logical
> both because of the form of the declaration and because the
> identification of module procedures is most easily done with an
> attribute bit. With traditional procedure declarations, the procedure,
> result and dummy characteristics are compared with those of the
> interface declaration. The comparison of the dummy characteristics is
> a bit cobbled together and might be better done by copying the
> formal_namespace and it's contents to the new symbol and retaining the
> old for the interface symbol. This patch leaves the old dummy symbols
> in the formal namespace in the new ones in the formal arglist. I have
> checked that cleanup occurs for all objects.
>
> Note the comment in submodule_1.f90 about the possibility of
> undetected recursion between procedures in different submodules. I am
> not at all sure that I know how to deal with this and am open to
> suggestions.
>
> In addition, it should be noted that collisions between the names of
> entities and procedures, other than module procedures are detected by
> the linker at present.
>
> Apart from this, all is very straightforward and follows the the ChangeLogs.
>
> Thanks for testing of an early version of the patch by Damian Rouson,
> Salvatore Filippone and Tobias Burnus.
>
> Bootstrapped and regtested on FC21/x86_64 - OK for trunk?
>
> Cheers
>
> Paul
>
> 2015-06-22 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.
> (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.
> (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
> prototypes for the functions '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'.
> * module.c (gfc_match_submodule): New function. Add handling
> for the 'module_procedure' attribute bit.
> * parse.c (decode_statement): 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.
> (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.
> * 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_finish_var_decl): Symbols with the 'used_in_submodule' bit
> set are set DECL_EXTERNAL as if they were use associated.
>
> 2015-06-22 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
--
Outside of a dog, a book is a man's best friend. Inside of a dog it's
too dark to read.
Groucho Marx
[-- Attachment #2: submit2.diff --]
[-- Type: text/plain, Size: 62284 bytes --]
Index: gcc/fortran/decl.c
===================================================================
*** gcc/fortran/decl.c (revision 224724)
--- gcc/fortran/decl.c (working copy)
*************** get_proc_name (const char *name, gfc_sym
*** 903,909 ****
sym = *result;
! 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
--- 903,937 ----
sym = *result;
! 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
*************** gfc_match_import (void)
*** 3262,3267 ****
--- 3290,3302 ----
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;
*************** match_attr_spec (void)
*** 3925,3931 ****
}
/* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
! if (gfc_current_state () == COMP_MODULE && !current_attr.save
&& (gfc_option.allow_std & GFC_STD_F2008) != 0)
current_attr.save = SAVE_IMPLICIT;
--- 3960,3968 ----
}
/* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
! 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;
*************** gfc_match_prefix (gfc_typespec *ts)
*** 4513,4518 ****
--- 4550,4571 ----
/* 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;
*************** gfc_match_formal_arglist (gfc_symbol *pr
*** 4550,4558 ****
--- 4603,4626 ----
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)
*************** ok:
*** 4658,4663 ****
--- 4726,4749 ----
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:
*************** gfc_match_procedure (void)
*** 5271,5276 ****
--- 5357,5363 ----
case COMP_NONE:
case COMP_PROGRAM:
case COMP_MODULE:
+ case COMP_SUBMODULE:
case COMP_SUBROUTINE:
case COMP_FUNCTION:
case COMP_BLOCK:
*************** do_warn_intrinsic_shadow (const gfc_symb
*** 5309,5315 ****
bool in_module;
in_module = (gfc_state_stack->previous
! && gfc_state_stack->previous->state == COMP_MODULE);
gfc_warn_intrinsic_shadow (sym, in_module, func);
}
--- 5396,5403 ----
bool in_module;
in_module = (gfc_state_stack->previous
! && (gfc_state_stack->previous->state == COMP_MODULE
! || gfc_state_stack->previous->state == COMP_SUBMODULE));
gfc_warn_intrinsic_shadow (sym, in_module, func);
}
*************** gfc_match_function_decl (void)
*** 5348,5359 ****
--- 5436,5451 ----
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);
*************** gfc_match_entry (void)
*** 5547,5552 ****
--- 5639,5647 ----
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");
*************** gfc_match_subroutine (void)
*** 5791,5796 ****
--- 5886,5894 ----
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;
*************** gfc_match_end (gfc_statement *st)
*** 6114,6119 ****
--- 6212,6218 ----
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)
*************** gfc_match_end (gfc_statement *st)
*** 6142,6147 ****
--- 6241,6250 ----
break;
}
+ abreviated_modproc_decl
+ = gfc_current_block ()
+ && gfc_current_block ()->abr_modproc_decl;
+
switch (state)
{
case COMP_NONE:
*************** gfc_match_end (gfc_statement *st)
*** 6153,6165 ****
--- 6256,6274 ----
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;
*************** gfc_match_end (gfc_statement *st)
*** 6175,6180 ****
--- 6284,6295 ----
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";
*************** gfc_match_end (gfc_statement *st)
*** 6259,6265 ****
{
if (!gfc_notify_std (GFC_STD_F2008, "END statement "
"instead of %s statement at %L",
! gfc_ascii_statement(*st), &old_loc))
goto cleanup;
}
else if (!eos_ok)
--- 6374,6381 ----
{
if (!gfc_notify_std (GFC_STD_F2008, "END statement "
"instead of %s statement at %L",
! abreviated_modproc_decl ? "END PROCEDURE"
! : gfc_ascii_statement(*st), &old_loc))
goto cleanup;
}
else if (!eos_ok)
*************** gfc_match_end (gfc_statement *st)
*** 6276,6283 ****
/* 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);
goto cleanup;
}
--- 6392,6399 ----
/* 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", abreviated_modproc_decl
! ? "END PROCEDURE" : gfc_ascii_statement(*st), &old_loc);
goto cleanup;
}
*************** syntax:
*** 7417,7422 ****
--- 7533,7647 ----
}
+ /* 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;
+ int rc;
+
+ 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;
+
+ if (sym->ts.interface->attr.function
+ && sym->ts.interface->result
+ && sym->ts.interface->result != sym->ts.interface)
+ sym->result= sym->ts.interface->result;
+ else if (sym->ts.interface->attr.function
+ && sym->ts.interface->result)
+ 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;
+ }
+
+ rc = gfc_get_symbol (formal->sym->name, NULL, &fsym);
+ if (rc)
+ goto cleanup;
+
+ if (!gfc_add_type (fsym, &(formal->sym->ts), &gfc_current_locus))
+ goto cleanup;
+
+ if (!gfc_copy_attr (&(fsym->attr), &(formal->sym->attr),
+ &gfc_current_locus))
+ goto cleanup;
+
+ if (fsym->attr.dimension)
+ fsym->as = gfc_copy_array_spec (formal->sym->as);
+
+ fsym->attr.class_ok = formal->sym->attr.class_ok;
+
+ if (fsym != NULL
+ && (!gfc_add_dummy(&fsym->attr, fsym->name, NULL)
+ || !gfc_missing_attr (&fsym->attr, NULL)))
+ 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. */
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h (revision 224724)
--- gcc/fortran/gfortran.h (working copy)
*************** typedef enum
*** 201,219 ****
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_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,
--- 201,219 ----
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_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,
*************** typedef struct
*** 751,756 ****
--- 751,759 ----
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. */
*************** typedef struct
*** 779,784 ****
--- 782,792 ----
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;
*************** typedef struct gfc_symbol
*** 1459,1464 ****
--- 1467,1476 ----
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. This is only needed
+ to signal the correct END statement. */
+ unsigned abr_modproc_decl:1;
int refs;
struct gfc_namespace *ns; /* namespace containing this symbol */
*************** bool gfc_ref_dimen_size (gfc_array_ref *
*** 3087,3092 ****
--- 3099,3108 ----
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 *);
Index: gcc/fortran/interface.c
===================================================================
*** gcc/fortran/interface.c (revision 224724)
--- gcc/fortran/interface.c (working copy)
*************** symbol_rank (gfc_symbol *sym)
*** 1066,1074 ****
/* 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)
{
if (s1 == NULL || s2 == NULL)
return s1 == s2 ? true : false;
--- 1066,1075 ----
/* Check if the characteristics of two dummy arguments match,
cf. F08:12.3.2. */
! 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;
*************** check_dummy_characteristics (gfc_symbol
*** 1275,1282 ****
/* 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,
char *errmsg, int err_len)
{
gfc_symbol *r1, *r2;
--- 1276,1283 ----
/* Check if the characteristics of two function results match,
cf. F08:12.3.3. */
! bool
! gfc_check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2,
char *errmsg, int err_len)
{
gfc_symbol *r1, *r2;
*************** gfc_compare_interfaces (gfc_symbol *s1,
*** 1472,1479 ****
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))
return 0;
}
--- 1473,1480 ----
if (s1->attr.function && s2->attr.function)
{
/* If both are functions, check result characteristics. */
! if (!gfc_check_result_characteristics (s1, s2, errmsg, err_len)
! || !gfc_check_result_characteristics (s2, s1, errmsg, err_len))
return 0;
}
*************** gfc_compare_interfaces (gfc_symbol *s1,
*** 1533,1539 ****
if (strict_flag)
{
/* Check all characteristics. */
! if (!check_dummy_characteristics (f1->sym, f2->sym, true,
errmsg, err_len))
return 0;
}
--- 1534,1540 ----
if (strict_flag)
{
/* Check all characteristics. */
! if (!gfc_check_dummy_characteristics (f1->sym, f2->sym, true,
errmsg, err_len))
return 0;
}
*************** gfc_check_typebound_override (gfc_symtre
*** 4241,4248 ****
return false;
}
! if (!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);
--- 4242,4249 ----
return false;
}
! 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);
*************** gfc_check_typebound_override (gfc_symtre
*** 4293,4299 ****
}
check_type = proc_pass_arg != argpos && old_pass_arg != argpos;
! if (!check_dummy_characteristics (proc_formal->sym, old_formal->sym,
check_type, err, sizeof(err)))
{
gfc_error ("Argument mismatch for the overriding procedure "
--- 4294,4300 ----
}
check_type = proc_pass_arg != argpos && old_pass_arg != argpos;
! if (!gfc_check_dummy_characteristics (proc_formal->sym, old_formal->sym,
check_type, err, sizeof(err)))
{
gfc_error ("Argument mismatch for the overriding procedure "
Index: gcc/fortran/match.h
===================================================================
*** gcc/fortran/match.h (revision 224724)
--- gcc/fortran/match.h (working copy)
*************** match gfc_match_generic (void);
*** 203,208 ****
--- 203,209 ----
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);
*************** match gfc_match_expr (gfc_expr **);
*** 291,296 ****
--- 292,298 ----
/* module.c. */
match gfc_match_use (void);
+ match gfc_match_submodule (void);
void gfc_use_modules (void);
#endif /* GFC_MATCH_H */
Index: gcc/fortran/module.c
===================================================================
*** gcc/fortran/module.c (revision 224724)
--- gcc/fortran/module.c (working copy)
*************** cleanup:
*** 716,721 ****
--- 716,782 ----
}
+ /* 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
*************** typedef enum
*** 1887,1893 ****
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_attribute;
--- 1948,1954 ----
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_MODULE_PROCEDURE
}
ab_attribute;
*************** static const mstring attr_bits[] =
*** 1944,1949 ****
--- 2005,2011 ----
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)
};
*************** mio_symbol_attribute (symbol_attribute *
*** 2126,2131 ****
--- 2188,2195 ----
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 ();
*************** mio_symbol_attribute (symbol_attribute *
*** 2295,2300 ****
--- 2359,2367 ----
case AB_ARRAY_OUTER_DEPENDENCY:
attr->array_outer_dependency =1;
break;
+ case AB_MODULE_PROCEDURE:
+ attr->module_procedure =1;
+ break;
}
}
}
*************** gfc_use_module (gfc_use_list *module)
*** 6757,6764 ****
/* 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!");
init_pi_tree ();
init_true_name_tree ();
--- 6824,6833 ----
/* 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 || 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 ();
Index: gcc/fortran/parse.c
===================================================================
*** gcc/fortran/parse.c (revision 224724)
--- gcc/fortran/parse.c (working copy)
*************** decode_statement (void)
*** 369,374 ****
--- 369,384 ----
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
*************** decode_statement (void)
*** 522,527 ****
--- 532,538 ----
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);
*************** gfc_enclosing_unit (gfc_compile_state *
*** 1534,1541 ****
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)
{
if (result != NULL)
--- 1545,1552 ----
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_SUBMODULE
! || p->state == COMP_BLOCK_DATA || p->state == COMP_PROGRAM)
{
if (result != NULL)
*************** gfc_ascii_statement (gfc_statement st)
*** 1660,1665 ****
--- 1671,1679 ----
case ST_END_MODULE:
p = "END MODULE";
break;
+ case ST_END_SUBMODULE:
+ p = "END SUBMODULE";
+ break;
case ST_END_PROGRAM:
p = "END PROGRAM";
break;
*************** gfc_ascii_statement (gfc_statement st)
*** 1742,1747 ****
--- 1756,1764 ----
case ST_MODULE:
p = "MODULE";
break;
+ case ST_SUBMODULE:
+ p = "SUBMODULE";
+ break;
case ST_PAUSE:
p = "PAUSE";
break;
*************** accept_statement (gfc_statement st)
*** 2186,2191 ****
--- 2203,2209 ----
case ST_FUNCTION:
case ST_SUBROUTINE:
case ST_MODULE:
+ case ST_SUBMODULE:
gfc_current_ns->proc_name = gfc_new_block;
break;
*************** loop:
*** 2931,2936 ****
--- 2949,2958 ----
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:
*************** declSt:
*** 3280,3286 ****
break;
case ST_STATEMENT_FUNCTION:
! if (gfc_current_state () == COMP_MODULE)
{
unexpected_statement (st);
break;
--- 3302,3309 ----
break;
case ST_STATEMENT_FUNCTION:
! if (gfc_current_state () == COMP_MODULE
! || gfc_current_state () == COMP_SUBMODULE)
{
unexpected_statement (st);
break;
*************** parse_contained (int module)
*** 4903,4908 ****
--- 4926,4932 ----
/* 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);
*************** parse_contained (int module)
*** 4919,4925 ****
}
}
while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE
! && st != ST_END_MODULE && st != ST_END_PROGRAM);
/* The first namespace in the list is guaranteed to not have
anything (worthwhile) in it. */
--- 4943,4950 ----
}
}
while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE
! && 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. */
*************** contains:
*** 5006,5012 ****
if (p->state == COMP_CONTAINS)
n++;
! if (gfc_find_state (COMP_MODULE) == true)
n--;
if (n > 0)
--- 5031,5038 ----
if (p->state == COMP_CONTAINS)
n++;
! if (gfc_find_state (COMP_MODULE) == true
! || gfc_find_state (COMP_SUBMODULE) == true)
n--;
if (n > 0)
*************** parse_block_data (void)
*** 5127,5132 ****
--- 5153,5188 ----
}
+ /* 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
*************** parse_module (void)
*** 5146,5151 ****
--- 5202,5216 ----
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;
*************** loop:
*** 5160,5165 ****
--- 5225,5231 ----
break;
case ST_END_MODULE:
+ case ST_END_SUBMODULE:
accept_statement (st);
break;
*************** loop:
*** 5455,5460 ****
--- 5521,5534 ----
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)
*************** loop:
*** 5479,5485 ****
gfc_dump_parse_tree (gfc_current_ns, stdout);
gfc_get_errors (NULL, &errors);
! if (s.state == COMP_MODULE)
{
gfc_dump_module (s.sym->name, errors_before == errors);
gfc_current_ns->derived_types = gfc_derived_types;
--- 5553,5559 ----
gfc_dump_parse_tree (gfc_current_ns, stdout);
gfc_get_errors (NULL, &errors);
! 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;
Index: gcc/fortran/parse.h
===================================================================
*** gcc/fortran/parse.h (revision 224724)
--- gcc/fortran/parse.h (working copy)
*************** along with GCC; see the file COPYING3.
*** 25,33 ****
/* 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_DO, COMP_SELECT, COMP_FORALL, COMP_WHERE, COMP_CONTAINS, COMP_ENUM,
COMP_SELECT_TYPE, COMP_OMP_STRUCTURED_BLOCK, COMP_CRITICAL, COMP_DO_CONCURRENT
}
--- 25,33 ----
/* Enum for what the compiler is currently doing. */
typedef enum
{
! 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
}
Index: gcc/fortran/primary.c
===================================================================
*** gcc/fortran/primary.c (revision 224724)
--- gcc/fortran/primary.c (working copy)
*************** gfc_match_rvalue (gfc_expr **result)
*** 2960,2966 ****
st = gfc_enclosing_unit (NULL);
! if (st != NULL && st->state == COMP_FUNCTION
&& st->sym == sym
&& !sym->attr.recursive)
{
--- 2960,2967 ----
st = gfc_enclosing_unit (NULL);
! if (st != NULL
! && st->state == COMP_FUNCTION
&& st->sym == sym
&& !sym->attr.recursive)
{
*************** match_variable (gfc_expr **result, int e
*** 3264,3269 ****
--- 3265,3271 ----
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;
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c (revision 224724)
--- gcc/fortran/resolve.c (working copy)
*************** no_init_error:
*** 11301,11306 ****
--- 11301,11332 ----
}
+ /* 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
*************** resolve_fl_procedure (gfc_symbol *sym, i
*** 11565,11570 ****
--- 11591,11661 ----
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;
}
Index: gcc/fortran/symbol.c
===================================================================
*** gcc/fortran/symbol.c (revision 224724)
--- gcc/fortran/symbol.c (working copy)
*************** gfc_add_procedure (symbol_attribute *att
*** 1539,1545 ****
if (where == NULL)
where = &gfc_current_locus;
! if (attr->proc != PROC_UNKNOWN)
{
gfc_error ("%s procedure at %L is already declared as %s procedure",
gfc_code2string (procedures, t), where,
--- 1539,1545 ----
if (where == NULL)
where = &gfc_current_locus;
! 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,
*************** bool
*** 1655,1664 ****
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;
if (where == NULL)
where = &gfc_current_locus;
--- 1655,1669 ----
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;
*************** gfc_add_explicit_interface (gfc_symbol *
*** 1677,1682 ****
--- 1682,1688 ----
return false;
}
+ finish:
sym->formal = formal;
sym->attr.if_source = source;
*************** gfc_add_type (gfc_symbol *sym, gfc_types
*** 1703,1709 ****
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 (sym->attr.use_assoc)
gfc_error ("Symbol %qs at %L conflicts with symbol from module %qs, "
--- 1709,1718 ----
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)
! && !(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, "
Index: gcc/fortran/trans-decl.c
===================================================================
*** gcc/fortran/trans-decl.c (revision 224724)
--- gcc/fortran/trans-decl.c (working copy)
*************** gfc_sym_mangled_function_id (gfc_symbol
*** 379,387 ****
/* use the binding label rather than the mangled name */
return get_identifier (sym->binding_label);
! if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
|| (sym->module != NULL && (sym->attr.external
|| sym->attr.if_source == IFSRC_IFBODY)))
{
/* Main program is mangled into MAIN__. */
if (sym->attr.is_main_program)
--- 379,388 ----
/* use the binding label rather than the mangled name */
return get_identifier (sym->binding_label);
! 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)
*************** gfc_finish_var_decl (tree decl, gfc_symb
*** 601,607 ****
}
/* If a variable is USE associated, it's always external. */
! if (sym->attr.use_assoc)
{
DECL_EXTERNAL (decl) = 1;
TREE_PUBLIC (decl) = 1;
--- 602,608 ----
}
/* If a variable is USE associated, it's always external. */
! if (sym->attr.use_assoc || sym->attr.used_in_submodule)
{
DECL_EXTERNAL (decl) = 1;
TREE_PUBLIC (decl) = 1;
Index: gcc/testsuite/gfortran.dg/submodule_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/submodule_1.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/submodule_1.f90 (working copy)
***************
*** 0 ****
--- 1,174 ----
+ ! { 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
+ !
+
Index: gcc/testsuite/gfortran.dg/submodule_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/submodule_2.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/submodule_2.f90 (working copy)
***************
*** 0 ****
--- 1,101 ----
+ ! { 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
+ !
Index: gcc/testsuite/gfortran.dg/submodule_3.f90
===================================================================
*** gcc/testsuite/gfortran.dg/submodule_3.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/submodule_3.f90 (working copy)
***************
*** 0 ****
--- 1,36 ----
+ ! { 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" }
Index: gcc/testsuite/gfortran.dg/submodule_4.f90
===================================================================
*** gcc/testsuite/gfortran.dg/submodule_4.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/submodule_4.f90 (working copy)
***************
*** 0 ****
--- 1,135 ----
+ ! { dg-do compile }
+ !
+ ! Tests comparisons of MODULE PROCEDURE characteristics and
+ ! the characteristics of their dummies.
+ !
+ ! 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
+ 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
+
+ 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
+
+ !
+ program try
+ use foo_interface
+ end program
+ !
Index: gcc/testsuite/gfortran.dg/submodule_5.f90
===================================================================
*** gcc/testsuite/gfortran.dg/submodule_5.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/submodule_5.f90 (working copy)
***************
*** 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
^ permalink raw reply [flat|nested] 7+ messages in thread
* AW: [Patch, fortran] PR52846 - [F2008] Support submodules
2015-06-25 15:29 ` Paul Richard Thomas
@ 2015-06-25 21:23 ` Bader, Reinhold
2015-06-25 22:57 ` Paul Richard Thomas
2015-06-30 12:36 ` Paul Richard Thomas
1 sibling, 1 reply; 7+ messages in thread
From: Bader, Reinhold @ 2015-06-25 21:23 UTC (permalink / raw)
To: Paul Richard Thomas, fortran, gcc-patches
Cc: Damian Rouson, Tobias Burnus, salvatore.filippone
[-- Attachment #1: Type: text/plain, Size: 12904 bytes --]
Looks much better.
Attached another test case that fails compilation. The function result as declared
in the module procedure interface is not propagated to the submodule that uses the
argument/resultless form in the implementation.
Cheers
Reinhold
> -----Ursprüngliche Nachricht-----
> Von: Paul Richard Thomas [mailto:paul.richard.thomas@gmail.com]
> Gesendet: Donnerstag, 25. Juni 2015 17:16
> An: fortran@gcc.gnu.org; gcc-patches
> Cc: Damian Rouson; Tobias Burnus; salvatore.filippone@uniroma2.it; Bader,
> Reinhold
> Betreff: Re: [Patch, fortran] PR52846 - [F2008] Support submodules
>
> Dear All,
>
> Please find attached an updated version of the submodule patch.
> Reinhold Bader uncovered a couple of bugs, which have now been fixed:
> (i) IMPORT is no longer permitted in module_procedure interface
> bodies, as required by F2008(C1210). Instead, import occurs
> automatically; and
> (ii) The end statement for the abreviated module procedure declaration
> was wrong; should have been END PROCEDURE. I started introducing
> COMP_MODPROC_FUNC/SUBR in the parser to fix this. However, many of the
> if statement became impossibly torturous considering that there was
> only one place where it matters. Therefore, I decided to add a bit
> field to gfc_symbol as the least invasive way of dealing with the
> problem.
>
> The testcases were modified accordingly.
>
> Bootstraps and regtests on FC21/x86_64 - OK for trunk?
>
> Thanks Reinhold!
>
> Paul
>
> 2015-06-25 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.
> (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
> prototypes for the functions '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'.
> * module.c (gfc_match_submodule): New function. Add handling
> for the 'module_procedure' attribute bit.
> * 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.
> (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.
> * 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_finish_var_decl): Symbols with the 'used_in_submodule' bit
> set are set DECL_EXTERNAL as if they were use associated.
>
> 2015-06-25 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
>
> On 22 June 2015 at 14:39, Paul Richard Thomas
> <paul.richard.thomas@gmail.com> wrote:
> > Dear All,
> >
> > This patch enables submodule support in gfortran. Submodules are a
> > feature of F2008 but are fully described in ISO/IEC TR 19767:2004(E).
> >
> > The patch has one significant non-conformance (that I know about,
> > anyway!); whilst private derived type components are correctly dealt
> > with, symbols whose access is private within the parent module are
> > not. They should effectively be host associated in descendant
> > submodules. At present gfortran handles private access at the module
> > write stage. This means that when a submodule reads the module file,
> > there is no information present about symbols whose access was
> > private. Since this modification might cause significant fall-out to
> > existing code, I propose to submit a separate patch later on to sort
> > out the non-conformance. However, as required private and public
> > statements are not allowed in submodules.
> >
> > The patch makes maximum possible leverage of existing code to handle
> > modules. Once the submodule is matched, the ancestor module and
> > submodules are first "used" and then all the symbols are set host
> > associated and private derived type components set public.
> >
> > Most of the work involved matching module procedures, with both the
> > traditional form of declaration and the abbreviated one. I have chosen
> > to treat MODULE as a prefix like PURE or ELEMENTAL. This is logical
> > both because of the form of the declaration and because the
> > identification of module procedures is most easily done with an
> > attribute bit. With traditional procedure declarations, the procedure,
> > result and dummy characteristics are compared with those of the
> > interface declaration. The comparison of the dummy characteristics is
> > a bit cobbled together and might be better done by copying the
> > formal_namespace and it's contents to the new symbol and retaining the
> > old for the interface symbol. This patch leaves the old dummy symbols
> > in the formal namespace in the new ones in the formal arglist. I have
> > checked that cleanup occurs for all objects.
> >
> > Note the comment in submodule_1.f90 about the possibility of
> > undetected recursion between procedures in different submodules. I am
> > not at all sure that I know how to deal with this and am open to
> > suggestions.
> >
> > In addition, it should be noted that collisions between the names of
> > entities and procedures, other than module procedures are detected by
> > the linker at present.
> >
> > Apart from this, all is very straightforward and follows the the ChangeLogs.
> >
> > Thanks for testing of an early version of the patch by Damian Rouson,
> > Salvatore Filippone and Tobias Burnus.
> >
> > Bootstrapped and regtested on FC21/x86_64 - OK for trunk?
> >
> > Cheers
> >
> > Paul
> >
> > 2015-06-22 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.
> > (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.
> > (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
> > prototypes for the functions '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'.
> > * module.c (gfc_match_submodule): New function. Add handling
> > for the 'module_procedure' attribute bit.
> > * parse.c (decode_statement): 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.
> > (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.
> > * 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_finish_var_decl): Symbols with the 'used_in_submodule' bit
> > set are set DECL_EXTERNAL as if they were use associated.
> >
> > 2015-06-22 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
>
>
>
> --
> Outside of a dog, a book is a man's best friend. Inside of a dog it's
> too dark to read.
>
> Groucho Marx
[-- Attachment #2: subm_04_pos.f90 --]
[-- Type: application/octet-stream, Size: 2004 bytes --]
module mod_a
implicit none
type, abstract :: t_a
end type t_a
interface
module subroutine p_a(this, q)
! t_a is accessible - no IMPORT needed
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
write(*,*) 'FAIL (RTTI1)'
error stop
end select
class default
write(*,*) 'FAIL (RTTI2)'
error stop
end select
end procedure p_a
module procedure print
select type (this)
type is (t_imp)
if (sum (abs(this%b%i - [3,4,5])) == 0) then
write(*,*) 'OK'
else
write(*,*) 'FAIL:', this%b%i
end if
class default
write(*,*) 'FAIL (RTTI3)'
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
^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: [Patch, fortran] PR52846 - [F2008] Support submodules
2015-06-25 21:23 ` AW: " Bader, Reinhold
@ 2015-06-25 22:57 ` Paul Richard Thomas
0 siblings, 0 replies; 7+ messages in thread
From: Paul Richard Thomas @ 2015-06-25 22:57 UTC (permalink / raw)
To: Bader, Reinhold
Cc: fortran, gcc-patches, Damian Rouson, Tobias Burnus, salvatore.filippone
Dear Reinhold,
That looks like a very strange bug. I am out of the loop until Sunday
evening and so cannot look at it until then.
Thanks, this really helps
Paul
On 25 June 2015 at 23:21, Bader, Reinhold <Reinhold.Bader@lrz.de> wrote:
> Looks much better.
>
> Attached another test case that fails compilation. The function result as declared
> in the module procedure interface is not propagated to the submodule that uses the
> argument/resultless form in the implementation.
>
> Cheers
> Reinhold
>
>> -----Ursprüngliche Nachricht-----
>> Von: Paul Richard Thomas [mailto:paul.richard.thomas@gmail.com]
>> Gesendet: Donnerstag, 25. Juni 2015 17:16
>> An: fortran@gcc.gnu.org; gcc-patches
>> Cc: Damian Rouson; Tobias Burnus; salvatore.filippone@uniroma2.it; Bader,
>> Reinhold
>> Betreff: Re: [Patch, fortran] PR52846 - [F2008] Support submodules
>>
>> Dear All,
>>
>> Please find attached an updated version of the submodule patch.
>> Reinhold Bader uncovered a couple of bugs, which have now been fixed:
>> (i) IMPORT is no longer permitted in module_procedure interface
>> bodies, as required by F2008(C1210). Instead, import occurs
>> automatically; and
>> (ii) The end statement for the abreviated module procedure declaration
>> was wrong; should have been END PROCEDURE. I started introducing
>> COMP_MODPROC_FUNC/SUBR in the parser to fix this. However, many of the
>> if statement became impossibly torturous considering that there was
>> only one place where it matters. Therefore, I decided to add a bit
>> field to gfc_symbol as the least invasive way of dealing with the
>> problem.
>>
>> The testcases were modified accordingly.
>>
>> Bootstraps and regtests on FC21/x86_64 - OK for trunk?
>>
>> Thanks Reinhold!
>>
>> Paul
>>
>> 2015-06-25 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.
>> (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
>> prototypes for the functions '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'.
>> * module.c (gfc_match_submodule): New function. Add handling
>> for the 'module_procedure' attribute bit.
>> * 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.
>> (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.
>> * 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_finish_var_decl): Symbols with the 'used_in_submodule' bit
>> set are set DECL_EXTERNAL as if they were use associated.
>>
>> 2015-06-25 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
>>
>> On 22 June 2015 at 14:39, Paul Richard Thomas
>> <paul.richard.thomas@gmail.com> wrote:
>> > Dear All,
>> >
>> > This patch enables submodule support in gfortran. Submodules are a
>> > feature of F2008 but are fully described in ISO/IEC TR 19767:2004(E).
>> >
>> > The patch has one significant non-conformance (that I know about,
>> > anyway!); whilst private derived type components are correctly dealt
>> > with, symbols whose access is private within the parent module are
>> > not. They should effectively be host associated in descendant
>> > submodules. At present gfortran handles private access at the module
>> > write stage. This means that when a submodule reads the module file,
>> > there is no information present about symbols whose access was
>> > private. Since this modification might cause significant fall-out to
>> > existing code, I propose to submit a separate patch later on to sort
>> > out the non-conformance. However, as required private and public
>> > statements are not allowed in submodules.
>> >
>> > The patch makes maximum possible leverage of existing code to handle
>> > modules. Once the submodule is matched, the ancestor module and
>> > submodules are first "used" and then all the symbols are set host
>> > associated and private derived type components set public.
>> >
>> > Most of the work involved matching module procedures, with both the
>> > traditional form of declaration and the abbreviated one. I have chosen
>> > to treat MODULE as a prefix like PURE or ELEMENTAL. This is logical
>> > both because of the form of the declaration and because the
>> > identification of module procedures is most easily done with an
>> > attribute bit. With traditional procedure declarations, the procedure,
>> > result and dummy characteristics are compared with those of the
>> > interface declaration. The comparison of the dummy characteristics is
>> > a bit cobbled together and might be better done by copying the
>> > formal_namespace and it's contents to the new symbol and retaining the
>> > old for the interface symbol. This patch leaves the old dummy symbols
>> > in the formal namespace in the new ones in the formal arglist. I have
>> > checked that cleanup occurs for all objects.
>> >
>> > Note the comment in submodule_1.f90 about the possibility of
>> > undetected recursion between procedures in different submodules. I am
>> > not at all sure that I know how to deal with this and am open to
>> > suggestions.
>> >
>> > In addition, it should be noted that collisions between the names of
>> > entities and procedures, other than module procedures are detected by
>> > the linker at present.
>> >
>> > Apart from this, all is very straightforward and follows the the ChangeLogs.
>> >
>> > Thanks for testing of an early version of the patch by Damian Rouson,
>> > Salvatore Filippone and Tobias Burnus.
>> >
>> > Bootstrapped and regtested on FC21/x86_64 - OK for trunk?
>> >
>> > Cheers
>> >
>> > Paul
>> >
>> > 2015-06-22 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.
>> > (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.
>> > (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
>> > prototypes for the functions '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'.
>> > * module.c (gfc_match_submodule): New function. Add handling
>> > for the 'module_procedure' attribute bit.
>> > * parse.c (decode_statement): 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.
>> > (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.
>> > * 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_finish_var_decl): Symbols with the 'used_in_submodule' bit
>> > set are set DECL_EXTERNAL as if they were use associated.
>> >
>> > 2015-06-22 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
>>
>>
>>
>> --
>> Outside of a dog, a book is a man's best friend. Inside of a dog it's
>> too dark to read.
>>
>> Groucho Marx
--
Outside of a dog, a book is a man's best friend. Inside of a dog it's
too dark to read.
Groucho Marx
^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: [Patch, fortran] PR52846 - [F2008] Support submodules
2015-06-25 15:29 ` Paul Richard Thomas
2015-06-25 21:23 ` AW: " Bader, Reinhold
@ 2015-06-30 12:36 ` Paul Richard Thomas
2015-06-30 13:59 ` FX
1 sibling, 1 reply; 7+ messages in thread
From: Paul Richard Thomas @ 2015-06-30 12:36 UTC (permalink / raw)
To: fortran, gcc-patches
Cc: Damian Rouson, Tobias Burnus, salvatore.filippone, Bader, Reinhold
[-- Attachment #1: Type: text/plain, Size: 18257 bytes --]
Dear All,
Please find attached the latest version of the submodule patch. You
might note that the number of the patch has been incremented by two.
The intermediate version went to Reinhold Bader and co for testing.
The main improvements in this version are:
(i) As reported by Reinhold, the interface declaration of the function
result in the abbreviated form of module procedure was not being
correctly incorporated. The only reason why the previous version
worked at all was that I wasn't using implicit none... or, rather, I
did not detect the error for that reason ***blush*** This has been
fixed in parse.c(get_modproc_result);
(ii) Repetition of the dummy or result declarations is now caught and
prevents a segfault as the parser state stack dies; and
(iii) Various new errors are tested in submodule_4.f90 and Reinhold's
test has been added as submodule_6.f90.
Please note that the issue with PRIVATE statements or attributes in
modules has not been corrected yet. I will correct this once the
attached has been committed. Private components are handled correctly,
however.
Bootstrapped and regtested on FC21/x86_64 - OK for trunk?
If the patch is not reviewed by Thursday evening (21:00 CET), I will
commit it anyway unless Reinhold or Salvatore come up with and
further, significant issues. The new elements in the patch are well
ring-fenced by new attributes or F2008 specific declarations and so I
do not believe that it will cause any regressions. Any minor issues
that come up can be dealt with later. I am anxious to get to work on
the PRIVATE issue and want to do so on the basis of this patch being
committed.
With best regards
Paul
2015-06-30 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'.
* module.c (gfc_match_submodule): New function. Add handling
for the 'module_procedure' attribute bit.
* 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-06-30 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
On 25 June 2015 at 17:15, Paul Richard Thomas
<paul.richard.thomas@gmail.com> wrote:
> Dear All,
>
> Please find attached an updated version of the submodule patch.
> Reinhold Bader uncovered a couple of bugs, which have now been fixed:
> (i) IMPORT is no longer permitted in module_procedure interface
> bodies, as required by F2008(C1210). Instead, import occurs
> automatically; and
> (ii) The end statement for the abreviated module procedure declaration
> was wrong; should have been END PROCEDURE. I started introducing
> COMP_MODPROC_FUNC/SUBR in the parser to fix this. However, many of the
> if statement became impossibly torturous considering that there was
> only one place where it matters. Therefore, I decided to add a bit
> field to gfc_symbol as the least invasive way of dealing with the
> problem.
>
> The testcases were modified accordingly.
>
> Bootstraps and regtests on FC21/x86_64 - OK for trunk?
>
> Thanks Reinhold!
>
> Paul
>
> 2015-06-25 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.
> (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
> prototypes for the functions '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'.
> * module.c (gfc_match_submodule): New function. Add handling
> for the 'module_procedure' attribute bit.
> * 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.
> (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.
> * 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_finish_var_decl): Symbols with the 'used_in_submodule' bit
> set are set DECL_EXTERNAL as if they were use associated.
>
> 2015-06-25 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
>
> On 22 June 2015 at 14:39, Paul Richard Thomas
> <paul.richard.thomas@gmail.com> wrote:
>> Dear All,
>>
>> This patch enables submodule support in gfortran. Submodules are a
>> feature of F2008 but are fully described in ISO/IEC TR 19767:2004(E).
>>
>> The patch has one significant non-conformance (that I know about,
>> anyway!); whilst private derived type components are correctly dealt
>> with, symbols whose access is private within the parent module are
>> not. They should effectively be host associated in descendant
>> submodules. At present gfortran handles private access at the module
>> write stage. This means that when a submodule reads the module file,
>> there is no information present about symbols whose access was
>> private. Since this modification might cause significant fall-out to
>> existing code, I propose to submit a separate patch later on to sort
>> out the non-conformance. However, as required private and public
>> statements are not allowed in submodules.
>>
>> The patch makes maximum possible leverage of existing code to handle
>> modules. Once the submodule is matched, the ancestor module and
>> submodules are first "used" and then all the symbols are set host
>> associated and private derived type components set public.
>>
>> Most of the work involved matching module procedures, with both the
>> traditional form of declaration and the abbreviated one. I have chosen
>> to treat MODULE as a prefix like PURE or ELEMENTAL. This is logical
>> both because of the form of the declaration and because the
>> identification of module procedures is most easily done with an
>> attribute bit. With traditional procedure declarations, the procedure,
>> result and dummy characteristics are compared with those of the
>> interface declaration. The comparison of the dummy characteristics is
>> a bit cobbled together and might be better done by copying the
>> formal_namespace and it's contents to the new symbol and retaining the
>> old for the interface symbol. This patch leaves the old dummy symbols
>> in the formal namespace in the new ones in the formal arglist. I have
>> checked that cleanup occurs for all objects.
>>
>> Note the comment in submodule_1.f90 about the possibility of
>> undetected recursion between procedures in different submodules. I am
>> not at all sure that I know how to deal with this and am open to
>> suggestions.
>>
>> In addition, it should be noted that collisions between the names of
>> entities and procedures, other than module procedures are detected by
>> the linker at present.
>>
>> Apart from this, all is very straightforward and follows the the ChangeLogs.
>>
>> Thanks for testing of an early version of the patch by Damian Rouson,
>> Salvatore Filippone and Tobias Burnus.
>>
>> Bootstrapped and regtested on FC21/x86_64 - OK for trunk?
>>
>> Cheers
>>
>> Paul
>>
>> 2015-06-22 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.
>> (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.
>> (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
>> prototypes for the functions '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'.
>> * module.c (gfc_match_submodule): New function. Add handling
>> for the 'module_procedure' attribute bit.
>> * parse.c (decode_statement): 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.
>> (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.
>> * 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_finish_var_decl): Symbols with the 'used_in_submodule' bit
>> set are set DECL_EXTERNAL as if they were use associated.
>>
>> 2015-06-22 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
>
>
>
> --
> Outside of a dog, a book is a man's best friend. Inside of a dog it's
> too dark to read.
>
> Groucho Marx
--
Outside of a dog, a book is a man's best friend. Inside of a dog it's
too dark to read.
Groucho Marx
[-- Attachment #2: submit4.diff --]
[-- Type: text/plain, Size: 69541 bytes --]
Index: gcc/fortran/decl.c
===================================================================
*** gcc/fortran/decl.c (revision 224724)
--- gcc/fortran/decl.c (working copy)
*************** get_proc_name (const char *name, gfc_sym
*** 903,909 ****
sym = *result;
! 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
--- 903,937 ----
sym = *result;
! 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
*************** variable_decl (int elem)
*** 1918,1923 ****
--- 1946,1968 ----
}
}
+ /* 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. */
*************** gfc_match_import (void)
*** 3262,3267 ****
--- 3307,3319 ----
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;
*************** match_attr_spec (void)
*** 3925,3931 ****
}
/* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
! if (gfc_current_state () == COMP_MODULE && !current_attr.save
&& (gfc_option.allow_std & GFC_STD_F2008) != 0)
current_attr.save = SAVE_IMPLICIT;
--- 3977,3985 ----
}
/* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
! 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;
*************** gfc_match_prefix (gfc_typespec *ts)
*** 4513,4518 ****
--- 4567,4588 ----
/* 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;
*************** gfc_match_formal_arglist (gfc_symbol *pr
*** 4550,4558 ****
--- 4620,4643 ----
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)
*************** ok:
*** 4658,4663 ****
--- 4743,4766 ----
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:
*************** gfc_match_procedure (void)
*** 5271,5276 ****
--- 5374,5380 ----
case COMP_NONE:
case COMP_PROGRAM:
case COMP_MODULE:
+ case COMP_SUBMODULE:
case COMP_SUBROUTINE:
case COMP_FUNCTION:
case COMP_BLOCK:
*************** do_warn_intrinsic_shadow (const gfc_symb
*** 5309,5315 ****
bool in_module;
in_module = (gfc_state_stack->previous
! && gfc_state_stack->previous->state == COMP_MODULE);
gfc_warn_intrinsic_shadow (sym, in_module, func);
}
--- 5413,5420 ----
bool in_module;
in_module = (gfc_state_stack->previous
! && (gfc_state_stack->previous->state == COMP_MODULE
! || gfc_state_stack->previous->state == COMP_SUBMODULE));
gfc_warn_intrinsic_shadow (sym, in_module, func);
}
*************** gfc_match_function_decl (void)
*** 5348,5359 ****
--- 5453,5468 ----
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);
*************** gfc_match_entry (void)
*** 5547,5552 ****
--- 5656,5664 ----
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");
*************** gfc_match_subroutine (void)
*** 5791,5796 ****
--- 5903,5911 ----
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;
*************** gfc_match_end (gfc_statement *st)
*** 6114,6119 ****
--- 6229,6235 ----
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)
*************** gfc_match_end (gfc_statement *st)
*** 6142,6147 ****
--- 6258,6267 ----
break;
}
+ abreviated_modproc_decl
+ = gfc_current_block ()
+ && gfc_current_block ()->abr_modproc_decl;
+
switch (state)
{
case COMP_NONE:
*************** gfc_match_end (gfc_statement *st)
*** 6153,6165 ****
--- 6273,6291 ----
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;
*************** gfc_match_end (gfc_statement *st)
*** 6175,6180 ****
--- 6301,6312 ----
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";
*************** gfc_match_end (gfc_statement *st)
*** 6259,6265 ****
{
if (!gfc_notify_std (GFC_STD_F2008, "END statement "
"instead of %s statement at %L",
! gfc_ascii_statement(*st), &old_loc))
goto cleanup;
}
else if (!eos_ok)
--- 6391,6398 ----
{
if (!gfc_notify_std (GFC_STD_F2008, "END statement "
"instead of %s statement at %L",
! abreviated_modproc_decl ? "END PROCEDURE"
! : gfc_ascii_statement(*st), &old_loc))
goto cleanup;
}
else if (!eos_ok)
*************** gfc_match_end (gfc_statement *st)
*** 6276,6283 ****
/* 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);
goto cleanup;
}
--- 6409,6416 ----
/* 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", abreviated_modproc_decl
! ? "END PROCEDURE" : gfc_ascii_statement(*st), &old_loc);
goto cleanup;
}
*************** syntax:
*** 7417,7422 ****
--- 7550,7648 ----
}
+ /* 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. */
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h (revision 224724)
--- gcc/fortran/gfortran.h (working copy)
*************** typedef enum
*** 201,219 ****
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_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,
--- 201,219 ----
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_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,
*************** typedef struct
*** 751,756 ****
--- 751,759 ----
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. */
*************** typedef struct
*** 779,784 ****
--- 782,792 ----
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;
*************** typedef struct gfc_symbol
*** 1459,1464 ****
--- 1467,1475 ----
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 */
*************** bool gfc_add_type (gfc_symbol *, gfc_typ
*** 2786,2792 ****
void gfc_clear_attr (symbol_attribute *);
bool gfc_missing_attr (symbol_attribute *, locus *);
bool gfc_copy_attr (symbol_attribute *, symbol_attribute *, locus *);
!
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 *);
--- 2797,2803 ----
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 *);
*************** bool gfc_ref_dimen_size (gfc_array_ref *
*** 3087,3092 ****
--- 3098,3107 ----
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 *);
Index: gcc/fortran/interface.c
===================================================================
*** gcc/fortran/interface.c (revision 224724)
--- gcc/fortran/interface.c (working copy)
*************** symbol_rank (gfc_symbol *sym)
*** 1066,1074 ****
/* 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)
{
if (s1 == NULL || s2 == NULL)
return s1 == s2 ? true : false;
--- 1066,1075 ----
/* Check if the characteristics of two dummy arguments match,
cf. F08:12.3.2. */
! 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;
*************** check_dummy_characteristics (gfc_symbol
*** 1275,1282 ****
/* 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,
char *errmsg, int err_len)
{
gfc_symbol *r1, *r2;
--- 1276,1283 ----
/* Check if the characteristics of two function results match,
cf. F08:12.3.3. */
! bool
! gfc_check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2,
char *errmsg, int err_len)
{
gfc_symbol *r1, *r2;
*************** gfc_compare_interfaces (gfc_symbol *s1,
*** 1472,1479 ****
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))
return 0;
}
--- 1473,1480 ----
if (s1->attr.function && s2->attr.function)
{
/* If both are functions, check result characteristics. */
! if (!gfc_check_result_characteristics (s1, s2, errmsg, err_len)
! || !gfc_check_result_characteristics (s2, s1, errmsg, err_len))
return 0;
}
*************** gfc_compare_interfaces (gfc_symbol *s1,
*** 1533,1539 ****
if (strict_flag)
{
/* Check all characteristics. */
! if (!check_dummy_characteristics (f1->sym, f2->sym, true,
errmsg, err_len))
return 0;
}
--- 1534,1540 ----
if (strict_flag)
{
/* Check all characteristics. */
! if (!gfc_check_dummy_characteristics (f1->sym, f2->sym, true,
errmsg, err_len))
return 0;
}
*************** gfc_check_typebound_override (gfc_symtre
*** 4241,4248 ****
return false;
}
! if (!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);
--- 4242,4249 ----
return false;
}
! 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);
*************** gfc_check_typebound_override (gfc_symtre
*** 4293,4299 ****
}
check_type = proc_pass_arg != argpos && old_pass_arg != argpos;
! if (!check_dummy_characteristics (proc_formal->sym, old_formal->sym,
check_type, err, sizeof(err)))
{
gfc_error ("Argument mismatch for the overriding procedure "
--- 4294,4300 ----
}
check_type = proc_pass_arg != argpos && old_pass_arg != argpos;
! if (!gfc_check_dummy_characteristics (proc_formal->sym, old_formal->sym,
check_type, err, sizeof(err)))
{
gfc_error ("Argument mismatch for the overriding procedure "
Index: gcc/fortran/match.h
===================================================================
*** gcc/fortran/match.h (revision 224724)
--- gcc/fortran/match.h (working copy)
*************** match gfc_match_generic (void);
*** 203,208 ****
--- 203,209 ----
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);
*************** match gfc_match_expr (gfc_expr **);
*** 291,296 ****
--- 292,298 ----
/* module.c. */
match gfc_match_use (void);
+ match gfc_match_submodule (void);
void gfc_use_modules (void);
#endif /* GFC_MATCH_H */
Index: gcc/fortran/module.c
===================================================================
*** gcc/fortran/module.c (revision 224724)
--- gcc/fortran/module.c (working copy)
*************** cleanup:
*** 716,721 ****
--- 716,782 ----
}
+ /* 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
*************** typedef enum
*** 1887,1893 ****
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_attribute;
--- 1948,1954 ----
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_MODULE_PROCEDURE
}
ab_attribute;
*************** static const mstring attr_bits[] =
*** 1944,1949 ****
--- 2005,2011 ----
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)
};
*************** mio_symbol_attribute (symbol_attribute *
*** 2126,2131 ****
--- 2188,2195 ----
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 ();
*************** mio_symbol_attribute (symbol_attribute *
*** 2295,2300 ****
--- 2359,2367 ----
case AB_ARRAY_OUTER_DEPENDENCY:
attr->array_outer_dependency =1;
break;
+ case AB_MODULE_PROCEDURE:
+ attr->module_procedure =1;
+ break;
}
}
}
*************** gfc_use_module (gfc_use_list *module)
*** 6757,6764 ****
/* 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!");
init_pi_tree ();
init_true_name_tree ();
--- 6824,6833 ----
/* 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 || 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 ();
Index: gcc/fortran/parse.c
===================================================================
*** gcc/fortran/parse.c (revision 224724)
--- gcc/fortran/parse.c (working copy)
*************** decode_statement (void)
*** 369,374 ****
--- 369,384 ----
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
*************** decode_statement (void)
*** 522,527 ****
--- 532,538 ----
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);
*************** gfc_enclosing_unit (gfc_compile_state *
*** 1534,1541 ****
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)
{
if (result != NULL)
--- 1545,1552 ----
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_SUBMODULE
! || p->state == COMP_BLOCK_DATA || p->state == COMP_PROGRAM)
{
if (result != NULL)
*************** gfc_ascii_statement (gfc_statement st)
*** 1660,1665 ****
--- 1671,1679 ----
case ST_END_MODULE:
p = "END MODULE";
break;
+ case ST_END_SUBMODULE:
+ p = "END SUBMODULE";
+ break;
case ST_END_PROGRAM:
p = "END PROGRAM";
break;
*************** gfc_ascii_statement (gfc_statement st)
*** 1742,1747 ****
--- 1756,1764 ----
case ST_MODULE:
p = "MODULE";
break;
+ case ST_SUBMODULE:
+ p = "SUBMODULE";
+ break;
case ST_PAUSE:
p = "PAUSE";
break;
*************** accept_statement (gfc_statement st)
*** 2186,2191 ****
--- 2203,2209 ----
case ST_FUNCTION:
case ST_SUBROUTINE:
case ST_MODULE:
+ case ST_SUBMODULE:
gfc_current_ns->proc_name = gfc_new_block;
break;
*************** loop:
*** 2931,2936 ****
--- 2949,2958 ----
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:
*************** declSt:
*** 3280,3286 ****
break;
case ST_STATEMENT_FUNCTION:
! if (gfc_current_state () == COMP_MODULE)
{
unexpected_statement (st);
break;
--- 3302,3309 ----
break;
case ST_STATEMENT_FUNCTION:
! if (gfc_current_state () == COMP_MODULE
! || gfc_current_state () == COMP_SUBMODULE)
{
unexpected_statement (st);
break;
*************** parse_contained (int module)
*** 4903,4908 ****
--- 4926,4932 ----
/* 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);
*************** parse_contained (int module)
*** 4919,4925 ****
}
}
while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE
! && st != ST_END_MODULE && st != ST_END_PROGRAM);
/* The first namespace in the list is guaranteed to not have
anything (worthwhile) in it. */
--- 4943,4950 ----
}
}
while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE
! && 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. */
*************** parse_contained (int module)
*** 4939,4944 ****
--- 4964,4998 ----
}
+ /* 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
*************** parse_progunit (gfc_statement st)
*** 4947,4952 ****
--- 5001,5011 ----
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)
{
*************** contains:
*** 5006,5012 ****
if (p->state == COMP_CONTAINS)
n++;
! if (gfc_find_state (COMP_MODULE) == true)
n--;
if (n > 0)
--- 5065,5072 ----
if (p->state == COMP_CONTAINS)
n++;
! if (gfc_find_state (COMP_MODULE) == true
! || gfc_find_state (COMP_SUBMODULE) == true)
n--;
if (n > 0)
*************** parse_block_data (void)
*** 5127,5132 ****
--- 5187,5222 ----
}
+ /* 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
*************** parse_module (void)
*** 5146,5151 ****
--- 5236,5250 ----
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;
*************** loop:
*** 5160,5165 ****
--- 5259,5265 ----
break;
case ST_END_MODULE:
+ case ST_END_SUBMODULE:
accept_statement (st);
break;
*************** loop:
*** 5455,5460 ****
--- 5555,5568 ----
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)
*************** loop:
*** 5479,5485 ****
gfc_dump_parse_tree (gfc_current_ns, stdout);
gfc_get_errors (NULL, &errors);
! if (s.state == COMP_MODULE)
{
gfc_dump_module (s.sym->name, errors_before == errors);
gfc_current_ns->derived_types = gfc_derived_types;
--- 5587,5593 ----
gfc_dump_parse_tree (gfc_current_ns, stdout);
gfc_get_errors (NULL, &errors);
! 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;
Index: gcc/fortran/parse.h
===================================================================
*** gcc/fortran/parse.h (revision 224724)
--- gcc/fortran/parse.h (working copy)
*************** along with GCC; see the file COPYING3.
*** 25,33 ****
/* 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_DO, COMP_SELECT, COMP_FORALL, COMP_WHERE, COMP_CONTAINS, COMP_ENUM,
COMP_SELECT_TYPE, COMP_OMP_STRUCTURED_BLOCK, COMP_CRITICAL, COMP_DO_CONCURRENT
}
--- 25,33 ----
/* Enum for what the compiler is currently doing. */
typedef enum
{
! 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
}
Index: gcc/fortran/primary.c
===================================================================
*** gcc/fortran/primary.c (revision 224724)
--- gcc/fortran/primary.c (working copy)
*************** gfc_match_rvalue (gfc_expr **result)
*** 2960,2966 ****
st = gfc_enclosing_unit (NULL);
! if (st != NULL && st->state == COMP_FUNCTION
&& st->sym == sym
&& !sym->attr.recursive)
{
--- 2960,2967 ----
st = gfc_enclosing_unit (NULL);
! if (st != NULL
! && st->state == COMP_FUNCTION
&& st->sym == sym
&& !sym->attr.recursive)
{
*************** match_variable (gfc_expr **result, int e
*** 3264,3269 ****
--- 3265,3271 ----
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;
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c (revision 224724)
--- gcc/fortran/resolve.c (working copy)
*************** no_init_error:
*** 11301,11306 ****
--- 11301,11332 ----
}
+ /* 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
*************** resolve_fl_procedure (gfc_symbol *sym, i
*** 11565,11570 ****
--- 11591,11661 ----
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;
}
Index: gcc/fortran/symbol.c
===================================================================
*** gcc/fortran/symbol.c (revision 224724)
--- gcc/fortran/symbol.c (working copy)
*************** gfc_add_procedure (symbol_attribute *att
*** 1539,1545 ****
if (where == NULL)
where = &gfc_current_locus;
! if (attr->proc != PROC_UNKNOWN)
{
gfc_error ("%s procedure at %L is already declared as %s procedure",
gfc_code2string (procedures, t), where,
--- 1539,1545 ----
if (where == NULL)
where = &gfc_current_locus;
! 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,
*************** bool
*** 1655,1664 ****
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;
if (where == NULL)
where = &gfc_current_locus;
--- 1655,1669 ----
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;
*************** gfc_add_explicit_interface (gfc_symbol *
*** 1677,1682 ****
--- 1682,1688 ----
return false;
}
+ finish:
sym->formal = formal;
sym->attr.if_source = source;
*************** gfc_add_type (gfc_symbol *sym, gfc_types
*** 1703,1709 ****
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 (sym->attr.use_assoc)
gfc_error ("Symbol %qs at %L conflicts with symbol from module %qs, "
--- 1709,1718 ----
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)
! && !(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, "
*************** fail:
*** 1876,1881 ****
--- 1885,1928 ----
}
+ /* 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
Index: gcc/fortran/trans-decl.c
===================================================================
*** gcc/fortran/trans-decl.c (revision 224724)
--- gcc/fortran/trans-decl.c (working copy)
*************** gfc_sym_mangled_function_id (gfc_symbol
*** 379,387 ****
/* use the binding label rather than the mangled name */
return get_identifier (sym->binding_label);
! if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
|| (sym->module != NULL && (sym->attr.external
|| sym->attr.if_source == IFSRC_IFBODY)))
{
/* Main program is mangled into MAIN__. */
if (sym->attr.is_main_program)
--- 379,388 ----
/* use the binding label rather than the mangled name */
return get_identifier (sym->binding_label);
! 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)
*************** gfc_finish_var_decl (tree decl, gfc_symb
*** 601,607 ****
}
/* If a variable is USE associated, it's always external. */
! if (sym->attr.use_assoc)
{
DECL_EXTERNAL (decl) = 1;
TREE_PUBLIC (decl) = 1;
--- 602,608 ----
}
/* If a variable is USE associated, it's always external. */
! if (sym->attr.use_assoc || sym->attr.used_in_submodule)
{
DECL_EXTERNAL (decl) = 1;
TREE_PUBLIC (decl) = 1;
*************** gfc_get_symbol_decl (gfc_symbol * sym)
*** 1321,1326 ****
--- 1322,1328 ----
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));
Index: gcc/testsuite/gfortran.dg/submodule_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/submodule_1.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/submodule_1.f90 (working copy)
***************
*** 0 ****
--- 1,174 ----
+ ! { 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
+ !
+
Index: gcc/testsuite/gfortran.dg/submodule_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/submodule_2.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/submodule_2.f90 (working copy)
***************
*** 0 ****
--- 1,101 ----
+ ! { 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
+ !
Index: gcc/testsuite/gfortran.dg/submodule_3.f90
===================================================================
*** gcc/testsuite/gfortran.dg/submodule_3.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/submodule_3.f90 (working copy)
***************
*** 0 ****
--- 1,36 ----
+ ! { 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" }
Index: gcc/testsuite/gfortran.dg/submodule_4.f90
===================================================================
*** gcc/testsuite/gfortran.dg/submodule_4.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/submodule_4.f90 (working copy)
***************
*** 0 ****
--- 1,146 ----
+ ! { 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
+
+ !
+ program try
+ use foo_interface
+ end program
+ !
Index: gcc/testsuite/gfortran.dg/submodule_5.f90
===================================================================
*** gcc/testsuite/gfortran.dg/submodule_5.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/submodule_5.f90 (working copy)
***************
*** 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
Index: gcc/testsuite/gfortran.dg/submodule_6.f90
===================================================================
*** gcc/testsuite/gfortran.dg/submodule_6.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/submodule_6.f90 (working copy)
***************
*** 0 ****
--- 1,92 ----
+ ! { 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
+
+
^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: [Patch, fortran] PR52846 - [F2008] Support submodules
2015-06-30 12:36 ` Paul Richard Thomas
@ 2015-06-30 13:59 ` FX
2015-07-02 20:45 ` Paul Richard Thomas
0 siblings, 1 reply; 7+ messages in thread
From: FX @ 2015-06-30 13:59 UTC (permalink / raw)
To: Paul Richard Thomas
Cc: fortran, gcc-patches, Damian Rouson, Tobias Burnus,
salvatore.filippone, Bader, Reinhold
Hi Paul,
I don’t feel confident enough in many parts of the code (including the module part) to formally review it, but from what I’ve read it seemed rather logical and well-commented. If it regtests fine, I think your plan (especially at the current GCC stage) of committing this week is sound.
One question I had is: does this change the .mod file format in any case? I don’t think, cause you don’t seem to bump the version number, but have you checked on specific cases (like, the mega cp2k example) that the patch indeed does not change existing module files (the ones that do not use submodules)?
Cheers, and thanks for this patch!
FX
^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: [Patch, fortran] PR52846 - [F2008] Support submodules
2015-06-30 13:59 ` FX
@ 2015-07-02 20:45 ` Paul Richard Thomas
0 siblings, 0 replies; 7+ messages in thread
From: Paul Richard Thomas @ 2015-07-02 20:45 UTC (permalink / raw)
To: FX
Cc: fortran, gcc-patches, Damian Rouson, Tobias Burnus,
salvatore.filippone, Bader, Reinhold
Dear All,
Committed as revision 225354.
Compared with the submitted version, I have added another test -
submodule_7.f90. This is a slightly tweaked version of the example in
the F2008 standard. In order to get it to compile, the error produced
by the main program's interface block was suppressed by excluding
module procedures from the error in interface.c. Otherwise, the
compiler complains that module procedures are not module procedures.
Thanks to Damian, Reinhold, Salvatore and FX for help, comments and advice.
I'll get on and sort out the business with private symbols now.
Cheers
Paul
On 30 June 2015 at 15:51, FX <fxcoudert@gmail.com> wrote:
> Hi Paul,
>
> I don’t feel confident enough in many parts of the code (including the module part) to formally review it, but from what I’ve read it seemed rather logical and well-commented. If it regtests fine, I think your plan (especially at the current GCC stage) of committing this week is sound.
>
> One question I had is: does this change the .mod file format in any case? I don’t think, cause you don’t seem to bump the version number, but have you checked on specific cases (like, the mega cp2k example) that the patch indeed does not change existing module files (the ones that do not use submodules)?
>
> Cheers, and thanks for this patch!
>
> FX
>
--
Outside of a dog, a book is a man's best friend. Inside of a dog it's
too dark to read.
Groucho Marx
^ permalink raw reply [flat|nested] 7+ messages in thread
end of thread, other threads:[~2015-07-02 20:45 UTC | newest]
Thread overview: 7+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2015-06-22 12:41 [Patch, fortran] PR52846 - [F2008] Support submodules Paul Richard Thomas
2015-06-25 15:29 ` Paul Richard Thomas
2015-06-25 21:23 ` AW: " Bader, Reinhold
2015-06-25 22:57 ` Paul Richard Thomas
2015-06-30 12:36 ` Paul Richard Thomas
2015-06-30 13:59 ` FX
2015-07-02 20:45 ` Paul Richard Thomas
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).