Intrinsic comparison operator in polymorphic subroutine

Help
1

Hello fortran-lang community,

I need to compare polymorphic entities (a==b) a lot and I always struggle writing a lot of bloatware that basically just replicates the intrinsic comparison operator. Here’s the easiest way I came up with to accomplish that:

type, abstract :: base
contains
    procedure(equality), deferred, private :: is_equal
    generic :: operator(==) => is_equal
end type base

type, extends(base) :: ext
contains
   procedure :: ext_is_equal => is_equal
end type

abstract interface
   elemental logical function equality(this,that) 
       import base
       class(base), intent(in) :: this, that
   end function equality
end interface 

! For each extended type, need to write this one
elemental logical function ext_is_equal(this,that)
    class(ext), intent(in) :: this
    class(base), intent(in) :: that

    select type (that_type => that)
        type is (ext)
            ext_is_equal = that_type == this ! use intrinsic comparison 
        class default
            ext_is_equal = .false.
    end select
end function ext_is_equal

Now I need to write that such routine for each and every extended class, just to use the intrinsic operator. Is this the easiest strategy, or am I missing something?
I would like e.g. to make usage of same_type_as(a,b) but I can’t because it’s not in a select type block.

2

Is this what you are trying to do?

module mammals
implicit none
type, abstract :: mammal
end type
type, extends(mammal) :: dog
end type
type, extends(mammal) :: cat
end type
interface operator(==)
module procedure is_equal
end interface
contains
elemental logical function is_equal(A,B)
class(mammal), intent(in) :: A, B
is_equal = same_type_as(A,B)
end function
end module
program main
use mammals
implicit none
class(mammal), allocatable :: petA, petB, petC
allocate(dog :: petA)
allocate(cat :: petB)
allocate(cat :: petC)
write(*,'(A,L1)') "Are A and B same mammal? ", petA == petB
write(*,'(A,L1)') "Are B and C same mammal? ", petB == petC 
end program
3

Thak you Ivan - I’m trying to get to the full intrinsic comparison, i.e., not only the type, but also all of its contents.

i.e. if my extended class is

type, extends(base) :: animal
   integer :: legs
   logical :: tail
   real :: max_speed
end type animal

I also need to implement

elemental logical function ani_is_equal(this,that)
    class(animal), intent(in) :: this
    class(base), intent(in) :: that

    select type (that_type => that)
        type is (animal)
            ani_is_equal = that_type%legs == this%legs .and. &
                           that_type%max_speed == this%max_speed .and. &
                           that_type%tail .eqv. this%tail
        class default
            ani_is_equal = .false.
    end select
end function ani_is_equal

which is error-prone and could be totally avoided, it is just a reimplementation of the intrinsic == for two entities of the same type.

4

@FedericoPerini , you can make a proposal at the GitHub J3 site on this and perhaps also look “under the hood” with gfortran, LFortran, etc. compiler implementatoins and consult with @certik et al. to see how much the processor itself can do this automagically for the practitioners, a la intrinsic assignment.

Note from the standard committee perspective, since the Fortran 90 days, the view appears appears to be that comparison operations with derived types are the responsibility of the author(s) of said types, that this cannot be “avoided”, meaning the processor cannot do this for you - hence my suggestion above to challenge such thinking.

My hunch is also there will not be acceptance that it is any more “error-prone” than authoring the type itself.

As things stand now with the current standard including in the works “Fortran 2023”, what you are doing with defined operations is the only option you have. You can pursue somewhat different takes on this depending on your situation but you still need to implement defined operations.

1 Like
5

I’ve got very much your same feeling. Hopefully with more and more people embracing the more advanced Fortran features, the practitioners will tell what design patterns in the language they stumble upon more often, that they may require an adjustment :slight_smile:

BTW: the intrinsic comparison operator is (I believe) already natively available for all types.

6

Thanks for providing the extra example. It makes more sense when there are additional properties to compare. On the other hand the notion of comparison between polymorphic entities feels kind of ambiguous.

If you know you are working only with animal’s (and not also plant’s, protozoa, bacteria…), you should use a concrete/non-polymorphic type:

type(animal), allocatable :: group(:)  ! <- intrinsic comparison available

