Nice example! with the caveat that all shapes have the same interface, I think you can remove most of the boilerplate using a hybrid of your first and last approaches:
module shapes
use iso_fortran_env
implicit none
private
type, public, abstract :: shape_base
contains
procedure(shape_base_draw), deferred :: draw
procedure(shape_base_ser), deferred :: serialize
end type shape_base
type, public, extends(shape_base) :: shape
class(shape_base), allocatable :: value
contains
procedure :: serialize => shape_serialize
procedure :: draw => shape_draw
procedure, private :: shape_assign
generic :: assignment(=) => shape_assign
end type shape
! The basic shapes
type, public, extends(shape_base) :: circle
real(real64) :: radius
contains
procedure :: draw => draw_circle
procedure :: serialize => serialize_circle
end type circle
type, public, extends(shape_base) :: rectangle
real(real64) :: width,height
contains
procedure :: draw => draw_rectangle
procedure :: serialize => serialize_rectangle
end type rectangle
abstract interface
subroutine shape_base_draw(c)
import shape_base
class(shape_base), intent(in) :: c
end subroutine
impure elemental subroutine shape_base_ser(c)
import shape_base
class(shape_base), intent(in) :: c
end subroutine
end interface
interface shape
module procedure shape_new
end interface
contains
subroutine draw_circle(c)
class(circle), intent(in) :: c
write(*,'(A,G0,A)') "Drawing CIRCLE: { R = ", c%radius, "}"
end subroutine
impure elemental subroutine serialize_circle(c)
class(circle), intent(in) :: c
print *, "CIRCLE ", c%radius
end subroutine
subroutine draw_rectangle(c)
class(rectangle), intent(in) :: c
write(*,'(A,G0,A,G0,A)') "Drawing RECTANGLE { W = ", c%width, &
", H = ", c%height, "}"
end subroutine
impure elemental subroutine serialize_rectangle(c)
class(rectangle), intent(in) :: c
print *, "RECTANGLE ", c%width, c%height
end subroutine
subroutine shape_draw(c)
class(shape), intent(in) :: c
if (allocated(c%value)) then
call c%value%draw()
else
stop 'trying to draw an empty shape'
endif
end subroutine
impure elemental subroutine shape_serialize(c)
class(shape), intent(in) :: c
if (allocated(c%value)) then
call c%value%serialize()
else
print *, "EMPTY "
endif
end subroutine
! Shape initializer
subroutine shape_assign(lhs,rhs)
class(shape), intent(inout) :: lhs
class(shape_base), intent(in) :: rhs
if (allocated(lhs%value))deallocate(lhs%value)
allocate(lhs%value,source=rhs)
end subroutine shape_assign
! Shape initializer
type(shape) function shape_new(rhs) result(lhs)
class(shape_base), intent(in) :: rhs
allocate(lhs%value,source=rhs)
end function shape_new
end module shapes
!> Let's see where the use of interfaces and generics
!> have brought us
program process_shapes
use shapes
implicit none
call demo1()
call demo2()
contains
subroutine demo1()
type(shape) :: shape_scalar
type(shape) :: shape_array(3)
write(*,'(A,/)') "Demo 1"
!> We can construct a scalar shape by chaining the structure
!> constuctors
shape_scalar = circle(42.)
call shape_scalar%serialize()
!> To construct an array of shapes, it would be nice if we could
!> use an an array constructor with automatic conversion:
!
! shape_array = [ shape :: &
! circle(10.), &
! rectangle(4.,5.), &
! circle(12.)]
!
!> Unfortunately, this doesn't work currently, and leads the the
!> following errors:
!> gfortran - Error: Cannot convert TYPE(circle) to TYPE(shape_base)
!> ifort - Catastrophic error: **Internal compiler error**
! So instead we just assign the shapes one by one
! (again it would be nice to have an implicit conversion)
shape_array(1) = circle(10.)
shape_array(2) = circle(5.)
shape_array(3) = rectangle(width=12.,height=14.)
! Since the procedure is elemental, we can easily serialize
! the whole array
call shape_array%serialize()
! We can copy an existing shape, preserving the shape
shape_scalar = shape_array(1)
call shape_scalar%serialize()
! And we can also instantiate a shape from another shape
! (on the condition we overloaded the structure constructor)
shape_scalar = shape_array(3)
call shape_scalar%serialize()
end subroutine
subroutine demo2()
type(shape), allocatable :: scrapbook(:)
write(*,'(/,A,/)') "Demo 2"
scrapbook = [shape(circle(10.0))]
scrapbook = [scrapbook, shape(rectangle(12.,12.))]
call scrapbook%serialize()
end subroutine
end program
- Full inheritance => no need to keep redefining interfaces or using
select types - Just a bit verbose array constructor (at least with gfortran)
*** EDIT ***
Small improvement: to prevent unwanted nested types, without loss of generality, the assignment routine can be modified as
subroutine shape_assign(lhs,rhs)
class(shape), intent(inout) :: lhs
class(shape_base), intent(in) :: rhs
if (allocated(lhs%value))deallocate(lhs%value)
! Prevent nested derived type
select type (rhsT=>rhs)
class is (shape); if (allocated(rhsT%value)) allocate(lhs%value,source=rhsT%value)
class default; allocate(lhs%value,source=rhsT)
end select
end subroutine shape_assign
Array handling also works:
subroutine demo3()
type(shape), allocatable :: array(:),chunk(:)
integer :: i
write(*,'(/,A,/)') "Demo 3"
allocate(array(0))
do i=1,10
array = [array,shape(circle(real(i)))]
end do
chunk = array(2:8:2)
call chunk%serialize()
end subroutine demo3
produces
Demo 3
CIRCLE 2.0000000000000000
CIRCLE 4.0000000000000000
CIRCLE 6.0000000000000000
CIRCLE 8.0000000000000000