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