This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
Class arrays
- From: Salvatore Filippone <filippone dot salvatore at gmail dot com>
- To: Paul Richard Thomas <paul dot richard dot thomas at gmail dot com>
- Cc: fortran at gcc dot gnu dot org
- Date: Mon, 12 Dec 2011 11:30:43 +0100
- Subject: Class arrays
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" } }
------------------------------------------------------------__