gcc/testsuite/gfortran.dg/alloc_comp_assign_10.f90

   1 ! { dg-do run }
   2 !
   3 ! Test the fix for PR39879, in which gfc gagged on the double
   4 ! defined assignment where the rhs had a default initialiser.
   5 !
   6 ! Contributed by David Sagan <david.sagan@gmail.com>
   7 !
   8 module test_struct
   9   interface assignment (=)
  10     module procedure tao_lat_equal_tao_lat
  11   end interface
  12   type bunch_params_struct
  13     integer n_live_particle
  14   end type
  15   type tao_lattice_struct
  16     type (bunch_params_struct), allocatable :: bunch_params(:)
  17     type (bunch_params_struct), allocatable :: bunch_params2(:)
  18   end type
  19   type tao_universe_struct
  20     type (tao_lattice_struct), pointer :: model, design
  21     character(200), pointer :: descrip => NULL()
  22   end type
  23   type tao_super_universe_struct
  24     type (tao_universe_struct), allocatable :: u(:)
  25   end type
  26   type (tao_super_universe_struct), save, target :: s
  27   contains
  28     subroutine tao_lat_equal_tao_lat (lat1, lat2)
  29       implicit none
  30       type (tao_lattice_struct), intent(inout) :: lat1
  31       type (tao_lattice_struct), intent(in) :: lat2
  32       if (allocated(lat2%bunch_params)) then
  33         lat1%bunch_params = lat2%bunch_params
  34       end if
  35       if (allocated(lat2%bunch_params2)) then
  36         lat1%bunch_params2 = lat2%bunch_params2
  37       end if
  38     end subroutine
  39 end module
  40
  41 program tao_program
  42   use test_struct
  43   implicit none
  44   type (tao_universe_struct), pointer :: u
  45   integer n, i
  46   allocate (s%u(1))
  47   u => s%u(1)
  48   allocate (u%design, u%model)
  49   n = 112
  50   allocate (u%model%bunch_params(0:n), u%design%bunch_params(0:n))
  51   u%design%bunch_params%n_live_particle = [(i, i = 0, n)]
  52   u%model = u%design
  53   u%model = u%design ! The double assignment was the cause of the ICE
  54   if (.not. allocated (u%model%bunch_params)) call abort
  55   if (any (u%model%bunch_params%n_live_particle .ne. [(i, i = 0, n)])) call abort
  56   Deallocate (u%model%bunch_params, u%design%bunch_params)
  57   deallocate (u%design, u%model)
  58   deallocate (s%u)
  59 end program
  60
  61 ! { dg-final { cleanup-modules "test_struct" } }