https://gcc.gnu.org/g:d745dfbe669d71061dbd5fbb3d5d0dce6432621c
commit r17-4865-gd745dfbe669d71061dbd5fbb3d5d0dce6432621c Author: Mikael Morin <[email protected]> Date: Sun Oct 4 11:25:06 2026 +0200 fortran: Enforce restrictions on polymorphic volatile array arguments [PR127682] 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. 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
