gcc/testsuite/gfortran.dg/interface_assignment_7.f90

   1 ! { dg-do compile }
   2 ! PR 96843 - this was wrongly rejected.
   3 ! Test case by William Clodius.
   4
   5 module test_shape_mismatch
   6 ! Implements zero based bitsets of size up to HUGE(0_INT32).
   7 ! The current code uses 32 bit integers to store the bits and uses all 32 bits.
   8 ! The code assumes two's complement integers, and treats negative integers as
   9 ! having the sign bit set.
  10
  11     use, intrinsic ::            &
  12         iso_fortran_env, only:   &
  13             bits_kind  => int32, &
  14             block_kind => int64, &
  15             int8,                &
  16             dp => real64
  17
  18     implicit none
  19
  20     private
  21
  22     integer, parameter ::                                                     &
  23         block_size  = bit_size(0_block_kind),                                 &
  24         block_shift = int( ceiling( log( real(block_size, dp) )/log(2._dp) ) )
  25
  26     public :: bits_kind
  27 ! Public constant
  28
  29     public :: bitset_t
  30 ! Public type
  31
  32     public ::          &
  33         assignment(=)
  34
  35     type, abstract :: bitset_t
  36         private
  37         integer(bits_kind) :: num_bits
  38
  39     end type bitset_t
  40
  41
  42     type, extends(bitset_t) :: bitset_large
  43         private
  44         integer(block_kind), private, allocatable :: blocks(:)
  45
  46     end type bitset_large
  47
  48     interface assign
  49
  50         pure module subroutine assign_log8_large( self, alogical )
  51 !!     Used to define assignment from an array of type LOG for bitset_t
  52             type(bitset_large), intent(out) :: self
  53             logical(int8), intent(in) :: alogical(:)
  54         end subroutine assign_log8_large
  55
  56     end interface assign
  57
  58 contains
  59
  60     pure module subroutine assign_log8_large( self, alogical )
  61 !     Used to define assignment from an array of type LOG for bitset_t
  62         type(bitset_large), intent(out) :: self
  63         logical(int8), intent(in)  :: alogical(:)
  64
  65         integer(bits_kind) :: blocks
  66         integer(bits_kind) :: log_size
  67         integer(bits_kind) :: index
  68
  69         log_size = size( alogical, kind=bits_kind )
  70         self % num_bits = log_size
  71         if ( log_size == 0 ) then
  72             blocks = 0
  73
  74         else
  75             blocks = (log_size-1)/block_size + 1
  76
  77         end if
  78         allocate( self % blocks( blocks ) )
  79         self % blocks(:) = 0
  80
  81         return
  82     end subroutine assign_log8_large
  83
  84 end module test_shape_mismatch