https://gcc.gnu.org/g:4ab54e5913e8a2d0959ffd683a78f581c26274c4
commit 4ab54e5913e8a2d0959ffd683a78f581c26274c4 Author: Mikael Morin <[email protected]> Date: Wed Sep 30 21:48:54 2026 +0200 fortran: Enforce restrictions on polymorphic volatile array arguments [PR127682] 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. There are probably many more cases of this in the same function; this is just fixing the one case I stumbled on. 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. Diff: --- gcc/fortran/interface.cc | 18 +++++++--- gcc/testsuite/gfortran.dg/volatile_15.f90 | 59 +++++++++++++++++++++++++++++++ 2 files changed, 72 insertions(+), 5 deletions(-) diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc index 9dae6685be2a..ba05c08c62c9 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 000000000000..8ff4d6a030f5 --- /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
