gcc/testsuite/gfortran.dg/pr84155.f90

! { dg-do run }
!
! Test the fix for PR84155 and PR84141.
!
! Contributed by Juergen Reuter  <juergen.reuter@desy.de>
!
module test_case

  implicit none

  type :: array_t
     integer, dimension(:), allocatable :: child
   contains
     procedure :: write_raw => particle_write_raw
  end type array_t

  type :: container_t
     type(array_t), dimension(:), allocatable :: array
  end type container_t

contains

  subroutine proc ()
    type(container_t) :: container
    integer :: unit, check
    integer, parameter :: ival = 42

    allocate (container%array(1))
    allocate (container%array(1)%child (1), source = [ival])

    unit = 33
    open (unit, action="readwrite", form="unformatted", status="scratch")
    call container%array(1)%write_raw (unit)
    rewind (unit)
    read (unit) check
    close (unit)
    if (ival .ne. check) STOP 1
  end subroutine proc

  subroutine particle_write_raw (array, u)
    class(array_t), intent(in) :: array
    integer, intent(in) :: u
    write (u) array%child
  end subroutine particle_write_raw

  subroutine particle_read_raw (array)
    class(array_t), intent(out) :: array
    allocate (array%child (1))    ! comment this out
  end subroutine particle_read_raw

end module test_case

program main
  use test_case
  call proc ()
  end program main