| ! { dg-do compile } |
| ! PR 96843 - this was wrongly rejected. |
| ! Test case by William Clodius. |
| |
| module test_shape_mismatch |
| ! Implements zero based bitsets of size up to HUGE(0_INT32). |
| ! The current code uses 32 bit integers to store the bits and uses all 32 bits. |
| ! The code assumes two's complement integers, and treats negative integers as |
| ! having the sign bit set. |
| |
| use, intrinsic :: & |
| iso_fortran_env, only: & |
| bits_kind => int32, & |
| block_kind => int64, & |
| int8, & |
| dp => real64 |
| |
| implicit none |
| |
| private |
| |
| integer, parameter :: & |
| block_size = bit_size(0_block_kind), & |
| block_shift = int( ceiling( log( real(block_size, dp) )/log(2._dp) ) ) |
| |
| public :: bits_kind |
| ! Public constant |
| |
| public :: bitset_t |
| ! Public type |
| |
| public :: & |
| assignment(=) |
| |
| type, abstract :: bitset_t |
| private |
| integer(bits_kind) :: num_bits |
| |
| end type bitset_t |
| |
| |
| type, extends(bitset_t) :: bitset_large |
| private |
| integer(block_kind), private, allocatable :: blocks(:) |
| |
| end type bitset_large |
| |
| interface assign |
| |
| pure module subroutine assign_log8_large( self, alogical ) |
| !! Used to define assignment from an array of type LOG for bitset_t |
| type(bitset_large), intent(out) :: self |
| logical(int8), intent(in) :: alogical(:) |
| end subroutine assign_log8_large |
| |
| end interface assign |
| |
| contains |
| |
| pure module subroutine assign_log8_large( self, alogical ) |
| ! Used to define assignment from an array of type LOG for bitset_t |
| type(bitset_large), intent(out) :: self |
| logical(int8), intent(in) :: alogical(:) |
| |
| integer(bits_kind) :: blocks |
| integer(bits_kind) :: log_size |
| integer(bits_kind) :: index |
| |
| log_size = size( alogical, kind=bits_kind ) |
| self % num_bits = log_size |
| if ( log_size == 0 ) then |
| blocks = 0 |
| |
| else |
| blocks = (log_size-1)/block_size + 1 |
| |
| end if |
| allocate( self % blocks( blocks ) ) |
| self % blocks(:) = 0 |
| |
| return |
| end subroutine assign_log8_large |
| |
| end module test_shape_mismatch |
