Compiler Explorer

Source code

! File p.f90
module bitbucket_m
   
   use, intrinsic :: iso_c_binding, only : I1 => c_int8_t, I4 => c_int32_t, I8 => c_int64_t, c_loc, &
      c_f_pointer
      
   private

type, public :: bitbucket_t
   ! Field of 8-bit integers
      private
      integer(I1) :: m_fields(8) = 0_i1
   contains
      private
      procedure, pass(this) :: zap_fields
      procedure, pass(this), public :: int32 => get_int32
      procedure, pass(this), public :: int64 => get_int64
      procedure, pass(this), public :: hi => get_int32_hi
      procedure, pass(this), public :: lo => get_int32_lo
      generic, public :: zap => zap_fields
   end type bitbucket_t

! Ref: https://developer.ibm.com/articles/au-endianc/
   logical, parameter :: IS_BIG_ENDIAN = iachar( c=transfer(source=1,mold="a") ) == 0
   integer, parameter :: POS = merge( 3, 1, IS_BIG_ENDIAN )

contains

subroutine zap_fields( this, idx )
      ! Argument list
      class(bitbucket_t), intent(inout) :: this
      integer, intent(in)               :: idx(:)
      ! Local variable
      if ( size(idx) > size(this%m_fields) ) error stop 
      if ( any(idx > size(this%m_fields)) ) error stop 
      this%m_fields( idx ) = 0_i1
      return
   end subroutine zap_fields
   
   function get_int32( this ) result(pval)
      ! Argument list
      class(bitbucket_t), intent(in), target :: this
      ! Function result
      integer(I4), pointer :: pval
      call c_f_pointer( cptr=c_loc(this%m_fields(POS)), fptr=pval )
      return
   end function get_int32
   
   function get_int64( this ) result(pval)
      ! Argument list
      class(bitbucket_t), intent(in), target :: this
      ! Function result
      integer(I8), pointer :: pval
      call c_f_pointer( cptr=c_loc(this%m_fields), fptr=pval )
      return
   end function get_int64

function get_int32_hi( this ) result(pval)
      ! Argument list
      class(bitbucket_t), intent(in), target :: this
      ! Function result
      integer(I4), pointer :: pval
      call c_f_pointer( cptr=c_loc(this%m_fields(POS)), fptr=pval )
      return
   end function get_int32_hi
   
   function get_int32_lo( this ) result(pval)
      ! Argument list
      class(bitbucket_t), intent(in), target :: this
      ! Function result
      integer(I4), pointer :: pval
      call c_f_pointer( cptr=c_loc(this%m_fields(POS+4)), fptr=pval )
      return
   end function get_int32_lo
end module