Forpedo Preprocessor Now Supports Run-Time Polymorhpism

The Fortran preprocessor Forpedo no supports run-time polymorphism in
pre-Fortran 2003 standards, as proposed by Decyk and co-workers
(http://www.cs.rpi.edu/~szymansk/oof90.html). This is in addition to
the compile-time polymorphism (ie generics) already supported.

It can be downloaded from http://www.maniacalextent.com/forpedo

To define a polymorphic type (known as a 'protocol') with Forpedo, you
can do something like this:

#protocol AnimalProtocol AnimalProtocolMod

#method makeSound
type(AnimalProtocol), intent(in) :: self
#endmethod

#method increaseAgeInAnimalYears increase
type(AnimalProtocol), intent(inout) :: self
integer, intent(in) :: increase
#endmethod

#conformingtype Dog DogMod
#conformingtype Cat CatMod

#endprotocol

You use such a type like this

program Main
use AnimalProtocolMod
use DogMod
use CatMod
type (Dog), target :: d
type (Cat), target :: c
type (AnimalProtocol) :: p

! Assign protocol to Dog
p = d

! Pass pointer to a subroutine that knows nothing about the concrete type Dog
call doStuffWithAnimal(p)

! Repeat for Cat. Results will be different, though subroutine call
is the same.
p = c
call doStuffWithAnimal(p)

contains

subroutine doStuffWithAnimal(a)
type (AnimalProtocol) :: a
call makeSound(a)
call increaseAgeInAnimalYears(a, 2)
end subroutine

end program

Forpedo expands the protocol declaration into a human-readable Fortran
module. You should never need to look into this module, but here is
what is generated, for completeness:

!-------------------------------------------------------------------------------------------
!

This protocol module was generated by Forpedo
(http://www.maniacalextent.com/forpedo).
! Do not edit this module directly. Instead, locate the forpedo input
file used to generate
! it, and make changes there. When you are ready, regenerate this file
with Forpedo.
!-------------------------------------------------------------------------------------------
module

AnimalProtocolMod
use DogMod
use CatMod
implicit none

integer, parameter, private :: DogId = 0
integer, parameter, private :: CatId = 1

type AnimalProtocol
private
integer :: concreteTypeId
type (Dog), pointer :: DogPtr
type (Cat), pointer :: CatPtr
end type

interface assignment(=)
module procedure assignToType0
module procedure assignToType1
end interface

interface makeSound
module procedure makeSoundProt
end interface
interface increaseAgeInAnimalYears
module procedure increaseAgeInAnimalYearsProt
end interface

private :: assignToType0
private :: assignToType1
private :: makeSoundProt
private :: increaseAgeInAnimalYearsProt

contains

subroutine assignToType0(self,concreteType)
type (AnimalProtocol), intent(out) :: self
type (Dog), intent(in), target :: concreteType
self%DogPtr => concreteType
self%concreteTypeId = DogId
end subroutine

subroutine assignToType1(self,concreteType)
type (AnimalProtocol), intent(out) :: self
type (Cat), intent(in), target :: concreteType
self%CatPtr => concreteType
self%concreteTypeId = CatId
end subroutine

subroutine makeSoundProt(self)
type(AnimalProtocol), intent(in) :: self
select case (self%concreteTypeId)
case (DogId)
call makeSound(self%DogPtr)
case (CatId)
call makeSound(self%CatPtr)
case default
print *,"Invalid case in makeSoundProt"
stop
end select
end subroutine

subroutine increaseAgeInAnimalYearsProt(self, increase)
type(AnimalProtocol), intent(inout) :: self
integer, intent(in) :: increase
select case (self%concreteTypeId)
case (DogId)
call increaseAgeInAnimalYears(self%DogPtr, increase)
case (CatId)
call increaseAgeInAnimalYears(self%CatPtr, increase)
case default
print *,"Invalid case in increaseAgeInAnimalYearsProt"
stop
end select
end subroutine

end module