[patch, fortran] PR93701 - ICE on associate of wrongly accessed array

[patch, fortran] PR93701 - ICE on associate of wrongly accessed array

[Paul Richard Thomas]

[-- Attachment #1: Type: text/plain, Size: 593 bytes --]

This is a rather old patch, which is completely obvious.

Regtests on FC33/x86_64 - OK for master and 10-branch?

I might absorb the three testcases into one.

Paul

Fortran: Improve resolution of associate variables. [PR93701].

2021-01-04  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
PR fortran/93701
* resolve.c (find_array_spec): Put static prototype for
resolve_assoc_var before this function and call for associate
variables.

gcc/testsuite/
PR fortran/93701
* gfortran.dg/associate_54.f90: New test.
* gfortran.dg/associate_55.f90: New test.
* gfortran.dg/associate_56.f90: New test.

[-- Attachment #2: submit.diff --]
[-- Type: text/x-patch, Size: 920 bytes --]

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 249f402b8d9..179181598d4 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -4885,6 +4885,8 @@ gfc_resolve_dim_arg (gfc_expr *dim)
    base symbol.  We traverse the list of reference structures, setting
    the stored reference to references.  Component references can
    provide an additional array specification.  */
+static void
+resolve_assoc_var (gfc_symbol* sym, bool resolve_target);
 
 static void
 find_array_spec (gfc_expr *e)
@@ -4894,6 +4896,13 @@ find_array_spec (gfc_expr *e)
   gfc_ref *ref;
   bool class_as = false;
 
+  if (e->symtree->n.sym->assoc)
+    {
+      if (e->symtree->n.sym->assoc->target)
+	gfc_resolve_expr (e->symtree->n.sym->assoc->target);
+      resolve_assoc_var (e->symtree->n.sym, false);
+    }
+
   if (e->symtree->n.sym->ts.type == BT_CLASS)
     {
       as = CLASS_DATA (e->symtree->n.sym)->as;

[-- Attachment #3: associate_54.f90 --]
[-- Type: text/x-fortran, Size: 736 bytes --]

! { dg-do compile }
!
! Test the fix for PR93701.
!
! Contributed by Simon Brass  <simon.brass@desy.de>
!
module test
  implicit none

  integer, parameter :: N_STATE = 1, &
       TEST_STATE = 1

  type :: test_t
     integer, dimension(:), allocatable :: state
  end type test_t

contains

  subroutine test_allocate (obj)
    class(test_t), intent(out) :: obj
    allocate (obj%state(N_STATE))
  end subroutine test_allocate

  subroutine test_alter_state1 (obj, a)
    class(test_t), intent(inout) :: obj
    integer, intent(in) :: a
    associate (state => obj%state(TEST_STATES)) ! { dg-error "is used as array" }
!      state = a
      state(TEST_STATE) = a
    end associate
  end subroutine test_alter_state1

end module test


[-- Attachment #4: associate_55.f90 --]
[-- Type: text/x-fortran, Size: 808 bytes --]

! { dg-do compile }
!
! Test the fix for PR93701.
!
! Contributed by Simon Brass  <simon.brass@desy.de>
!
module test
  implicit none

  integer, parameter :: N_STATE = 1, &
       TEST_STATE = 1

  type :: test_t
     integer, dimension(:), allocatable :: state
  end type test_t

contains

  subroutine test_allocate (obj)
    class(test_t), intent(out) :: obj
    allocate (obj%state(N_STATE))
  end subroutine test_allocate


  subroutine test_alter_state2 (obj, a)
    class(test_t), intent(inout) :: obj
    integer, intent(in) :: a
    associate (state => obj%state(TEST_STATES)) ! { dg-error "no IMPLICIT type" }
      state = a                                 ! { dg-error "vector-indexed target" }
!      state(TEST_STATE) = a
    end associate
  end subroutine test_alter_state2

end module test


[-- Attachment #5: associate_56.f90 --]
[-- Type: text/x-fortran, Size: 881 bytes --]

! { dg-do compile }
!
! Test the fix for PR93701.
!
! Contributed by Simon Brass  <simon.brass@desy.de>
!
module test
  implicit none

  integer, parameter :: N_STATE = 1, &
       TEST_STATE = 1

  type :: test_t
     integer, dimension(:), allocatable :: state
  end type test_t

contains

  subroutine test_allocate (obj)
    class(test_t), intent(out) :: obj
    allocate (obj%state(N_STATE))
  end subroutine test_allocate


  subroutine test_alter_state2 (obj, a)
    class(test_t), intent(inout) :: obj
    integer, intent(in) :: a
    integer, dimension(2) :: TEST_STATES = [1,2]
    associate (state => obj%state(TEST_STATES))
      state = a                                 ! { dg-error "vector-indexed target" }
      state(TEST_STATE) = a                     ! { dg-error "vector-indexed target" }
    end associate
  end subroutine test_alter_state2

end module test