re PR fortran/90813 (gfortran.dg/proc_ptr_51.f90 fails (SIGSEGV) after 272084)

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.

From-SVN: r273880

gcc/fortran/ChangeLog

@@ -1,3 +1,22 @@
+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

gcc/fortran/dump-parse-tree.c

@@ -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);
+}

gcc/fortran/gfortran.h

@@ -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);

gcc/fortran/invoke.texi

@@ -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 generate internal
 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

gcc/fortran/lang.opt

@@ -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.

gcc/fortran/parse.c

@@ -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;
 

gcc/fortran/symbol.c

@@ -4357,6 +4357,19 @@ 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)

gcc/fortran/trans-decl.c

@@ -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,17 +398,40 @@ gfc_sym_mangled_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.  */
 
@@ -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;