From 8358ac9bbc57d6986c9bd5dd17c0331a60114f45 Mon Sep 17 00:00:00 2001 From: Mark Eggleston Date: Thu, 7 May 2020 08:02:02 +0100 Subject: [PATCH] Fortran : ProcPtr function results: 'ppr@' in error message PR39695 The value 'ppr@' is set in the name of result symbol, the actual name of the symbol is in the procedure name symbol pointed to by the result symbol's namespace (ns). When reporting errors for symbols that have the proc_pointer attribute check whether the result attribute is set and set the name accordingly. Backported from master. 2020-05-20 Mark Eggleston gcc/fortran/ PR fortran/39695 * resolve.c (resolve_fl_procedure): Set name depending on whether the result attribute is set. For PROCEDURE/RESULT conflict use the name in sym->ns->proc_name->name. * symbol.c (gfc_add_type): Add check for function and result attributes use sym->ns->proc_name->name if both are set. Where the symbol cannot have a type use the name in sym->ns->proc_name->name. 2020-05-20 Mark Eggleston gcc/testsuite/ PR fortran/39695 * gfortran.dg/pr39695_1.f90: New test. * gfortran.dg/pr39695_2.f90: New test. * gfortran.dg/pr39695_3.f90: New test. * gfortran.dg/pr39695_4.f90: New test. (cherry picked from commit eb069ae8819c3a84d7f78becc5501e21ee3a9554) --- gcc/fortran/ChangeLog | 14 ++++++++++++++ gcc/fortran/resolve.c | 6 ++++-- gcc/fortran/symbol.c | 7 +++++-- gcc/testsuite/ChangeLog | 11 +++++++++++ gcc/testsuite/gfortran.dg/pr39695_1.f90 | 8 ++++++++ gcc/testsuite/gfortran.dg/pr39695_2.f90 | 12 ++++++++++++ gcc/testsuite/gfortran.dg/pr39695_3.f90 | 11 +++++++++++ gcc/testsuite/gfortran.dg/pr39695_4.f90 | 14 ++++++++++++++ 8 files changed, 79 insertions(+), 4 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/pr39695_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/pr39695_2.f90 create mode 100644 gcc/testsuite/gfortran.dg/pr39695_3.f90 create mode 100644 gcc/testsuite/gfortran.dg/pr39695_4.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index b864c0b071b9..1e18ff35a6c0 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,17 @@ +2020-05-20 Mark Eggleston + + Backported from master + 2020-05-20 Mark Eggleston + + PR fortran/39695 + * resolve.c (resolve_fl_procedure): Set name depending on + whether the result attribute is set. For PROCEDURE/RESULT + conflict use the name in sym->ns->proc_name->name. + * symbol.c (gfc_add_type): Add check for function and result + attributes use sym->ns->proc_name->name if both are set. + Where the symbol cannot have a type use the name in + sym->ns->proc_name->name. + 2020-05-13 Mark Eggleston Backported from master diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index f6e10ea379c9..aaee5eb6b9b9 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -13125,8 +13125,10 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) { if (sym->attr.proc_pointer) { + const char* name = (sym->attr.result ? sym->ns->proc_name->name + : sym->name); gfc_error ("Procedure pointer %qs at %L shall not be elemental", - sym->name, &sym->declared_at); + name, &sym->declared_at); return false; } if (sym->attr.dummy) @@ -13213,7 +13215,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) if (sym->attr.subroutine && sym->attr.result) { gfc_error ("PROCEDURE attribute conflicts with RESULT attribute " - "in %qs at %L", sym->name, &sym->declared_at); + "in %qs at %L", sym->ns->proc_name->name, &sym->declared_at); return false; } if (sym->attr.external && sym->attr.function && !sym->attr.module_procedure diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 59f602d80d52..b96706138c9f 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -2004,9 +2004,12 @@ gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where) gfc_error ("Symbol %qs at %L conflicts with symbol from module %qs, " "use-associated at %L", sym->name, where, sym->module, &sym->declared_at); + else if (sym->attr.function && sym->attr.result) + gfc_error ("Symbol %qs at %L already has basic type of %s", + sym->ns->proc_name->name, where, gfc_basic_typename (type)); else gfc_error ("Symbol %qs at %L already has basic type of %s", sym->name, - where, gfc_basic_typename (type)); + where, gfc_basic_typename (type)); return false; } @@ -2024,7 +2027,7 @@ gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where) || (flavor == FL_PROCEDURE && sym->attr.subroutine) || flavor == FL_DERIVED || flavor == FL_NAMELIST) { - gfc_error ("Symbol %qs at %L cannot have a type", sym->name, where); + gfc_error ("Symbol %qs at %L cannot have a type", sym->ns->proc_name->name, where); return false; } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 4b26ffc6998a..cf115caeafb3 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,14 @@ +2020-05-20 Mark Eggleston + + Backported from master + 2020-05-20 Mark Eggleston + + PR fortran/39695 + * gfortran.dg/pr39695_1.f90: New test. + * gfortran.dg/pr39695_2.f90: New test. + * gfortran.dg/pr39695_3.f90: New test. + * gfortran.dg/pr39695_4.f90: New test. + 2020-05-19 Tobias Burnus Backport from mainline diff --git a/gcc/testsuite/gfortran.dg/pr39695_1.f90 b/gcc/testsuite/gfortran.dg/pr39695_1.f90 new file mode 100644 index 000000000000..4c4b3045f69c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr39695_1.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! + +function f() + intrinsic :: sin + procedure(sin), pointer :: f ! { dg-error "Procedure pointer 'f'" } + f => sin +end function f diff --git a/gcc/testsuite/gfortran.dg/pr39695_2.f90 b/gcc/testsuite/gfortran.dg/pr39695_2.f90 new file mode 100644 index 000000000000..8534724959a7 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr39695_2.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! + +function g() + interface + subroutine g() + end subroutine g + end interface + pointer g + real g ! { dg-error "Symbol 'g' at .1. cannot have a type" } +end function + diff --git a/gcc/testsuite/gfortran.dg/pr39695_3.f90 b/gcc/testsuite/gfortran.dg/pr39695_3.f90 new file mode 100644 index 000000000000..661e2540bb3e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr39695_3.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! + +function g() + interface + subroutine g() ! { dg-error "RESULT attribute in 'g'" } + end subroutine g + end interface + real g ! { dg-error "Symbol 'g' at .1. cannot have a type" } +end function + diff --git a/gcc/testsuite/gfortran.dg/pr39695_4.f90 b/gcc/testsuite/gfortran.dg/pr39695_4.f90 new file mode 100644 index 000000000000..ecb0a43929fe --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr39695_4.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! + +function g() + implicit none + interface + function g() + integer g + end function g + end interface + pointer g + real g ! { dg-error "Symbol 'g' at .1. already has basic type of INTEGER" } +end function + -- 2.47.3