A polymorphic comparison/equality makes more sense to me when you’d use it compare properties which exist for all child types:

module mammals
implicit none
type :: mammal
   integer :: weight
end type
type, extends(mammal) :: dog
   character(32) :: furcolor
end type
type, extends(mammal) :: cat
   integer :: lives
end type
interface operator(==)
   module procedure are_equal_species_and_weigh_the_same
end interface
contains
logical function are_equal_species_and_weigh_the_same(A,B) result(equal)
   class(mammal), intent(in) :: A, B
   equal = same_type_as(A,B) .and. A%weight == B%weight
end function
end module

program main
use mammals
implicit none
class(mammal), allocatable, target :: petA, petB
petA = dog(weight=30,furcolor="brown")
petB = cat(weight=10,lives=7)
petC = dog(weight=30,furcolor="white")
write(*,'(A,L1)') 'Are pet A and B "equal"? ', petA == petB  ! .false., different species
write(*,'(A,L1)') 'Are pet A and C "equal"? ', petA == petC  ! .true., same species, same weight
end program

FWIW, your original solution appears to match the accepted answer on StackOverflow: c++ - Class Polymorphism and equality operators - Stack Overflow; the base class cannot know what you mean by “equality”, so it has to be provided by the child:

#include <iostream>
#include <string>
#include <typeinfo>

class Base
{
public:
    virtual ~Base() {}

    bool operator==(const Base& other) const
    {
        // If the derived types are the same then compare them
        return typeid(*this) == typeid(other) && isEqual(other);
    }

private:
    // A pure virtual function derived classes must implement.
    // Furthermore, this function has a precondition that it will only
    // be called when the 'other' is the same type as the instance
    // invoking the function.
    virtual bool isEqual(const Base& other) const = 0;
};

(In the C++ code, I guess short-circuiting applies to expression which first compares the typeid.)

2 Likes
7

@FedericoPerini and any other reader interested in OO designs in Fortran:

So as indicated by @ivanpribec , there are a couple of aspects you may want to consider when it comes to defined operations (and assignment) with derived types in Fortran, particularly when OO patterns including polymorphism is of interest:

  1. When it comes to defined operations, consider direct generic interfaces instead of type-bound generics,
  2. Start with as abstract an type as the base class as can be envisioned e.g., animal class,
  3. Make judicial use of intermediate concrete extensions to help here, particularly with type-safe operations e.g., a mammal class which then allows type extension to morph into other classes such as cats and dogs,
  4. Realize there is no getting away from considerable boilerplate code in current standard Fortran including the 2023 revision

Thus for the example discussed here, you can do:

Click to see code 
module animal_m
   private
   type, abstract, public :: animal_t
      ! base class properties
      real :: body_mass = 0.0
   contains
      private
      procedure(Icompare), deferred, public :: is_equal
      procedure :: is_not_equal
      generic, public :: operator(/=) => is_not_equal  !<-- perhaps this is Ok
   end type
   abstract interface
      impure elemental function Icompare( lhs, rhs) result(r) !<-- Impure for IO
         import :: animal_t
         class(animal_t), intent(in) :: lhs
         class(animal_t), intent(in) :: rhs
         ! Function result
         logical :: r
      end function
   end interface
contains
   impure elemental function is_not_equal( lhs, rhs) result(r)
      ! Argument list
      class(animal_t), intent(in) :: lhs
      class(animal_t), intent(in) :: rhs
      ! Function result
      logical :: r
      r = .not. lhs%is_equal( rhs )
   end function
end module 
module mammal_m
! Intermediate concrete class
   use animal_m, only : animal_t
   private
   type, extends(animal_t), public :: mammal_t
      character(len=10) :: fur_color = ""
   contains
      private
      procedure, public :: is_equal => is_equal_mammal_animal
   end type
   !generic, public :: operator(==) => is_equal_mammal !<-- Fortran 2018
   interface operator(==)
      module procedure :: is_equal_mammal
   end interface 
   public :: operator(==) 
