[Bug fortran/87359] [9 regression] pointer being freed was not allocated

[pault at gcc dot gnu.org]

https://gcc.gnu.org/bugzilla/show_bug.cgi?id=87359

--- Comment #42 from Paul Thomas <pault at gcc dot gnu.org> ---
Created attachment 44746
  --> https://gcc.gnu.org/bugzilla/attachment.cgi?id=44746&action=edit
Patch for the PR

Many thanks Juergen for the reduced test. This is now DEJA-GNUified (see
below).

The patch regtests OK. Note that I cannot commit this until next week.

(Thomas or Dominique, are you in a position to do the honours?)

Best regards

Paul

! { dg-do compile }
! { dg-options "-fdump-tree-original" }
!
! Test the fix for the second part of PR87359 in which the reallocation on
! assignment for components of associate names was disallowed by r264358.
! -fcheck-all exposed the mismatch in array shapes.
!
! Contributed by Juergen Reuter  <juergen.reu...@desy.de>
!
module phs_fks
  implicit none
  private
  public :: phs_identifier_t
  public :: phs_fks_t
  type :: phs_identifier_t
     integer, dimension(:), allocatable :: contributors
  contains
    procedure :: init => phs_identifier_init
  end type phs_identifier_t

  type :: phs_fks_t
     type(phs_identifier_t), dimension(:), allocatable :: phs_identifiers
  end type phs_fks_t
contains

  subroutine phs_identifier_init &
     (phs_id, contributors)
     class(phs_identifier_t), intent(out) :: phs_id
     integer, intent(in), dimension(:) :: contributors
     allocate (phs_id%contributors (size (contributors)))
     phs_id%contributors = contributors
   end subroutine phs_identifier_init

end module phs_fks

!!!!!

module instances
  use phs_fks
  implicit none
  private
  public :: process_instance_t

  type :: nlo_event_deps_t
     type(phs_identifier_t), dimension(:), allocatable :: phs_identifiers
  end type nlo_event_deps_t

  type :: process_instance_t
     type(phs_fks_t), pointer :: phs => null ()
     type(nlo_event_deps_t) :: event_deps
   contains
     procedure :: init => process_instance_init
     procedure :: setup_real_event_kinematics => pi_setup_real_event_kinematics
  end type process_instance_t

contains

  subroutine process_instance_init (instance)
    class(process_instance_t), intent(out), target :: instance
    integer :: i
    integer :: i_born, i_real
    print *, "Process instance init"
    allocate (instance%phs)
  end subroutine process_instance_init

  subroutine pi_setup_real_event_kinematics (process_instance)
    class(process_instance_t), intent(inout) :: process_instance
    integer :: i_real, i
    associate (event_deps => process_instance%event_deps)
       i_real = 2
       associate (phs => process_instance%phs)
          print *, "Type is phs_fks_t"
          allocate (phs%phs_identifiers (3))
          call phs%phs_identifiers(1)%init ([1])
          call phs%phs_identifiers(2)%init ([1,2])
          call phs%phs_identifiers(3)%init ([1,2,3])
          event_deps%phs_identifiers = phs%phs_identifiers  ! Error: mismatch
in array shapes.
       end associate
    end associate
  end subroutine pi_setup_real_event_kinematics

end module instances

!!!!!

program main
  use instances, only: process_instance_t
  implicit none
  type(process_instance_t), allocatable, target :: process_instance
  allocate (process_instance)
  call process_instance%init ()
  call process_instance%setup_real_event_kinematics ()
end program main
! { dg-final { scan-tree-dump-times "__builtin_realloc" 2 "original" } }