gcc/testsuite/gfortran.dg/class_allocate_19.f03

   1 ! { dg-do run }
   2 !
   3 ! Contributed by: Vladimir Fuka  <vladimir.fuka@gmail.com>
   4
   5 use iso_c_binding
   6 implicit none
   7 real, target :: e
   8 class(*), allocatable, target :: a(:)
   9 e = 1.0
  10 call add_element_poly(a,e)
  11 if (size(a) /= 1) STOP 1
  12 call add_element_poly(a,e)
  13 if (size(a) /= 2) STOP 2
  14 select type (a)
  15   type is (real)
  16     if (any (a /= [ 1, 1])) STOP 3
  17 end select
  18 contains
  19     subroutine add_element_poly(a,e)
  20       use iso_c_binding
  21       class(*),allocatable,intent(inout),target :: a(:)
  22       class(*),intent(in),target :: e
  23       class(*),allocatable,target :: tmp(:)
  24       type(c_ptr) :: dummy
  25
  26       interface
  27         function memcpy(dest,src,n) bind(C,name="memcpy") result(res)
  28           import
  29           type(c_ptr) :: res
  30           integer(c_intptr_t),value :: dest
  31           integer(c_intptr_t),value :: src
  32           integer(c_size_t),value :: n
  33         end function
  34       end interface
  35
  36       if (.not.allocated(a)) then
  37         allocate(a(1), source=e)
  38       else
  39         allocate(tmp(size(a)),source=a)
  40         deallocate(a)
  41         allocate(a(size(tmp)+1),mold=e)
  42         dummy = memcpy(loc(a(1)),loc(tmp),sizeof(tmp))
  43         dummy = memcpy(loc(a(size(tmp)+1)),loc(e),sizeof(e))
  44       end if
  45     end subroutine
  46 end
  47