Forpedo Preprocessor Now Supports Run-Time Polymorhpism

[Drew McCormack]

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