[gcc r13-1904] Fortran: fix invalid rank error in ASSOCIATED when rank is remapped [PR77652]

[gcc r13-1904] Fortran: fix invalid rank error in ASSOCIATED when rank is remapped [PR77652]

[Harald Anlauf]

https://gcc.gnu.org/g:0110cfd5449bae3a772f45ea2e4c5dab5b7a8ccd

commit r13-1904-g0110cfd5449bae3a772f45ea2e4c5dab5b7a8ccd
Author: Harald Anlauf <anlauf@gmx.de>
Date:   Wed Jul 27 21:34:22 2022 +0200

    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.

Diff:
---
 gcc/fortran/check.cc                               | 23 ++++++++++++++++--
 gcc/testsuite/gfortran.dg/associated_target_9a.f90 | 27 ++++++++++++++++++++++
 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 91d87a1b2c1..1da0b3cbe15 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 00000000000..708645d5bcb
--- /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 00000000000..1daa0a7dde1
--- /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