From: Thomas Koenig Date: Sat, 3 Aug 2019 11:50:39 +0000 (+0000) Subject: backport: re PR fortran/90786 (ICE on procedure pointer assignment to function with... X-Git-Tag: releases/gcc-7.5.0~329 X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=242f918fff86032e390462db2729903019a51e98;p=thirdparty%2Fgcc.git backport: re PR fortran/90786 (ICE on procedure pointer assignment to function with class pointer result) 2019-08-03 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. * 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-08-03 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: r274038 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index e1549c697b3c..0388a116e660 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,23 @@ +2019-08-03 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. + * 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-06-21 Thomas Koenig Backport from trunk diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index e403936dff02..ba9fde9161c8 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -334,39 +334,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 @@ -381,17 +387,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. */ @@ -1864,6 +1893,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 1bcc43c5546d..e5a8cea422fb 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -8333,23 +8333,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. */ @@ -8403,7 +8386,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) tree tmp; tree decl; tree expr1_vptr = NULL_TREE; - bool scalar, non_proc_pointer_assign; + bool scalar, non_proc_ptr_assign; gfc_ss *ss; gfc_start_block (&block); @@ -8411,7 +8394,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. */ @@ -8421,7 +8406,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 @@ -8441,7 +8426,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 e0c5f0a39388..107ab53fea54 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,11 @@ +2019-08-03 Thomas Koenig + Paul Thomas + + Backport from trunk + PR fortran/90786 + PR fortran/90813 + * gfortran.dg/proc_ptr_51.f90: New test. + 2019-07-22 Martin Liska 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