contains
   impure elemental function is_equal_mammal_animal( lhs, rhs ) result(r)
      ! Argument list
      class(mammal_t), intent(in) :: lhs
      class(animal_t), intent(in) :: rhs
      ! Function result
      logical :: r
      print *, "In is_equal_mammal_animal"
      r = .false.
      select type ( rhs )
         type is ( mammal_t )
            r = is_equal_mammal( lhs, rhs )
         class default 
      end select
   end function
   impure elemental function is_equal_mammal( lhs, rhs ) result(r)
      ! Argument list
      type(mammal_t), intent(in) :: lhs
      type(mammal_t), intent(in) :: rhs
      ! Function result
      logical :: r
      print *, "In is_equal_mammal"
      r = ( lhs%fur_color == rhs%fur_color ) .and. &
          ( lhs%body_mass == rhs%body_mass )
   end function
end module 
module cat_m
! Extended concrete class
   use animal_m, only : animal_t
   use mammal_m, only : mammal_t, operator(==)
   private
   type, extends(mammal_t), public :: cat_t
      integer :: number_of_lives = 7
   contains
      private
      procedure, public :: is_equal => is_equal_cat_animal
   end type
   !generic, public :: operator(==) => is_equal_cat
   interface operator(==)
      module procedure :: is_equal_cat
   end interface
   public :: operator(==) 
contains
   impure elemental function is_equal_cat_animal( lhs, rhs ) result(r)
      ! Argument list
      class(cat_t), intent(in)    :: lhs
      class(animal_t), intent(in) :: rhs
      ! Function result
      logical :: r
      print *, "In is_equal_cat_animal"
      r = .false.
      select type ( rhs )
         type is ( cat_t )
            r = is_equal_cat( lhs, rhs )
         class default 
      end select
   end function
   impure elemental function is_equal_cat( lhs, rhs ) result(r)
      ! Argument list
      type(cat_t), intent(in) :: lhs
      type(cat_t), intent(in) :: rhs
      ! Function result
      logical :: r
      print *, "In is_equal_cat"
      r = ( lhs%number_of_lives == rhs%number_of_lives ) .and. &
          ( lhs%mammal_t == rhs%mammal_t )
   end function
end module
module dog_m
! Extended concrete class
   use animal_m, only : animal_t
   use mammal_m, only : mammal_t, operator(==)
   private
   type, extends(mammal_t), public :: dog_t
      character(len=10) :: breed = ""
   contains
      private
      procedure, public :: is_equal => is_equal_dog_animal
   end type
   !generic, public :: operator(==) => is_equal_dog
   interface operator(==)
      module procedure :: is_equal_dog
   end interface 
   public :: operator(==) 
contains
   impure elemental function is_equal_dog_animal( lhs, rhs ) result(r)
      ! Argument list
      class(dog_t), intent(in)    :: lhs
      class(animal_t), intent(in) :: rhs
      ! Function result
      logical :: r
      print *, "In is_equal_dog_animal"
      r = .false.
      select type ( rhs )
         type is ( dog_t )
            r = is_equal_dog( lhs, rhs )
         class default 
      end select
   end function
   impure elemental function is_equal_dog( lhs, rhs ) result(r)
      ! Argument list
      type(dog_t), intent(in) :: lhs
      type(dog_t), intent(in) :: rhs
      ! Function result
      logical :: r
      print *, "In is_equal_dog"
      r = ( lhs%breed == rhs%breed ) .and.    &
          ( lhs%mammal_t == rhs%mammal_t )
   end function
end module
   use mammal_m
   use cat_m
   use dog_m
   class(mammal_t), allocatable :: Lucy, Jasper
   type(cat_t) :: Milo
   type(dog_t) :: Luna, Sur
   logical :: chk
   Lucy = cat_t(fur_color="brown") ; Jasper = cat_t(fur_color="black")
   chk = Lucy == Jasper
   print *, chk
   Milo = cat_t(fur_color="golden")
   Luna = dog_t(breed="Poodle")
   Sur = dog_t(breed="Labrador")
   chk = Luna == Sur 
   print *, chk
   !chk == Sur == Milo !<-- compiler error, only as expected and likely desired
end

C:\temp>gfortran -ffree-form p.f -o p.exe

C:\temp>p.exe
 In is_equal_mammal
 F
 In is_equal_dog
 In is_equal_mammal
 F
2 Likes