gcc/testsuite/gfortran.dg/class_array_7.f03

   1 ! { dg-do run }
   2 ! PR46990 - class array implementation
   3 !
   4 ! Contributed by Wolfgang Kilian on comp.lang.fortran - see comment #7 of PR
   5 !
   6 module realloc
   7   implicit none
   8
   9   type :: base_type
  10      integer :: i
  11   contains
  12     procedure :: assign
  13     generic :: assignment(=) => assign   ! define generic assignment
  14   end type base_type
  15
  16   type, extends(base_type) :: extended_type
  17      integer :: j
  18   end type extended_type
  19
  20 contains
  21
  22   impure elemental subroutine assign (a, b)
  23     class(base_type), intent(out) :: a
  24     type(base_type), intent(in) :: b
  25     a%i = b%i
  26   end subroutine assign
  27
  28   subroutine reallocate (a)
  29     class(base_type), dimension(:), allocatable, intent(inout) :: a
  30     class(base_type), dimension(:), allocatable :: tmp
  31     allocate (tmp (2 * size (a))) ! how to alloc b with same type as a ?
  32     if (trim (print_type ("tmp", tmp)) .ne. "tmp is base_type") STOP 1
  33     tmp(:size(a)) = a             ! polymorphic l.h.s.
  34     call move_alloc (from=tmp, to=a)
  35   end subroutine reallocate
  36
  37   character(20) function print_type (name, a)
  38     character(*), intent(in) :: name
  39     class(base_type), dimension(:), intent(in) :: a
  40     select type (a)
  41      type is (base_type);      print_type = NAME // " is base_type"
  42      type is (extended_type);  print_type = NAME // " is extended_type"
  43     end select
  44   end function
  45
  46 end module realloc
  47
  48 program main
  49   use realloc
  50   implicit none
  51   class(base_type), dimension(:), allocatable :: a
  52
  53   allocate (extended_type :: a(10))
  54   if (trim (print_type ("a", a)) .ne. "a is extended_type") STOP 2
  55   call reallocate (a)
  56   if (trim (print_type ("a", a)) .ne. "a is base_type") STOP 3
  57   deallocate (a)
  58 end program main