Binding C union in Fortran

20

There are some problems with class(*), allocatable variables, see:

That’s a close description to what it is.

There was a thread recently, which provides a way of emulating a union: Data-pointer-object and unlimited polymorphic target. The solution involves sequence types and class(*), pointer variables. There is still some uncertainty about the conformity of such usage.

Plain union (potentially uncorforming)

program plain_union

use, intrinsic :: iso_fortran_env
implicit none

logical, parameter :: little_endian = ( 1 == transfer( [1_int8, 0_int8], 0_int16) )
integer, parameter :: dp = kind(1.0d0)

type :: t_double ! 8 bytes
   sequence
   real(dp) :: val
end type
type t_int ! 4 bytes
   sequence
   integer :: val
end type

! The data for the union
type(t_double) :: a

type(t_int), pointer :: a_i
type(t_double), pointer :: a_d

class(*), pointer :: u

print *, "little endian? ", little_endian

! z'3FD5 5555 5555 5555' ~= 1/3
a%val = 1.0_dp/3.0_dp
print *, a%val
print '(Z16)', transfer(a,1_int64)

u => a

a_i => u
print '(Z16)', a_i
a_d => u
print '(Z16)', transfer(a_d,1_int64)

end program

Output:

$ gfortran -Wall union.f90 
$ ./a.out
 little endian?  T
  0.33333333333333331     
3FD5555555555555
        55555555
3FD5555555555555

$ flang-new union.f90 
$ ./a.out
 little endian?  T
 .3333333333333333
3FD5555555555555
        55555555
3FD5555555555555

$ ifort union.f90 
$ ./a.out
 little endian?  T
  0.333333333333333     
3FD5555555555555
        55555555
3FD5555555555555

~> nagfor union.f90 
NAG Fortran Compiler Release 7.2(Shin-Urayasu) Build 7203
[NAG Fortran Compiler normal termination]
~> ./a.out
 little endian?  T
   0.3333333333333333
3FD5555555555555
        55555555
3FD5555555555555

All compilers silently accept the type-punning. The only one that doesn’t is nvfortran which says:

NVFORTRAN-S-0155-Illegal POINTER assignment - type mismatch (/app/example.f90: 36)
NVFORTRAN-S-0155-Illegal POINTER assignment - type mismatch (/app/example.f90: 40)
  0 inform,   0 warnings,   2 severes, 0 fatal for plain_union
Compiler returned: 2

Even if the plain union is not conformant due to the type-punning, the tagged case should be legal.

Tagged union

! tagged_union.f90

module menu

implicit none
private

public :: menu_item
public :: pizza_order, burger_order
public :: print_orders

integer, parameter :: ITEM_PIZZA = 1
integer, parameter :: ITEM_BURGER = 2

! N.b. sequence types are not polymorphic

type :: pizza
    sequence
    character(len=1) :: size ! S, M, L
    integer :: toppings ! Number of toppings
end type

type :: burger
    sequence
    integer :: patty_count
    logical :: cheese
end type

! Since item will contain
type :: menu_item
    private
    integer :: type
    class(*), allocatable :: item
end type

contains

    function pizza_order(size,toppings) result(order)
        character(len=1), intent(in) :: size
        integer, intent(in) :: toppings
        type(menu_item) :: order
        if (size /= 'S' .and. size /= 'M' .and. size /= 'L') error stop "Wrong pizza size"
        if (toppings > 5) error stop "Only up to 5 toppings are available"
        order = menu_item(ITEM_PIZZA,pizza(size=size,toppings=toppings))
    end function

    function burger_order(patty_count,with_cheese) result(order)
        integer, intent(in) :: patty_count
        logical, intent(in) :: with_cheese
        type(menu_item) :: order
        order = menu_item(ITEM_BURGER,burger(patty_count,with_cheese))
    end function

    subroutine print_orders(orders)
        type(menu_item), intent(in), target :: orders(:)
        integer :: i

        do i = 1, size(orders)
        select case(orders(i)%type)
        case(ITEM_PIZZA)
            block
                type(pizza), pointer :: p
                p => orders(i)%item
                print '("Pizza: Size ",A1,", ",I0," extra toppings")', &
                    p%size, p%toppings
            end block
        case(ITEM_BURGER)
            block
                type(burger), pointer :: p
                p => orders(i)%item
                write(*,'("Burger: ",I0," patties, ")',advance='no') &
                    p%patty_count
                if (p%cheese) then
                    write(*,'(A)') "with cheese"
                else
                    write(*,'(A)') "no cheese"
                end if
            end block
        case default
            error stop "Unknown menu item"
        end select
        end do
    end subroutine

end module

program tagged_union

use menu
implicit none

type(menu_item), allocatable :: ord(:)

ord = [ pizza_order(size='M',toppings=3), &
        burger_order(patty_count=2,with_cheese=.false.) ]

call print_orders(ord)

end program

Output:

$ flang-new tagged_union.f90 
$ ./a.out
Pizza: Size M, 3 extra toppings
Burger: 2 patties, no cheese

~> nagfor tagged_union.f90 
NAG Fortran Compiler Release 7.2(Shin-Urayasu) Build 7203
[NAG Fortran Compiler normal termination]
~> ./a.out
Pizza: Size M, 3 extra toppings
Burger: 2 patties, no cheese