Class arrays

[Salvatore Filippone <filippone dot salvatore at gmail dot com>]

Hello,
First of all, kudos to Paul for getting the CLASS arrays to work.
I have a minor style issue with test case class_array_7 which, IMHO,
would be more OO as follows:
Of course you're free to look/reuse/redirect to /dev/null as you see fit.

Salvatore
------------------
! { 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, nopass :: print => base_print
    procedure :: assign
    generic :: assignment(=) => assign   ! define generic assignment
  end type base_type

  type, extends(base_type) :: extended_type
     integer :: j
  contains
    procedure, nopass :: print => extended_print
  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 (tmp(1)%print ("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

  function base_print (name) result(this)
    character(len=20) :: this
    character(*), intent(in) :: name

    this  = name // " is base_type"

  end function base_print

  function extended_print (name) result(this)
    character(len=20) :: this
    character(*), intent(in) :: name

    this  = name // " is extended_type"

  end function extended_print


end module realloc

program main
  use realloc
  implicit none
  class(base_type), dimension(:), allocatable :: a

  allocate (extended_type :: a(10))
  if (trim (a(1)%print("a")) .ne. "a is extended_type") call abort
  call reallocate (a)
  if (trim (a(1)%print("a")) .ne. "a is base_type") call abort
end program main

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

------------------------------------------------------------__