gcc/testsuite/gfortran.dg/allocate_with_source_6.f90

   1 ! { dg-do  run }
   2 ! { dg-options "-fbounds-check" }
   3 !
   4 ! Contributed by Juergen Reuter
   5 ! Check that pr65548 is fixed and that the ICE is gone, when bounds-check
   6 ! is requested.
   7 !
   8
   9 module selectors
  10   type :: selector_t
  11      integer, dimension(:), allocatable :: map
  12      real, dimension(:), allocatable :: weight
  13    contains
  14      procedure :: init => selector_init
  15    end type selector_t
  16
  17 contains
  18
  19   subroutine selector_init (selector, weight)
  20     class(selector_t), intent(out) :: selector
  21     real, dimension(:), intent(in) :: weight
  22     real :: s
  23     integer :: n, i
  24     logical, dimension(:), allocatable :: mask
  25     s = sum (weight)
  26     allocate (mask (size (weight)), source = weight /= 0)
  27     n = count (mask)
  28     if (n > 0) then
  29        allocate (selector%map (n), &
  30             source = pack ([(i, i = 1, size (weight))], mask))
  31        allocate (selector%weight (n), &
  32             source = pack (weight / s, mask))
  33     else
  34        allocate (selector%map (1), source = 1)
  35        allocate (selector%weight (1), source = 0.)
  36     end if
  37   end subroutine selector_init
  38
  39 end module selectors
  40
  41 module phs_base
  42   type :: flavor_t
  43   contains
  44      procedure :: get_mass => flavor_get_mass
  45   end type flavor_t
  46
  47   type :: phs_config_t
  48      integer :: n_in = 0
  49      type(flavor_t), dimension(:,:), allocatable :: flv
  50   end type phs_config_t
  51
  52   type :: phs_t
  53      class(phs_config_t), pointer :: config => null ()
  54      real, dimension(:), allocatable :: m_in
  55   end type phs_t
  56
  57 contains
  58
  59   elemental function flavor_get_mass (flv) result (mass)
  60     real :: mass
  61     class(flavor_t), intent(in) :: flv
  62     mass = 42.0
  63   end function flavor_get_mass
  64
  65   subroutine phs_base_init (phs, phs_config)
  66     class(phs_t), intent(out) :: phs
  67     class(phs_config_t), intent(in), target :: phs_config
  68     phs%config => phs_config
  69     allocate (phs%m_in  (phs%config%n_in), &
  70          source = phs_config%flv(:phs_config%n_in, 1)%get_mass ())
  71   end subroutine phs_base_init
  72
  73 end module phs_base
  74
  75 module foo
  76   type :: t
  77      integer :: n
  78      real, dimension(:,:), allocatable :: val
  79    contains
  80      procedure :: make => t_make
  81      generic :: get_int => get_int_array, get_int_element
  82      procedure :: get_int_array => t_get_int_array
  83      procedure :: get_int_element => t_get_int_element
  84   end type t
  85
  86 contains
  87
  88   subroutine t_make (this)
  89     class(t), intent(inout) :: this
  90     real, dimension(:), allocatable :: int
  91     allocate (int (0:this%n-1), source=this%get_int())
  92   end subroutine t_make
  93
  94   pure function t_get_int_array (this) result (array)
  95     class(t), intent(in) :: this
  96     real, dimension(this%n) :: array
  97     array = this%val (0:this%n-1, 4)
  98   end function t_get_int_array
  99
 100   pure function t_get_int_element (this, set) result (element)
 101     class(t), intent(in) :: this
 102     integer, intent(in) :: set
 103     real :: element
 104     element = this%val (set, 4)
 105   end function t_get_int_element
 106 end module foo
 107 module foo2
 108   type :: t2
 109      integer :: n
 110      character(32), dimension(:), allocatable :: md5
 111    contains
 112      procedure :: init => t2_init
 113   end type t2
 114
 115 contains
 116
 117   subroutine t2_init (this)
 118     class(t2), intent(inout) :: this
 119     character(32), dimension(:), allocatable :: md5
 120     allocate (md5 (this%n), source=this%md5)
 121     if (md5(1) /= "tst                             ") call abort()
 122     if (md5(2) /= "                                ") call abort()
 123     if (md5(3) /= "fooblabar                       ") call abort()
 124   end subroutine t2_init
 125 end module foo2
 126
 127 program test
 128   use selectors
 129   use phs_base
 130   use foo
 131   use foo2
 132
 133   type(selector_t) :: sel
 134   type(phs_t) :: phs
 135   type(phs_config_t) :: phs_config
 136   type(t) :: o
 137   type(t2) :: o2
 138
 139   call sel%init([2., 0., 3., 0., 4.])
 140
 141   if (any(sel%map /= [1, 3, 5])) call abort()
 142   if (any(abs(sel%weight - [2., 3., 4.] / 9.) > 1E-6)) call abort()
 143
 144   phs_config%n_in = 2
 145   allocate (phs_config%flv (phs_config%n_in, 1))
 146   call phs_base_init (phs, phs_config)
 147
 148   if (any(abs(phs%m_in - [42.0, 42.0]) > 1E-6)) call abort()
 149
 150   o%n = 2
 151   allocate (o%val(0:1,4))
 152   call o%make()
 153
 154   o2%n = 3
 155   allocate(o2%md5(o2%n))
 156   o2%md5(1) = "tst"
 157   o2%md5(2) = ""
 158   o2%md5(3) = "fooblabar"
 159   call o2%init()
 160 end program test
 161