2019-07-29 Thomas Koenig <tkoenig@gcc.gnu.org>
Paul Thomas <pault@gcc.gnu.org>
Backport from trunk
PR fortran/90786
PR fortran/90813
* trans-expr.c (pointer_assignment_is_proc_pointer) Remove as
it is very simple and only called from one place.
(gfc_trans_pointer_assignment): Rename non_proc_pointer_assign
as non_proc_ptr_assign. Assign to it directly, rather than call
to above, deleted function and use gfc_expr_attr instead of
only checking the reference chain.
* 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-29 Thomas Koenig <tkoenig@gcc.gnu.org>
Paul Thomas <pault@gcc.gnu.org>
Backport from trunk
PR fortran/90786
PR fortran/90813
* gfortran.dg/proc_ptr_51.f90: New test.
Co-Authored-By: Paul Thomas <pault@gcc.gnu.org>
From-SVN: r273913
+2019-07-29 Thomas Koenig <tkoenig@gcc.gnu.org>
+ Paul Thomas <pault@gcc.gnu.org>
+
+ Backport from trunk
+ PR fortran/90786
+ PR fortran/90813
+ * trans-expr.c (pointer_assignment_is_proc_pointer) Remove as
+ it is very simple and only called from one place.
+ (gfc_trans_pointer_assignment): Rename non_proc_pointer_assign
+ as non_proc_ptr_assign. Assign to it directly, rather than call
+ to above, deleted function and use gfc_expr_attr instead of
+ only checking the reference chain.
+ * 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-23 Thomas König <tkoenig@gcc.gnu.org>
Backport from trunk
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;
}
}
-/* Indentify class valued proc_pointer assignments. */
-
-static bool
-pointer_assignment_is_proc_pointer (gfc_expr * expr1, gfc_expr * expr2)
-{
- gfc_ref * ref;
-
- ref = expr1->ref;
- while (ref && ref->next)
- ref = ref->next;
-
- return ref && ref->type == REF_COMPONENT
- && ref->u.c.component->attr.proc_pointer
- && expr2->expr_type == EXPR_VARIABLE
- && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE;
-}
-
/* Do everything that is needed for a CLASS function expr2. */
tree desc;
tree tmp;
tree expr1_vptr = NULL_TREE;
- bool scalar, non_proc_pointer_assign;
+ bool scalar, non_proc_ptr_assign;
gfc_ss *ss;
gfc_start_block (&block);
gfc_init_se (&lse, NULL);
/* Usually testing whether this is not a proc pointer assignment. */
- non_proc_pointer_assign = !pointer_assignment_is_proc_pointer (expr1, expr2);
+ non_proc_ptr_assign = !(gfc_expr_attr (expr1).proc_pointer
+ && expr2->expr_type == EXPR_VARIABLE
+ && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE);
/* Check whether the expression is a scalar or not; we cannot use
expr1->rank as it can be nonzero for proc pointers. */
gfc_free_ss_chain (ss);
if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
- && expr2->expr_type != EXPR_FUNCTION && non_proc_pointer_assign)
+ && expr2->expr_type != EXPR_FUNCTION && non_proc_ptr_assign)
{
gfc_add_data_component (expr2);
/* The following is required as gfc_add_data_component doesn't
else
gfc_conv_expr (&rse, expr2);
- if (non_proc_pointer_assign && expr1->ts.type == BT_CLASS)
+ if (non_proc_ptr_assign && expr1->ts.type == BT_CLASS)
{
trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL,
NULL);
+2019-07-29 Thomas Koenig <tkoenig@gcc.gnu.org>
+ Paul Thomas <pault@gcc.gnu.org>
+
+ Backport from trunk
+ PR fortran/90786
+ PR fortran/90813
+ * gfortran.dg/proc_ptr_51.f90: New test.
+
2019-07-24 Bin Cheng <bin.cheng@linux.alibaba.com>
Backport from mainline
--- /dev/null
+! { dg-do run }
+!
+! Test the fix for PR90786.
+!
+! Contributed by Andrew benson <abensonca@gmail.com>
+!
+module f
+procedure(c), pointer :: c_
+
+ type :: s
+ integer :: i = 42
+ end type s
+ class(s), pointer :: res, tgt
+
+contains
+
+ function c()
+ implicit none
+ class(s), pointer :: c
+ c => tgt
+ return
+ end function c
+
+ subroutine fs()
+ implicit none
+ c_ => c ! This used to ICE
+ return
+ end subroutine fs
+
+end module f
+
+ use f
+ allocate (tgt, source = s(99))
+ call fs()
+ res => c_()
+ if (res%i .ne. 99) stop 1
+ deallocate (tgt)
+end
projects / thirdparty / gcc.git / commitdiff
