On 10/1/26 2:40 AM, Mikael Morin wrote:
From: Mikael Morin <[email protected]>
Use CLASS_DATA when querying polymorphic entities, see below for details.
There are probably many more cases like this in the same function; this is
just fixing the one case I stumbled on.
Fortran-tested on aarch64-unknown-linux-gnu.
OK for mainline?
Yes, OK. Regression tested here also on x86_64
Thanks,
Jerry
-- >8 --
Use CLASS_DATA when querying polymorphic entities.
The checks of restrictions on volatile or asynchronous actual and dummy
arrays missed forbidden cases, when the arrays were polymorphic. Adjust
them so that the right attributes and fields are checked depending on
whether the dummy is polymorphic or not.
PR fortran/127682
gcc/fortran/ChangeLog:
* interface.cc (compare_parameter): Update the conditions enforcing
the restrictions on volatile and asynchronous array arguments so
that they also work with polymorphic dummy arrays.
gcc/testsuite/ChangeLog:
* gfortran.dg/volatile_15.f90: New test.
---
gcc/fortran/interface.cc | 18 +++++--
gcc/testsuite/gfortran.dg/volatile_15.f90 | 59 +++++++++++++++++++++++
2 files changed, 72 insertions(+), 5 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/volatile_15.f90
diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc
index 9dae6685be2..ba05c08c62c 100644
--- a/gcc/fortran/interface.cc
+++ b/gcc/fortran/interface.cc
@@ -2838,11 +2838,19 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
&& (actual->symtree->n.sym->attr.asynchronous
|| actual->symtree->n.sym->attr.volatile_)
&& (formal->attr.asynchronous || formal->attr.volatile_)
- && actual->rank && formal->as
- && !gfc_is_simply_contiguous (actual, true, false)
- && ((formal->as->type != AS_ASSUMED_SHAPE
- && formal->as->type != AS_ASSUMED_RANK && !formal->attr.pointer)
- || formal->attr.contiguous))
+ && actual->rank
+ && ((formal->ts.type == BT_CLASS
+ && formal->ts.u.derived->attr.is_class
+ && CLASS_DATA (formal)->as
+ && !(CLASS_DATA (formal)->as->type == AS_ASSUMED_SHAPE
+ || CLASS_DATA (formal)->as->type == AS_ASSUMED_RANK)
+ && !CLASS_DATA (formal)->attr.class_pointer)
+ || (formal->as
+ && !(formal->as->type == AS_ASSUMED_SHAPE
+ || formal->as->type == AS_ASSUMED_RANK)
+ && !formal->attr.pointer)
+ || formal->attr.contiguous)
+ && !gfc_is_simply_contiguous (actual, true, false))
{
if (where)
gfc_error ("Dummy argument %qs has to be a pointer, assumed-shape or "
diff --git a/gcc/testsuite/gfortran.dg/volatile_15.f90
b/gcc/testsuite/gfortran.dg/volatile_15.f90
new file mode 100644
index 00000000000..8ff4d6a030f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/volatile_15.f90
@@ -0,0 +1,59 @@
+! { dg-do compile }
+!
+! PR fortran/127682
+! Check that the rules for asynchronous and volatile dummy arrays are
+! correctly enforced when they are polymorphic.
+
+program prog
+ implicit none
+ integer, parameter :: n = 5
+ type :: t1
+ integer :: c1
+ end type
+ type, extends(t1) :: t2
+ integer :: c2
+ end type
+ type(t2), volatile :: x(n)
+ type(t2), asynchronous :: y(n)
+ call check_vol1(x%t1) ! { dg-error "has to be a pointer, assumed-shape or
assumed-rank array without CONTIGUOUS" }
+ call check_vol2(x%t1) ! { dg-error "has to be a pointer, assumed-shape or
assumed-rank array without CONTIGUOUS" }
+ call check_vol3(x%t1) ! { dg-error "has to be a pointer, assumed-shape or
assumed-rank array without CONTIGUOUS" }
+ call check_vol4(x%t1) ! { dg-error "has to be a pointer, assumed-shape or
assumed-rank array without CONTIGUOUS" }
+ call check_async1(x%t1) ! { dg-error "has to be a pointer, assumed-shape or
assumed-rank array without CONTIGUOUS" }
+ call check_async2(x%t1) ! { dg-error "has to be a pointer, assumed-shape or
assumed-rank array without CONTIGUOUS" }
+ call check_async3(x%t1) ! { dg-error "has to be a pointer, assumed-shape or
assumed-rank array without CONTIGUOUS" }
+ call check_async4(x%t1) ! { dg-error "has to be a pointer, assumed-shape or
assumed-rank array without CONTIGUOUS" }
+ call check_vol1(y%t1) ! { dg-error "has to be a pointer, assumed-shape or
assumed-rank array without CONTIGUOUS" }
+ call check_vol2(y%t1) ! { dg-error "has to be a pointer, assumed-shape or
assumed-rank array without CONTIGUOUS" }
+ call check_vol3(y%t1) ! { dg-error "has to be a pointer, assumed-shape or
assumed-rank array without CONTIGUOUS" }
+ call check_vol4(y%t1) ! { dg-error "has to be a pointer, assumed-shape or
assumed-rank array without CONTIGUOUS" }
+ call check_async1(y%t1) ! { dg-error "has to be a pointer, assumed-shape or
assumed-rank array without CONTIGUOUS" }
+ call check_async2(y%t1) ! { dg-error "has to be a pointer, assumed-shape or
assumed-rank array without CONTIGUOUS" }
+ call check_async3(y%t1) ! { dg-error "has to be a pointer, assumed-shape or
assumed-rank array without CONTIGUOUS" }
+ call check_async4(y%t1) ! { dg-error "has to be a pointer, assumed-shape or
assumed-rank array without CONTIGUOUS" }
+contains
+ subroutine check_vol1(a)
+ class(t1), volatile :: a(n)
+ end subroutine
+ subroutine check_vol2(a)
+ class(t1), volatile :: a(*)
+ end subroutine
+ subroutine check_vol3(a)
+ class(t1), volatile, contiguous :: a(:)
+ end subroutine
+ subroutine check_vol4(a)
+ class(t1), volatile, contiguous :: a(..)
+ end subroutine
+ subroutine check_async1(a)
+ class(t1), asynchronous :: a(n)
+ end subroutine
+ subroutine check_async2(a)
+ class(t1), asynchronous :: a(*)
+ end subroutine
+ subroutine check_async3(a)
+ class(t1), asynchronous, contiguous :: a(:)
+ end subroutine
+ subroutine check_async4(a)
+ class(t1), asynchronous, contiguous :: a(..)
+ end subroutine
+end program
