@@ -1641,6 +1641,8 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
array->as->type = AS_ASSUMED_RANK;
array->as->rank = -1;
array->attr.intent = INTENT_INOUT;
+ if (ns->proc_name->attr.flavor == FL_MODULE)
+ array->module = ns->proc_name->name;
gfc_set_sym_referenced (array);
final->formal = gfc_get_formal_arglist ();
final->formal->sym = array;
@@ -1654,6 +1656,8 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
byte_stride->attr.dummy = 1;
byte_stride->attr.value = 1;
byte_stride->attr.artificial = 1;
+ if (ns->proc_name->attr.flavor == FL_MODULE)
+ byte_stride->module = ns->proc_name->name;
gfc_set_sym_referenced (byte_stride);
final->formal->next = gfc_get_formal_arglist ();
final->formal->next->sym = byte_stride;
@@ -1667,6 +1671,8 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
fini_coarray->attr.dummy = 1;
fini_coarray->attr.value = 1;
fini_coarray->attr.artificial = 1;
+ if (ns->proc_name->attr.flavor == FL_MODULE)
+ fini_coarray->module = ns->proc_name->name;
gfc_set_sym_referenced (fini_coarray);
final->formal->next->next = gfc_get_formal_arglist ();
final->formal->next->next->sym = fini_coarray;
@@ -2432,7 +2438,9 @@ gfc_find_derived_vtab (gfc_symbol *derived)
src->attr.flavor = FL_VARIABLE;
src->attr.dummy = 1;
src->attr.artificial = 1;
- src->attr.intent = INTENT_IN;
+ src->attr.intent = INTENT_IN;
+ if (ns->proc_name->attr.flavor == FL_MODULE)
+ src->module = sub_ns->proc_name->name;
gfc_set_sym_referenced (src);
copy->formal = gfc_get_formal_arglist ();
copy->formal->sym = src;
@@ -2443,6 +2451,8 @@ gfc_find_derived_vtab (gfc_symbol *derived)
dst->attr.dummy = 1;
dst->attr.artificial = 1;
dst->attr.intent = INTENT_INOUT;
+ if (ns->proc_name->attr.flavor == FL_MODULE)
+ dst->module = sub_ns->proc_name->name;
gfc_set_sym_referenced (dst);
copy->formal->next = gfc_get_formal_arglist ();
copy->formal->next->sym = dst;
@@ -2761,7 +2771,7 @@ find_intrinsic_vtab (gfc_typespec *ts)
copy->attr.elemental = 1;
if (ns->proc_name->attr.flavor == FL_MODULE)
copy->module = ns->proc_name->name;
- gfc_set_sym_referenced (copy);
+ gfc_set_sym_referenced (copy);
/* Set up formal arguments. */
gfc_get_symbol (gfc_get_string ("%s", "src"), sub_ns, &src);
src->ts.type = ts->type;
@@ -2769,6 +2779,8 @@ find_intrinsic_vtab (gfc_typespec *ts)
src->attr.flavor = FL_VARIABLE;
src->attr.dummy = 1;
src->attr.intent = INTENT_IN;
+ if (ns->proc_name->attr.flavor == FL_MODULE)
+ src->module = sub_ns->proc_name->name;
gfc_set_sym_referenced (src);
copy->formal = gfc_get_formal_arglist ();
copy->formal->sym = src;
@@ -2778,6 +2790,8 @@ find_intrinsic_vtab (gfc_typespec *ts)
dst->attr.flavor = FL_VARIABLE;
dst->attr.dummy = 1;
dst->attr.intent = INTENT_INOUT;
+ if (ns->proc_name->attr.flavor == FL_MODULE)
+ dst->module = sub_ns->proc_name->name;
gfc_set_sym_referenced (dst);
copy->formal->next = gfc_get_formal_arglist ();
copy->formal->next->sym = dst;
@@ -4061,6 +4061,10 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
upe->refs++;
upe->ts.type = BT_VOID;
upe->attr.unlimited_polymorphic = 1;
+ /* Make sure gfc_find_gsymbol sees a (non-NULL) name to
+ * search for by plugging in some module name. */
+ if (gfc_current_ns->proc_name != NULL)
+ upe->module = gfc_current_ns->proc_name->name;
/* This is essential to force the construction of
unlimited polymorphic component class containers. */
upe->attr.zero_comp = 1;
@@ -6681,6 +6685,8 @@ match_procedure_decl (void)
sym->ts.interface->ts = current_ts;
sym->ts.interface->attr.flavor = FL_PROCEDURE;
sym->ts.interface->attr.function = 1;
+ /* Suppress warnings about explicit interface */
+ sym->ts.interface->attr.artificial = 1;
sym->attr.function = 1;
sym->attr.if_source = IFSRC_UNKNOWN;
}
@@ -6820,6 +6826,8 @@ match_ppc_decl (void)
c->ts.interface->ts = ts;
c->ts.interface->attr.flavor = FL_PROCEDURE;
c->ts.interface->attr.function = 1;
+ /* Suppress warnings about explicit interface */
+ c->ts.interface->attr.artificial = 1;
c->attr.function = 1;
c->attr.if_source = IFSRC_UNKNOWN;
}
@@ -159,7 +159,7 @@ typedef struct pointer_info
{
gfc_symbol *sym;
const char *binding_label;
- char *true_name, *module;
+ const char *true_name, *module;
fixup_t *stfixup;
gfc_symtree *symtree;
enum gfc_rsym_state state;
@@ -239,12 +239,6 @@ free_pi_tree (pointer_info *p)
free_pi_tree (p->left);
free_pi_tree (p->right);
- if (iomode == IO_INPUT)
- {
- XDELETEVEC (p->u.rsym.true_name);
- XDELETEVEC (p->u.rsym.module);
- }
-
free (p);
}
@@ -1271,8 +1265,9 @@ parse_string (void)
len++;
}
- atom_string = XRESIZEVEC (char, atom_string, len + 1);
- atom_string[len] = '\0'; /* C-style string for debug purposes. */
+ if (len >= cursz)
+ atom_string = XRESIZEVEC (char, atom_string, len + 1);
+ atom_string[len] = '\0'; /* C-style string for debug purposes. */
}
@@ -1594,19 +1589,6 @@ find_enum (const mstring *m)
}
-/* Read a string. The caller is responsible for freeing. */
-
-static char*
-read_string (void)
-{
- char* p;
- require_atom (ATOM_STRING);
- p = atom_string;
- atom_string = NULL;
- return p;
-}
-
-
/**************** Module output subroutines ***************************/
/* Output a character to a module file. */
@@ -3013,7 +2995,7 @@ mio_symtree_ref (gfc_symtree **stp)
{
p->u.rsym.sym = gfc_new_symbol (p->u.rsym.true_name,
gfc_current_ns);
- p->u.rsym.sym->module = gfc_get_string ("%s", p->u.rsym.module);
+ p->u.rsym.sym->module = p->u.rsym.module;
}
p->u.rsym.symtree->n.sym = p->u.rsym.sym;
@@ -4242,13 +4224,13 @@ mio_omp_udr_expr (gfc_omp_udr *udr, gfc_symbol **sym1, gfc_symbol **sym2,
q->u.pointer = (void *) ns;
sym = gfc_new_symbol (is_initializer ? "omp_priv" : "omp_out", ns);
sym->ts = udr->ts;
- sym->module = gfc_get_string ("%s", p1->u.rsym.module);
+ sym->module = p1->u.rsym.module;
associate_integer_pointer (p1, sym);
sym->attr.omp_udr_artificial_var = 1;
gcc_assert (p2->u.rsym.sym == NULL);
sym = gfc_new_symbol (is_initializer ? "omp_orig" : "omp_in", ns);
sym->ts = udr->ts;
- sym->module = gfc_get_string ("%s", p2->u.rsym.module);
+ sym->module = p2->u.rsym.module;
associate_integer_pointer (p2, sym);
sym->attr.omp_udr_artificial_var = 1;
if (mio_name (0, omp_declare_reduction_stmt) == 0)
@@ -4371,8 +4353,8 @@ mio_symbol (gfc_symbol *sym)
/************************* Top level subroutines *************************/
/* A recursive function to look for a specific symbol by name and by
- module. Whilst several symtrees might point to one symbol, its
- is sufficient for the purposes here than one exist. Note that
+ module. Whilst several symtrees might point to one symbol, it
+ is sufficient for the purposes here that one exist. Note that
generic interfaces are distinguished as are symbols that have been
renamed in another module. */
static gfc_symtree *
@@ -4890,15 +4872,24 @@ load_needed (pointer_info *p)
/* Use the module sym as 'proc_name' so that gfc_get_symbol_decl
doesn't go pear-shaped if the symbol is used. */
- if (!ns->proc_name)
- gfc_find_symbol (p->u.rsym.module, gfc_current_ns,
- 1, &ns->proc_name);
+ if (ns->proc_name == NULL && p->u.rsym.module != NULL)
+ gfc_find_symbol (p->u.rsym.module,
+ gfc_current_ns, 1, &ns->proc_name);
+ if (p->u.rsym.true_name != NULL)
+ {
+ sym = gfc_new_symbol (p->u.rsym.true_name, ns);
+ sym->name = gfc_dt_lower_string (p->u.rsym.true_name);
+ }
+ else
+ {
+ static unsigned int fake = 0;
+ const char *fake_node;
- sym = gfc_new_symbol (p->u.rsym.true_name, ns);
- sym->name = gfc_dt_lower_string (p->u.rsym.true_name);
- sym->module = gfc_get_string ("%s", p->u.rsym.module);
- if (p->u.rsym.binding_label)
- sym->binding_label = p->u.rsym.binding_label;
+ fake_node = gfc_get_string ("__fake_fixup_node_%d", fake++);
+ sym = gfc_new_symbol (fake_node, ns);
+ }
+ sym->module = p->u.rsym.module;
+ sym->binding_label = p->u.rsym.binding_label;
associate_integer_pointer (p, sym);
}
@@ -5073,18 +5064,15 @@ read_module (void)
while (peek_atom () != ATOM_RPAREN)
{
- const char* bind_label;
require_atom (ATOM_INTEGER);
info = get_integer (atom_int);
info->type = P_SYMBOL;
info->u.rsym.state = UNUSED;
- info->u.rsym.true_name = read_string ();
- info->u.rsym.module = read_string ();
- mio_pool_string (&bind_label);
- if (bind_label)
- info->u.rsym.binding_label = bind_label;
+ mio_pool_string (&info->u.rsym.true_name);
+ mio_pool_string (&info->u.rsym.module);
+ mio_pool_string (&info->u.rsym.binding_label);
require_atom (ATOM_INTEGER);
info->u.rsym.ns = atom_int;
@@ -5096,10 +5084,13 @@ read_module (void)
being loaded again. This should not happen if the symbol being
read is an index for an assumed shape dummy array (ns != 1). */
- sym = find_true_name (info->u.rsym.true_name, info->u.rsym.module);
+ if (info->u.rsym.true_name == NULL || info->u.rsym.module == NULL)
+ sym = NULL;
+ else
+ sym = find_true_name (info->u.rsym.true_name, info->u.rsym.module);
if (sym == NULL
- || (sym->attr.flavor == FL_VARIABLE && info->u.rsym.ns !=1))
+ || (sym->attr.flavor == FL_VARIABLE && info->u.rsym.ns != 1))
{
skip_list ();
continue;
@@ -5254,14 +5245,11 @@ read_module (void)
/* Create a symbol node if it doesn't already exist. */
if (sym == NULL)
{
- info->u.rsym.sym = gfc_new_symbol (info->u.rsym.true_name,
- gfc_current_ns);
- info->u.rsym.sym->name = gfc_dt_lower_string (info->u.rsym.true_name);
- sym = info->u.rsym.sym;
- sym->module = gfc_get_string ("%s", info->u.rsym.module);
-
- if (info->u.rsym.binding_label)
- sym->binding_label = info->u.rsym.binding_label;
+ sym = gfc_new_symbol (info->u.rsym.true_name, gfc_current_ns);
+ sym->name = gfc_dt_lower_string (info->u.rsym.true_name);
+ sym->module = info->u.rsym.module;
+ sym->binding_label = info->u.rsym.binding_label;
+ info->u.rsym.sym = sym;
}
st->n.sym = sym;
@@ -5795,7 +5783,7 @@ find_symbols_to_write(sorted_pointer_info **tree, pointer_info *p)
sp->p = p;
gfc_insert_bbt (tree, sp, compare_sorted_pointer_info);
- }
+ }
find_symbols_to_write (tree, p->left);
find_symbols_to_write (tree, p->right);
@@ -173,7 +173,7 @@ check_proc_interface (gfc_symbol *ifc, locus *where)
"PROCEDURE statement at %L", ifc->name, where);
return false;
}
- if (!ifc->attr.if_source && !ifc->attr.intrinsic && ifc->name[0] != '\0')
+ if (!ifc->attr.if_source && !ifc->attr.intrinsic && !ifc->attr.artificial)
{
gfc_error ("Interface %qs at %L must be explicit", ifc->name, where);
return false;
From: Bernhard Reutner-Fischer <aldot@gcc.gnu.org> gcc/fortran/ChangeLog: 2018-09-19 Bernhard Reutner-Fischer <aldot@gcc.gnu.org> * class.c (generate_finalization_wrapper, gfc_find_derived_vtab, find_intrinsic_vtab): Set module if in module context. * decl.c (gfc_match_decl_type_spec): Likewise. (match_procedure_decl, match_ppc_decl): Flag interface function as artificial. * resolve.c (check_proc_interface): Do not warn about missing explicit interface for artificial interface functions. * module.c (free_pi_tree): Do not free true_name nor module. (parse_string): Avoid needless reallocation. (read_string): Delete. (read_module): Use stringpool when generating symbols and module names. (mio_symtree_ref): Use stringpool for module. (mio_omp_udr_expr): Likewise. (load_needed): Use stringpool for module and symbol name. (find_symbols_to_write): Fix indentation. --- gcc/fortran/class.c | 18 ++++++++- gcc/fortran/decl.c | 8 ++++ gcc/fortran/module.c | 92 +++++++++++++++++++------------------------ gcc/fortran/resolve.c | 2 +- 4 files changed, 65 insertions(+), 55 deletions(-)