Following the second option suggested by Federico Perini in Fortran : Is it possible to overload a procedure in a abstract interface?, I wrote this code.
module myModule
implicit none
type, abstract :: shape_t
contains
! Put init in a generic interface
procedure(abstract_init), deferred, private :: shared_init
generic :: init => shared_init
procedure(abstract_print), deferred :: print_size
end type shape_t
abstract interface
subroutine abstract_init(this,length1,length2,length3)
import shape_t
class(shape_t), intent(inout) :: this
real, intent(in) :: length1,length2,length3
end subroutine abstract_init
subroutine abstract_print(this)
import shape_t
class(shape_t), intent(in) :: this
end subroutine abstract_print
end interface
type, extends(shape_t) :: line_t
real :: length
contains
procedure :: shared_init => init_line
procedure :: init_line_1d
generic :: init => init_line_1d
procedure :: print_size => print_linesize
end type line_t
type, extends(shape_t) :: rectangle_t
real :: length,width
contains
procedure :: shared_init => init_rectangle
procedure :: init_rectangle_2d
generic :: init => init_rectangle_2d
procedure :: print_size => print_rectanglesize
end type rectangle_t
type, extends(shape_t) :: box_t
real :: length,width,height
contains
procedure :: shared_init => init_box
procedure :: print_size => print_boxsize
end type box_t
contains
subroutine init_line_1d(this,length1)
class(line_t), intent(inout) :: this
real, intent(in) :: length1
this%length = length1
end subroutine init_line_1d
subroutine init_line(this,length1,length2,length3)
class(line_t), intent(inout) :: this
real, intent(in) :: length1,length2,length3
call init_line_1d(this,length1)
end subroutine init_line
subroutine print_linesize(this)
class(line_t), intent(in) :: this
print*,'Line size',this%length,'meter'
end subroutine print_linesize
subroutine init_rectangle(this,length1,length2,length3)
class(rectangle_t), intent(inout) :: this
real, intent(in) :: length1,length2,length3
call init_rectangle_2d(this,length1,length2)
end subroutine init_rectangle
subroutine init_rectangle_2d(this,length1,length2)
class(rectangle_t), intent(inout) :: this
real, intent(in) :: length1,length2
this%length = length1
this%width = length2
end subroutine init_rectangle_2d
subroutine print_rectanglesize(this)
class(rectangle_t), intent(in) :: this
print*,'Rectangle area',this%length*this%width,'meter^2'
end subroutine print_rectanglesize
subroutine init_box(this,length1,length2,length3)
class(box_t), intent(inout) :: this
real, intent(in) :: length1,length2,length3
this%length = length1
this%width = length2
this%height = length3
end subroutine init_box
subroutine print_boxsize(this)
class(box_t), intent(in) :: this
print*,'Box volume',this%length*this%width*this%height,'meter^3'
end subroutine print_boxsize
end module myModule
program main
use myModule
implicit none
class(shape_t), allocatable :: dynamic_typing
integer :: choice
print *,'choice (1:line, 2:rectangle or 3:box)'
read(*,'(i1)') choice
select case (choice)
case(1)
allocate(line_t::dynamic_typing)
case(2)
allocate(rectangle_t::dynamic_typing)
case(3)
allocate(box_t::dynamic_typing)
case default
print *,'not permitted'
stop
end select
select type (dynamic_typing)
type is (line_t)
call dynamic_typing%init(4.0)
call dynamic_typing%print_size()
type is (rectangle_t)
call dynamic_typing%init(4.0,3.0)
call dynamic_typing%print_size()
type is (box_t)
call dynamic_typing%init(4.0,3.0,2.0)
call dynamic_typing%print_size()
end select
end program main
But, shared_init
in the abstract interface made me wonder. On one hand, it is useful because, an init
procedure is mandatory in derived type. But, a subroutine (init_line, init_rectangle, init_box
) not used must be written for each derived type. And as it contains all parameters, if a new derived type is added with another parameters (an integer, a logical, or whatever), the abstract interface must be changed and consequently all subroutines mentionned above. It seems me very difficult to maintain (but I am not an OOP specialist).
In first intention, I removed the deferred procedure abstract_init
and I keep only procedure :: init_line_1d
and generic :: init => init_line_1d
(idem for rectangle and box) in the definition of the derived type. but in this case, init
was not mandatory and it bothered me.
So, I have written the code below where it is mandatory to have an init
procedure. But, this procedure is very short and has no parameter. And, new derived type could be easily added with new parameters, without changing code for the previous defined.
module myModule
implicit none
type, abstract :: shape_t
contains
! Put init in a generic interface
procedure(abstract_init), nopass, deferred, private :: shared_init
generic :: init => shared_init
procedure(abstract_print), deferred :: print_size
end type shape_t
abstract interface
subroutine abstract_init()
end subroutine abstract_init
subroutine abstract_print(this)
import shape_t
class(shape_t), intent(in) :: this
end subroutine abstract_print
end interface
type, extends(shape_t) :: line_t
real :: length
contains
procedure, nopass, private :: shared_init => init_line
procedure :: init_line_1d
generic :: init => init_line_1d
procedure :: print_size => print_linesize
end type line_t
type, extends(shape_t) :: rectangle_t
real :: length,width
contains
procedure, nopass, private :: shared_init => init_rectangle
procedure :: init_rectangle_2d
generic :: init => init_rectangle_2d
procedure :: print_size => print_rectanglesize
end type rectangle_t
type, extends(shape_t) :: box_t
real :: length,width,height
contains
procedure, nopass, private :: shared_init => init_box
procedure :: init_box_3d
generic :: init => init_box_3d
procedure :: print_size => print_boxsize
end type box_t
contains
subroutine init_line_1d(this,length1)
class(line_t), intent(inout) :: this
real, intent(in) :: length1
this%length = length1
end subroutine init_line_1d
subroutine print_linesize(this)
class(line_t), intent(in) :: this
print*,'Line size',this%length,'meter'
end subroutine print_linesize
subroutine init_rectangle_2d(this,length1,length2)
class(rectangle_t), intent(inout) :: this
real, intent(in) :: length1,length2
this%length = length1
this%width = length2
end subroutine init_rectangle_2d
subroutine print_rectanglesize(this)
class(rectangle_t), intent(in) :: this
print*,'Rectangle area',this%length*this%width,'meter^2'
end subroutine print_rectanglesize
subroutine init_box_3d(this,length1,length2,length3)
class(box_t), intent(inout) :: this
real, intent(in) :: length1,length2,length3
this%length = length1
this%width = length2
this%height = length3
end subroutine init_box_3d
subroutine print_boxsize(this)
class(box_t), intent(in) :: this
print*,'Box volume',this%length*this%width*this%height,'meter^3'
end subroutine print_boxsize
subroutine init_rectangle() ; end subroutine init_rectangle
subroutine init_line() ; end subroutine init_line
subroutine init_box() ; end subroutine init_box
end module myModule
But, as I am a beginner in OOP, I wonder if it is a good idea or totally stupid. Thank for answer.
CodePudding user response:
The reason abstract interface
s exist is to define a common template that all extended types need to comply to. In your example, you could have such interfaces to mandate properties that are shared across all them. For example (to name a couple):
abstract interface
elemental real(real64) function shape_area(this) result(A)
class(shape_t), intent(in) :: this
end function shape_area
elemental real(real64) function shape_perimeter(this) result(p2)
class(shape_t), intent(in) :: this
end function shape_perimeter
end interface
Initializers for different extended types clearly will never comply to that interface being always the same (otherwise, there would be no need to have a polymorphic class), so, some strategy needs to be put in place. For simple cases like yours, I think the most compact/easy/understandable thing to do is to use default type initializers:
select type (new)
type is (rectangle_t); new = rectangle_t(width,length)
type is (line_t); new = line_t(length)
type is (box_t); new = box_t(length,width,height)
class default; stop 'catastrophic error!'
end select
Otherwise, you need to have a factory that hides away all of the complexity in a separate module.