diff options
author | Harald Anlauf <anlauf@gmx.de> | 2022-07-27 21:34:22 +0200 |
---|---|---|
committer | Harald Anlauf <anlauf@gmx.de> | 2022-07-31 20:28:38 +0200 |
commit | 0110cfd5449bae3a772f45ea2e4c5dab5b7a8ccd (patch) | |
tree | 297d550a3369382d8bda6a68bb15bc28f489bcb6 | |
parent | b04c399e258e686dddad879bf7e27d9e28fd6fde (diff) | |
download | gcc-0110cfd5449bae3a772f45ea2e4c5dab5b7a8ccd.zip gcc-0110cfd5449bae3a772f45ea2e4c5dab5b7a8ccd.tar.gz gcc-0110cfd5449bae3a772f45ea2e4c5dab5b7a8ccd.tar.bz2 |
Fortran: fix invalid rank error in ASSOCIATED when rank is remapped [PR77652]
gcc/fortran/ChangeLog:
PR fortran/77652
* check.cc (gfc_check_associated): Make the rank check of POINTER
vs. TARGET match the allowed forms of pointer assignment for the
selected Fortran standard.
gcc/testsuite/ChangeLog:
PR fortran/77652
* gfortran.dg/associated_target_9a.f90: New test.
* gfortran.dg/associated_target_9b.f90: New test.
-rw-r--r-- | gcc/fortran/check.cc | 23 | ||||
-rw-r--r-- | gcc/testsuite/gfortran.dg/associated_target_9a.f90 | 27 | ||||
-rw-r--r-- | gcc/testsuite/gfortran.dg/associated_target_9b.f90 | 23 |
3 files changed, 71 insertions, 2 deletions
diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc index 91d87a1..1da0b3c 100644 --- a/gcc/fortran/check.cc +++ b/gcc/fortran/check.cc @@ -1502,8 +1502,27 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target) t = false; /* F2018 C838 explicitly allows an assumed-rank variable as the first argument of intrinsic inquiry functions. */ - if (pointer->rank != -1 && !rank_check (target, 0, pointer->rank)) - t = false; + if (pointer->rank != -1 && pointer->rank != target->rank) + { + if (pointer->rank == 0 || target->rank == 0) + { + /* There exists no valid pointer assignment using bounds + remapping for scalar => array or array => scalar. */ + if (!rank_check (target, 0, pointer->rank)) + t = false; + } + else if (target->rank != 1) + { + if (!gfc_notify_std (GFC_STD_F2008, "Rank remapping target is not " + "rank 1 at %L", &target->where)) + t = false; + } + else if ((gfc_option.allow_std & GFC_STD_F2003) == 0) + { + if (!rank_check (target, 0, pointer->rank)) + t = false; + } + } if (target->rank > 0 && target->ref) { for (i = 0; i < target->rank; i++) diff --git a/gcc/testsuite/gfortran.dg/associated_target_9a.f90 b/gcc/testsuite/gfortran.dg/associated_target_9a.f90 new file mode 100644 index 0000000..708645d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/associated_target_9a.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! { dg-options "-std=f2018" } +! PR fortran/77652 - Invalid rank error in ASSOCIATED when rank is remapped +! Contributed by Paul Thomas + +program p + real, dimension(100), target :: array + real, dimension(:,:), pointer :: matrix + real, dimension(20,5), target :: array2 + real, dimension(:), pointer :: matrix2 + matrix(1:20,1:5) => array + matrix2(1:100) => array2 + ! + ! F2018:16.9.16, ASSOCIATED (POINTER [, TARGET]) + ! Case(v): If TARGET is present and is an array target, the result is + ! true if and only if POINTER is associated with a target that has + ! the same shape as TARGET, ... + if (associated (matrix, array )) stop 1 + if (associated (matrix2,array2)) stop 2 + call check (matrix2, array2) +contains + subroutine check (ptr, tgt) + real, pointer :: ptr(..) + real, target :: tgt(:,:) + if (associated (ptr, tgt)) stop 3 + end subroutine check +end diff --git a/gcc/testsuite/gfortran.dg/associated_target_9b.f90 b/gcc/testsuite/gfortran.dg/associated_target_9b.f90 new file mode 100644 index 0000000..1daa0a7 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/associated_target_9b.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! PR fortran/77652 - Invalid rank error in ASSOCIATED when rank is remapped +! Contributed by Paul Thomas + +subroutine s + real, dimension(100), target :: array + real, dimension(:,:), pointer :: matrix + real, dimension(20,5), target :: array2 + real, dimension(:), pointer :: matrix2 + real, pointer :: scalar, scalar2 + scalar => scalar2 + print *, associated (scalar, scalar2) + + matrix(1:20,1:5) => array ! F2003+ +! matrix2(1:100) => array2 ! F2008+ + print *, associated (matrix, array ) ! Technically legal F2003 + print *, associated (matrix2,array2) ! { dg-error "is not rank 1" } + + ! There exists no related valid pointer assignment for these cases: + print *, associated (scalar,matrix2) ! { dg-error "must be of rank 0" } + print *, associated (matrix2,scalar) ! { dg-error "must be of rank 1" } +end |