Overriding intrinsic operators

[Paul Richard Thomas <paul.richard.thomas@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 1829 bytes --]

Hi All,

Happy New Year!

I took an interest in a recent clf thread, entitled "comparison between
class(*) instances", and submitted an example of a possible implementation.
I have attached a reduced version of it.

gfortran, back as far as version 7.4.1, gives the expected output:
a & b are type pvar
T
 a & b are type pvar
 F

ifort (IFORT) 2021.1 Beta 20201112 gives:
 a & b are type pvar
 class default: returning false
 class default: returning false
 F
 a & b are type pvar
 class default: returning false
 class default: returning false
 F

This comes about because ifort is using the defined operation to override
the intrinsic uses of the operator as defined in 10.1.5 of the standard.

I believe that gfortran has this one right, since the first paragraph of
15.4.3.4.2 Defined operations has:
"...If the operator is an intrinsic-operator (R608), the number of dummy
arguments shall be consistent with the intrinsic uses of that operator, and
the types, kind type parameters, or ranks of the dummy arguments shall
differ from those required for the intrinsic operation (10.1.5)."

ifort gives the expected result if the interface is moved to the main
program.

Steve, I would be grateful if you would pass this on because my Intel uid
seems to have expired. Of course, your thoughts would be welcome.

The second attachment does away with the select type constructs by
transferring the unlimited polymorphic payloads to deferred length
characters and comparing them. The use of unlimited polymorphic actual
arguments is leading to invalid reads and the loss of 8 bytes in two blocks
because realloc is being finickity about the casting of the arguments.
Also, when u and v carry strings, both storage_size and transfer fail
because the _len field is not used. I will raise PRs on these issues
tomorrow.

Regards

Paul

[-- Attachment #2: equals4.f90 --]
[-- Type: text/x-fortran, Size: 1086 bytes --]

MODULE mytypes
  IMPLICIT none

  TYPE pvar
     character(len=20) :: name
     integer           :: level
  end TYPE pvar

  interface operator (==)
     module procedure pvar_eq
  end interface

contains
  function pvar_eq(a,b)
    implicit none
    class(*), intent(in) ::a,b
    logical ::pvar_eq
    if (.not. same_type_as (a, b)) then
      pvar_eq = .false.
      return
    end if
    select type (a)
      type is (pvar)
      select type (b)
        type is (pvar)
          print *, "a & b are type pvar"
          if((a%level.eq. b%level) .and. (a%name .eq. b%name)) then
            pvar_eq = .true.
          else
            pvar_eq = .false.
          end if
      end select
      class default
        print *, "class default: returning false"
        pvar_eq = .false.
    end select
  end function pvar_eq
end MODULE mytypes

program test_eq
   use mytypes
   implicit none
   type(pvar) x, y
   x = pvar('test 1', 100)
   y = pvar('test 1', 100)
   write(*, *) x == y
   x = pvar('test 1', 100)
   y = pvar('test 2', 100)
   write(*, *) x == y
end program test_eq


[-- Attachment #3: equals5.f90 --]
[-- Type: text/x-fortran, Size: 1156 bytes --]

MODULE mytypes
  IMPLICIT none

  TYPE pvar
     character(len=20) :: name
     integer           :: level
  end TYPE pvar

  interface operator (==)
     module procedure star_eq
  end interface

contains
  function star_eq(a,b)
    implicit none
    class(*), intent(in) ::a,b
    character(len=:), allocatable :: c1, c2
    logical ::star_eq
    integer(8) :: sza, szb
    star_eq = same_type_as (a, b)
    if (.not. star_eq) return
    sza = storage_size (a)/8
    szb = storage_size (b)/8
    if (sza .ne. szb) then
      star_eq = .false.
    else
      allocate(character(len = sza) :: c1)
      allocate(character(len = szb) :: c2)
      c1 = transfer (a, c1)
      c2 = transfer (b, c2)
      star_eq = c1 .eq. c2
    end if
  end function star_eq
end MODULE mytypes

program test_eq
   use mytypes
   implicit none
   type(pvar) :: x, y
   class(*), allocatable :: u, v
   x = pvar('test 1', 100)
   y = pvar('test 1', 100)
   write(*, *) x == y
   u = pvar('test 1', 100)
   v = pvar('test 2', 100)
   write(*, *) u == v
   u = 1.0_4
   v = 2.0_4
   write(*, *) u == v
   v = 1.0_4
   write(*, *) u == v
   deallocate (u,v)
end program test_eq