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!
6module 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
20contains
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
46end module realloc
47
48program 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)
58end program main
59