gcc/testsuite/gfortran.dg/pr84155.f90

   1 ! { dg-do run }
   2 !
   3 ! Test the fix for PR84155 and PR84141.
   4 !
   5 ! Contributed by Juergen Reuter  <juergen.reuter@desy.de>
   6 !
   7 module test_case
   8
   9   implicit none
  10
  11   type :: array_t
  12      integer, dimension(:), allocatable :: child
  13    contains
  14      procedure :: write_raw => particle_write_raw
  15   end type array_t
  16
  17   type :: container_t
  18      type(array_t), dimension(:), allocatable :: array
  19   end type container_t
  20
  21 contains
  22
  23   subroutine proc ()
  24     type(container_t) :: container
  25     integer :: unit, check
  26     integer, parameter :: ival = 42
  27
  28     allocate (container%array(1))
  29     allocate (container%array(1)%child (1), source = [ival])
  30
  31     unit = 33
  32     open (unit, action="readwrite", form="unformatted", status="scratch")
  33     call container%array(1)%write_raw (unit)
  34     rewind (unit)
  35     read (unit) check
  36     close (unit)
  37     if (ival .ne. check) STOP 1
  38   end subroutine proc
  39
  40   subroutine particle_write_raw (array, u)
  41     class(array_t), intent(in) :: array
  42     integer, intent(in) :: u
  43     write (u) array%child
  44   end subroutine particle_write_raw
  45
  46   subroutine particle_read_raw (array)
  47     class(array_t), intent(out) :: array
  48     allocate (array%child (1))    ! comment this out
  49   end subroutine particle_read_raw
  50
  51 end module test_case
  52
  53 program main
  54   use test_case
  55   call proc ()
  56   end program main