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.

2020-05-20  Mark Eggleston  <markeggleston@gcc.gnu.org>

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  <markeggleston@gcc.gnu.org>

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.

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index ab79158f7b6b4bcb4faf20a0c3766549754d2226..fb0e47c76246d1a7a93a10ecf0b01752290fe986 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,14 @@
+2020-05-20  Mark Eggleston  <markeggleston@gcc.gnu.org>
+
+       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-18  Harald Anlauf  <anlauf@gmx.de>
 
        PR fortran/95053

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index f6e10ea379c9d7513bc2b0d6bcaf53ea48075f4d..aaee5eb6b9b95b10870ca9ae0e609dc002a4ec0d 100644 (file)
--- 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 59f602d80d521263ec2e23102b3a450cf3b8e766..b96706138c9f4d6ffeabc8441fde7ce344aa2ce2 100644 (file)
--- 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 3594d01cb93802e564eaf342344f591ba1f2d0ed..d62db054a159cedb8386712ad4d282089370f2cc 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,11 @@
+2020-05-20  Mark Eggleston  <markeggleston@gcc.gnu.org>
+
+       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-20  Patrick Palka  <ppalka@redhat.com>
 
        PR c++/95223

diff --git a/gcc/testsuite/gfortran.dg/pr39695_1.f90 b/gcc/testsuite/gfortran.dg/pr39695_1.f90
new file mode 100644 (file)
index 0000000..4c4b304
--- /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 (file)
index 0000000..8534724
--- /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 (file)
index 0000000..661e254
--- /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 (file)
index 0000000..ecb0a43
--- /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
+