Subversion Repositories openrisc

! { 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

end program main

! { dg-final { cleanup-modules "realloc" } }