From 68d73e6e2efa692afff10ea16eafb88236cbe69c Mon Sep 17 00:00:00 2001 From: Harald Anlauf Date: Thu, 23 May 2024 21:13:00 +0200 Subject: [PATCH] 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 --- gcc/fortran/symbol.cc | 63 +++++++++---------- .../gfortran.dg/c-interop/c1255-2.f90 | 4 +- gcc/testsuite/gfortran.dg/pr87907.f90 | 8 ++- gcc/testsuite/gfortran.dg/pr93635.f90 | 19 ++++++ 4 files changed, 54 insertions(+), 40 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/pr93635.f90 diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc index 0a1646def67..5db3c887127 100644 --- 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 0e5505a0183..feed2e7645f 100644 --- 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 0fe4e5090d2..5c2acaf9b7f 100644 --- 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 index 00000000000..4ef33fecf2b --- /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 -- 2.35.3