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