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