https://gcc.gnu.org/g:bac95615b50d4a012c448cba080c106702184e3a
commit r15-3958-gbac95615b50d4a012c448cba080c106702184e3a
Author: Andre Vehreschild <ve...@gcc.gnu.org>
Date: Fri Sep 27 14:18:42 2024 +0200
Ensure coarrays in calls use a descriptor [PR81265]
gcc/fortran/ChangeLog:
PR fortran/81265
* trans-expr.cc (gfc_conv_procedure_call): Ensure coarrays use a
descriptor when passed.
gcc/testsuite/ChangeLog:
* gfortran.dg/coarray/pr81265.f90: New test.
Diff:
---
gcc/fortran/trans-expr.cc | 8 ++-
gcc/testsuite/gfortran.dg/coarray/pr81265.f90 | 74 +++++++++++++++++++++++++++
2 files changed, 81 insertions(+), 1 deletion(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index e4c491a98486..9f223a1314a6 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -6438,11 +6438,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
{
bool finalized = false;
tree derived_array = NULL_TREE;
+ symbol_attribute *attr;
e = arg->expr;
fsym = formal ? formal->sym : NULL;
parm_kind = MISSING;
+ attr = fsym ? &(fsym->ts.type == BT_CLASS ? CLASS_DATA (fsym)->attr
+ : fsym->attr)
+ : nullptr;
/* If the procedure requires an explicit interface, the actual
argument is passed according to the corresponding formal
argument. If the corresponding formal argument is a POINTER,
@@ -6458,7 +6462,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
if (comp)
nodesc_arg = nodesc_arg || !comp->attr.always_explicit;
else
- nodesc_arg = nodesc_arg || !sym->attr.always_explicit;
+ nodesc_arg
+ = nodesc_arg
+ || !(sym->attr.always_explicit || (attr && attr->codimension));
/* Class array expressions are sometimes coming completely unadorned
with either arrayspec or _data component. Correct that here.
diff --git a/gcc/testsuite/gfortran.dg/coarray/pr81265.f90
b/gcc/testsuite/gfortran.dg/coarray/pr81265.f90
new file mode 100644
index 000000000000..378733bfa7c2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/pr81265.f90
@@ -0,0 +1,74 @@
+!{ dg-do run }
+
+! Contributed by Anton Shterenlikht <as at cmplx dot uk>
+! Check PR81265 is fixed.
+
+module m
+implicit none
+private
+public :: s
+
+abstract interface
+ subroutine halo_exchange( array )
+ integer, allocatable, intent( inout ) :: array(:,:,:,:)[:,:,:]
+ end subroutine halo_exchange
+end interface
+
+interface
+ module subroutine s( coarray, hx )
+ integer, allocatable, intent( inout ) :: coarray(:,:,:,:)[:,:,:]
+ procedure( halo_exchange ) :: hx
+ end subroutine s
+end interface
+
+end module m
+submodule( m ) sm
+contains
+module procedure s
+
+if ( .not. allocated(coarray) ) then
+ write (*,*) "ERROR: s: coarray is not allocated"
+ error stop
+end if
+
+sync all
+
+call hx( coarray )
+
+end procedure s
+
+end submodule sm
+module m2
+ implicit none
+ private
+ public :: s2
+ contains
+ subroutine s2( coarray )
+ integer, allocatable, intent( inout ) :: coarray(:,:,:,:)[:,:,:]
+ if ( .not. allocated( coarray ) ) then
+ write (*,'(a)') "ERROR: s2: coarray is not allocated"
+ error stop
+ end if
+ end subroutine s2
+end module m2
+program p
+use m
+use m2
+implicit none
+integer, allocatable :: space(:,:,:,:)[:,:,:]
+integer :: errstat
+
+allocate( space(10,10,10,2) [2,2,*], source=0, stat=errstat )
+if ( errstat .ne. 0 ) then
+ write (*,*) "ERROR: p: allocate( space ) )"
+ error stop
+end if
+
+if ( .not. allocated (space) ) then
+ write (*,*) "ERROR: p: space is not allocated"
+ error stop
+end if
+
+call s( space, s2 )
+
+end program p
