From 402b831544c18769f3b12de512a0a8dc2a395171 Mon Sep 17 00:00:00 2001 From: Thomas Koenig Date: Tue, 30 Jul 2019 19:11:03 +0000 Subject: [PATCH] backport: re PR fortran/90786 (ICE on procedure pointer assignment to function with class pointer result) 2019-07-29 Thomas Koenig Paul Thomas 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 Paul Thomas Backport from trunk PR fortran/90786 PR fortran/90813 * gfortran.dg/proc_ptr_51.f90: New test. Co-Authored-By: Paul Thomas From-SVN: r273913 --- gcc/fortran/ChangeLog | 28 +++++++++ gcc/fortran/dump-parse-tree.c | 33 ++++++++++ gcc/fortran/gfortran.h | 2 + gcc/fortran/invoke.texi | 11 +++- gcc/fortran/lang.opt | 4 ++ gcc/fortran/parse.c | 7 +++ gcc/fortran/symbol.c | 13 ++++ gcc/fortran/trans-decl.c | 75 ++++++++++++++++++----- gcc/fortran/trans-expr.c | 27 ++------ gcc/testsuite/ChangeLog | 8 +++ gcc/testsuite/gfortran.dg/proc_ptr_51.f90 | 38 ++++++++++++ 11 files changed, 209 insertions(+), 37 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/proc_ptr_51.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 7901430a1945..c7a3df6bc590 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,31 @@ +2019-07-29 Thomas Koenig + Paul Thomas + + 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 Backport from trunk diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index 41b2c88265c1..ebd73110e2de 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -3443,3 +3443,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); +} diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 54987ac878b6..2bb82980e8ef 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -3123,6 +3123,7 @@ void gfc_free_dt_list (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*); @@ -3466,6 +3467,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); diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi index d53be69646af..cf18a23d84d4 100644 --- a/gcc/fortran/invoke.texi +++ b/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 @@ -1182,6 +1183,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 diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt index cc5c217e70b5..90b09f99f72e 100644 --- a/gcc/fortran/lang.opt +++ b/gcc/fortran/lang.opt @@ -500,6 +500,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. diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 8947299bc1f4..66d84b4118fb 100644 --- a/gcc/fortran/parse.c +++ b/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; diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index f4273633db74..2b8f86e0881f 100644 --- a/gcc/fortran/symbol.c +++ b/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) diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 14fa6462bd93..9538dee5733a 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -345,39 +345,45 @@ gfc_get_label_decl (gfc_st_label * lp) } } +/* 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 @@ -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. */ @@ -1905,6 +1934,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; diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 3711c38b2f23..afe08fc26681 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -8785,23 +8785,6 @@ trans_caf_token_assign (gfc_se *lse, gfc_se *rse, gfc_expr *expr1, } } -/* 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. */ @@ -8854,7 +8837,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * 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); @@ -8862,7 +8845,9 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) 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. */ @@ -8872,7 +8857,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) 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 @@ -8892,7 +8877,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) 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); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 0f2bda5dd0ec..643e3e5a5cda 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,11 @@ +2019-07-29 Thomas Koenig + Paul Thomas + + Backport from trunk + PR fortran/90786 + PR fortran/90813 + * gfortran.dg/proc_ptr_51.f90: New test. + 2019-07-24 Bin Cheng Backport from mainline diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_51.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_51.f90 new file mode 100644 index 000000000000..62b5d71e30bf --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_51.f90 @@ -0,0 +1,38 @@ +! { dg-do run } +! +! Test the fix for PR90786. +! +! Contributed by Andrew benson +! +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 -- 2.47.2