Fortran: improve attribute conflict checking [PR93635]

gcc/fortran/ChangeLog:

	PR fortran/93635
	* symbol.cc (conflict_std): Helper function for reporting attribute
	conflicts depending on the Fortran standard version.
	(conf_std): Helper macro for checking standard-dependent conflicts.
	(gfc_check_conflict): Use it.

gcc/testsuite/ChangeLog:

	PR fortran/93635
	* gfortran.dg/c-interop/c1255-2.f90: Adjust pattern.
	* gfortran.dg/pr87907.f90: Likewise.
	* gfortran.dg/pr93635.f90: New test.

Co-authored-by: Steven G. Kargl <kargl@gcc.gnu.org>

diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc
index 0a1646def678e2b8790e381ed2e94f10a9b825c4..5db3c887127bcd02a1cc44b34e9d2f548f737595 100644 (file)
--- a/gcc/fortran/symbol.cc
+++ b/gcc/fortran/symbol.cc
@@ -407,18 +407,36 @@ gfc_check_function_type (gfc_namespace *ns)
 
 /******************** Symbol attribute stuff *********************/
 
+/* Older standards produced conflicts for some attributes that are allowed
+   in newer standards.  Check for the conflict and issue an error depending
+   on the standard in play.  */
+
+static bool
+conflict_std (int standard, const char *a1, const char *a2, const char *name,
+             locus *where)
+{
+  if (name == NULL)
+    {
+      return gfc_notify_std (standard, "%s attribute conflicts "
+                            "with %s attribute at %L", a1, a2,
+                            where);
+    }
+  else
+    {
+      return gfc_notify_std (standard, "%s attribute conflicts "
+                            "with %s attribute in %qs at %L",
+                            a1, a2, name, where);
+    }
+}
+
 /* This is a generic conflict-checker.  We do this to avoid having a
    single conflict in two places.  */
 
 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
-#define conf_std(a, b, std) if (attr->a && attr->b)\
-                              {\
-                                a1 = a;\
-                                a2 = b;\
-                                standard = std;\
-                                goto conflict_std;\
-                              }
+#define conf_std(a, b, std) if (attr->a && attr->b \
+                               && !conflict_std (std, a, b, name, where)) \
+                               return false;
 
 bool
 gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where)
@@ -451,7 +469,6 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where)
                                                "OACC DECLARE DEVICE_RESIDENT";
 
   const char *a1, *a2;
-  int standard;
 
   if (attr->artificial)
     return true;
@@ -460,20 +477,10 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where)
     where = &gfc_current_locus;
 
   if (attr->pointer && attr->intent != INTENT_UNKNOWN)
-    {
-      a1 = pointer;
-      a2 = intent;
-      standard = GFC_STD_F2003;
-      goto conflict_std;
-    }
+    conf_std (pointer, intent, GFC_STD_F2003);
 
-  if (attr->in_namelist && (attr->allocatable || attr->pointer))
-    {
-      a1 = in_namelist;
-      a2 = attr->allocatable ? allocatable : pointer;
-      standard = GFC_STD_F2003;
-      goto conflict_std;
-    }
+  conf_std (in_namelist, allocatable, GFC_STD_F2003);
+  conf_std (in_namelist, pointer, GFC_STD_F2003);
 
   /* Check for attributes not allowed in a BLOCK DATA.  */
   if (gfc_current_state () == COMP_BLOCK_DATA)
@@ -922,20 +929,6 @@ conflict:
               a1, a2, name, where);
 
   return false;
-
-conflict_std:
-  if (name == NULL)
-    {
-      return gfc_notify_std (standard, "%s attribute conflicts "
-                             "with %s attribute at %L", a1, a2,
-                             where);
-    }
-  else
-    {
-      return gfc_notify_std (standard, "%s attribute conflicts "
-                            "with %s attribute in %qs at %L",
-                             a1, a2, name, where);
-    }
 }
 
 #undef conf

diff --git a/gcc/testsuite/gfortran.dg/c-interop/c1255-2.f90 b/gcc/testsuite/gfortran.dg/c-interop/c1255-2.f90
index 0e5505a018359111a06569eaed5de6bd12782a3a..feed2e7645fdaa50810575d5925356a0a4b778b3 100644 (file)
--- a/gcc/testsuite/gfortran.dg/c-interop/c1255-2.f90
+++ b/gcc/testsuite/gfortran.dg/c-interop/c1255-2.f90
@@ -92,12 +92,12 @@ module m2
     end function
 
     ! function result is a type that is not interoperable
-    function g (x) bind (c)  ! { dg-error "BIND\\(C\\)" }
+    function g (x) bind (c)  ! { dg-error "has no IMPLICIT type" }
       use ISO_C_BINDING
       use m1
       implicit none
       integer(C_INT) :: x
-      integer(C_INT), allocatable :: g
+      integer(C_INT), allocatable :: g  ! { dg-error "BIND\\(C\\) attribute conflicts with ALLOCATABLE" }
     end function
 
   end interface

diff --git a/gcc/testsuite/gfortran.dg/pr87907.f90 b/gcc/testsuite/gfortran.dg/pr87907.f90
index 0fe4e5090d257ba199f7feadf2930974752e1b57..5c2acaf9b7fdf44107535627db84556133c49a13 100644 (file)
--- a/gcc/testsuite/gfortran.dg/pr87907.f90
+++ b/gcc/testsuite/gfortran.dg/pr87907.f90
@@ -12,12 +12,14 @@ end
 
 submodule(m) m2
    contains
-      subroutine g(x)   ! { dg-error "mismatch in argument" }
+      subroutine g(x) ! { dg-error "FUNCTION attribute conflicts with SUBROUTINE" }
       end
 end
 
 program p
-   use m                ! { dg-error "has a type" }
+   use m
    integer :: x = 3
-   call g(x)            ! { dg-error "which is not consistent with" }
+   call g(x)
 end
+
+! { dg-prune-output "Two main PROGRAMs" }

diff --git a/gcc/testsuite/gfortran.dg/pr93635.f90 b/gcc/testsuite/gfortran.dg/pr93635.f90
new file mode 100644 (file)
index 0000000..4ef33fe
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr93635.f90
@@ -0,0 +1,19 @@
+! { dg-do compile }
+! PR fortran/93635
+!
+! Test that some attribute conflicts are properly diagnosed
+
+program p
+  implicit none
+  character(len=:),allocatable :: r,s
+  namelist /args/ r,s
+  equivalence(r,s) ! { dg-error "EQUIVALENCE attribute conflicts with ALLOCATABLE" }
+  allocate(character(len=1024) :: r)
+end
+
+subroutine sub (p, q)
+  implicit none
+  real, pointer, intent(inout) :: p(:), q(:)
+  namelist /nml/ p,q
+  equivalence(p,q) ! { dg-error "EQUIVALENCE attribute conflicts with DUMMY" }
+end