On Wed, 20 Nov 2019 22:38:30 +0200
Janne Blomqvist <blomqvist.ja...@gmail.com> wrote:
> On Wed, Nov 20, 2019 at 8:00 PM Bernhard Reutner-Fischer
> <rep.dot....@gmail.com> wrote:
> >
> > On 19 November 2019 23:54:55 CET, Thomas Koenig <tkoe...@netcologne.de>
> > wrote:
> > >Am 19.11.19 um 11:39 schrieb Bernhard Reutner-Fischer:
> > >> + char name[GFC_MAX_SYMBOL_LEN + 1];
> > >> + snprintf (name, GFC_MAX_SYMBOL_LEN, "__dummy_%d_%s", var_num++,
> > >> + f->sym->name);
> > >> +
> > >> + if (gfc_get_sym_tree (name, ns, &symtree, false) != 0)
> > >>
> > >> (I) you should + sizeof(__dummy__) + 10 for unsigned long %d or the
> > >like.
> > >
> > >GFC_MAX_SYMBOL_LEN is the maximum length of a gfortran symbol. AFAIK,
> >
> > This is only true for user-provided names in the source code.
> >
> > Think e.g. class names as can be seen in the dumps..
>
> We have GFC_MAX_MANGLED_SYMBOL_LEN for that. *Insert my standard pet
> peeve rant that we should use heap allocated unlimited length strings
> for these rather than copying stack allocated strings around, or
> preferable a symbol table*
yea, which i started to lay grounds to address that in
https://gcc.gnu.org/git/?p=gcc.git;a=shortlog;h=refs/heads/aldot/fortran-fe-stringpool
about a year ago ;) Reminds me: i had to change the symbol names that
are persisted in module-files to make it work; Still not sure if that's
acceptable so if somebody would be willing to lend me a hand for
sanity-checking that aspect of the series i'd be glad. Would certainly
help to trick me into continuing the thing now, during winter.
Looks like i've another memory leak plug lying around on that tree that
i didn't try to push yet; It's the hunk in gfc_release_symbol() in the
attached brain-dump i think, don't remember and should revisit to
have it fixed for good i suppose..
>
> > >it
> > >is not possible to use a longer symbol name than that, so it needs to
> > >be
> > >truncated. Uniqueness of the variable name is guaranteed by the var_num
> > >variable.
> > >
> > >If the user puts dummy arguments Supercalifragilisticexpialidociousa
> > >and
> > >Supercalifragilisticexpialidociousb into the argument list of a
> > >procedure, he will have to look at the numbers to differentiate them
> > >:-)
> > >
> > >> (II) s/__dummy/__intent_in/ for clarity?
> > >
> > >It's moved away a bit from INTENT(IN) now, because an argument which
> > >cannot be modified (even by passing to a procedure with a dummy
> > >argument
> > >with unknown intent) is now also handled.
> >
> > So maybe __readonly_ , __rdonly_, __rd_or the like? dummy is really
> > misleading a name in the dumps..
>
> Well, dummy is a term with a precise definition in the Fortran
> standard, so in a way it's good so one realizes it has something to do
> with a dummy argument. But yes, it's a bit misleading because it's not
> the dummy argument itself but rather a dereferenced copy of it. I
> suggest __readonly_dereferenced_dummy_copy_yes_this_is_a_really_long_name_.
> :)
:) __rodummy_ then?
but bikeshedding either way, so, Thomas, please go for __dummy_ short of
sensible alternatives.
cheers,
diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index e0bb381a55f..30b2a517246 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -680,6 +680,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
c->ts.type = BT_DERIVED;
c->attr.access = ACCESS_PRIVATE;
c->ts.u.derived = ts->u.derived;
+ c->attr.artificial = 1;
c->attr.class_pointer = attr->pointer;
c->attr.pointer = attr->pointer || (attr->dummy && !attr->allocatable)
|| attr->select_type_temporary;
@@ -687,7 +688,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
c->attr.dimension = attr->dimension;
c->attr.codimension = attr->codimension;
c->attr.abstract = fclass->attr.abstract;
- c->as = (*as);
+ c->as = *as;
c->initializer = NULL;
/* Add component '_vptr'. */
@@ -696,6 +697,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
c->ts.type = BT_DERIVED;
c->attr.access = ACCESS_PRIVATE;
c->attr.pointer = 1;
+ c->attr.artificial = 1;
if (ts->u.derived->attr.unlimited_polymorphic)
{
@@ -2296,6 +2298,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
goto cleanup;
vtype->attr.access = ACCESS_PUBLIC;
vtype->attr.vtype = 1;
+ vtype->attr.artificial = 1;
gfc_set_sym_referenced (vtype);
/* Add component '_hash'. */
@@ -2304,6 +2307,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
c->ts.type = BT_INTEGER;
c->ts.kind = 4;
c->attr.access = ACCESS_PRIVATE;
+ c->attr.artificial = 1;
c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
NULL, derived->hash_value);
@@ -2313,6 +2317,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
c->ts.type = BT_INTEGER;
c->ts.kind = gfc_size_kind;
c->attr.access = ACCESS_PRIVATE;
+ c->attr.artificial = 1;
/* Remember the derived type in ts.u.derived,
so that the correct initializer can be set later on
(in gfc_conv_structure). */
@@ -2323,6 +2328,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
/* Add component _extends. */
if (!gfc_add_component (vtype, "_extends", &c))
goto cleanup;
+ c->attr.artificial = 1;
c->attr.pointer = 1;
c->attr.access = ACCESS_PRIVATE;
if (!derived->attr.unlimited_polymorphic)
@@ -2337,6 +2343,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
c->ts.u.derived = parent_vtab->ts.u.derived;
c->initializer = gfc_get_expr ();
c->initializer->expr_type = EXPR_VARIABLE;
+ c->attr.artificial = 1;
gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns,
0, &c->initializer->symtree);
}
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index f6f4a37d357..a3ae50d6985 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -4071,7 +4071,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
upe->attr.zero_comp = 1;
if (!gfc_add_flavor (&upe->attr, FL_DERIVED, NULL,
&gfc_current_locus))
- return MATCH_ERROR;
+ return MATCH_ERROR;
}
else
{
@@ -7852,7 +7852,7 @@ gfc_match_end (gfc_statement *st)
case COMP_SUBROUTINE:
*st = ST_END_SUBROUTINE;
if (!abreviated_modproc_decl)
- target = " subroutine";
+ target = " subroutine";
else
target = " procedure";
eos_ok = !contained_procedure ();
@@ -7861,7 +7861,7 @@ gfc_match_end (gfc_statement *st)
case COMP_FUNCTION:
*st = ST_END_FUNCTION;
if (!abreviated_modproc_decl)
- target = " function";
+ target = " function";
else
target = " procedure";
eos_ok = !contained_procedure ();
@@ -9920,7 +9920,7 @@ gfc_match_derived_decl (void)
match m;
match is_type_attr_spec = MATCH_NO;
bool seen_attr = false;
- gfc_interface *intr = NULL, *head;
+ gfc_interface *intr = NULL;
bool parameterized_type = false;
bool seen_colons = false;
@@ -9943,16 +9943,15 @@ gfc_match_derived_decl (void)
been added to 'attr' but now the parent type must be found and
checked. */
if (parent != NULL)
- extended = check_extended_derived_type (parent);
-
- if (parent != NULL && !extended)
- return MATCH_ERROR;
+ {
+ extended = check_extended_derived_type (parent);
+ if (extended == NULL)
+ return MATCH_ERROR;
+ }
m = gfc_match (" ::");
if (m == MATCH_YES)
- {
- seen_colons = true;
- }
+ seen_colons = true;
else if (seen_attr)
{
gfc_error ("Expected :: in TYPE definition at %C");
@@ -9991,23 +9990,25 @@ gfc_match_derived_decl (void)
if (gfc_get_symbol (name, NULL, &gensym))
return MATCH_ERROR;
+ //gfc_new_block = gensym;
+
if (!gensym->attr.generic && gensym->ts.type != BT_UNKNOWN)
{
if (gensym->ts.u.derived)
gfc_error ("Derived type name %qs at %C already has a basic type "
- "of %s", gensym->name, gfc_typename (&gensym->ts));
+ "of %s", name, gfc_typename (&gensym->ts));
else
gfc_error ("Derived type name %qs at %C already has a basic type",
- gensym->name);
+ name);
return MATCH_ERROR;
}
if (!gensym->attr.generic
- && !gfc_add_generic (&gensym->attr, gensym->name, NULL))
+ && !gfc_add_generic (&gensym->attr, name, NULL))
return MATCH_ERROR;
if (!gensym->attr.function
- && !gfc_add_function (&gensym->attr, gensym->name, NULL))
+ && !gfc_add_function (&gensym->attr, name, NULL))
return MATCH_ERROR;
sym = gfc_find_dt_in_generic (gensym);
@@ -10022,14 +10023,12 @@ gfc_match_derived_decl (void)
if (!sym)
{
/* Use upper case to save the actual derived-type symbol. */
- gfc_get_symbol (gfc_dt_upper_string (gensym->name), NULL, &sym);
- sym->name = gfc_get_string ("%s", gensym->name);
- head = gensym->generic;
+ gfc_get_symbol (gfc_dt_upper_string (name), NULL, &sym);
+ sym->name = gensym->name;
intr = gfc_get_interface ();
intr->sym = sym;
intr->where = gfc_current_locus;
- intr->sym->declared_at = gfc_current_locus;
- intr->next = head;
+ intr->next = gensym->generic;
gensym->generic = intr;
gensym->attr.if_source = IFSRC_DECL;
}
@@ -10040,16 +10039,16 @@ gfc_match_derived_decl (void)
derived type that is a pointer. The first part of the AND clause
is true if the symbol is not the return value of a function. */
if (sym->attr.flavor != FL_DERIVED
- && !gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL))
+ && !gfc_add_flavor (&sym->attr, FL_DERIVED, name, NULL))
return MATCH_ERROR;
if (attr.access != ACCESS_UNKNOWN
- && !gfc_add_access (&sym->attr, attr.access, sym->name, NULL))
+ && !gfc_add_access (&sym->attr, attr.access, name, NULL))
return MATCH_ERROR;
else if (sym->attr.access == ACCESS_UNKNOWN
&& gensym->attr.access != ACCESS_UNKNOWN
&& !gfc_add_access (&sym->attr, gensym->attr.access,
- sym->name, NULL))
+ name, NULL))
return MATCH_ERROR;
if (sym->attr.access != ACCESS_UNKNOWN
@@ -10085,15 +10084,6 @@ gfc_match_derived_decl (void)
gfc_component *p;
gfc_formal_arglist *f, *g, *h;
- /* Add the extended derived type as the first component. */
- gfc_add_component (sym, parent, &p);
- extended->refs++;
- gfc_set_sym_referenced (extended);
-
- p->ts.type = BT_DERIVED;
- p->ts.u.derived = extended;
- p->initializer = gfc_default_initializer (&p->ts);
-
/* Set extension level. */
if (extended->attr.extension == 255)
{
@@ -10103,6 +10093,16 @@ gfc_match_derived_decl (void)
extended->name, &extended->declared_at);
return MATCH_ERROR;
}
+
+ /* Add the extended derived type as the first component. */
+ gfc_add_component (sym, parent, &p);
+ extended->refs++;
+ gfc_set_sym_referenced (extended);
+
+ p->ts.type = BT_DERIVED;
+ p->ts.u.derived = extended;
+ p->initializer = gfc_default_initializer (&p->ts);
+
sym->attr.extension = extended->attr.extension + 1;
/* Provide the links between the extended type and its extension. */
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index f7c369a17ac..3467d4a6780 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -3264,6 +3264,8 @@ parse_derived (void)
gfc_component *c, *lock_comp = NULL, *event_comp = NULL;
accept_statement (ST_DERIVED_DECL);
+
+ //push_state (&s, COMP_DERIVED, gfc_new_block->generic->sym);
push_state (&s, COMP_DERIVED, gfc_new_block);
gfc_new_block->component_access = ACCESS_PUBLIC;
@@ -3280,6 +3282,7 @@ parse_derived (void)
{
case ST_NONE:
unexpected_eof ();
+ break; /* never reached */
case ST_DATA_DECL:
case ST_PROCEDURE:
@@ -3339,9 +3342,7 @@ endType:
"TYPE statement");
if (seen_sequence)
- {
- gfc_error ("Duplicate SEQUENCE statement at %C");
- }
+ gfc_error ("Duplicate SEQUENCE statement at %C");
seen_sequence = 1;
gfc_add_sequence (&gfc_current_block ()->attr,
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 7a87f2c0ad4..058f71e41a5 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -2489,7 +2489,7 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
gsym = gfc_get_gsymbol (sym->binding_label ? sym->binding_label : sym->name);
- if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
+ if (gsym->type != GSYM_UNKNOWN && gsym->type != type)
gfc_global_used (gsym, where);
if ((sym->attr.if_source == IFSRC_UNKNOWN
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index c99c106a0c0..4dd871d50cb 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -1759,8 +1759,8 @@ gfc_add_flavor (symbol_attribute *attr, sym_flavor f, const char *name,
/* Copying a procedure dummy argument for a module procedure in a
submodule results in the flavor being copied and would result in
an error without this. */
- if (gfc_new_block && gfc_new_block->abr_modproc_decl
- && attr->flavor == f && f == FL_PROCEDURE)
+ if (f == FL_PROCEDURE && attr->flavor == f
+ && gfc_new_block && gfc_new_block->abr_modproc_decl)
return true;
if (attr->flavor != FL_UNKNOWN)
@@ -2319,6 +2319,8 @@ gfc_use_derived (gfc_symbol *sym)
gfc_symbol *s;
gfc_typespec *t;
gfc_symtree *st;
+ gfc_interface *inter;
+ gfc_formal_arglist *f;
int i;
if (!sym)
@@ -2362,7 +2364,22 @@ gfc_use_derived (gfc_symbol *sym)
gfc_commit_symbol (sym);
switch_types (sym->ns->sym_root, sym, s);
-
+#if 1
+ /* Replace old sym with new one in generic and formal interfaces */
+ if (sym->attr.generic)
+ for (inter = sym->generic; inter; inter = inter->next)
+ if (inter->sym == sym)
+ {
+gcc_unreachable ();
+ inter->sym = s;
+ }
+ for (f = sym->formal; f; f = f->next)
+ if (f->sym == sym)
+ {
+gcc_unreachable ();
+ f->sym = s;
+ }
+#endif
/* TODO: Also have to replace sym -> s in other lists like
namelists, common lists and interface lists. */
gfc_free_symbol (sym);
@@ -3086,6 +3103,8 @@ gfc_free_symbol (gfc_symbol *&sym)
if (sym->ns != sym->formal_ns)
gfc_free_namespace (sym->formal_ns);
+ free_components (sym->components);
+
if (!sym->attr.generic_copy)
gfc_free_interface (sym->generic);
@@ -3093,8 +3112,6 @@ gfc_free_symbol (gfc_symbol *&sym)
gfc_free_namespace (sym->f2k_derived);
- free_components (sym->components);
-
set_symbol_common_block (sym, NULL);
if (sym->param_list)
@@ -3123,6 +3140,21 @@ gfc_release_symbol (gfc_symbol *&sym)
gfc_free_namespace (ns);
}
+ /* Free the symbol for the abstract type of derived decls. */
+ if (sym->attr.flavor == FL_DERIVED
+ && sym->attr.if_source == IFSRC_UNKNOWN
+ && !sym->attr.artificial
+ && !sym->attr.generic
+ && !sym->attr.is_class
+ && !sym->attr.zero_comp
+ && !sym->attr.alloc_comp
+ && !sym->attr.proc_pointer_comp
+ && sym->refs == 2
+ && ((sym->attr.abstract && !sym->attr.extension)
+ || (!sym->attr.abstract && sym->attr.extension))
+ )
+ sym->refs--;
+
sym->refs--;
if (sym->refs > 0)
return;
@@ -3140,7 +3172,6 @@ gfc_new_symbol (const char *name, gfc_namespace *ns)
gfc_symbol *p;
p = XCNEW (gfc_symbol);
-
gfc_clear_ts (&p->ts);
gfc_clear_attr (&p->attr);
p->ns = ns;
@@ -3376,7 +3407,6 @@ gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result,
p = gfc_new_symbol (name, ns);
/* Add to the list of tentative symbols. */
- p->old_symbol = NULL;
p->mark = 1;
p->gfc_new = 1;
latest_undo_chgset->syms.safe_push (p);
@@ -3384,7 +3414,6 @@ gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result,
st = gfc_new_symtree (&ns->sym_root, name);
st->n.sym = p;
p->refs++;
-
}
else
{
@@ -3889,16 +3918,21 @@ free_uop_tree (gfc_symtree *uop_tree)
that it contains. */
static void
-free_sym_tree (gfc_symtree *sym_tree)
+free_sym_tree (gfc_symtree **sym_tree)
{
- if (sym_tree == NULL)
+ if (!sym_tree || !*sym_tree)
return;
- free_sym_tree (sym_tree->left);
- free_sym_tree (sym_tree->right);
+ free_sym_tree (&(*sym_tree)->left);
+ free_sym_tree (&(*sym_tree)->right);
+
+ gfc_release_symbol ((*sym_tree)->n.sym);
- gfc_release_symbol (sym_tree->n.sym);
- free (sym_tree);
+// if ((*sym_tree)->n.sym == NULL)
+ {
+ free (*sym_tree);
+ *sym_tree = NULL;
+ }
}
@@ -4035,21 +4069,35 @@ gfc_free_namespace (gfc_namespace *&ns)
gfc_free_statements (ns->code);
- free_sym_tree (ns->sym_root);
+ free_sym_tree (&ns->sym_root);
+ ns->sym_root = NULL;
free_uop_tree (ns->uop_root);
+ ns->uop_root = NULL;
free_common_tree (ns->common_root);
+ ns->common_root = NULL;
free_omp_udr_tree (ns->omp_udr_root);
+ ns->omp_udr_root = NULL;
free_tb_tree (ns->tb_sym_root);
+ ns->tb_sym_root = NULL;
free_tb_tree (ns->tb_uop_root);
+ ns->tb_uop_root = NULL;
gfc_free_finalizer_list (ns->finalizers);
+ ns->finalizers = NULL;
gfc_free_omp_declare_simd_list (ns->omp_declare_simd);
+ ns->omp_declare_simd = NULL;
gfc_free_charlen (ns->cl_list, NULL);
+ ns->cl_list = NULL;
free_st_labels (ns->st_labels);
+ ns->st_labels = NULL;
free_entry_list (ns->entries);
+ ns->entries = NULL;
gfc_free_equiv (ns->equiv);
+ ns->equiv = NULL;
gfc_free_equiv_lists (ns->equiv_lists);
+ ns->equiv_lists = NULL;
gfc_free_use_stmts (ns->use_stmts);
+ ns->use_stmts = NULL;
for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
gfc_free_interface (ns->op[i]);
@@ -4777,9 +4825,7 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
gfc_derived_types->dt_next = tmp_sym;
}
else
- {
- tmp_sym->dt_next = tmp_sym;
- }
+ tmp_sym->dt_next = tmp_sym;
gfc_derived_types = tmp_sym;
}
@@ -4955,9 +5001,7 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
gfc_derived_types->dt_next = dt_sym;
}
else
- {
- dt_sym->dt_next = dt_sym;
- }
+ dt_sym->dt_next = dt_sym;
gfc_derived_types = dt_sym;
gfc_add_component (dt_sym, "c_address", &tmp_comp);
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index b202469bc40..8f2bdf96b2e 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -7648,7 +7648,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr,
gfc_add_expr_to_block (&block, tmp);
}
}
- else if (!cm->attr.artificial)
+ else //if (!cm->attr.artificial)
{
/* Scalar component (excluding deferred parameters). */
gfc_init_se (&se, NULL);
