+2019-07-29 Thomas Koenig <tkoenig@gcc.gnu.org>
+
+ PR fortran/90813
+ * dump-parse-tree.c (show_global_symbol): New function.
+ (gfc_dump_global_symbols): New function.
+ * gfortran.h (gfc_traverse_gsymbol): Add prototype.
+ (gfc_dump_global_symbols): Likewise.
+ * invoke.texi: Document -fdump-fortran-global.
+ * lang.opt: Add -fdump-fortran-global.
+ * parse.c (gfc_parse_file): Handle flag_dump_fortran_global.
+ * symbol.c (gfc_traverse_gsymbol): New function.
+ * trans-decl.c (sym_identifier): New function.
+ (mangled_identifier): New function, doing most of the work
+ of gfc_sym_mangled_identifier.
+ (gfc_sym_mangled_identifier): Use mangled_identifier. Add mangled
+ identifier to global symbol table.
+ (get_proc_pointer_decl): Use backend decl from global identifier
+ if present.
+
2019-07-25 Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/65819
else if (sym->attr.flavor == FL_PROCEDURE)
write_proc (sym, true);
}
+
+/* This section deals with dumping the global symbol tree. */
+
+/* Callback function for printing out the contents of the tree. */
+
+static void
+show_global_symbol (gfc_gsymbol *gsym, void *f_data)
+{
+ FILE *out;
+ out = (FILE *) f_data;
+
+ if (gsym->name)
+ fprintf (out, "name=%s", gsym->name);
+
+ if (gsym->sym_name)
+ fprintf (out, ", sym_name=%s", gsym->sym_name);
+
+ if (gsym->mod_name)
+ fprintf (out, ", mod_name=%s", gsym->mod_name);
+
+ if (gsym->binding_label)
+ fprintf (out, ", binding_label=%s", gsym->binding_label);
+
+ fputc ('\n', out);
+}
+
+/* Show all global symbols. */
+
+void
+gfc_dump_global_symbols (FILE *f)
+{
+ gfc_traverse_gsymbol (gfc_gsym_root, show_global_symbol, (void *) f);
+}
gfc_gsymbol *gfc_get_gsymbol (const char *, bool bind_c);
gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, const char *);
gfc_gsymbol *gfc_find_case_gsymbol (gfc_gsymbol *, const char *);
+void gfc_traverse_gsymbol (gfc_gsymbol *, void (*)(gfc_gsymbol *, void *), void *);
gfc_typebound_proc* gfc_get_typebound_proc (gfc_typebound_proc*);
gfc_symbol* gfc_get_derived_super_type (gfc_symbol*);
void gfc_dump_parse_tree (gfc_namespace *, FILE *);
void gfc_dump_c_prototypes (gfc_namespace *, FILE *);
void gfc_dump_external_c_prototypes (FILE *);
+void gfc_dump_global_symbols (FILE *);
/* parse.c */
bool gfc_parse_file (void);
@item Debugging Options
@xref{Debugging Options,,Options for debugging your program or GNU Fortran}.
@gccoptlist{-fbacktrace -fdump-fortran-optimized -fdump-fortran-original @gol
--fdump-parse-tree -ffpe-trap=@var{list} -ffpe-summary=@var{list}
+-fdump-fortran-global -fdump-parse-tree -ffpe-trap=@var{list} @gol
+-ffpe-summary=@var{list}
}
@item Directory Options
compiler errors for features which have only recently been added. This
option is deprecated; use @code{-fdump-fortran-original} instead.
+@item -fdump-fortran-global
+@opindex @code{fdump-fortran-global}
+Output a list of the global identifiers after translating into
+middle-end representation. Mostly useful for debugging the GNU Fortran
+compiler itself. The output generated by this option might change
+between releases. This option may also generate internal compiler
+errors for features which have only recently been added.
+
@item -ffpe-trap=@var{list}
@opindex @code{ffpe-trap=}@var{list}
Specify a list of floating point exception traps to enable. On most
Fortran Var(flag_dump_fortran_optimized)
Display the code tree after front end optimization.
+fdump-fortran-global
+Fortran Var(flag_dump_fortran_global)
+Display the global symbol table after parsing.
+
fdump-parse-tree
Fortran Alias(fdump-fortran-original)
Display the code tree after parsing; deprecated option.
/* Do the translation. */
translate_all_program_units (gfc_global_ns_list);
+ /* Dump the global symbol ist. We only do this here because part
+ of it is generated after mangling the identifiers in
+ trans-decl.c. */
+
+ if (flag_dump_fortran_global)
+ gfc_dump_global_symbols (stdout);
+
gfc_end_source_files ();
return true;
return s;
}
+void
+gfc_traverse_gsymbol (gfc_gsymbol *gsym,
+ void (*do_something) (gfc_gsymbol *, void *),
+ void *data)
+{
+ if (gsym->left)
+ gfc_traverse_gsymbol (gsym->left, do_something, data);
+
+ (*do_something) (gsym, data);
+
+ if (gsym->right)
+ gfc_traverse_gsymbol (gsym->right, do_something, data);
+}
static gfc_symbol *
get_iso_c_binding_dt (int sym_id)
}
}
+/* Return the name of an identifier. */
-/* Convert a gfc_symbol to an identifier of the same name. */
-
-static tree
-gfc_sym_identifier (gfc_symbol * sym)
+static const char *
+sym_identifier (gfc_symbol *sym)
{
if (sym->attr.is_main_program && strcmp (sym->name, "main") == 0)
- return (get_identifier ("MAIN__"));
+ return "MAIN__";
else
- return (get_identifier (sym->name));
+ return sym->name;
}
-
-/* Construct mangled name from symbol name. */
+/* Convert a gfc_symbol to an identifier of the same name. */
static tree
-gfc_sym_mangled_identifier (gfc_symbol * sym)
+gfc_sym_identifier (gfc_symbol * sym)
{
- char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
+ return get_identifier (sym_identifier (sym));
+}
+/* Construct mangled name from symbol name. */
+
+static const char *
+mangled_identifier (gfc_symbol *sym)
+{
+ static char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
/* Prevent the mangling of identifiers that have an assigned
binding label (mainly those that are bind(c)). */
+
if (sym->attr.is_bind_c == 1 && sym->binding_label)
- return get_identifier (sym->binding_label);
+ return sym->binding_label;
if (!sym->fn_result_spec)
{
if (sym->module == NULL)
- return gfc_sym_identifier (sym);
+ return sym_identifier (sym);
else
{
snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
- return get_identifier (name);
+ return name;
}
}
else
sym->ns->proc_name->module,
sym->ns->proc_name->name,
sym->name);
- return get_identifier (name);
+ return name;
}
else
{
snprintf (name, sizeof name, "__%s_PROC_%s",
sym->ns->proc_name->name, sym->name);
- return get_identifier (name);
+ return name;
}
}
}
+/* Get mangled identifier, adding the symbol to the global table if
+ it is not yet already there. */
+
+static tree
+gfc_sym_mangled_identifier (gfc_symbol * sym)
+{
+ tree result;
+ gfc_gsymbol *gsym;
+ const char *name;
+
+ name = mangled_identifier (sym);
+ result = get_identifier (name);
+
+ gsym = gfc_find_gsymbol (gfc_gsym_root, name);
+ if (gsym == NULL)
+ {
+ gsym = gfc_get_gsymbol (name, false);
+ gsym->ns = sym->ns;
+ gsym->sym_name = sym->name;
+ }
+
+ return result;
+}
/* Construct mangled function name from symbol name. */
tree decl;
tree attributes;
+ if (sym->module || sym->fn_result_spec)
+ {
+ const char *name;
+ gfc_gsymbol *gsym;
+
+ name = mangled_identifier (sym);
+ gsym = gfc_find_gsymbol (gfc_gsym_root, name);
+ if (gsym != NULL)
+ {
+ gfc_symbol *s;
+ gfc_find_symbol (sym->name, gsym->ns, 0, &s);
+ if (s && s->backend_decl)
+ return s->backend_decl;
+ }
+ }
+
decl = sym->backend_decl;
if (decl)
return decl;
projects / gcc.git / commitdiff