===================================================================
@@ -3462,3 +3462,36 @@ write_interop_decl (gfc_symbol *sym)
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);
+}
===================================================================
@@ -3128,6 +3128,7 @@ void gfc_enforce_clean_symbol_state (void);
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*);
@@ -3471,6 +3472,7 @@ void gfc_delete_bbt (void *, void *, compare_fn);
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);
===================================================================
@@ -157,7 +157,8 @@ and warnings}.
@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
@@ -1199,6 +1200,14 @@ change between releases. This option may also gene
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
===================================================================
@@ -512,6 +512,10 @@ fdump-fortran-optimized
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.
===================================================================
@@ -6366,6 +6366,13 @@ done:
/* 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;
===================================================================
@@ -4357,7 +4357,20 @@ gfc_get_gsymbol (const char *name, bool bind_c)
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)
{
===================================================================
@@ -345,39 +345,45 @@ gfc_get_label_decl (gfc_st_label * lp)
}
}
+/* Return the name of an identifier. */
+static const char *
+sym_identifier (gfc_symbol *sym)
+{
+ if (sym->attr.is_main_program && strcmp (sym->name, "main") == 0)
+ return "MAIN__";
+ else
+ return sym->name;
+}
+
/* Convert a gfc_symbol to an identifier of the same name. */
static tree
gfc_sym_identifier (gfc_symbol * sym)
{
- if (sym->attr.is_main_program && strcmp (sym->name, "main") == 0)
- return (get_identifier ("MAIN__"));
- else
- return (get_identifier (sym->name));
+ return get_identifier (sym_identifier (sym));
}
+/* Construct mangled name from symbol name. */
-/* Construct mangled name from symbol name. */
-
-static tree
-gfc_sym_mangled_identifier (gfc_symbol * sym)
+static const char *
+mangled_identifier (gfc_symbol *sym)
{
- char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
-
+ 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
@@ -392,18 +398,41 @@ gfc_sym_identifier (gfc_symbol * sym)
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. */
static tree
@@ -1914,6 +1943,22 @@ get_proc_pointer_decl (gfc_symbol *sym)
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;