From cd7e19d0c9118e4765eb219eeff03ceb73f102ff Mon Sep 17 00:00:00 2001 From: William Clodius Date: Tue, 29 Sep 2020 17:05:29 -0600 Subject: [PATCH 01/53] Added core files for stdlib_bitsets Added stdlib_bitsets.f90, stdlib_bitset_64.f90, and stdlib_bitset_large.f90 and modified CMakeLists.txt and Makefile.manual so they should compile the files. [ticket: X] --- src/CMakeLists.txt | 3 + src/Makefile.manual | 5 + src/stdlib_bitset_64.f90 | 1344 ++++++++++++++++++++++ src/stdlib_bitset_large.f90 | 1579 ++++++++++++++++++++++++++ src/stdlib_bitsets.f90 | 2130 +++++++++++++++++++++++++++++++++++ 5 files changed, 5061 insertions(+) create mode 100644 src/stdlib_bitset_64.f90 create mode 100644 src/stdlib_bitset_large.f90 create mode 100644 src/stdlib_bitsets.f90 diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index ea7403663..77005e8e9 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -31,6 +31,9 @@ fypp_f90("${fyppFlags}" "${fppFiles}" outFiles) set(SRC stdlib_ascii.f90 + stdlib_bitsets.f90 + stdlib_bitset_64.f90 + stdlib_bitset_large.f90 stdlib_error.f90 stdlib_kinds.f90 stdlib_logger.f90 diff --git a/src/Makefile.manual b/src/Makefile.manual index 1c731b9bb..3986112f6 100644 --- a/src/Makefile.manual +++ b/src/Makefile.manual @@ -1,5 +1,8 @@ SRC = f18estop.f90 \ stdlib_ascii.f90 \ + stdlib_bitsets.f90 \ + stdlib_bitset_64.f90 \ + stdlib_bitset_large.f90 \ stdlib_error.f90 \ stdlib_io.f90 \ stdlib_kinds.f90 \ @@ -40,6 +43,8 @@ clean: # Fortran module dependencies f18estop.o: stdlib_error.o +stdlib_bitset_64.o: stdlib_bitsets.o +stdlib_bitset_large.o: stdlib_bitsets.o stdlib_error.o: stdlib_optval.o stdlib_io.o: \ stdlib_error.o \ diff --git a/src/stdlib_bitset_64.f90 b/src/stdlib_bitset_64.f90 new file mode 100644 index 000000000..daa566bb5 --- /dev/null +++ b/src/stdlib_bitset_64.f90 @@ -0,0 +1,1344 @@ +submodule(stdlib_bitsets) stdlib_bitset_64 + implicit none + +contains + + elemental module function all_64( self ) result(all) +! Returns .TRUE. if all bits in SELF are 1, .FALSE. otherwise. + logical :: all + class(bitset_64), intent(in) :: self + + intrinsic :: btest + integer(bits_kind) :: pos + + do pos=0, self % num_bits - 1 + if ( .not. btest(self % block, pos) ) then + all = .false. + return + end if + end do + all = .true. + + end function all_64 + + + elemental module subroutine and_64(set1, set2) +! +! Sets the bits in SET1 to the bitwise AND of the original bits in SET1 +! and SET2. It is required that SET1 have the same number of bits as +! SET2 otherwise the result is undefined. +! + type(bitset_64), intent(inout) :: set1 + type(bitset_64), intent(in) :: set2 + +! The set2 extent includes the entire extent of set1. +! The (zeroed) region past the end of set1 is unaffected by +! the iand. + set1 % block = iand( set1 % block, & + set2 % block ) + + end subroutine and_64 + + + elemental module subroutine and_not_64(set1, set2) +! +! Sets the bits in SET1 to the bitwise and of the original bits in SET1 +! with the bitwise negation of SET2. SET1 and SET2 must have the same +! number of bits otherwise the result is undefined. +! + type(bitset_64), intent(inout) :: set1 + type(bitset_64), intent(in) :: set2 + +! The not with iand means that the zero'ed regions past the end of each set +! do not interact with the in set regions + set1 % block = iand( set1 % block, not( set2 % block ) ) + + end subroutine and_not_64 + + + elemental module function any_64(self) result(any) +! Returns .TRUE. if any bit in SELF is 1, .FALSE. otherwise. + logical :: any + class(bitset_64), intent(in) :: self + + if ( self % block /= 0 ) then + any = .true. + return + else + any = .false. + end if + + end function any_64 + + + pure module subroutine assign_64( set1, set2 ) +! Used to define assignment for bitset_64 + type(bitset_64), intent(out) :: set1 + type(bitset_64), intent(in) :: set2 + + set1 % num_bits = set2 % num_bits + set1 % block = set2 % block + + end subroutine assign_64 + + + module subroutine assign_log8_64( self, logical_vector ) +! Used to define assignment from an array of type logical for bitset_64 + type(bitset_64), intent(out) :: self + logical(int8), intent(in) :: logical_vector(:) + + integer(bits_kind) :: log_size + integer(bits_kind) :: index + + log_size = size( logical_vector, kind=bits_kind ) + if ( log_size > 64 ) then + error stop module_name // ' % ' // 'ASSIGNMENT' // " has " // & + "SIZE(LOGICAL_VECTOR) > 64 with assignment to a BITSET_64." + end if + self % num_bits = log_size + self % block = 0 + + do index=0, log_size-1 + if ( logical_vector(index+1) ) then + self % block = ibset( self % block, index ) + end if + end do + + end subroutine assign_log8_64 + + + module subroutine assign_log16_64( self, logical_vector ) +! Used to define assignment from an array of type logical for bitset_64 + type(bitset_64), intent(out) :: self + logical(int16), intent(in) :: logical_vector(:) + + integer(bits_kind) :: log_size + integer(bits_kind) :: index + + log_size = size( logical_vector, kind=bits_kind ) + if ( log_size > 64 ) then + error stop module_name // ' % ' // 'ASSIGNMENT' // " has " // & + "SIZE(LOGICAL_VECTOR) > 64 with assignment to a BITSET_64." + end if + self % num_bits = log_size + self % block = 0 + + do index=0, log_size-1 + if ( logical_vector(index+1) ) then + self % block = ibset( self % block, index ) + end if + end do + + end subroutine assign_log16_64 + + + module subroutine assign_log32_64( self, logical_vector ) +! Used to define assignment from an array of type logical for bitset_64 + type(bitset_64), intent(out) :: self + logical(int32), intent(in) :: logical_vector(:) + + integer(bits_kind) :: log_size + integer(bits_kind) :: index + + log_size = size( logical_vector, kind=bits_kind ) + if ( log_size > 64 ) then + error stop module_name // ' % ' // 'ASSIGNMENT' // " has " // & + "SIZE(LOGICAL_VECTOR) > 64 with assignment to a BITSET_64." + end if + self % num_bits = log_size + self % block = 0 + + do index=0, log_size-1 + if ( logical_vector(index+1) ) then + self % block = ibset( self % block, index ) + end if + end do + + end subroutine assign_log32_64 + + + module subroutine assign_log64_64( self, logical_vector ) +! Used to define assignment from an array of type logical for bitset_64 + type(bitset_64), intent(out) :: self + logical(int64), intent(in) :: logical_vector(:) + + integer(bits_kind) :: log_size + integer(bits_kind) :: index + + log_size = size( logical_vector, kind=bits_kind ) + if ( log_size > 64 ) then + error stop module_name // ' % ' // 'ASSIGNMENT' // " has " // & + "SIZE(LOGICAL_VECTOR) > 64 with assignment to a BITSET_64." + end if + self % num_bits = log_size + self % block = 0 + + do index=0, log_size-1 + if ( logical_vector(index+1) ) then + self % block = ibset( self % block, index ) + end if + end do + + end subroutine assign_log64_64 + + + pure module subroutine log8_assign_64( logical_vector, set ) +! Used to define assignment to an array of type logical for bitset_64 + logical(int8), intent(out), allocatable :: logical_vector(:) + type(bitset_64), intent(in) :: set + + integer(bits_kind) :: index + + allocate( logical_vector( set % num_bits ) ) + do index=0, set % num_bits-1 + if ( set % value( index ) == 1 ) then + logical_vector(index+1) = .true. + else + logical_vector(index+1) = .false. + end if + end do + + end subroutine log8_assign_64 + + + pure module subroutine log16_assign_64( logical_vector, set ) +! Used to define assignment to an array of type logical for bitset_64 + logical(int16), intent(out), allocatable :: logical_vector(:) + type(bitset_64), intent(in) :: set + + integer(bits_kind) :: index + + allocate( logical_vector( set % num_bits ) ) + do index=0, set % num_bits-1 + if ( set % value( index ) == 1 ) then + logical_vector(index+1) = .true. + else + logical_vector(index+1) = .false. + end if + end do + + end subroutine log16_assign_64 + + + pure module subroutine log32_assign_64( logical_vector, set ) +! Used to define assignment to an array of type logical for bitset_64 + logical(int32), intent(out), allocatable :: logical_vector(:) + type(bitset_64), intent(in) :: set + + integer(bits_kind) :: index + + allocate( logical_vector( set % num_bits ) ) + do index=0, set % num_bits-1 + if ( set % value( index ) == 1 ) then + logical_vector(index+1) = .true. + else + logical_vector(index+1) = .false. + end if + end do + + end subroutine log32_assign_64 + + + pure module subroutine log64_assign_64( logical_vector, set ) +! Used to define assignment to an array of type logical for bitset_64 + logical(int64), intent(out), allocatable :: logical_vector(:) + type(bitset_64), intent(in) :: set + + integer(bits_kind) :: index + + allocate( logical_vector( set % num_bits ) ) + do index=0, set % num_bits-1 + if ( set % value( index ) == 1 ) then + logical_vector(index+1) = .true. + else + logical_vector(index+1) = .false. + end if + end do + + end subroutine log64_assign_64 + + + elemental module function bit_count_64(self) result(bit_count) +! Returns the number of non-zero bits in SELF. + integer(bits_kind) :: bit_count + class(bitset_64), intent(in) :: self + + integer(bits_kind) :: pos + + bit_count = 0 + + do pos = 0, self % num_bits - 1 + if ( btest( self % block, pos ) ) bit_count = bit_count + 1 + end do + + end function bit_count_64 + + + elemental module subroutine clear_bit_64(self, pos) +! +! Sets to zero the POS position in SELF. If POS is less than zero or +! greater than BITS(SELF)-1 it is ignored. +! + class(bitset_64), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + + if ( pos < 0 .OR. (pos > self % num_bits-1) ) & + return + self % block = ibclr( self % block, pos ) + + end subroutine clear_bit_64 + + + pure module subroutine clear_range_64(self, start_pos, stop_pos) +! +! Sets to zero all bits from the START_POS to STOP_POS positions in SELF. +! If STOP_POS < START_POS then no bits are modified. Positions outside +! the range 0 to BITS(SELF)-1 are ignored. +! + class(bitset_64), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + + integer(bits_kind) :: true_first, true_last + + true_first = max( 0, start_pos ) + true_last = min( self % num_bits-1, stop_pos ) + if ( true_last < true_first ) return + + call mvbits( all_zeros, & + true_first, & + true_last - true_first + 1, & + self % block, & + true_first ) + + end subroutine clear_range_64 + + + elemental module function eqv_64(set1, set2) result(eqv) +! +! Returns .TRUE. if all bits in SET1 and SET2 have the same value, +! .FALSE. otherwise. The sets must have the same number of bits +! otherwise the results are undefined. +! + logical :: eqv + type(bitset_64), intent(in) :: set1, set2 + + eqv = set1 % block == set2 % block + + end function eqv_64 + + + module subroutine extract_64(new, old, start_pos, stop_pos, status) +! Creates a new bitset, NEW, from a range, START_POS to STOP_POS, in bitset +! OLD. If START_POS is greater than STOP_POS the new bitset is empty. +! If START_POS is less than zero or STOP_POS is greater than BITS(OLD)-1 +! then if STATUS is present it has the value INDEX_INVALID_ERROR, +! otherwise processing stops with an informative message. + type(bitset_64), intent(out) :: new + type(bitset_64), intent(in) :: old + integer(bits_kind), intent(in) :: start_pos, stop_pos + integer, intent(out), optional :: status + + integer(bits_kind) :: bits, i, k + character(*), parameter :: procedure = 'EXTRACT' + + if ( start_pos < 0 ) go to 999 + if ( stop_pos >= old % num_bits ) go to 998 + bits = stop_pos - start_pos + 1 + + if ( bits <= 0 ) then + new % num_bits = 0 + new % block = 0 + return + else + new % num_bits = bits + do i=0, bits-1 + k = start_pos + i + if ( btest( old % block, k ) ) & + new % block = ibset(new % block, i) + end do + end if + + if ( present(status) ) status = success + + return + +998 if ( present(status) ) then + status = index_invalid_error + return + else + error stop module_name // ' % ' // procedure // ' had a ' // & + 'STOP_POS greater than BITS(OLD)-1.' + end if + +999 if ( present(status) ) then + status = index_invalid_error + return + else + error stop module_name // ' % ' // procedure // ' had a ' // & + 'START_POS less than 0.' + end if + + end subroutine extract_64 + + + elemental module subroutine flip_bit_64(self, pos) +! +! Flips the value at the POS position in SELF, provided the position is +! valid. If POS is less than 0 or greater than BITS(SELF)-1, no value is +! changed. +! + class(bitset_64), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + + if ( pos < 0 .OR. pos > self % num_bits-1 ) return + + if ( btest( self % block, pos ) ) then + self % block = ibclr( self % block, pos ) + else + self % block = ibset( self % block, pos ) + end if + + end subroutine flip_bit_64 + + + pure module subroutine flip_range_64(self, start_pos, stop_pos) +! +! Flips all valid bits from the START_POS to the STOP_POS positions in +! SELF. If STOP_POS < START_POS no bits are flipped. Positions less than +! 0 or greater than BITS(SELF)-1 are ignored. +! + class(bitset_64), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + + integer(bits_kind) :: bit, end_bit, start_bit + + start_bit = max( 0, start_pos ) + end_bit = min( stop_pos , self % num_bits-1 ) + call mvbits( not(self % block), & + start_bit, & + end_bit - start_bit + 1, & + self % block, & + start_bit ) + + end subroutine flip_range_64 + + + module subroutine from_string_64(self, string, status) +! Initializes the bitset SELF treating STRING as a binary literal +! STATUS may have the values SUCCESS, ALLOC_FAULT, +! ARRAY_SIZE_INVALID_ERROR, or CHAR_STRING_INVALID. + class(bitset_64), intent(out) :: self + character(*), intent(in) :: string + integer, intent(out), optional :: status + + character(*), parameter :: procedure = 'FROM_STRING' + integer(bits_kind) :: bit + integer(int64) :: bits + character(1) :: char + + bits = len(string, kind=int64) + if ( bits > 64 ) go to 998 + self % num_bits = bits + do bit = 1, bits + char = string(bit:bit) + if ( char == '0' ) then + call self % clear( int(bits, kind=bits_kind)-bit ) + else if ( char == '1' ) then + call self % set( int(bits, kind=bits_kind)-bit ) + else + go to 999 + end if + end do + + if ( present(status) ) status = success + + return + +998 if ( present(status) ) then + status = array_size_invalid_error + return + else + error stop module_name // ' % ' // procedure // ' STRING ' // & + 'was too long for a BITSET_64 SELF.' + end if + +999 if ( present(status) ) then + status = char_string_invalid_error + return + else + error stop module_name // ' % ' // procedure // ' STRING ' // & + 'had a character other than "0" or "1",' + end if + + end subroutine from_string_64 + + + elemental module function ge_64(set1, set2) result(ge) +! +! Returns .TRUE. if the bits in SET1 and SET2 are the same or the +! highest order different bit is set to 1 in SET1 and to 0 in set2. +! .FALSE. otherwise. The sets must have the same number of bits +! otherwise the results are undefined. +! + logical :: ge + type(bitset_64), intent(in) :: set1, set2 + + ge = bge( set1 % block, set2 % block ) + + end function ge_64 + + + elemental module function gt_64(set1, set2) result(gt) +! +! Returns .TRUE. if the bits in SET1 and SET2 differ and the +! highest order different bit is set to 1 in SET1 and to 0 in set2. +! .FALSE. otherwise. The sets must have the same number of bits +! otherwise the results are undefined. +! + logical :: gt + type(bitset_64), intent(in) :: set1, set2 + + gt = bgt( set1 % block, set2 % block ) + + end function gt_64 + + + module subroutine init_zero_64(self, bits, status) +! +! Creates the bitset, SELF, of size BITS, with all bits initialized to +! zero. BITS must be non-negative. If an error occurs and STATUS is +! absent then processing stops with an informative stop code. STATUS +! has a default value of SUCCESS. If an error occurs it has the value +! ARRAY_SIZE_INVALID_ERROR if BITS is either negative larger than 64 +! if SELF is of type BITSET_64, or the value ALLOC_FAULT if it failed +! during allocation of memory for SELF. +! + class(bitset_64), intent(out) :: self + integer(bits_kind), intent(in) :: bits + integer, intent(out), optional :: status + + character(*), parameter :: procedure = "INIT" + + if ( bits < 0 .or. bits > 64 ) go to 999 + + self % num_bits = bits + self % block = all_zeros + + if ( present(status) ) status = success + + return + +999 if ( present(status) ) then + status = array_size_invalid_error + return + else + if ( bits < 0 ) then + error stop module_name // ' %' // procedure // ' BITS had ' // & + 'a negative value.' + else + error stop module_name // ' %' // procedure // ' BITS had ' // & + 'a value greater than 64.' + end if + end if + + end subroutine init_zero_64 + + + module subroutine input_64(self, unit, status) +! +! Reads the components of the bitset, SELF, from the unformatted I/O +! unit, UNIT, assuming that the components were written using OUTPUT. +! If an error occurs and STATUS is absent then processing stops with +! an informative stop code. STATUS has a default value of SUCCESS. +! If an error occurs it has the value READ_FAILURE if it failed +! during the reads from UNIT or the value ALLOC_FAULT if it failed +! during allocation of memory for SELF, or the value +! ARRAY_SIZE_INVALID_ERROR if the BITS(SELF) in UNIT is less than 0 +! or greater than 64 for a BITSET_64 input. +! + class(bitset_64), intent(out) :: self + integer, intent(in) :: unit + integer, intent(out), optional :: status + + integer(bits_kind) :: bits + integer :: ierr + character(len=120) :: message + character(*), parameter :: procedure = 'INPUT' + integer :: stat + + read(unit, iostat=ierr, iomsg=message) bits + if (ierr /= 0) go to 999 + if ( bits < 0 .or. bits > 64 ) go to 998 + + call self % init(bits, stat) + if (stat /= success) go to 998 + + if (bits < 1) return + + read(unit, iostat=ierr, iomsg=message) self % block + if (ierr /= 0) go to 999 + + if ( present(status) ) status = success + + return + +998 if ( present(status) ) then + status = array_size_invalid_error + return + else + if ( bits < 0 ) then + error stop module_name // ' %' // procedure // ' BITS in ' // & + 'UNIT had a negative value.' + else + error stop module_name // ' %' // procedure // ' BITS in ' // & + 'UNIT had a value greater than 64.' + end if + end if + +999 if ( present(status) ) then + status = read_failure + return + else + error stop module_name // ' % ' // procedure // ' had a ' // & + 'failure on a READ statement for UNIT.' + end if + + end subroutine input_64 + + + elemental module function le_64(set1, set2) result(le) +! +! Returns .TRUE. if the bits in SET1 and SET2 are the same or the +! highest order different bit is set to 0 in SET1 and to 1 in set2. +! .FALSE. otherwise. The sets must have the same number of bits +! otherwise the results are undefined. +! + logical :: le + type(bitset_64), intent(in) :: set1, set2 + + le = ble( set1 % block, set2 % block ) + + end function le_64 + + + elemental module function lt_64(set1, set2) result(lt) +! +! Returns .TRUE. if the bits in SET1 and SET2 differ and the +! highest order different bit is set to 0 in SET1 and to 1 in set2. +! .FALSE. otherwise. The sets must have the same number of bits +! otherwise the results are undefined. +! + logical :: lt + type(bitset_64), intent(in) :: set1, set2 + + lt = blt( set1 % block, set2 % block ) + + end function lt_64 + + + elemental module function neqv_64(set1, set2) result(neqv) +! +! Returns .TRUE. if all bits in SET1 and SET2 have the same value, +! .FALSE. otherwise. The sets must have the same number of bits +! otherwise the results are undefined. +! + logical :: neqv + type(bitset_64), intent(in) :: set1, set2 + + neqv = set1 % block /= set2 % block + + end function neqv_64 + + + elemental module function none_64(self) result(none) +! +! Returns .TRUE. if none of the bits in SELF have the value 1. +! + logical :: none + class(bitset_64), intent(in) :: self + + none = .true. + if (self % block /= 0) then + none = .false. + return + end if + + end function none_64 + + + elemental module subroutine not_64(self) +! +! Sets the bits in SELF to their logical complement +! + class(bitset_64), intent(inout) :: self + + integer(bits_kind) :: bit + + if ( self % num_bits == 0 ) return + + do bit=0, self % num_bits - 1 + if ( btest( self % block, bit ) ) then + self % block = ibclr( self % block, bit ) + else + self % block = ibset( self % block, bit ) + end if + end do + + end subroutine not_64 + + + elemental module subroutine or_64(set1, set2) +! +! Sets the bits in SET1 to the bitwise OR of the original bits in SET1 +! and SET2. If SET1 has fewer bits than SET2 then the additional bits +! in SET2 are ignored. If SET1 has more bits than SET2, then the +! absent SET2 bits are treated as if present with zero value. +! + type(bitset_64), intent(inout) :: set1 + type(bitset_64), intent(in) :: set2 + + if ( set1 % num_bits >= set2 % num_bits ) then + set1 % block = ior( set1 % block, & + set2 % block ) + else +! The set1 extent ends before set2 => set2 bits must not affect bits in +! set1 beyond its extent => set those bits to zero while keeping proper +! values of other bits in set2 + set1 % block = & + ior( set1 % block, & + ibits( set2 % block, & + 0, & + set1 % num_bits ) ) + end if + + end subroutine or_64 + + + module subroutine output_64(self, unit, status) +! +! Writes the components of the bitset, SELF, to the unformatted I/O +! unit, UNIT, in a unformatted sequence compatible with INPUT. If +! STATUS is absent an error results in an error stop with an +! informative stop code. If STATUS is present it has the default +! value of SUCCESS, or the value WRITE_FAILURE if the write failed. +! + class(bitset_64), intent(in) :: self + integer, intent(in) :: unit + integer, intent(out), optional :: status + + integer :: ierr + character(len=120) :: message + character(*), parameter :: procedure = "OUTPUT" + integer(bits_kind) :: words + + write(unit, iostat=ierr, iomsg=message) self % num_bits + if (ierr /= 0) go to 999 + + if (self % num_bits < 1) return + write(unit, iostat=ierr, iomsg=message) self % block + if (ierr /= 0) go to 999 + + return + +999 if ( present(status) ) then + status = write_failure + return + else + error stop module_name // ' % ' // procedure // ' had a ' // & + 'failure in the write to UNIT.' + end if + + end subroutine output_64 + + + module subroutine read_bitset_string_64(self, string, status) +! +! Uses the bitset literal in the default character STRING, to define +! the bitset, SELF. The literal may be preceded by an an arbitrary +! sequence of blank characters. If STATUS is absent an error results +! in an error stop with an informative stop code. If STATUS +! is present it has the default value of SUCCESS, the value +! INTEGER_OVERFLOW_ERROR if the bitset literal has a BITS(SELF) value +! too large to be represented, the value ALLOC_FAULT if allocation of +! memory for SELF failed, or CHAR_STRING_INVALID_ERROR if the bitset +! literal has an invalid character, or ARRAY_SIZE_INVALID_ERROR if +! BITS(SELF) in STRING is greater than 64 for a BITSET_64, or +! CHAR_STRING_TOO_SMALL_ERROR if the string ends before all the bits +! are read. +! + class(bitset_64), intent(out) :: self + character(len=*), intent(in) :: string + integer, intent(out), optional :: status + + integer(bits_kind) :: bit, bits + integer(int64) :: bits_needed + integer(bits_kind) :: digits, pos + character(*), parameter :: procedure = "READ_BITSET" + integer :: stat + + pos = 1 + find_start: do pos=1, len(string) + if ( string(pos:pos) /= ' ' ) exit + end do find_start + + if ( pos > len(string) - 8 ) go to 999 + + if ( string(pos:pos) /= 's' .AND. string(pos:pos) /= 'S' ) go to 999 + + pos = pos + 1 + bits = 0 + digits = 0 + + do + select case( iachar( string(pos:pos) ) ) + case(ia0:ia9) + digits = digits + 1 + if ( digits == 10 .AND. bits > 2_bits_kind**30/5 ) go to 996 +!! May not be quite right + if ( digits > 10 ) go to 996 + bits = bits*10 + iachar( string(pos:pos) ) - ia0 + if ( bits < 0 ) go to 996 + case(iachar('b'), iachar('B')) + go to 100 + case default + go to 999 + end select + + pos = pos + 1 + + end do + +100 if ( bits > 64 ) go to 995 + if ( bits + pos > len(string) ) go to 994 + call self % init( bits, stat ) + if (stat /= success) go to 998 + + pos = pos + 1 + bit = bits - 1 + do + if ( string(pos:pos) == '0' ) then + call self % clear( bit ) ! this may not be needed + else if ( string(pos:pos) == '1' ) then + call self % set( bit ) + else + go to 999 + end if + pos = pos + 1 + bit = bit - 1 + if ( bit < 0 ) exit + end do + + if ( present(status) ) status = success + + return + +994 if ( present(status) ) then + status = char_string_too_small_error + return + else + error stop module_name // ' % ' // procedure // ' STRING ' // & + 'was too small for the BITS specified by the STRING.' + end if + +995 if ( present(status) ) then + status = array_size_invalid_error + return + else + error stop module_name // ' %' // procedure // ' BITS in ' // & + 'STRING had a value greater than 64.' + end if + + +996 if ( present(status) ) then + status = integer_overflow_error + return + else + error stop module_name // ' % ' // procedure // ' failed on ' // & + 'integer overflow in reading size of bitset literal from ' // & + 'UNIT.' + end if + +998 if ( present(status) ) then + status = alloc_fault + return + else + error stop module_name // ' % ' // procedure // ' failed in ' // & + 'allocating memory for the bitset.' + end if + +999 if ( present(status) ) then + status = char_string_invalid_error + return + else + error stop module_name // ' % ' // procedure // ' failed due ' // & + 'to an invalid character in STRING.' + end if + + end subroutine read_bitset_string_64 + + + module subroutine read_bitset_unit_64(self, unit, advance, status) +! +! + class(bitset_64), intent(out) :: self + integer, intent(in) :: unit + character(*), intent(in), optional :: advance + integer, intent(out), optional :: status + + integer(bits_kind) :: bit, bits, digits + integer :: ierr + character(len=128) :: message + character(len=:), allocatable :: literal + integer(bits_kind) :: pos + character(*), parameter :: procedure = "READ_BITSET" + integer :: stat + character(len=1) :: char, quote + + do + read( unit, & + advance='NO', & + FMT='(A1)', & + err=997, & + end=998, & + iostat=ierr, & + iomsg=message ) char + select case( char ) + case( ' ' ) + cycle + case( 's', 'S' ) + exit + case default + go to 999 + end select + end do + + bits = 0 + digits = 0 + do + read( unit, & + advance='NO', & + FMT='(A1)', & + err=998, & + end=999, & + iostat=ierr, & + iomsg=message ) char + if ( char == 'b' .or. char == 'B' ) exit + select case( char ) + case( '0', '1', '2', '3', '4', '5', '6', '7', '8', '9' ) + digits = digits + 1 + if ( digits == 10 .AND. bits > 2_bits_kind**30/5 ) go to 996 +!! May not be quite right + if ( digits > 10 ) go to 996 + bits = 10*bits + iachar(char) - iachar('0') + if ( bits < 0 ) go to 996 + case default + go to 999 + end select + end do + + if ( bits < 0 .OR. digits == 0 .OR. digits > 10 ) go to 999 + + if ( bits > 64 ) go to 995 + call self % init( bits ) + do bit = 1, bits-1 + read( unit, & + advance='NO', & + FMT='(A1)', & + err=997, & + end=998, & + iostat=ierr, & + iomsg=message ) char + if ( char == '0' ) then + call self % clear( bits-bit ) + else if ( char == '1' ) then + call self % set( bits-bit ) + else + go to 999 + end if + end do + + if ( present(advance) ) then + read( unit, & + advance=advance, & + FMT='(A1)', & + err=997, & + end=998, & + iostat=ierr, & + iomsg=message ) char + + else + read( unit, & + advance='YES', & + FMT='(A1)', & + err=997, & + end=998, & + iostat=ierr, & + iomsg=message ) char + + end if + if ( char == '0' ) then + call self % clear( bits-bit ) + else if ( char == '1' ) then + call self % set( bits-bit ) + else + go to 999 + end if + + if ( present(status) ) status = success + + return + +995 if ( present(status) ) then + status = array_size_invalid_error + return + else + error stop module_name // ' %' // procedure // ' BITS in ' // & + 'STRING had a value greater than 64.' + end if + +996 if ( present(status) ) then + status = integer_overflow_error + return + else + error stop module_name // ' % ' // procedure // ' failed on ' // & + 'integer overflow in reading size of bitset literal from ' // & + 'UNIT.' + end if + +997 if ( present(status) ) then + status = read_failure + return + else + error stop module_name // ' % ' // procedure // ' failed on ' // & + 'read of UNIT.' + end if + +998 if ( present(status) ) then + status = eof_failure + return + else + error stop module_name // ' % ' // procedure // ' reached ' // & + 'End of File of UNIT before finding a bitset literal.' + end if + +999 if ( present(status) ) then + status = char_string_invalid_error + return + else + error stop module_name // ' % ' // procedure // ' found an ' // & + 'invalid bitset literal in UNIT.' + end if + + end subroutine read_bitset_unit_64 + + + elemental module subroutine set_bit_64(self, pos) +! +! Sets the value at the POS position in SELF, provided the position is +! valid. If the position is less than 0 or greater than BITS(SELF)-1 +! then SELF is unchanged. +! + class(bitset_64), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + + integer(bits_kind) :: set_block, block_bit + + if ( pos < 0 .OR. pos > self % num_bits-1 ) return + self % block = ibset( self % block, pos ) + + end subroutine set_bit_64 + + + pure module subroutine set_range_64(self, start_pos, stop_pos) +! +! Sets all valid bits to 1 from the START_POS to the STOP_POS positions +! in SELF. If STOP_POA < START_POS no bits are changed. Positions outside +! the range 0 to BITS(SELF)-1 are ignored. +! + class(bitset_64), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + + integer(bits_kind) :: bit, end_bit, start_bit + + start_bit = max( 0, start_pos ) + end_bit = min( stop_pos, self % num_bits-1 ) + if ( end_bit < start_bit ) return + +! FIRST and LAST are in the same block + call mvbits( all_ones, & + start_bit, & + end_bit - start_bit + 1, & + self % block, & + start_bit ) + + end subroutine set_range_64 + + + elemental module function test_64(self, pos) result(test) +! +! Returns .TRUE. if the POS position is set, .FALSE. otherwise. If POS +! is negative or greater than BITS(SELF) - 1 the result is .FALSE.. +! + logical :: test + class(bitset_64), intent(in) :: self + integer(bits_kind), intent(in) :: pos + + if ( pos < 0 .or. pos >= self % num_bits ) then + test = .false. + else + test = btest( self % block, pos ) + end if + + end function test_64 + + + module subroutine to_string_64(self, string, status) +! +! Represents the value of SELF as a binary literal in STRING +! Status may have the values SUCCESS or ALLOC_FAULT +! + class(bitset_64), intent(in) :: self + character(len=:), allocatable, intent(out) :: string + integer, intent(out), optional :: status + + character(*), parameter :: procedure = 'TO_STRING' + integer :: bit, bit_count, pos, stat + + bit_count = self % num_bits + allocate( character(len=bit_count)::string, stat=stat ) + if ( stat > 0 ) go to 999 + + do bit=0, bit_count-1 + pos = bit_count - bit + if ( btest( self % block, bit ) ) then + string( pos:pos ) = '1' + else + string( pos:pos ) = '0' + end if + end do + + if ( present(status) ) status = success + + return + +999 if ( present(status) ) then + status = alloc_fault + return + + else + error stop module_name // ' % ' // procedure // ' allocation ' // & + 'of STRING failed.' + + end if + + end subroutine to_string_64 + + + elemental module function value_64(self, pos) result(value) +! +! Returns 1 if the POS position is set, 0 otherwise. If POS is negative +! or greater than BITS(SELF) - 1 the result is 0. +! + integer :: value + class(bitset_64), intent(in) :: self + integer(bits_kind), intent(in) :: pos + + if ( pos < 0 .or. pos >= self % num_bits ) then + value = 0 + + else + if ( btest( self % block, pos ) ) then + value = 1 + + else + value = 0 + + end if + + end if + + end function value_64 + + + module subroutine write_bitset_string_64(self, string, status) +! +! Writes a bitset literal to the allocatable default character STRING, +! representing the individual bit values in the bitset_t, SELF. +! If STATUS is absent an error results in an error stop with an +! informative stop code. If STATUS is present it has the default +! value of SUCCESS, or the value ALLOC_FAULT if allocation of +! the output string failed. +! + class(bitset_64), intent(in) :: self + character(len=:), allocatable, intent(out) :: string + integer, intent(out), optional :: status + + integer(bits_kind) :: bit, & + bit_count, & + count_digits, & + digit, & + digits, & + max_bit, & + pos, & + processed, & + val + integer :: stat + + character(*), parameter :: procedure = 'WRITE_BITSET' + + bit_count = bits(self) + + call digit_count( self % num_bits, count_digits ) + + allocate( character(len=count_digits+bit_count+2)::string, stat=stat ) + if ( stat > 0 ) go to 999 + + write( string, "('S', i0)" ) self % num_bits + + string( count_digits + 2:count_digits + 2 ) = "B" + do bit=0, bit_count-1 + pos = count_digits + 2 + bit_count - bit + if ( btest( self % block, bit ) ) then + string( pos:pos ) = '1' + else + string( pos:pos ) = '0' + end if + end do + + if ( present(status) ) status = success + + return + +999 if ( present(status) ) then + status = alloc_fault + return + + else + error stop module_name // ' % ' // procedure // ' had a ' // & + 'memory sllocation failure for a string.' + + end if + + contains + + subroutine digit_count( bits, digits ) + integer(bits_kind), intent(in) :: bits + integer(bits_kind), intent(out) :: digits + + select case ( bits ) + case ( 0:9 ) + digits = 1 + + case ( 10:99 ) + digits = 2 + + case ( 100:999 ) + digits = 3 + + case ( 1000:9999 ) + digits = 4 + + case ( 10000:99999 ) + digits = 5 + + case ( 100000:999999 ) + digits = 6 + + case ( 1000000:9999999 ) + digits = 7 + + case ( 10000000:99999999 ) + digits = 8 + + case ( 100000000:999999999 ) + digits = 9 + + case ( 1000000000:min(2147483647, huge( self % num_bits ) ) ) + digits = 10 + + case default + error stop module_name // ' % ' // procedure // & + ' internal consistency fault was found.' + + end select + + end subroutine digit_count + + end subroutine write_bitset_string_64 + + + module subroutine write_bitset_unit_64(self, unit, advance, status) +! +! Writes a bitset literal to the I/O unit, UNIT, representing the +! individual bit values in the bitset_t, SELF. By default or if +! ADVANCE is present with the value 'YES', advancing output is used. +! If ADVANCE is present with the value 'NO', then the current record +! is not advanced by the write. If STATUS is absent an error results +! in an error stop with an informative stop code. If STATUS is +! present it has the default value of SUCCESS, the value +! ALLOC_FAULT if allocation of the output string failed, or +! WRITE_FAILURE if the WRITE statement outputting the literal failed. +! + class(bitset_64), intent(in) :: self + integer, intent(in) :: unit + character(len=*), intent(in), optional :: advance + integer, intent(out), optional :: status + + integer :: ierr + character(:), allocatable :: string + character(len=120) :: message + character(*), parameter :: procedure = "WRITE_BITSET" + + call self % write_bitset(string, status) + + if ( present(status) ) then + if (status /= success ) return + end if + + + if ( present( advance ) ) then + write( unit, & + FMT='(A)', & + advance=advance, & + iostat=ierr, & + iomsg=message ) & + string + else + write( unit, & + FMT='(A)', & + advance='YES', & + iostat=ierr, & + iomsg=message ) & + string + end if + if (ierr /= 0) go to 999 + + return + +999 if ( present(status) ) then + status = write_failure + return + else + error stop module_name // ' % ' // procedure // ' had a ' // & + 'failure on a WRITE statement.' + end if + + end subroutine write_bitset_unit_64 + + + elemental module subroutine xor_64(set1, set2) +! +! Sets the bits in SET1 to the bitwise XOR of the original bits in SET1 +! and SET2. SET1 and SET2 must have the same number of bits otherwise +! the result is undefined. +! + type(bitset_64), intent(inout) :: set1 + type(bitset_64), intent(in) :: set2 + + set1 % block = ieor( set1 % block, & + set2 % block ) + + end subroutine xor_64 + + +end submodule stdlib_bitset_64 diff --git a/src/stdlib_bitset_large.f90 b/src/stdlib_bitset_large.f90 new file mode 100644 index 000000000..9e58e046b --- /dev/null +++ b/src/stdlib_bitset_large.f90 @@ -0,0 +1,1579 @@ +submodule(stdlib_bitsets) stdlib_bitset_large + implicit none + +contains + + + elemental module function all_large( self ) result(all) +! Returns .TRUE. if all bits in SELF are 1, .FALSE. otherwise. + logical :: all + class(bitset_large), intent(in) :: self + + integer(bits_kind) :: block, full_blocks, pos + + all = .true. + full_blocks = bits(self)/block_size + do block = 1, full_blocks + if ( self % blocks(block) /= -1_block_kind ) then + all = .false. + return + end if + end do + + if ( full_blocks == size(self % blocks) ) return + + do pos=0, modulo( bits(self), block_size )-1 + if ( .not. btest(self % blocks(full_blocks+1), pos) ) then + all = .false. + return + end if + end do + + end function all_large + + + elemental module subroutine and_large(set1, set2) +! +! Sets the bits in SET1 to the bitwise AND of the original bits in SET1 +! and SET2. It is required that SET1 have the same number of bits as +! SET2 otherwise the result is undefined. +! + type(bitset_large), intent(inout) :: set1 + type(bitset_large), intent(in) :: set2 + + integer(bits_kind) :: ablock + + do ablock = 1, size(set1 % blocks) + set1 % blocks(ablock) = iand( set1 % blocks(ablock), & + set2 % blocks(ablock) ) + end do + + end subroutine and_large + + + elemental module subroutine and_not_large(set1, set2) +! +! Sets the bits in SET1 to the bitwise and of the original bits in SET1 +! with the bitwise negation of SET2. SET1 and SET2 must have the same +! number of bits otherwise the result is undefined. +! + type(bitset_large), intent(inout) :: set1 + type(bitset_large), intent(in) :: set2 + + integer(bits_kind) :: ablock + + do ablock = 1, size( set1 % blocks ) + set1 % blocks(ablock) = & + iand( set1 % blocks(ablock), not( set2 % blocks(ablock) ) ) + end do + + end subroutine and_not_large + + + elemental module function any_large(self) result(any) +! Returns .TRUE. if any bit in SELF is 1, .FALSE. otherwise. + logical :: any + class(bitset_large), intent(in) :: self + + integer(bits_kind) :: ablock + + do ablock = 1, size(self % blocks) + if ( self % blocks(ablock) /= 0 ) then + any = .true. + return + end if + end do + any = .false. + + end function any_large + + + pure module subroutine assign_large( set1, set2 ) +! Used to define assignment for bitset_large + type(bitset_large), intent(out) :: set1 + type(bitset_large), intent(in) :: set2 + + set1 % num_bits = set2 % num_bits + allocate( set1 % blocks( size( set2 % blocks, kind=bits_kind ) ) ) + set1 % blocks(:) = set2 % blocks(:) + + end subroutine assign_large + + + pure module subroutine assign_log8_large( self, logical_vector ) +! Used to define assignment from an array of type logical for bitset_large + type(bitset_large), intent(out) :: self + logical(int8), intent(in) :: logical_vector(:) + + integer(bits_kind) :: blocks + integer(bits_kind) :: log_size + integer(bits_kind) :: index + + log_size = size( logical_vector, 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 + + do index=0, log_size-1 + if ( logical_vector(index+1) ) then + call self % set( index ) + end if + end do + + end subroutine assign_log8_large + + + pure module subroutine assign_log16_large( self, logical_vector ) +! Used to define assignment from an array of type logical for bitset_large + type(bitset_large), intent(out) :: self + logical(int16), intent(in) :: logical_vector(:) + + integer(bits_kind) :: blocks + integer(bits_kind) :: log_size + integer(bits_kind) :: index + + log_size = size( logical_vector, 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 + + do index=0, log_size-1 + if ( logical_vector(index+1) ) then + call self % set( index ) + end if + end do + + end subroutine assign_log16_large + + + pure module subroutine assign_log32_large( self, logical_vector ) +! Used to define assignment from an array of type logical for bitset_large + type(bitset_large), intent(out) :: self + logical(int32), intent(in) :: logical_vector(:) + + integer(bits_kind) :: blocks + integer(bits_kind) :: log_size + integer(bits_kind) :: index + + log_size = size( logical_vector, 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 + + do index=0, log_size-1 + if ( logical_vector(index+1) ) then + call self % set( index ) + end if + end do + + end subroutine assign_log32_large + + + pure module subroutine assign_log64_large( self, logical_vector ) +! Used to define assignment from an array of type logical for bitset_large + type(bitset_large), intent(out) :: self + logical(int64), intent(in) :: logical_vector(:) + + integer(bits_kind) :: blocks + integer(bits_kind) :: log_size + integer(bits_kind) :: index + + log_size = size( logical_vector, 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 + + do index=0, log_size-1 + if ( logical_vector(index+1) ) then + call self % set( index ) + end if + end do + + end subroutine assign_log64_large + + + pure module subroutine log8_assign_large( logical_vector, set ) +! Used to define assignment to an array of type logical for bitset_large + logical(int8), intent(out), allocatable :: logical_vector(:) + type(bitset_large), intent(in) :: set + + integer(bits_kind) :: index + + allocate( logical_vector( set % num_bits ) ) + do index=0, set % num_bits-1 + if ( set % value( index ) == 1 ) then + logical_vector(index+1) = .true. + else + logical_vector(index+1) = .false. + end if + end do + + end subroutine log8_assign_large + + + pure module subroutine log16_assign_large( logical_vector, set ) +! Used to define assignment to an array of type logical for bitset_large + logical(int16), intent(out), allocatable :: logical_vector(:) + type(bitset_large), intent(in) :: set + + integer(bits_kind) :: index + + allocate( logical_vector( set % num_bits ) ) + do index=0, set % num_bits-1 + if ( set % value( index ) == 1 ) then + logical_vector(index+1) = .true. + else + logical_vector(index+1) = .false. + end if + end do + + end subroutine log16_assign_large + + + pure module subroutine log32_assign_large( logical_vector, set ) +! Used to define assignment to an array of type logical for bitset_large + logical(int32), intent(out), allocatable :: logical_vector(:) + type(bitset_large), intent(in) :: set + + integer(bits_kind) :: index + + allocate( logical_vector( set % num_bits ) ) + do index=0, set % num_bits-1 + if ( set % value( index ) == 1 ) then + logical_vector(index+1) = .true. + else + logical_vector(index+1) = .false. + end if + end do + + end subroutine log32_assign_large + + + pure module subroutine log64_assign_large( logical_vector, set ) +! Used to define assignment to an array of type logical for bitset_large + logical(int64), intent(out), allocatable :: logical_vector(:) + type(bitset_large), intent(in) :: set + + integer(bits_kind) :: index + + allocate( logical_vector( set % num_bits ) ) + do index=0, set % num_bits-1 + if ( set % value( index ) == 1 ) then + logical_vector(index+1) = .true. + else + logical_vector(index+1) = .false. + end if + end do + + end subroutine log64_assign_large + + + elemental module function bit_count_large(self) result(bit_count) +! Returns the number of non-zero bits in SELF. + integer(bits_kind) :: bit_count + class(bitset_large), intent(in) :: self + + integer(bits_kind) :: ablock, pos + + bit_count = 0 + do ablock = 1, size(self % blocks) - 1 + do pos = 0, block_size-1 + if ( btest( self % blocks(ablock), pos ) ) & + bit_count = bit_count + 1 + end do + + end do + + do pos = 0, self % num_bits - (ablock-1)*block_size - 1 + if ( btest( self % blocks(ablock), pos ) ) bit_count = bit_count + 1 + end do + + end function bit_count_large + + + elemental module subroutine clear_bit_large(self, pos) +! +! Sets to zero the POS position in SELF. If POS is less than zero or +! greater than BITS(SELF)-1 it is ignored. +! + class(bitset_large), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + + integer :: clear_block, block_bit + + if ( pos < 0 .OR. (pos > self % num_bits-1) ) return + clear_block = pos / block_size + 1 + block_bit = pos - (clear_block - 1) * block_size + self % blocks(clear_block) = & + ibclr( self % blocks(clear_block), block_bit ) + + end subroutine clear_bit_large + + + pure module subroutine clear_range_large(self, start_pos, stop_pos) +! +! Sets to zero all bits from the START_POS to STOP_POS positions in SELF. +! If STOP_POS < START_POS then no bits are modified. Positions outside +! the range 0 to BITS(SELF)-1 are ignored. +! + class(bitset_large), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + + integer(bits_kind) :: bit, ablock, first_block, last_block, & + true_first, true_last + + true_first = max( 0, start_pos ) + true_last = min( self % num_bits-1, stop_pos ) + if ( true_last < true_first ) return + + first_block = true_first / block_size + 1 + last_block = true_last / block_size + 1 + if ( first_block == last_block ) then +! TRUE_FIRST and TRUE_LAST are in the same block + call mvbits( all_zeros, & + true_first - (first_block-1)*block_size, & + true_last - true_first + 1, & + self % blocks(first_block), & + true_first - (first_block-1)*block_size ) + return + end if + +! Do "partial" black containing FIRST + bit = true_first - (first_block-1)*block_size + call mvbits( all_zeros, & + bit, & + block_size - bit, & + self % blocks(first_block), & + bit ) + +! Do "partial" black containing LAST + bit = true_last - (last_block-1)*block_size + call mvbits( all_zeros, & + 0, & + bit+1, & + self % blocks(last_block), & + 0 ) + +! Do intermediate blocks + do ablock = first_block+1, last_block-1 + self % blocks(ablock) = all_zeros + end do + + end subroutine clear_range_large + + + elemental module function eqv_large(set1, set2) result(eqv) +! +! Returns .TRUE. if all bits in SET1 and SET2 have the same value, +! .FALSE. otherwise. The sets must have the same number of bits +! otherwise the results are undefined. +! + logical :: eqv + type(bitset_large), intent(in) :: set1, set2 + + integer(bits_kind) :: block, common_blocks + + eqv = .false. + common_blocks = size(set1 % blocks) + do block = 1, common_blocks + if ( set1 % blocks(block) /= set2 % blocks(block) ) return + end do + eqv = .true. + + end function eqv_large + + + module subroutine extract_large(new, old, start_pos, stop_pos, status) +! Creates a new bitset, NEW, from a range, START_POS to STOP_POS, in bitset +! OLD. If START_POS is greater than STOP_POS the new bitset is empty. +! If START_POS is less than zero or STOP_POS is greater than BITS(OLD)-1 +! then if STATUS is present it has the value INDEX_INVALID_ERROR, +! otherwise processing stops with an informative message. + type(bitset_large), intent(out) :: new + type(bitset_large), intent(in) :: old + integer(bits_kind), intent(in) :: start_pos, stop_pos + integer, intent(out), optional :: status + + integer(bits_kind) :: bits, blocks, ex_block, i, j, k, old_block + character(*), parameter :: procedure = 'EXTRACT' + + if ( start_pos < 0 ) go to 999 + if ( stop_pos >= old % num_bits ) go to 998 + bits = stop_pos - start_pos + 1 + + if ( bits <= 0 ) then + new % num_bits = 0 + allocate( new % blocks(0) ) + return + end if + + blocks = ((bits-1) / block_size) + 1 + + new % num_bits = bits + allocate( new % blocks(blocks) ) + new % blocks(:) = 0 + + do i=0, bits-1 + ex_block = i / block_size + 1 + j = i - (ex_block-1) * block_size + old_block = (start_pos + i) / block_size + 1 + k = (start_pos + i) - (old_block-1) * block_size + if ( btest( old % blocks(old_block), k ) ) then + new % blocks(ex_block) = ibset(new % blocks(ex_block), j) + end if + end do + + if ( present(status) ) status = success + + return + +998 if ( present(status) ) then + status = index_invalid_error + return + else + error stop module_name // ' % ' // procedure // ' had a ' // & + 'STOP_POS greater than BITS(OLD)-1.' + end if + +999 if ( present(status) ) then + status = index_invalid_error + return + else + error stop module_name // ' % ' // procedure // ' had a ' // & + 'START_POS less than 0.' + end if + + end subroutine extract_large + + + elemental module subroutine flip_bit_large(self, pos) +! +! Flips the value at the POS position in SELF, provided the position is +! valid. If POS is less than 0 or greater than BITS(SELF)-1, no value is +! changed. +! + class(bitset_large), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + + integer :: flip_block, block_bit + + if ( pos < 0 .OR. pos > self % num_bits-1 ) return + + flip_block = pos / block_size + 1 + block_bit = pos - (flip_block - 1) * block_size + if ( btest( self % blocks(flip_block), block_bit ) ) then + self % blocks(flip_block) = ibclr( self % blocks(flip_block), & + block_bit ) + else + self % blocks(flip_block) = ibset( self % blocks(flip_block), & + block_bit ) + end if + + end subroutine flip_bit_large + + + pure module subroutine flip_range_large(self, start_pos, stop_pos) +! +! Flips all valid bits from the START_POS to the STOP_POS positions in +! SELF. If STOP_POS < START_POS no bits are flipped. Positions less than +! 0 or greater than BITS(SELF)-1 are ignored. +! + class(bitset_large), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + + integer(bits_kind) :: bit, ablock, end_bit, first_block, last_block, & + start_bit + + start_bit = max( 0, start_pos ) + end_bit = min( stop_pos , self % num_bits-1 ) + if ( end_bit < start_bit ) return + + first_block = start_bit / block_size + 1 + last_block = end_bit / block_size + 1 + if (first_block == last_block) then +! FIRST and LAST are in the same block + call mvbits( not(self % blocks(first_block)), & + start_bit - (first_block-1)*block_size, & + end_bit - start_bit + 1, & + self % blocks(first_block), & + start_bit - (first_block-1)*block_size ) + return + end if + +! Do "partial" black containing FIRST + bit = start_bit - (first_block-1)*block_size + call mvbits( not(self % blocks(first_block) ), & + bit, & + block_size - bit, & + self % blocks(first_block), & + bit ) + +! Do "partial" black containing LAST + bit = end_bit - (last_block-1)*block_size + call mvbits( not( self % blocks(last_block) ), & + 0, & + bit+1, & + self % blocks(last_block), & + 0 ) + +! Do remaining blocks + do ablock = first_block+1, last_block-1 + self % blocks(ablock) = not( self % blocks(ablock) ) + end do + + end subroutine flip_range_large + + module subroutine from_string_large(self, string, status) +! Initializes the bitset SELF treating STRING as a binary literal +! STATUS may have the values SUCCESS, ALLOC_FAULT, +! ARRAY_SIZE_INVALID_ERROR, or CHAR_STRING_INVALID. + class(bitset_large), intent(out) :: self + character(*), intent(in) :: string + integer, intent(out), optional :: status + + character(*), parameter :: procedure = 'FROM_STRING' + integer(bits_kind) :: bit + integer(int64) :: bits + character(1) :: char + + bits = len(string, kind=int64) + if ( bits > huge(0_bits_kind) ) go to 998 + + call init_zero_large( self, int(bits, kind=bits_kind), status ) + + if ( present(status) ) then + if ( status /= success ) return + end if + + do bit = 1_bits_kind, bits + char = string(bit:bit) + if ( char == '0' ) then + call self % clear( int(bits, kind=bits_kind)-bit ) + else if ( char == '1' ) then + call self % set( int(bits, kind=bits_kind)-bit ) + else + go to 999 + end if + end do + + if ( present(status) ) status = success + + return + +998 if ( present(status) ) then + status = array_size_invalid_error + return + else + error stop module_name // ' % ' // procedure // ' STRING ' // & + 'was too long for a BITSET_64 SELF.' + end if + +999 if ( present(status) ) then + status = char_string_invalid_error + return + else + error stop module_name // ' % ' // procedure // ' STRING ' // & + 'had a character other than "0" or "1",' + end if + + end subroutine from_string_large + + + elemental module function ge_large(set1, set2) result(ge) +! +! Returns .TRUE. if the bits in SET1 and SET2 are the same or the +! highest order different bit is set to 1 in SET1 and to 0 in set2. +! .FALSE. otherwise. The sets must have the same number of bits +! otherwise the results are undefined. +! + logical :: ge + type(bitset_large), intent(in) :: set1, set2 + + integer(bits_kind) :: ablock + + do ablock = size(set1 % blocks), 1, -1 + if ( set1 % blocks(ablock) == set2 % blocks(ablock) ) then + cycle + else if ( bgt(set1 % blocks(ablock), set2 % blocks(ablock) ) ) then + ge = .true. + return + else + ge = .false. + return + end if + end do + ge = .true. + + end function ge_large + + + elemental module function gt_large(set1, set2) result(gt) +! +! Returns .TRUE. if the bits in SET1 and SET2 differ and the +! highest order different bit is set to 1 in SET1 and to 0 in set2. +! .FALSE. otherwise. The sets must have the same number of bits +! otherwise the results are undefined. +! + logical :: gt + type(bitset_large), intent(in) :: set1, set2 + + integer(bits_kind) :: ablock + + do ablock = size(set1 % blocks), 1, -1 + if ( set1 % blocks(ablock) == set2 % blocks(ablock) ) then + cycle + else if ( bgt( set1 % blocks(ablock), set2 % blocks(ablock) ) ) then + gt = .true. + return + else + gt = .false. + return + end if + end do + gt = .false. + + end function gt_large + + + module subroutine init_zero_large(self, bits, status) +! +! Creates the bitset, SELF, of size BITS, with all bits initialized to +! zero. BITS must be non-negative. If an error occurs and STATUS is +! absent then processing stops with an informative stop code. STATUS +! has a default value of SUCCESS. If an error occurs it has the value +! ARRAY_SIZE_INVALID_ERROR if BITS is either negative larger than 64 +! if SELF is of type BITSET_64, or the value ALLOC_FAULT if it failed +! during allocation of memory for SELF. +! + class(bitset_large), intent(out) :: self + integer(bits_kind), intent(in) :: bits + integer, intent(out), optional :: status + + character(len=120) :: message + character(*), parameter :: procedure = "INIT" + integer :: blocks, ierr + + message = '' + if ( bits < 0 ) go to 999 + + if (bits == 0) then + self % num_bits = 0 + allocate( self % blocks(0), stat=ierr, errmsg=message ) + if (ierr /= 0) go to 998 + return + else + blocks = ((bits-1) / block_size) + 1 + end if + + self % num_bits = bits + allocate( self % blocks(blocks), stat=ierr, errmsg=message ) + if (ierr /= 0) go to 998 + + self % blocks(:) = all_zeros + + if ( present(status) ) status = success + + return + +998 if ( present(status) ) then + status = alloc_fault + return + else + error stop module_name // ' % ' // procedure // ' allocation ' // & + 'failure for SELF.' + end if + +999 if ( present(status) ) then + status = array_size_invalid_error + return + else + error stop module_name // ' %' // procedure // ' BITS had ' // & + 'a negative value.' + end if + + end subroutine init_zero_large + + + module subroutine input_large(self, unit, status) +! +! Reads the components of the bitset, SELF, from the unformatted I/O +! unit, UNIT, assuming that the components were written using OUTPUT. +! If an error occurs and STATUS is absent then processing stops with +! an informative stop code. STATUS has a default value of SUCCESS. +! If an error occurs it has the value READ_FAILURE if it failed +! during the reads from UNIT or the value ALLOC_FAULT if it failed +! during allocation of memory for SELF, or the value +! ARRAY_SIZE_INVALID_ERROR if the BITS(SELF) in UNIT is less than 0 +! or greater than 64 for a BITSET_64 input. +! + class(bitset_large), intent(out) :: self + integer, intent(in) :: unit + integer, intent(out), optional :: status + + integer(bits_kind) :: bits + integer :: ierr + character(len=120) :: message + character(*), parameter :: procedure = 'INPUT' + integer :: stat + + read(unit, iostat=ierr, iomsg=message) bits + if (ierr /= 0) go to 999 + if ( bits < 0 ) go to 997 + + call self % init(bits, stat) + if (stat /= success) go to 998 + + if (bits < 1) return + + read(unit, iostat=ierr, iomsg=message) self % blocks(:) + if (ierr /= 0) go to 999 + + if ( present(status) ) status = success + + return + +997 if ( present(status) ) then + status = array_size_invalid_error + return + else + error stop module_name // ' %' // procedure // ' BITS in ' // & + 'UNIT had a negative value.' + end if + +998 if ( present(status) ) then + status = alloc_fault + return + else + error stop module_name // ' % ' // procedure // ' had an ' // & + 'alloction fault for SELF.' + end if + +999 if ( present(status) ) then + status = read_failure + return + else + error stop module_name // ' % ' // procedure // ' had a ' // & + 'failure on a READ statement for UNIT.' + end if + + end subroutine input_large + + + elemental module function le_large(set1, set2) result(le) +! +! Returns .TRUE. if the bits in SET1 and SET2 are the same or the +! highest order different bit is set to 0 in SET1 and to 1 in set2. +! .FALSE. otherwise. The sets must have the same number of bits +! otherwise the results are undefined. +! + logical :: le + type(bitset_large), intent(in) :: set1, set2 + + integer(bits_kind) :: ablock + + do ablock = size(set1 % blocks), 1, -1 + if ( set1 % blocks(ablock) == set2 % blocks(ablock) ) then + cycle + else if ( blt( set1 % blocks(ablock), set2 % blocks(ablock) ) ) then + le = .true. + return + else + le = .false. + return + end if + end do + + le = .true. + + end function le_large + + + elemental module function lt_large(set1, set2) result(lt) +! +! Returns .TRUE. if the bits in SET1 and SET2 differ and the +! highest order different bit is set to 0 in SET1 and to 1 in set2. +! .FALSE. otherwise. The sets must have the same number of bits +! otherwise the results are undefined. +! + logical :: lt + type(bitset_large), intent(in) :: set1, set2 + + integer(bits_kind) :: ablock + + do ablock = size(set1 % blocks), 1, -1 + if ( set1 % blocks(ablock) == set2 % blocks(ablock) ) then + cycle + else if ( blt( set1 % blocks(ablock), set2 % blocks(ablock) ) ) then + lt = .true. + return + else + lt = .false. + return + end if + end do + lt = .false. + + end function lt_large + + + elemental module function neqv_large(set1, set2) result(neqv) +! +! Returns .TRUE. if any bits in SET1 and SET2 differ in value, +! .FALSE. otherwise. The sets must have the same number of bits +! otherwise the results are undefined. +! + logical :: neqv + type(bitset_large), intent(in) :: set1, set2 + + integer(bits_kind) :: block + + neqv = .true. + do block = 1, size(set1 % blocks) + if ( set1 % blocks(block) /= set2 % blocks(block) ) return + end do + neqv = .false. + + end function neqv_large + + + elemental module function none_large(self) result(none) +! +! Returns .TRUE. if none of the bits in SELF have the value 1. +! + logical :: none + class(bitset_large), intent(in) :: self + + integer :: block + + none = .true. + do block = 1, size(self % blocks) + if (self % blocks(block) /= 0) then + none = .false. + return + end if + end do + + end function none_large + + + elemental module subroutine not_large(self) +! +! Sets the bits in SELF to their logical complement +! + class(bitset_large), intent(inout) :: self + + integer(bits_kind) :: bit, full_blocks, block, remaining_bits + + if ( self % num_bits == 0 ) return + full_blocks = self % num_bits / block_size + do block = 1, full_blocks + self % blocks(block) = not( self % blocks(block) ) + end do + remaining_bits = self % num_bits - full_blocks * block_size + + do bit=0, remaining_bits - 1 + if ( btest( self % blocks( block ), bit ) ) then + self % blocks( block ) = ibclr( self % blocks(block), bit ) + else + self % blocks( block ) = ibset( self % blocks(block), bit ) + end if + end do + + end subroutine not_large + + + elemental module subroutine or_large(set1, set2) +! +! Sets the bits in SET1 to the bitwise OR of the original bits in SET1 +! and SET2. SET1 and SET2 must have the same number of bits otherwise +! the result is undefined. +! + type(bitset_large), intent(inout) :: set1 + type(bitset_large), intent(in) :: set2 + + integer(bits_kind) :: ablock + + do ablock = 1, size( set1 % blocks ) + set1 % blocks(ablock) = ior( set1 % blocks(ablock), & + set2 % blocks(ablock) ) + end do + + end subroutine or_large + + + module subroutine output_large(self, unit, status) +! +! Writes the components of the bitset, SELF, to the unformatted I/O +! unit, UNIT, in a unformatted sequence compatible with INPUT. If +! STATUS is absent an error results in an error stop with an +! informative stop code. If STATUS is present it has the default +! value of SUCCESS, or the value WRITE_FAILURE if the write failed. +! + class(bitset_large), intent(in) :: self + integer, intent(in) :: unit + integer, intent(out), optional :: status + + integer :: ierr + character(len=120) :: message + character(*), parameter :: procedure = "OUTPUT" + + write(unit, iostat=ierr, iomsg=message) self % num_bits + if (ierr /= 0) go to 999 + + if (self % num_bits < 1) return + write(unit, iostat=ierr, iomsg=message) self % blocks(:) + if (ierr /= 0) go to 999 + + return + +999 if ( present(status) ) then + status = write_failure + return + else + error stop module_name // ' % ' // procedure // ' had a ' // & + 'failure in the write to UNIT.' + end if + + end subroutine output_large + + + module subroutine read_bitset_string_large(self, string, status) +! +! Uses the bitset literal in the default character STRING, to define +! the bitset, SELF. The literal may be preceded by an an arbitrary +! sequence of blank characters. If STATUS is absent an error results +! in an error stop with an informative stop code. If STATUS +! is present it has the default value of SUCCESS, the value +! INTEGER_OVERFLOW_ERROR if the bitset literal has a BITS(SELF) value +! too large to be represented, the value ALLOC_FAULT if allocation of +! memory for SELF failed, or CHAR_STRING_INVALID_ERROR if the bitset +! literal has an invalid character, or ARRAY_SIZE_INVALID_ERROR if +! BITS(SELF) in STRING is greater than 64 for a BITSET_64, or +! CHAR_STRING_TOO_SMALL_ERROR if the string ends before all the bits +! are read. +! + class(bitset_large), intent(out) :: self + character(len=*), intent(in) :: string + integer, intent(out), optional :: status + + integer(bits_kind) :: bit, bits + integer(int64) :: bits_needed + integer(bits_kind) :: digits, pos + character(*), parameter :: procedure = "READ_BITSET" + integer :: stat + + pos = 1 + find_start: do pos=1, len(string) + if ( string(pos:pos) /= ' ' ) exit + end do find_start + + if ( pos > len(string) - 8 ) go to 999 + + if ( string(pos:pos) /= 's' .AND. string(pos:pos) /= 'S' ) go to 999 + + pos = pos + 1 + bits = 0 + digits = 0 + + do + select case( iachar( string(pos:pos) ) ) + case(ia0:ia9) + digits = digits + 1 + if ( digits == 10 .AND. bits > 2_bits_kind**30/5 ) go to 996 +!! May not be quite right + if ( digits > 10 ) go to 996 + bits = bits*10 + iachar( string(pos:pos) ) - ia0 + if ( bits < 0 ) go to 996 + case(iachar('b'), iachar('B')) + go to 100 + case default + go to 999 + end select + + pos = pos + 1 + end do + +100 if ( bits + pos > len(string) ) go to 994 + call self % init( bits, stat ) + if (stat /= success) go to 998 + + pos = pos + 1 + bit = bits - 1 + do + if ( string(pos:pos) == '0' ) then + call self % clear( bit ) + else if ( string(pos:pos) == '1' ) then + call self % set( bit ) + else + go to 999 + end if + pos = pos + 1 + bit = bit - 1 + if ( bit < 0 ) exit + end do + + if ( present(status) ) status = success + + return + +994 if ( present(status) ) then + status = char_string_too_small_error + return + else + error stop module_name // ' % ' // procedure // ' STRING ' // & + 'was too small for the BITS specified by the STRING.' + end if + +996 if ( present(status) ) then + status = integer_overflow_error + return + else + error stop module_name // ' % ' // procedure // ' failed on ' // & + 'integer overflow in reading size of bitset literal from ' // & + 'UNIT.' + end if + +998 if ( present(status) ) then + status = alloc_fault + return + else + error stop module_name // ' % ' // procedure // ' failed in ' // & + 'allocating memory for the bitset.' + end if + +999 if ( present(status) ) then + status = char_string_invalid_error + return + else + error stop module_name // ' % ' // procedure // ' failed due ' // & + 'to an invalid character in STRING.' + end if + + end subroutine read_bitset_string_large + + + module subroutine read_bitset_unit_large(self, unit, advance, status) +! +! Uses the bitset literal at the current position in the formatted +! file with I/O unit, UNIT, to define the bitset, SELF. The literal +! may be preceded by an an arbitrary sequence of blank characters. +! If ADVANCE is present it must be either 'YES' or 'NO'. If absent +! it has the default value of 'YES' to determine whether advancing +! I/O occurs. If STATUS is absent an error results in an error stop +! with an informative stop code. If STATUS is present it has the +! default value of SUCCESS, the value INTEGER_OVERFLOW_ERROR if the +! bitset literal has a BITS(SELF) value too large to be +! represented, the value READ_FAILURE if a READ statement fails, +! EOF_FAILURE if a READ statement reach an end-of-file before +! completing the read of the bitset literal, or the value +! CHAR_STRING_INVALID_ERROR if the read of the bitset literal found +! an invalid character, or ARRAY_SIZE_INVALID_ERROR if BITS(SELF) +! in STRING is greater than 64 for a BITSET_64. +! + class(bitset_large), intent(out) :: self + integer, intent(in) :: unit + character(*), intent(in), optional :: advance + integer, intent(out), optional :: status + + integer(bits_kind) :: bit, bits, digits + integer :: ierr + character(len=128) :: message + character(len=:), allocatable :: literal + integer(bits_kind) :: pos + character(*), parameter :: procedure = "READ_BITSET" + integer :: stat + character(len=1) :: char, quote + + do + read( unit, & + advance='NO', & + FMT='(A1)', & + err=997, & + end=998, & + iostat=ierr, & + iomsg=message ) char + select case( char ) + case( ' ' ) + cycle + case( 's', 'S' ) + exit + case default + go to 999 + end select + end do + + bits = 0 + digits = 0 + do + read( unit, & + advance='NO', & + FMT='(A1)', & + err=998, & + end=999, & + iostat=ierr, & + iomsg=message ) char + if ( char == 'b' .or. char == 'B' ) exit + select case( char ) + case( '0', '1', '2', '3', '4', '5', '6', '7', '8', '9' ) + digits = digits + 1 + if ( digits == 10 .AND. bits > 2_bits_kind**30/5 ) go to 996 +!! May not be quite right + if ( digits > 10 ) go to 996 + bits = 10*bits + iachar(char) - iachar('0') + if ( bits < 0 ) go to 996 + case default + go to 999 + end select + end do + + if ( bits < 0 .OR. digits == 0 .OR. digits > 10 ) go to 999 + + call self % init( bits ) + do bit = 1, bits-1 + read( unit, & + advance='NO', & + FMT='(A1)', & + err=997, & + end=998, & + iostat=ierr, & + iomsg=message ) char + if ( char == '0' ) then + call self % clear( bits-bit ) + else if ( char == '1' ) then + call self % set( bits-bit ) + else + go to 999 + end if + end do + + if ( present(advance) ) then + read( unit, & + advance=advance, & + FMT='(A1)', & + err=997, & + end=998, & + iostat=ierr, & + iomsg=message ) char + else + read( unit, & + advance='YES', & + FMT='(A1)', & + err=997, & + end=998, & + iostat=ierr, & + iomsg=message ) char + end if + + if ( char == '0' ) then + call self % clear( bits-bit ) + else if ( char == '1' ) then + call self % set( bits-bit ) + else + go to 999 + end if + + if ( present(status) ) status = success + + return + +996 if ( present(status) ) then + status = integer_overflow_error + return + else + error stop module_name // ' % ' // procedure // ' failed on ' // & + 'integer overflow in reading size of bitset literal from ' // & + 'UNIT.' + end if + + +997 if ( present(status) ) then + status = read_failure + return + else + error stop module_name // ' % ' // procedure // ' failed on ' // & + 'read of UNIT.' + end if + +998 if ( present(status) ) then + status = eof_failure + return + else + error stop module_name // ' % ' // procedure // ' reached ' // & + 'End of File of UNIT before finding a bitset literal.' + end if + +999 if ( present(status) ) then + status = char_string_invalid_error + return + else + error stop module_name // ' % ' // procedure // ' found an ' // & + 'invalid bitset literal in UNIT.' + end if + + end subroutine read_bitset_unit_large + + + elemental module subroutine set_bit_large(self, pos) +! +! Sets the value at the POS position in SELF, provided the position is +! valid. If the position is less than 0 or greater than BITS(SELF)-1 +! then SELF is unchanged. +! + class(bitset_large), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + + integer(bits_kind) :: set_block, block_bit + + if ( pos < 0 .OR. pos > self % num_bits-1 ) return + + set_block = pos / block_size + 1 + block_bit = pos - (set_block - 1) * block_size + self % blocks(set_block) = ibset( self % blocks(set_block), block_bit ) + + end subroutine set_bit_large + + + pure module subroutine set_range_large(self, start_pos, stop_pos) +! +! Sets all valid bits to 1 from the START_POS to the STOP_POS positions +! in SELF. If STOP_POA < START_POS no bits are changed. Positions outside +! the range 0 to BITS(SELF)-1 are ignored. +! + class(bitset_large), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + + integer(bits_kind) :: bit, ablock, end_bit, first_block, last_block, & + start_bit + + start_bit = max( 0, start_pos ) + end_bit = min( stop_pos, self % num_bits-1 ) + if ( end_bit < start_bit ) return + + first_block = start_bit / block_size + 1 + last_block = end_bit / block_size + 1 + if ( first_block == last_block ) then +! FIRST and LAST are in the same block + call mvbits( all_ones, & + start_bit - (first_block-1)*block_size, & + end_bit - start_bit + 1, & + self % blocks(first_block), & + start_bit - (first_block-1)*block_size ) + return + end if + +! Do "partial" black containing FIRST + bit = start_bit - (first_block-1)*block_size + call mvbits( all_ones, & + bit, & + block_size - bit, & + self % blocks(first_block), & + bit ) + +! Do "partial" black containing LAST + bit = end_bit - (last_block-1)*block_size + call mvbits( all_ones, & + 0, & + bit+1, & + self % blocks(last_block), & + 0 ) + +! Do remaining blocks + do ablock = first_block+1, last_block-1 + self % blocks(ablock) = all_ones + end do + + end subroutine set_range_large + + + elemental module function test_large(self, pos) result(test) +! +! Returns .TRUE. if the POS position is set, .FALSE. otherwise. If POS +! is negative or greater than BITS(SELF) - 1 the result is .FALSE.. +! + logical :: test + class(bitset_large), intent(in) :: self + integer(bits_kind), intent(in) :: pos + + integer(bits_kind) :: bit_block + + if ( pos < 0 .or. pos >= self % num_bits ) then + test = .false. + else + bit_block = pos / block_size + 1 + test = btest( self % blocks(bit_block), & + pos - ( bit_block-1 ) * block_size ) + end if + + end function test_large + + + module subroutine to_string_large(self, string, status) +! +! Represents the value of SELF as a binary literal in STRING +! Status may have the values SUCCESS or ALLOC_FAULT +! + class(bitset_large), intent(in) :: self + character(len=:), allocatable, intent(out) :: string + integer, intent(out), optional :: status + + character(*), parameter :: procedure = 'TO_STRING' + integer(bits_kind) :: bit, bit_count, pos + integer :: stat + + bit_count = self % num_bits + allocate( character(len=bit_count)::string, stat=stat ) + if ( stat > 0 ) go to 999 + do bit=0, bit_count-1 + pos = bit_count - bit + if ( self % test( bit) ) then + string( pos:pos ) = '1' + else + string( pos:pos ) = '0' + end if + end do + + if ( present(status) ) status = success + + return + +999 if ( present(status) ) then + status = alloc_fault + return + else + error stop module_name // ' % ' // procedure // ' allocation ' // & + 'of STRING failed.' + end if + + end subroutine to_string_large + + + elemental module function value_large(self, pos) result(value) +! +! Returns 1 if the POS position is set, 0 otherwise. If POS is negative +! or greater than BITS(SELF) - 1 the result is 0. +! + integer :: value + class(bitset_large), intent(in) :: self + integer(bits_kind), intent(in) :: pos + + integer :: bit_block + + if ( pos < 0 .or. pos >= self % num_bits ) then + value = 0 + else + bit_block = pos / block_size + 1 + if ( btest( self % blocks(bit_block), & + pos - ( bit_block-1 ) * block_size ) ) then + value = 1 + else + value = 0 + end if + end if + + end function value_large + + + module subroutine write_bitset_string_large(self, string, status) +! +! Writes a bitset literal to the allocatable default character STRING, +! representing the individual bit values in the bitset_t, SELF. +! If STATUS is absent an error results in an error stop with an +! informative stop code. If STATUS is present it has the default +! value of SUCCESS, or the value ALLOC_FAULT if allocation of +! the output string failed. +! + class(bitset_large), intent(in) :: self + character(len=:), allocatable, intent(out) :: string + integer, intent(out), optional :: status + + integer(bits_kind) :: bit, & + bit_count, & + count_digits, & + digit, & + digits, & + max_bit, & + pos, & + processed, & + val + integer :: stat + + character(*), parameter :: procedure = 'WRITE_BITSET' + + bit_count = bits(self) + + call digit_count( self % num_bits, count_digits ) + + allocate( character(len=count_digits+bit_count+2)::string, stat=stat ) + if ( stat > 0 ) go to 999 + + write( string, "('S', i0)" ) self % num_bits + + string( count_digits + 2:count_digits + 2 ) = "B" + do bit=0, bit_count-1 + pos = count_digits + 2 + bit_count - bit + if ( self % test( bit) ) then + string( pos:pos ) = '1' + else + string( pos:pos ) = '0' + end if + end do + + if ( present(status) ) status = success + + return + +999 if ( present(status) ) then + status = alloc_fault + return + else + error stop module_name // ' % ' // procedure // ' had a ' // & + 'memory sllocation failure for a string.' + end if + + contains + + subroutine digit_count( bits, digits ) + integer(bits_kind), intent(in) :: bits + integer(bits_kind), intent(out) :: digits + + select case ( bits ) + case ( 0:9 ) + digits = 1 + + case ( 10:99 ) + digits = 2 + + case ( 100:999 ) + digits = 3 + + case ( 1000:9999 ) + digits = 4 + + case ( 10000:99999 ) + digits = 5 + + case ( 100000:999999 ) + digits = 6 + + case ( 1000000:9999999 ) + digits = 7 + + case ( 10000000:99999999 ) + digits = 8 + + case ( 100000000:999999999 ) + digits = 9 + + case ( 1000000000:min(2147483647, huge( self % num_bits ) ) ) + digits = 10 + + case default + error stop module_name // ' % ' // procedure // & + ' internal consistency fault was found.' + + end select + + end subroutine digit_count + + end subroutine write_bitset_string_large + + + module subroutine write_bitset_unit_large(self, unit, advance, status) +! +! Writes a bitset literal to the I/O unit, UNIT, representing the +! individual bit values in the bitset_t, SELF. By default or if +! ADVANCE is present with the value 'YES', advancing output is used. +! If ADVANCE is present with the value 'NO', then the current record +! is not advanced by the write. If STATUS is absent an error results +! in an error stop with an informative stop code. If STATUS is +! present it has the default value of SUCCESS, the value +! ALLOC_FAULT if allocation of the output string failed, or +! WRITE_FAILURE if the WRITE statement outputting the literal failed. +! + class(bitset_large), intent(in) :: self + integer, intent(in) :: unit + character(len=*), intent(in), optional :: advance + integer, intent(out), optional :: status + + integer :: ierr + character(:), allocatable :: string + character(len=120) :: message + character(*), parameter :: procedure = "WRITE_BITSET" + + call self % write_bitset(string, status) + + if ( present(status) ) then + if (status /= success ) return + + end if + + + if ( present( advance ) ) then + write( unit, & + FMT='(A)', & + advance=advance, & + iostat=ierr, & + iomsg=message ) & + string + else + write( unit, & + FMT='(A)', & + advance='YES', & + iostat=ierr, & + iomsg=message ) & + string + end if + if (ierr /= 0) go to 999 + + return + +999 if ( present(status) ) then + status = write_failure + return + else + error stop module_name // ' % ' // procedure // ' had a ' // & + 'failure on a WRITE statement.' + end if + + end subroutine write_bitset_unit_large + + + elemental module subroutine xor_large(set1, set2) +! +! Sets the bits in SET1 to the bitwise XOR of the original bits in SET1 +! and SET2. SET1 and SET2 must have the same number of bits otherwise +! the result is undefined. +! + type(bitset_large), intent(inout) :: set1 + type(bitset_large), intent(in) :: set2 + + integer(bits_kind) :: ablock + + do ablock = 1, size(set1 % blocks) + set1 % blocks(ablock) = ieor( set1 % blocks(ablock), & + set2 % blocks(ablock) ) + end do + + end subroutine xor_large + +end submodule stdlib_bitset_large diff --git a/src/stdlib_bitsets.f90 b/src/stdlib_bitsets.f90 new file mode 100644 index 000000000..96853eeb2 --- /dev/null +++ b/src/stdlib_bitsets.f90 @@ -0,0 +1,2130 @@ +module stdlib_bitsets +!! Implements zero based bitsets of size up to `huge(0_int32)`. +!! The current code uses 64 bit integers to store the bits and uses all 64 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, & + int16, & + int32, & + int64, & + dp => real64 + + implicit none + + private + + integer, parameter :: & + block_size = bit_size(0_block_kind) + + integer(block_kind), private, parameter :: all_zeros = 0_block_kind + integer(block_kind), private, parameter :: all_ones = not(all_zeros) + + character(*), parameter, private :: module_name = "STDLIB_BITSETS" + integer, parameter, private :: & + ia0 = iachar('0'), & + ia9 = iachar('9') + + integer, parameter, public :: success = 0 +!! Error flag indicating no errors + integer, parameter, public :: alloc_fault = 1 +!! Error flag indicating a memory allocation failure + integer, parameter, public :: array_size_invalid_error = 2 +!! error flag indicating an invalid bits value + integer, parameter, public :: char_string_invalid_error = 3 +!! Error flag indicating an invalid character string + integer, parameter, public :: char_string_too_small_error = 4 +!! Error flag indicating a too small character string + integer, parameter, public :: index_invalid_error = 5 +!! Error flag indicating an invalid index + integer, parameter, public :: integer_overflow_error = 6 +!! Error flag indicating integer overflow + integer, parameter, public :: read_failure = 7 +!! Error flag indicating failure of a READ statement + integer, parameter, public :: eof_failure = 8 +!! Error flag indicating unexpected End-of-File on a READ + integer, parameter, public :: write_failure = 9 +!! Error flag indicating a failure on a WRITE statement + + public :: bits_kind +! Public constant + + public :: & + bitset_type, & + bitset_large, & + bitset_64 + +! Public types + + public :: & + assignment(=), & + and, & + and_not, & + bits, & + extract, & + operator(==), & + operator(/=), & + operator(>), & + operator(>=), & + operator(<), & + operator(<=), & + or, & + xor +! Public procedures + + type, abstract :: bitset_type +!! version: experimental +!! +!! Parent type for bitset_64 and bitset_large + private + integer(bits_kind) :: num_bits + + contains + + procedure(all_abstract), deferred, pass(self) :: all + procedure(any_abstract), deferred, pass(self) :: any + procedure(bit_count_abstract), deferred, pass(self) :: bit_count + procedure, pass(self) :: bits + procedure(clear_bit_abstract), deferred, pass(self) :: clear_bit + procedure(clear_range_abstract), deferred, pass(self) :: clear_range + generic :: clear => clear_bit, clear_range + procedure(flip_bit_abstract), deferred, pass(self) :: flip_bit + procedure(flip_range_abstract), deferred, pass(self) :: flip_range + generic :: flip => flip_bit, flip_range + procedure(from_string_abstract), deferred, pass(self) :: from_string + procedure(init_zero_abstract), deferred, pass(self) :: init_zero + generic :: init => init_zero + procedure(input_abstract), deferred, pass(self) :: input + procedure(none_abstract), deferred, pass(self) :: none + procedure(not_abstract), deferred, pass(self) :: not + procedure(output_abstract), deferred, pass(self) :: output + procedure(read_bitset_string_abstract), deferred, pass(self) :: & + read_bitset_string + procedure(read_bitset_unit_abstract), deferred, pass(self) :: & + read_bitset_unit + generic :: read_bitset => read_bitset_string, read_bitset_unit + procedure(set_bit_abstract), deferred, pass(self) :: set_bit + procedure(set_range_abstract), deferred, pass(self) :: set_range + generic :: set => set_bit, set_range + procedure(test_abstract), deferred, pass(self) :: test + procedure(to_string_abstract), deferred, pass(self) :: to_string + procedure(value_abstract), deferred, pass(self) :: value + procedure(write_bitset_string_abstract), deferred, pass(self) :: & + write_bitset_string + procedure(write_bitset_unit_abstract), deferred, pass(self) :: & + write_bitset_unit + generic :: write_bitset => write_bitset_string, write_bitset_unit + + end type bitset_type + + + abstract interface + + elemental function all_abstract( self ) result(all) +!! Version: experimental +!! +!! Returns `.true.` if all bits in `self` are 1, `.false`. otherwise. +!! +!!#### Example +!! +!! ```fortran +!! program demo_all +!! use stdlib_bitsets +!! character(*), parameter :: & +!! bits_all = '111111111111111111111111111111111' +!! type(bitset_64) :: set0 +!! call set0 % from_string( bits_all ) +!! if ( bits(set0) /= 33 ) then +!! error stop "FROM_STRING failed to interpret " // & +!! 'BITS_ALL's size properly." +!! else if ( .not. set0 % all() ) then +!! error stop "FROM_STRING failed to interpret" // & +!! "BITS_ALL's value properly." +!! else +!! write(*,*) "FROM_STRING transferred BITS_ALL properly" // & +!! " into set0." +!! end if +!! end program demo_all +!! + import :: bitset_type + logical :: all + class(bitset_type), intent(in) :: self + end function all_abstract + + elemental function any_abstract(self) result(any) +!! Version: experimental +!! +!! Returns `.true.` if any bit in `self` is 1, `.false.` otherwise. +!! +!!#### Example +!! +!! ```fortran +!! program demo_any +!! use stdlib_bitsets +!! character(*), parameter :: & +!! bits_0 = '0000000000000000000' +!! type(bitset_64) :: set0 +!! call set0 % from_string( bits_0 ) +!! if ( .not. set0 % any() ) then +!! write(*,*) "FROM_STRING interpreted " // & +!! "BITS_0's value properly." +!! end if +!! call set0 % set(5) +!! if ( set0 % any() ) then +!! write(*,*) "ANY interpreted SET0's value properly." +!! end if +!! end program demo_any +!! + import :: bitset_type + logical :: any + class(bitset_type), intent(in) :: self + end function any_abstract + + elemental function bit_count_abstract(self) result(bit_count) +!! Version: experimental +!! +!! Returns the number of non-zero bits in `self`. +!! +!!#### Example +!! +!! ```fortran +!! program demo_bit_count +!! use stdlib_bitsets +!! character(*), parameter :: & +!! bits_0 = '0000000000000000000' +!! type(bitset_64) :: set0 +!! call set0 % from_string( bits_0 ) +!! if ( set0 % bit_count() == 0 ) then +!! write(*,*) "FROM_STRING interpreted " // & +!! "BITS_0's value properly." +!! end if +!! call set0 % set(5) +!! if ( set0 % bit_count() == 1 ) then +!! write(*,*) "BIT_COUNT interpreted SET0's value properly." +!! end if +!! end program demo_bit_count +!! + import :: bitset_type, bits_kind + integer(bits_kind) :: bit_count + class(bitset_type), intent(in) :: self + end function bit_count_abstract + + elemental subroutine clear_bit_abstract(self, pos) +!! Version: experimental +!! +!! Sets to zero the `pos` position in `self`. If `pos` is less than zero or +!! greater than `bits(self)-1` it is ignored. +!! +!!#### Example +!! +!! ```fortran +!! program demo_clear +!! use stdlib_bitsets +!! type(bitset_large) :: set0 +!! call set0 % init(166) +!! call set0 % not() +!! if ( set0 % all() ) write(*,*) 'SET0 is properly initialized.' +!! call set0 % clear(165) +!! if ( .not. set0 % test(165) ) write(*,*) 'Bit 165 is cleared.' +!! call set0 % clear(0,164) +!! if ( set0 % none() ) write(*,*) 'All bits are cleared.' +!! end program demo_clear +!! + import :: bitset_type, bits_kind + class(bitset_type), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + end subroutine clear_bit_abstract + + pure subroutine clear_range_abstract(self, start_pos, stop_pos) +!! Version: experimental +!! +!! Sets to zero all bits from the `start_pos` to `stop_pos` positions in `set`. +!! If `stop_pos < start_pos` then no bits are modified. Positions outside +!! the range 0 to `bits(self)-1` are ignored. + import :: bitset_type, bits_kind + class(bitset_type), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + end subroutine clear_range_abstract + + elemental subroutine flip_bit_abstract(self, pos) +!! Version: experimental +!! +!! Flips the value at the `pos` position in `self`, provided the position is +!! valid. If `pos` is less than 0 or greater than `bits(self)-1`, no value is +!! changed. +!! +!!#### Example +!! +!! ```fortran +!! program demo_flip +!! use stdlib_bitsets +!! type(bitset_large) :: set0 +!! call set0 % init(166) +!! if ( set0 % none() ) write(*,*) 'SET0 is properly initialized.' +!! call set0 % flip(165) +!! if ( set0 % test(165) ) write(*,*) 'Bit 165 is flipped.' +!! call set0 % flip(0,164) +!! if ( set0 % all() ) write(*,*) 'All bits are flipped.' +!! end program demo_flip +!! + import :: bitset_type, bits_kind + class(bitset_type), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + end subroutine flip_bit_abstract + + pure subroutine flip_range_abstract(self, start_pos, stop_pos) +!! Version: experimental +!! +!! Flips all valid bits from the `start_pos` to the `stop_pos` positions in +!! `self`. If `stop_pos < start_pos` no bits are flipped. Positions less than +!! 0 or greater than `bits(self)-1` are ignored. + import :: bitset_type, bits_kind + class(bitset_type), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + end subroutine flip_range_abstract + + subroutine from_string_abstract(self, string, status) +!! Version: experimental +!! +!! Initializes the bitset `self` treating `string` as a binary literal +!! `status` may have the values `success`, `alloc_fault`, +!! `array_size_invalid_error`, or `char_string_invalid`. +!! +!!#### Example +!! +!! ```fortran +!! program demo_from_string +!! use stdlib_bitsets +!! character(*), parameter :: & +!! bits_all = '111111111111111111111111111111111' +!! type(bitset_64) :: set0 +!! call set0 % from_string( bits_all ) +!! if ( bits(set0) /= 33 ) then +!! error stop "FROM_STRING failed to interpret " // & +!! 'BITS_ALL's size properly." +!! else if ( .not. set0 % all() ) then +!! error stop "FROM_STRING failed to interpret" // & +!! "BITS_ALL's value properly." +!! else +!! write(*,*) "FROM_STRING transferred BITS_ALL properly" // & +!! " into set0." +!! end if +!! end program demo_from_string +!! + import :: bitset_type + class(bitset_type), intent(out) :: self + character(*), intent(in) :: string + integer, intent(out), optional :: status + end subroutine from_string_abstract + + subroutine init_zero_abstract(self, bits, status) +!! Creates the bitset, `self`, of size `bits`, with all bits initialized to +!! zero. `bits` must be non-negative. If an error occurs and `status` is +!! absent then processing stops with an informative stop code. `status` +!! has a default value of `success`. If an error occurs it has the value +!! `array_size_invalid_error` if `bits` is either negative or larger than 64 +!! if `self` is class `bitset_64`, or the value `alloc_fault` if it failed +!! during allocation of memory for `self`. +!! +!!#### Example +!! +!! ```fortran +!! program demo_init +!! use stdlib_bitsets +!! type(bitset_large) :: set0 +!! call set0 % init(166) +!! if ( set0 % bits() == 166 ) & +!! write(*,*) `SET0 has the proper size.' +!! if ( set0 % none() ) write(*,*) 'SET0 is properly initialized.' +!! end program demo_init +!! + import :: bitset_type, bits_kind + class(bitset_type), intent(out) :: self + integer(bits_kind), intent(in) :: bits + integer, intent(out), optional :: status + end subroutine init_zero_abstract + + subroutine input_abstract(self, unit, status) +!! Version: experimental +!! +!! Reads the components of the bitset, `self`, from the unformatted I/O +!! unit, `unit`, assuming that the components were written using `output`. +!! If an error occurs and `status` is absent then processing stops with +!! an informative stop code. `status` has a default value of `success`. +!! If an error occurs it has the value `read_failure` if it failed +!! during the reads from `unit` or the value `alloc_fault` if it failed +!! during allocation of memory for `self`, or the value +!! `array_size_invalid_error` if the `bits(self)` in `unit` is less than 0 +!! or greater than 64 for a `bitset_64` input. +!! +!!#### Example +!! +!! ```fortran +!! program demo_input +!! character(*), parameter :: & +!! bits_0 = '000000000000000000000000000000000', & +!! bits_1 = '000000000000000000000000000000001', & +!! bits_33 = '100000000000000000000000000000000' +!! integer :: unit +!! type(bitset_64) :: set0, set1, set2, set3, set4, set5 +!! call set0 % from_string( bits_0 ) +!! call set1 % from_string( bits_1 ) +!! call set2 % from_string( bits_33 ) +!! open( newunit=unit, file='test.bin', status='replace', & +!! form='unformatted', action='write' ) +!! call set2 % output(unit) +!! call set1 % output(unit) +!! call set0 % output(unit) +!! close( unit ) +!! open( newunit=unit, file='test.bin', status='old', & +!! form='unformatted', action='read' ) +!! call set5 % input(unit) +!! call set4 % input(unit) +!! call set3 % input(unit) +!! close( unit ) +!! if ( set3 /= set0 .or. set4 /= set1 .or. set5 /= set2 ) then +!! error stop 'Transfer to and from units using ' // & +!! ' output and input failed.' +!! else +!! write(*,*) 'Transfer to and from units using ' // & +!! 'output and input succeeded.' +!! end if +!! end program demo_input +!! + import :: bitset_type + class(bitset_type), intent(out) :: self + integer, intent(in) :: unit + integer, intent(out), optional :: status + end subroutine input_abstract + + elemental function none_abstract(self) result(none) +!! Version: experimental +!! +!! Returns `.true.` if none of the bits in `self` have the value 1. +!! +!!#### Example +!! +!! ```fortran +!! program demo_none +!! use stdlib_bitsets +!! character(*), parameter :: & +!! bits_0 = '0000000000000000000' +!! type(bitset_large) :: set0 +!! call set0 % from_string( bits_0 ) +!! if ( set0 % none() ) then +!! write(*,*) "FROM_STRING interpreted " // & +!! "BITS_0's value properly." +!! end if +!! call set0 % set(5) +!! if ( .not. set0 % none() ) then +!! write(*,*) "NONE interpreted SET0's value properly." +!! end if +!! end program demo_none +!! + import :: bitset_type + logical :: none + class(bitset_type), intent(in) :: self + end function none_abstract + + elemental subroutine not_abstract(self) +!! Version: experimental +!! +!! Sets the bits in `self` to their logical complement +!! +!!#### Example +!! +!! ```fortran +!! program demo_not +!! use stdlib_bitsets +!! type(bitset_large) :: set0 +!! call set0 % init( 155 ) +!! if ( set0 % none() ) then +!! write(*,*) "FROM_STRING interpreted " // & +!! "BITS_0's value properly." +!! end if +!! call set0 % not() +!! if ( set0 % all() ) then +!! write(*,*) "ALL interpreted SET0's value properly." +!! end if +!! end program demo_not +!! + import :: bitset_type + class(bitset_type), intent(inout) :: self + end subroutine not_abstract + + subroutine output_abstract(self, unit, status) +!! Version: experimental +!! +!! Writes the components of the bitset, `self`, to the unformatted I/O +!! unit, `unit`, in a unformatted sequence compatible with `input`. If +!! `status` is absent an error results in an error stop with an +!! informative stop code. If `status` is present it has the default +!! value of `success`, or the value `write_failure` if the write failed. +!! +!!#### Example +!! +!! ```fortran +!! program demo_output +!! character(*), parameter :: & +!! bits_0 = '000000000000000000000000000000000', & +!! bits_1 = '000000000000000000000000000000001', & +!! bits_33 = '100000000000000000000000000000000' +!! integer :: unit +!! type(bitset_64) :: set0, set1, set2, set3, set4, set5 +!! call set0 % from_string( bits_0 ) +!! call set1 % from_string( bits_1 ) +!! call set2 % from_string( bits_33 ) +!! open( newunit=unit, file='test.bin', status='replace', & +!! form='unformatted', action='write' ) +!! call set2 % output(unit) +!! call set1 % output(unit) +!! call set0 % output(unit) +!! close( unit ) +!! open( newunit=unit, file='test.bin', status='old', & +!! form='unformatted', action='read' ) +!! call set5 % input(unit) +!! call set4 % input(unit) +!! call set3 % input(unit) +!! close( unit ) +!! if ( set3 /= set0 .or. set4 /= set1 .or. set5 /= set2 ) then +!! error stop 'Transfer to and from units using ' // & +!! ' output and input failed.' +!! else +!! write(*,*) 'Transfer to and from units using ' // & +!! 'output and input succeeded.' +!! end if +!! end program demo_output +!! + import :: bitset_type + class(bitset_type), intent(in) :: self + integer, intent(in) :: unit + integer, intent(out), optional :: status + end subroutine output_abstract + + subroutine read_bitset_string_abstract(self, string, status) +!! Version: experimental +!! +!! Uses the bitset literal in the default character `string`, to define +!! the bitset, `self`. The literal may be preceded by an an arbitrary +!! sequence of blank characters. If `status` is absent an error results +!! in an error stop with an informative stop code. If `status` is +!! present it has the default value of `success`, the value +!! `integer_overflow_error` if the bitset literal has a `bits(self)` value +!! too large to be represented, the value `alloc_fault` if allocation of +!! memory for `self` failed, or `char_string_invalid_error` if the bitset +!! literal has an invlaaid character, or `array_size_invalid_error` if +!! `bits(self)` in `string` is greater than 64 for a `bitset_64`. +!! +!!#### Example +!! +!! ```fortran +!! program demo_read_bitset +!! character(*), parameter :: & +!! bits_0 = 'S33B000000000000000000000000000000000', & +!! bits_1 = 'S33B000000000000000000000000000000001', & +!! bits_33 = 'S33B100000000000000000000000000000000' +!! character(:), allocatable :: test_0, test_1, test_2 +!! integer :: unit +!! type(bitset_64) :: set0, set1, set2, set3, set4, set5 +!! call set0 % read_bitset( bits_0, status ) +!! call set1 % read_bitset( bits_1, status ) +!! call set2 % read_bitset( bits_2, status ) +!! call set0 % write_bitset( test_0, status ) +!! call set1 % write_bitset( test_1, status ) +!! call set2 % write_bitset( test_2, status ) +!! if ( bits_0 == test_0 .and. bits_1 == test_1 .and. & +!! bits_2 == test_2 ) then +!! write(*,*) 'READ_BITSET to WRITE_BITSET strings worked.' +!! end if +!! open( newunit=unit, file='test.txt', status='replace', & +!! form='formatted', action='write' ) +!! call set2 % write_bitset(unit, advance='no') +!! call set1 % write_bitset(unit, advance='no') +!! call set0 % write_bitset(unit) +!! close( unit ) +!! open( newunit=unit, file='test.txt', status='old', & +!! form='formatted', action='read' ) +!! call set3 % read_bitset(unit, advance='no') +!! call set4 % read_bitset(unit, advance='no') +!! call set5 % read_bitset(unit) +!! if ( set3 == set0 .and. set4 == set1 .and. set5 == set2 ) then +!! write(*,*) WRITE_BITSET to READ_BITSET through unit worked.' +!! end if +!! end program demo_read_bitset +!! + import :: bitset_type + class(bitset_type), intent(out) :: self + character(len=*), intent(in) :: string + integer, intent(out), optional :: status + end subroutine read_bitset_string_abstract + + subroutine read_bitset_unit_abstract(self, unit, advance, status) +!! Version: experimental +!! +!! Uses the bitset literal at the current position in the formatted +!! file with I/O unit, `unit`, to define the bitset, `self`. The literal +!! may be preceded by an an arbitrary sequence of blank characters. +!! If `advance` is present it must be either 'YES' or 'NO'. If absent +!! it has the default value of 'YES' to determine whether advancing +!! I/O occurs. If `status` is absent an error results in an error stop +!! with an informative stop code. If `status` is present it has the +!! default value of `success`, the value `integer_overflow_error` if the +!! bitset literal has a `bits(self)` value too large to be +!! represented, the value `read_failure` if a `read` statement fails, +!! `eof_failure` if a `read` statement reaches an end-of-file before +!! completing the read of the bitset literal, or the value +!! `char_string_invalid_error` if the read of the bitset literal found +!! an invalid character, or `array_size_invalid_error` if `bits(self)` +!! in `string` is greater than 64 for a `bitset_64`. + import :: bitset_type + class(bitset_type), intent(out) :: self + integer, intent(in) :: unit + character(*), intent(in), optional :: advance + integer, intent(out), optional :: status + end subroutine read_bitset_unit_abstract + + elemental subroutine set_bit_abstract(self, pos) +!! Version: experimental +!! +!! Sets the value at the `pos` position in `self`, provided the position is +!! valid. If the position is less than 0 or greater than `bits(self)-1` +!! then `self` is unchanged. +!! +!!#### Example +!! +!! ```fortran +!! program demo_set +!! use stdlib_bitsets +!! type(bitset_large) :: set0 +!! call set0 % init(166) +!! if ( set0 % none() ) write(*,*) 'SET0 is properly initialized.' +!! call set0 % set(165) +!! if ( set0 % test(165) ) write(*,*) 'Bit 165 is set.' +!! call set0 % set(0,164) +!! if ( set0 % all() ) write(*,*) 'All bits are set.' +!! end program demo_set +!! + import :: bitset_type, bits_kind + class(bitset_type), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + end subroutine set_bit_abstract + + pure subroutine set_range_abstract(self, start_pos, stop_pos) +!! Version: experimental +!! +!! Sets all valid bits to 1 from the `start_pos` to the `stop_pos` positions +!! in `self`. If `stop_pos < start_pos` no bits are changed. Positions outside +!! the range 0 to `bits(self)-1` are ignored. + import :: bitset_type, bits_kind + class(bitset_type), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + end subroutine set_range_abstract + + elemental function test_abstract(self, pos) result(test) +!! Version: experimental +!! +!! Returns `.true.` if the `pos` position is set, `.false.` otherwise. If `pos` +!! is negative or greater than `bits(self) - 1` the result is `.false.`. +!! +!!#### Example +!! +!! ```fortran +!! program demo_test +!! use stdlib_bitsets +!! type(bitset_large) :: set0 +!! call set0 % init(166) +!! call set0 % not() +!! if ( set0 % all() ) write(*,*) 'SET0 is properly initialized.' +!! call set0 % clear(165) +!! if ( .not. set0 % test(165) ) write(*,*) 'Bit 165 is cleared.' +!! call set0 % set(165) +!! if ( set0 % test(165) ) write(*,*) 'Bit 165 is set.' +!! end program demo_test +!! + import :: bitset_type, bits_kind + logical :: test + class(bitset_type), intent(in) :: self + integer(bits_kind), intent(in) :: pos + end function test_abstract + + subroutine to_string_abstract(self, string, status) +!! Version: experimental +!! +!! Represents the value of `self` as a binary literal in `string` +!! Status may have the values `success` or `alloc_fault`. +!! +!!#### Example +!! +!! ```fortran +!! program demo_to_string +!! use stdlib_bitsets +!! character(*), parameter :: & +!! bits_all = '111111111111111111111111111111111' +!! type(bitset_64) :: set0 +!! character(:), allocatable :: new_string +!! call set0 % init(33) +!! call set0 % not() +!! call set0 % to_string( new_string ) +!! if ( new_string == bits_all ) then +!! write(*,*) "TO_STRING transferred BITS0 properly" // & +!! " into NEW_STRING." +!! end if +!! end program demo_to_string +!! + import :: bitset_type + class(bitset_type), intent(in) :: self + character(:), allocatable, intent(out) :: string + integer, intent(out), optional :: status + end subroutine to_string_abstract + + elemental function value_abstract(self, pos) result(value) +!! Version: experimental +!! +!! Returns 1 if the `pos` position is set, 0 otherwise. If `pos` is negative +!! or greater than `bits(set) - 1` the result is 0. +!! +!!#### Example +!! +!! ```fortran +!! program demo_value +!! use stdlib_bitsets +!! type(bitset_large) :: set0 +!! call set0 % init(166) +!! call set0 % not() +!! if ( set0 % all() ) write(*,*) 'SET0 is properly initialized.' +!! call set0 % clear(165) +!! if ( set0 % value(165) == 0 ) write(*,*) 'Bit 165 is cleared.' +!! call set0 % set(165) +!! if ( set0 % value(165) == 1 ) write(*,*) 'Bit 165 is set.' +!! end program demo_value +!! + import :: bitset_type, bits_kind + integer :: value + class(bitset_type), intent(in) :: self + integer(bits_kind), intent(in) :: pos + end function value_abstract + + subroutine write_bitset_string_abstract(self, string, status) +!! Version: experimental +!! +!! Writes a bitset literal to the allocatable default character `string`, +!! representing the individual bit values in the `bitset_type`, `self`. +!! If `status` is absent an error results in an error stop with an +!! informative stop code. If `status` is present it has the default +!! value of `success`, or the value `alloc_fault` if allocation of +!! the output string failed. +!! +!!#### Example +!! +!! ```fortran +!! program demo_write_bitset +!! character(*), parameter :: & +!! bits_0 = 'S33B000000000000000000000000000000000', & +!! bits_1 = 'S33B000000000000000000000000000000001', & +!! bits_33 = 'S33B100000000000000000000000000000000' +!! character(:), allocatable :: test_0, test_1, test_2 +!! integer :: unit +!! type(bitset_64) :: set0, set1, set2, set3, set4, set5 +!! call set0 % read_bitset( bits_0, status ) +!! call set1 % read_bitset( bits_1, status ) +!! call set2 % read_bitset( bits_2, status ) +!! call set0 % write_bitset( test_0, status ) +!! call set1 % write_bitset( test_1, status ) +!! call set2 % write_bitset( test_2, status ) +!! if ( bits_0 == test_0 .and. bits_1 == test_1 .and. & +!! bits_2 == test_2 ) then +!! write(*,*) 'READ_BITSET to WRITE_BITSET strings worked.' +!! end if +!! open( newunit=unit, file='test.txt', status='replace', & +!! form='formatted', action='write' ) +!! call set2 % write_bitset(unit, advance='no') +!! call set1 % write_bitset(unit, advance='no') +!! call set0 % write_bitset(unit) +!! close( unit ) +!! open( newunit=unit, file='test.txt', status='old', & +!! form='formatted', action='read' ) +!! call set3 % read_bitset(unit, advance='no') +!! call set4 % read_bitset(unit, advance='no') +!! call set5 % read_bitset(unit) +!! if ( set3 == set0 .and. set4 == set1 .and. set5 == set2 ) then +!! write(*,*) WRITE_BITSET to READ_BITSET through unit worked.' +!! end if +!! end program demo_write_bitset +!! + import :: bitset_type + class(bitset_type), intent(in) :: self + character(len=:), allocatable, intent(out) :: string + integer, intent(out), optional :: status + end subroutine write_bitset_string_abstract + + subroutine write_bitset_unit_abstract(self, unit, advance, & + status) +!! Version: experimental +!! +!! Writes a bitset literal to the I/O unit, `unit`, representing the +!! individual bit values in the `bitset_t`, `self`. If an error occurs then +!! processing stops with a message to `error_unit`. By default or if +!! `advance` is present with the value 'YES', advancing output is used. +!! If `advance` is present with the value 'NO', then the current record +!! is not advanced by the write. If `status` is absent, an error results +!! in an error stop with an informative stop code. If `status` is +!! present it has the default value of `success`, the value +!! `alloc_fault` if allocation of the output string failed, +!! `write_failure` if the `write` statement outputting the literal failed. + import :: bitset_type + class(bitset_type), intent(in) :: self + integer, intent(in) :: unit + character(len=*), intent(in), optional :: advance + integer, intent(out), optional :: status + end subroutine write_bitset_unit_abstract + + end interface + + type, extends(bitset_type) :: bitset_large +!! Version: experimental +!! +!! Type for bitsets with more than 64 bits. + private + integer(block_kind), private, allocatable :: blocks(:) + + contains + + procedure, pass(self) :: all => all_large + procedure, pass(self) :: any => any_large + procedure, pass(self) :: bit_count => bit_count_large + procedure, pass(self) :: clear_bit => clear_bit_large + procedure, pass(self) :: clear_range => clear_range_large + procedure, pass(self) :: flip_bit => flip_bit_large + procedure, pass(self) :: flip_range => flip_range_large + procedure, pass(self) :: from_string => from_string_large + procedure, pass(self) :: init_zero => init_zero_large + procedure, pass(self) :: input => input_large + procedure, pass(self) :: none => none_large + procedure, pass(self) :: not => not_large + procedure, pass(self) :: output => output_large + procedure, pass(self) :: & + read_bitset_string => read_bitset_string_large + procedure, pass(self) :: read_bitset_unit => read_bitset_unit_large + procedure, pass(self) :: set_bit => set_bit_large + procedure, pass(self) :: set_range => set_range_large + procedure, pass(self) :: test => test_large + procedure, pass(self) :: to_string => to_string_large + procedure, pass(self) :: value => value_large + procedure, pass(self) :: & + write_bitset_string => write_bitset_string_large + procedure, pass(self) :: write_bitset_unit => write_bitset_unit_large + + end type bitset_large + + + interface + + elemental module function all_large( self ) result(all) +!! Version: experimental +!! +!! Returns `.true.` if all bits in `self` are 1, `.false.` otherwise. + logical :: all + class(bitset_large), intent(in) :: self + end function all_large + + elemental module function any_large(self) result(any) +!! Version: experimental +!! +!! Returns `.true.` if any bit in `self` is 1, `.false.` otherwise. + logical :: any + class(bitset_large), intent(in) :: self + end function any_large + + elemental module function bit_count_large(self) result(bit_count) +!! Version: experimental +!! +!! Returns the number of non-zero bits in `self`. + integer(bits_kind) :: bit_count + class(bitset_large), intent(in) :: self + end function bit_count_large + + elemental module subroutine clear_bit_large(self, pos) +!! Version: experimental +!! +!! Sets to zero the bit at `pos` position in `self`. If 'pos` is less than +!! zero or greater than `bits(self)-1` it is ignored. + class(bitset_large), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + end subroutine clear_bit_large + + pure module subroutine clear_range_large(self, start_pos, stop_pos) +!! Version: experimental +!! +!! Sets to zero all bits from the `start_pos` to `stop_pos` positions in `self`. +!! If `stop_pos < start_pos` then no bits are modified. Positions outside +!! the range 0 to `bits(set)-1` are ignored. + class(bitset_large), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + end subroutine clear_range_large + + elemental module subroutine flip_bit_large(self, pos) +!! Version: experimental +!! +!! Flips the bit value at the `pos` position in `self`, provided the position is +!! valid. If `pos` is less than 0 or greater than `bits(self)-1`, no value is +!! changed. + class(bitset_large), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + end subroutine flip_bit_large + + pure module subroutine flip_range_large(self, start_pos, stop_pos) +!! Version: experimental +!! +!! Flips all valid bits from the `start_pos` to the `stop_pos` positions in +!! `self`. If `stop_pos < start_pos` no bits are flipped. Positions less than +!! 0 or greater than `bits(self)-1` are ignored. + class(bitset_large), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + end subroutine flip_range_large + + module subroutine from_string_large(self, string, status) +!! Version: experimental +!! +!! Initializes the bitset `self` treating `string` as a binary literal +!! `status` may have the values `success`, `alloc_fault`, +!! `array_size_invalid_error`, or `char_string_invalid`. + class(bitset_large), intent(out) :: self + character(*), intent(in) :: string + integer, intent(out), optional :: status + end subroutine from_string_large + + module subroutine init_zero_large(self, bits, status) +!! Version: experimental +!! +!! Creates the bitset, `self`, of size `bits`, with all bits initialized to +!! zero. `bits` must be non-negative. If an error occurs and `status` is +!! absent then processing stops with an informative stop code. `status` +!! has a default value of `success`. If an error occurs it has the value +!! `array_size_invalid_error` if `bits` is either negative larger than 64 +!! if `self` is of type `bitset_64`, or the value `alloc_fault` if it failed +!! during allocation of memory for `self`. + class(bitset_large), intent(out) :: self + integer(bits_kind), intent(in) :: bits + integer, intent(out), optional :: status + end subroutine init_zero_large + + module subroutine input_large(self, unit, status) +!! Version: experimental +!! +!! Reads the components of the bitset, `self`, from the unformatted I/O +!! unit, `unit`, assuming that the components were written using `output`. +!! If an error occurs and `status` is absent then processing stops with +!! an informative stop code. `status` has a default value of `success`. +!! If an error occurs it has the value `read_failure` if it failed +!! during the reads from `unit` or the value `alloc_fault` if it failed +!! during allocation of memory for `self`, or the value +!! `array_size_invalid_error if the `bits(self) in `unit` is less than 0 +!! or greater than 64 for a `bitset_64` input. + class(bitset_large), intent(out) :: self + integer, intent(in) :: unit + integer, intent(out), optional :: status + end subroutine input_large + + elemental module function none_large(self) result(none) +!! Version: experimental +!! +!! Returns `.true.` if none of the bits in `self` have the value 1. + logical :: none + class(bitset_large), intent(in) :: self + end function none_large + + elemental module subroutine not_large(self) +!! Version: experimental +!! +!! Sets the bits in `self` to their logical complement + class(bitset_large), intent(inout) :: self + end subroutine not_large + + module subroutine output_large(self, unit, status) +!! Version: experimental +!! +!! Writes the components of the bitset, `self`, to the unformatted I/O +!! unit, `unit`, in a unformatted sequence compatible with `input`. If +!! `status` is absent an error results in an error stop with an +!! informative stop code. If `status` is present it has the default +!! value of `success`, or the value `write_failure` if the write failed. + class(bitset_large), intent(in) :: self + integer, intent(in) :: unit + integer, intent(out), optional :: status + end subroutine output_large + + module subroutine read_bitset_string_large(self, string, status) +!! Version: experimental +!! +!! Uses the bitset literal in the default character `string`, to define +!! the bitset, `self`. The literal may be preceded by an an arbitrary +!! sequence of blank characters. If `status` is absent an error results +!! in an error stop with an informative stop code. If `status` is +!! present it has the default value of `success`, the value +!! `integer_overflow_error` if the bitset literal has a `bits(self)` value +!! too large to be represented, the value `alloc_fault` if allocation of +!! memory for `self` failed, or `char_string_invalid_error` if the bitset +!! literal has an invlaid character, or `array_size_invalid_error` if +!! `bits(self)` in `string` is greater than 64 for a `bitset_64`, or +!! `char_string_too_small_error` if the string ends before all the bits +!! are read. + class(bitset_large), intent(out) :: self + character(len=*), intent(in) :: string + integer, intent(out), optional :: status + end subroutine read_bitset_string_large + + module subroutine read_bitset_unit_large(self, unit, advance, status) +!! Version: experimental +!! +!! Uses the bitset literal at the current position in the formatted +!! file with I/O unit, `unit`, to define the bitset, `self`. The literal +!! may be preceded by an an arbitrary sequence of blank characters. +!! If `advance` is present it must be either 'YES' or 'NO'. If absent +!! it has the default value of 'YES' to determine whether advancing +!! I/O occurs. If `status` is absent an error results in an error stop +!! with an informative stop code. If `status` is present it has the +!! default value of `success`, the value `integer_overflow_error` if the +!! bitset literal has a `bits(self)` value too large to be +!! represented, the value `read_failure` if a `read` statement fails, +!! `eof_failure` if a `read` statement reach an end-of-file before +!! completing the read of the bitset literal, or the value +!! `char_string_invalid_error` if the read of the bitset literal found +!! an invalid character, or `array_size_invalid_error` if `bits(self)` +!! in `string` is greater than 64 for a `bitset_64`. + class(bitset_large), intent(out) :: self + integer, intent(in) :: unit + character(*), intent(in), optional :: advance + integer, intent(out), optional :: status + end subroutine read_bitset_unit_large + + elemental module subroutine set_bit_large(self, pos) +!! Version: experimental +!! +!! Sets the value at the `pos` position in `self`, provided the position is +!! valid. If the position is less than 0 or greater than `bits(self)-1` +!! then `self` is unchanged. + class(bitset_large), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + end subroutine set_bit_large + + pure module subroutine set_range_large(self, start_pos, stop_pos) +!! Version: experimental +!! +!! Sets all valid bits to 1 from the `start_pos` to the `stop_pos` positions +!! in `self`. If `stop_pos < start_pos` no bits are changed. Positions outside +!! the range 0 to `bits(self)-1` are ignored. + class(bitset_large), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + end subroutine set_range_large + + elemental module function test_large(self, pos) result(test) +!! Version: experimental +!! +!! Returns `.true.` if the `pos` position is set, `.false.` otherwise. If `pos` +!! is negative or greater than `bits(self) - 1` the result is `.false.`. + logical :: test + class(bitset_large), intent(in) :: self + integer(bits_kind), intent(in) :: pos + end function test_large + + module subroutine to_string_large(self, string, status) +!! Version: experimental +!! +!! Represents the value of `self` as a binary literal in `string` +!! Status may have the values `success` or `alloc_fault`. + class(bitset_large), intent(in) :: self + character(len=:), allocatable, intent(out) :: string + integer, intent(out), optional :: status + end subroutine to_string_large + + elemental module function value_large(self, pos) result(value) +!! Version: experimental +!! +!! Returns 1 if the `pos` position is set, 0 otherwise. If `pos` is negative +!! or greater than `bits(set) - 1` the result is 0. + integer :: value + class(bitset_large), intent(in) :: self + integer(bits_kind), intent(in) :: pos + end function value_large + + module subroutine write_bitset_string_large(self, string, status) +!! Version: experimental +!! +!! Writes a bitset literal to the allocatable default character `string`, +!! representing the individual bit values in the bitset_large, `self`. +!! If `status` is absent an error results in an error stop with an +!! informative stop code. If `status` is present it has the default +!! value of `success, or the value `alloc_fault` if allocation of +!! the output string failed. + class(bitset_large), intent(in) :: self + character(len=:), allocatable, intent(out) :: string + integer, intent(out), optional :: status + end subroutine write_bitset_string_large + + module subroutine write_bitset_unit_large(self, unit, advance, status) +!! Version: experimental +!! +!! Writes a bitset literal to the I/O unit, `unit`, representing the +!! individual bit values in the bitset, `self`. By default or if +!! `advance` is present with the value 'YES', advancing output is used. +!! If `advance` is present with the value 'NO', then the current record +!! is not advanced by the write. If `status` is absent an error results +!! in an error stop with an informative stop code. If `status` is +!! present it has the default value of `success`, the value +!! `alloc_fault` if allocation of the output string failed, or +!! `write_failure` if the `write` statement outputting the literal failed. + class(bitset_large), intent(in) :: self + integer, intent(in) :: unit + character(len=*), intent(in), optional :: advance + integer, intent(out), optional :: status + end subroutine write_bitset_unit_large + + end interface + + + interface assignment(=) +!! +!!#### Example +!! +!! ```fortran +!! program demo_assignment +!! use stdlib_bitsets +!! logical(int8) :: logical1(64) = .true. +!! logical(int32), allocatable :: logical2(:) +!! type(bitset_64) :: set0, set1 +!! set0 = logical1 +!! if ( set0 % bits() /= 64 ) then +!! error stop procedure // & +!! ' initialization with logical(int8) failed to set' // & +!! ' the right size.' +!! else if ( .not. set0 % all() ) then +!! error stop procedure // ' initialization with' // & +!! ' logical(int8) failed to set the right values.' +!! else +!! write(*,*) 'Initialization with logical(int8) succeeded.' +!! end if +!! set1 = set0 +!! if ( set1 == set0 ) & +!! write(*,*) 'Initialization by assignment succeeded' +!! logical2 = set1 +!! if ( all( logical2 ) ) then +!! write(*,*) 'Initialization of logical(int32) succeeded.' +!! end if +!! end program demo_assignment +!! + + pure module subroutine assign_large( set1, set2 ) +!! Version: experimental +!! +!! Used to define assignment for `bitset_large`. + type(bitset_large), intent(out) :: set1 + type(bitset_large), intent(in) :: set2 + end subroutine assign_large + + pure module subroutine assign_log8_large( self, logical_vector ) +!! Version: experimental +!! +!! Used to define assignment from an array of type `logical(int8)` to a +!! `bitset_large`. + type(bitset_large), intent(out) :: self + logical(int8), intent(in) :: logical_vector(:) + end subroutine assign_log8_large + + pure module subroutine assign_log16_large( self, logical_vector ) +!! Version: experimental +!! +!! Used to define assignment from an array of type `logical(int16)` to a +!! `bitset_large`. + type(bitset_large), intent(out) :: self + logical(int16), intent(in) :: logical_vector(:) + end subroutine assign_log16_large + + pure module subroutine assign_log32_large( self, logical_vector ) +!! Version: experimental +!! +!! Used to define assignment from an array of type `logical(int32)` to a +!! `bitset_large` + type(bitset_large), intent(out) :: self + logical(int32), intent(in) :: logical_vector(:) + end subroutine assign_log32_large + + pure module subroutine assign_log64_large( self, logical_vector ) +!! Version: experimental +!! +!! Used to define assignment from an array of type `logical(int64)` to a +!! `bitset_large`. + type(bitset_large), intent(out) :: self + logical(int64), intent(in) :: logical_vector(:) + end subroutine assign_log64_large + + pure module subroutine log8_assign_large( logical_vector, set ) +!! Version: experimental +!! +!! Used to define assignment to an array of type `logical(int8)` from a +!! `bitset_large`. + logical(int8), intent(out), allocatable :: logical_vector(:) + type(bitset_large), intent(in) :: set + end subroutine log8_assign_large + + pure module subroutine log16_assign_large( logical_vector, set ) +!! Version: experimental +!! +!! Used to define assignment to an array of type `logical(int16) from a +!! `bitset_large`. + logical(int16), intent(out), allocatable :: logical_vector(:) + type(bitset_large), intent(in) :: set + end subroutine log16_assign_large + + pure module subroutine log32_assign_large( logical_vector, set ) +!! Version: experimental +!! +!! Used to define assignment to an array of type `logical(int32)` from a +!! `bitset_lsrge`. + logical(int32), intent(out), allocatable :: logical_vector(:) + type(bitset_large), intent(in) :: set + end subroutine log32_assign_large + + pure module subroutine log64_assign_large( logical_vector, set ) +!! Version: experimental +!! +!! Used to define assignment to an array of type `logical(int64)` from a +!! `bitset_large`. + logical(int64), intent(out), allocatable :: logical_vector(:) + type(bitset_large), intent(in) :: set + end subroutine log64_assign_large + + end interface assignment(=) + + + type, extends(bitset_type) :: bitset_64 +!! Version: experimental +!! +!! Type for bitsets with no more than 64 bits. + private + integer(block_kind), private :: block = 0 + + contains + + procedure, pass(self) :: all => all_64 + procedure, pass(self) :: any => any_64 + procedure, pass(self) :: bit_count => bit_count_64 + procedure, pass(self) :: clear_bit => clear_bit_64 + procedure, pass(self) :: clear_range => clear_range_64 + procedure, pass(self) :: flip_bit => flip_bit_64 + procedure, pass(self) :: flip_range => flip_range_64 + procedure, pass(self) :: from_string => from_string_64 + procedure, pass(self) :: init_zero => init_zero_64 + procedure, pass(self) :: input => input_64 + procedure, pass(self) :: none => none_64 + procedure, pass(self) :: not => not_64 + procedure, pass(self) :: output => output_64 + procedure, pass(self) :: read_bitset_string => read_bitset_string_64 + procedure, pass(self) :: read_bitset_unit => read_bitset_unit_64 + procedure, pass(self) :: set_bit => set_bit_64 + procedure, pass(self) :: set_range => set_range_64 + procedure, pass(self) :: test => test_64 + procedure, pass(self) :: to_string => to_string_64 + procedure, pass(self) :: value => value_64 + procedure, pass(self) :: write_bitset_string => write_bitset_string_64 + procedure, pass(self) :: write_bitset_unit => write_bitset_unit_64 + + end type bitset_64 + + + interface + + elemental module function all_64( self ) result(all) +!! Version: experimental +!! +!! Returns `.true.` if all bits in `self` are 1, `.false.` otherwise. + logical :: all + class(bitset_64), intent(in) :: self + end function all_64 + + elemental module function any_64(self) result(any) +!! Version: experimental +!! +!! Returns `.true.` if any bit in `self` is 1, `.false.` otherwise. + logical :: any + class(bitset_64), intent(in) :: self + end function any_64 + + elemental module function bit_count_64(self) result(bit_count) +!! Version: experimental +!! +!! Returns the number of non-zero bits in `self`. + integer(bits_kind) :: bit_count + class(bitset_64), intent(in) :: self + end function bit_count_64 + + elemental module subroutine clear_bit_64(self, pos) +!! Version: experimental +!! +!! Sets to zero the bit at `pos` position in `self`. If 'pos` is less than +!! zero or greater than `bits(self)-1` it is ignored. + class(bitset_64), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + end subroutine clear_bit_64 + + pure module subroutine clear_range_64(self, start_pos, stop_pos) +!! Version: experimental +!! +!! Sets to zero all bits from the `start_pos` to `stop_pos` positions in `self`. +!! If `stop_pos < start_pos` then no bits are modified. Positions outside +!! the range 0 to `bits(set)-1` are ignored. + class(bitset_64), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + end subroutine clear_range_64 + + elemental module subroutine flip_bit_64(self, pos) +!! Version: experimental +!! +!! Flips the bit value at the `pos` position in `self`, provided the position is +!! valid. If `pos` is less than 0 or greater than `bits(self)-1`, no value is +!! changed. + class(bitset_64), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + end subroutine flip_bit_64 + + pure module subroutine flip_range_64(self, start_pos, stop_pos) +!! Version: experimental +!! +!! Flips all valid bits from the `start_pos` to the `stop_pos` positions in +!! `self`. If `stop_pos < start_pos` no bits are flipped. Positions less than +!! 0 or greater than `bits(self)-1` are ignored. + class(bitset_64), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + end subroutine flip_range_64 + + module subroutine from_string_64(self, string, status) +!! Version: experimental +!! +!! Initializes the bitset `self` treating `string` as a binary literal +!! `status` has the default value `success`, the value `alloc_fault` if the +!! allocation of the bits in self failed, `array_size_invalid_error` if the +!! `len(string)>64` for a `bitset_64`, or `char_string_invalid` if an invalid +!! character was found in `string`. + class(bitset_64), intent(out) :: self + character(*), intent(in) :: string + integer, intent(out), optional :: status + end subroutine from_string_64 + + module subroutine init_zero_64(self, bits, status) +!! Version: experimental +!! +!! Creates the bitset, `self`, of size `bits`, with all bits initialized to +!! zero. `bits` must be non-negative. If an error occurs and `status` is +!! absent then processing stops with an informative stop code. `status` +!! has a default value of `success`. If an error occurs it has the value +!! `array_size_invalid_error` if `bits` is either negative larger than 64 +!! for `self` of type `bitset_64`, or the value `alloc_fault` if it failed +!! during allocation of memory for `self`. + class(bitset_64), intent(out) :: self + integer(bits_kind), intent(in) :: bits + integer, intent(out), optional :: status + end subroutine init_zero_64 + + module subroutine input_64(self, unit, status) +!! Version: experimental +!! +!! Reads the components of the bitset, `self`, from the unformatted I/O +!! unit, `unit`, assuming that the components were written using `output`. +!! If an error occurs and `status` is absent then processing stops with +!! an informative stop code. `status` has a default value of `success`. +!! If an error occurs it has the value `read_failure` if it failed +!! during the reads from `unit` or the value `alloc_fault` if it failed +!! during allocation of memory for `self`, or the value +!! `array_size_invalid_error` if the `bits(self)` in `unit` is less than 0 +!! or greater than 64 for a `bitset_64` input. + class(bitset_64), intent(out) :: self + integer, intent(in) :: unit + integer, intent(out), optional :: status + end subroutine input_64 + + elemental module function none_64(self) result(none) +!! Version: experimental +!! +!! Returns `.true.` if none of the bits in `self` have the value 1. + logical :: none + class(bitset_64), intent(in) :: self + end function none_64 + + elemental module subroutine not_64(self) +!! Version: experimental +!! +!! Sets the bits in `self` to their logical complement. + class(bitset_64), intent(inout) :: self + end subroutine not_64 + + module subroutine output_64(self, unit, status) +!! Version: experimental +!! +!! Writes the components of the bitset, `self`, to the unformatted I/O +!! unit, `unit`, in a unformatted sequence compatible with `input`. If +!! `status` is absent an error results in an error stop with an +!! informative stop code. If `status` is present it has the default +!! value of `success`, or the value `write_failure` if the write failed. + class(bitset_64), intent(in) :: self + integer, intent(in) :: unit + integer, intent(out), optional :: status + end subroutine output_64 + + module subroutine read_bitset_string_64(self, string, status) +!! Version: experimental +!! +!! Uses the bitset literal in the default character `string`, to define +!! the bitset, `self`. The literal may be preceded by an an arbitrary +!! sequence of blank characters. If `status` is absent an error results +!! in an error stop with an informative stop code. If `status` is +!! present it has the default value of `success`, the value +!! `integer_overflow_error` if the bitset literal has a `bits(self)` value +!! too large to be represented, the value `alloc_fault` if allocation of +!! memory for `self` failed, or `char_string_invalid_error` if the bitset +!! literal has an invlaid character, or `array_size_invalid_error` if +!! `bits(self)` in `string` is greater than 64 for a `bitset_64`, or +!! `char_string_too_small_error` if the string ends before all the bits +!! are read. + class(bitset_64), intent(out) :: self + character(len=*), intent(in) :: string + integer, intent(out), optional :: status + end subroutine read_bitset_string_64 + + module subroutine read_bitset_unit_64(self, unit, advance, status) +!! Version: experimental +!! +!! Uses the bitset literal at the current position in the formatted +!! file with I/O unit, `unit`, to define the bitset, `self`. The literal +!! may be preceded by an an arbitrary sequence of blank characters. +!! If `advance` is present it must be either 'YES' or 'NO'. If absent +!! it has the default value of 'YES' to determine whether advancing +!! I/O occurs. If `status` is absent an error results in an error stop +!! with an informative stop code. If `status` is present it has the +!! default value of `success`, the value `integer_overflow_error` if the +!! bitset literal has a `bits(self)` value too large to be +!! represented, the value `read_failure` if a `read` statement fails, +!! `eof_failure` if a `read` statement reach an end-of-file before +!! completing the read of the bitset literal, or the value +!! `char_string_invalid_error` if the read of the bitset literal found +!! an invalid character, or `array_size_invalid_error` if `bits(self)` +!! in `string` is greater than 64 for a `bitset_64`. + class(bitset_64), intent(out) :: self + integer, intent(in) :: unit + character(*), intent(in), optional :: advance + integer, intent(out), optional :: status + end subroutine read_bitset_unit_64 + + elemental module subroutine set_bit_64(self, pos) +!! Version: experimental +!! +!! Sets the value at the `pos` position in `self`, provided the position is +!! valid. If the position is less than 0 or greater than `bits(self)-1` +!! then `self` is unchanged. + class(bitset_64), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + end subroutine set_bit_64 + + pure module subroutine set_range_64(self, start_pos, stop_pos) +!! Version: experimental +!! +!! Sets all valid bits to 1 from the `start_pos` to the `stop_pos` positions +!! in `self`. If `stop_pos < start_pos` no bits are changed. Positions outside +!! the range 0 to `bits(self)-1` are ignored. + class(bitset_64), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + end subroutine set_range_64 + + elemental module function test_64(self, pos) result(test) +!! Version: experimental +!! +!! Returns `.true.` if the `pos` position is set, `.false.` otherwise. If `pos` +!! is negative or greater than `bits(self)-1` the result is `.false.`. + logical :: test + class(bitset_64), intent(in) :: self + integer(bits_kind), intent(in) :: pos + end function test_64 + + module subroutine to_string_64(self, string, status) +!! Version: experimental +!! +!! Represents the value of `self` as a binary literal in `string`. +!! Status may have the values `success` or `alloc_fault` + class(bitset_64), intent(in) :: self + character(len=:), allocatable, intent(out) :: string + integer, intent(out), optional :: status + end subroutine to_string_64 + + elemental module function value_64(self, pos) result(value) +!! Version: experimental +!! +!! Returns 1 if the `pos` position is set, 0 otherwise. If `pos` is negative +!! or greater than `bits(set)-1` the result is 0. + integer :: value + class(bitset_64), intent(in) :: self + integer(bits_kind), intent(in) :: pos + end function value_64 + + module subroutine write_bitset_string_64(self, string, status) +!! Version: experimental +!! +!! Writes a bitset literal to the allocatable default character `string`, +!! representing the individual bit values in the `bitset_64`, `self`. +!! If `status` is absent an error results in an error stop with an +!! informative stop code. If `status` is present it has the default +!! value of `success`, or the value `alloc_fault` if allocation of +!! the output string failed. + class(bitset_64), intent(in) :: self + character(len=:), allocatable, intent(out) :: string + integer, intent(out), optional :: status + end subroutine write_bitset_string_64 + + module subroutine write_bitset_unit_64(self, unit, advance, status) +!! Version: experimental +!! +!! Writes a bitset literal to the I/O unit, `unit`, representing the +!! individual bit values in the bitset, `self`. By default or if +!! `advance` is present with the value 'YES', advancing output is used. +!! If `advance` is present with the value 'NO', then the current record +!! is not advanced by the write. If `status` is absent an error results +!! in an error stop with an informative stop code. If `status` is +!! present it has the default value of `success`, the value +!! `alloc_fault` if allocation of the output string failed, or +!! `write_failure` if the `write` statement outputting the literal failed. + class(bitset_64), intent(in) :: self + integer, intent(in) :: unit + character(len=*), intent(in), optional :: advance + integer, intent(out), optional :: status + end subroutine write_bitset_unit_64 + + end interface + + + interface assignment(=) + + pure module subroutine assign_64( set1, set2 ) +!! Version: experimental +!! +!! Used to define assignment for `bitset_64`. + type(bitset_64), intent(out) :: set1 + type(bitset_64), intent(in) :: set2 + end subroutine assign_64 + + module subroutine assign_log8_64( self, logical_vector ) +!! Version: experimental +!! +!! Used to define assignment from an array of type `logical(int8)` to a +!! `bitset_64`. + type(bitset_64), intent(out) :: self + logical(int8), intent(in) :: logical_vector(:) + end subroutine assign_log8_64 + + module subroutine assign_log16_64( self, logical_vector ) +!! Version: experimental +!! +!! Used to define assignment from an array of type `logical(int16)` to a +!! `bitset_64`. + type(bitset_64), intent(out) :: self + logical(int16), intent(in) :: logical_vector(:) + end subroutine assign_log16_64 + + module subroutine assign_log32_64( self, logical_vector ) +!! Version: experimental +!! +!! Used to define assignment from an array of type `logical(int32)` to a +!! `bitset_64`. + type(bitset_64), intent(out) :: self + logical(int32), intent(in) :: logical_vector(:) + end subroutine assign_log32_64 + + module subroutine assign_log64_64( self, logical_vector ) +!! Version: experimental +!! +!! Used to define assignment from an array of type `logical(int64)` to a +!! `bitset_64`. + type(bitset_64), intent(out) :: self + logical(int64), intent(in) :: logical_vector(:) + end subroutine assign_log64_64 + + pure module subroutine log8_assign_64( logical_vector, set ) +!! Version: experimental +!! +!! Used to define assignment to an array of type `logical(int8)` from a +!! `bitset_64`. + logical(int8), intent(out), allocatable :: logical_vector(:) + type(bitset_64), intent(in) :: set + end subroutine log8_assign_64 + + pure module subroutine log16_assign_64( logical_vector, set ) +!! Version: experimental +!! +!! Used to define assignment to an array of type `logical(int16)` from a +!! `bitset_64` + logical(int16), intent(out), allocatable :: logical_vector(:) + type(bitset_64), intent(in) :: set + end subroutine log16_assign_64 + + pure module subroutine log32_assign_64( logical_vector, set ) +!! Version: experimental +!! +!! Used to define assignment to an array of type `logical(int32)` from a +!! `bitset_64`. + logical(int32), intent(out), allocatable :: logical_vector(:) + type(bitset_64), intent(in) :: set + end subroutine log32_assign_64 + + pure module subroutine log64_assign_64( logical_vector, set ) +!! Version: experimental +!! +!! Used to define assignment to an array of type `logical(int64)` from a +!! `bitset_64`. + logical(int64), intent(out), allocatable :: logical_vector(:) + type(bitset_64), intent(in) :: set + end subroutine log64_assign_64 + + end interface assignment(=) + + + interface and + + elemental module subroutine and_large(set1, set2) +!! Version: experimental +!! +!! Sets the bits in `set1` to the bitwise `and` of the original bits in `set1` +!! and `set2`. The sets mmust have the same number of bits +!! otherwise the result is undefined. +!! +!!#### Example +!! +!! ```fortran +!! program demo_and +!! use stdlib_bitsets +!! type(bitset_large) :: set0, set1 +!! call set0 % init(166) +!! call set1 % init(166) +!! call and( set0, set1 ) ! none none +!! if ( none(set0) ) write(*,*) 'First test of AND worked.' +!! call set0 % not() +!! call and( set0, set1 ) ! all none +!! if ( none(set0) ) write(*,*) 'Second test of AND worked.' +!! call set1 % not() +!! call and( set0, set1 ) ! none all +!! if ( none(set0) ) write(*,*) 'Third test of AND worked.' +!! call set0 % not() +!! call and( set0, set1 ) ! all all +!! if ( all(set0) ) write(*,*) 'Fourth test of AND worked.' +!! end program demo_and +!! + type(bitset_large), intent(inout) :: set1 + type(bitset_large), intent(in) :: set2 + end subroutine and_large + + elemental module subroutine and_64(set1, set2) +!! Version: experimental +!! +!! Sets the bits in `set1` to the bitwise `and` of the original bits in `set1` +!! and `set2`. The sets must have the same number of bits +!! otherwise the result is undefined. + type(bitset_64), intent(inout) :: set1 + type(bitset_64), intent(in) :: set2 + end subroutine and_64 + + end interface and + + + interface and_not + + elemental module subroutine and_not_large(set1, set2) +!! Version: experimental +!! +!! Sets the bits in `set1` to the bitwise and of the original bits in `set1` +!! with the bitwise negation of `set2`. The sets must have the same +!! number of bits otherwise the result is undefined. +!! +!!#### Example +!! +!! ```fortran +!! program demo_and_not +!! use stdlib_bitsets +!! type(bitset_large) :: set0, set1 +!! call set0 % init(166) +!! call set1 % init(166) +!! call and_not( set0, set1 ) ! none none +!! if ( none(set0) ) write(*,*) 'First test of AND_NOT worked.' +!! call set0 % not() +!! call and_not( set0, set1 ) ! all none +!! if ( all(set0) ) write(*,*) 'Second test of AND_NOT worked.' +!! call set0 % not() +!! call set1 % not() +!! call and_not( set0, set1 ) ! none all +!! if ( none(set0) ) write(*,*) 'Third test of AND_NOT worked.' +!! call set0 % not() +!! call and_not( set0, set1 ) ! all all +!! if ( none(set0) ) write(*,*) 'Fourth test of AND_NOT worked.' +!! end program demo_and_not +!! + type(bitset_large), intent(inout) :: set1 + type(bitset_large), intent(in) :: set2 + end subroutine and_not_large + + elemental module subroutine and_not_64(set1, set2) +!! Version: experimental +!! +!! Sets the bits in `set1` to the bitwise and of the original bits in `set1` +!! with the bitwise negation of `set2`. The sets must have the same +!! number of bits otherwise the result is undefined. + type(bitset_64), intent(inout) :: set1 + type(bitset_64), intent(in) :: set2 + end subroutine and_not_64 + + end interface and_not + + interface extract + + module subroutine extract_large(new, old, start_pos, stop_pos, status) +!! Version: experimental +!! +!! Creates a new bitset, `new`, from a range, `start_pos` to `stop_pos`, in +!! bitset `old`. If 'start_pos` is greater than `stop_pos` the new bitset is +!! empty. If `start_pos` is less than zero or `stop_pos` is greater than +!! `bits(old)-1` then if `status` is present it has the value +!! `index_invalid_error`and `new` is undefined, otherwise processing stops +!! with an informative message. +!! +!!#### Example +!! +!! ```fortran +!! program demo_extract +!! use stdlib_bitsets +!! type(bitset_large) :: set0, set1 +!! call set0 % init(166) +!! call set0 % set(100,150) +!! call extract( set1, set0, 100, 150) +!! if ( set1 % bits() == 51 ) & +!! write(*,*) 'SET1 has the proper size.' +!! if ( set1 % all() ) write(*,*) 'SET1 has the proper values.' +!! end program demo_extract +!! + type(bitset_large), intent(out) :: new + type(bitset_large), intent(in) :: old + integer(bits_kind), intent(in) :: start_pos, stop_pos + integer, intent(out), optional :: status + end subroutine extract_large + + module subroutine extract_64(new, old, start_pos, stop_pos, status) +!! Version: experimental +!! +!! Creates a new bitset, `new`, from a range, `start_pos` to `stop_pos`, in +!! bitset `old`. If 'start_pos` is greater than `stop_pos` the new bitset is +!! empty. If `start_pos` is less than zero or `stop_pos` is greater than +!! `bits(old)-1` then if `status` is present it has the value +!! `index_invalid_error`and `new` is undefined, otherwise processing stops +!! with an informative message. + type(bitset_64), intent(out) :: new + type(bitset_64), intent(in) :: old + integer(bits_kind), intent(in) :: start_pos, stop_pos + integer, intent(out), optional :: status + end subroutine extract_64 + + end interface extract + + + interface or + + elemental module subroutine or_large(set1, set2) +!! Version: experimental +!! +!! Sets the bits in `set1` to the bitwise `or` of the original bits in `set1` +!! and `set2`. The sets must have the same number of bits otherwise +!! the result is undefined. +!! +!!#### Example +!! +!! ```fortran +!! program demo_or +!! use stdlib_bitsets +!! type(bitset_large) :: set0, set1 +!! call set0 % init(166) +!! call set1 % init(166) +!! call or( set0, set1 ) ! none none +!! if ( none(set0) ) write(*,*) 'First test of OR worked.' +!! call set0 % not() +!! call or( set0, set1 ) ! all none +!! if ( all(set0) ) write(*,*) 'Second test of OR worked.' +!! call set0 % not() +!! call set1 % not() +!! call or( set0, set1 ) ! none all +!! if ( all(set0) ) write(*,*) 'Third test of OR worked.' +!! call set0 % not() +!! call or( set0, set1 ) ! all all +!! if ( all(set0) ) write(*,*) 'Fourth test of OR worked.' +!! end program demo_or +!! + type(bitset_large), intent(inout) :: set1 + type(bitset_large), intent(in) :: set2 + end subroutine or_large + + elemental module subroutine or_64(set1, set2) +!! Version: experimental +!! +!! Sets the bits in `set1` to the bitwise `or` of the original bits in `set1` +!! and `set2`. The sets must have the same number of bits otherwise +!! the result is undefined. + type(bitset_64), intent(inout) :: set1 + type(bitset_64), intent(in) :: set2 + end subroutine or_64 + + end interface or + + + interface xor + + elemental module subroutine xor_large(set1, set2) +!! Version: experimental +!! +!! Sets the bits in `set1` to the bitwise `xor` of the original bits in `set1` +!! and `set2`. The sets must have the same number of bits otherwise +!! the result is undefined. +!! +!!#### Example +!! +!! ```fortran +!! program demo_xor +!! use stdlib_bitsets +!! type(bitset_large) :: set0, set1 +!! call set0 % init(166) +!! call set1 % init(166) +!! call xor( set0, set1 ) ! none none +!! if ( none(set0) ) write(*,*) 'First test of XOR worked.' +!! call set0 % not() +!! call xor( set0, set1 ) ! all none +!! if ( all(set0) ) write(*,*) 'Second test of XOR worked.' +!! call set0 % not() +!! call set1 % not() +!! call xor( set0, set1 ) ! none all +!! if ( all(set0) ) write(*,*) 'Third test of XOR worked.' +!! call set0 % not() +!! call xor( set0, set1 ) ! all all +!! if ( none(set0) ) write(*,*) 'Fourth test of XOR worked.' +!! end program demo_xor +!! + type(bitset_large), intent(inout) :: set1 + type(bitset_large), intent(in) :: set2 + end subroutine xor_large + + elemental module subroutine xor_64(set1, set2) +!! Version: experimental +!! +!! Sets the bits in `set1` to the bitwise `xor` of the original bits in `set1` +!! and `set2`. The sets must have the same number of bits +!! otherwise the result is undefined. + type(bitset_64), intent(inout) :: set1 + type(bitset_64), intent(in) :: set2 + end subroutine xor_64 + + end interface xor + + + interface operator(==) + + elemental module function eqv_large(set1, set2) result(eqv) +!! Version: experimental +!! +!! Returns `.true`. if all bits in `set1` and `set2` have the same value, +!! `.false.` otherwise. The sets must have the same number of bits +!! otherwise the result is undefined. +!! +!!#### Example +!! +!! ```fortran +!! program demo_equality +!! use stdlib_bitsets +!! type(bitset_64) :: set0, set1, set2 +!! call set0 % init( 33 ) +!! call set1 % init( 33 ) +!! call set2 % init( 33 ) +!! call set1 % set( 0 ) +!! call set2 % set( 32 ) +!! if ( set0 == set0 .and. set1 == set1 .and. set2 == set2 .and. & +!! .not. set0 == set1 .and. .not. set0 == set2 .and. .not. & +!! set1 == set2 ) then +!! write(*,*) 'Passed 64 bit equality tests.' +!! else +!! error stop 'Failed 64 bit equality tests.' +!! end if +!! end program demo_equality +!! + logical :: eqv + type(bitset_large), intent(in) :: set1, set2 + end function eqv_large + + elemental module function eqv_64(set1, set2) result(eqv) +!! Version: experimental +!! +!! Returns `.true`. if all bits in `set1` and `set2` have the same value, +!! `.false.` otherwise. The sets must have the same number of bits +!! otherwise the result is undefined. + logical :: eqv + type(bitset_64), intent(in) :: set1, set2 + end function eqv_64 + + end interface operator(==) + + + interface operator(/=) + + elemental module function neqv_large(set1, set2) result(neqv) +!! Version: experimental +!! +!! Returns `.true.` if not all bits in `set1` and `set2` have the same value, +!! `.false.` otherwise. The sets must have the same number of bits +!! otherwise the result is undefined. +!! +!!#### Example +!! +!! ```fortran +!! program demo_inequality +!! use stdlib_bitsets +!! type(bitset_64) :: set0, set1, set2 +!! call set0 % init( 33 ) +!! call set1 % init( 33 ) +!! call set2 % init( 33 ) +!! call set1 % set( 0 ) +!! call set2 % set( 32 ) +!! if ( set0 /= set1 .and. set0 /= set2 .and. set1 /= set2 .and. & +!! .not. set0 /= set0 .and. .not. set1 /= set1 .and. .not. & +!! set2 /= set2 ) then +!! write(*,*) 'Passed 64 bit inequality tests.' +!! else +!! error stop 'Failed 64 bit inequality tests.' +!! end if +!! end program demo_inequality +!! + logical :: neqv + type(bitset_large), intent(in) :: set1, set2 + end function neqv_large + + elemental module function neqv_64(set1, set2) result(neqv) +!! Version: experimental +!! +!! Returns `.true.` if not all bits in `set1` and `set2 have the same value, +!! `.false.` otherwise. The sets must have the same number of bits +!! otherwise the result is undefined. + logical :: neqv + type(bitset_64), intent(in) :: set1, set2 + end function neqv_64 + + end interface operator(/=) + + + interface operator(>) + + elemental module function gt_large(set1, set2) result(gt) +!! Version: experimental +!! +!! Returns `.true.` if the bits in `set1` and `set2` differ and the +!! highest order different bit is set to 1 in `set1` and to 0 in `set2`. +!! `.false.` otherwise. The sets must have the same number of bits +!! otherwise the result is undefined. +!! +!!#### Example +!! +!! ```fortran +!! program demo_gt +!! use stdlib_bitsets +!! type(bitset_64) :: set0, set1, set2 +!! call set0 % init( 33 ) +!! call set1 % init( 33 ) +!! call set2 % init( 33 ) +!! call set1 % set( 0 ) +!! call set2 % set( 32 ) +!! if ( set1 > set0 .and. set2 > set1 .and. set2 > set0 .and. & +!! .not. set0 > set0 .and. .not. set0 > set1 .and. .not. & +!! set1 > set2 ) then +!! write(*,*) 'Passed 64 bit greater than tests.' +!! else +!! error stop 'Failed 64 bit greater than tests.' +!! end if +!! end program demo_gt +!! + logical :: gt + type(bitset_large), intent(in) :: set1, set2 + end function gt_large + + elemental module function gt_64(set1, set2) result(gt) +!! Version: experimental +!! +!! Returns `.true.` if the bits in `set1` and `set2` differ and the +!! highest order different bit is set to 1 in `set1` and to 0 in `set2`. +!! `.false.` otherwise. The sets must have the same number of bits +!! otherwise the result is undefined. + logical :: gt + type(bitset_64), intent(in) :: set1, set2 + end function gt_64 + + end interface operator(>) + + + interface operator(>=) + + elemental module function ge_large(set1, set2) result(ge) +!! Version: experimental +!! +!! Returns `.true.` if the bits in `set1` and `set2` are the same or the +!! highest order different bit is set to 1 in `set1` and to 0 in `set2`. +!! `.false.` otherwise. The sets must have the same number of bits +!! otherwise the result is undefined. +!! +!!#### Example +!! +!! ```fortran +!! program demo_ge +!! use stdlib_bitsets +!! type(bitset_64) :: set0, set1, set2 +!! call set0 % init( 33 ) +!! call set1 % init( 33 ) +!! call set2 % init( 33 ) +!! call set1 % set( 0 ) +!! call set2 % set( 32 ) +!! if ( set1 >= set0 .and. set2 >= set1 .and. set2 >= set0 .and. & +!! set0 >= set0 .and. set1 >= set1 .and. set2 >= set2 .and. & +!! .not. set0 >= set1 .and. .not. set0 >= set2 .and. .not. & +!! set1 >= set2 ) then +!! write(*,*) 'Passed 64 bit greater than or equals tests.' +!! else +!! error stop 'Failed 64 bit greater than or equals tests.' +!! end if +!! end program demo_ge +!! + logical :: ge + type(bitset_large), intent(in) :: set1, set2 + end function ge_large + + elemental module function ge_64(set1, set2) result(ge) +!! Version: experimental +!! +!! Returns `.true.` if the bits in `set1` and `set2` are the same or the +!! highest order different bit is set to 1 in `set1` and to 0 in `set2`. +!! `.false.` otherwise. The sets must have the same number of bits +!! otherwise the result is undefined. + logical :: ge + type(bitset_64), intent(in) :: set1, set2 + end function ge_64 + + end interface operator(>=) + + + interface operator(<) + + elemental module function lt_large(set1, set2) result(lt) +!! Version: experimental +!! +!! Returns `.true.` if the bits in `set1` and `set2` differ and the +!! highest order different bit is set to 0 in `set1` and to 1 in `set2`. +!! `.false.` otherwise. The sets must have the same number of bits +!! otherwise the result is undefined. +!! +!!#### Example +!! +!! ```fortran +!! program demo_lt +!! use stdlib_bitsets +!! type(bitset_64) :: set0, set1, set2 +!! call set0 % init( 33 ) +!! call set1 % init( 33 ) +!! call set2 % init( 33 ) +!! call set1 % set( 0 ) +!! call set2 % set( 32 ) +!! if ( set0 < set1 .and. set1 < set2 .and. set0 < set2 .and. & +!! .not. set0 < set0 .and. .not. set2 < set0 .and. .not. & +!! set2 < set1 ) then +!! write(*,*) 'Passed 64 bit less than tests.' +!! else +!! error stop 'Failed 64 bit less than tests.' +!! end if +!! end program demo_lt +!! + logical :: lt + type(bitset_large), intent(in) :: set1, set2 + end function lt_large + + elemental module function lt_64(set1, set2) result(lt) +!! Version: experimental +!! +!! Returns `.true.` if the bits in `set1` and `set2` differ and the +!! highest order different bit is set to 0 in `set1` and to 1 in `set2`. +!! `.false.` otherwise. The sets must have the same number of bits +!! otherwise the result is undefined. + logical :: lt + type(bitset_64), intent(in) :: set1, set2 + end function lt_64 + + end interface operator(<) + + + interface operator(<=) + + elemental module function le_large(set1, set2) result(le) +!! Version: experimental +!! +!! Returns `.true.` if the bits in `set1` and `set2` are the same or the +!! highest order different bit is set to 0 in `set1` and to 1 in `set2`. +!! `.false.` otherwise. The sets must have the same number of bits +!! otherwise the result is undefined. +!! +!!#### Example +!! +!! ```fortran +!! program demo_le +!! use stdlib_bitsets +!! type(bitset_64) :: set0, set1, set2 +!! call set0 % init( 33 ) +!! call set1 % init( 33 ) +!! call set2 % init( 33 ) +!! call set1 % set( 0 ) +!! call set2 % set( 32 ) +!! if ( set0 <= set1 .and. set1 <= set2 .and. set0 <= set2 .and. & +!! set0 <= set0 .and. set1 <= set1 .and. set2 <= set2 .and. & +!! .not. set1 <= set0 .and. .not. set2 <= set0 .and. .not. & +!! set2 <= set1 ) then +!! write(*,*) 'Passed 64 bit less than or equal tests.' +!! else +!! error stop 'Failed 64 bit less than or equal tests.' +!! end if +!! end program demo_le +!! + logical :: le + type(bitset_large), intent(in) :: set1, set2 + end function le_large + + elemental module function le_64(set1, set2) result(le) +!! Version: experimental +!! +!! Returns `.true.` if the bits in `set1` and `set2` are the same or the +!! highest order different bit is set to 0 in `set1` and to 1 in `set2`. +!! `.false.` otherwise. The sets must have the same number of bits +!! otherwise the result is undefined. + logical :: le + type(bitset_64), intent(in) :: set1, set2 + end function le_64 + + end interface operator(<=) + +contains + + elemental function bits(self) +!! Version: experimental +!! +!! Returns the number of bit positions in `self`. + integer(bits_kind) :: bits + class(bitset_type), intent(in) :: self + + bits = self % num_bits + + return + end function bits + + +end module stdlib_bitsets From e35ebc74bcf2e5313dcbc77b271a1b116ba0b465 Mon Sep 17 00:00:00 2001 From: William Clodius Date: Tue, 29 Sep 2020 17:18:59 -0600 Subject: [PATCH 02/53] Prepared for testing of stdlib_bitsets Added tests/bitsets/test_stdlib_bitset*.f90, tests/bitsets/CMakeLists.txt, and tests/bitsets/Makefile.manual and modified tests/CMakeLists.txt and tests/Makefile.manual to compile the test programs. [ticket: X] --- src/tests/CMakeLists.txt | 1 + src/tests/Makefile.manual | 3 + src/tests/bitsets/CMakeLists.txt | 3 + src/tests/bitsets/Makefile.manual | 3 + src/tests/bitsets/test_stdlib_bitset_64.f90 | 744 +++++++++ .../bitsets/test_stdlib_bitset_large.f90 | 1476 +++++++++++++++++ 6 files changed, 2230 insertions(+) create mode 100644 src/tests/bitsets/CMakeLists.txt create mode 100644 src/tests/bitsets/Makefile.manual create mode 100644 src/tests/bitsets/test_stdlib_bitset_64.f90 create mode 100644 src/tests/bitsets/test_stdlib_bitset_large.f90 diff --git a/src/tests/CMakeLists.txt b/src/tests/CMakeLists.txt index 9e341d380..c3b09e34d 100644 --- a/src/tests/CMakeLists.txt +++ b/src/tests/CMakeLists.txt @@ -7,6 +7,7 @@ macro(ADDTEST name) endmacro(ADDTEST) add_subdirectory(ascii) +add_subdirectory(bitsets) add_subdirectory(io) add_subdirectory(linalg) add_subdirectory(logger) diff --git a/src/tests/Makefile.manual b/src/tests/Makefile.manual index 9b0227232..2fa5fbd27 100644 --- a/src/tests/Makefile.manual +++ b/src/tests/Makefile.manual @@ -2,6 +2,7 @@ all: $(MAKE) -f Makefile.manual --directory=ascii + $(MAKE) -f Makefile.manual --directory=bitsets $(MAKE) -f Makefile.manual --directory=io $(MAKE) -f Makefile.manual --directory=logger $(MAKE) -f Makefile.manual --directory=optval @@ -10,6 +11,7 @@ all: test: $(MAKE) -f Makefile.manual --directory=ascii test + $(MAKE) -f Makefile.manual --directoru=bitsets test $(MAKE) -f Makefile.manual --directory=io test $(MAKE) -f Makefile.manual --directory=logger test $(MAKE) -f Makefile.manual --directory=optval test @@ -18,6 +20,7 @@ test: clean: $(MAKE) -f Makefile.manual --directory=ascii clean + $(MAKE) -f Makefile.manual --directory=bitsets clean $(MAKE) -f Makefile.manual --directory=io clean $(MAKE) -f Makefile.manual --directory=logger clean $(MAKE) -f Makefile.manual --directory=optval clean diff --git a/src/tests/bitsets/CMakeLists.txt b/src/tests/bitsets/CMakeLists.txt new file mode 100644 index 000000000..519015e20 --- /dev/null +++ b/src/tests/bitsets/CMakeLists.txt @@ -0,0 +1,3 @@ +ADDTEST(stdlib_bitset_64) +ADDTEST(stdlib_bitset_large) + diff --git a/src/tests/bitsets/Makefile.manual b/src/tests/bitsets/Makefile.manual new file mode 100644 index 000000000..0ecba442e --- /dev/null +++ b/src/tests/bitsets/Makefile.manual @@ -0,0 +1,3 @@ +PROGS_SRC = test_stdlib_bitset_64.f90 test_stdlib_bitset_large.f90 + +include ../Makefile.manual.test.mk diff --git a/src/tests/bitsets/test_stdlib_bitset_64.f90 b/src/tests/bitsets/test_stdlib_bitset_64.f90 new file mode 100644 index 000000000..a71b3cd8b --- /dev/null +++ b/src/tests/bitsets/test_stdlib_bitset_64.f90 @@ -0,0 +1,744 @@ +program test_stdlib_bitset_64 + use, intrinsic :: iso_fortran_env, only : int8, int16, int32, int64 + use stdlib_bitsets + character(*), parameter :: & + bitstring_0 = '000000000000000000000000000000000', & + bitstring_33 = '100000000000000000000000000000000', & + bitstring_all = '111111111111111111111111111111111' + type(bitset_64) :: set0, set1, set2, set3, set4, set5 + integer :: status + character(:), allocatable :: string0 + + call test_string_operations() + + call test_io() + + call test_initialization() + + call test_bitset_inquiry() + + call test_bit_operations() + + call test_bitset_comparisons() + + call test_bitset_operations() + +contains + + subroutine test_string_operations() + character(*), parameter:: procedure = 'TEST_STRING_OPERATIONS' + + write(*,*) + write(*,*) 'Test string operations: from_string, read_bitset, ' // & + 'to_string, and write_bitset' + + call set0 % from_string( bitstring_0 ) + if ( bits(set0) /= 33 ) then + error stop procedure // ' from_string failed to interpret ' // & + 'bitstring_0 size properly.' + else if ( .not. set0 % none() ) then + error stop procedure // ' failed to interpret bitstring_0 ' // & + 'value properly.' + else if ( set0 % any() ) then + error stop procedure // ' failed to interpret bitstring_0 ' // & + 'value properly.' + else + write(*,*) 'from_string transferred bitstring_0 properly into set0' + end if + + call set1 % from_string( bitstring_all ) + if ( bits(set1) /= 33 ) then + error stop procedure // ' from_string failed to interpret ' // & + 'bitstring_all size properly.' + else if ( set1 % none() ) then + error stop procedure // ' failed to interpret bitstring_all ' // & + 'value properly.' + else if ( .not. set1 % any() ) then + error stop procedure // ' failed to interpret bitstring_all ' // & + 'value properly.' + else if ( .not. set1 % all() ) then + error stop procedure // ' failed to interpret bitstring_all ' // & + 'value properly.' + else + write(*,*) 'from_string transferred bitstring_all properly ' // & + 'into set1' + end if + + call set3 % read_bitset( bitstring_0, status ) + if ( status /= success ) then + write(*,*) 'read_bitset_string failed with bitstring_0 as expected.' + end if + + call set3 % read_bitset( 's33b' // bitstring_0, status ) + + if ( bits(set3) /= 33 ) then + error stop procedure // ' read_bitset_string failed to ' // & + 'interpret "s33b" // bitstring_0 size properly.' + else if ( .not. set3 % none() ) then + error stop procedure // ' failed to interpret "s33b" // ' // & + 'bitstring_0 value properly.' + else + write(*,*) 'read_bitset_string transferred "s33b" // ' // & + 'bitstring_0 properly into set3' + end if + + call set4 % read_bitset( 's33b' // bitstring_all ) + if ( bits(set4) /= 33 ) then + error stop procedure // ' read_bitset_string failed to ' // & + 'interpret "s33b" // bitstring_all size properly.' + else if ( set4 % none() ) then + error stop procedure // ' read_bitset_string failed to ' // & + 'interpret "s33b" // bitstring_all value properly.' + else if ( .not. set4 % any() ) then + error stop procedure // ' read_bitset_string failed to // ' // & + 'interpret "s33b" bitstring_all value properly.' + else if ( .not. set4 % all() ) then + error stop procedure // ' read_bitset_string failed to // ' // & + 'interpret "s33b" bitstring_all value properly.' + else + write(*,*) 'read_bitset_string transferred "s33b" // ' // & + 'bitstring_all properly into set4.' + end if + + call set0 % to_string( string0 ) + if ( bitstring_0 /= string0 ) then + error stop procedure // ' to_string failed to convert set0 ' // & + 'value properly.' + else + write(*,*) 'to_string properly converted the set0 value' + end if + + call set1 % to_string( string0 ) + if ( bitstring_all /= string0 ) then + error stop procedure // ' to_string failed to convert set1 ' // & + 'value properly.' + else + write(*,*) 'to_string properly converted the set1 value' + end if + + call set0 % write_bitset( string0 ) + if ( ('S33B' // bitstring_0) /= string0 ) then + error stop procedure // ' write_bitset_string failed to ' // & + 'convert set0 value properly.' + else + write(*,*) 'write_bitset_string properly converted the set0 value' + end if + + call set1 % write_bitset( string0 ) + if ( ('S33B' // bitstring_all) /= string0 ) then + error stop procedure // ' write_bitset_string failed to ' // & + 'convert set1 value properly.' + else + write(*,*) 'write_bitset_string properly converted the set1 value' + end if + + return + end subroutine test_string_operations + + subroutine test_io() + character(*), parameter:: procedure = 'TEST_IO' + + integer :: unit + + write(*,*) + write(*,*) 'Test bitset I/O: input, read_bitset, output, and ' // & + 'write_bitset' + + call set2 % from_string( bitstring_33 ) + open( newunit=unit, file='test.txt', status='replace', & + form='formatted', action='write' ) + call set2 % write_bitset(unit) + call set1 % write_bitset(unit) + call set0 % write_bitset(unit) + close( unit ) + open( newunit=unit, file='test.txt', status='old', & + form='formatted', action='read' ) + call set3 % read_bitset(unit) + call set5 % read_bitset(unit) + call set4 % read_bitset(unit) + + if ( set4 /= set0 .or. set5 /= set1 .or. set3 /= set2 ) then + error stop procedure // ' transfer to and from units using ' // & + 'bitset literals failed.' + else + write(*,*) 'Transfer to and from units using ' // & + 'plain write_bitset_unit and read_bitset_unit succeeded.' + end if + + close( unit ) + + open( newunit=unit, file='test.txt', status='replace', & + form='formatted', action='write' ) + call set2 % write_bitset(unit, advance='no') + call set1 % write_bitset(unit, advance='no') + call set0 % write_bitset(unit) + close( unit ) + open( newunit=unit, file='test.txt', status='old', & + form='formatted', action='read' ) + call set3 % read_bitset(unit, advance='no') + call set4 % read_bitset(unit, advance='no') + call set5 % read_bitset(unit) + + if ( set5 /= set0 .or. set4 /= set1 .or. set3 /= set2 ) then + error stop procedure // ' transfer to and from units using ' // & + ' bitset literals with advance == "no" failed.' + else + write(*,*) 'Transfer to and from units using ' // & + 'write_bitset_unit and read_bitset_unit with ' // & + 'advance=="no" succeeded.' + end if + + open( newunit=unit, file='test.bin', status='replace', & + form='unformatted', action='write' ) + call set2 % output(unit) + call set1 % output(unit) + call set0 % output(unit) + close( unit ) + open( newunit=unit, file='test.bin', status='old', & + form='unformatted', action='read' ) + call set5 % input(unit) + call set4 % input(unit) + call set3 % input(unit) + close( unit ) + + if ( set3 /= set0 .or. set4 /= set1 .or. set5 /= set2 ) then + error stop procedure // ' transfer to and from units using ' // & + ' output and input failed.' + else + write(*,*) 'Transfer to and from units using ' // & + 'output and input succeeded.' + end if + + end subroutine test_io + + subroutine test_initialization() + character(*), parameter:: procedure = 'TEST_INITIALIZATION' + logical(int8) :: log1(64) = .true. + logical(int16) :: log2(31) = .false. + logical(int32) :: log3(15) = .true. + logical(int64) :: log4(33) = .false. + logical(int8), allocatable :: log5(:) + logical(int16), allocatable :: log6(:) + logical(int32), allocatable :: log7(:) + logical(int64), allocatable :: log8(:) + + write(*,*) + write(*,*) 'Test initialization: assignment, extract, and init' + + set5 = log1 + if ( set5 % bits() /= 64 ) then + error stop procedure // & + ' initialization with logical(int8) failed to set' // & + ' the right size.' + else if ( .not. set5 % all() ) then + error stop procedure // ' initialization with' // & + ' logical(int8) failed to set the right values.' + else + write(*,*) 'Initialization with logical(int8) succeeded.' + end if + + set5 = log2 + if ( set5 % bits() /= 31 ) then + error stop procedure // & + ' initialization with logical(int16) failed to set' // & + ' the right size.' + else if ( .not. set5 % none() ) then + error stop procedure // & + ' initialization with logical(int16) failed to set' // & + ' the right values.' + else + write(*,*) 'Initialization with logical(int16) succeeded.' + end if + + set5 = log3 + if ( set5 % bits() /= 15 ) then + error stop procedure // & + ' initialization with logical(int32) failed to set' // & + ' the right size.' + else if ( .not. set5 % all() ) then + error stop procedure // & + ' initialization with logical(int32) failed to set' // & + ' the right values.' + else + write(*,*) 'Initialization with logical(int32) succeeded.' + end if + + set5 = log4 + if ( set5 % bits() /= 33 ) then + error stop procedure // & + ' initialization with logical(int64) failed to set' // & + ' the right size.' + else if ( .not. set5 % none() ) then + error stop procedure // & + ' initialization with logical(int64) failed to set' // & + ' the right values.' + else + write(*,*) 'Initialization with logical(int64) succeeded.' + end if + + set5 = log1 + call extract( set4, set5, 1, 33 ) + if ( set4 % bits() /= 33 ) then + error stop procedure // & + ' initialization with extract failed to set' // & + ' the right size.' + else if ( .not. set4 % all() ) then + error stop procedure // & + ' initialization with extract failed to set' // & + ' the right values.' + else + write(*,*) 'Initialization with extract succeeded.' + end if + + set4 = set5 + if ( set4 % bits() /= 64 ) then + write(*,*) 'Bits = ', set4 % bits() + error stop procedure // & + ' initialization with simple assignment failed to set' // & + ' the right size.' + else if ( .not. set4 % all() ) then + error stop procedure // & + ' initialization with simple assignment failed to set' // & + ' the right values.' + else + write(*,*) 'Initialization with simple assignment succeeded.' + end if + + log5 = set5 + if ( size(log5) /= 64 ) then + error stop procedure // & + ' initialization of logical(int8) with assignment failed' // & + ' to set the right size.' + else if ( .not. all(log5) ) then + error stop procedure // & + ' initialization of logical(int8) with assignment failed' // & + ' to set the right values.' + else + write(*,*) 'Initialization of logical(int8) succeeded.' + end if + + log6 = set5 + if ( size(log6) /= 64 ) then + error stop procedure // & + ' initialization of logical(int16) with assignment failed' // & + ' to set the right size.' + else if ( .not. all(log6) ) then + error stop procedure // & + ' initialization of logical(int16) with assignment failed' // & + ' to set the right values.' + else + write(*,*) 'Initialization of logical(int16) succeeded.' + end if + + log7 = set5 + if ( size(log7) /= 64 ) then + error stop procedure // & + ' initialization of logical(int32) with assignment failed' // & + ' to set the right size.' + else if ( .not. all(log7) ) then + error stop procedure // & + ' initialization of logical(int32) with assignment failed' // & + ' to set the right values.' + else + write(*,*) 'Initialization of logical(int32) succeeded.' + end if + + log8 = set5 + if ( size(log8) /= 64 ) then + error stop procedure // & + ' initialization of logical(int64) with assignment failed' // & + ' to set the right size.' + else if ( .not. all(log8) ) then + error stop procedure // & + ' initialization of logical(int64) with assignment failed' // & + ' to set the right values.' + else + write(*,*) 'Initialization of logical(int64) succeeded.' + end if + + end subroutine test_initialization + + subroutine test_bitset_inquiry() + character(*), parameter:: procedure = 'TEST_BITSET_INQUIRY' + integer :: i + + write(*,*) + write(*,*) 'Test bitset inquiry: all, any, bits, none, test, and value' + + if ( set0 % none() ) then + if ( .not. set0 % any() ) then + write(*,*) 'As expected set0 has no bits set' + else + error stop procedure // ' set0 had some bits set which ' // & + 'was unexpected.' + end if + else + error stop procedure // ' set0 did not have none set which ' // & + 'was unexpected' + end if + + call set0 % not() + if ( set0 % all() ) then + if ( set0 % any() ) then + write(*,*) 'As expected set0 now has all bits set' + else + error stop procedure // ' set0 had no bits set which ' // & + 'was unexpected.' + end if + else + error stop procedure // ' set0 did not have all bits set ' // & + 'which was unexpected' + end if + + if ( set1 % any() ) then + if ( set1 % all() ) then + write(*,*) 'As expected set1 has all bits set' + else + error stop procedure // ' set1 did not have all bits set ' // & + 'which was unexpected.' + end if + else + error stop procedure // ' set1 had no bits set ' // & + 'which was unexpected' + end if + + call set0 % not() + do i=0, set0 % bits() - 1 + if ( set0 % test(i) ) go to 100 + end do + + write(*,*) 'As expected set0 had no bits set.' + + go to 110 + +100 error stop procedure // ' against expectations set0 has ' // & + 'at least 1 bit set.' + +110 continue + + do i=0, set1 % bits() - 1 + if ( .not. set1 % test(i) ) go to 200 + end do + + write(*,*) 'As expected set1 had all bits set.' + + go to 210 + +200 error stop procedure // ' against expectations set1 has ' // & + 'at least 1 bit unset.' +210 continue + + do i=0, set0 % bits() - 1 + if ( set0 % value(i) /= 0 ) go to 300 + end do + + write(*,*) 'As expected set0 had no bits set.' + + go to 310 + +300 error stop procedure // ' against expectations set0 has ' // & + 'at least 1 bit set.' + +310 continue + + do i=0, set1 % bits() - 1 + if ( set1 % value(i) /= 1 ) go to 400 + end do + + write(*,*) 'As expected set1 had all bits set.' + + go to 410 + +400 error stop procedure // ' against expectations set1 has ' // & + 'at least 1 bit unset.' + +410 continue + + if ( set0 % bits() == 33 ) then + write(*,*) 'set0 has 33 bits as expected.' + else + error stop procedure // 'set0 unexpectedly does not have 33 bits.' + end if + + end subroutine test_bitset_inquiry + + subroutine test_bit_operations() + character(*), parameter:: procedure = 'TEST_BIT_OPERATIONS' + + write(*,*) + write(*,*) 'Test bit operations: clear, flip, not, and set' + + if ( .not. set1 % all() ) then + error stop procedure // ' set1 is not all set.' + end if + + call set1 % clear(0) + if ( .not. set1 % test(0) ) then + if ( set1 % test(1) ) then + write(*,*) 'Cleared one bit in set1 as expected.' + else + error stop procedure // ' cleared more than one bit in set1.' + end if + else + error stop procedure // ' did not clear the first bit in set1.' + end if + + call set1 % clear(1, 32) + if ( set1 % none() ) then + write(*,*) 'Cleared remaining bits in set1 as expected.' + else + error stop procedure // ' did not clear remaining bits ' // & + 'in set1.' + end if + + call set1 % flip(0) + if ( set1 % test(0) ) then + if ( .not. set1 % test(1) ) then + write(*,*) 'Flipped one bit in set1 as expected.' + else + error stop procedure // ' flipped more than one bit in set1.' + end if + else + error stop procedure // ' did not flip the first bit in set1.' + end if + + call set1 % flip(1, 32) + if ( set1 % all() ) then + write(*,*) 'Flipped remaining bits in set1 as expected.' + else + error stop procedure // ' did not flip remaining bits ' // & + 'in set1.' + end if + + call set1 % not() + if ( set1 % none() ) then + write(*,*) 'Unset bits in set1 as expected.' + else + error stop procedure // ' did not unset bits in set1.' + end if + + call set1 % set(0) + if ( set1 % test(0) ) then + if ( .not. set1 % test(1) ) then + write(*,*) 'Set first bit in set1 as expected.' + else + error stop procedure // ' set more than one bit in set1.' + end if + else + error stop procedure // ' did not set the first bit in set1.' + end if + + call set1 % set(1, 32) + if ( set1 % all() ) then + write(*,*) 'Set the remaining bits in set1 as expected.' + else + error stop procedure // ' did not set the remaining bits ' // & + 'in set1.' + end if + + end subroutine test_bit_operations + + subroutine test_bitset_comparisons() + character(*), parameter:: procedure = 'TEST_BITSET_COMPARISON' + + write(*,*) + write(*,*) 'Test bitset comparisons: ==, /=, <, <=, >, and >=' + + if ( set0 == set0 .and. set1 == set1 .and. set2 == set2 .and. & + .not. set0 == set1 .and. .not. set0 == set2 .and. .not. & + set1 == set2 ) then + write(*,*) 'Passed 64 bit equality tests.' + else + error stop procedure // ' failed 64 bit equality tests.' + end if + + if ( set0 /= set1 .and. set1 /= set2 .and. set0 /= set2 .and. & + .not. set0 /= set0 .and. .not. set1 /= set1 .and. .not. & + set2 /= set2 ) then + write(*,*) 'Passed 64 bit inequality tests.' + else + error stop procedure // ' failed 64 bit inequality tests.' + end if + + if ( set1 > set0 .and. set2 > set0 .and. set1 > set2 .and. & + .not. set0 > set1 .and. .not. set1 > set1 .and. .not. & + set2 > set1 ) then + write(*,*) 'Passed 64 bit greater than tests.' + else + error stop procedure // ' failed 64 bit greater than tests.' + end if + + if ( set1 >= set0 .and. set1 >= set2 .and. set2 >= set2 .and. & + .not. set0 >= set1 .and. .not. set0 >= set1 .and. .not. & + set2 >= set1 ) then + write(*,*) 'Passed 64 bit greater than or equal tests.' + else + error stop procedure // ' failed 64 bit greater than or ' // & + 'equal tests.' + end if + + if ( set0 < set1 .and. set0 < set1 .and. set2 < set1 .and. & + .not. set1 < set0 .and. .not. set0 < set0 .and. .not. & + set1 < set2 ) then + write(*,*) 'Passed 64 bit less than tests.' + else + error stop procedure // ' failed 64 bit less than tests.' + end if + + if ( set0 <= set1 .and. set2 <= set1 .and. set2 <= set2 .and. & + .not. set1 <= set0 .and. .not. set2 <= set0 .and. .not. & + set1 <= set2 ) then + write(*,*) 'Passed 64 bit less than or equal tests.' + else + error stop procedure // ' failed 64 bit less than or ' // & + 'equal tests.' + end if + + end subroutine test_bitset_comparisons + + subroutine test_bitset_operations() + character(*), parameter:: procedure = 'TEST_BITSET_OPERATIONS' + + write(*,*) + write(*,*) 'Test bitset operations: and, and_not, or, and xor' + + call set0 % from_string( bitstring_all ) + call set4 % from_string( bitstring_all ) + call and( set0, set4 ) ! all all + if ( set0 % all() ) then + write(*,*) 'First test of AND worked.' + else + error stop procedure // ' first test of AND failed.' + end if + + call set4 % from_string( bitstring_0 ) + call set3 % from_string( bitstring_all ) + call and( set3, set4 ) ! all none + if ( set3 % none() ) then + write(*,*) 'Second test of AND worked.' + else + error stop procedure // ' second test of AND failed.' + end if + + call set3 % from_string( bitstring_all ) + call set4 % from_string( bitstring_0 ) + call and( set4, set3 ) ! none all + if ( set4 % none() ) then + write(*,*) 'Third test of AND worked.' + else + error stop procedure // ' third test of AND failed.' + end if + + call set3 % from_string( bitstring_0 ) + call and( set4, set3 ) ! none none + if ( set4 % none() ) then + write(*,*) 'Fourth test of AND worked.' + else + error stop procedure // ' fourth test of AND failed.' + end if + + call set3 % from_string( bitstring_all ) + call set4 % from_string( bitstring_all ) + call and_not( set4, set3 ) ! all all + if ( set4 % none() ) then + write(*,*) 'First test of AND_NOT worked.' + else + error stop procedure // ' first test of AND_NOT failed.' + end if + + call set4 % from_string( bitstring_0 ) + call and_not( set4, set3 ) ! none all + if ( set4 % none() ) then + write(*,*) 'Second test of AND_NOT worked.' + else + error stop procedure // ' second test of AND_NOT failed.' + end if + + call set3 % from_string( bitstring_all ) + call set4 % from_string( bitstring_0 ) + call and_not( set3, set4 ) ! all none + if ( set3 % all() ) then + write(*,*) 'Third test of AND_NOT worked.' + else + error stop procedure // ' third test of AND_NOT failed.' + end if + + call set3 % from_string( bitstring_0 ) + call set4 % from_string( bitstring_0 ) + call and_not( set3, set4 ) ! none none + if ( set3 % none() ) then + write(*,*) 'Fourth test of AND_NOT worked.' + else + error stop procedure // ' fourth test of AND_NOT failed.' + end if + + call set3 % from_string( bitstring_all ) + call set4 % from_string( bitstring_all ) + call or( set3, set4 ) ! all all + if ( set3 % all() ) then + write(*,*) 'First test of OR worked.' + else + error stop procedure // ' first test of OR failed.' + end if + + call set3 % from_string( bitstring_0 ) + call or( set4, set3 ) ! all none + if ( set4 % all() ) then + write(*,*) 'Second test of OR worked.' + else + error stop procedure // ' second test of OR failed.' + end if + + call or( set3, set4 ) ! none all + if ( set3 % all() ) then + write(*,*) 'Third test of OR worked.' + else + error stop procedure // ' third test of OR failed.' + end if + + call set3 % from_string( bitstring_0 ) + call set4 % from_string( bitstring_0 ) + call or( set4, set3 ) !none none + if ( set4 % none() ) then + write(*,*) 'Fourth test of OR worked.' + else + error stop procedure // ' fourth test of OR failed.' + end if + + call set3 % from_string( bitstring_0 ) + call set4 % from_string( bitstring_0 ) + call xor( set3, set4 ) ! none none + if ( set3 % none() ) then + write(*,*) 'First test of XOR worked.' + else + error stop procedure // ' first test of XOR failed.' + end if + + call set4 % from_string( bitstring_all ) + call xor( set3, set4 ) ! none all + if ( set3 % all() ) then + write(*,*) 'Second test of XOR worked.' + else + error stop procedure // ' second test of XOR failed.' + end if + + call set4 % from_string( bitstring_0 ) + call xor( set3, set4 ) ! all none + if ( set3 % all() ) then + write(*,*) 'Third test of XOR worked.' + else + error stop procedure // ' third test of XOR failed.' + end if + + call set4 % from_string( bitstring_all ) + call xor( set3, set4 ) ! all all + if ( set3 % none() ) then + write(*,*) 'Fourth test of XOR worked.' + else + error stop procedure // ' fourth test of XOR failed.' + end if + + end subroutine test_bitset_operations + + +end program test_stdlib_bitset_64 diff --git a/src/tests/bitsets/test_stdlib_bitset_large.f90 b/src/tests/bitsets/test_stdlib_bitset_large.f90 new file mode 100644 index 000000000..dec05bb09 --- /dev/null +++ b/src/tests/bitsets/test_stdlib_bitset_large.f90 @@ -0,0 +1,1476 @@ +program test_stdlib_bitset_large + use, intrinsic :: iso_fortran_env, only : int8, int16, int32, int64 + use stdlib_bitsets + implicit none + character(*), parameter :: & + bitstring_0 = '000000000000000000000000000000000', & + bitstring_33 = '100000000000000000000000000000000', & + bitstring_all = '111111111111111111111111111111111' + type(bitset_large) :: set0, set1, set2, set3, set4, set5 + type(bitset_large) :: set10, set11, set12, set13, set14, set15 + integer :: status + character(:), allocatable :: string0 + + call test_string_operations() + + call test_io() + + call test_initialization() + + call test_bitset_inquiry() + + call test_bit_operations() + + call test_bitset_comparisons() + + call test_bitset_operations() + +contains + + subroutine test_string_operations() + character(*), parameter:: procedure = 'TEST_STRING_OPERATIONS' + + write(*,*) + write(*,*) 'Test string operations: from_string, read_bitset, ' // & + 'to_string, and write_bitset' + + call set0 % from_string( bitstring_0 ) + if ( bits(set0) /= 33 ) then + error stop procedure // ' from_string failed to interpret ' // & + 'bitstring_0 size properly.' + else if ( .not. set0 % none() ) then + error stop procedure // ' failed to interpret bitstring_0 ' // & + 'value properly.' + else if ( set0 % any() ) then + error stop procedure // ' failed to interpret bitstring_0 ' // & + 'value properly.' + else + write(*,*) 'from_string transferred bitstring_0 properly into set0' + end if + + call set10 % from_string( bitstring_0 // bitstring_0 ) + if ( bits(set10) /= 66 ) then + error stop procedure // ' from_string failed to interpret ' // & + 'bitstring_0 // bitstring_0 size properly.' + else if ( .not. set10 % none() ) then + error stop procedure // ' failed to interpret bitstring_0 ' // & + '// bitstring_0 value properly.' + else if ( set10 % any() ) then + error stop procedure // ' failed to interpret bitstring_0 ' // & + '// bitstring_0 value properly.' + else + write(*,*) 'from_string transferred bitstring_0//bitstring_0' // & + ' properly into set10' + end if + + call set1 % from_string( bitstring_all ) + if ( bits(set1) /= 33 ) then + error stop procedure // ' from_string failed to interpret ' // & + 'bitstring_all size properly.' + else if ( set1 % none() ) then + error stop procedure // ' failed to interpret bitstring_all ' // & + 'value properly.' + else if ( .not. set1 % any() ) then + error stop procedure // ' failed to interpret bitstring_all ' // & + 'value properly.' + else if ( .not. set1 % all() ) then + error stop procedure // ' failed to interpret bitstring_all ' // & + 'value properly.' + else + write(*,*) 'from_string transferred bitstring_1 properly into set1' + end if + + call set11 % from_string( bitstring_all // bitstring_all ) + if ( bits(set11) /= 66 ) then + error stop procedure // ' from_string failed to interpret ' // & + 'bitstring_all // bitstring_all size properly.' + else if ( set11 % none() ) then + error stop procedure // ' failed to interpret bitstring_all ' // & + '// bitstring_all value properly.' + else if ( .not. set11 % any() ) then + error stop procedure // ' failed to interpret bitstring_all ' // & + '// bitstring_all value properly.' + else if ( .not. set11 % all() ) then + error stop procedure // ' failed to interpret bitstring_all ' // & + '// bitstring_all value properly.' + else + write(*,*) 'from_string transferred bitstring_all // ' // & + 'bitstring_all properly into set11' + end if + + call set3 % read_bitset( bitstring_0, status ) + if ( status /= success ) then + write(*,*) 'read_bitset_string failed with bitstring_0 as expected.' + end if + + call set13 % read_bitset( bitstring_0 // bitstring_0, status ) + if ( status /= success ) then + write(*,*) 'read_bitset_string failed with bitstring_0 ' // & + '// bitstring_0 as expected.' + end if + + call set3 % read_bitset( 's33b' // bitstring_0, status ) + if ( bits(set3) /= 33 ) then + error stop procedure // ' read_bitset_string failed to ' // & + 'interpret "s33b" // bitstring_0 size properly.' + else if ( .not. set3 % none() ) then + error stop procedure // ' failed to interpret "s33b" // ' // & + 'bitstring_0 value properly.' + else + write(*,*) 'read_bitset_string transferred "s33b" // ' // & + 'bitstring_0 properly into set3' + end if + + call set13 % read_bitset( 's66b' // bitstring_0 // bitstring_0, & + status ) + if ( bits(set13) /= 66 ) then + error stop procedure // ' read_bitset_string failed to ' // & + 'interpret "s66b" // bitstring_0 // bitstring_0 size properly.' + else if ( .not. set13 % none() ) then + error stop procedure // ' failed to interpret "s66b" // ' // & + 'bitstring_0 // bitstring_0 value properly.' + else + write(*,*) 'read_bitset_string transferred "s66b" // ' // & + 'bitstring_0 // bitstring_0 properly into set13' + end if + + call set4 % read_bitset( 's33b' // bitstring_all ) + if ( bits(set4) /= 33 ) then + error stop procedure // ' read_bitset_string failed to ' // & + 'interpret "s33b" // bitstring_all size properly.' + else if ( set4 % none() ) then + error stop procedure // ' read_bitset_string failed to ' // & + 'interpret "s33b" // bitstring_all value properly.' + else if ( .not. set4 % any() ) then + error stop procedure // ' read_bitset_string failed to // ' // & + 'interpret "s33b" bitstring_all value properly.' + else if ( .not. set4 % all() ) then + error stop procedure // ' read_bitset_string failed to // ' // & + 'interpret "s33b" bitstring_all value properly.' + else + write(*,*) 'read_bitset_string transferred "s33b" // ' // & + 'bitstring_all properly into set4.' + end if + + call set14 % read_bitset( 's66b' // bitstring_all & + // bitstring_all ) + if ( bits(set14) /= 66 ) then + error stop procedure // ' read_bitset_string failed to ' // & + 'interpret "s66b" // bitstring_all // bitstring_all ' // & + 'size properly.' + else if ( set14 % none() ) then + error stop procedure // ' read_bitset_string failed to ' // & + 'interpret "s66b" // bitstring_all // bitstring_all ' // & + 'value properly.' + else if ( .not. set14 % any() ) then + error stop procedure // ' read_bitset_string failed to // ' // & + 'interpret "s66b" bitstring_all // bitstring_all ' // & + 'value properly.' + else if ( .not. set14 % all() ) then + error stop procedure // ' read_bitset_string failed to // ' // & + 'interpret "s66b" bitstring_all // bitstring_all ' // & + 'value properly.' + else + write(*,*) 'read_bitset_string transferred "s66b" // ' // & + 'bitstring_all // bitstring_all properly into set14.' + end if + + call set0 % to_string( string0 ) + if ( bitstring_0 /= string0 ) then + error stop procedure // ' to_string failed to convert set0 ' // & + 'value properly.' + else + write(*,*) 'to_string properly converted the set0 value' + end if + + call set10 % to_string( string0 ) + if ( bitstring_0 // bitstring_0 /= string0 ) then + error stop procedure // ' to_string failed to convert set10 ' // & + 'value properly.' + else + write(*,*) 'to_string properly converted the set10 value' + end if + + call set1 % to_string( string0 ) + if ( bitstring_all /= string0 ) then + error stop procedure // ' to_string failed to convert set1 ' // & + 'value properly.' + else + write(*,*) 'to_string properly converted the set1 value' + end if + + call set11 % to_string( string0 ) + if ( bitstring_all // bitstring_all /= string0 ) then + error stop procedure // ' to_string failed to convert set11 ' // & + 'value properly.' + else + write(*,*) 'to_string properly converted the set11 value' + end if + + call set0 % write_bitset( string0 ) + if ( ('S33B' // bitstring_0) /= string0 ) then + error stop procedure // ' write_bitset_string failed to ' // & + 'convert set2 value properly.' + else + write(*,*) 'write_bitset_string properly converted the set0 value' + end if + + call set10 % write_bitset( string0 ) + if ( ('S66B' // bitstring_0 // bitstring_0) /= string0 ) then + error stop procedure // ' write_bitset_string failed to ' // & + 'convert set10 value properly.' + else + write(*,*) 'write_bitset_string properly converted the set10 value' + end if + + call set1 % write_bitset( string0 ) + if ( ('S33B' // bitstring_all) /= string0 ) then + error stop procedure // ' write_bitset_string failed to ' // & + 'convert set1 value properly.' + else + write(*,*) 'write_bitset_string properly converted the set1 value' + end if + + call set11 % write_bitset( string0 ) + if ( ('S66B' // bitstring_all // bitstring_all) /= string0 ) then + error stop procedure // ' write_bitset_string failed to ' // & + 'convert set11 value properly.' + else + write(*,*) 'write_bitset_string properly converted the set11 value' + end if + + return + end subroutine test_string_operations + + subroutine test_io() + character(*), parameter:: procedure = 'TEST_IO' + + integer :: unit + + write(*,*) + write(*,*) 'Test bitset I/O: input, read_bitset, output, and ' // & + 'write_bitset' + + call set2 % from_string( bitstring_33 ) + open( newunit=unit, file='test.txt', status='replace', & + form='formatted', action='write' ) + call set2 % write_bitset(unit) + call set1 % write_bitset(unit) + call set0 % write_bitset(unit) + close( unit ) + open( newunit=unit, file='test.txt', status='old', & + form='formatted', action='read' ) + call set3 % read_bitset(unit) + call set5 % read_bitset(unit) + call set4 % read_bitset(unit) + if ( set4 /= set0 .or. set5 /= set1 .or. set3 /= set2 ) then + error stop procedure // ' transfer to and from units using ' // & + ' bitset literals failed.' + else + write(*,*) 'Transfer to and from units using ' // & + 'plain write_bitset_unit and read_bitset_unit succeeded.' + end if + + close( unit ) + + call set12 % from_string( bitstring_33 // bitstring_33 ) + open( newunit=unit, file='test.txt', status='replace', & + form='formatted', action='write' ) + call set12 % write_bitset(unit) + call set11 % write_bitset(unit) + call set10 % write_bitset(unit) + close( unit ) + open( newunit=unit, file='test.txt', status='old', & + form='formatted', action='read' ) + call set13 % read_bitset(unit) + call set15 % read_bitset(unit) + call set14 % read_bitset(unit) + if ( set14 /= set10 .or. set15 /= set11 .or. set3 /= set12 ) then + error stop procedure // ' transfer to and from units using ' // & + ' bitset literals for bits > 64 failed.' + else + write(*,*) 'Transfer bits > 64 to and from units using ' // & + 'plain write_bitset_unit and read_bitset_unit succeeded.' + end if + + close( unit ) + + open( newunit=unit, file='test.txt', status='replace', & + form='formatted', action='write' ) + call set2 % write_bitset(unit, advance='no') + call set1 % write_bitset(unit, advance='no') + call set0 % write_bitset(unit) + close( unit ) + open( newunit=unit, file='test.txt', status='old', & + form='formatted', action='read' ) + call set3 % read_bitset(unit, advance='no') + call set4 % read_bitset(unit, advance='no') + call set5 % read_bitset(unit) + if ( set5 /= set0 .or. set4 /= set1 .or. set3 /= set2 ) then + error stop procedure // ' transfer to and from units using ' // & + ' bitset literals with advance == "no" failed.' + else + write(*,*) 'Transfer to and from units using ' // & + 'write_bitset_unit and read_bitset_unit with ' // & + 'advance=="no" succeeded.' + end if + + close( unit ) + + open( newunit=unit, file='test.txt', status='replace', & + form='formatted', action='write' ) + call set12 % write_bitset(unit, advance='no') + call set11 % write_bitset(unit, advance='no') + call set10 % write_bitset(unit) + close( unit ) + open( newunit=unit, file='test.txt', status='old', & + form='formatted', action='read' ) + call set13 % read_bitset(unit, advance='no') + call set14 % read_bitset(unit, advance='no') + call set15 % read_bitset(unit) + if ( set15 /= set10 .or. set14 /= set11 .or. set13 /= set12 ) then + error stop procedure // ' transfer to and from units using ' // & + ' bitset literals for bitss > 64 with advance == "no" failed.' + else + write(*,*) 'Transfer bits > 64 to and from units using ' // & + 'write_bitset_unit and read_bitset_unit with ' // & + 'advance=="no" succeeded.' + end if + + open( newunit=unit, file='test.bin', status='replace', & + form='unformatted', action='write' ) + call set2 % output(unit) + call set1 % output(unit) + call set0 % output(unit) + close( unit ) + open( newunit=unit, file='test.bin', status='old', & + form='unformatted', action='read' ) + call set5 % input(unit) + call set4 % input(unit) + call set3 % input(unit) + if ( set3 /= set0 .or. set4 /= set1 .or. set5 /= set2 ) then + error stop procedure // ' transfer to and from units using ' // & + ' output and input failed.' + else + write(*,*) 'Transfer to and from units using ' // & + 'output and input succeeded.' + end if + + close( unit ) + + open( newunit=unit, file='test.bin', status='replace', & + form='unformatted', action='write' ) + call set12 % output(unit) + call set11 % output(unit) + call set10 % output(unit) + close( unit ) + open( newunit=unit, file='test.bin', status='old', & + form='unformatted', action='read' ) + call set15 % input(unit) + call set14 % input(unit) + call set13 % input(unit) + if ( set13 /= set10 .or. set14 /= set11 .or. set15 /= set12 ) then + error stop procedure // ' transfer to and from units using ' // & + ' output and input failed for bits . 64.' + else + write(*,*) 'Transfer to and from units using ' // & + 'output and input succeeded for bits > 64.' + end if + + end subroutine test_io + + subroutine test_initialization() + character(*), parameter:: procedure = 'TEST_INITIALIZATION' + logical(int8) :: log1(64) = .true. + logical(int16) :: log2(31) = .false. + logical(int32) :: log3(15) = .true. + logical(int64) :: log4(33) = .false. + logical(int8) :: log11(66) = .true. + logical(int16) :: log12(99) = .false. + logical(int32) :: log13(132) = .true. + logical(int64) :: log14(165) = .false. + logical(int8), allocatable :: log5(:) + logical(int16), allocatable :: log6(:) + logical(int32), allocatable :: log7(:) + logical(int64), allocatable :: log8(:) + + write(*,*) + write(*,*) 'Test initialization: assignment, extract, and init' + + set5 = log1 + if ( set5 % bits() /= 64 ) then + error stop procedure // & + ' initialization with logical(int8) failed to set' // & + ' the right size.' + else if ( .not. set5 % all() ) then + error stop procedure // ' initialization with' // & + ' logical(int8) failed to set the right values.' + else + write(*,*) 'Initialization with logical(int8) succeeded.' + end if + + set5 = log11 + if ( set5 % bits() /= 66 ) then + error stop procedure // & + ' initialization with logical(int8) failed to set' // & + ' the right size > 64 bits.' + else if ( .not. set5 % all() ) then + error stop procedure // ' initialization with' // & + ' logical(int8) failed to set the right values.' + else + write(*,*) 'Initialization > 64 bits with logical(int8)succeeded.' + end if + + set5 = log2 + if ( set5 % bits() /= 31 ) then + error stop procedure // & + ' initialization with logical(int16) failed to set' // & + ' the right size.' + else if ( .not. set5 % none() ) then + error stop procedure // & + ' initialization with logical(int16) failed to set' // & + ' the right values.' + else + write(*,*) 'Initialization with logical(int16) succeeded.' + end if + + set5 = log12 + if ( set5 % bits() /= 99 ) then + error stop procedure // & + ' initialization with logical(int16) failed to set' // & + ' the right size > 64 bits .' + else if ( .not. set5 % none() ) then + error stop procedure // & + ' initialization with logical(int16) failed to set' // & + ' the right values > 64 bits .' + else + write(*,*) 'Initialization > 64 bits with logical(int16) ' // & + 'succeeded.' + end if + + set5 = log3 + if ( set5 % bits() /= 15 ) then + error stop procedure // & + ' initialization with logical(int32) failed to set' // & + ' the right size.' + else if ( .not. set5 % all() ) then + error stop procedure // & + ' initialization with logical(int32) failed to set' // & + ' the right values.' + else + write(*,*) 'Initialization with logical(int32) succeeded.' + end if + + set5 = log13 + if ( set5 % bits() /= 132 ) then + error stop procedure // & + ' initialization with logical(int32) failed to set' // & + ' the right size > 64 bits .' + else if ( .not. set5 % all() ) then + error stop procedure // & + ' initialization with logical(int32) failed to set' // & + ' the right values > 64 bits .' + else + write(*,*) 'Initialization > 64 bits with logical(int32) ' // & + 'succeeded.' + end if + + set5 = log4 + if ( set5 % bits() /= 33 ) then + error stop procedure // & + ' initialization with logical(int64) failed to set' // & + ' the right size.' + else if ( .not. set5 % none() ) then + error stop procedure // & + ' initialization with logical(int64) failed to set' // & + ' the right values.' + else + write(*,*) 'Initialization with logical(int64) succeeded.' + end if + + set5 = log14 + if ( set5 % bits() /= 165 ) then + error stop procedure // & + ' initialization with logical(int64) failed to set' // & + ' the right size > 64 bits .' + else if ( .not. set5 % none() ) then + error stop procedure // & + ' initialization with logical(int64) failed to set' // & + ' the right values > 64 bits .' + else + write(*,*) 'Initialization > 64 bits with logical(int64) ' // & + 'succeeded.' + end if + + set5 = log1 + call extract( set4, set5, 1, 33 ) + if ( set4 % bits() /= 33 ) then + error stop procedure // & + ' initialization with extract failed to set' // & + ' the right size.' + else if ( .not. set4 % all() ) then + error stop procedure // & + ' initialization with extract failed to set' // & + ' the right values.' + else + write(*,*) 'Initialization with extract succeeded.' + end if + + set5 = log11 + call extract( set4, set5, 1, 65 ) + if ( set4 % bits() /= 65 ) then + error stop procedure // & + ' initialization with extract failed to set' // & + ' the right size > 64 bits.' + else if ( .not. set4 % all() ) then + error stop procedure // & + ' initialization with extract failed to set' // & + ' the right values > 64 bits.' + else + write(*,*) 'Initialization with extract succeeded.' + end if + + set5 = log1 + set4 = set5 + if ( set4 % bits() /= 64 ) then + write(*,*) 'Bits = ', set4 % bits() + error stop procedure // & + ' initialization with simple assignment failed to set' // & + ' the right size.' + else if ( .not. set4 % all() ) then + error stop procedure // & + ' initialization with simple assignment failed to set' // & + ' the right values.' + else + write(*,*) 'Initialization with simple assignment succeeded.' + end if + + set5 = log11 + set4 = set5 + if ( set4 % bits() /= 66 ) then + write(*,*) 'Bits = ', set4 % bits() + error stop procedure // & + ' initialization with simple assignment failed to set' // & + ' the right size > 64 bits.' + else if ( .not. set4 % all() ) then + error stop procedure // & + ' initialization with simple assignment failed to set' // & + ' the right values > 64 bits.' + else + write(*,*) 'Initialization > 64 bits with simple assignment ' // & + 'succeeded.' + end if + + set5 = log1 + log5 = set5 + if ( size(log5) /= 64 ) then + error stop procedure // & + ' initialization of logical(int8) with assignment failed' // & + ' to set the right size.' + else if ( .not. all(log5) ) then + error stop procedure // & + ' initialization of logical(int8) with assignment failed' // & + ' to set the right values.' + else + write(*,*) 'Initialization of logical(int8) succeeded.' + end if + + set5 = log11 + log5 = set5 + if ( size(log5) /= 66 ) then + error stop procedure // & + ' initialization of logical(int8) with assignment failed' // & + ' to set the right size > 64 bits.' + else if ( .not. all(log5) ) then + error stop procedure // & + ' initialization of logical(int8) with assignment failed' // & + ' to set the right values > 64 bits.' + else + write(*,*) 'Initialization > 64 bits of logical(int8) succeeded.' + end if + + set5 = log1 + log6 = set5 + if ( size(log6) /= 64 ) then + error stop procedure // & + ' initialization of logical(int16) with assignment failed' // & + ' to set the right size.' + else if ( .not. all(log6) ) then + error stop procedure // & + ' initialization of logical(int16) with assignment failed' // & + ' to set the right values.' + else + write(*,*) 'Initialization of logical(int16) succeeded.' + end if + + set5 = log11 + log6 = set5 + if ( size(log6) /= 66 ) then + error stop procedure // & + ' initialization of logical(int16) with assignment failed' // & + ' to set the right size > 64 bits.' + else if ( .not. all(log6) ) then + error stop procedure // & + ' initialization of logical(int16) with assignment failed' // & + ' to set the right values > 64 bits.' + else + write(*,*) 'Initialization > 64 bits of logical(int16) succeeded.' + end if + + set5 = log1 + log7 = set5 + if ( size(log7) /= 64 ) then + error stop procedure // & + ' initialization of logical(int32) with assignment failed' // & + ' to set the right size.' + else if ( .not. all(log7) ) then + error stop procedure // & + ' initialization of logical(int32) with assignment failed' // & + ' to set the right values.' + else + write(*,*) 'Initialization of logical(int32) succeeded.' + end if + + set5 = log11 + log7 = set5 + if ( size(log7) /= 66 ) then + error stop procedure // & + ' initialization of logical(int32) with assignment failed' // & + ' to set the right size > 64 bits.' + else if ( .not. all(log7) ) then + error stop procedure // & + ' initialization of logical(int32) with assignment failed' // & + ' to set the right values > 64 bits.' + else + write(*,*) 'Initialization > 64 bits of logical(int32) succeeded.' + end if + + set5 = log1 + log8 = set5 + if ( size(log8) /= 64 ) then + error stop procedure // & + ' initialization of logical(int64) with assignment failed' // & + ' to set the right size.' + else if ( .not. all(log8) ) then + error stop procedure // & + ' initialization of logical(int64) with assignment failed' // & + ' to set the right values.' + else + write(*,*) 'Initialization of logical(int64) succeeded.' + end if + + set5 = log11 + log8 = set5 + if ( size(log8) /= 66 ) then + error stop procedure // & + ' initialization of logical(int64) with assignment failed' // & + ' to set the right size > 64 bits.' + else if ( .not. all(log8) ) then + error stop procedure // & + ' initialization of logical(int64) with assignment failed' // & + ' to set the right values > 64 bits.' + else + write(*,*) 'Initialization > 64 bits of logical(int64) succeeded.' + end if + + end subroutine test_initialization + + subroutine test_bitset_inquiry() + character(*), parameter:: procedure = 'TEST_BITSET_INQUIRY' + integer :: i + + write(*,*) + write(*,*) 'Test bitset inquiry: all, any, bits, none, test, and value' + + if ( set0 % none() ) then + if ( .not. set0 % any() ) then + write(*,*) 'As expected set0 has no bits set' + else + error stop procedure // ' set0 had some bits set which ' // & + 'was unexpected.' + end if + else + error stop procedure // ' set0 did not have none set which ' // & + 'was unexpected' + end if + + call set0 % not() + + if ( set0 % all() ) then + if ( set0 % any() ) then + write(*,*) 'As expected set0 now has all bits set' + else + error stop procedure // ' set0 had no bits set which ' // & + 'was unexpected.' + end if + else + error stop procedure // ' set0 did not have all bits set ' // & + 'which was unexpected' + end if + + if ( set1 % any() ) then + if ( set1 % all() ) then + write(*,*) 'As expected set1 has all bits set' + else + error stop procedure // ' set1 did not have all bits set ' // & + 'which was unexpected.' + end if + else + error stop procedure // ' set1 had none bits set ' // & + 'which was unexpected' + end if + + call set0 % not() + do i=0, set0 % bits() - 1 + if ( set0 % test(i) ) go to 100 + end do + + write(*,*) 'As expected set0 had no bits set.' + + go to 110 + +100 error stop procedure // ' against expectations set0 has ' // & + 'at least 1 bit set.' + +110 continue + + do i=0, set1 % bits() - 1 + if ( .not. set1 % test(i) ) go to 200 + end do + + write(*,*) 'As expected set1 had all bits set.' + + go to 210 + +200 error stop procedure // ' against expectations set0 has ' // & + 'at least 1 bit unset.' + +210 continue + + do i=0, set0 % bits() - 1 + if ( set0 % value(i) /= 0 ) go to 300 + end do + + write(*,*) 'As expected set0 had no bits set.' + + go to 310 + +300 error stop procedure // ' against expectations set0 has ' // & + 'at least 1 bit set.' + +310 continue + + do i=0, set1 % bits() - 1 + if ( set1 % value(i) /= 1 ) go to 400 + end do + + write(*,*) 'As expected set1 had all bits set.' + + go to 410 + +400 error stop procedure // ' against expectations set0 has ' // & + 'at least 1 bit unset.' + +410 continue + + if ( set0 % bits() == 33 ) then + write(*,*) 'set0 has 33 bits as expected.' + else + error stop procedure // 'set0 unexpectedly does not have 33 bits.' + end if + +! > 64 bit inquiries + call set10 % from_string( bitstring_0 // bitstring_0 // bitstring_0 ) + if ( set10 % none() ) then + if ( .not. set10 % any() ) then + write(*,*) 'As expected set10 has no bits set' + else + error stop procedure // ' set10 had some bits set which ' // & + 'was unexpected.' + end if + else + error stop procedure // ' set10 did not have none set which ' // & + 'was unexpected' + end if + + call set10 % not() + + if ( set10 % all() ) then + if ( set10 % any() ) then + write(*,*) 'As expected set10 now has all bits set' + else + error stop procedure // ' set10 had no bits set which ' // & + 'was unexpected.' + end if + else + error stop procedure // ' set10 did not have all bits set ' // & + 'which was unexpected' + end if + + call set11 % from_string( bitstring_all // bitstring_all // & + bitstring_all ) + if ( set11 % any() ) then + if ( set11 % all() ) then + write(*,*) 'As expected set11 has all bits set' + else + error stop procedure // ' set11 did not have all bits set ' // & + 'which was unexpected.' + end if + else + error stop procedure // ' set11 had none bits set ' // & + 'which was unexpected' + end if + + call set10 % not() + do i=0, set10 % bits() - 1 + if ( set10 % test(i) ) go to 500 + end do + + write(*,*) 'As expected set10 had no bits set.' + + go to 510 + +500 error stop procedure // ' against expectations set10 has ' // & + 'at least 1 bit set.' + +510 continue + + do i=0, set11 % bits() - 1 + if ( .not. set11 % test(i) ) go to 600 + end do + + write(*,*) 'As expected set11 had all bits set.' + + go to 610 + +600 error stop procedure // ' against expectations set11 has ' // & + 'at least 1 bit unset.' + +610 continue + + do i=0, set10 % bits() - 1 + if ( set10 % value(i) /= 0 ) go to 700 + end do + + write(*,*) 'As expected set10 had no bits set.' + + go to 710 + +700 error stop procedure // ' against expectations set10 has ' // & + 'at least 1 bit set.' + +710 continue + + do i=0, set11 % bits() - 1 + if ( set11 % value(i) /= 1 ) go to 800 + end do + + write(*,*) 'As expected set11 had all bits set.' + + go to 810 + +800 error stop procedure // ' against expectations set11 has ' // & + 'at least 1 bit unset.' + +810 continue + + if ( set0 % bits() == 33 ) then + write(*,*) 'set0 has 33 bits as expected.' + else + error stop procedure // 'set0 unexpectedly does not have 33 bits.' + end if + + if ( set10 % bits() == 99 ) then + write(*,*) 'set10 has 99 bits as expected.' + else + error stop procedure // 'set10 unexpectedly does not have 99 bits.' + end if + + end subroutine test_bitset_inquiry + + subroutine test_bit_operations() + character(*), parameter:: procedure = 'TEST_BIT_OPERATIONS' + + write(*,*) + write(*,*) 'Test bit operations: clear, flip, not, and set' + + if ( .not. set1 % all() ) then + error stop procedure // ' set1 is not all set.' + end if + + call set1 % clear(0) + if ( .not. set1 % test(0) ) then + if ( set1 % test(1) ) then + write(*,*) 'Cleared one bit in set1 as expected.' + else + error stop procedure // ' cleared more than one bit in set1.' + end if + else + error stop procedure // ' did not clear the first bit in set1.' + end if + + call set1 % clear(1, 32) + if ( set1 % none() ) then + write(*,*) 'Cleared remaining bits in set1 as expected.' + else + error stop procedure // ' did not clear remaining bits ' // & + 'in set1.' + end if + + call set1 % flip(0) + if ( set1 % test(0) ) then + if ( .not. set1 % test(1) ) then + write(*,*) 'Flipped one bit in set1 as expected.' + else + error stop procedure // ' flipped more than one bit in set1.' + end if + else + error stop procedure // ' did not flip the first bit in set1.' + end if + + call set1 % flip(1, 32) + if ( set1 % all() ) then + write(*,*) 'Flipped remaining bits in set1 as expected.' + else + error stop procedure // ' did not flip remaining bits ' // & + 'in set1.' + end if + + call set1 % not() + if ( set1 % none() ) then + write(*,*) 'Unset bits in set1 as expected.' + else + error stop procedure // ' did not unset bits in set1.' + end if + + call set1 % set(0) + if ( set1 % test(0) ) then + if ( .not. set1 % test(1) ) then + write(*,*) 'Set first bit in set1 as expected.' + else + error stop procedure // ' set more than one bit in set1.' + end if + else + error stop procedure // ' did not set the first bit in set1.' + end if + + call set1 % set(1, 32) + if ( set1 % all() ) then + write(*,*) 'Set the remaining bits in set1 as expected.' + else + error stop procedure // ' did not set the remaining bits ' // & + 'in set1.' + end if + + call set11 % init( 166 ) + call set11 % not() + if ( .not. set11 % all() ) then + error stop procedure // ' set11 is not all set.' + end if + + call set11 % clear(0) + if ( .not. set11 % test(0) ) then + if ( set11 % test(1) ) then + write(*,*) 'Cleared one bit in set11 as expected.' + else + error stop procedure // ' cleared more than one bit in set11.' + end if + else + error stop procedure // ' did not clear the first bit in set11.' + end if + + call set11 % clear(165) + if ( .not. set11 % test(165) ) then + if ( set11 % test(164) ) then + write(*,*) 'Cleared the last bit in set11 as expected.' + else + error stop procedure // ' cleared more than one bit in set11.' + end if + else + error stop procedure // ' did not clear the last bit in set11.' + end if + + call set11 % clear(1, 164) + if ( set11 % none() ) then + write(*,*) 'Cleared remaining bits in set11 as expected.' + else + error stop procedure // ' did not clear remaining bits ' // & + 'in set11.' + end if + + call set11 % flip(0) + if ( set11 % test(0) ) then + if ( .not. set11 % test(1) ) then + write(*,*) 'Flipped one bit in set11 as expected.' + else + error stop procedure // ' flipped more than one bit in set11.' + end if + else + error stop procedure // ' did not flip the first bit in set11.' + end if + + call set11 % flip(165) + if ( set11 % test(165) ) then + if ( .not. set11 % test(164) ) then + write(*,*) 'Flipped last bit in set11 as expected.' + else + error stop procedure // ' flipped more than one bit in set11.' + end if + else + error stop procedure // ' did not flip the last bit in set11.' + end if + + call set11 % flip(1, 164) + if ( set11 % all() ) then + write(*,*) 'Flipped remaining bits in set11 as expected.' + else + error stop procedure // ' did not flip remaining bits ' // & + 'in set11.' + end if + + call set11 % not() + if ( set11 % none() ) then + write(*,*) 'Unset bits in set11 as expected.' + else + error stop procedure // ' did not unset bits in set11.' + end if + + call set11 % set(0) + if ( set11 % test(0) ) then + if ( .not. set11 % test(1) ) then + write(*,*) 'Set first bit in set11 as expected.' + else + error stop procedure // ' set more than one bit in set11.' + end if + else + error stop procedure // ' did not set the first bit in set11.' + end if + + call set11 % set(165) + if ( set11 % test(165) ) then + if ( .not. set11 % test(164) ) then + write(*,*) 'Set last bit in set11 as expected.' + else + error stop procedure // ' set more than one bit in set11.' + end if + else + error stop procedure // ' did not set the last bit in set11.' + end if + + call set11 % set(1, 164) + if ( set11 % all() ) then + write(*,*) 'Set the remaining bits in set11 as expected.' + else + error stop procedure // ' did not set the remaining bits ' // & + 'in set11.' + end if + + end subroutine test_bit_operations + + subroutine test_bitset_comparisons() + character(*), parameter:: procedure = 'TEST_BITSET_COMPARISON' + + write(*,*) + write(*,*) 'Test bitset comparisons: ==, /=, <, <=, >, and >=' + + if ( set0 == set0 .and. set1 == set1 .and. set2 == set2 .and. & + .not. set0 == set1 .and. .not. set0 == set2 .and. .not. & + set1 == set2 ) then + write(*,*) 'Passed 64 bit equality tests.' + else + error stop procedure // ' failed 64 bit equality tests.' + end if + + if ( set0 /= set1 .and. set1 /= set2 .and. set0 /= set2 .and. & + .not. set0 /= set0 .and. .not. set1 /= set1 .and. .not. & + set2 /= set2 ) then + write(*,*) 'Passed 64 bit inequality tests.' + else + error stop procedure // ' failed 64 bit inequality tests.' + end if + + if ( set1 > set0 .and. set2 > set0 .and. set1 > set2 .and. & + .not. set0 > set1 .and. .not. set1 > set1 .and. .not. & + set2 > set1 ) then + write(*,*) 'Passed 64 bit greater than tests.' + else + error stop procedure // ' failed 64 bit greater than tests.' + end if + + if ( set1 >= set0 .and. set1 >= set2 .and. set2 >= set2 .and. & + .not. set0 >= set1 .and. .not. set0 >= set1 .and. .not. & + set2 >= set1 ) then + write(*,*) 'Passed 64 bit greater than or equal tests.' + else + error stop procedure // ' failed 64 bit greater than or ' // & + 'equal tests.' + end if + + if ( set0 < set1 .and. set0 < set1 .and. set2 < set1 .and. & + .not. set1 < set0 .and. .not. set0 < set0 .and. .not. & + set1 < set2 ) then + write(*,*) 'Passed 64 bit less than tests.' + else + error stop procedure // ' failed 64 bit less than tests.' + end if + + if ( set0 <= set1 .and. set2 <= set1 .and. set2 <= set2 .and. & + .not. set1 <= set0 .and. .not. set2 <= set0 .and. .not. & + set1 <= set2 ) then + write(*,*) 'Passed 64 bit less than or equal tests.' + else + error stop procedure // ' failed 64 bit less than or ' // & + 'equal tests.' + end if + + call set10 % init(166) + call set11 % init(166) + call set11 % not() + call set12 % init(166) + call set12 % set(165) + call set13 % init(166) + call set13 % set(65) + call set14 % init(166) + call set14 % set(0) + if ( set10 == set10 .and. set11 == set11 .and. set12 == set12 .and. & + set13 == set13 .and. set14 == set14 .and. & + .not. set13 == set14 .and. .not. set12 == set13 .and. & + .not. set10 == set11 .and. .not. set10 == set12 .and. .not. & + set11 == set12 ) then + write(*,*) 'Passed > 64 bit equality tests.' + else + error stop procedure // ' failed > 64 bit equality tests.' + end if + + if ( set10 /= set11 .and. set11 /= set12 .and. set10 /= set12 .and. & + set13 /= set12 .and. set14 /= set13 .and. set14 /= set12 .and. & + .not. set13 /= set13 .and. .not. set12 /= set12 .and. & + .not. set10 /= set10 .and. .not. set11 /= set11 .and. .not. & + set12 /= set12 ) then + write(*,*) 'Passed > 64 bit inequality tests.' + else + error stop procedure // ' failed > 64 bit inequality tests.' + end if + + if ( set11 > set10 .and. set12 > set10 .and. set11 > set12 .and. & + set13 > set14 .and. set12 > set13 .and. set12 > set14 .and. & + .not. set14 > set12 .and. .not. set12 > set11 .and. & + .not. set10 > set11 .and. .not. set11 > set11 .and. .not. & + set12 > set11 ) then + write(*,*) 'Passed > 64 bit greater than tests.' + else + error stop procedure // ' failed > 64 bit greater than tests.' + end if + + if ( set11 >= set10 .and. set11 >= set12 .and. set12 >= set12 .and. & + set13 >= set14 .and. set12 >= set13 .and. set12 >= set14 .and. & + .not. set14 >= set12 .and. .not. set12 >= set11 .and. & + .not. set10 >= set11 .and. .not. set10 >= set11 .and. .not. & + set12 >= set11 ) then + write(*,*) 'Passed > 64 bit greater than or equal tests.' + else + error stop procedure // ' failed 64 bit greater than or ' // & + 'equal tests.' + end if + + if ( set10 < set11 .and. set10 < set11 .and. set12 < set11 .and. & + set14 < set13 .and. set13 < set12 .and. set14 < set12 .and. & + .not. set12 < set14 .and. .not. set11 < set12 .and. & + .not. set11 < set10 .and. .not. set10 < set10 .and. .not. & + set11 < set12 ) then + write(*,*) 'Passed > 64 bit less than tests.' + else + error stop procedure // ' failed > 64 bit less than tests.' + end if + + if ( set10 <= set11 .and. set12 <= set11 .and. set12 <= set12 .and. & + set14 <= set13 .and. set13 <= set12 .and. set14 <= set12 .and. & + .not. set12 <= set14 .and. .not. set11 <= set12 .and. & + .not. set11 <= set10 .and. .not. set12 <= set10 .and. .not. & + set11 <= set12 ) then + write(*,*) 'Passed > 64 bit less than or equal tests.' + else + error stop procedure // ' failed > 64 bit less than or ' // & + 'equal tests.' + end if + + end subroutine test_bitset_comparisons + + subroutine test_bitset_operations() + character(*), parameter:: procedure = 'TEST_BITSET_OPERATIONS' + + write(*,*) + write(*,*) 'Test bitset operations: and, and_not, or, and xor' + + call set0 % from_string( bitstring_all ) + call set4 % from_string( bitstring_all ) + call and( set0, set4 ) ! all all + if ( set0 % all() ) then + write(*,*) 'First test of < 64 bit AND worked.' + else + error stop procedure // ' first test of < 64 bit AND failed.' + end if + + call set4 % from_string( bitstring_0 ) + call and( set0, set4 ) ! all none + if ( set0 % none() ) then + write(*,*) 'Second test of < 64 bit AND worked.' + else + error stop procedure // ' second test of < 64 bit AND failed.' + end if + + call set3 % from_string( bitstring_all ) + call set4 % from_string( bitstring_0 ) + call and( set4, set3 ) ! none all + if ( set4 % none() ) then + write(*,*) 'Third test of < 64 bit AND worked.' + else + error stop procedure // ' third test of < 64 bit AND failed.' + end if + + call set3 % from_string( bitstring_0 ) + call and( set4, set3 ) ! none none + if ( set4 % none() ) then + write(*,*) 'Fourth test of < 64 bit AND worked.' + else + error stop procedure // ' fourth test of < 64 bit AND failed.' + end if + + call set3 % from_string( bitstring_all ) + call set4 % from_string( bitstring_all ) + call and_not( set4, set3 ) ! all all + if ( set4 % none() ) then + write(*,*) 'First test of < 64 bit AND_NOT worked.' + else + error stop procedure // ' first test of < 64 bit AND_NOT failed.' + end if + + call set4 % from_string( bitstring_0 ) + call and_not( set4, set3 ) ! none all + if ( set4 % none() ) then + write(*,*) 'Second test of < 64 bit AND_NOT worked.' + else + error stop procedure // ' second test of < 64 bit AND_NOT failed.' + end if + + call set3 % from_string( bitstring_all ) + call set4 % from_string( bitstring_0 ) + call and_not( set3, set4 ) ! all none + if ( set3 % all() ) then + write(*,*) 'Third test of < 64 bit AND_NOT worked.' + else + error stop procedure // ' third test of < 64 bit AND_NOT failed.' + end if + + call set3 % from_string( bitstring_0 ) + call set4 % from_string( bitstring_0 ) + call and_not( set3, set4 ) ! none none + if ( set3 % none() ) then + write(*,*) 'Fourth test of < 64 bit AND_NOT worked.' + else + error stop procedure // ' fourth test of < 64 bit AND_NOT failed.' + end if + + call set3 % from_string( bitstring_all ) + call set4 % from_string( bitstring_all ) + call or( set3, set4 ) ! all all + if ( set3 % all() ) then + write(*,*) 'First test of < 64 bit OR worked.' + else + error stop procedure // ' first test of < 64 bit OR failed.' + end if + + call set3 % from_string( bitstring_0 ) + call or( set4, set3 ) ! all none + if ( set4 % all() ) then + write(*,*) 'Second test of < 64 bit OR worked.' + else + error stop procedure // ' second test of < 64 bit OR failed.' + end if + + call or( set3, set4 ) ! none all + if ( set3 % all() ) then + write(*,*) 'Third test of < 64 bit OR worked.' + else + error stop procedure // ' third test of < 64 bit OR failed.' + end if + + call set3 % from_string( bitstring_0 ) + call set4 % from_string( bitstring_0 ) + call or( set4, set3 ) !none none + if ( set4 % none() ) then + write(*,*) 'Fourth test of < 64 bit OR worked.' + else + error stop procedure // ' fourth test of < 64 bit OR failed.' + end if + + call set3 % from_string( bitstring_0 ) + call set4 % from_string( bitstring_0 ) + call xor( set3, set4 ) ! none none + if ( set3 % none() ) then + write(*,*) 'First test of < 64 bit XOR worked.' + else + error stop procedure // ' first test of < 64 bit XOR failed.' + end if + + call set4 % from_string( bitstring_all ) + call xor( set3, set4 ) ! none all + if ( set3 % all() ) then + write(*,*) 'Second test of < 64 bit XOR worked.' + else + error stop procedure // ' second test of < 64 bit XOR failed.' + end if + + call set4 % from_string( bitstring_0 ) + call xor( set3, set4 ) ! all none + if ( set3 % all() ) then + write(*,*) 'Third test of < 64 bit XOR worked.' + else + error stop procedure // ' third test of < 64 bit XOR failed.' + end if + + call set4 % from_string( bitstring_all ) + call xor( set3, set4 ) ! all all + if ( set3 % none() ) then + write(*,*) 'Fourth test of < 64 bit XOR worked.' + else + error stop procedure // ' fourth test of < 64 bit XOR failed.' + end if + + call set0 % init(166) + call set0 % not() + call set4 % init(166) + call set4 % not() + call and( set0, set4 ) ! all all + if ( set0 % all() ) then + write(*,*) 'First test of > 64 bit AND worked.' + else + error stop procedure // ' first test of > 64 bit AND failed.' + end if + + call set4 % init(166) + call and( set0, set4 ) ! all none + if ( set0 % none() ) then + write(*,*) 'Second test of > 64 bit AND worked.' + else + error stop procedure // ' second test of > 64 bit AND failed.' + end if + + call set3 % init(166) + call set3 % not() + call and( set4, set3 ) ! none all + if ( set4 % none() ) then + write(*,*) 'Third test of > 64 bit AND worked.' + else + error stop procedure // ' third test of > 64 bit AND failed.' + end if + + call set3 % init(166) + call and( set4, set3 ) ! none none + if ( set4 % none() ) then + write(*,*) 'Fourth test of > 64 bit AND worked.' + else + error stop procedure // ' fourth test of > 64 bit AND failed.' + end if + + call set3 % not() + call set4 % not() + call and_not( set4, set3 ) ! all all + if ( set4 % none() ) then + write(*,*) 'First test of > 64 bit AND_NOT worked.' + else + error stop procedure // ' first test of > 64 bit AND_NOT failed.' + end if + + call and_not( set4, set3 ) ! none all + if ( set4 % none() ) then + write(*,*) 'Second test of > 64 bit AND_NOT worked.' + else + error stop procedure // ' second test of > 64 bit AND_NOT failed.' + end if + + call and_not( set3, set4 ) ! all none + if ( set3 % all() ) then + write(*,*) 'Third test of > 64 bit AND_NOT worked.' + else + error stop procedure // ' third test of > 64 bit AND_NOT failed.' + end if + + call set3 % not() + call and_not( set3, set4 ) ! none none + if ( set3 % none() ) then + write(*,*) 'Fourth test of > 64 bit AND_NOT worked.' + else + error stop procedure // ' fourth test of > 64 bit AND_NOT failed.' + end if + + call set3 % init(166) + call set3 % not() + call set4 % init(166) + call set4 % not() + call or( set3, set4 ) ! all all + if ( set3 % all() ) then + write(*,*) 'First test of > 64 bit OR worked.' + else + error stop procedure // ' first test of > 64 bit OR failed.' + end if + + call set3 % init(166) + call or( set4, set3 ) ! all none + if ( set4 % all() ) then + write(*,*) 'Second test of > 64 bit OR worked.' + else + error stop procedure // ' second test of > 64 bit OR failed.' + end if + + call or( set3, set4 ) ! none all + if ( set3 % all() ) then + write(*,*) 'Third test of > 64 bit OR worked.' + else + error stop procedure // ' third test of > 64 bit OR failed.' + end if + + call set3 % init(166) + call set4 % init(166) + call or( set4, set3 ) !none none + if ( set4 % none() ) then + write(*,*) 'Fourth test of > 64 bit OR worked.' + else + error stop procedure // ' fourth test of > 64 bit OR failed.' + end if + + call xor( set3, set4 ) ! none none + if ( set3 % none() ) then + write(*,*) 'First test of > 64 bit XOR worked.' + else + error stop procedure // ' first test of > 64 bit XOR failed.' + end if + + call set4 % not() + call xor( set3, set4 ) ! none all + if ( set3 % all() ) then + write(*,*) 'Second test of > 64 bit XOR worked.' + else + error stop procedure // ' second test of > 64 bit XOR failed.' + end if + + call set4 % not() + call xor( set3, set4 ) ! all none + if ( set3 % all() ) then + write(*,*) 'Third test of > 64 bit XOR worked.' + else + error stop procedure // ' third test of > 64 bit XOR failed.' + end if + + call set4 % not() + call xor( set3, set4 ) ! all all + if ( set3 % none() ) then + write(*,*) 'Fourth test of > 64 bit XOR worked.' + else + error stop procedure // ' fourth test of > 64 bit XOR failed.' + end if + + end subroutine test_bitset_operations + + +end program test_stdlib_bitset_large From e2f3d6667f9f3fb48024bfac3bd4208e47bb1a97 Mon Sep 17 00:00:00 2001 From: William Clodius Date: Tue, 29 Sep 2020 19:33:00 -0600 Subject: [PATCH 03/53] Eliminated unused variablese Eliminated unused variables in stdlib_bitset_64.f90, stdlib_bitset_large.f90 and rename variables called ablock to block_ in stdlib_bitset_large.f90 [ticket: X] --- src/stdlib_bitset_64.f90 | 26 +++------ src/stdlib_bitset_large.f90 | 110 +++++++++++++++++------------------- 2 files changed, 58 insertions(+), 78 deletions(-) diff --git a/src/stdlib_bitset_64.f90 b/src/stdlib_bitset_64.f90 index daa566bb5..eaf2224d5 100644 --- a/src/stdlib_bitset_64.f90 +++ b/src/stdlib_bitset_64.f90 @@ -410,7 +410,7 @@ pure module subroutine flip_range_64(self, start_pos, stop_pos) class(bitset_64), intent(inout) :: self integer(bits_kind), intent(in) :: start_pos, stop_pos - integer(bits_kind) :: bit, end_bit, start_bit + integer(bits_kind) :: end_bit, start_bit start_bit = max( 0, start_pos ) end_bit = min( stop_pos , self % num_bits-1 ) @@ -729,7 +729,6 @@ module subroutine output_64(self, unit, status) integer :: ierr character(len=120) :: message character(*), parameter :: procedure = "OUTPUT" - integer(bits_kind) :: words write(unit, iostat=ierr, iomsg=message) self % num_bits if (ierr /= 0) go to 999 @@ -766,12 +765,11 @@ module subroutine read_bitset_string_64(self, string, status) ! CHAR_STRING_TOO_SMALL_ERROR if the string ends before all the bits ! are read. ! - class(bitset_64), intent(out) :: self - character(len=*), intent(in) :: string - integer, intent(out), optional :: status + class(bitset_64), intent(out) :: self + character(len=*), intent(in) :: string + integer, intent(out), optional :: status integer(bits_kind) :: bit, bits - integer(int64) :: bits_needed integer(bits_kind) :: digits, pos character(*), parameter :: procedure = "READ_BITSET" integer :: stat @@ -888,11 +886,8 @@ module subroutine read_bitset_unit_64(self, unit, advance, status) integer(bits_kind) :: bit, bits, digits integer :: ierr character(len=128) :: message - character(len=:), allocatable :: literal - integer(bits_kind) :: pos character(*), parameter :: procedure = "READ_BITSET" - integer :: stat - character(len=1) :: char, quote + character(len=1) :: char do read( unit, & @@ -1041,8 +1036,6 @@ elemental module subroutine set_bit_64(self, pos) class(bitset_64), intent(inout) :: self integer(bits_kind), intent(in) :: pos - integer(bits_kind) :: set_block, block_bit - if ( pos < 0 .OR. pos > self % num_bits-1 ) return self % block = ibset( self % block, pos ) @@ -1058,7 +1051,7 @@ pure module subroutine set_range_64(self, start_pos, stop_pos) class(bitset_64), intent(inout) :: self integer(bits_kind), intent(in) :: start_pos, stop_pos - integer(bits_kind) :: bit, end_bit, start_bit + integer(bits_kind) :: end_bit, start_bit start_bit = max( 0, start_pos ) end_bit = min( stop_pos, self % num_bits-1 ) @@ -1176,12 +1169,7 @@ module subroutine write_bitset_string_64(self, string, status) integer(bits_kind) :: bit, & bit_count, & count_digits, & - digit, & - digits, & - max_bit, & - pos, & - processed, & - val + pos integer :: stat character(*), parameter :: procedure = 'WRITE_BITSET' diff --git a/src/stdlib_bitset_large.f90 b/src/stdlib_bitset_large.f90 index 9e58e046b..80674db76 100644 --- a/src/stdlib_bitset_large.f90 +++ b/src/stdlib_bitset_large.f90 @@ -41,11 +41,11 @@ elemental module subroutine and_large(set1, set2) type(bitset_large), intent(inout) :: set1 type(bitset_large), intent(in) :: set2 - integer(bits_kind) :: ablock + integer(bits_kind) :: block_ - do ablock = 1, size(set1 % blocks) - set1 % blocks(ablock) = iand( set1 % blocks(ablock), & - set2 % blocks(ablock) ) + do block_ = 1, size(set1 % blocks) + set1 % blocks(block_) = iand( set1 % blocks(block_), & + set2 % blocks(block_) ) end do end subroutine and_large @@ -60,11 +60,11 @@ elemental module subroutine and_not_large(set1, set2) type(bitset_large), intent(inout) :: set1 type(bitset_large), intent(in) :: set2 - integer(bits_kind) :: ablock + integer(bits_kind) :: block_ - do ablock = 1, size( set1 % blocks ) - set1 % blocks(ablock) = & - iand( set1 % blocks(ablock), not( set2 % blocks(ablock) ) ) + do block_ = 1, size( set1 % blocks ) + set1 % blocks(block_) = & + iand( set1 % blocks(block_), not( set2 % blocks(block_) ) ) end do end subroutine and_not_large @@ -75,10 +75,10 @@ elemental module function any_large(self) result(any) logical :: any class(bitset_large), intent(in) :: self - integer(bits_kind) :: ablock + integer(bits_kind) :: block_ - do ablock = 1, size(self % blocks) - if ( self % blocks(ablock) /= 0 ) then + do block_ = 1, size(self % blocks) + if ( self % blocks(block_) /= 0 ) then any = .true. return end if @@ -293,19 +293,19 @@ elemental module function bit_count_large(self) result(bit_count) integer(bits_kind) :: bit_count class(bitset_large), intent(in) :: self - integer(bits_kind) :: ablock, pos + integer(bits_kind) :: block_, pos bit_count = 0 - do ablock = 1, size(self % blocks) - 1 + do block_ = 1, size(self % blocks) - 1 do pos = 0, block_size-1 - if ( btest( self % blocks(ablock), pos ) ) & + if ( btest( self % blocks(block_), pos ) ) & bit_count = bit_count + 1 end do end do - do pos = 0, self % num_bits - (ablock-1)*block_size - 1 - if ( btest( self % blocks(ablock), pos ) ) bit_count = bit_count + 1 + do pos = 0, self % num_bits - (block_-1)*block_size - 1 + if ( btest( self % blocks(block_), pos ) ) bit_count = bit_count + 1 end do end function bit_count_large @@ -339,7 +339,7 @@ pure module subroutine clear_range_large(self, start_pos, stop_pos) class(bitset_large), intent(inout) :: self integer(bits_kind), intent(in) :: start_pos, stop_pos - integer(bits_kind) :: bit, ablock, first_block, last_block, & + integer(bits_kind) :: bit, block_, first_block, last_block, & true_first, true_last true_first = max( 0, start_pos ) @@ -375,8 +375,8 @@ pure module subroutine clear_range_large(self, start_pos, stop_pos) 0 ) ! Do intermediate blocks - do ablock = first_block+1, last_block-1 - self % blocks(ablock) = all_zeros + do block_ = first_block+1, last_block-1 + self % blocks(block_) = all_zeros end do end subroutine clear_range_large @@ -501,7 +501,7 @@ pure module subroutine flip_range_large(self, start_pos, stop_pos) class(bitset_large), intent(inout) :: self integer(bits_kind), intent(in) :: start_pos, stop_pos - integer(bits_kind) :: bit, ablock, end_bit, first_block, last_block, & + integer(bits_kind) :: bit, block_, end_bit, first_block, last_block, & start_bit start_bit = max( 0, start_pos ) @@ -537,8 +537,8 @@ pure module subroutine flip_range_large(self, start_pos, stop_pos) 0 ) ! Do remaining blocks - do ablock = first_block+1, last_block-1 - self % blocks(ablock) = not( self % blocks(ablock) ) + do block_ = first_block+1, last_block-1 + self % blocks(block_) = not( self % blocks(block_) ) end do end subroutine flip_range_large @@ -609,12 +609,12 @@ elemental module function ge_large(set1, set2) result(ge) logical :: ge type(bitset_large), intent(in) :: set1, set2 - integer(bits_kind) :: ablock + integer(bits_kind) :: block_ - do ablock = size(set1 % blocks), 1, -1 - if ( set1 % blocks(ablock) == set2 % blocks(ablock) ) then + do block_ = size(set1 % blocks), 1, -1 + if ( set1 % blocks(block_) == set2 % blocks(block_) ) then cycle - else if ( bgt(set1 % blocks(ablock), set2 % blocks(ablock) ) ) then + else if ( bgt(set1 % blocks(block_), set2 % blocks(block_) ) ) then ge = .true. return else @@ -637,12 +637,12 @@ elemental module function gt_large(set1, set2) result(gt) logical :: gt type(bitset_large), intent(in) :: set1, set2 - integer(bits_kind) :: ablock + integer(bits_kind) :: block_ - do ablock = size(set1 % blocks), 1, -1 - if ( set1 % blocks(ablock) == set2 % blocks(ablock) ) then + do block_ = size(set1 % blocks), 1, -1 + if ( set1 % blocks(block_) == set2 % blocks(block_) ) then cycle - else if ( bgt( set1 % blocks(ablock), set2 % blocks(ablock) ) ) then + else if ( bgt( set1 % blocks(block_), set2 % blocks(block_) ) ) then gt = .true. return else @@ -789,12 +789,12 @@ elemental module function le_large(set1, set2) result(le) logical :: le type(bitset_large), intent(in) :: set1, set2 - integer(bits_kind) :: ablock + integer(bits_kind) :: block_ - do ablock = size(set1 % blocks), 1, -1 - if ( set1 % blocks(ablock) == set2 % blocks(ablock) ) then + do block_ = size(set1 % blocks), 1, -1 + if ( set1 % blocks(block_) == set2 % blocks(block_) ) then cycle - else if ( blt( set1 % blocks(ablock), set2 % blocks(ablock) ) ) then + else if ( blt( set1 % blocks(block_), set2 % blocks(block_) ) ) then le = .true. return else @@ -818,12 +818,12 @@ elemental module function lt_large(set1, set2) result(lt) logical :: lt type(bitset_large), intent(in) :: set1, set2 - integer(bits_kind) :: ablock + integer(bits_kind) :: block_ - do ablock = size(set1 % blocks), 1, -1 - if ( set1 % blocks(ablock) == set2 % blocks(ablock) ) then + do block_ = size(set1 % blocks), 1, -1 + if ( set1 % blocks(block_) == set2 % blocks(block_) ) then cycle - else if ( blt( set1 % blocks(ablock), set2 % blocks(ablock) ) ) then + else if ( blt( set1 % blocks(block_), set2 % blocks(block_) ) ) then lt = .true. return else @@ -911,11 +911,11 @@ elemental module subroutine or_large(set1, set2) type(bitset_large), intent(inout) :: set1 type(bitset_large), intent(in) :: set2 - integer(bits_kind) :: ablock + integer(bits_kind) :: block_ - do ablock = 1, size( set1 % blocks ) - set1 % blocks(ablock) = ior( set1 % blocks(ablock), & - set2 % blocks(ablock) ) + do block_ = 1, size( set1 % blocks ) + set1 % blocks(block_) = ior( set1 % blocks(block_), & + set2 % blocks(block_) ) end do end subroutine or_large @@ -977,7 +977,6 @@ module subroutine read_bitset_string_large(self, string, status) integer, intent(out), optional :: status integer(bits_kind) :: bit, bits - integer(int64) :: bits_needed integer(bits_kind) :: digits, pos character(*), parameter :: procedure = "READ_BITSET" integer :: stat @@ -1098,11 +1097,9 @@ module subroutine read_bitset_unit_large(self, unit, advance, status) integer(bits_kind) :: bit, bits, digits integer :: ierr character(len=128) :: message - character(len=:), allocatable :: literal - integer(bits_kind) :: pos character(*), parameter :: procedure = "READ_BITSET" integer :: stat - character(len=1) :: char, quote + character(len=1) :: char do read( unit, & @@ -1262,7 +1259,7 @@ pure module subroutine set_range_large(self, start_pos, stop_pos) class(bitset_large), intent(inout) :: self integer(bits_kind), intent(in) :: start_pos, stop_pos - integer(bits_kind) :: bit, ablock, end_bit, first_block, last_block, & + integer(bits_kind) :: bit, block_, end_bit, first_block, last_block, & start_bit start_bit = max( 0, start_pos ) @@ -1298,8 +1295,8 @@ pure module subroutine set_range_large(self, start_pos, stop_pos) 0 ) ! Do remaining blocks - do ablock = first_block+1, last_block-1 - self % blocks(ablock) = all_ones + do block_ = first_block+1, last_block-1 + self % blocks(block_) = all_ones end do end subroutine set_range_large @@ -1409,12 +1406,7 @@ module subroutine write_bitset_string_large(self, string, status) integer(bits_kind) :: bit, & bit_count, & count_digits, & - digit, & - digits, & - max_bit, & - pos, & - processed, & - val + pos integer :: stat character(*), parameter :: procedure = 'WRITE_BITSET' @@ -1567,11 +1559,11 @@ elemental module subroutine xor_large(set1, set2) type(bitset_large), intent(inout) :: set1 type(bitset_large), intent(in) :: set2 - integer(bits_kind) :: ablock + integer(bits_kind) :: block_ - do ablock = 1, size(set1 % blocks) - set1 % blocks(ablock) = ieor( set1 % blocks(ablock), & - set2 % blocks(ablock) ) + do block_ = 1, size(set1 % blocks) + set1 % blocks(block_) = ieor( set1 % blocks(block_), & + set2 % blocks(block_) ) end do end subroutine xor_large From 7d778cd30dfd835cccdf9be725bcdd60b9c26ce5 Mon Sep 17 00:00:00 2001 From: William Clodius Date: Tue, 29 Sep 2020 19:43:55 -0600 Subject: [PATCH 04/53] Added documentation for stdlib_bitsets Added stdlib/doc/specs/stdlib_bitsets.md [ticket: X] --- doc/specs/stdlib_bitsets.md | 1975 +++++++++++++++++++++++++++++++++++ 1 file changed, 1975 insertions(+) create mode 100644 doc/specs/stdlib_bitsets.md diff --git a/doc/specs/stdlib_bitsets.md b/doc/specs/stdlib_bitsets.md new file mode 100644 index 000000000..cb9b9891d --- /dev/null +++ b/doc/specs/stdlib_bitsets.md @@ -0,0 +1,1975 @@ +--- +title: Bitsets +--- + +# The `stdlib_bitsets` module + +(TOC) + +## Introduction + +The `stdlib_bitsets` module implements bitset types. A bitset is a +compact representation of a sequence of binary values, that can +equivalently be considered a sequence of logical values or a subset of +the integers 0 ... `bits(bitset)-1`. The bits are indexed from 0 to +`bits(bitset)-1`. A bitset is used when space savings are critical in applications that require a large number +of closely related logical values. +It may also improve performance by reducing memory traffic. To implement bitsets the module +defines three bitset types, multiple constants, a character string +literal that can be read to and from strings and formatted files, a +simple character string literal that can be read to and from strings, +assignments, procedures, methods, and operators. Note that the module +assumes two's complement integers, but all current Fortran 95+ processors use such integers. + + +## The module's constants + +The module defines several public constants all integers, almost all +intended to serve as error codes in reporting problems through an +optional `stat` argument. One constant, `bits_kind` is +the integer kind value for indexing bits and reporting counts of +bits. The other constants that are error codes are summarized below: + +|Error Code|Summary| +|----------|-------| +|`success`|No problems found| +|`alloc_fault`|Failure with a memory allocation| +|`array_size_invalid_error`|Attempt to define more than 64 bits in a `bitset_64`| +|`char_string_invalid_error`|Invalid character found in a character string| +|`char_string_too_small_error`|Character string was too small to hold the expected number of bits| +|`index_invalid_error`|Index to a bitstring was less than zero or greater than the number of bits| +|`integer_overflow_error`|Attempt to define an integer value bigger than `huge(0_bits_kind`)| +|`read_failure`|Failure on a `read` statement| +|`eof_failure`|An unexpected "End-of-File" on a `read` statement| +|`write_failure`|Failure on a `write` statement| + + +## The `stdlib_bitsets` derived types + +The `stdlib_bitsets` module defines three derived types, +`bitset_type`, `bitset_64`, and `bitset_large`. `bitset_type` is an abstract +type that serves as the ancestor of `bitset_64` and +`bitset_large`. `bitset_type` defines one method, `bits`, all of its +other methods are deferred to its extensions. `bitset_64` is a bitset +that can handle up 64 bits. `bitset_large` is a bitset that can handle +up `huge(0_bits_kind)` bits. All attributes of the bitset types are +private. The various types each define a sequence of binary values: 0 +or 1. In some cases it is useful to associate a logical value, `test`, +for each element of the sequence, where `test` is `.true.` if the value +is 1 and `.false.` otherwise. The number of such values in an entity +of that type is to be termed, `bits`. The bits are ordered in terms of +position, that, in turn, is indexed from 0 to `bits-1`. `bitset_type` is +not used in source code. The syntax for using the types are: + +`class([[stdlib_bitset(module):bitset_type(class)]]) :: variable` + +`type([[stdlib_bitset(module):bitset_64(type)]]) :: variable` + +and + +`type([[stdlib_bitset(module):bitset_large(type)]]) :: variable` + +## The *bitset-literal* + +A bitset value may be represented as a *bitset-literal-constant* +character string in source code or as a *bitset-literal* in +formatted files and non-constant strings. + +*bitset-literal-constant* is ' *bitset-literal* ' + or " *bitset-literal* " + +*bitset-literal* is *bitsize-literal* *binary-literal* + +*bitsize-literal* is S *digit* [ *digit* ] ... + +*binary-literal* is B *binary-digit* [ *binary-digit* ] ... + +*digit* is 0 + or 1 + or 2 + or 3 + or 4 + or 5 + or 6 + or 7 + or 8 + or 9 + + +*binary-digit* is 0 + or 1 + +The *bitset-literal* consists of two parts: a *bitsize-literal* and a +*binary-literal*. The sequence of decimal digits that is part of the +*bitsize-literal* is interpreted as the decimal value of `bits`. +The *binary-literal* value is interpreted as a sequence of bit +values and there must be as many binary digits in the literal as there +are `bits`. The sequence of binary digits are treated as if they were +an unsigned integer with the i'th digit corresponding to the `bits-i` +bit position. + +## The *binary-literal* + +In defining the *bitset-literal* we also defined a +*binary-literal*. While not suitable for file I/0, the +*binary-literal* is suitable for transfer to and from character +strings. In that case the length of the string is the number of bits +and all characters in the string must be either "0" or "1". + +## Summary of the module's operations + +The `stdlib_bitsets` module defines a number of operations: +assignments, "unary" methods of class `bitset_type`, "binary" +procedure overloads of type `bitset_64` or `bitset_large`, and binary +comparison operators of type `bitset_64` or `bitset_large`. Each +category will be discussed separately. + +### Assignments + +The module defines an assignment operation, `=`, that creates a +duplicate of an original bitset. It also defines assignments to and +from rank one arrays of logical type of kinds `int8`, `int16`, +`int32`, and `int64`. In the assignment to and from logical arrays +array index, `i`, is mapped to bit position, `pos=i-1`, and `.true.` +is mapped to a set bit, and `.false.` is mapped to an unset bit. + + +#### Example + + ```fortran + program demo_assignment + use stdlib_bitsets + logical(int8) :: logical1(64) = .true. + logical(int32), allocatable :: logical2(:) + type(bitset_64) :: set0, set1 + set0 = logical1 + if ( set0 % bits() /= 64 ) then + error stop procedure // & + ' initialization with logical(int8) failed to set' // & + ' the right size.' + else if ( .not. set0 % all() ) then + error stop procedure // ' initialization with' // & + ' logical(int8) failed to set the right values.' + else + write(*,*) 'Initialization with logical(int8) succeeded.' + end if + set1 = set0 + if ( set1 == set0 ) & + write(*,*) 'Initialization by assignment succeeded' + logical2 = set1 + if ( all( logical2 ) ) then + write(*,*) 'Initialization of logical(int32) succeeded.' + end if + end program demo_assignment + + +### Table of the `bitset_type` methods + +The `bitset_type` class has a number of methods. All except one, `bits`, +are deferred. The methods consist of all procedures with one argument +of class `bitset_type`. The procedures with two arguments of type +`bitset_64` or `bitset_large` are not methods and are +summarized in a separate table of procedures. The methods are +summarized below: + +|Method name|Class|Summary| +|-----------|-----|-------| +|`all`|function|`.true.` if all bits are 1, `.false.` otherwise| +|`any`|function|`.true.` if any bits are 1, `.false.` otherwise| +|`bit_count`|function|returns the number of bits that are 1| +|`bits`|function|returns the number of bits in the bitset| +|`clear`|subroutine|sets a sequence of one or more bits to 0| +|`flip`|subroutine|flips the value of a sequence of one or more bits| +|`from_string`|subroutine|reads the bitset from a string treating it as a binary literal| +|`init`|subroutine|creates a new bitset of size `bits`with no bits set| +|`input`|subroutine|reads a bitset from an unformatted I/O unit| +|`none`|function|`.true.` if no bits are 1, `.false.` otherwise| +|`not`|subroutine|performs a logical `not` operation on all the bits| +|`output`|subroutine|writes a bitset to an unformatted I/O unit| +|`read_bitset`|subroutine|reads a bitset from a bitset literal in a character string or formatted I/O unit| +|`set`|subroutine|sets a sequence of one or more bits to 1| +|`test`|function|`.true.` if the bit at `pos` is 1, `.false.` otherwise| +|`to_string`|subroutine|represents the bitset as a binary literal| +|`value`|function|1 if the bit at `pos` is 1, 0 otherwise| +|`write_bitset`|subroutine|writes a bitset as a bitset literal to a character string or formatted I/O unit| + +### Table of the non-member procedure overloads + +The procedures with two arguments of type `bitset_large` or +`bitset_64` must have both arguments of the same known type which +prevents them from being methods. The bitwise "logical" procedures, +`and`, `and_not`, `or`, and `xor` also require that the two bitset +arguments have the same number of bits, otherwise the results are +undefined, These procedures are summarized in the following table: + +|Procedure name|Class|Summary| +|--------------|-----|-------| +|`and`|elemental subroutine|Sets `self` to the bitwise `and` of the original bits in `self` and `set2`| +|`and_not`|elemental subroutine|Sets `self` to the bitwise `and` of the original bits in `self` and the negation of `set2`| +|`extract`|subroutine|creates a new bitset, `new`, from a range in `old`| +|`or`|elemental subroutine|Sets `self` to the bitwise `or` of the original bits in `self` and `set2`| +|`xor`|elemental subroutine|Sets `self` to the bitwise exclusive `or` of the original bits in `self` and `set2`| + + +### Table of the non-member comparison operations +The comparison operators with two arguments of type `bitset_large` or +`bitset_64` must have both arguments of the same known type which +prevents them from being methods. The operands must also have the same +number of bits otherwise the results are undefined. These operators +are summarized in the following table: + +|Operator|Description| +|--------|-----------| +|`==`|`.true.` if all bits in `set1` and `set2` have the same value, `.false.` otherwise| +|`/=`|`.true.` if any bits in `set1` and `set2` differ in value, `.false.` otherwise| +|`>`|`.true.` if the bits in `set1` and `set2` differ in value and the highest order differing bit is 1 in `set1` and 0 in `set2`, `.false.` otherwise| +|`>=`|`.true.` if the bits in `set1` and `set2` are the same or the highest order differing bit is 1 in `set1` and 0 in `set2`, `.false.` otherwise| +|`<`|`.true.` if the bits in `set1` and `set2` differ in value and the highest order differing bit is 0 in `set1` and 1 in `set2`, `.false.` otherwise| +|`<=`|`.true.` if the bits in `set1` and `set2` are the same or the highest order differing bit is 0 in `set1` and 1 in `set2`, `.false.` otherwise| + + +## Specification of the `stdlib_bitsets` methods and procedures + +### `all` - determine whether all bits are set in `self`. + +#### Status + +Experimental + +#### Description + +Determines whether all bits are set to 1 in self. + +#### Syntax + +`result = self % [[bitset_type(class):all(bound)]]()` + +#### Class + +Elemental function. + +#### Argument + +`self`: shall be a scalar expression of class `bitset_type`. It is an +`intent(in)` argument. + +#### Result character + +The result is a default logical scalar. + +#### Result value + +The result is `.true.` if all bits in `self` are set, +otherwise it is `.false.`. + +#### Example + + ```fortran + program demo_all + use stdlib_bitsets + character(*), parameter :: & + bits_all = '111111111111111111111111111111111' + type(bitset_64) :: set0 + call set0 % from_string( bits_all ) + if ( bits(set0) /= 33 ) then + error stop "FROM_STRING failed to interpret " // & + 'BITS_ALL's size properly." + else if ( .not. set0 % all() ) then + error stop "FROM_STRING failed to interpret" // & + "BITS_ALL's value properly." + else + write(*,*) "FROM_STRING transferred BITS_ALL properly" // & + " into set0." + end if + end program demo_all + + +#### `and` - bitwise `and` of the bits of two bitsets. + +#### Status + +Experimental + +#### Description + +Sets the bits in `set1` to the bitwise `and` of the original bits in +`set1` and `set2`. Note that `set1` and `set2` must have the same +number of bits, otherwise the result is undefined. + +#### Syntax + +`call [[stdlib_bitsets(module):and(interface]] (set1, set2)` + +#### Class + +Elemental subroutine. + +#### Arguments + +`set1`: shall be a `bitset_64` or `bitset_large` scalar variable. It +is an `intent(inout)` argument. On return the values of the bits in +`set1` are the bitwise `and` of the original bits in `set1` with the +corresponding bits in `set2`. + +`set2`: shall be a scalar expression of the same type as `set1`. It is +an `intent(in)` argument. Note that `set2` must also have the same +number of bits as `set1`. + +#### Example + + ```fortran + program demo_and + use stdlib_bitsets + type(bitset_large) :: set0, set1 + call set0 % init(166) + call set1 % init(166) + call and( set0, set1 ) ! none none + if ( none(set0) ) write(*,*) 'First test of AND worked.' + call set0 % not() + call and( set0, set1 ) ! all none + if ( none(set0) ) write(*,*) 'Second test of AND worked.' + call set1 % not() + call and( set0, set1 ) ! none all + if ( none(set0) ) write(*,*) 'Third test of AND worked.' + call set0 % not() + call and( set0, set1 ) ! all all + if ( all(set0) ) write(*,*) 'Fourth test of AND worked.' + end program demo_and + +### `and_not` - Bitwise `and` of one bitset with the negation of another + +#### Status + +Experimental + +#### Description + +Sets the bits of `set1` to bitwise `and` of the bits of `set1` with +the bitwise negation of the corresponding bits of `set2`. Note that +`set1` and `set2` must have the same number of bits, otherwise the +result is undefined. + +#### Syntax + +`call [[stdlib_bitsets(module):and_not(interface)]](set1, set2)` + +#### Class + +Elemental subroutine. + +#### Arguments + +`set1`: shall be a scalar `bitset_64` or `bitset_large` variable. It +is an `intent(inout)` argument. On return the values of the bits in +`set1` are the bitwise `and` of the original bits in `set1` with the +corresponding negation of the bits in `set2`. + +`set2`: shall be a scalar expression of the same type as `set1`. It is +an `intent(in)` argument. Note that it should also have the same +number of bits as `set1` otherwise the result is undefined. + +#### Example + + ```fortran + program demo_and_not + use stdlib_bitsets + type(bitset_large) :: set0, set1 + call set0 % init(166) + call set1 % init(166) + call and_not( set0, set1 ) ! none none + if ( none(set0) ) write(*,*) 'First test of AND_NOT worked.' + call set0 % not() + call and_not( set0, set1 ) ! all none + if ( all(set0) ) write(*,*) 'Second test of AND_NOT worked.' + call set0 % not() + call set1 % not() + call and_not( set0, set1 ) ! none all + if ( none(set0) ) write(*,*) 'Third test of AND_NOT worked.' + call set0 % not() + call and_not( set0, set1 ) ! all all + if ( none(set0) ) write(*,*) 'Fourth test of AND_NOT worked.' + end program demo_and_not + +### `any` - determine whether any bits are set + +#### Status + +Experimental + +#### Description + +Determines whether any bits are set in `self`. + +#### Syntax + +`result = self % [[bitset_type(class):any(bound)]]()` + +#### Class + +Elemental function. + +#### Argument + +`self`: shall be a scalar expression of class `bitset_type`. It is an +`intent(in)` argument. + +#### Result character + +The result is a default logical scalar. + +#### Result value + +The result is `.true.` if any bits in `self` are set, otherwise it +is `.false.`. + +#### Example + + ```fortran + program demo_any + use stdlib_bitsets + character(*), parameter :: & + bits_0 = '0000000000000000000' + type(bitset_64) :: set0 + call set0 % from_string( bits_0 ) + if ( .not. set0 % any() ) then + write(*,*) "FROM_STRING interpreted " // & + "BITS_0's value properly." + end if + call set0 % set(5) + if ( set0 % any() ) then + write(*,*) "ANY interpreted SET0's value properly." + end if + end program demo_any + + +### `bit_count` - return the number of bits that are set + +#### Status + +Experimental + +#### Description + +Returns the number of bits that are set to one in `self`. + +#### Syntax + +`result = self % [[bitset_type(class):bit_count(bound)]] ()` + +#### Class + +Elemental function. + +#### Argument + +`self`: shall be a scalar expression of class `bitset_type`. It is an +`intent(in)` argument. + +#### Result character + +The result is an integer scalar of kind `bits_kind`. + +#### Result value + +The result is the number of bits that are set in `self`. + +#### Example + + ```fortran + program demo_bit_count + use stdlib_bitsets + character(*), parameter :: & + bits_0 = '0000000000000000000' + type(bitset_64) :: set0 + call set0 % from_string( bits_0 ) + if ( set0 % bit_count() == 0 ) then + write(*,*) "FROM_STRING interpreted " // & + "BITS_0's value properly." + end if + call set0 % set(5) + if ( set0 % bit_count() == 1 ) then + write(*,*) "BIT_COUNT interpreted SET0's value properly." + end if + end program demo_bit_count + + +#### `bits` - returns the number of bits + +#### Status + +Experimental + +#### Description + +Reports the number of bits in `self`. + +#### Syntax + +`result = self % [[bitset_type(class):bits(bound)]] ()` + +#### Class + +Elemental function. + +#### Argument + +`self`: shall be a scalar expression of class `bitset_type`. It is an +`intent(in)` argument. + +#### Result character + +The result is an integer scalar of kind `bits_kind`. + +#### Result value + +The result is the number of defined bits in `self`. + +#### Example + + ```fortran + program demo_bits + use stdlib_bitsets + character(*), parameter :: & + bits_0 = '0000000000000000000' + type(bitset_64) :: set0 + call set0 % from_string( bits_0 ) + if ( set0 % bits() == 19 ) then + write(*,*) "FROM_STRING interpreted " // & + "BITS_0's size properly." + end if + end program demo_bits + + +### `clear` - clears a sequence of one or more bits. + +#### Status + +Experimental + +#### Description + +* If only `pos` is present, clears the bit with position `pos` in +`self`. + +* If `start_pos` and `end_pos` are present with `end_pos >= start_pos` +clears the bits with positions from `start_pos` to `end_pos` in `self`. + +* if `start_pos` and `end_pos` are present with `end_pos < start_pos` +`self` is unmodified. + +Note: Positions outside the range 0 to `BITS(SET) -1` are ignored. + +#### Syntax + +`call self % [[bitset_type(class):clear(bound)]](pos)' + +or + +`call self % [[bitset_type(class):clear(bound)]](start_pos, end_pos)` + +#### Class + +Elemental subroutine + +#### Arguments + +`self`: shall be a scalar variable of class `bitset_type`. It is an + `intent(inout)` argument. + +`pos`: shall be a scalar integer expression of kind `bits_kind`. It is +an `intent(in)` argument. + +`start_pos`: shall be a scalar integer expression of kind +`bits_kind`. It is an `intent(in)` argument. + +`end_pos`: shall be a scalar integer expression of kind +`bits_kind`. It is an `intent(in)` argument. + +#### Example + + ```fortran + program demo_clear + use stdlib_bitsets + type(bitset_large) :: set0 + call set0 % init(166) + call set0 % not() + if ( set0 % all() ) write(*,*) 'SET0 is properly initialized.' + call set0 % clear(165) + if ( .not. set0 % test(165) ) write(*,*) 'Bit 165 is cleared.' + call set0 % clear(0,164) + if ( set0 % none() ) write(*,*) 'All bits are cleared.' + end program demo_clear + +### `extract` - create a new bitset from a range in an old bitset + +#### Status + +Experimental + +#### Description + +Creates a new bitset, `new`, from a range, `start_pos` to `stop_pos`, +in bitset `old`. If `start_pos` is greater than `stop_pos` the new +bitset is empty. If `start_pos` is less than zero or `stop_pos` is +greater than `bits(old)-1` then if `status` is present it has the +value `index_invalid_error`, otherwise processing stops with an +informative message. + +#### Syntax + +`call [[stdlib_bitsets(module):extract(interface)]](new, old, start_pos, stop_pos, status )` + +#### Class + +Subroutine + +#### Arguments + +`new`: shall be a scalar `bitset_64` or `bitset_large` variable. It +is an `intent(out)` argument. It will be the new bitset. + +`old`: shall be a scalar expression of the same type as `new`. It is +an `intent(in)` argument. It will be the source bitset. + +`start_pos`: shall be a scalar integer expression of the kind +`bits_kind`. It is an `intent(in)` argument. + +`stop_pos`: shall be a scalar integer expression of the kind +`bits_kind`. It is an `intent(in)` argument. + +`status` (optional): shall be a scalar default integer variable. It is +an `intent(out)` argument. If present it shall have one of the values: + +* `success` - no problems found + +* `index_invalid_error` - `start_pos` was less than zero or `stop_pos` + was greater than `bits(old)-1`. + +#### Example + + ```fortran + program demo_extract + use stdlib_bitsets + type(bitset_large) :: set0, set1 + call set0 % init(166) + call set0 % set(100,150) + call extract( set1, set0, 100, 150) + if ( set1 % bits() == 51 ) & + write(*,*) 'SET1 has the proper size.' + if ( set1 % all() ) write(*,*) 'SET1 has the proper values.' + end program demo_extract + +### `flip` - flip the values of a sequence of one or more bits + +#### Status + +Experimental + +#### Description + +Flip the values of a sequence of one or more bits. +* If only `pos` is present flip the bit value with position `pos` in + `self`. +* If `start_pos` and `end_pos` are present with `end_pos >= start_pos` +flip the bit values with positions from `start_pos` to `end_pos` in +`self`. +* If `end_pos < start_pos` then `self` is unmodified. + + +#### Syntax + +`call self % [[bitset_type(class):flip(bound)]] (pos)` + +or + +`call self % [[bitset_type(class):flip(bound)]] (start_pos, end_pos)` + +#### Class + +Elemental subroutine. + +#### Arguments + +`self`: shall be a scalar class `bitset_type` variable It is an +`intent(inout)` argument. + +`pos`: shall be a scalar integer expression of kind `bits_kind`. It is +an `intent(in)` argument. + +`start_pos`: shall be a scalar integer expression of kind +`bits_kind`. It is an `intent(in)` argument. + +`end_pos`: shall be a scalar integer expression of kind +`bits_kind`. It is an `intent(in)` argument. + +#### Example + + ```fortran + program demo_flip + use stdlib_bitsets + type(bitset_large) :: set0 + call set0 % init(166) + if ( set0 % none() ) write(*,*) 'SET0 is properly initialized.' + call set0 % flip(165) + if ( set0 % test(165) ) write(*,*) 'Bit 165 is flipped.' + call set0 % flip(0,164) + if ( set0 % all() ) write(*,*) 'All bits are flipped.' + end program demo_flip + +### `from_string` - initializes a bitset from a binary literal + +#### Status + +Experimental + +#### Description + +Initializes the bitset `self` from `string`, treating `string` as a +binary literal. + +#### Syntax + +`call self % [[bitset_type(class):from_string(bound)]](string[, status])` + +#### Class + +Subroutine + +#### Arguments + +`self`: shall be a scalar class `bitset_type` variable. It is an +`intent(out)` argument. + +`string`: shall be a scalar default character expression. It is an +`intent(in)` argument. It shall consist only of the characters "0", +and "1". + +`status` (optional): shall be a scalar default integer variable. It is +an `intent(out)` argument. If present, on return its value shall be +one of the error codes defined in this module. If absent, and its +value would not have been `success`, then processing will stop with an +informative text as its stop code. + +#### Example + + ```fortran + program demo_from_string + use stdlib_bitsets + character(*), parameter :: & + bits_all = '111111111111111111111111111111111' + type(bitset_64) :: set0 + call set0 % from_string( bits_all ) + if ( bits(set0) /= 33 ) then + error stop "FROM_STRING failed to interpret " // & + 'BITS_ALL's size properly." + else if ( .not. set0 % all() ) then + error stop "FROM_STRING failed to interpret" // & + "BITS_ALL's value properly." + else + write(*,*) "FROM_STRING transferred BITS_ALL properly" // & + " into set0." + end if + end program demo_from_string + +### `init` - `bitset_type` initialization routines. + +#### Status + +Experimental + +#### Description + +`bitset_type` initialization routine. + +#### Syntax + +`call [[stdlib_bitsets(module):init(interface)]] (self, bits [, status])` + +#### Class + +Subroutine. + +#### Arguments + +`self`: shall be a scalar `bitset_64` or `bitset_large` variable. It +is an `intent(out)` argument. + +`bits` (optional): shall be a scalar integer expression of kind +`bits_kind`. It is an `intent(in)` argument that if present +specifies the number of bits in `set`. A negative value or a value +greater than 64 if `self` is of type `bitset_64` is an error. + +`status` (optional): shall be a scalar default integer variable. It is +an `intent(out)` argument that, if present, returns an error code +indicating any problem found in processing `init`, and if absent and +an error was found result in stopping processing with an informative +stop code. It can have any of the following error codes: + +* `success` - no problem found + +* `alloc_fault` - `self` was of type `bitset_large` and memory + allocation failed + +* `array_size_invalid_error` - bits was present with either a negative + value, or a value greater than 64 when `self` was of type + `bitset_64`. + +#### Example + + ```fortran + program demo_init + use stdlib_bitsets + type(bitset_large) :: set0 + call set0 % init(166) + if ( set0 % bits() == 166 ) & + write(*,*) `SET0 has the proper size.' + if ( set0 % none() ) write(*,*) 'SET0 is properly initialized.' + end program demo_init + +### `input` - reads a bitset from an unformatted file + +#### Status + +Experimental + +#### Description + +Reads a bitset from its binary representation in an unformatted +file. + +#### Syntax + +`call self % [[bitset_type(class):input(bound)]] (unit [, status])` + +#### Class + +Subroutine + +#### Arguments + +`self`: shall be a scalar variable of class `bitset_64` or +`bitset_large`. It is an `intent(out)` argument. + +`unit`: shall be a scalar default integer expression. It is an +`intent(in)` argument. Its value must be that of a logical unit +number for an open unformatted file with `READ` or `READWRITE` +access positioned at the start of a BITSET value written by a +`bitset_type` `output` subroutine by the same processor. + +`status` (optional): shall be a scalar default integer variable. If +present its value shall be of one of the error codes defined in this +module. IF absent and it would have had a value other than `success` +processing will stop with an informative stop code. Allowed error code +values for this `status` are: + +* `success` - no problem found + +* `alloc_fault` - `self` was of type `bitset_large` and allocation of + memory failed. + +* `array_size_invalid_error` - if the number of bits read from `unit` + is either negative or greater than 64, if class of `self` is + `bitset_64`. + +* `read_failure` - failure during a read statement + +#### Example + + ```fortran + program demo_input + character(*), parameter :: & + bits_0 = '000000000000000000000000000000000', & + bits_1 = '000000000000000000000000000000001', & + bits_33 = '100000000000000000000000000000000' + integer :: unit + type(bitset_64) :: set0, set1, set2, set3, set4, set5 + call set0 % from_string( bits_0 ) + call set1 % from_string( bits_1 ) + call set2 % from_string( bits_33 ) + open( newunit=unit, file='test.bin', status='replace', & + form='unformatted', action='write' ) + call set2 % output(unit) + call set1 % output(unit) + call set0 % output(unit) + close( unit ) + open( newunit=unit, file='test.bin', status='old', & + form='unformatted', action='read' ) + call set5 % input(unit) + call set4 % input(unit) + call set3 % input(unit) + close( unit ) + if ( set3 /= set0 .or. set4 /= set1 .or. set5 /= set2 ) then + error stop 'Transfer to and from units using ' // & + ' output and input failed.' + else + write(*,*) 'Transfer to and from units using ' // & + 'output and input succeeded.' + end if + end program demo_input + + +### `none` - determines whether no bits are set + +#### Status + +Experimental + +#### Description + +Determines whether no bits are set in `self`. + +#### Syntax + +`result = self % [[bitset_type(class):none(bound)]] ()` + +#### Class + +Elemental function. + +#### Argument + +`self`: shall be a scalar expression of class `bitset_type`. It is an + `intent(in)` argument. + +#### Result character + +The result is a default logical scalar. + +#### Result value + +The result is `.true.` if no bits in `self` are set, otherwise it is +`.false.`. + +#### Example + + ```fortran + program demo_none + use stdlib_bitsets + character(*), parameter :: & + bits_0 = '0000000000000000000' + type(bitset_large) :: set0 + call set0 % from_string( bits_0 ) + if ( set0 % none() ) then + write(*,*) "FROM_STRING interpreted " // & + "BITS_0's value properly." + end if + call set0 % set(5) + if ( .not. set0 % none() ) then + write(*,*) "NONE interpreted SET0's value properly." + end if + end program demo_none + + +### `not` - Performs the logical complement on a bitset + +#### Status + +Experimental + +#### Description + +Performs the logical complement on the bits of `self`. + +#### Syntax + +`result = self % [[bitset_type(class):not(bound)]] ()` + +#### Class + +Elemental subroutine. + +#### Argument + +`self` shall be a scalar variable of class `bitset_type`. It is an + `intent(inout)` argument. On return its bits shall be the logical + complement of their values on input. + +#### Example + + ```fortran + program demo_not + use stdlib_bitsets + type(bitset_large) :: set0 + call set0 % init( 155 ) + if ( set0 % none() ) then + write(*,*) "FROM_STRING interpreted " // & + "BITS_0's value properly." + end if + call set0 % not() + if ( set0 % all() ) then + write(*,*) "ALL interpreted SET0's value properly." + end if + end program demo_not + +### `or` - Bitwise OR of the bits of two bitsets. + +#### Status + +Experimental + +#### Description + +Replaces the original bits of `set1` with the bitwise `or` of those +bits with the bits of `set2`. Note `set1` and `set2` must have the +samee number of bits, otherwise the result is undefined. + +#### Syntax + +`call [[stdlib_bitsets(module):or(interface)]](set1, set2)` + +#### Class + +Elemental subroutine. + +#### Arguments + +`set1`: shall be a scalar `bitset_64` or `bitset_large` variable. It + is an `intent(inout)` argument. On return the values of the bits in + `setf` are the bitwise `or` of the original bits in `set1` with the + corresponding bits in `set2`. + +`set2`: shall be a scalar expression of the same type as `set1`. It is +an `intent(in)` argument. Note `bits(set2)` must equal `bits(set1)` +otherwise the results are undefined. + +#### Example + + ```fortran + program demo_or + use stdlib_bitsets + type(bitset_large) :: set0, set1 + call set0 % init(166) + call set1 % init(166) + call or( set0, set1 ) ! none none + if ( none(set0) ) write(*,*) 'First test of OR worked.' + call set0 % not() + call or( set0, set1 ) ! all none + if ( all(set0) ) write(*,*) 'Second test of OR worked.' + call set0 % not() + call set1 % not() + call or( set0, set1 ) ! none all + if ( all(set0) ) write(*,*) 'Third test of OR worked.' + call set0 % not() + call or( set0, set1 ) ! all all + if ( all(set0) ) write(*,*) 'Fourth test of OR worked.' + end program demo_or + + +### `output` - Writes a binary representation of a bitset to a file + +#### Status + +Experimental + +#### Description + +Writes a binary representation of a bitset to an unformatted file. + +#### Syntax + +`call self % [[bitset_type(class):output(bound)]] (unit[, status])` + +#### Class + +Subroutine. + +#### Arguments + +`self`: shall be a scalar expression of class `bitset_64` or +`bitset_large`. It is an `intent(in)` argument. + +`unit`: shall be a scalar default integer expression. It is an +`intent(in)` argument. Its value must be that of an I/O unit number +for an open unformatted file with `WRITE` or `READWRITE` access. + +`status` (optional): shall be a scalar default integer variable. It is +an `intent(out)` argument. If present on return it will have the value +of `success` or `write_failure`. If absent and it would not have the +value of `success` then processing will stop with an informative stop +code. The two code values have the meaning: + +* `success` - no problem found + +* `write_failure` - a failure occured in a write statement. + +#### Example + + ```fortran + program demo_output + character(*), parameter :: & + bits_0 = '000000000000000000000000000000000', & + bits_1 = '000000000000000000000000000000001', & + bits_33 = '100000000000000000000000000000000' + integer :: unit + type(bitset_64) :: set0, set1, set2, set3, set4, set5 + call set0 % from_string( bits_0 ) + call set1 % from_string( bits_1 ) + call set2 % from_string( bits_33 ) + open( newunit=unit, file='test.bin', status='replace', & + form='unformatted', action='write' ) + call set2 % output(unit) + call set1 % output(unit) + call set0 % output(unit) + close( unit ) + open( newunit=unit, file='test.bin', status='old', & + form='unformatted', action='read' ) + call set5 % input(unit) + call set4 % input(unit) + call set3 % input(unit) + close( unit ) + if ( set3 /= set0 .or. set4 /= set1 .or. set5 /= set2 ) then + error stop 'Transfer to and from units using ' // & + ' output and input failed.' + else + write(*,*) 'Transfer to and from units using ' // & + 'output and input succeeded.' + end if + end program demo_output + +### `read_bitset` - initializes `self` with the value of a *bitset_literal* + +#### Status + +Experimental + +#### Description + +Reads a *bitset-literal* and initializes `self` with the corresponding +value. + + +#### Syntax + +`call self % [[bitset_type(class):read_bitset(bound)]](string[, status])` + +or + +`call self % [[bitset_type(class):read_bitset(bound)]](unit[, advance, status])` + + +#### Class + +Subroutine + +#### Arguments + +`self`: shall be a scalar variable of class `bitset_type`. It is an +`intent(out)` argument. Upon a successful return it is initialized with +the value of a *bitset-literal*. + +`string` (optional): shall be a scalar default character +expression. It is an `intent(in)` argument. It will consist of a left +justified *bitset-literal*, terminated by either the end of the string +or a blank. + +`unit` (optional): shall be a scalar default integer expression. It is +an `intent(in)` argument. Its value must be that of an I/O unit number +for an open formatted file with `READ` or `READWRITE` access +positioned at the start of a *bitset-literal*. + +`advance` (optional): shall be a scalar default character +expression. It is an `intent(in)` argument. It is the `advance` +specifier for the final read of `unit`. If present it should have +the value `'yes'` or `'no'`. If absent it has the default value of +`'yes'`. + +`status` (optional): shall be a scalar default integer variable. It is +an `intent(out)` argument. If present on return it shall have the +value of one of the error codes of this module. If absent and it would +not have had the value `success` processing will stop with a message +as its error code. The possible error codes are: + +* `success` - no problems detected; + +* `alloc_fault` - if `self` is of class `bitset_large` and allocation + of the bits failed; + +* `array_size_invalid_error` - if the *bitset-literal* has a bits + value greater than 64 and `self` is of class `bitset_64`; + +* `char_string_invalid_error` - if the `bitset-literal` has an invalid + character; + +* `char_string_too_small_error` - if `string` ends before all the bits + are read; or + +* `integer_overflow_error` - if the *bitset-literal* has a `bits` + value larger than `huge(0_bits_kind)`. + +#### Example + + ```fortran + program demo_read_bitset + character(*), parameter :: & + bits_0 = 'S33B000000000000000000000000000000000', & + bits_1 = 'S33B000000000000000000000000000000001', & + bits_33 = 'S33B100000000000000000000000000000000' + character(:), allocatable :: test_0, test_1, test_2 + integer :: unit + type(bitset_64) :: set0, set1, set2, set3, set4, set5 + call set0 % read_bitset( bits_0, status ) + call set1 % read_bitset( bits_1, status ) + call set2 % read_bitset( bits_2, status ) + call set0 % write_bitset( test_0, status ) + call set1 % write_bitset( test_1, status ) + call set2 % write_bitset( test_2, status ) + if ( bits_0 == test_0 .and. bits_1 == test_1 .and. & + bits_2 == test_2 ) then + write(*,*) 'READ_BITSET to WRITE_BITSET strings worked.' + end if + open( newunit=unit, file='test.txt', status='replace', & + form='formatted', action='write' ) + call set2 % write_bitset(unit, advance='no') + call set1 % write_bitset(unit, advance='no') + call set0 % write_bitset(unit) + close( unit ) + open( newunit=unit, file='test.txt', status='old', & + form='formatted', action='read' ) + call set3 % read_bitset(unit, advance='no') + call set4 % read_bitset(unit, advance='no') + call set5 % read_bitset(unit) + if ( set3 == set0 .and. set4 == set1 .and. set5 == set2 ) then + write(*,*) WRITE_BITSET to READ_BITSET through unit worked.' + end if + end program demo_read_bitset + + +### `set` - sets a sequence of one or more bits to 1. + +#### Status + +Experimental + +#### Description + +Sets a sequence of one or more bits in `self` to 1. + +* If `start_pos` and `end_pos` are absent sets the bit at position +`pos` in `self` to 1. + +* If `start_pos` and `end_pos` are present with `end_pos >= start_pos` +set the bits at positions from `start_pos` to `end_pos` in `self` to 1. + +* If `start_pos` and `end_pos` are present with `end_pos < start_pos` +`self` is unchanged. + +* Positions outside the range 0 to `bits(self)` are ignored. + + +#### Syntax + +`call self % [[bitset_type(class):set(bound)]] (POS)` + +or + +`call self % [[bitset_type(class):set(bound)]] (START_POS, END_POS)` + +#### Class + +Elemental subroutine + +#### Arguments + +`self`: shall be a scalar variable of class `bitset_type`. It is an + `intent(inout)` argument. + +`pos` (optional): shall be a scalar integer expression of kind +`bits_kind`. It is an `intent(in)` argument. + +`start_pos` (optional): shall be a scalar integer expression of kind +`bits_kind`. It is an `intent(in)` argument. + +`end_pos` (optional): shall be a scalar integer expression of kind +`bits_kind`. It is an `intent(in)` argument. + +#### Example + + ```fortran + program demo_set + use stdlib_bitsets + type(bitset_large) :: set0 + call set0 % init(166) + if ( set0 % none() ) write(*,*) 'SET0 is properly initialized.' + call set0 % set(165) + if ( set0 % test(165) ) write(*,*) 'Bit 165 is set.' + call set0 % set(0,164) + if ( set0 % all() ) write(*,*) 'All bits are set.' + end program demo_set + +### `test` - determine whether a bit is set + +#### Status + +Experimental + +#### Descriptions + +Determine whether the bit at position `pos` is set to 1 in `self`. + + +#### Syntax + +`result = self % [[bitset_type(class):test(bound)]](pos)` + +#### Class + +Elemental function. + +#### Arguments + +`self`: shall be a scalar expression of class `bitset_type`. It is an +`intent(in)` argument. + +`pos`: shall be a scalar integer expression of kind `bits_kind`. It is +an `intent(in)` argument. + +#### Result character + +The result is a default logical scalar. + +#### Result value + +The result is `.true.` if the bit at `pos`, in `self` is set, +otherwise it is `.false.`. If `pos` is outside the range +`0... bits(self)-1` the result is `.false.`. + +#### Example + + ```fortran + program demo_test + use stdlib_bitsets + type(bitset_large) :: set0 + call set0 % init(166) + call set0 % not() + if ( set0 % all() ) write(*,*) 'SET0 is properly initialized.' + call set0 % clear(165) + if ( .not. set0 % test(165) ) write(*,*) 'Bit 165 is cleared.' + call set0 % set(165) + if ( set0 % test(165) ) write(*,*) 'Bit 165 is set.' + end program demo_test + + +### `to_string` - represent a bitset as a binary literal + +### Status + +Experimental + +#### Description + +Represents the value of `self` as a binary literal in `string`. + +#### Syntax + +`call self % [[bitset_type(class):to_string(bound)]](string[, status]) + +#### Class + +Subroutine + +#### Arguments + +`self`: shall be a scalar expression of class `bitset_type`. It is an +`intent(in)` argument. + +`string`: shall be a scalar default character variable of allocatable +length. It is an `intent(out)` argument. On return it shall hav a +*binary-literal* representation of the bitset `self`. + +`status` (optional): shall be a scalar default integer variable. It is +an `intent(out)` argument. If present it shall have either the value +`success` or `alloc_fault`. If absent and it would have had the value +`alloc_fault` then processing will stop with an informative test as +the stop code. The values have the following meanings: + +`success` - no problem found. + +`alloc_fault` - allocation of `string` failed. + + +#### Example + + ```fortran + program demo_to_string + use stdlib_bitsets + character(*), parameter :: & + bits_all = '111111111111111111111111111111111' + type(bitset_64) :: set0 + character(:), allocatable :: new_string + call set0 % init(33) + call set0 % not() + call set0 % to_string( new_string ) + if ( new_string == bits_all ) then + write(*,*) "TO_STRING transferred BITS0 properly" // & + " into NEW_STRING." + end if + end program demo_to_string + +### `value` - determine the value of a bit + +#### Status + +Experimeental + +#### Description + +Determines the value of the bit at position, `pos`, in `self`. + +#### Syntax + +`result = self % [[bitset_type(class):value(bound)]](pos)` + +#### Class + +Elemental function. + +#### Arguments + +`self`: shall be a scalar expression of class `bitset_type`. It is an +`intent(in)` argument. + +`pos`: shall be a scalar integer expression of kind `bits_kind`. It is +an `intent(in)` argument. + +#### Result character + +The result is a default logical scalar. + +#### Result value + +The result is one if the bit at `pos` in `self` is set, otherwise it +is zero. If `pos` is outside the range `0... bits(set)-1` the result +is zero. + +#### Example + + ```fortran + program demo_value + use stdlib_bitsets + type(bitset_large) :: set0 + call set0 % init(166) + call set0 % not() + if ( set0 % all() ) write(*,*) 'SET0 is properly initialized.' + call set0 % clear(165) + if ( set0 % value(165) == 0 ) write(*,*) 'Bit 165 is cleared.' + call set0 % set(165) + if ( set0 % value(165) == 1 ) write(*,*) 'Bit 165 is set.' + end program demo_value + + +### `write_bitset` - writes a *bitset-literal* + +#### Status + +Experimental + +#### Description + +Writes a *bitset-literal* representing `self`'s current value to a +character string or formatted file. + + +#### Syntax + +`call self % [[bitset_type(class):write_bitset(bound)]](string[, status])` + +or + +`call self % [[bitset_type(class):write_bitset(bound)]] (unit[, advance, status])` + +#### Class + +Subroutine + +#### Arguments + +`self`: shall be a scalar expression of class `bitset_type`. It is an +`intent(in)` argument. + +`string` (optional): shall be a scalar default character variable of +allocatable length. It is an `intent(out)` argument. + +`unit` (optional): shall be a scalar default logical expression. It is +an `intent(in)` argument. Its value must be that of a I/O unit number +for an open formatted file with `write` or `readwrite` access. + +`advance` (optional): shall be a scalar default character +expression. It is an `intent(in)` argument. It is the `advance` +specifier for the write to `unit`. If present it must have the value +`'yes'` or `'no'`. It has the default value of `'yes'`. + +* if `advance` is not present or is present with a value of `'no'` + then the bitset's *bitset-literal* is written to `unit` + followed by a blank, and the current record is not advanced. + +* If `advance` is present with a value of `'yes'` then the + bitset's *bitset-literal* is written to `unit` and the + record is immediately advanced. + +`status` (optional): shall be a scalar default integer variable. It is +an `intent(out)` argument. If present on return it shall have the +value of one of the module's error codes. If absent and a problem was +found processing will stop with an informative stop code. It may have +the following error code values: + +* `success` - no problem was found + +* `alloc_fault` - allocation of the string failed + +* `write_failure` - the `write` to the `unit` failed + +#### Example + + ```fortran + program demo_write_bitset + character(*), parameter :: & + bits_0 = 'S33B000000000000000000000000000000000', & + bits_1 = 'S33B000000000000000000000000000000001', & + bits_33 = 'S33B100000000000000000000000000000000' + character(:), allocatable :: test_0, test_1, test_2 + integer :: unit + type(bitset_64) :: set0, set1, set2, set3, set4, set5 + call set0 % read_bitset( bits_0, status ) + call set1 % read_bitset( bits_1, status ) + call set2 % read_bitset( bits_2, status ) + call set0 % write_bitset( test_0, status ) + call set1 % write_bitset( test_1, status ) + call set2 % write_bitset( test_2, status ) + if ( bits_0 == test_0 .and. bits_1 == test_1 .and. & + bits_2 == test_2 ) then + write(*,*) 'READ_BITSET to WRITE_BITSET strings worked.' + end if + open( newunit=unit, file='test.txt', status='replace', & + form='formatted', action='write' ) + call set2 % write_bitset(unit, advance='no') + call set1 % write_bitset(unit, advance='no') + call set0 % write_bitset(unit) + close( unit ) + open( newunit=unit, file='test.txt', status='old', & + form='formatted', action='read' ) + call set3 % read_bitset(unit, advance='no') + call set4 % read_bitset(unit, advance='no') + call set5 % read_bitset(unit) + if ( set3 == set0 .and. set4 == set1 .and. set5 == set2 ) then + write(*,*) WRITE_BITSET to READ_BITSET through unit worked.' + end if + end program demo_write_bitset + + +### `xor` - bitwise exclusive `or` + +#### Status + +Experimental + +#### Description + +Replaces `set1`'s bitset with the bitwise exclusive `or` of the +original bits of `set1` and `set2`. Note `set1` and `set2` must have +the samee number of bits, otherwise the result is undefined. + +#### Syntax + +`result = [[stdlib_bitsets(module):xor(interface)]] (set1, set2)` + +#### Class + +Elemental subroutine + +#### Arguments + +`set1`: shall be a scalar `bitset_64` or `bitset_large` variable. It +is an `intent(inout)` argument. On return the values of the bits in +`set1` are the bitwise exclusive `or` of the original bits in `set1` +with the corresponding bits in `set2`. + +`set2` shall be a scalar expression of the same type as `set1`. It is + an `intent(in)` argument. Note `set1` and `set2` must have the +samee number of bits, otherwise the result is undefined. + +#### Example + + ```fortran + program demo_xor + use stdlib_bitsets + type(bitset_large) :: set0, set1 + call set0 % init(166) + call set1 % init(166) + call xor( set0, set1 ) ! none none + if ( none(set0) ) write(*,*) 'First test of XOR worked.' + call set0 % not() + call xor( set0, set1 ) ! all none + if ( all(set0) ) write(*,*) 'Second test of XOR worked.' + call set0 % not() + call set1 % not() + call xor( set0, set1 ) ! none all + if ( all(set0) ) write(*,*) 'Third test of XOR worked.' + call set0 % not() + call xor( set0, set1 ) ! all all + if ( none(set0) ) write(*,*) 'Fourth test of XOR worked.' + end program demo_xor + + +## Specification of the `stdlib_bitsets` operators + +### `==` - compare two bitsets to determine whether the bits have the same value + +#### Status + +Experimental + +#### Description + +Returns `.true.` if all bits in `set1` and `set2` have the same value, +`.false.` otherwise. + +#### Syntax + +`Result = set1 [[stdlib_bitsets(module):==(interface)]] set2 + +#### Class + +Elemental operator + +#### Arguments + +`set1`: shall be a scalar `bitset_64` or `bitset_large` expression. It +is an `intent(in)` argument. + +`set2`: shall be a scalar expression of the same type as `self`. It +will have the same number of bits as `set1`. It is an `intent(in)` +argument. + +#### Result character + +The result is a default logical scalar. + +#### Result value + +The result is `.true.` if the bits in both bitsets are set + to the same value, otherwise the result is `.FALSE.`. + +#### Example + + ```fortran + program demo_equality + use stdlib_bitsets + type(bitset_64) :: set0, set1, set2 + call set0 % init( 33 ) + call set1 % init( 33 ) + call set2 % init( 33 ) + call set1 % set( 0 ) + call set2 % set( 32 ) + if ( set0 == set0 .and. set1 == set1 .and. set2 == set2 .and. & + .not. set0 == set1 .and. .not. set0 == set2 .and. .not. & + set1 == set2 ) then + write(*,*) 'Passed 64 bit equality tests.' + else + error stop 'Failed 64 bit equality tests.' + end if + end program demo_equality + +### `/=` - compare two bitsets to determine whether any bits differ in value + +#### Status + +Experimental + +#### Description + +Returns `.true.` if any bits in `self` and `set2` differ in value, +`.false.` otherwise. + + +#### Syntax + +`Result = set1 [[stdlib_bitsets(module):/=(interface)]] set2` + +#### Class + +Elemental function + +#### Arguments + +`set1`: shall be a scalar `bitset_64` or `bitset_large` expression. It +is an `intent(in)` argument. + +`set2`: shall be a scalar expression of the same type as `self`. It +will have the same number of bits as `set1`. It is an `intent(in)` +argument. + +#### Result character + +The result is a default logical scalar. + +#### Result value + +The result is `.true.` if any bits in both bitsets differ, otherwise +the result is `.false.`. + +#### Example + + ```fortran + program demo_inequality + use stdlib_bitsets + type(bitset_64) :: set0, set1, set2 + call set0 % init( 33 ) + call set1 % init( 33 ) + call set2 % init( 33 ) + call set1 % set( 0 ) + call set2 % set( 32 ) + if ( set0 /= set1 .and. set0 /= set2 .and. set1 /= set2 .and. & + .not. set0 /= set0 .and. .not. set1 /= set1 .and. .not. & + set2 /= set2 ) then + write(*,*) 'Passed 64 bit inequality tests.' + else + error stop 'Failed 64 bit inequality tests.' + end if + end program demo_inequality + +### `>=` - compare two bitsets to determine whether the first is greater than or equal to the second + +#### Status + +Experimental + +#### Description + +Returns `.true.` if the bits in `set1` and `set2` are the same or the +highest order different bit is set to 1 in `set1` and to 0 in `set2`, +`.false.`. otherwise. The sets must be the same size otherwise the +results are undefined + + +#### Syntax + +`Result = set1 [[stdlib_bitsets(module):>=(interface)]] set2` + +#### Class + +Elemental operator + +#### Arguments + +`set1`: shall be a scalar `bitset_64` or `bitset_large` expression. It +is an `intent(in)` argument. + +`set2`: shall be a scalar expression of the same type as `self`. It +will have the same number of bits as `set1`. It is an `intent(in)` +argument. + +#### Result character + +The result is a default logical scalar. + +#### Result value + +The result is `.true.` if the bits in `set1` and `set2` are the same +or the highest order different bit is set to 1 in `set1` and to 0 in +`set2`, `.false.`. otherwise. + +#### Example + + ```fortran + program demo_ge + use stdlib_bitsets + type(bitset_64) :: set0, set1, set2 + call set0 % init( 33 ) + call set1 % init( 33 ) + call set2 % init( 33 ) + call set1 % set( 0 ) + call set2 % set( 32 ) + if ( set1 >= set0 .and. set2 >= set1 .and. set2 >= set0 .and. & + set0 >= set0 .and. set1 >= set1 .and. set2 >= set2 .and. & + .not. set0 >= set1 .and. .not. set0 >= set2 .and. .not. & + set1 >= set2 ) then + write(*,*) 'Passed 64 bit greater than or equals tests.' + else + error stop 'Failed 64 bit greater than or equals tests.' + end if + end program demo_ge + +### `>` - compare two bitsets to determine whether the first is greater than the other + +#### Status + +Experimental + +#### Description + +Returns `.true.` if the bits in `set1` and `set2` differ and the +highest order different bit is set to 1 in `set1` and to 0 in `set2`, +`.false.`. otherwise. The sets must be the same size otherwise the +results are undefined + +#### Syntax + +`Result = set1 [[stdlib_bitsets(module):>(interface)]] set2` + +#### Class + +Elemental operator + +#### Arguments + +`set1`: shall be a scalar `bitset_64` or `bitset_large` expression. It +is an `intent(in)` argument. + +`set2`: shall be a scalar expression of the same type as `self`. It +will have the same number of bits as `set1`. It is an `intent(in)` +argument. + +#### Result character + +The result is a default logical scalar. + +#### Result value + +The result is `.true.` if the bits in `set1` and `set2` differ and the +highest order different bit is set to 1 in `set1` and to 0 in `set2`, +`.false.`. otherwise. + +#### Example + + ```fortran + program demo_gt + use stdlib_bitsets + type(bitset_64) :: set0, set1, set2 + call set0 % init( 33 ) + call set1 % init( 33 ) + call set2 % init( 33 ) + call set1 % set( 0 ) + call set2 % set( 32 ) + if ( set1 > set0 .and. set2 > set1 .and. set2 > set0 .and. & + .not. set0 > set0 .and. .not. set0 > set1 .and. .not. & + set1 > set2 ) then + write(*,*) 'Passed 64 bit greater than tests.' + else + error stop 'Failed 64 bit greater than tests.' + end if + end program demo_gt + + +### `<=` - compare two bitsets to determine whether the first is less than or equal to the other + +#### Status + +Experimental + +#### Description + +Returns `.true.` if the bits in `set1` and `set2` are the same or the +highest order different bit is set to 0 in `set1` and to 1 in `set2`, +`.false.`. otherwise. The sets must be the same size otherwise the +results are undefined + + +#### Syntax + +`Result = set1 [[stdlib_bitsets(module):<=(interface)]] set2` + +#### Class + +Elemental operator + +#### Arguments + +`set1`: shall be a scalar `bitset_64` or `bitset_large` expression. It +is an `intent(in)` argument. + +`set2`: shall be a scalar expression of the same type as `self`. It +will have the same number of bits as `set1`. It is an `intent(in)` +argument. + +#### Result character + +The result is a default logical scalar. + +#### Result value + +The result is `.true.` if the bits in `set1` and `set2` are the same +or the highest order different bit is set to 0 in `set1` and to 1 in +`set2`, `.false.`. otherwise. + +#### Example + + ```fortran + program demo_le + use stdlib_bitsets + type(bitset_64) :: set0, set1, set2 + call set0 % init( 33 ) + call set1 % init( 33 ) + call set2 % init( 33 ) + call set1 % set( 0 ) + call set2 % set( 32 ) + if ( set0 <= set1 .and. set1 <= set2 .and. set0 <= set2 .and. & + set0 <= set0 .and. set1 <= set1 .and. set2 <= set2 .and. & + .not. set1 <= set0 .and. .not. set2 <= set0 .and. .not. & + set2 <= set1 ) then + write(*,*) 'Passed 64 bit less than or equal tests.' + else + error stop 'Failed 64 bit less than or equal tests.' + end if + end program demo_le + +### `<` - compare two bitsets to determine whether the first is less than the other + +#### Status + +Experimental + +#### Description + +Returns `.true.` if the bits in `set1` and `set2` differ and the +highest order different bit is set to 0 in `set1` and to 1 in `set2`, +`.false.`. otherwise. The sets must be the same size otherwise the +results are undefined + + +#### Syntax + +`Result = set1 [[stdlib_bitsets(module):<(interface)]] set2` + +#### Class + +Elemental operator + +#### Arguments + +`set1`: shall be a scalar `bitset_64` or `bitset_large` expression. It +is an `intent(in)` argument. + +`set2`: shall be a scalar expression of the same type as `self`. It +will have the same number of bits as `set1`. It is an `intent(in)` +argument. + +#### Result character + +The result is a default logical scalar. + +#### Result value + +The result is `.true.` if the bits in `set1` and `set2` differ and the +highest order different bit is set to 0 in `set1` and to 1 in `set2`, +`.false.` otherwise. + +#### Example + + ```fortran + program demo_lt + use stdlib_bitsets + type(bitset_64) :: set0, set1, set2 + call set0 % init( 33 ) + call set1 % init( 33 ) + call set2 % init( 33 ) + call set1 % set( 0 ) + call set2 % set( 32 ) + if ( set0 < set1 .and. set1 < set2 .and. set0 < set2 .and. & + .not. set0 < set0 .and. .not. set2 < set0 .and. .not. & + set2 < set1 ) then + write(*,*) 'Passed 64 bit less than tests.' + else + error stop 'Failed 64 bit less than tests.' + end if + end program demo_lt + From acfa3ac384de83a6a0131178c68f993148f26232 Mon Sep 17 00:00:00 2001 From: Jeremie Vandenplas Date: Sun, 4 Oct 2020 19:35:38 +0200 Subject: [PATCH 05/53] Update doc/specs/stdlib_bitsets.md --- doc/specs/stdlib_bitsets.md | 2 -- 1 file changed, 2 deletions(-) diff --git a/doc/specs/stdlib_bitsets.md b/doc/specs/stdlib_bitsets.md index cb9b9891d..aa8927f23 100644 --- a/doc/specs/stdlib_bitsets.md +++ b/doc/specs/stdlib_bitsets.md @@ -162,7 +162,6 @@ is mapped to a set bit, and `.false.` is mapped to an unset bit. end if end program demo_assignment - ### Table of the `bitset_type` methods The `bitset_type` class has a number of methods. All except one, `bits`, @@ -1972,4 +1971,3 @@ highest order different bit is set to 0 in `set1` and to 1 in `set2`, error stop 'Failed 64 bit less than tests.' end if end program demo_lt - From 7c5361caff2b06073cf9fbf1328e03d7321130d4 Mon Sep 17 00:00:00 2001 From: Jeremie Vandenplas Date: Sun, 4 Oct 2020 19:35:49 +0200 Subject: [PATCH 06/53] Update doc/specs/stdlib_bitsets.md --- doc/specs/stdlib_bitsets.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/specs/stdlib_bitsets.md b/doc/specs/stdlib_bitsets.md index aa8927f23..357f2c744 100644 --- a/doc/specs/stdlib_bitsets.md +++ b/doc/specs/stdlib_bitsets.md @@ -4,7 +4,7 @@ title: Bitsets # The `stdlib_bitsets` module -(TOC) +[TOC] ## Introduction From eb2e5c17ddf84314f90ba7967f5fc1653770eac2 Mon Sep 17 00:00:00 2001 From: Jeremie Vandenplas Date: Sun, 4 Oct 2020 19:43:35 +0200 Subject: [PATCH 07/53] formatting --- doc/specs/stdlib_bitsets.md | 103 +++++++++++++++++++++--------------- 1 file changed, 60 insertions(+), 43 deletions(-) diff --git a/doc/specs/stdlib_bitsets.md b/doc/specs/stdlib_bitsets.md index 357f2c744..1a4e70938 100644 --- a/doc/specs/stdlib_bitsets.md +++ b/doc/specs/stdlib_bitsets.md @@ -136,7 +136,7 @@ is mapped to a set bit, and `.false.` is mapped to an unset bit. #### Example - ```fortran +```fortran program demo_assignment use stdlib_bitsets logical(int8) :: logical1(64) = .true. @@ -161,6 +161,7 @@ is mapped to a set bit, and `.false.` is mapped to an unset bit. write(*,*) 'Initialization of logical(int32) succeeded.' end if end program demo_assignment +``` ### Table of the `bitset_type` methods @@ -263,7 +264,7 @@ otherwise it is `.false.`. #### Example - ```fortran +```fortran program demo_all use stdlib_bitsets character(*), parameter :: & @@ -281,7 +282,7 @@ otherwise it is `.false.`. " into set0." end if end program demo_all - +``` #### `and` - bitwise `and` of the bits of two bitsets. @@ -316,7 +317,7 @@ number of bits as `set1`. #### Example - ```fortran +```fortran program demo_and use stdlib_bitsets type(bitset_large) :: set0, set1 @@ -334,6 +335,7 @@ number of bits as `set1`. call and( set0, set1 ) ! all all if ( all(set0) ) write(*,*) 'Fourth test of AND worked.' end program demo_and +``` ### `and_not` - Bitwise `and` of one bitset with the negation of another @@ -369,7 +371,7 @@ number of bits as `set1` otherwise the result is undefined. #### Example - ```fortran +```fortran program demo_and_not use stdlib_bitsets type(bitset_large) :: set0, set1 @@ -388,6 +390,7 @@ number of bits as `set1` otherwise the result is undefined. call and_not( set0, set1 ) ! all all if ( none(set0) ) write(*,*) 'Fourth test of AND_NOT worked.' end program demo_and_not +``` ### `any` - determine whether any bits are set @@ -423,7 +426,7 @@ is `.false.`. #### Example - ```fortran +```fortran program demo_any use stdlib_bitsets character(*), parameter :: & @@ -439,7 +442,7 @@ is `.false.`. write(*,*) "ANY interpreted SET0's value properly." end if end program demo_any - +``` ### `bit_count` - return the number of bits that are set @@ -474,7 +477,7 @@ The result is the number of bits that are set in `self`. #### Example - ```fortran +```fortran program demo_bit_count use stdlib_bitsets character(*), parameter :: & @@ -490,7 +493,7 @@ The result is the number of bits that are set in `self`. write(*,*) "BIT_COUNT interpreted SET0's value properly." end if end program demo_bit_count - +``` #### `bits` - returns the number of bits @@ -525,7 +528,7 @@ The result is the number of defined bits in `self`. #### Example - ```fortran +```fortran program demo_bits use stdlib_bitsets character(*), parameter :: & @@ -537,7 +540,7 @@ The result is the number of defined bits in `self`. "BITS_0's size properly." end if end program demo_bits - +``` ### `clear` - clears a sequence of one or more bits. @@ -586,7 +589,7 @@ an `intent(in)` argument. #### Example - ```fortran +```fortran program demo_clear use stdlib_bitsets type(bitset_large) :: set0 @@ -598,6 +601,7 @@ an `intent(in)` argument. call set0 % clear(0,164) if ( set0 % none() ) write(*,*) 'All bits are cleared.' end program demo_clear +``` ### `extract` - create a new bitset from a range in an old bitset @@ -646,7 +650,7 @@ an `intent(out)` argument. If present it shall have one of the values: #### Example - ```fortran +```fortran program demo_extract use stdlib_bitsets type(bitset_large) :: set0, set1 @@ -657,6 +661,7 @@ an `intent(out)` argument. If present it shall have one of the values: write(*,*) 'SET1 has the proper size.' if ( set1 % all() ) write(*,*) 'SET1 has the proper values.' end program demo_extract +``` ### `flip` - flip the values of a sequence of one or more bits @@ -703,7 +708,7 @@ an `intent(in)` argument. #### Example - ```fortran +```fortran program demo_flip use stdlib_bitsets type(bitset_large) :: set0 @@ -714,6 +719,7 @@ an `intent(in)` argument. call set0 % flip(0,164) if ( set0 % all() ) write(*,*) 'All bits are flipped.' end program demo_flip +``` ### `from_string` - initializes a bitset from a binary literal @@ -751,7 +757,7 @@ informative text as its stop code. #### Example - ```fortran +```fortran program demo_from_string use stdlib_bitsets character(*), parameter :: & @@ -769,6 +775,7 @@ informative text as its stop code. " into set0." end if end program demo_from_string +``` ### `init` - `bitset_type` initialization routines. @@ -815,7 +822,7 @@ stop code. It can have any of the following error codes: #### Example - ```fortran +```fortran program demo_init use stdlib_bitsets type(bitset_large) :: set0 @@ -824,6 +831,7 @@ stop code. It can have any of the following error codes: write(*,*) `SET0 has the proper size.' if ( set0 % none() ) write(*,*) 'SET0 is properly initialized.' end program demo_init +``` ### `input` - reads a bitset from an unformatted file @@ -874,7 +882,7 @@ values for this `status` are: #### Example - ```fortran +```fortran program demo_input character(*), parameter :: & bits_0 = '000000000000000000000000000000000', & @@ -905,7 +913,7 @@ values for this `status` are: 'output and input succeeded.' end if end program demo_input - +``` ### `none` - determines whether no bits are set @@ -941,7 +949,7 @@ The result is `.true.` if no bits in `self` are set, otherwise it is #### Example - ```fortran +```fortran program demo_none use stdlib_bitsets character(*), parameter :: & @@ -957,7 +965,7 @@ The result is `.true.` if no bits in `self` are set, otherwise it is write(*,*) "NONE interpreted SET0's value properly." end if end program demo_none - +``` ### `not` - Performs the logical complement on a bitset @@ -985,7 +993,7 @@ Elemental subroutine. #### Example - ```fortran +```fortran program demo_not use stdlib_bitsets type(bitset_large) :: set0 @@ -999,6 +1007,7 @@ Elemental subroutine. write(*,*) "ALL interpreted SET0's value properly." end if end program demo_not +``` ### `or` - Bitwise OR of the bits of two bitsets. @@ -1033,7 +1042,7 @@ otherwise the results are undefined. #### Example - ```fortran +```fortran program demo_or use stdlib_bitsets type(bitset_large) :: set0, set1 @@ -1052,7 +1061,7 @@ otherwise the results are undefined. call or( set0, set1 ) ! all all if ( all(set0) ) write(*,*) 'Fourth test of OR worked.' end program demo_or - +``` ### `output` - Writes a binary representation of a bitset to a file @@ -1093,7 +1102,7 @@ code. The two code values have the meaning: #### Example - ```fortran +```fortran program demo_output character(*), parameter :: & bits_0 = '000000000000000000000000000000000', & @@ -1124,6 +1133,7 @@ code. The two code values have the meaning: 'output and input succeeded.' end if end program demo_output +``` ### `read_bitset` - initializes `self` with the value of a *bitset_literal* @@ -1197,7 +1207,7 @@ as its error code. The possible error codes are: #### Example - ```fortran +```fortran program demo_read_bitset character(*), parameter :: & bits_0 = 'S33B000000000000000000000000000000000', & @@ -1231,7 +1241,7 @@ as its error code. The possible error codes are: write(*,*) WRITE_BITSET to READ_BITSET through unit worked.' end if end program demo_read_bitset - +``` ### `set` - sets a sequence of one or more bits to 1. @@ -1283,7 +1293,7 @@ Elemental subroutine #### Example - ```fortran +```fortran program demo_set use stdlib_bitsets type(bitset_large) :: set0 @@ -1294,6 +1304,7 @@ Elemental subroutine call set0 % set(0,164) if ( set0 % all() ) write(*,*) 'All bits are set.' end program demo_set +``` ### `test` - determine whether a bit is set @@ -1334,7 +1345,7 @@ otherwise it is `.false.`. If `pos` is outside the range #### Example - ```fortran +```fortran program demo_test use stdlib_bitsets type(bitset_large) :: set0 @@ -1346,7 +1357,7 @@ otherwise it is `.false.`. If `pos` is outside the range call set0 % set(165) if ( set0 % test(165) ) write(*,*) 'Bit 165 is set.' end program demo_test - +``` ### `to_string` - represent a bitset as a binary literal @@ -1388,7 +1399,7 @@ the stop code. The values have the following meanings: #### Example - ```fortran +```fortran program demo_to_string use stdlib_bitsets character(*), parameter :: & @@ -1403,6 +1414,7 @@ the stop code. The values have the following meanings: " into NEW_STRING." end if end program demo_to_string +``` ### `value` - determine the value of a bit @@ -1442,7 +1454,7 @@ is zero. #### Example - ```fortran +```fortran program demo_value use stdlib_bitsets type(bitset_large) :: set0 @@ -1454,7 +1466,7 @@ is zero. call set0 % set(165) if ( set0 % value(165) == 1 ) write(*,*) 'Bit 165 is set.' end program demo_value - +``` ### `write_bitset` - writes a *bitset-literal* @@ -1519,7 +1531,7 @@ the following error code values: #### Example - ```fortran +```fortran program demo_write_bitset character(*), parameter :: & bits_0 = 'S33B000000000000000000000000000000000', & @@ -1553,7 +1565,7 @@ the following error code values: write(*,*) WRITE_BITSET to READ_BITSET through unit worked.' end if end program demo_write_bitset - +``` ### `xor` - bitwise exclusive `or` @@ -1588,7 +1600,7 @@ samee number of bits, otherwise the result is undefined. #### Example - ```fortran +```fortran program demo_xor use stdlib_bitsets type(bitset_large) :: set0, set1 @@ -1607,7 +1619,7 @@ samee number of bits, otherwise the result is undefined. call xor( set0, set1 ) ! all all if ( none(set0) ) write(*,*) 'Fourth test of XOR worked.' end program demo_xor - +``` ## Specification of the `stdlib_bitsets` operators @@ -1650,7 +1662,7 @@ The result is `.true.` if the bits in both bitsets are set #### Example - ```fortran +```fortran program demo_equality use stdlib_bitsets type(bitset_64) :: set0, set1, set2 @@ -1667,6 +1679,7 @@ The result is `.true.` if the bits in both bitsets are set error stop 'Failed 64 bit equality tests.' end if end program demo_equality +``` ### `/=` - compare two bitsets to determine whether any bits differ in value @@ -1708,7 +1721,7 @@ the result is `.false.`. #### Example - ```fortran +```fortran program demo_inequality use stdlib_bitsets type(bitset_64) :: set0, set1, set2 @@ -1725,6 +1738,7 @@ the result is `.false.`. error stop 'Failed 64 bit inequality tests.' end if end program demo_inequality +``` ### `>=` - compare two bitsets to determine whether the first is greater than or equal to the second @@ -1769,7 +1783,7 @@ or the highest order different bit is set to 1 in `set1` and to 0 in #### Example - ```fortran +```fortran program demo_ge use stdlib_bitsets type(bitset_64) :: set0, set1, set2 @@ -1787,6 +1801,7 @@ or the highest order different bit is set to 1 in `set1` and to 0 in error stop 'Failed 64 bit greater than or equals tests.' end if end program demo_ge +``` ### `>` - compare two bitsets to determine whether the first is greater than the other @@ -1830,7 +1845,7 @@ highest order different bit is set to 1 in `set1` and to 0 in `set2`, #### Example - ```fortran +```fortran program demo_gt use stdlib_bitsets type(bitset_64) :: set0, set1, set2 @@ -1847,7 +1862,7 @@ highest order different bit is set to 1 in `set1` and to 0 in `set2`, error stop 'Failed 64 bit greater than tests.' end if end program demo_gt - +``` ### `<=` - compare two bitsets to determine whether the first is less than or equal to the other @@ -1892,7 +1907,7 @@ or the highest order different bit is set to 0 in `set1` and to 1 in #### Example - ```fortran +```fortran program demo_le use stdlib_bitsets type(bitset_64) :: set0, set1, set2 @@ -1910,6 +1925,7 @@ or the highest order different bit is set to 0 in `set1` and to 1 in error stop 'Failed 64 bit less than or equal tests.' end if end program demo_le +``` ### `<` - compare two bitsets to determine whether the first is less than the other @@ -1954,7 +1970,7 @@ highest order different bit is set to 0 in `set1` and to 1 in `set2`, #### Example - ```fortran +```fortran program demo_lt use stdlib_bitsets type(bitset_64) :: set0, set1, set2 @@ -1971,3 +1987,4 @@ highest order different bit is set to 0 in `set1` and to 1 in `set2`, error stop 'Failed 64 bit less than tests.' end if end program demo_lt +``` From e70c9094178bd4fa0ff49d496bb0205f7e8adb14 Mon Sep 17 00:00:00 2001 From: Jeremie Vandenplas Date: Sun, 4 Oct 2020 19:49:23 +0200 Subject: [PATCH 08/53] Update src/tests/Makefile.manual --- src/tests/Makefile.manual | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tests/Makefile.manual b/src/tests/Makefile.manual index 2fa5fbd27..89325cd56 100644 --- a/src/tests/Makefile.manual +++ b/src/tests/Makefile.manual @@ -11,7 +11,7 @@ all: test: $(MAKE) -f Makefile.manual --directory=ascii test - $(MAKE) -f Makefile.manual --directoru=bitsets test + $(MAKE) -f Makefile.manual --directory=bitsets test $(MAKE) -f Makefile.manual --directory=io test $(MAKE) -f Makefile.manual --directory=logger test $(MAKE) -f Makefile.manual --directory=optval test From 8e25812384a68e05b6756fa3d402e01f8264ea97 Mon Sep 17 00:00:00 2001 From: Jeremie Vandenplas Date: Sun, 4 Oct 2020 20:38:17 +0200 Subject: [PATCH 09/53] Update doc/specs/stdlib_bitsets.md --- doc/specs/stdlib_bitsets.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/specs/stdlib_bitsets.md b/doc/specs/stdlib_bitsets.md index 1a4e70938..756e70ca7 100644 --- a/doc/specs/stdlib_bitsets.md +++ b/doc/specs/stdlib_bitsets.md @@ -1098,7 +1098,7 @@ code. The two code values have the meaning: * `success` - no problem found -* `write_failure` - a failure occured in a write statement. +* `write_failure` - a failure occurred in a write statement. #### Example From c9e851ba0ed934e22aa00ef24ba8788313c582ed Mon Sep 17 00:00:00 2001 From: William Clodius Date: Wed, 7 Oct 2020 18:22:55 -0600 Subject: [PATCH 10/53] Changed makefiles to accept stdlib_bitset*.fypp instead of stdlib_bitset*.f90 Changed makeefiles to preprocess ths stdlib_bitset*.fypp files to stdlib_bitset*.f90 files. [ticket: X] --- src/CMakeLists.txt | 6 +++--- src/Makefile.manual | 3 +++ 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 77005e8e9..0253a8e9c 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -2,6 +2,9 @@ # Create a list of the files to be preprocessed set(fppFiles + stdlib_bitset_64.fypp + stdlib_bitset_large.fypp + stdlib_bitsets.fypp stdlib_io.fypp stdlib_linalg.fypp stdlib_linalg_diag.fypp @@ -31,9 +34,6 @@ fypp_f90("${fyppFlags}" "${fppFiles}" outFiles) set(SRC stdlib_ascii.f90 - stdlib_bitsets.f90 - stdlib_bitset_64.f90 - stdlib_bitset_large.f90 stdlib_error.f90 stdlib_kinds.f90 stdlib_logger.f90 diff --git a/src/Makefile.manual b/src/Makefile.manual index 3986112f6..4a1ec3110 100644 --- a/src/Makefile.manual +++ b/src/Makefile.manual @@ -68,6 +68,9 @@ stdlib_stats_var.o: \ stdlib_stats.o # Fortran sources that are built from fypp templates +stdlib_bitset_64.f90: stdlib_bitset_64.fypp +stdlib_bitset_large.f90: stdlib_bitset_large.fypp +stdlib_bitsets.f90: stdlib_bitsets.fypp stdlib_io.f90: stdlib_io.fypp stdlib_linalg.f90: stdlib_linalg.fypp stdlib_linalg_diag.f90: stdlib_linalg_diag.fypp From d80e5d9e374491168077aa7bf0d84ffc4ed3d943 Mon Sep 17 00:00:00 2001 From: William Clodius Date: Wed, 7 Oct 2020 18:28:24 -0600 Subject: [PATCH 11/53] Renamed files stdlib_bitset*.f90 to stdlib_bitset*.fypp Renamed files stdlib_bitset*.f90 to fypp preprocessor stdlib_bitset*.fypp files [ticket: X] --- src/stdlib_bitset_64.f90 | 122 ++++++++++++++---------------- src/stdlib_bitset_large.f90 | 129 +++++++++++++++---------------- src/stdlib_bitsets.f90 | 146 +++++++++++++++++------------------- 3 files changed, 189 insertions(+), 208 deletions(-) diff --git a/src/stdlib_bitset_64.f90 b/src/stdlib_bitset_64.f90 index eaf2224d5..bebce9bde 100644 --- a/src/stdlib_bitset_64.f90 +++ b/src/stdlib_bitset_64.f90 @@ -82,7 +82,7 @@ pure module subroutine assign_64( set1, set2 ) end subroutine assign_64 - module subroutine assign_log8_64( self, logical_vector ) + module subroutine assign_logint8_64( self, logical_vector ) ! Used to define assignment from an array of type logical for bitset_64 type(bitset_64), intent(out) :: self logical(int8), intent(in) :: logical_vector(:) @@ -104,38 +104,30 @@ module subroutine assign_log8_64( self, logical_vector ) end if end do - end subroutine assign_log8_64 + end subroutine assign_logint8_64 - module subroutine assign_log16_64( self, logical_vector ) -! Used to define assignment from an array of type logical for bitset_64 - type(bitset_64), intent(out) :: self - logical(int16), intent(in) :: logical_vector(:) + pure module subroutine logint8_assign_64( logical_vector, set ) +! Used to define assignment to an array of type logical for bitset_64 + logical(int8), intent(out), allocatable :: logical_vector(:) + type(bitset_64), intent(in) :: set - integer(bits_kind) :: log_size integer(bits_kind) :: index - log_size = size( logical_vector, kind=bits_kind ) - if ( log_size > 64 ) then - error stop module_name // ' % ' // 'ASSIGNMENT' // " has " // & - "SIZE(LOGICAL_VECTOR) > 64 with assignment to a BITSET_64." - end if - self % num_bits = log_size - self % block = 0 - - do index=0, log_size-1 - if ( logical_vector(index+1) ) then - self % block = ibset( self % block, index ) + allocate( logical_vector( set % num_bits ) ) + do index=0, set % num_bits-1 + if ( set % value( index ) == 1 ) then + logical_vector(index+1) = .true. + else + logical_vector(index+1) = .false. end if end do - end subroutine assign_log16_64 - - - module subroutine assign_log32_64( self, logical_vector ) + end subroutine logint8_assign_64 + module subroutine assign_logint16_64( self, logical_vector ) ! Used to define assignment from an array of type logical for bitset_64 type(bitset_64), intent(out) :: self - logical(int32), intent(in) :: logical_vector(:) + logical(int16), intent(in) :: logical_vector(:) integer(bits_kind) :: log_size integer(bits_kind) :: index @@ -154,13 +146,30 @@ module subroutine assign_log32_64( self, logical_vector ) end if end do - end subroutine assign_log32_64 + end subroutine assign_logint16_64 + + + pure module subroutine logint16_assign_64( logical_vector, set ) +! Used to define assignment to an array of type logical for bitset_64 + logical(int16), intent(out), allocatable :: logical_vector(:) + type(bitset_64), intent(in) :: set + + integer(bits_kind) :: index + allocate( logical_vector( set % num_bits ) ) + do index=0, set % num_bits-1 + if ( set % value( index ) == 1 ) then + logical_vector(index+1) = .true. + else + logical_vector(index+1) = .false. + end if + end do - module subroutine assign_log64_64( self, logical_vector ) + end subroutine logint16_assign_64 + module subroutine assign_logint32_64( self, logical_vector ) ! Used to define assignment from an array of type logical for bitset_64 type(bitset_64), intent(out) :: self - logical(int64), intent(in) :: logical_vector(:) + logical(int32), intent(in) :: logical_vector(:) integer(bits_kind) :: log_size integer(bits_kind) :: index @@ -179,12 +188,12 @@ module subroutine assign_log64_64( self, logical_vector ) end if end do - end subroutine assign_log64_64 + end subroutine assign_logint32_64 - pure module subroutine log8_assign_64( logical_vector, set ) + pure module subroutine logint32_assign_64( logical_vector, set ) ! Used to define assignment to an array of type logical for bitset_64 - logical(int8), intent(out), allocatable :: logical_vector(:) + logical(int32), intent(out), allocatable :: logical_vector(:) type(bitset_64), intent(in) :: set integer(bits_kind) :: index @@ -198,51 +207,36 @@ pure module subroutine log8_assign_64( logical_vector, set ) end if end do - end subroutine log8_assign_64 - - - pure module subroutine log16_assign_64( logical_vector, set ) -! Used to define assignment to an array of type logical for bitset_64 - logical(int16), intent(out), allocatable :: logical_vector(:) - type(bitset_64), intent(in) :: set + end subroutine logint32_assign_64 + module subroutine assign_logint64_64( self, logical_vector ) +! Used to define assignment from an array of type logical for bitset_64 + type(bitset_64), intent(out) :: self + logical(int64), intent(in) :: logical_vector(:) + integer(bits_kind) :: log_size integer(bits_kind) :: index - allocate( logical_vector( set % num_bits ) ) - do index=0, set % num_bits-1 - if ( set % value( index ) == 1 ) then - logical_vector(index+1) = .true. - else - logical_vector(index+1) = .false. - end if - end do - - end subroutine log16_assign_64 - - - pure module subroutine log32_assign_64( logical_vector, set ) -! Used to define assignment to an array of type logical for bitset_64 - logical(int32), intent(out), allocatable :: logical_vector(:) - type(bitset_64), intent(in) :: set - - integer(bits_kind) :: index + log_size = size( logical_vector, kind=bits_kind ) + if ( log_size > 64 ) then + error stop module_name // ' % ' // 'ASSIGNMENT' // " has " // & + "SIZE(LOGICAL_VECTOR) > 64 with assignment to a BITSET_64." + end if + self % num_bits = log_size + self % block = 0 - allocate( logical_vector( set % num_bits ) ) - do index=0, set % num_bits-1 - if ( set % value( index ) == 1 ) then - logical_vector(index+1) = .true. - else - logical_vector(index+1) = .false. + do index=0, log_size-1 + if ( logical_vector(index+1) ) then + self % block = ibset( self % block, index ) end if end do - end subroutine log32_assign_64 + end subroutine assign_logint64_64 - pure module subroutine log64_assign_64( logical_vector, set ) + pure module subroutine logint64_assign_64( logical_vector, set ) ! Used to define assignment to an array of type logical for bitset_64 logical(int64), intent(out), allocatable :: logical_vector(:) - type(bitset_64), intent(in) :: set + type(bitset_64), intent(in) :: set integer(bits_kind) :: index @@ -255,7 +249,7 @@ pure module subroutine log64_assign_64( logical_vector, set ) end if end do - end subroutine log64_assign_64 + end subroutine logint64_assign_64 elemental module function bit_count_64(self) result(bit_count) diff --git a/src/stdlib_bitset_large.f90 b/src/stdlib_bitset_large.f90 index 80674db76..137825694 100644 --- a/src/stdlib_bitset_large.f90 +++ b/src/stdlib_bitset_large.f90 @@ -99,8 +99,7 @@ pure module subroutine assign_large( set1, set2 ) end subroutine assign_large - - pure module subroutine assign_log8_large( self, logical_vector ) + pure module subroutine assign_logint8_large( self, logical_vector ) ! Used to define assignment from an array of type logical for bitset_large type(bitset_large), intent(out) :: self logical(int8), intent(in) :: logical_vector(:) @@ -125,41 +124,30 @@ pure module subroutine assign_log8_large( self, logical_vector ) end if end do - end subroutine assign_log8_large + end subroutine assign_logint8_large - pure module subroutine assign_log16_large( self, logical_vector ) -! Used to define assignment from an array of type logical for bitset_large - type(bitset_large), intent(out) :: self - logical(int16), intent(in) :: logical_vector(:) + pure module subroutine logint8_assign_large( logical_vector, set ) +! Used to define assignment to an array of type logical for bitset_large + logical(int8), intent(out), allocatable :: logical_vector(:) + type(bitset_large), intent(in) :: set - integer(bits_kind) :: blocks - integer(bits_kind) :: log_size integer(bits_kind) :: index - log_size = size( logical_vector, 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 - - do index=0, log_size-1 - if ( logical_vector(index+1) ) then - call self % set( index ) + allocate( logical_vector( set % num_bits ) ) + do index=0, set % num_bits-1 + if ( set % value( index ) == 1 ) then + logical_vector(index+1) = .true. + else + logical_vector(index+1) = .false. end if end do - end subroutine assign_log16_large - - - pure module subroutine assign_log32_large( self, logical_vector ) + end subroutine logint8_assign_large + pure module subroutine assign_logint16_large( self, logical_vector ) ! Used to define assignment from an array of type logical for bitset_large type(bitset_large), intent(out) :: self - logical(int32), intent(in) :: logical_vector(:) + logical(int16), intent(in) :: logical_vector(:) integer(bits_kind) :: blocks integer(bits_kind) :: log_size @@ -181,13 +169,30 @@ pure module subroutine assign_log32_large( self, logical_vector ) end if end do - end subroutine assign_log32_large + end subroutine assign_logint16_large + + + pure module subroutine logint16_assign_large( logical_vector, set ) +! Used to define assignment to an array of type logical for bitset_large + logical(int16), intent(out), allocatable :: logical_vector(:) + type(bitset_large), intent(in) :: set + + integer(bits_kind) :: index + allocate( logical_vector( set % num_bits ) ) + do index=0, set % num_bits-1 + if ( set % value( index ) == 1 ) then + logical_vector(index+1) = .true. + else + logical_vector(index+1) = .false. + end if + end do - pure module subroutine assign_log64_large( self, logical_vector ) + end subroutine logint16_assign_large + pure module subroutine assign_logint32_large( self, logical_vector ) ! Used to define assignment from an array of type logical for bitset_large type(bitset_large), intent(out) :: self - logical(int64), intent(in) :: logical_vector(:) + logical(int32), intent(in) :: logical_vector(:) integer(bits_kind) :: blocks integer(bits_kind) :: log_size @@ -209,12 +214,12 @@ pure module subroutine assign_log64_large( self, logical_vector ) end if end do - end subroutine assign_log64_large + end subroutine assign_logint32_large - pure module subroutine log8_assign_large( logical_vector, set ) + pure module subroutine logint32_assign_large( logical_vector, set ) ! Used to define assignment to an array of type logical for bitset_large - logical(int8), intent(out), allocatable :: logical_vector(:) + logical(int32), intent(out), allocatable :: logical_vector(:) type(bitset_large), intent(in) :: set integer(bits_kind) :: index @@ -228,51 +233,39 @@ pure module subroutine log8_assign_large( logical_vector, set ) end if end do - end subroutine log8_assign_large - - - pure module subroutine log16_assign_large( logical_vector, set ) -! Used to define assignment to an array of type logical for bitset_large - logical(int16), intent(out), allocatable :: logical_vector(:) - type(bitset_large), intent(in) :: set + end subroutine logint32_assign_large + pure module subroutine assign_logint64_large( self, logical_vector ) +! Used to define assignment from an array of type logical for bitset_large + type(bitset_large), intent(out) :: self + logical(int64), intent(in) :: logical_vector(:) + integer(bits_kind) :: blocks + integer(bits_kind) :: log_size integer(bits_kind) :: index - allocate( logical_vector( set % num_bits ) ) - do index=0, set % num_bits-1 - if ( set % value( index ) == 1 ) then - logical_vector(index+1) = .true. - else - logical_vector(index+1) = .false. - end if - end do - - end subroutine log16_assign_large - - - pure module subroutine log32_assign_large( logical_vector, set ) -! Used to define assignment to an array of type logical for bitset_large - logical(int32), intent(out), allocatable :: logical_vector(:) - type(bitset_large), intent(in) :: set - - integer(bits_kind) :: index + log_size = size( logical_vector, 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 - allocate( logical_vector( set % num_bits ) ) - do index=0, set % num_bits-1 - if ( set % value( index ) == 1 ) then - logical_vector(index+1) = .true. - else - logical_vector(index+1) = .false. + do index=0, log_size-1 + if ( logical_vector(index+1) ) then + call self % set( index ) end if end do - end subroutine log32_assign_large + end subroutine assign_logint64_large - pure module subroutine log64_assign_large( logical_vector, set ) + pure module subroutine logint64_assign_large( logical_vector, set ) ! Used to define assignment to an array of type logical for bitset_large logical(int64), intent(out), allocatable :: logical_vector(:) - type(bitset_large), intent(in) :: set + type(bitset_large), intent(in) :: set integer(bits_kind) :: index @@ -285,7 +278,7 @@ pure module subroutine log64_assign_large( logical_vector, set ) end if end do - end subroutine log64_assign_large + end subroutine logint64_assign_large elemental module function bit_count_large(self) result(bit_count) diff --git a/src/stdlib_bitsets.f90 b/src/stdlib_bitsets.f90 index 96853eeb2..d9965549d 100644 --- a/src/stdlib_bitsets.f90 +++ b/src/stdlib_bitsets.f90 @@ -1125,77 +1125,74 @@ pure module subroutine assign_large( set1, set2 ) type(bitset_large), intent(in) :: set2 end subroutine assign_large - pure module subroutine assign_log8_large( self, logical_vector ) + pure module subroutine assign_logint8_large( self, logical_vector ) !! Version: experimental !! !! Used to define assignment from an array of type `logical(int8)` to a !! `bitset_large`. type(bitset_large), intent(out) :: self logical(int8), intent(in) :: logical_vector(:) - end subroutine assign_log8_large + end subroutine assign_logint8_large - pure module subroutine assign_log16_large( self, logical_vector ) + pure module subroutine logint8_assign_large( logical_vector, set ) !! Version: experimental !! -!! Used to define assignment from an array of type `logical(int16)` to a +!! Used to define assignment to an array of type `logical(int8)` from a !! `bitset_large`. - type(bitset_large), intent(out) :: self - logical(int16), intent(in) :: logical_vector(:) - end subroutine assign_log16_large - - pure module subroutine assign_log32_large( self, logical_vector ) -!! Version: experimental -!! -!! Used to define assignment from an array of type `logical(int32)` to a -!! `bitset_large` - type(bitset_large), intent(out) :: self - logical(int32), intent(in) :: logical_vector(:) - end subroutine assign_log32_large - - pure module subroutine assign_log64_large( self, logical_vector ) + logical(int8), intent(out), allocatable :: logical_vector(:) + type(bitset_large), intent(in) :: set + end subroutine logint8_assign_large + pure module subroutine assign_logint16_large( self, logical_vector ) !! Version: experimental !! -!! Used to define assignment from an array of type `logical(int64)` to a +!! Used to define assignment from an array of type `logical(int16)` to a !! `bitset_large`. type(bitset_large), intent(out) :: self - logical(int64), intent(in) :: logical_vector(:) - end subroutine assign_log64_large + logical(int16), intent(in) :: logical_vector(:) + end subroutine assign_logint16_large - pure module subroutine log8_assign_large( logical_vector, set ) + pure module subroutine logint16_assign_large( logical_vector, set ) !! Version: experimental !! -!! Used to define assignment to an array of type `logical(int8)` from a +!! Used to define assignment to an array of type `logical(int16)` from a !! `bitset_large`. - logical(int8), intent(out), allocatable :: logical_vector(:) + logical(int16), intent(out), allocatable :: logical_vector(:) type(bitset_large), intent(in) :: set - end subroutine log8_assign_large - - pure module subroutine log16_assign_large( logical_vector, set ) + end subroutine logint16_assign_large + pure module subroutine assign_logint32_large( self, logical_vector ) !! Version: experimental !! -!! Used to define assignment to an array of type `logical(int16) from a +!! Used to define assignment from an array of type `logical(int32)` to a !! `bitset_large`. - logical(int16), intent(out), allocatable :: logical_vector(:) - type(bitset_large), intent(in) :: set - end subroutine log16_assign_large + type(bitset_large), intent(out) :: self + logical(int32), intent(in) :: logical_vector(:) + end subroutine assign_logint32_large - pure module subroutine log32_assign_large( logical_vector, set ) + pure module subroutine logint32_assign_large( logical_vector, set ) !! Version: experimental !! !! Used to define assignment to an array of type `logical(int32)` from a -!! `bitset_lsrge`. +!! `bitset_large`. logical(int32), intent(out), allocatable :: logical_vector(:) - type(bitset_large), intent(in) :: set - end subroutine log32_assign_large + type(bitset_large), intent(in) :: set + end subroutine logint32_assign_large + pure module subroutine assign_logint64_large( self, logical_vector ) +!! Version: experimental +!! +!! Used to define assignment from an array of type `logical(int64)` to a +!! `bitset_large`. + type(bitset_large), intent(out) :: self + logical(int64), intent(in) :: logical_vector(:) + end subroutine assign_logint64_large - pure module subroutine log64_assign_large( logical_vector, set ) + pure module subroutine logint64_assign_large( logical_vector, set ) !! Version: experimental !! !! Used to define assignment to an array of type `logical(int64)` from a !! `bitset_large`. logical(int64), intent(out), allocatable :: logical_vector(:) - type(bitset_large), intent(in) :: set - end subroutine log64_assign_large + type(bitset_large), intent(in) :: set + end subroutine logint64_assign_large end interface assignment(=) @@ -1512,77 +1509,74 @@ pure module subroutine assign_64( set1, set2 ) type(bitset_64), intent(in) :: set2 end subroutine assign_64 - module subroutine assign_log8_64( self, logical_vector ) + module subroutine assign_logint8_64( self, logical_vector ) !! Version: experimental !! !! Used to define assignment from an array of type `logical(int8)` to a !! `bitset_64`. type(bitset_64), intent(out) :: self logical(int8), intent(in) :: logical_vector(:) - end subroutine assign_log8_64 + end subroutine assign_logint8_64 - module subroutine assign_log16_64( self, logical_vector ) + pure module subroutine logint8_assign_64( logical_vector, set ) !! Version: experimental !! -!! Used to define assignment from an array of type `logical(int16)` to a +!! Used to define assignment to an array of type `logical(int8)` from a !! `bitset_64`. - type(bitset_64), intent(out) :: self - logical(int16), intent(in) :: logical_vector(:) - end subroutine assign_log16_64 - - module subroutine assign_log32_64( self, logical_vector ) + logical(int8), intent(out), allocatable :: logical_vector(:) + type(bitset_64), intent(in) :: set + end subroutine logint8_assign_64 + module subroutine assign_logint16_64( self, logical_vector ) !! Version: experimental !! -!! Used to define assignment from an array of type `logical(int32)` to a +!! Used to define assignment from an array of type `logical(int8)` to a !! `bitset_64`. type(bitset_64), intent(out) :: self - logical(int32), intent(in) :: logical_vector(:) - end subroutine assign_log32_64 + logical(int16), intent(in) :: logical_vector(:) + end subroutine assign_logint16_64 - module subroutine assign_log64_64( self, logical_vector ) + pure module subroutine logint16_assign_64( logical_vector, set ) !! Version: experimental !! -!! Used to define assignment from an array of type `logical(int64)` to a +!! Used to define assignment to an array of type `logical(int8)` from a +!! `bitset_64`. + logical(int16), intent(out), allocatable :: logical_vector(:) + type(bitset_64), intent(in) :: set + end subroutine logint16_assign_64 + module subroutine assign_logint32_64( self, logical_vector ) +!! Version: experimental +!! +!! Used to define assignment from an array of type `logical(int8)` to a !! `bitset_64`. type(bitset_64), intent(out) :: self - logical(int64), intent(in) :: logical_vector(:) - end subroutine assign_log64_64 + logical(int32), intent(in) :: logical_vector(:) + end subroutine assign_logint32_64 - pure module subroutine log8_assign_64( logical_vector, set ) + pure module subroutine logint32_assign_64( logical_vector, set ) !! Version: experimental !! !! Used to define assignment to an array of type `logical(int8)` from a !! `bitset_64`. - logical(int8), intent(out), allocatable :: logical_vector(:) + logical(int32), intent(out), allocatable :: logical_vector(:) type(bitset_64), intent(in) :: set - end subroutine log8_assign_64 - - pure module subroutine log16_assign_64( logical_vector, set ) -!! Version: experimental -!! -!! Used to define assignment to an array of type `logical(int16)` from a -!! `bitset_64` - logical(int16), intent(out), allocatable :: logical_vector(:) - type(bitset_64), intent(in) :: set - end subroutine log16_assign_64 - - pure module subroutine log32_assign_64( logical_vector, set ) + end subroutine logint32_assign_64 + module subroutine assign_logint64_64( self, logical_vector ) !! Version: experimental !! -!! Used to define assignment to an array of type `logical(int32)` from a +!! Used to define assignment from an array of type `logical(int8)` to a !! `bitset_64`. - logical(int32), intent(out), allocatable :: logical_vector(:) - type(bitset_64), intent(in) :: set - end subroutine log32_assign_64 + type(bitset_64), intent(out) :: self + logical(int64), intent(in) :: logical_vector(:) + end subroutine assign_logint64_64 - pure module subroutine log64_assign_64( logical_vector, set ) + pure module subroutine logint64_assign_64( logical_vector, set ) !! Version: experimental !! -!! Used to define assignment to an array of type `logical(int64)` from a +!! Used to define assignment to an array of type `logical(int8)` from a !! `bitset_64`. logical(int64), intent(out), allocatable :: logical_vector(:) - type(bitset_64), intent(in) :: set - end subroutine log64_assign_64 + type(bitset_64), intent(in) :: set + end subroutine logint64_assign_64 end interface assignment(=) From f2d67fc60b83b2e3a4e8428e7de58f22a51c8889 Mon Sep 17 00:00:00 2001 From: William Clodius Date: Wed, 7 Oct 2020 18:31:41 -0600 Subject: [PATCH 12/53] Changed preprocessor files to generate logical assignments. Changed stdlib_bitsets.fypp, stdlib_bitset_64.fypp, and stdlib_bitset_large.fypp to generate the assignment procedures of logical arrays to and from bitsets. [ticket: X] --- src/stdlib_bitset_64.fypp | 1203 ++++++++++++++++++++ src/stdlib_bitset_large.fypp | 1432 ++++++++++++++++++++++++ src/stdlib_bitsets.fypp | 2027 ++++++++++++++++++++++++++++++++++ 3 files changed, 4662 insertions(+) create mode 100644 src/stdlib_bitset_64.fypp create mode 100644 src/stdlib_bitset_large.fypp create mode 100644 src/stdlib_bitsets.fypp diff --git a/src/stdlib_bitset_64.fypp b/src/stdlib_bitset_64.fypp new file mode 100644 index 000000000..da586d73a --- /dev/null +++ b/src/stdlib_bitset_64.fypp @@ -0,0 +1,1203 @@ +#:include "common.fypp" +submodule(stdlib_bitsets) stdlib_bitset_64 + implicit none + +contains + + elemental module function all_64( self ) result(all) +! Returns .TRUE. if all bits in SELF are 1, .FALSE. otherwise. + logical :: all + class(bitset_64), intent(in) :: self + + intrinsic :: btest + integer(bits_kind) :: pos + + do pos=0, self % num_bits - 1 + if ( .not. btest(self % block, pos) ) then + all = .false. + return + end if + end do + all = .true. + + end function all_64 + + + elemental module subroutine and_64(set1, set2) +! +! Sets the bits in SET1 to the bitwise AND of the original bits in SET1 +! and SET2. It is required that SET1 have the same number of bits as +! SET2 otherwise the result is undefined. +! + type(bitset_64), intent(inout) :: set1 + type(bitset_64), intent(in) :: set2 + +! The set2 extent includes the entire extent of set1. +! The (zeroed) region past the end of set1 is unaffected by +! the iand. + set1 % block = iand( set1 % block, & + set2 % block ) + + end subroutine and_64 + + + elemental module subroutine and_not_64(set1, set2) +! +! Sets the bits in SET1 to the bitwise and of the original bits in SET1 +! with the bitwise negation of SET2. SET1 and SET2 must have the same +! number of bits otherwise the result is undefined. +! + type(bitset_64), intent(inout) :: set1 + type(bitset_64), intent(in) :: set2 + +! The not with iand means that the zero'ed regions past the end of each set +! do not interact with the in set regions + set1 % block = iand( set1 % block, not( set2 % block ) ) + + end subroutine and_not_64 + + + elemental module function any_64(self) result(any) +! Returns .TRUE. if any bit in SELF is 1, .FALSE. otherwise. + logical :: any + class(bitset_64), intent(in) :: self + + if ( self % block /= 0 ) then + any = .true. + return + else + any = .false. + end if + + end function any_64 + + + pure module subroutine assign_64( set1, set2 ) +! Used to define assignment for bitset_64 + type(bitset_64), intent(out) :: set1 + type(bitset_64), intent(in) :: set2 + + set1 % num_bits = set2 % num_bits + set1 % block = set2 % block + + end subroutine assign_64 + + + #:for k1 in INT_KINDS + module subroutine assign_log${k1}$_64( self, logical_vector ) +! Used to define assignment from an array of type logical for bitset_64 + type(bitset_64), intent(out) :: self + logical(${k1}$), intent(in) :: logical_vector(:) + + integer(bits_kind) :: log_size + integer(bits_kind) :: index + + log_size = size( logical_vector, kind=bits_kind ) + if ( log_size > 64 ) then + error stop module_name // ' % ' // 'ASSIGNMENT' // " has " // & + "SIZE(LOGICAL_VECTOR) > 64 with assignment to a BITSET_64." + end if + self % num_bits = log_size + self % block = 0 + + do index=0, log_size-1 + if ( logical_vector(index+1) ) then + self % block = ibset( self % block, index ) + end if + end do + + end subroutine assign_log${k1}$_64 + + + pure module subroutine log${k1}$_assign_64( logical_vector, set ) +! Used to define assignment to an array of type logical for bitset_64 + logical(${k1}$), intent(out), allocatable :: logical_vector(:) + type(bitset_64), intent(in) :: set + + integer(bits_kind) :: index + + allocate( logical_vector( set % num_bits ) ) + do index=0, set % num_bits-1 + if ( set % value( index ) == 1 ) then + logical_vector(index+1) = .true. + else + logical_vector(index+1) = .false. + end if + end do + + end subroutine log${k1}$_assign_64 + #:endfor + + + elemental module function bit_count_64(self) result(bit_count) +! Returns the number of non-zero bits in SELF. + integer(bits_kind) :: bit_count + class(bitset_64), intent(in) :: self + + integer(bits_kind) :: pos + + bit_count = 0 + + do pos = 0, self % num_bits - 1 + if ( btest( self % block, pos ) ) bit_count = bit_count + 1 + end do + + end function bit_count_64 + + + elemental module subroutine clear_bit_64(self, pos) +! +! Sets to zero the POS position in SELF. If POS is less than zero or +! greater than BITS(SELF)-1 it is ignored. +! + class(bitset_64), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + + if ( pos < 0 .OR. (pos > self % num_bits-1) ) & + return + self % block = ibclr( self % block, pos ) + + end subroutine clear_bit_64 + + + pure module subroutine clear_range_64(self, start_pos, stop_pos) +! +! Sets to zero all bits from the START_POS to STOP_POS positions in SELF. +! If STOP_POS < START_POS then no bits are modified. Positions outside +! the range 0 to BITS(SELF)-1 are ignored. +! + class(bitset_64), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + + integer(bits_kind) :: true_first, true_last + + true_first = max( 0, start_pos ) + true_last = min( self % num_bits-1, stop_pos ) + if ( true_last < true_first ) return + + call mvbits( all_zeros, & + true_first, & + true_last - true_first + 1, & + self % block, & + true_first ) + + end subroutine clear_range_64 + + + elemental module function eqv_64(set1, set2) result(eqv) +! +! Returns .TRUE. if all bits in SET1 and SET2 have the same value, +! .FALSE. otherwise. The sets must have the same number of bits +! otherwise the results are undefined. +! + logical :: eqv + type(bitset_64), intent(in) :: set1, set2 + + eqv = set1 % block == set2 % block + + end function eqv_64 + + + module subroutine extract_64(new, old, start_pos, stop_pos, status) +! Creates a new bitset, NEW, from a range, START_POS to STOP_POS, in bitset +! OLD. If START_POS is greater than STOP_POS the new bitset is empty. +! If START_POS is less than zero or STOP_POS is greater than BITS(OLD)-1 +! then if STATUS is present it has the value INDEX_INVALID_ERROR, +! otherwise processing stops with an informative message. + type(bitset_64), intent(out) :: new + type(bitset_64), intent(in) :: old + integer(bits_kind), intent(in) :: start_pos, stop_pos + integer, intent(out), optional :: status + + integer(bits_kind) :: bits, i, k + character(*), parameter :: procedure = 'EXTRACT' + + if ( start_pos < 0 ) go to 999 + if ( stop_pos >= old % num_bits ) go to 998 + bits = stop_pos - start_pos + 1 + + if ( bits <= 0 ) then + new % num_bits = 0 + new % block = 0 + return + else + new % num_bits = bits + do i=0, bits-1 + k = start_pos + i + if ( btest( old % block, k ) ) & + new % block = ibset(new % block, i) + end do + end if + + if ( present(status) ) status = success + + return + +998 if ( present(status) ) then + status = index_invalid_error + return + else + error stop module_name // ' % ' // procedure // ' had a ' // & + 'STOP_POS greater than BITS(OLD)-1.' + end if + +999 if ( present(status) ) then + status = index_invalid_error + return + else + error stop module_name // ' % ' // procedure // ' had a ' // & + 'START_POS less than 0.' + end if + + end subroutine extract_64 + + + elemental module subroutine flip_bit_64(self, pos) +! +! Flips the value at the POS position in SELF, provided the position is +! valid. If POS is less than 0 or greater than BITS(SELF)-1, no value is +! changed. +! + class(bitset_64), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + + if ( pos < 0 .OR. pos > self % num_bits-1 ) return + + if ( btest( self % block, pos ) ) then + self % block = ibclr( self % block, pos ) + else + self % block = ibset( self % block, pos ) + end if + + end subroutine flip_bit_64 + + + pure module subroutine flip_range_64(self, start_pos, stop_pos) +! +! Flips all valid bits from the START_POS to the STOP_POS positions in +! SELF. If STOP_POS < START_POS no bits are flipped. Positions less than +! 0 or greater than BITS(SELF)-1 are ignored. +! + class(bitset_64), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + + integer(bits_kind) :: end_bit, start_bit + + start_bit = max( 0, start_pos ) + end_bit = min( stop_pos , self % num_bits-1 ) + call mvbits( not(self % block), & + start_bit, & + end_bit - start_bit + 1, & + self % block, & + start_bit ) + + end subroutine flip_range_64 + + + module subroutine from_string_64(self, string, status) +! Initializes the bitset SELF treating STRING as a binary literal +! STATUS may have the values SUCCESS, ALLOC_FAULT, +! ARRAY_SIZE_INVALID_ERROR, or CHAR_STRING_INVALID. + class(bitset_64), intent(out) :: self + character(*), intent(in) :: string + integer, intent(out), optional :: status + + character(*), parameter :: procedure = 'FROM_STRING' + integer(bits_kind) :: bit + integer(int64) :: bits + character(1) :: char + + bits = len(string, kind=int64) + if ( bits > 64 ) go to 998 + self % num_bits = bits + do bit = 1, bits + char = string(bit:bit) + if ( char == '0' ) then + call self % clear( int(bits, kind=bits_kind)-bit ) + else if ( char == '1' ) then + call self % set( int(bits, kind=bits_kind)-bit ) + else + go to 999 + end if + end do + + if ( present(status) ) status = success + + return + +998 if ( present(status) ) then + status = array_size_invalid_error + return + else + error stop module_name // ' % ' // procedure // ' STRING ' // & + 'was too long for a BITSET_64 SELF.' + end if + +999 if ( present(status) ) then + status = char_string_invalid_error + return + else + error stop module_name // ' % ' // procedure // ' STRING ' // & + 'had a character other than "0" or "1",' + end if + + end subroutine from_string_64 + + + elemental module function ge_64(set1, set2) result(ge) +! +! Returns .TRUE. if the bits in SET1 and SET2 are the same or the +! highest order different bit is set to 1 in SET1 and to 0 in set2. +! .FALSE. otherwise. The sets must have the same number of bits +! otherwise the results are undefined. +! + logical :: ge + type(bitset_64), intent(in) :: set1, set2 + + ge = bge( set1 % block, set2 % block ) + + end function ge_64 + + + elemental module function gt_64(set1, set2) result(gt) +! +! Returns .TRUE. if the bits in SET1 and SET2 differ and the +! highest order different bit is set to 1 in SET1 and to 0 in set2. +! .FALSE. otherwise. The sets must have the same number of bits +! otherwise the results are undefined. +! + logical :: gt + type(bitset_64), intent(in) :: set1, set2 + + gt = bgt( set1 % block, set2 % block ) + + end function gt_64 + + + module subroutine init_zero_64(self, bits, status) +! +! Creates the bitset, SELF, of size BITS, with all bits initialized to +! zero. BITS must be non-negative. If an error occurs and STATUS is +! absent then processing stops with an informative stop code. STATUS +! has a default value of SUCCESS. If an error occurs it has the value +! ARRAY_SIZE_INVALID_ERROR if BITS is either negative larger than 64 +! if SELF is of type BITSET_64, or the value ALLOC_FAULT if it failed +! during allocation of memory for SELF. +! + class(bitset_64), intent(out) :: self + integer(bits_kind), intent(in) :: bits + integer, intent(out), optional :: status + + character(*), parameter :: procedure = "INIT" + + if ( bits < 0 .or. bits > 64 ) go to 999 + + self % num_bits = bits + self % block = all_zeros + + if ( present(status) ) status = success + + return + +999 if ( present(status) ) then + status = array_size_invalid_error + return + else + if ( bits < 0 ) then + error stop module_name // ' %' // procedure // ' BITS had ' // & + 'a negative value.' + else + error stop module_name // ' %' // procedure // ' BITS had ' // & + 'a value greater than 64.' + end if + end if + + end subroutine init_zero_64 + + + module subroutine input_64(self, unit, status) +! +! Reads the components of the bitset, SELF, from the unformatted I/O +! unit, UNIT, assuming that the components were written using OUTPUT. +! If an error occurs and STATUS is absent then processing stops with +! an informative stop code. STATUS has a default value of SUCCESS. +! If an error occurs it has the value READ_FAILURE if it failed +! during the reads from UNIT or the value ALLOC_FAULT if it failed +! during allocation of memory for SELF, or the value +! ARRAY_SIZE_INVALID_ERROR if the BITS(SELF) in UNIT is less than 0 +! or greater than 64 for a BITSET_64 input. +! + class(bitset_64), intent(out) :: self + integer, intent(in) :: unit + integer, intent(out), optional :: status + + integer(bits_kind) :: bits + integer :: ierr + character(len=120) :: message + character(*), parameter :: procedure = 'INPUT' + integer :: stat + + read(unit, iostat=ierr, iomsg=message) bits + if (ierr /= 0) go to 999 + if ( bits < 0 .or. bits > 64 ) go to 998 + + call self % init(bits, stat) + if (stat /= success) go to 998 + + if (bits < 1) return + + read(unit, iostat=ierr, iomsg=message) self % block + if (ierr /= 0) go to 999 + + if ( present(status) ) status = success + + return + +998 if ( present(status) ) then + status = array_size_invalid_error + return + else + if ( bits < 0 ) then + error stop module_name // ' %' // procedure // ' BITS in ' // & + 'UNIT had a negative value.' + else + error stop module_name // ' %' // procedure // ' BITS in ' // & + 'UNIT had a value greater than 64.' + end if + end if + +999 if ( present(status) ) then + status = read_failure + return + else + error stop module_name // ' % ' // procedure // ' had a ' // & + 'failure on a READ statement for UNIT.' + end if + + end subroutine input_64 + + + elemental module function le_64(set1, set2) result(le) +! +! Returns .TRUE. if the bits in SET1 and SET2 are the same or the +! highest order different bit is set to 0 in SET1 and to 1 in set2. +! .FALSE. otherwise. The sets must have the same number of bits +! otherwise the results are undefined. +! + logical :: le + type(bitset_64), intent(in) :: set1, set2 + + le = ble( set1 % block, set2 % block ) + + end function le_64 + + + elemental module function lt_64(set1, set2) result(lt) +! +! Returns .TRUE. if the bits in SET1 and SET2 differ and the +! highest order different bit is set to 0 in SET1 and to 1 in set2. +! .FALSE. otherwise. The sets must have the same number of bits +! otherwise the results are undefined. +! + logical :: lt + type(bitset_64), intent(in) :: set1, set2 + + lt = blt( set1 % block, set2 % block ) + + end function lt_64 + + + elemental module function neqv_64(set1, set2) result(neqv) +! +! Returns .TRUE. if all bits in SET1 and SET2 have the same value, +! .FALSE. otherwise. The sets must have the same number of bits +! otherwise the results are undefined. +! + logical :: neqv + type(bitset_64), intent(in) :: set1, set2 + + neqv = set1 % block /= set2 % block + + end function neqv_64 + + + elemental module function none_64(self) result(none) +! +! Returns .TRUE. if none of the bits in SELF have the value 1. +! + logical :: none + class(bitset_64), intent(in) :: self + + none = .true. + if (self % block /= 0) then + none = .false. + return + end if + + end function none_64 + + + elemental module subroutine not_64(self) +! +! Sets the bits in SELF to their logical complement +! + class(bitset_64), intent(inout) :: self + + integer(bits_kind) :: bit + + if ( self % num_bits == 0 ) return + + do bit=0, self % num_bits - 1 + if ( btest( self % block, bit ) ) then + self % block = ibclr( self % block, bit ) + else + self % block = ibset( self % block, bit ) + end if + end do + + end subroutine not_64 + + + elemental module subroutine or_64(set1, set2) +! +! Sets the bits in SET1 to the bitwise OR of the original bits in SET1 +! and SET2. If SET1 has fewer bits than SET2 then the additional bits +! in SET2 are ignored. If SET1 has more bits than SET2, then the +! absent SET2 bits are treated as if present with zero value. +! + type(bitset_64), intent(inout) :: set1 + type(bitset_64), intent(in) :: set2 + + if ( set1 % num_bits >= set2 % num_bits ) then + set1 % block = ior( set1 % block, & + set2 % block ) + else +! The set1 extent ends before set2 => set2 bits must not affect bits in +! set1 beyond its extent => set those bits to zero while keeping proper +! values of other bits in set2 + set1 % block = & + ior( set1 % block, & + ibits( set2 % block, & + 0, & + set1 % num_bits ) ) + end if + + end subroutine or_64 + + + module subroutine output_64(self, unit, status) +! +! Writes the components of the bitset, SELF, to the unformatted I/O +! unit, UNIT, in a unformatted sequence compatible with INPUT. If +! STATUS is absent an error results in an error stop with an +! informative stop code. If STATUS is present it has the default +! value of SUCCESS, or the value WRITE_FAILURE if the write failed. +! + class(bitset_64), intent(in) :: self + integer, intent(in) :: unit + integer, intent(out), optional :: status + + integer :: ierr + character(len=120) :: message + character(*), parameter :: procedure = "OUTPUT" + + write(unit, iostat=ierr, iomsg=message) self % num_bits + if (ierr /= 0) go to 999 + + if (self % num_bits < 1) return + write(unit, iostat=ierr, iomsg=message) self % block + if (ierr /= 0) go to 999 + + return + +999 if ( present(status) ) then + status = write_failure + return + else + error stop module_name // ' % ' // procedure // ' had a ' // & + 'failure in the write to UNIT.' + end if + + end subroutine output_64 + + + module subroutine read_bitset_string_64(self, string, status) +! +! Uses the bitset literal in the default character STRING, to define +! the bitset, SELF. The literal may be preceded by an an arbitrary +! sequence of blank characters. If STATUS is absent an error results +! in an error stop with an informative stop code. If STATUS +! is present it has the default value of SUCCESS, the value +! INTEGER_OVERFLOW_ERROR if the bitset literal has a BITS(SELF) value +! too large to be represented, the value ALLOC_FAULT if allocation of +! memory for SELF failed, or CHAR_STRING_INVALID_ERROR if the bitset +! literal has an invalid character, or ARRAY_SIZE_INVALID_ERROR if +! BITS(SELF) in STRING is greater than 64 for a BITSET_64, or +! CHAR_STRING_TOO_SMALL_ERROR if the string ends before all the bits +! are read. +! + class(bitset_64), intent(out) :: self + character(len=*), intent(in) :: string + integer, intent(out), optional :: status + + integer(bits_kind) :: bit, bits + integer(bits_kind) :: digits, pos + character(*), parameter :: procedure = "READ_BITSET" + integer :: stat + + pos = 1 + find_start: do pos=1, len(string) + if ( string(pos:pos) /= ' ' ) exit + end do find_start + + if ( pos > len(string) - 8 ) go to 999 + + if ( string(pos:pos) /= 's' .AND. string(pos:pos) /= 'S' ) go to 999 + + pos = pos + 1 + bits = 0 + digits = 0 + + do + select case( iachar( string(pos:pos) ) ) + case(ia0:ia9) + digits = digits + 1 + if ( digits == 10 .AND. bits > 2_bits_kind**30/5 ) go to 996 +!! May not be quite right + if ( digits > 10 ) go to 996 + bits = bits*10 + iachar( string(pos:pos) ) - ia0 + if ( bits < 0 ) go to 996 + case(iachar('b'), iachar('B')) + go to 100 + case default + go to 999 + end select + + pos = pos + 1 + + end do + +100 if ( bits > 64 ) go to 995 + if ( bits + pos > len(string) ) go to 994 + call self % init( bits, stat ) + if (stat /= success) go to 998 + + pos = pos + 1 + bit = bits - 1 + do + if ( string(pos:pos) == '0' ) then + call self % clear( bit ) ! this may not be needed + else if ( string(pos:pos) == '1' ) then + call self % set( bit ) + else + go to 999 + end if + pos = pos + 1 + bit = bit - 1 + if ( bit < 0 ) exit + end do + + if ( present(status) ) status = success + + return + +994 if ( present(status) ) then + status = char_string_too_small_error + return + else + error stop module_name // ' % ' // procedure // ' STRING ' // & + 'was too small for the BITS specified by the STRING.' + end if + +995 if ( present(status) ) then + status = array_size_invalid_error + return + else + error stop module_name // ' %' // procedure // ' BITS in ' // & + 'STRING had a value greater than 64.' + end if + + +996 if ( present(status) ) then + status = integer_overflow_error + return + else + error stop module_name // ' % ' // procedure // ' failed on ' // & + 'integer overflow in reading size of bitset literal from ' // & + 'UNIT.' + end if + +998 if ( present(status) ) then + status = alloc_fault + return + else + error stop module_name // ' % ' // procedure // ' failed in ' // & + 'allocating memory for the bitset.' + end if + +999 if ( present(status) ) then + status = char_string_invalid_error + return + else + error stop module_name // ' % ' // procedure // ' failed due ' // & + 'to an invalid character in STRING.' + end if + + end subroutine read_bitset_string_64 + + + module subroutine read_bitset_unit_64(self, unit, advance, status) +! +! + class(bitset_64), intent(out) :: self + integer, intent(in) :: unit + character(*), intent(in), optional :: advance + integer, intent(out), optional :: status + + integer(bits_kind) :: bit, bits, digits + integer :: ierr + character(len=128) :: message + character(*), parameter :: procedure = "READ_BITSET" + character(len=1) :: char + + do + read( unit, & + advance='NO', & + FMT='(A1)', & + err=997, & + end=998, & + iostat=ierr, & + iomsg=message ) char + select case( char ) + case( ' ' ) + cycle + case( 's', 'S' ) + exit + case default + go to 999 + end select + end do + + bits = 0 + digits = 0 + do + read( unit, & + advance='NO', & + FMT='(A1)', & + err=998, & + end=999, & + iostat=ierr, & + iomsg=message ) char + if ( char == 'b' .or. char == 'B' ) exit + select case( char ) + case( '0', '1', '2', '3', '4', '5', '6', '7', '8', '9' ) + digits = digits + 1 + if ( digits == 10 .AND. bits > 2_bits_kind**30/5 ) go to 996 +!! May not be quite right + if ( digits > 10 ) go to 996 + bits = 10*bits + iachar(char) - iachar('0') + if ( bits < 0 ) go to 996 + case default + go to 999 + end select + end do + + if ( bits < 0 .OR. digits == 0 .OR. digits > 10 ) go to 999 + + if ( bits > 64 ) go to 995 + call self % init( bits ) + do bit = 1, bits-1 + read( unit, & + advance='NO', & + FMT='(A1)', & + err=997, & + end=998, & + iostat=ierr, & + iomsg=message ) char + if ( char == '0' ) then + call self % clear( bits-bit ) + else if ( char == '1' ) then + call self % set( bits-bit ) + else + go to 999 + end if + end do + + if ( present(advance) ) then + read( unit, & + advance=advance, & + FMT='(A1)', & + err=997, & + end=998, & + iostat=ierr, & + iomsg=message ) char + + else + read( unit, & + advance='YES', & + FMT='(A1)', & + err=997, & + end=998, & + iostat=ierr, & + iomsg=message ) char + + end if + if ( char == '0' ) then + call self % clear( bits-bit ) + else if ( char == '1' ) then + call self % set( bits-bit ) + else + go to 999 + end if + + if ( present(status) ) status = success + + return + +995 if ( present(status) ) then + status = array_size_invalid_error + return + else + error stop module_name // ' %' // procedure // ' BITS in ' // & + 'STRING had a value greater than 64.' + end if + +996 if ( present(status) ) then + status = integer_overflow_error + return + else + error stop module_name // ' % ' // procedure // ' failed on ' // & + 'integer overflow in reading size of bitset literal from ' // & + 'UNIT.' + end if + +997 if ( present(status) ) then + status = read_failure + return + else + error stop module_name // ' % ' // procedure // ' failed on ' // & + 'read of UNIT.' + end if + +998 if ( present(status) ) then + status = eof_failure + return + else + error stop module_name // ' % ' // procedure // ' reached ' // & + 'End of File of UNIT before finding a bitset literal.' + end if + +999 if ( present(status) ) then + status = char_string_invalid_error + return + else + error stop module_name // ' % ' // procedure // ' found an ' // & + 'invalid bitset literal in UNIT.' + end if + + end subroutine read_bitset_unit_64 + + + elemental module subroutine set_bit_64(self, pos) +! +! Sets the value at the POS position in SELF, provided the position is +! valid. If the position is less than 0 or greater than BITS(SELF)-1 +! then SELF is unchanged. +! + class(bitset_64), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + + if ( pos < 0 .OR. pos > self % num_bits-1 ) return + self % block = ibset( self % block, pos ) + + end subroutine set_bit_64 + + + pure module subroutine set_range_64(self, start_pos, stop_pos) +! +! Sets all valid bits to 1 from the START_POS to the STOP_POS positions +! in SELF. If STOP_POA < START_POS no bits are changed. Positions outside +! the range 0 to BITS(SELF)-1 are ignored. +! + class(bitset_64), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + + integer(bits_kind) :: end_bit, start_bit + + start_bit = max( 0, start_pos ) + end_bit = min( stop_pos, self % num_bits-1 ) + if ( end_bit < start_bit ) return + +! FIRST and LAST are in the same block + call mvbits( all_ones, & + start_bit, & + end_bit - start_bit + 1, & + self % block, & + start_bit ) + + end subroutine set_range_64 + + + elemental module function test_64(self, pos) result(test) +! +! Returns .TRUE. if the POS position is set, .FALSE. otherwise. If POS +! is negative or greater than BITS(SELF) - 1 the result is .FALSE.. +! + logical :: test + class(bitset_64), intent(in) :: self + integer(bits_kind), intent(in) :: pos + + if ( pos < 0 .or. pos >= self % num_bits ) then + test = .false. + else + test = btest( self % block, pos ) + end if + + end function test_64 + + + module subroutine to_string_64(self, string, status) +! +! Represents the value of SELF as a binary literal in STRING +! Status may have the values SUCCESS or ALLOC_FAULT +! + class(bitset_64), intent(in) :: self + character(len=:), allocatable, intent(out) :: string + integer, intent(out), optional :: status + + character(*), parameter :: procedure = 'TO_STRING' + integer :: bit, bit_count, pos, stat + + bit_count = self % num_bits + allocate( character(len=bit_count)::string, stat=stat ) + if ( stat > 0 ) go to 999 + + do bit=0, bit_count-1 + pos = bit_count - bit + if ( btest( self % block, bit ) ) then + string( pos:pos ) = '1' + else + string( pos:pos ) = '0' + end if + end do + + if ( present(status) ) status = success + + return + +999 if ( present(status) ) then + status = alloc_fault + return + + else + error stop module_name // ' % ' // procedure // ' allocation ' // & + 'of STRING failed.' + + end if + + end subroutine to_string_64 + + + elemental module function value_64(self, pos) result(value) +! +! Returns 1 if the POS position is set, 0 otherwise. If POS is negative +! or greater than BITS(SELF) - 1 the result is 0. +! + integer :: value + class(bitset_64), intent(in) :: self + integer(bits_kind), intent(in) :: pos + + if ( pos < 0 .or. pos >= self % num_bits ) then + value = 0 + + else + if ( btest( self % block, pos ) ) then + value = 1 + + else + value = 0 + + end if + + end if + + end function value_64 + + + module subroutine write_bitset_string_64(self, string, status) +! +! Writes a bitset literal to the allocatable default character STRING, +! representing the individual bit values in the bitset_t, SELF. +! If STATUS is absent an error results in an error stop with an +! informative stop code. If STATUS is present it has the default +! value of SUCCESS, or the value ALLOC_FAULT if allocation of +! the output string failed. +! + class(bitset_64), intent(in) :: self + character(len=:), allocatable, intent(out) :: string + integer, intent(out), optional :: status + + integer(bits_kind) :: bit, & + bit_count, & + count_digits, & + pos + integer :: stat + + character(*), parameter :: procedure = 'WRITE_BITSET' + + bit_count = bits(self) + + call digit_count( self % num_bits, count_digits ) + + allocate( character(len=count_digits+bit_count+2)::string, stat=stat ) + if ( stat > 0 ) go to 999 + + write( string, "('S', i0)" ) self % num_bits + + string( count_digits + 2:count_digits + 2 ) = "B" + do bit=0, bit_count-1 + pos = count_digits + 2 + bit_count - bit + if ( btest( self % block, bit ) ) then + string( pos:pos ) = '1' + else + string( pos:pos ) = '0' + end if + end do + + if ( present(status) ) status = success + + return + +999 if ( present(status) ) then + status = alloc_fault + return + + else + error stop module_name // ' % ' // procedure // ' had a ' // & + 'memory sllocation failure for a string.' + + end if + + contains + + subroutine digit_count( bits, digits ) + integer(bits_kind), intent(in) :: bits + integer(bits_kind), intent(out) :: digits + + select case ( bits ) + case ( 0:9 ) + digits = 1 + + case ( 10:99 ) + digits = 2 + + case ( 100:999 ) + digits = 3 + + case ( 1000:9999 ) + digits = 4 + + case ( 10000:99999 ) + digits = 5 + + case ( 100000:999999 ) + digits = 6 + + case ( 1000000:9999999 ) + digits = 7 + + case ( 10000000:99999999 ) + digits = 8 + + case ( 100000000:999999999 ) + digits = 9 + + case ( 1000000000:min(2147483647, huge( self % num_bits ) ) ) + digits = 10 + + case default + error stop module_name // ' % ' // procedure // & + ' internal consistency fault was found.' + + end select + + end subroutine digit_count + + end subroutine write_bitset_string_64 + + + module subroutine write_bitset_unit_64(self, unit, advance, status) +! +! Writes a bitset literal to the I/O unit, UNIT, representing the +! individual bit values in the bitset_t, SELF. By default or if +! ADVANCE is present with the value 'YES', advancing output is used. +! If ADVANCE is present with the value 'NO', then the current record +! is not advanced by the write. If STATUS is absent an error results +! in an error stop with an informative stop code. If STATUS is +! present it has the default value of SUCCESS, the value +! ALLOC_FAULT if allocation of the output string failed, or +! WRITE_FAILURE if the WRITE statement outputting the literal failed. +! + class(bitset_64), intent(in) :: self + integer, intent(in) :: unit + character(len=*), intent(in), optional :: advance + integer, intent(out), optional :: status + + integer :: ierr + character(:), allocatable :: string + character(len=120) :: message + character(*), parameter :: procedure = "WRITE_BITSET" + + call self % write_bitset(string, status) + + if ( present(status) ) then + if (status /= success ) return + end if + + + if ( present( advance ) ) then + write( unit, & + FMT='(A)', & + advance=advance, & + iostat=ierr, & + iomsg=message ) & + string + else + write( unit, & + FMT='(A)', & + advance='YES', & + iostat=ierr, & + iomsg=message ) & + string + end if + if (ierr /= 0) go to 999 + + return + +999 if ( present(status) ) then + status = write_failure + return + else + error stop module_name // ' % ' // procedure // ' had a ' // & + 'failure on a WRITE statement.' + end if + + end subroutine write_bitset_unit_64 + + + elemental module subroutine xor_64(set1, set2) +! +! Sets the bits in SET1 to the bitwise XOR of the original bits in SET1 +! and SET2. SET1 and SET2 must have the same number of bits otherwise +! the result is undefined. +! + type(bitset_64), intent(inout) :: set1 + type(bitset_64), intent(in) :: set2 + + set1 % block = ieor( set1 % block, & + set2 % block ) + + end subroutine xor_64 + + +end submodule stdlib_bitset_64 diff --git a/src/stdlib_bitset_large.fypp b/src/stdlib_bitset_large.fypp new file mode 100644 index 000000000..7cfb74892 --- /dev/null +++ b/src/stdlib_bitset_large.fypp @@ -0,0 +1,1432 @@ +#:include "common.fypp" +submodule(stdlib_bitsets) stdlib_bitset_large + implicit none + +contains + + + elemental module function all_large( self ) result(all) +! Returns .TRUE. if all bits in SELF are 1, .FALSE. otherwise. + logical :: all + class(bitset_large), intent(in) :: self + + integer(bits_kind) :: block, full_blocks, pos + + all = .true. + full_blocks = bits(self)/block_size + do block = 1, full_blocks + if ( self % blocks(block) /= -1_block_kind ) then + all = .false. + return + end if + end do + + if ( full_blocks == size(self % blocks) ) return + + do pos=0, modulo( bits(self), block_size )-1 + if ( .not. btest(self % blocks(full_blocks+1), pos) ) then + all = .false. + return + end if + end do + + end function all_large + + + elemental module subroutine and_large(set1, set2) +! +! Sets the bits in SET1 to the bitwise AND of the original bits in SET1 +! and SET2. It is required that SET1 have the same number of bits as +! SET2 otherwise the result is undefined. +! + type(bitset_large), intent(inout) :: set1 + type(bitset_large), intent(in) :: set2 + + integer(bits_kind) :: block_ + + do block_ = 1, size(set1 % blocks) + set1 % blocks(block_) = iand( set1 % blocks(block_), & + set2 % blocks(block_) ) + end do + + end subroutine and_large + + + elemental module subroutine and_not_large(set1, set2) +! +! Sets the bits in SET1 to the bitwise and of the original bits in SET1 +! with the bitwise negation of SET2. SET1 and SET2 must have the same +! number of bits otherwise the result is undefined. +! + type(bitset_large), intent(inout) :: set1 + type(bitset_large), intent(in) :: set2 + + integer(bits_kind) :: block_ + + do block_ = 1, size( set1 % blocks ) + set1 % blocks(block_) = & + iand( set1 % blocks(block_), not( set2 % blocks(block_) ) ) + end do + + end subroutine and_not_large + + + elemental module function any_large(self) result(any) +! Returns .TRUE. if any bit in SELF is 1, .FALSE. otherwise. + logical :: any + class(bitset_large), intent(in) :: self + + integer(bits_kind) :: block_ + + do block_ = 1, size(self % blocks) + if ( self % blocks(block_) /= 0 ) then + any = .true. + return + end if + end do + any = .false. + + end function any_large + + + pure module subroutine assign_large( set1, set2 ) +! Used to define assignment for bitset_large + type(bitset_large), intent(out) :: set1 + type(bitset_large), intent(in) :: set2 + + set1 % num_bits = set2 % num_bits + allocate( set1 % blocks( size( set2 % blocks, kind=bits_kind ) ) ) + set1 % blocks(:) = set2 % blocks(:) + + end subroutine assign_large + + #:for k1 in INT_KINDS + pure module subroutine assign_log${k1}$_large( self, logical_vector ) +! Used to define assignment from an array of type logical for bitset_large + type(bitset_large), intent(out) :: self + logical(${k1}$), intent(in) :: logical_vector(:) + + integer(bits_kind) :: blocks + integer(bits_kind) :: log_size + integer(bits_kind) :: index + + log_size = size( logical_vector, 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 + + do index=0, log_size-1 + if ( logical_vector(index+1) ) then + call self % set( index ) + end if + end do + + end subroutine assign_log${k1}$_large + + + pure module subroutine log${k1}$_assign_large( logical_vector, set ) +! Used to define assignment to an array of type logical for bitset_large + logical(${k1}$), intent(out), allocatable :: logical_vector(:) + type(bitset_large), intent(in) :: set + + integer(bits_kind) :: index + + allocate( logical_vector( set % num_bits ) ) + do index=0, set % num_bits-1 + if ( set % value( index ) == 1 ) then + logical_vector(index+1) = .true. + else + logical_vector(index+1) = .false. + end if + end do + + end subroutine log${k1}$_assign_large + #:endfor + + + elemental module function bit_count_large(self) result(bit_count) +! Returns the number of non-zero bits in SELF. + integer(bits_kind) :: bit_count + class(bitset_large), intent(in) :: self + + integer(bits_kind) :: block_, pos + + bit_count = 0 + do block_ = 1, size(self % blocks) - 1 + do pos = 0, block_size-1 + if ( btest( self % blocks(block_), pos ) ) & + bit_count = bit_count + 1 + end do + + end do + + do pos = 0, self % num_bits - (block_-1)*block_size - 1 + if ( btest( self % blocks(block_), pos ) ) bit_count = bit_count + 1 + end do + + end function bit_count_large + + + elemental module subroutine clear_bit_large(self, pos) +! +! Sets to zero the POS position in SELF. If POS is less than zero or +! greater than BITS(SELF)-1 it is ignored. +! + class(bitset_large), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + + integer :: clear_block, block_bit + + if ( pos < 0 .OR. (pos > self % num_bits-1) ) return + clear_block = pos / block_size + 1 + block_bit = pos - (clear_block - 1) * block_size + self % blocks(clear_block) = & + ibclr( self % blocks(clear_block), block_bit ) + + end subroutine clear_bit_large + + + pure module subroutine clear_range_large(self, start_pos, stop_pos) +! +! Sets to zero all bits from the START_POS to STOP_POS positions in SELF. +! If STOP_POS < START_POS then no bits are modified. Positions outside +! the range 0 to BITS(SELF)-1 are ignored. +! + class(bitset_large), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + + integer(bits_kind) :: bit, block_, first_block, last_block, & + true_first, true_last + + true_first = max( 0, start_pos ) + true_last = min( self % num_bits-1, stop_pos ) + if ( true_last < true_first ) return + + first_block = true_first / block_size + 1 + last_block = true_last / block_size + 1 + if ( first_block == last_block ) then +! TRUE_FIRST and TRUE_LAST are in the same block + call mvbits( all_zeros, & + true_first - (first_block-1)*block_size, & + true_last - true_first + 1, & + self % blocks(first_block), & + true_first - (first_block-1)*block_size ) + return + end if + +! Do "partial" black containing FIRST + bit = true_first - (first_block-1)*block_size + call mvbits( all_zeros, & + bit, & + block_size - bit, & + self % blocks(first_block), & + bit ) + +! Do "partial" black containing LAST + bit = true_last - (last_block-1)*block_size + call mvbits( all_zeros, & + 0, & + bit+1, & + self % blocks(last_block), & + 0 ) + +! Do intermediate blocks + do block_ = first_block+1, last_block-1 + self % blocks(block_) = all_zeros + end do + + end subroutine clear_range_large + + + elemental module function eqv_large(set1, set2) result(eqv) +! +! Returns .TRUE. if all bits in SET1 and SET2 have the same value, +! .FALSE. otherwise. The sets must have the same number of bits +! otherwise the results are undefined. +! + logical :: eqv + type(bitset_large), intent(in) :: set1, set2 + + integer(bits_kind) :: block, common_blocks + + eqv = .false. + common_blocks = size(set1 % blocks) + do block = 1, common_blocks + if ( set1 % blocks(block) /= set2 % blocks(block) ) return + end do + eqv = .true. + + end function eqv_large + + + module subroutine extract_large(new, old, start_pos, stop_pos, status) +! Creates a new bitset, NEW, from a range, START_POS to STOP_POS, in bitset +! OLD. If START_POS is greater than STOP_POS the new bitset is empty. +! If START_POS is less than zero or STOP_POS is greater than BITS(OLD)-1 +! then if STATUS is present it has the value INDEX_INVALID_ERROR, +! otherwise processing stops with an informative message. + type(bitset_large), intent(out) :: new + type(bitset_large), intent(in) :: old + integer(bits_kind), intent(in) :: start_pos, stop_pos + integer, intent(out), optional :: status + + integer(bits_kind) :: bits, blocks, ex_block, i, j, k, old_block + character(*), parameter :: procedure = 'EXTRACT' + + if ( start_pos < 0 ) go to 999 + if ( stop_pos >= old % num_bits ) go to 998 + bits = stop_pos - start_pos + 1 + + if ( bits <= 0 ) then + new % num_bits = 0 + allocate( new % blocks(0) ) + return + end if + + blocks = ((bits-1) / block_size) + 1 + + new % num_bits = bits + allocate( new % blocks(blocks) ) + new % blocks(:) = 0 + + do i=0, bits-1 + ex_block = i / block_size + 1 + j = i - (ex_block-1) * block_size + old_block = (start_pos + i) / block_size + 1 + k = (start_pos + i) - (old_block-1) * block_size + if ( btest( old % blocks(old_block), k ) ) then + new % blocks(ex_block) = ibset(new % blocks(ex_block), j) + end if + end do + + if ( present(status) ) status = success + + return + +998 if ( present(status) ) then + status = index_invalid_error + return + else + error stop module_name // ' % ' // procedure // ' had a ' // & + 'STOP_POS greater than BITS(OLD)-1.' + end if + +999 if ( present(status) ) then + status = index_invalid_error + return + else + error stop module_name // ' % ' // procedure // ' had a ' // & + 'START_POS less than 0.' + end if + + end subroutine extract_large + + + elemental module subroutine flip_bit_large(self, pos) +! +! Flips the value at the POS position in SELF, provided the position is +! valid. If POS is less than 0 or greater than BITS(SELF)-1, no value is +! changed. +! + class(bitset_large), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + + integer :: flip_block, block_bit + + if ( pos < 0 .OR. pos > self % num_bits-1 ) return + + flip_block = pos / block_size + 1 + block_bit = pos - (flip_block - 1) * block_size + if ( btest( self % blocks(flip_block), block_bit ) ) then + self % blocks(flip_block) = ibclr( self % blocks(flip_block), & + block_bit ) + else + self % blocks(flip_block) = ibset( self % blocks(flip_block), & + block_bit ) + end if + + end subroutine flip_bit_large + + + pure module subroutine flip_range_large(self, start_pos, stop_pos) +! +! Flips all valid bits from the START_POS to the STOP_POS positions in +! SELF. If STOP_POS < START_POS no bits are flipped. Positions less than +! 0 or greater than BITS(SELF)-1 are ignored. +! + class(bitset_large), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + + integer(bits_kind) :: bit, block_, end_bit, first_block, last_block, & + start_bit + + start_bit = max( 0, start_pos ) + end_bit = min( stop_pos , self % num_bits-1 ) + if ( end_bit < start_bit ) return + + first_block = start_bit / block_size + 1 + last_block = end_bit / block_size + 1 + if (first_block == last_block) then +! FIRST and LAST are in the same block + call mvbits( not(self % blocks(first_block)), & + start_bit - (first_block-1)*block_size, & + end_bit - start_bit + 1, & + self % blocks(first_block), & + start_bit - (first_block-1)*block_size ) + return + end if + +! Do "partial" black containing FIRST + bit = start_bit - (first_block-1)*block_size + call mvbits( not(self % blocks(first_block) ), & + bit, & + block_size - bit, & + self % blocks(first_block), & + bit ) + +! Do "partial" black containing LAST + bit = end_bit - (last_block-1)*block_size + call mvbits( not( self % blocks(last_block) ), & + 0, & + bit+1, & + self % blocks(last_block), & + 0 ) + +! Do remaining blocks + do block_ = first_block+1, last_block-1 + self % blocks(block_) = not( self % blocks(block_) ) + end do + + end subroutine flip_range_large + + module subroutine from_string_large(self, string, status) +! Initializes the bitset SELF treating STRING as a binary literal +! STATUS may have the values SUCCESS, ALLOC_FAULT, +! ARRAY_SIZE_INVALID_ERROR, or CHAR_STRING_INVALID. + class(bitset_large), intent(out) :: self + character(*), intent(in) :: string + integer, intent(out), optional :: status + + character(*), parameter :: procedure = 'FROM_STRING' + integer(bits_kind) :: bit + integer(int64) :: bits + character(1) :: char + + bits = len(string, kind=int64) + if ( bits > huge(0_bits_kind) ) go to 998 + + call init_zero_large( self, int(bits, kind=bits_kind), status ) + + if ( present(status) ) then + if ( status /= success ) return + end if + + do bit = 1_bits_kind, bits + char = string(bit:bit) + if ( char == '0' ) then + call self % clear( int(bits, kind=bits_kind)-bit ) + else if ( char == '1' ) then + call self % set( int(bits, kind=bits_kind)-bit ) + else + go to 999 + end if + end do + + if ( present(status) ) status = success + + return + +998 if ( present(status) ) then + status = array_size_invalid_error + return + else + error stop module_name // ' % ' // procedure // ' STRING ' // & + 'was too long for a BITSET_64 SELF.' + end if + +999 if ( present(status) ) then + status = char_string_invalid_error + return + else + error stop module_name // ' % ' // procedure // ' STRING ' // & + 'had a character other than "0" or "1",' + end if + + end subroutine from_string_large + + + elemental module function ge_large(set1, set2) result(ge) +! +! Returns .TRUE. if the bits in SET1 and SET2 are the same or the +! highest order different bit is set to 1 in SET1 and to 0 in set2. +! .FALSE. otherwise. The sets must have the same number of bits +! otherwise the results are undefined. +! + logical :: ge + type(bitset_large), intent(in) :: set1, set2 + + integer(bits_kind) :: block_ + + do block_ = size(set1 % blocks), 1, -1 + if ( set1 % blocks(block_) == set2 % blocks(block_) ) then + cycle + else if ( bgt(set1 % blocks(block_), set2 % blocks(block_) ) ) then + ge = .true. + return + else + ge = .false. + return + end if + end do + ge = .true. + + end function ge_large + + + elemental module function gt_large(set1, set2) result(gt) +! +! Returns .TRUE. if the bits in SET1 and SET2 differ and the +! highest order different bit is set to 1 in SET1 and to 0 in set2. +! .FALSE. otherwise. The sets must have the same number of bits +! otherwise the results are undefined. +! + logical :: gt + type(bitset_large), intent(in) :: set1, set2 + + integer(bits_kind) :: block_ + + do block_ = size(set1 % blocks), 1, -1 + if ( set1 % blocks(block_) == set2 % blocks(block_) ) then + cycle + else if ( bgt( set1 % blocks(block_), set2 % blocks(block_) ) ) then + gt = .true. + return + else + gt = .false. + return + end if + end do + gt = .false. + + end function gt_large + + + module subroutine init_zero_large(self, bits, status) +! +! Creates the bitset, SELF, of size BITS, with all bits initialized to +! zero. BITS must be non-negative. If an error occurs and STATUS is +! absent then processing stops with an informative stop code. STATUS +! has a default value of SUCCESS. If an error occurs it has the value +! ARRAY_SIZE_INVALID_ERROR if BITS is either negative larger than 64 +! if SELF is of type BITSET_64, or the value ALLOC_FAULT if it failed +! during allocation of memory for SELF. +! + class(bitset_large), intent(out) :: self + integer(bits_kind), intent(in) :: bits + integer, intent(out), optional :: status + + character(len=120) :: message + character(*), parameter :: procedure = "INIT" + integer :: blocks, ierr + + message = '' + if ( bits < 0 ) go to 999 + + if (bits == 0) then + self % num_bits = 0 + allocate( self % blocks(0), stat=ierr, errmsg=message ) + if (ierr /= 0) go to 998 + return + else + blocks = ((bits-1) / block_size) + 1 + end if + + self % num_bits = bits + allocate( self % blocks(blocks), stat=ierr, errmsg=message ) + if (ierr /= 0) go to 998 + + self % blocks(:) = all_zeros + + if ( present(status) ) status = success + + return + +998 if ( present(status) ) then + status = alloc_fault + return + else + error stop module_name // ' % ' // procedure // ' allocation ' // & + 'failure for SELF.' + end if + +999 if ( present(status) ) then + status = array_size_invalid_error + return + else + error stop module_name // ' %' // procedure // ' BITS had ' // & + 'a negative value.' + end if + + end subroutine init_zero_large + + + module subroutine input_large(self, unit, status) +! +! Reads the components of the bitset, SELF, from the unformatted I/O +! unit, UNIT, assuming that the components were written using OUTPUT. +! If an error occurs and STATUS is absent then processing stops with +! an informative stop code. STATUS has a default value of SUCCESS. +! If an error occurs it has the value READ_FAILURE if it failed +! during the reads from UNIT or the value ALLOC_FAULT if it failed +! during allocation of memory for SELF, or the value +! ARRAY_SIZE_INVALID_ERROR if the BITS(SELF) in UNIT is less than 0 +! or greater than 64 for a BITSET_64 input. +! + class(bitset_large), intent(out) :: self + integer, intent(in) :: unit + integer, intent(out), optional :: status + + integer(bits_kind) :: bits + integer :: ierr + character(len=120) :: message + character(*), parameter :: procedure = 'INPUT' + integer :: stat + + read(unit, iostat=ierr, iomsg=message) bits + if (ierr /= 0) go to 999 + if ( bits < 0 ) go to 997 + + call self % init(bits, stat) + if (stat /= success) go to 998 + + if (bits < 1) return + + read(unit, iostat=ierr, iomsg=message) self % blocks(:) + if (ierr /= 0) go to 999 + + if ( present(status) ) status = success + + return + +997 if ( present(status) ) then + status = array_size_invalid_error + return + else + error stop module_name // ' %' // procedure // ' BITS in ' // & + 'UNIT had a negative value.' + end if + +998 if ( present(status) ) then + status = alloc_fault + return + else + error stop module_name // ' % ' // procedure // ' had an ' // & + 'alloction fault for SELF.' + end if + +999 if ( present(status) ) then + status = read_failure + return + else + error stop module_name // ' % ' // procedure // ' had a ' // & + 'failure on a READ statement for UNIT.' + end if + + end subroutine input_large + + + elemental module function le_large(set1, set2) result(le) +! +! Returns .TRUE. if the bits in SET1 and SET2 are the same or the +! highest order different bit is set to 0 in SET1 and to 1 in set2. +! .FALSE. otherwise. The sets must have the same number of bits +! otherwise the results are undefined. +! + logical :: le + type(bitset_large), intent(in) :: set1, set2 + + integer(bits_kind) :: block_ + + do block_ = size(set1 % blocks), 1, -1 + if ( set1 % blocks(block_) == set2 % blocks(block_) ) then + cycle + else if ( blt( set1 % blocks(block_), set2 % blocks(block_) ) ) then + le = .true. + return + else + le = .false. + return + end if + end do + + le = .true. + + end function le_large + + + elemental module function lt_large(set1, set2) result(lt) +! +! Returns .TRUE. if the bits in SET1 and SET2 differ and the +! highest order different bit is set to 0 in SET1 and to 1 in set2. +! .FALSE. otherwise. The sets must have the same number of bits +! otherwise the results are undefined. +! + logical :: lt + type(bitset_large), intent(in) :: set1, set2 + + integer(bits_kind) :: block_ + + do block_ = size(set1 % blocks), 1, -1 + if ( set1 % blocks(block_) == set2 % blocks(block_) ) then + cycle + else if ( blt( set1 % blocks(block_), set2 % blocks(block_) ) ) then + lt = .true. + return + else + lt = .false. + return + end if + end do + lt = .false. + + end function lt_large + + + elemental module function neqv_large(set1, set2) result(neqv) +! +! Returns .TRUE. if any bits in SET1 and SET2 differ in value, +! .FALSE. otherwise. The sets must have the same number of bits +! otherwise the results are undefined. +! + logical :: neqv + type(bitset_large), intent(in) :: set1, set2 + + integer(bits_kind) :: block + + neqv = .true. + do block = 1, size(set1 % blocks) + if ( set1 % blocks(block) /= set2 % blocks(block) ) return + end do + neqv = .false. + + end function neqv_large + + + elemental module function none_large(self) result(none) +! +! Returns .TRUE. if none of the bits in SELF have the value 1. +! + logical :: none + class(bitset_large), intent(in) :: self + + integer :: block + + none = .true. + do block = 1, size(self % blocks) + if (self % blocks(block) /= 0) then + none = .false. + return + end if + end do + + end function none_large + + + elemental module subroutine not_large(self) +! +! Sets the bits in SELF to their logical complement +! + class(bitset_large), intent(inout) :: self + + integer(bits_kind) :: bit, full_blocks, block, remaining_bits + + if ( self % num_bits == 0 ) return + full_blocks = self % num_bits / block_size + do block = 1, full_blocks + self % blocks(block) = not( self % blocks(block) ) + end do + remaining_bits = self % num_bits - full_blocks * block_size + + do bit=0, remaining_bits - 1 + if ( btest( self % blocks( block ), bit ) ) then + self % blocks( block ) = ibclr( self % blocks(block), bit ) + else + self % blocks( block ) = ibset( self % blocks(block), bit ) + end if + end do + + end subroutine not_large + + + elemental module subroutine or_large(set1, set2) +! +! Sets the bits in SET1 to the bitwise OR of the original bits in SET1 +! and SET2. SET1 and SET2 must have the same number of bits otherwise +! the result is undefined. +! + type(bitset_large), intent(inout) :: set1 + type(bitset_large), intent(in) :: set2 + + integer(bits_kind) :: block_ + + do block_ = 1, size( set1 % blocks ) + set1 % blocks(block_) = ior( set1 % blocks(block_), & + set2 % blocks(block_) ) + end do + + end subroutine or_large + + + module subroutine output_large(self, unit, status) +! +! Writes the components of the bitset, SELF, to the unformatted I/O +! unit, UNIT, in a unformatted sequence compatible with INPUT. If +! STATUS is absent an error results in an error stop with an +! informative stop code. If STATUS is present it has the default +! value of SUCCESS, or the value WRITE_FAILURE if the write failed. +! + class(bitset_large), intent(in) :: self + integer, intent(in) :: unit + integer, intent(out), optional :: status + + integer :: ierr + character(len=120) :: message + character(*), parameter :: procedure = "OUTPUT" + + write(unit, iostat=ierr, iomsg=message) self % num_bits + if (ierr /= 0) go to 999 + + if (self % num_bits < 1) return + write(unit, iostat=ierr, iomsg=message) self % blocks(:) + if (ierr /= 0) go to 999 + + return + +999 if ( present(status) ) then + status = write_failure + return + else + error stop module_name // ' % ' // procedure // ' had a ' // & + 'failure in the write to UNIT.' + end if + + end subroutine output_large + + + module subroutine read_bitset_string_large(self, string, status) +! +! Uses the bitset literal in the default character STRING, to define +! the bitset, SELF. The literal may be preceded by an an arbitrary +! sequence of blank characters. If STATUS is absent an error results +! in an error stop with an informative stop code. If STATUS +! is present it has the default value of SUCCESS, the value +! INTEGER_OVERFLOW_ERROR if the bitset literal has a BITS(SELF) value +! too large to be represented, the value ALLOC_FAULT if allocation of +! memory for SELF failed, or CHAR_STRING_INVALID_ERROR if the bitset +! literal has an invalid character, or ARRAY_SIZE_INVALID_ERROR if +! BITS(SELF) in STRING is greater than 64 for a BITSET_64, or +! CHAR_STRING_TOO_SMALL_ERROR if the string ends before all the bits +! are read. +! + class(bitset_large), intent(out) :: self + character(len=*), intent(in) :: string + integer, intent(out), optional :: status + + integer(bits_kind) :: bit, bits + integer(bits_kind) :: digits, pos + character(*), parameter :: procedure = "READ_BITSET" + integer :: stat + + pos = 1 + find_start: do pos=1, len(string) + if ( string(pos:pos) /= ' ' ) exit + end do find_start + + if ( pos > len(string) - 8 ) go to 999 + + if ( string(pos:pos) /= 's' .AND. string(pos:pos) /= 'S' ) go to 999 + + pos = pos + 1 + bits = 0 + digits = 0 + + do + select case( iachar( string(pos:pos) ) ) + case(ia0:ia9) + digits = digits + 1 + if ( digits == 10 .AND. bits > 2_bits_kind**30/5 ) go to 996 +!! May not be quite right + if ( digits > 10 ) go to 996 + bits = bits*10 + iachar( string(pos:pos) ) - ia0 + if ( bits < 0 ) go to 996 + case(iachar('b'), iachar('B')) + go to 100 + case default + go to 999 + end select + + pos = pos + 1 + end do + +100 if ( bits + pos > len(string) ) go to 994 + call self % init( bits, stat ) + if (stat /= success) go to 998 + + pos = pos + 1 + bit = bits - 1 + do + if ( string(pos:pos) == '0' ) then + call self % clear( bit ) + else if ( string(pos:pos) == '1' ) then + call self % set( bit ) + else + go to 999 + end if + pos = pos + 1 + bit = bit - 1 + if ( bit < 0 ) exit + end do + + if ( present(status) ) status = success + + return + +994 if ( present(status) ) then + status = char_string_too_small_error + return + else + error stop module_name // ' % ' // procedure // ' STRING ' // & + 'was too small for the BITS specified by the STRING.' + end if + +996 if ( present(status) ) then + status = integer_overflow_error + return + else + error stop module_name // ' % ' // procedure // ' failed on ' // & + 'integer overflow in reading size of bitset literal from ' // & + 'UNIT.' + end if + +998 if ( present(status) ) then + status = alloc_fault + return + else + error stop module_name // ' % ' // procedure // ' failed in ' // & + 'allocating memory for the bitset.' + end if + +999 if ( present(status) ) then + status = char_string_invalid_error + return + else + error stop module_name // ' % ' // procedure // ' failed due ' // & + 'to an invalid character in STRING.' + end if + + end subroutine read_bitset_string_large + + + module subroutine read_bitset_unit_large(self, unit, advance, status) +! +! Uses the bitset literal at the current position in the formatted +! file with I/O unit, UNIT, to define the bitset, SELF. The literal +! may be preceded by an an arbitrary sequence of blank characters. +! If ADVANCE is present it must be either 'YES' or 'NO'. If absent +! it has the default value of 'YES' to determine whether advancing +! I/O occurs. If STATUS is absent an error results in an error stop +! with an informative stop code. If STATUS is present it has the +! default value of SUCCESS, the value INTEGER_OVERFLOW_ERROR if the +! bitset literal has a BITS(SELF) value too large to be +! represented, the value READ_FAILURE if a READ statement fails, +! EOF_FAILURE if a READ statement reach an end-of-file before +! completing the read of the bitset literal, or the value +! CHAR_STRING_INVALID_ERROR if the read of the bitset literal found +! an invalid character, or ARRAY_SIZE_INVALID_ERROR if BITS(SELF) +! in STRING is greater than 64 for a BITSET_64. +! + class(bitset_large), intent(out) :: self + integer, intent(in) :: unit + character(*), intent(in), optional :: advance + integer, intent(out), optional :: status + + integer(bits_kind) :: bit, bits, digits + integer :: ierr + character(len=128) :: message + character(*), parameter :: procedure = "READ_BITSET" + integer :: stat + character(len=1) :: char + + do + read( unit, & + advance='NO', & + FMT='(A1)', & + err=997, & + end=998, & + iostat=ierr, & + iomsg=message ) char + select case( char ) + case( ' ' ) + cycle + case( 's', 'S' ) + exit + case default + go to 999 + end select + end do + + bits = 0 + digits = 0 + do + read( unit, & + advance='NO', & + FMT='(A1)', & + err=998, & + end=999, & + iostat=ierr, & + iomsg=message ) char + if ( char == 'b' .or. char == 'B' ) exit + select case( char ) + case( '0', '1', '2', '3', '4', '5', '6', '7', '8', '9' ) + digits = digits + 1 + if ( digits == 10 .AND. bits > 2_bits_kind**30/5 ) go to 996 +!! May not be quite right + if ( digits > 10 ) go to 996 + bits = 10*bits + iachar(char) - iachar('0') + if ( bits < 0 ) go to 996 + case default + go to 999 + end select + end do + + if ( bits < 0 .OR. digits == 0 .OR. digits > 10 ) go to 999 + + call self % init( bits ) + do bit = 1, bits-1 + read( unit, & + advance='NO', & + FMT='(A1)', & + err=997, & + end=998, & + iostat=ierr, & + iomsg=message ) char + if ( char == '0' ) then + call self % clear( bits-bit ) + else if ( char == '1' ) then + call self % set( bits-bit ) + else + go to 999 + end if + end do + + if ( present(advance) ) then + read( unit, & + advance=advance, & + FMT='(A1)', & + err=997, & + end=998, & + iostat=ierr, & + iomsg=message ) char + else + read( unit, & + advance='YES', & + FMT='(A1)', & + err=997, & + end=998, & + iostat=ierr, & + iomsg=message ) char + end if + + if ( char == '0' ) then + call self % clear( bits-bit ) + else if ( char == '1' ) then + call self % set( bits-bit ) + else + go to 999 + end if + + if ( present(status) ) status = success + + return + +996 if ( present(status) ) then + status = integer_overflow_error + return + else + error stop module_name // ' % ' // procedure // ' failed on ' // & + 'integer overflow in reading size of bitset literal from ' // & + 'UNIT.' + end if + + +997 if ( present(status) ) then + status = read_failure + return + else + error stop module_name // ' % ' // procedure // ' failed on ' // & + 'read of UNIT.' + end if + +998 if ( present(status) ) then + status = eof_failure + return + else + error stop module_name // ' % ' // procedure // ' reached ' // & + 'End of File of UNIT before finding a bitset literal.' + end if + +999 if ( present(status) ) then + status = char_string_invalid_error + return + else + error stop module_name // ' % ' // procedure // ' found an ' // & + 'invalid bitset literal in UNIT.' + end if + + end subroutine read_bitset_unit_large + + + elemental module subroutine set_bit_large(self, pos) +! +! Sets the value at the POS position in SELF, provided the position is +! valid. If the position is less than 0 or greater than BITS(SELF)-1 +! then SELF is unchanged. +! + class(bitset_large), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + + integer(bits_kind) :: set_block, block_bit + + if ( pos < 0 .OR. pos > self % num_bits-1 ) return + + set_block = pos / block_size + 1 + block_bit = pos - (set_block - 1) * block_size + self % blocks(set_block) = ibset( self % blocks(set_block), block_bit ) + + end subroutine set_bit_large + + + pure module subroutine set_range_large(self, start_pos, stop_pos) +! +! Sets all valid bits to 1 from the START_POS to the STOP_POS positions +! in SELF. If STOP_POA < START_POS no bits are changed. Positions outside +! the range 0 to BITS(SELF)-1 are ignored. +! + class(bitset_large), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + + integer(bits_kind) :: bit, block_, end_bit, first_block, last_block, & + start_bit + + start_bit = max( 0, start_pos ) + end_bit = min( stop_pos, self % num_bits-1 ) + if ( end_bit < start_bit ) return + + first_block = start_bit / block_size + 1 + last_block = end_bit / block_size + 1 + if ( first_block == last_block ) then +! FIRST and LAST are in the same block + call mvbits( all_ones, & + start_bit - (first_block-1)*block_size, & + end_bit - start_bit + 1, & + self % blocks(first_block), & + start_bit - (first_block-1)*block_size ) + return + end if + +! Do "partial" black containing FIRST + bit = start_bit - (first_block-1)*block_size + call mvbits( all_ones, & + bit, & + block_size - bit, & + self % blocks(first_block), & + bit ) + +! Do "partial" black containing LAST + bit = end_bit - (last_block-1)*block_size + call mvbits( all_ones, & + 0, & + bit+1, & + self % blocks(last_block), & + 0 ) + +! Do remaining blocks + do block_ = first_block+1, last_block-1 + self % blocks(block_) = all_ones + end do + + end subroutine set_range_large + + + elemental module function test_large(self, pos) result(test) +! +! Returns .TRUE. if the POS position is set, .FALSE. otherwise. If POS +! is negative or greater than BITS(SELF) - 1 the result is .FALSE.. +! + logical :: test + class(bitset_large), intent(in) :: self + integer(bits_kind), intent(in) :: pos + + integer(bits_kind) :: bit_block + + if ( pos < 0 .or. pos >= self % num_bits ) then + test = .false. + else + bit_block = pos / block_size + 1 + test = btest( self % blocks(bit_block), & + pos - ( bit_block-1 ) * block_size ) + end if + + end function test_large + + + module subroutine to_string_large(self, string, status) +! +! Represents the value of SELF as a binary literal in STRING +! Status may have the values SUCCESS or ALLOC_FAULT +! + class(bitset_large), intent(in) :: self + character(len=:), allocatable, intent(out) :: string + integer, intent(out), optional :: status + + character(*), parameter :: procedure = 'TO_STRING' + integer(bits_kind) :: bit, bit_count, pos + integer :: stat + + bit_count = self % num_bits + allocate( character(len=bit_count)::string, stat=stat ) + if ( stat > 0 ) go to 999 + do bit=0, bit_count-1 + pos = bit_count - bit + if ( self % test( bit) ) then + string( pos:pos ) = '1' + else + string( pos:pos ) = '0' + end if + end do + + if ( present(status) ) status = success + + return + +999 if ( present(status) ) then + status = alloc_fault + return + else + error stop module_name // ' % ' // procedure // ' allocation ' // & + 'of STRING failed.' + end if + + end subroutine to_string_large + + + elemental module function value_large(self, pos) result(value) +! +! Returns 1 if the POS position is set, 0 otherwise. If POS is negative +! or greater than BITS(SELF) - 1 the result is 0. +! + integer :: value + class(bitset_large), intent(in) :: self + integer(bits_kind), intent(in) :: pos + + integer :: bit_block + + if ( pos < 0 .or. pos >= self % num_bits ) then + value = 0 + else + bit_block = pos / block_size + 1 + if ( btest( self % blocks(bit_block), & + pos - ( bit_block-1 ) * block_size ) ) then + value = 1 + else + value = 0 + end if + end if + + end function value_large + + + module subroutine write_bitset_string_large(self, string, status) +! +! Writes a bitset literal to the allocatable default character STRING, +! representing the individual bit values in the bitset_t, SELF. +! If STATUS is absent an error results in an error stop with an +! informative stop code. If STATUS is present it has the default +! value of SUCCESS, or the value ALLOC_FAULT if allocation of +! the output string failed. +! + class(bitset_large), intent(in) :: self + character(len=:), allocatable, intent(out) :: string + integer, intent(out), optional :: status + + integer(bits_kind) :: bit, & + bit_count, & + count_digits, & + pos + integer :: stat + + character(*), parameter :: procedure = 'WRITE_BITSET' + + bit_count = bits(self) + + call digit_count( self % num_bits, count_digits ) + + allocate( character(len=count_digits+bit_count+2)::string, stat=stat ) + if ( stat > 0 ) go to 999 + + write( string, "('S', i0)" ) self % num_bits + + string( count_digits + 2:count_digits + 2 ) = "B" + do bit=0, bit_count-1 + pos = count_digits + 2 + bit_count - bit + if ( self % test( bit) ) then + string( pos:pos ) = '1' + else + string( pos:pos ) = '0' + end if + end do + + if ( present(status) ) status = success + + return + +999 if ( present(status) ) then + status = alloc_fault + return + else + error stop module_name // ' % ' // procedure // ' had a ' // & + 'memory sllocation failure for a string.' + end if + + contains + + subroutine digit_count( bits, digits ) + integer(bits_kind), intent(in) :: bits + integer(bits_kind), intent(out) :: digits + + select case ( bits ) + case ( 0:9 ) + digits = 1 + + case ( 10:99 ) + digits = 2 + + case ( 100:999 ) + digits = 3 + + case ( 1000:9999 ) + digits = 4 + + case ( 10000:99999 ) + digits = 5 + + case ( 100000:999999 ) + digits = 6 + + case ( 1000000:9999999 ) + digits = 7 + + case ( 10000000:99999999 ) + digits = 8 + + case ( 100000000:999999999 ) + digits = 9 + + case ( 1000000000:min(2147483647, huge( self % num_bits ) ) ) + digits = 10 + + case default + error stop module_name // ' % ' // procedure // & + ' internal consistency fault was found.' + + end select + + end subroutine digit_count + + end subroutine write_bitset_string_large + + + module subroutine write_bitset_unit_large(self, unit, advance, status) +! +! Writes a bitset literal to the I/O unit, UNIT, representing the +! individual bit values in the bitset_t, SELF. By default or if +! ADVANCE is present with the value 'YES', advancing output is used. +! If ADVANCE is present with the value 'NO', then the current record +! is not advanced by the write. If STATUS is absent an error results +! in an error stop with an informative stop code. If STATUS is +! present it has the default value of SUCCESS, the value +! ALLOC_FAULT if allocation of the output string failed, or +! WRITE_FAILURE if the WRITE statement outputting the literal failed. +! + class(bitset_large), intent(in) :: self + integer, intent(in) :: unit + character(len=*), intent(in), optional :: advance + integer, intent(out), optional :: status + + integer :: ierr + character(:), allocatable :: string + character(len=120) :: message + character(*), parameter :: procedure = "WRITE_BITSET" + + call self % write_bitset(string, status) + + if ( present(status) ) then + if (status /= success ) return + + end if + + + if ( present( advance ) ) then + write( unit, & + FMT='(A)', & + advance=advance, & + iostat=ierr, & + iomsg=message ) & + string + else + write( unit, & + FMT='(A)', & + advance='YES', & + iostat=ierr, & + iomsg=message ) & + string + end if + if (ierr /= 0) go to 999 + + return + +999 if ( present(status) ) then + status = write_failure + return + else + error stop module_name // ' % ' // procedure // ' had a ' // & + 'failure on a WRITE statement.' + end if + + end subroutine write_bitset_unit_large + + + elemental module subroutine xor_large(set1, set2) +! +! Sets the bits in SET1 to the bitwise XOR of the original bits in SET1 +! and SET2. SET1 and SET2 must have the same number of bits otherwise +! the result is undefined. +! + type(bitset_large), intent(inout) :: set1 + type(bitset_large), intent(in) :: set2 + + integer(bits_kind) :: block_ + + do block_ = 1, size(set1 % blocks) + set1 % blocks(block_) = ieor( set1 % blocks(block_), & + set2 % blocks(block_) ) + end do + + end subroutine xor_large + +end submodule stdlib_bitset_large diff --git a/src/stdlib_bitsets.fypp b/src/stdlib_bitsets.fypp new file mode 100644 index 000000000..5e9e13433 --- /dev/null +++ b/src/stdlib_bitsets.fypp @@ -0,0 +1,2027 @@ +#:include "common.fypp" +module stdlib_bitsets +!! Implements zero based bitsets of size up to `huge(0_int32)`. +!! The current code uses 64 bit integers to store the bits and uses all 64 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, & + int16, & + int32, & + int64, & + dp => real64 + + implicit none + + private + + integer, parameter :: & + block_size = bit_size(0_block_kind) + + integer(block_kind), private, parameter :: all_zeros = 0_block_kind + integer(block_kind), private, parameter :: all_ones = not(all_zeros) + + character(*), parameter, private :: module_name = "STDLIB_BITSETS" + integer, parameter, private :: & + ia0 = iachar('0'), & + ia9 = iachar('9') + + integer, parameter, public :: success = 0 +!! Error flag indicating no errors + integer, parameter, public :: alloc_fault = 1 +!! Error flag indicating a memory allocation failure + integer, parameter, public :: array_size_invalid_error = 2 +!! error flag indicating an invalid bits value + integer, parameter, public :: char_string_invalid_error = 3 +!! Error flag indicating an invalid character string + integer, parameter, public :: char_string_too_small_error = 4 +!! Error flag indicating a too small character string + integer, parameter, public :: index_invalid_error = 5 +!! Error flag indicating an invalid index + integer, parameter, public :: integer_overflow_error = 6 +!! Error flag indicating integer overflow + integer, parameter, public :: read_failure = 7 +!! Error flag indicating failure of a READ statement + integer, parameter, public :: eof_failure = 8 +!! Error flag indicating unexpected End-of-File on a READ + integer, parameter, public :: write_failure = 9 +!! Error flag indicating a failure on a WRITE statement + + public :: bits_kind +! Public constant + + public :: & + bitset_type, & + bitset_large, & + bitset_64 + +! Public types + + public :: & + assignment(=), & + and, & + and_not, & + bits, & + extract, & + operator(==), & + operator(/=), & + operator(>), & + operator(>=), & + operator(<), & + operator(<=), & + or, & + xor +! Public procedures + + type, abstract :: bitset_type +!! version: experimental +!! +!! Parent type for bitset_64 and bitset_large + private + integer(bits_kind) :: num_bits + + contains + + procedure(all_abstract), deferred, pass(self) :: all + procedure(any_abstract), deferred, pass(self) :: any + procedure(bit_count_abstract), deferred, pass(self) :: bit_count + procedure, pass(self) :: bits + procedure(clear_bit_abstract), deferred, pass(self) :: clear_bit + procedure(clear_range_abstract), deferred, pass(self) :: clear_range + generic :: clear => clear_bit, clear_range + procedure(flip_bit_abstract), deferred, pass(self) :: flip_bit + procedure(flip_range_abstract), deferred, pass(self) :: flip_range + generic :: flip => flip_bit, flip_range + procedure(from_string_abstract), deferred, pass(self) :: from_string + procedure(init_zero_abstract), deferred, pass(self) :: init_zero + generic :: init => init_zero + procedure(input_abstract), deferred, pass(self) :: input + procedure(none_abstract), deferred, pass(self) :: none + procedure(not_abstract), deferred, pass(self) :: not + procedure(output_abstract), deferred, pass(self) :: output + procedure(read_bitset_string_abstract), deferred, pass(self) :: & + read_bitset_string + procedure(read_bitset_unit_abstract), deferred, pass(self) :: & + read_bitset_unit + generic :: read_bitset => read_bitset_string, read_bitset_unit + procedure(set_bit_abstract), deferred, pass(self) :: set_bit + procedure(set_range_abstract), deferred, pass(self) :: set_range + generic :: set => set_bit, set_range + procedure(test_abstract), deferred, pass(self) :: test + procedure(to_string_abstract), deferred, pass(self) :: to_string + procedure(value_abstract), deferred, pass(self) :: value + procedure(write_bitset_string_abstract), deferred, pass(self) :: & + write_bitset_string + procedure(write_bitset_unit_abstract), deferred, pass(self) :: & + write_bitset_unit + generic :: write_bitset => write_bitset_string, write_bitset_unit + + end type bitset_type + + + abstract interface + + elemental function all_abstract( self ) result(all) +!! Version: experimental +!! +!! Returns `.true.` if all bits in `self` are 1, `.false`. otherwise. +!! +!!#### Example +!! +!! ```fortran +!! program demo_all +!! use stdlib_bitsets +!! character(*), parameter :: & +!! bits_all = '111111111111111111111111111111111' +!! type(bitset_64) :: set0 +!! call set0 % from_string( bits_all ) +!! if ( bits(set0) /= 33 ) then +!! error stop "FROM_STRING failed to interpret " // & +!! 'BITS_ALL's size properly." +!! else if ( .not. set0 % all() ) then +!! error stop "FROM_STRING failed to interpret" // & +!! "BITS_ALL's value properly." +!! else +!! write(*,*) "FROM_STRING transferred BITS_ALL properly" // & +!! " into set0." +!! end if +!! end program demo_all +!! + import :: bitset_type + logical :: all + class(bitset_type), intent(in) :: self + end function all_abstract + + elemental function any_abstract(self) result(any) +!! Version: experimental +!! +!! Returns `.true.` if any bit in `self` is 1, `.false.` otherwise. +!! +!!#### Example +!! +!! ```fortran +!! program demo_any +!! use stdlib_bitsets +!! character(*), parameter :: & +!! bits_0 = '0000000000000000000' +!! type(bitset_64) :: set0 +!! call set0 % from_string( bits_0 ) +!! if ( .not. set0 % any() ) then +!! write(*,*) "FROM_STRING interpreted " // & +!! "BITS_0's value properly." +!! end if +!! call set0 % set(5) +!! if ( set0 % any() ) then +!! write(*,*) "ANY interpreted SET0's value properly." +!! end if +!! end program demo_any +!! + import :: bitset_type + logical :: any + class(bitset_type), intent(in) :: self + end function any_abstract + + elemental function bit_count_abstract(self) result(bit_count) +!! Version: experimental +!! +!! Returns the number of non-zero bits in `self`. +!! +!!#### Example +!! +!! ```fortran +!! program demo_bit_count +!! use stdlib_bitsets +!! character(*), parameter :: & +!! bits_0 = '0000000000000000000' +!! type(bitset_64) :: set0 +!! call set0 % from_string( bits_0 ) +!! if ( set0 % bit_count() == 0 ) then +!! write(*,*) "FROM_STRING interpreted " // & +!! "BITS_0's value properly." +!! end if +!! call set0 % set(5) +!! if ( set0 % bit_count() == 1 ) then +!! write(*,*) "BIT_COUNT interpreted SET0's value properly." +!! end if +!! end program demo_bit_count +!! + import :: bitset_type, bits_kind + integer(bits_kind) :: bit_count + class(bitset_type), intent(in) :: self + end function bit_count_abstract + + elemental subroutine clear_bit_abstract(self, pos) +!! Version: experimental +!! +!! Sets to zero the `pos` position in `self`. If `pos` is less than zero or +!! greater than `bits(self)-1` it is ignored. +!! +!!#### Example +!! +!! ```fortran +!! program demo_clear +!! use stdlib_bitsets +!! type(bitset_large) :: set0 +!! call set0 % init(166) +!! call set0 % not() +!! if ( set0 % all() ) write(*,*) 'SET0 is properly initialized.' +!! call set0 % clear(165) +!! if ( .not. set0 % test(165) ) write(*,*) 'Bit 165 is cleared.' +!! call set0 % clear(0,164) +!! if ( set0 % none() ) write(*,*) 'All bits are cleared.' +!! end program demo_clear +!! + import :: bitset_type, bits_kind + class(bitset_type), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + end subroutine clear_bit_abstract + + pure subroutine clear_range_abstract(self, start_pos, stop_pos) +!! Version: experimental +!! +!! Sets to zero all bits from the `start_pos` to `stop_pos` positions in `set`. +!! If `stop_pos < start_pos` then no bits are modified. Positions outside +!! the range 0 to `bits(self)-1` are ignored. + import :: bitset_type, bits_kind + class(bitset_type), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + end subroutine clear_range_abstract + + elemental subroutine flip_bit_abstract(self, pos) +!! Version: experimental +!! +!! Flips the value at the `pos` position in `self`, provided the position is +!! valid. If `pos` is less than 0 or greater than `bits(self)-1`, no value is +!! changed. +!! +!!#### Example +!! +!! ```fortran +!! program demo_flip +!! use stdlib_bitsets +!! type(bitset_large) :: set0 +!! call set0 % init(166) +!! if ( set0 % none() ) write(*,*) 'SET0 is properly initialized.' +!! call set0 % flip(165) +!! if ( set0 % test(165) ) write(*,*) 'Bit 165 is flipped.' +!! call set0 % flip(0,164) +!! if ( set0 % all() ) write(*,*) 'All bits are flipped.' +!! end program demo_flip +!! + import :: bitset_type, bits_kind + class(bitset_type), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + end subroutine flip_bit_abstract + + pure subroutine flip_range_abstract(self, start_pos, stop_pos) +!! Version: experimental +!! +!! Flips all valid bits from the `start_pos` to the `stop_pos` positions in +!! `self`. If `stop_pos < start_pos` no bits are flipped. Positions less than +!! 0 or greater than `bits(self)-1` are ignored. + import :: bitset_type, bits_kind + class(bitset_type), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + end subroutine flip_range_abstract + + subroutine from_string_abstract(self, string, status) +!! Version: experimental +!! +!! Initializes the bitset `self` treating `string` as a binary literal +!! `status` may have the values `success`, `alloc_fault`, +!! `array_size_invalid_error`, or `char_string_invalid`. +!! +!!#### Example +!! +!! ```fortran +!! program demo_from_string +!! use stdlib_bitsets +!! character(*), parameter :: & +!! bits_all = '111111111111111111111111111111111' +!! type(bitset_64) :: set0 +!! call set0 % from_string( bits_all ) +!! if ( bits(set0) /= 33 ) then +!! error stop "FROM_STRING failed to interpret " // & +!! 'BITS_ALL's size properly." +!! else if ( .not. set0 % all() ) then +!! error stop "FROM_STRING failed to interpret" // & +!! "BITS_ALL's value properly." +!! else +!! write(*,*) "FROM_STRING transferred BITS_ALL properly" // & +!! " into set0." +!! end if +!! end program demo_from_string +!! + import :: bitset_type + class(bitset_type), intent(out) :: self + character(*), intent(in) :: string + integer, intent(out), optional :: status + end subroutine from_string_abstract + + subroutine init_zero_abstract(self, bits, status) +!! Creates the bitset, `self`, of size `bits`, with all bits initialized to +!! zero. `bits` must be non-negative. If an error occurs and `status` is +!! absent then processing stops with an informative stop code. `status` +!! has a default value of `success`. If an error occurs it has the value +!! `array_size_invalid_error` if `bits` is either negative or larger than 64 +!! if `self` is class `bitset_64`, or the value `alloc_fault` if it failed +!! during allocation of memory for `self`. +!! +!!#### Example +!! +!! ```fortran +!! program demo_init +!! use stdlib_bitsets +!! type(bitset_large) :: set0 +!! call set0 % init(166) +!! if ( set0 % bits() == 166 ) & +!! write(*,*) `SET0 has the proper size.' +!! if ( set0 % none() ) write(*,*) 'SET0 is properly initialized.' +!! end program demo_init +!! + import :: bitset_type, bits_kind + class(bitset_type), intent(out) :: self + integer(bits_kind), intent(in) :: bits + integer, intent(out), optional :: status + end subroutine init_zero_abstract + + subroutine input_abstract(self, unit, status) +!! Version: experimental +!! +!! Reads the components of the bitset, `self`, from the unformatted I/O +!! unit, `unit`, assuming that the components were written using `output`. +!! If an error occurs and `status` is absent then processing stops with +!! an informative stop code. `status` has a default value of `success`. +!! If an error occurs it has the value `read_failure` if it failed +!! during the reads from `unit` or the value `alloc_fault` if it failed +!! during allocation of memory for `self`, or the value +!! `array_size_invalid_error` if the `bits(self)` in `unit` is less than 0 +!! or greater than 64 for a `bitset_64` input. +!! +!!#### Example +!! +!! ```fortran +!! program demo_input +!! character(*), parameter :: & +!! bits_0 = '000000000000000000000000000000000', & +!! bits_1 = '000000000000000000000000000000001', & +!! bits_33 = '100000000000000000000000000000000' +!! integer :: unit +!! type(bitset_64) :: set0, set1, set2, set3, set4, set5 +!! call set0 % from_string( bits_0 ) +!! call set1 % from_string( bits_1 ) +!! call set2 % from_string( bits_33 ) +!! open( newunit=unit, file='test.bin', status='replace', & +!! form='unformatted', action='write' ) +!! call set2 % output(unit) +!! call set1 % output(unit) +!! call set0 % output(unit) +!! close( unit ) +!! open( newunit=unit, file='test.bin', status='old', & +!! form='unformatted', action='read' ) +!! call set5 % input(unit) +!! call set4 % input(unit) +!! call set3 % input(unit) +!! close( unit ) +!! if ( set3 /= set0 .or. set4 /= set1 .or. set5 /= set2 ) then +!! error stop 'Transfer to and from units using ' // & +!! ' output and input failed.' +!! else +!! write(*,*) 'Transfer to and from units using ' // & +!! 'output and input succeeded.' +!! end if +!! end program demo_input +!! + import :: bitset_type + class(bitset_type), intent(out) :: self + integer, intent(in) :: unit + integer, intent(out), optional :: status + end subroutine input_abstract + + elemental function none_abstract(self) result(none) +!! Version: experimental +!! +!! Returns `.true.` if none of the bits in `self` have the value 1. +!! +!!#### Example +!! +!! ```fortran +!! program demo_none +!! use stdlib_bitsets +!! character(*), parameter :: & +!! bits_0 = '0000000000000000000' +!! type(bitset_large) :: set0 +!! call set0 % from_string( bits_0 ) +!! if ( set0 % none() ) then +!! write(*,*) "FROM_STRING interpreted " // & +!! "BITS_0's value properly." +!! end if +!! call set0 % set(5) +!! if ( .not. set0 % none() ) then +!! write(*,*) "NONE interpreted SET0's value properly." +!! end if +!! end program demo_none +!! + import :: bitset_type + logical :: none + class(bitset_type), intent(in) :: self + end function none_abstract + + elemental subroutine not_abstract(self) +!! Version: experimental +!! +!! Sets the bits in `self` to their logical complement +!! +!!#### Example +!! +!! ```fortran +!! program demo_not +!! use stdlib_bitsets +!! type(bitset_large) :: set0 +!! call set0 % init( 155 ) +!! if ( set0 % none() ) then +!! write(*,*) "FROM_STRING interpreted " // & +!! "BITS_0's value properly." +!! end if +!! call set0 % not() +!! if ( set0 % all() ) then +!! write(*,*) "ALL interpreted SET0's value properly." +!! end if +!! end program demo_not +!! + import :: bitset_type + class(bitset_type), intent(inout) :: self + end subroutine not_abstract + + subroutine output_abstract(self, unit, status) +!! Version: experimental +!! +!! Writes the components of the bitset, `self`, to the unformatted I/O +!! unit, `unit`, in a unformatted sequence compatible with `input`. If +!! `status` is absent an error results in an error stop with an +!! informative stop code. If `status` is present it has the default +!! value of `success`, or the value `write_failure` if the write failed. +!! +!!#### Example +!! +!! ```fortran +!! program demo_output +!! character(*), parameter :: & +!! bits_0 = '000000000000000000000000000000000', & +!! bits_1 = '000000000000000000000000000000001', & +!! bits_33 = '100000000000000000000000000000000' +!! integer :: unit +!! type(bitset_64) :: set0, set1, set2, set3, set4, set5 +!! call set0 % from_string( bits_0 ) +!! call set1 % from_string( bits_1 ) +!! call set2 % from_string( bits_33 ) +!! open( newunit=unit, file='test.bin', status='replace', & +!! form='unformatted', action='write' ) +!! call set2 % output(unit) +!! call set1 % output(unit) +!! call set0 % output(unit) +!! close( unit ) +!! open( newunit=unit, file='test.bin', status='old', & +!! form='unformatted', action='read' ) +!! call set5 % input(unit) +!! call set4 % input(unit) +!! call set3 % input(unit) +!! close( unit ) +!! if ( set3 /= set0 .or. set4 /= set1 .or. set5 /= set2 ) then +!! error stop 'Transfer to and from units using ' // & +!! ' output and input failed.' +!! else +!! write(*,*) 'Transfer to and from units using ' // & +!! 'output and input succeeded.' +!! end if +!! end program demo_output +!! + import :: bitset_type + class(bitset_type), intent(in) :: self + integer, intent(in) :: unit + integer, intent(out), optional :: status + end subroutine output_abstract + + subroutine read_bitset_string_abstract(self, string, status) +!! Version: experimental +!! +!! Uses the bitset literal in the default character `string`, to define +!! the bitset, `self`. The literal may be preceded by an an arbitrary +!! sequence of blank characters. If `status` is absent an error results +!! in an error stop with an informative stop code. If `status` is +!! present it has the default value of `success`, the value +!! `integer_overflow_error` if the bitset literal has a `bits(self)` value +!! too large to be represented, the value `alloc_fault` if allocation of +!! memory for `self` failed, or `char_string_invalid_error` if the bitset +!! literal has an invlaaid character, or `array_size_invalid_error` if +!! `bits(self)` in `string` is greater than 64 for a `bitset_64`. +!! +!!#### Example +!! +!! ```fortran +!! program demo_read_bitset +!! character(*), parameter :: & +!! bits_0 = 'S33B000000000000000000000000000000000', & +!! bits_1 = 'S33B000000000000000000000000000000001', & +!! bits_33 = 'S33B100000000000000000000000000000000' +!! character(:), allocatable :: test_0, test_1, test_2 +!! integer :: unit +!! type(bitset_64) :: set0, set1, set2, set3, set4, set5 +!! call set0 % read_bitset( bits_0, status ) +!! call set1 % read_bitset( bits_1, status ) +!! call set2 % read_bitset( bits_2, status ) +!! call set0 % write_bitset( test_0, status ) +!! call set1 % write_bitset( test_1, status ) +!! call set2 % write_bitset( test_2, status ) +!! if ( bits_0 == test_0 .and. bits_1 == test_1 .and. & +!! bits_2 == test_2 ) then +!! write(*,*) 'READ_BITSET to WRITE_BITSET strings worked.' +!! end if +!! open( newunit=unit, file='test.txt', status='replace', & +!! form='formatted', action='write' ) +!! call set2 % write_bitset(unit, advance='no') +!! call set1 % write_bitset(unit, advance='no') +!! call set0 % write_bitset(unit) +!! close( unit ) +!! open( newunit=unit, file='test.txt', status='old', & +!! form='formatted', action='read' ) +!! call set3 % read_bitset(unit, advance='no') +!! call set4 % read_bitset(unit, advance='no') +!! call set5 % read_bitset(unit) +!! if ( set3 == set0 .and. set4 == set1 .and. set5 == set2 ) then +!! write(*,*) WRITE_BITSET to READ_BITSET through unit worked.' +!! end if +!! end program demo_read_bitset +!! + import :: bitset_type + class(bitset_type), intent(out) :: self + character(len=*), intent(in) :: string + integer, intent(out), optional :: status + end subroutine read_bitset_string_abstract + + subroutine read_bitset_unit_abstract(self, unit, advance, status) +!! Version: experimental +!! +!! Uses the bitset literal at the current position in the formatted +!! file with I/O unit, `unit`, to define the bitset, `self`. The literal +!! may be preceded by an an arbitrary sequence of blank characters. +!! If `advance` is present it must be either 'YES' or 'NO'. If absent +!! it has the default value of 'YES' to determine whether advancing +!! I/O occurs. If `status` is absent an error results in an error stop +!! with an informative stop code. If `status` is present it has the +!! default value of `success`, the value `integer_overflow_error` if the +!! bitset literal has a `bits(self)` value too large to be +!! represented, the value `read_failure` if a `read` statement fails, +!! `eof_failure` if a `read` statement reaches an end-of-file before +!! completing the read of the bitset literal, or the value +!! `char_string_invalid_error` if the read of the bitset literal found +!! an invalid character, or `array_size_invalid_error` if `bits(self)` +!! in `string` is greater than 64 for a `bitset_64`. + import :: bitset_type + class(bitset_type), intent(out) :: self + integer, intent(in) :: unit + character(*), intent(in), optional :: advance + integer, intent(out), optional :: status + end subroutine read_bitset_unit_abstract + + elemental subroutine set_bit_abstract(self, pos) +!! Version: experimental +!! +!! Sets the value at the `pos` position in `self`, provided the position is +!! valid. If the position is less than 0 or greater than `bits(self)-1` +!! then `self` is unchanged. +!! +!!#### Example +!! +!! ```fortran +!! program demo_set +!! use stdlib_bitsets +!! type(bitset_large) :: set0 +!! call set0 % init(166) +!! if ( set0 % none() ) write(*,*) 'SET0 is properly initialized.' +!! call set0 % set(165) +!! if ( set0 % test(165) ) write(*,*) 'Bit 165 is set.' +!! call set0 % set(0,164) +!! if ( set0 % all() ) write(*,*) 'All bits are set.' +!! end program demo_set +!! + import :: bitset_type, bits_kind + class(bitset_type), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + end subroutine set_bit_abstract + + pure subroutine set_range_abstract(self, start_pos, stop_pos) +!! Version: experimental +!! +!! Sets all valid bits to 1 from the `start_pos` to the `stop_pos` positions +!! in `self`. If `stop_pos < start_pos` no bits are changed. Positions outside +!! the range 0 to `bits(self)-1` are ignored. + import :: bitset_type, bits_kind + class(bitset_type), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + end subroutine set_range_abstract + + elemental function test_abstract(self, pos) result(test) +!! Version: experimental +!! +!! Returns `.true.` if the `pos` position is set, `.false.` otherwise. If `pos` +!! is negative or greater than `bits(self) - 1` the result is `.false.`. +!! +!!#### Example +!! +!! ```fortran +!! program demo_test +!! use stdlib_bitsets +!! type(bitset_large) :: set0 +!! call set0 % init(166) +!! call set0 % not() +!! if ( set0 % all() ) write(*,*) 'SET0 is properly initialized.' +!! call set0 % clear(165) +!! if ( .not. set0 % test(165) ) write(*,*) 'Bit 165 is cleared.' +!! call set0 % set(165) +!! if ( set0 % test(165) ) write(*,*) 'Bit 165 is set.' +!! end program demo_test +!! + import :: bitset_type, bits_kind + logical :: test + class(bitset_type), intent(in) :: self + integer(bits_kind), intent(in) :: pos + end function test_abstract + + subroutine to_string_abstract(self, string, status) +!! Version: experimental +!! +!! Represents the value of `self` as a binary literal in `string` +!! Status may have the values `success` or `alloc_fault`. +!! +!!#### Example +!! +!! ```fortran +!! program demo_to_string +!! use stdlib_bitsets +!! character(*), parameter :: & +!! bits_all = '111111111111111111111111111111111' +!! type(bitset_64) :: set0 +!! character(:), allocatable :: new_string +!! call set0 % init(33) +!! call set0 % not() +!! call set0 % to_string( new_string ) +!! if ( new_string == bits_all ) then +!! write(*,*) "TO_STRING transferred BITS0 properly" // & +!! " into NEW_STRING." +!! end if +!! end program demo_to_string +!! + import :: bitset_type + class(bitset_type), intent(in) :: self + character(:), allocatable, intent(out) :: string + integer, intent(out), optional :: status + end subroutine to_string_abstract + + elemental function value_abstract(self, pos) result(value) +!! Version: experimental +!! +!! Returns 1 if the `pos` position is set, 0 otherwise. If `pos` is negative +!! or greater than `bits(set) - 1` the result is 0. +!! +!!#### Example +!! +!! ```fortran +!! program demo_value +!! use stdlib_bitsets +!! type(bitset_large) :: set0 +!! call set0 % init(166) +!! call set0 % not() +!! if ( set0 % all() ) write(*,*) 'SET0 is properly initialized.' +!! call set0 % clear(165) +!! if ( set0 % value(165) == 0 ) write(*,*) 'Bit 165 is cleared.' +!! call set0 % set(165) +!! if ( set0 % value(165) == 1 ) write(*,*) 'Bit 165 is set.' +!! end program demo_value +!! + import :: bitset_type, bits_kind + integer :: value + class(bitset_type), intent(in) :: self + integer(bits_kind), intent(in) :: pos + end function value_abstract + + subroutine write_bitset_string_abstract(self, string, status) +!! Version: experimental +!! +!! Writes a bitset literal to the allocatable default character `string`, +!! representing the individual bit values in the `bitset_type`, `self`. +!! If `status` is absent an error results in an error stop with an +!! informative stop code. If `status` is present it has the default +!! value of `success`, or the value `alloc_fault` if allocation of +!! the output string failed. +!! +!!#### Example +!! +!! ```fortran +!! program demo_write_bitset +!! character(*), parameter :: & +!! bits_0 = 'S33B000000000000000000000000000000000', & +!! bits_1 = 'S33B000000000000000000000000000000001', & +!! bits_33 = 'S33B100000000000000000000000000000000' +!! character(:), allocatable :: test_0, test_1, test_2 +!! integer :: unit +!! type(bitset_64) :: set0, set1, set2, set3, set4, set5 +!! call set0 % read_bitset( bits_0, status ) +!! call set1 % read_bitset( bits_1, status ) +!! call set2 % read_bitset( bits_2, status ) +!! call set0 % write_bitset( test_0, status ) +!! call set1 % write_bitset( test_1, status ) +!! call set2 % write_bitset( test_2, status ) +!! if ( bits_0 == test_0 .and. bits_1 == test_1 .and. & +!! bits_2 == test_2 ) then +!! write(*,*) 'READ_BITSET to WRITE_BITSET strings worked.' +!! end if +!! open( newunit=unit, file='test.txt', status='replace', & +!! form='formatted', action='write' ) +!! call set2 % write_bitset(unit, advance='no') +!! call set1 % write_bitset(unit, advance='no') +!! call set0 % write_bitset(unit) +!! close( unit ) +!! open( newunit=unit, file='test.txt', status='old', & +!! form='formatted', action='read' ) +!! call set3 % read_bitset(unit, advance='no') +!! call set4 % read_bitset(unit, advance='no') +!! call set5 % read_bitset(unit) +!! if ( set3 == set0 .and. set4 == set1 .and. set5 == set2 ) then +!! write(*,*) WRITE_BITSET to READ_BITSET through unit worked.' +!! end if +!! end program demo_write_bitset +!! + import :: bitset_type + class(bitset_type), intent(in) :: self + character(len=:), allocatable, intent(out) :: string + integer, intent(out), optional :: status + end subroutine write_bitset_string_abstract + + subroutine write_bitset_unit_abstract(self, unit, advance, & + status) +!! Version: experimental +!! +!! Writes a bitset literal to the I/O unit, `unit`, representing the +!! individual bit values in the `bitset_t`, `self`. If an error occurs then +!! processing stops with a message to `error_unit`. By default or if +!! `advance` is present with the value 'YES', advancing output is used. +!! If `advance` is present with the value 'NO', then the current record +!! is not advanced by the write. If `status` is absent, an error results +!! in an error stop with an informative stop code. If `status` is +!! present it has the default value of `success`, the value +!! `alloc_fault` if allocation of the output string failed, +!! `write_failure` if the `write` statement outputting the literal failed. + import :: bitset_type + class(bitset_type), intent(in) :: self + integer, intent(in) :: unit + character(len=*), intent(in), optional :: advance + integer, intent(out), optional :: status + end subroutine write_bitset_unit_abstract + + end interface + + type, extends(bitset_type) :: bitset_large +!! Version: experimental +!! +!! Type for bitsets with more than 64 bits. + private + integer(block_kind), private, allocatable :: blocks(:) + + contains + + procedure, pass(self) :: all => all_large + procedure, pass(self) :: any => any_large + procedure, pass(self) :: bit_count => bit_count_large + procedure, pass(self) :: clear_bit => clear_bit_large + procedure, pass(self) :: clear_range => clear_range_large + procedure, pass(self) :: flip_bit => flip_bit_large + procedure, pass(self) :: flip_range => flip_range_large + procedure, pass(self) :: from_string => from_string_large + procedure, pass(self) :: init_zero => init_zero_large + procedure, pass(self) :: input => input_large + procedure, pass(self) :: none => none_large + procedure, pass(self) :: not => not_large + procedure, pass(self) :: output => output_large + procedure, pass(self) :: & + read_bitset_string => read_bitset_string_large + procedure, pass(self) :: read_bitset_unit => read_bitset_unit_large + procedure, pass(self) :: set_bit => set_bit_large + procedure, pass(self) :: set_range => set_range_large + procedure, pass(self) :: test => test_large + procedure, pass(self) :: to_string => to_string_large + procedure, pass(self) :: value => value_large + procedure, pass(self) :: & + write_bitset_string => write_bitset_string_large + procedure, pass(self) :: write_bitset_unit => write_bitset_unit_large + + end type bitset_large + + + interface + + elemental module function all_large( self ) result(all) +!! Version: experimental +!! +!! Returns `.true.` if all bits in `self` are 1, `.false.` otherwise. + logical :: all + class(bitset_large), intent(in) :: self + end function all_large + + elemental module function any_large(self) result(any) +!! Version: experimental +!! +!! Returns `.true.` if any bit in `self` is 1, `.false.` otherwise. + logical :: any + class(bitset_large), intent(in) :: self + end function any_large + + elemental module function bit_count_large(self) result(bit_count) +!! Version: experimental +!! +!! Returns the number of non-zero bits in `self`. + integer(bits_kind) :: bit_count + class(bitset_large), intent(in) :: self + end function bit_count_large + + elemental module subroutine clear_bit_large(self, pos) +!! Version: experimental +!! +!! Sets to zero the bit at `pos` position in `self`. If 'pos` is less than +!! zero or greater than `bits(self)-1` it is ignored. + class(bitset_large), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + end subroutine clear_bit_large + + pure module subroutine clear_range_large(self, start_pos, stop_pos) +!! Version: experimental +!! +!! Sets to zero all bits from the `start_pos` to `stop_pos` positions in `self`. +!! If `stop_pos < start_pos` then no bits are modified. Positions outside +!! the range 0 to `bits(set)-1` are ignored. + class(bitset_large), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + end subroutine clear_range_large + + elemental module subroutine flip_bit_large(self, pos) +!! Version: experimental +!! +!! Flips the bit value at the `pos` position in `self`, provided the position is +!! valid. If `pos` is less than 0 or greater than `bits(self)-1`, no value is +!! changed. + class(bitset_large), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + end subroutine flip_bit_large + + pure module subroutine flip_range_large(self, start_pos, stop_pos) +!! Version: experimental +!! +!! Flips all valid bits from the `start_pos` to the `stop_pos` positions in +!! `self`. If `stop_pos < start_pos` no bits are flipped. Positions less than +!! 0 or greater than `bits(self)-1` are ignored. + class(bitset_large), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + end subroutine flip_range_large + + module subroutine from_string_large(self, string, status) +!! Version: experimental +!! +!! Initializes the bitset `self` treating `string` as a binary literal +!! `status` may have the values `success`, `alloc_fault`, +!! `array_size_invalid_error`, or `char_string_invalid`. + class(bitset_large), intent(out) :: self + character(*), intent(in) :: string + integer, intent(out), optional :: status + end subroutine from_string_large + + module subroutine init_zero_large(self, bits, status) +!! Version: experimental +!! +!! Creates the bitset, `self`, of size `bits`, with all bits initialized to +!! zero. `bits` must be non-negative. If an error occurs and `status` is +!! absent then processing stops with an informative stop code. `status` +!! has a default value of `success`. If an error occurs it has the value +!! `array_size_invalid_error` if `bits` is either negative larger than 64 +!! if `self` is of type `bitset_64`, or the value `alloc_fault` if it failed +!! during allocation of memory for `self`. + class(bitset_large), intent(out) :: self + integer(bits_kind), intent(in) :: bits + integer, intent(out), optional :: status + end subroutine init_zero_large + + module subroutine input_large(self, unit, status) +!! Version: experimental +!! +!! Reads the components of the bitset, `self`, from the unformatted I/O +!! unit, `unit`, assuming that the components were written using `output`. +!! If an error occurs and `status` is absent then processing stops with +!! an informative stop code. `status` has a default value of `success`. +!! If an error occurs it has the value `read_failure` if it failed +!! during the reads from `unit` or the value `alloc_fault` if it failed +!! during allocation of memory for `self`, or the value +!! `array_size_invalid_error if the `bits(self) in `unit` is less than 0 +!! or greater than 64 for a `bitset_64` input. + class(bitset_large), intent(out) :: self + integer, intent(in) :: unit + integer, intent(out), optional :: status + end subroutine input_large + + elemental module function none_large(self) result(none) +!! Version: experimental +!! +!! Returns `.true.` if none of the bits in `self` have the value 1. + logical :: none + class(bitset_large), intent(in) :: self + end function none_large + + elemental module subroutine not_large(self) +!! Version: experimental +!! +!! Sets the bits in `self` to their logical complement + class(bitset_large), intent(inout) :: self + end subroutine not_large + + module subroutine output_large(self, unit, status) +!! Version: experimental +!! +!! Writes the components of the bitset, `self`, to the unformatted I/O +!! unit, `unit`, in a unformatted sequence compatible with `input`. If +!! `status` is absent an error results in an error stop with an +!! informative stop code. If `status` is present it has the default +!! value of `success`, or the value `write_failure` if the write failed. + class(bitset_large), intent(in) :: self + integer, intent(in) :: unit + integer, intent(out), optional :: status + end subroutine output_large + + module subroutine read_bitset_string_large(self, string, status) +!! Version: experimental +!! +!! Uses the bitset literal in the default character `string`, to define +!! the bitset, `self`. The literal may be preceded by an an arbitrary +!! sequence of blank characters. If `status` is absent an error results +!! in an error stop with an informative stop code. If `status` is +!! present it has the default value of `success`, the value +!! `integer_overflow_error` if the bitset literal has a `bits(self)` value +!! too large to be represented, the value `alloc_fault` if allocation of +!! memory for `self` failed, or `char_string_invalid_error` if the bitset +!! literal has an invlaid character, or `array_size_invalid_error` if +!! `bits(self)` in `string` is greater than 64 for a `bitset_64`, or +!! `char_string_too_small_error` if the string ends before all the bits +!! are read. + class(bitset_large), intent(out) :: self + character(len=*), intent(in) :: string + integer, intent(out), optional :: status + end subroutine read_bitset_string_large + + module subroutine read_bitset_unit_large(self, unit, advance, status) +!! Version: experimental +!! +!! Uses the bitset literal at the current position in the formatted +!! file with I/O unit, `unit`, to define the bitset, `self`. The literal +!! may be preceded by an an arbitrary sequence of blank characters. +!! If `advance` is present it must be either 'YES' or 'NO'. If absent +!! it has the default value of 'YES' to determine whether advancing +!! I/O occurs. If `status` is absent an error results in an error stop +!! with an informative stop code. If `status` is present it has the +!! default value of `success`, the value `integer_overflow_error` if the +!! bitset literal has a `bits(self)` value too large to be +!! represented, the value `read_failure` if a `read` statement fails, +!! `eof_failure` if a `read` statement reach an end-of-file before +!! completing the read of the bitset literal, or the value +!! `char_string_invalid_error` if the read of the bitset literal found +!! an invalid character, or `array_size_invalid_error` if `bits(self)` +!! in `string` is greater than 64 for a `bitset_64`. + class(bitset_large), intent(out) :: self + integer, intent(in) :: unit + character(*), intent(in), optional :: advance + integer, intent(out), optional :: status + end subroutine read_bitset_unit_large + + elemental module subroutine set_bit_large(self, pos) +!! Version: experimental +!! +!! Sets the value at the `pos` position in `self`, provided the position is +!! valid. If the position is less than 0 or greater than `bits(self)-1` +!! then `self` is unchanged. + class(bitset_large), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + end subroutine set_bit_large + + pure module subroutine set_range_large(self, start_pos, stop_pos) +!! Version: experimental +!! +!! Sets all valid bits to 1 from the `start_pos` to the `stop_pos` positions +!! in `self`. If `stop_pos < start_pos` no bits are changed. Positions outside +!! the range 0 to `bits(self)-1` are ignored. + class(bitset_large), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + end subroutine set_range_large + + elemental module function test_large(self, pos) result(test) +!! Version: experimental +!! +!! Returns `.true.` if the `pos` position is set, `.false.` otherwise. If `pos` +!! is negative or greater than `bits(self) - 1` the result is `.false.`. + logical :: test + class(bitset_large), intent(in) :: self + integer(bits_kind), intent(in) :: pos + end function test_large + + module subroutine to_string_large(self, string, status) +!! Version: experimental +!! +!! Represents the value of `self` as a binary literal in `string` +!! Status may have the values `success` or `alloc_fault`. + class(bitset_large), intent(in) :: self + character(len=:), allocatable, intent(out) :: string + integer, intent(out), optional :: status + end subroutine to_string_large + + elemental module function value_large(self, pos) result(value) +!! Version: experimental +!! +!! Returns 1 if the `pos` position is set, 0 otherwise. If `pos` is negative +!! or greater than `bits(set) - 1` the result is 0. + integer :: value + class(bitset_large), intent(in) :: self + integer(bits_kind), intent(in) :: pos + end function value_large + + module subroutine write_bitset_string_large(self, string, status) +!! Version: experimental +!! +!! Writes a bitset literal to the allocatable default character `string`, +!! representing the individual bit values in the bitset_large, `self`. +!! If `status` is absent an error results in an error stop with an +!! informative stop code. If `status` is present it has the default +!! value of `success, or the value `alloc_fault` if allocation of +!! the output string failed. + class(bitset_large), intent(in) :: self + character(len=:), allocatable, intent(out) :: string + integer, intent(out), optional :: status + end subroutine write_bitset_string_large + + module subroutine write_bitset_unit_large(self, unit, advance, status) +!! Version: experimental +!! +!! Writes a bitset literal to the I/O unit, `unit`, representing the +!! individual bit values in the bitset, `self`. By default or if +!! `advance` is present with the value 'YES', advancing output is used. +!! If `advance` is present with the value 'NO', then the current record +!! is not advanced by the write. If `status` is absent an error results +!! in an error stop with an informative stop code. If `status` is +!! present it has the default value of `success`, the value +!! `alloc_fault` if allocation of the output string failed, or +!! `write_failure` if the `write` statement outputting the literal failed. + class(bitset_large), intent(in) :: self + integer, intent(in) :: unit + character(len=*), intent(in), optional :: advance + integer, intent(out), optional :: status + end subroutine write_bitset_unit_large + + end interface + + + interface assignment(=) +!! +!!#### Example +!! +!! ```fortran +!! program demo_assignment +!! use stdlib_bitsets +!! logical(int8) :: logical1(64) = .true. +!! logical(int32), allocatable :: logical2(:) +!! type(bitset_64) :: set0, set1 +!! set0 = logical1 +!! if ( set0 % bits() /= 64 ) then +!! error stop procedure // & +!! ' initialization with logical(int8) failed to set' // & +!! ' the right size.' +!! else if ( .not. set0 % all() ) then +!! error stop procedure // ' initialization with' // & +!! ' logical(int8) failed to set the right values.' +!! else +!! write(*,*) 'Initialization with logical(int8) succeeded.' +!! end if +!! set1 = set0 +!! if ( set1 == set0 ) & +!! write(*,*) 'Initialization by assignment succeeded' +!! logical2 = set1 +!! if ( all( logical2 ) ) then +!! write(*,*) 'Initialization of logical(int32) succeeded.' +!! end if +!! end program demo_assignment +!! + + pure module subroutine assign_large( set1, set2 ) +!! Version: experimental +!! +!! Used to define assignment for `bitset_large`. + type(bitset_large), intent(out) :: set1 + type(bitset_large), intent(in) :: set2 + end subroutine assign_large + + #:for k1 in INT_KINDS + pure module subroutine assign_log${k1}$_large( self, logical_vector ) +!! Version: experimental +!! +!! Used to define assignment from an array of type `logical(${k1}$)` to a +!! `bitset_large`. + type(bitset_large), intent(out) :: self + logical(${k1}$), intent(in) :: logical_vector(:) + end subroutine assign_log${k1}$_large + + pure module subroutine log${k1}$_assign_large( logical_vector, set ) +!! Version: experimental +!! +!! Used to define assignment to an array of type `logical(${k1}$)` from a +!! `bitset_large`. + logical(${k1}$), intent(out), allocatable :: logical_vector(:) + type(bitset_large), intent(in) :: set + end subroutine log${k1}$_assign_large + #:endfor + + end interface assignment(=) + + + type, extends(bitset_type) :: bitset_64 +!! Version: experimental +!! +!! Type for bitsets with no more than 64 bits. + private + integer(block_kind), private :: block = 0 + + contains + + procedure, pass(self) :: all => all_64 + procedure, pass(self) :: any => any_64 + procedure, pass(self) :: bit_count => bit_count_64 + procedure, pass(self) :: clear_bit => clear_bit_64 + procedure, pass(self) :: clear_range => clear_range_64 + procedure, pass(self) :: flip_bit => flip_bit_64 + procedure, pass(self) :: flip_range => flip_range_64 + procedure, pass(self) :: from_string => from_string_64 + procedure, pass(self) :: init_zero => init_zero_64 + procedure, pass(self) :: input => input_64 + procedure, pass(self) :: none => none_64 + procedure, pass(self) :: not => not_64 + procedure, pass(self) :: output => output_64 + procedure, pass(self) :: read_bitset_string => read_bitset_string_64 + procedure, pass(self) :: read_bitset_unit => read_bitset_unit_64 + procedure, pass(self) :: set_bit => set_bit_64 + procedure, pass(self) :: set_range => set_range_64 + procedure, pass(self) :: test => test_64 + procedure, pass(self) :: to_string => to_string_64 + procedure, pass(self) :: value => value_64 + procedure, pass(self) :: write_bitset_string => write_bitset_string_64 + procedure, pass(self) :: write_bitset_unit => write_bitset_unit_64 + + end type bitset_64 + + + interface + + elemental module function all_64( self ) result(all) +!! Version: experimental +!! +!! Returns `.true.` if all bits in `self` are 1, `.false.` otherwise. + logical :: all + class(bitset_64), intent(in) :: self + end function all_64 + + elemental module function any_64(self) result(any) +!! Version: experimental +!! +!! Returns `.true.` if any bit in `self` is 1, `.false.` otherwise. + logical :: any + class(bitset_64), intent(in) :: self + end function any_64 + + elemental module function bit_count_64(self) result(bit_count) +!! Version: experimental +!! +!! Returns the number of non-zero bits in `self`. + integer(bits_kind) :: bit_count + class(bitset_64), intent(in) :: self + end function bit_count_64 + + elemental module subroutine clear_bit_64(self, pos) +!! Version: experimental +!! +!! Sets to zero the bit at `pos` position in `self`. If 'pos` is less than +!! zero or greater than `bits(self)-1` it is ignored. + class(bitset_64), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + end subroutine clear_bit_64 + + pure module subroutine clear_range_64(self, start_pos, stop_pos) +!! Version: experimental +!! +!! Sets to zero all bits from the `start_pos` to `stop_pos` positions in `self`. +!! If `stop_pos < start_pos` then no bits are modified. Positions outside +!! the range 0 to `bits(set)-1` are ignored. + class(bitset_64), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + end subroutine clear_range_64 + + elemental module subroutine flip_bit_64(self, pos) +!! Version: experimental +!! +!! Flips the bit value at the `pos` position in `self`, provided the position is +!! valid. If `pos` is less than 0 or greater than `bits(self)-1`, no value is +!! changed. + class(bitset_64), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + end subroutine flip_bit_64 + + pure module subroutine flip_range_64(self, start_pos, stop_pos) +!! Version: experimental +!! +!! Flips all valid bits from the `start_pos` to the `stop_pos` positions in +!! `self`. If `stop_pos < start_pos` no bits are flipped. Positions less than +!! 0 or greater than `bits(self)-1` are ignored. + class(bitset_64), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + end subroutine flip_range_64 + + module subroutine from_string_64(self, string, status) +!! Version: experimental +!! +!! Initializes the bitset `self` treating `string` as a binary literal +!! `status` has the default value `success`, the value `alloc_fault` if the +!! allocation of the bits in self failed, `array_size_invalid_error` if the +!! `len(string)>64` for a `bitset_64`, or `char_string_invalid` if an invalid +!! character was found in `string`. + class(bitset_64), intent(out) :: self + character(*), intent(in) :: string + integer, intent(out), optional :: status + end subroutine from_string_64 + + module subroutine init_zero_64(self, bits, status) +!! Version: experimental +!! +!! Creates the bitset, `self`, of size `bits`, with all bits initialized to +!! zero. `bits` must be non-negative. If an error occurs and `status` is +!! absent then processing stops with an informative stop code. `status` +!! has a default value of `success`. If an error occurs it has the value +!! `array_size_invalid_error` if `bits` is either negative larger than 64 +!! for `self` of type `bitset_64`, or the value `alloc_fault` if it failed +!! during allocation of memory for `self`. + class(bitset_64), intent(out) :: self + integer(bits_kind), intent(in) :: bits + integer, intent(out), optional :: status + end subroutine init_zero_64 + + module subroutine input_64(self, unit, status) +!! Version: experimental +!! +!! Reads the components of the bitset, `self`, from the unformatted I/O +!! unit, `unit`, assuming that the components were written using `output`. +!! If an error occurs and `status` is absent then processing stops with +!! an informative stop code. `status` has a default value of `success`. +!! If an error occurs it has the value `read_failure` if it failed +!! during the reads from `unit` or the value `alloc_fault` if it failed +!! during allocation of memory for `self`, or the value +!! `array_size_invalid_error` if the `bits(self)` in `unit` is less than 0 +!! or greater than 64 for a `bitset_64` input. + class(bitset_64), intent(out) :: self + integer, intent(in) :: unit + integer, intent(out), optional :: status + end subroutine input_64 + + elemental module function none_64(self) result(none) +!! Version: experimental +!! +!! Returns `.true.` if none of the bits in `self` have the value 1. + logical :: none + class(bitset_64), intent(in) :: self + end function none_64 + + elemental module subroutine not_64(self) +!! Version: experimental +!! +!! Sets the bits in `self` to their logical complement. + class(bitset_64), intent(inout) :: self + end subroutine not_64 + + module subroutine output_64(self, unit, status) +!! Version: experimental +!! +!! Writes the components of the bitset, `self`, to the unformatted I/O +!! unit, `unit`, in a unformatted sequence compatible with `input`. If +!! `status` is absent an error results in an error stop with an +!! informative stop code. If `status` is present it has the default +!! value of `success`, or the value `write_failure` if the write failed. + class(bitset_64), intent(in) :: self + integer, intent(in) :: unit + integer, intent(out), optional :: status + end subroutine output_64 + + module subroutine read_bitset_string_64(self, string, status) +!! Version: experimental +!! +!! Uses the bitset literal in the default character `string`, to define +!! the bitset, `self`. The literal may be preceded by an an arbitrary +!! sequence of blank characters. If `status` is absent an error results +!! in an error stop with an informative stop code. If `status` is +!! present it has the default value of `success`, the value +!! `integer_overflow_error` if the bitset literal has a `bits(self)` value +!! too large to be represented, the value `alloc_fault` if allocation of +!! memory for `self` failed, or `char_string_invalid_error` if the bitset +!! literal has an invlaid character, or `array_size_invalid_error` if +!! `bits(self)` in `string` is greater than 64 for a `bitset_64`, or +!! `char_string_too_small_error` if the string ends before all the bits +!! are read. + class(bitset_64), intent(out) :: self + character(len=*), intent(in) :: string + integer, intent(out), optional :: status + end subroutine read_bitset_string_64 + + module subroutine read_bitset_unit_64(self, unit, advance, status) +!! Version: experimental +!! +!! Uses the bitset literal at the current position in the formatted +!! file with I/O unit, `unit`, to define the bitset, `self`. The literal +!! may be preceded by an an arbitrary sequence of blank characters. +!! If `advance` is present it must be either 'YES' or 'NO'. If absent +!! it has the default value of 'YES' to determine whether advancing +!! I/O occurs. If `status` is absent an error results in an error stop +!! with an informative stop code. If `status` is present it has the +!! default value of `success`, the value `integer_overflow_error` if the +!! bitset literal has a `bits(self)` value too large to be +!! represented, the value `read_failure` if a `read` statement fails, +!! `eof_failure` if a `read` statement reach an end-of-file before +!! completing the read of the bitset literal, or the value +!! `char_string_invalid_error` if the read of the bitset literal found +!! an invalid character, or `array_size_invalid_error` if `bits(self)` +!! in `string` is greater than 64 for a `bitset_64`. + class(bitset_64), intent(out) :: self + integer, intent(in) :: unit + character(*), intent(in), optional :: advance + integer, intent(out), optional :: status + end subroutine read_bitset_unit_64 + + elemental module subroutine set_bit_64(self, pos) +!! Version: experimental +!! +!! Sets the value at the `pos` position in `self`, provided the position is +!! valid. If the position is less than 0 or greater than `bits(self)-1` +!! then `self` is unchanged. + class(bitset_64), intent(inout) :: self + integer(bits_kind), intent(in) :: pos + end subroutine set_bit_64 + + pure module subroutine set_range_64(self, start_pos, stop_pos) +!! Version: experimental +!! +!! Sets all valid bits to 1 from the `start_pos` to the `stop_pos` positions +!! in `self`. If `stop_pos < start_pos` no bits are changed. Positions outside +!! the range 0 to `bits(self)-1` are ignored. + class(bitset_64), intent(inout) :: self + integer(bits_kind), intent(in) :: start_pos, stop_pos + end subroutine set_range_64 + + elemental module function test_64(self, pos) result(test) +!! Version: experimental +!! +!! Returns `.true.` if the `pos` position is set, `.false.` otherwise. If `pos` +!! is negative or greater than `bits(self)-1` the result is `.false.`. + logical :: test + class(bitset_64), intent(in) :: self + integer(bits_kind), intent(in) :: pos + end function test_64 + + module subroutine to_string_64(self, string, status) +!! Version: experimental +!! +!! Represents the value of `self` as a binary literal in `string`. +!! Status may have the values `success` or `alloc_fault` + class(bitset_64), intent(in) :: self + character(len=:), allocatable, intent(out) :: string + integer, intent(out), optional :: status + end subroutine to_string_64 + + elemental module function value_64(self, pos) result(value) +!! Version: experimental +!! +!! Returns 1 if the `pos` position is set, 0 otherwise. If `pos` is negative +!! or greater than `bits(set)-1` the result is 0. + integer :: value + class(bitset_64), intent(in) :: self + integer(bits_kind), intent(in) :: pos + end function value_64 + + module subroutine write_bitset_string_64(self, string, status) +!! Version: experimental +!! +!! Writes a bitset literal to the allocatable default character `string`, +!! representing the individual bit values in the `bitset_64`, `self`. +!! If `status` is absent an error results in an error stop with an +!! informative stop code. If `status` is present it has the default +!! value of `success`, or the value `alloc_fault` if allocation of +!! the output string failed. + class(bitset_64), intent(in) :: self + character(len=:), allocatable, intent(out) :: string + integer, intent(out), optional :: status + end subroutine write_bitset_string_64 + + module subroutine write_bitset_unit_64(self, unit, advance, status) +!! Version: experimental +!! +!! Writes a bitset literal to the I/O unit, `unit`, representing the +!! individual bit values in the bitset, `self`. By default or if +!! `advance` is present with the value 'YES', advancing output is used. +!! If `advance` is present with the value 'NO', then the current record +!! is not advanced by the write. If `status` is absent an error results +!! in an error stop with an informative stop code. If `status` is +!! present it has the default value of `success`, the value +!! `alloc_fault` if allocation of the output string failed, or +!! `write_failure` if the `write` statement outputting the literal failed. + class(bitset_64), intent(in) :: self + integer, intent(in) :: unit + character(len=*), intent(in), optional :: advance + integer, intent(out), optional :: status + end subroutine write_bitset_unit_64 + + end interface + + + interface assignment(=) + + pure module subroutine assign_64( set1, set2 ) +!! Version: experimental +!! +!! Used to define assignment for `bitset_64`. + type(bitset_64), intent(out) :: set1 + type(bitset_64), intent(in) :: set2 + end subroutine assign_64 + + #:for k1 in INT_KINDS + module subroutine assign_log${k1}$_64( self, logical_vector ) +!! Version: experimental +!! +!! Used to define assignment from an array of type `logical(int8)` to a +!! `bitset_64`. + type(bitset_64), intent(out) :: self + logical(${k1}$), intent(in) :: logical_vector(:) + end subroutine assign_log${k1}$_64 + + pure module subroutine log${k1}$_assign_64( logical_vector, set ) +!! Version: experimental +!! +!! Used to define assignment to an array of type `logical(int8)` from a +!! `bitset_64`. + logical(${k1}$), intent(out), allocatable :: logical_vector(:) + type(bitset_64), intent(in) :: set + end subroutine log${k1}$_assign_64 + #:endfor + + end interface assignment(=) + + + interface and + + elemental module subroutine and_large(set1, set2) +!! Version: experimental +!! +!! Sets the bits in `set1` to the bitwise `and` of the original bits in `set1` +!! and `set2`. The sets mmust have the same number of bits +!! otherwise the result is undefined. +!! +!!#### Example +!! +!! ```fortran +!! program demo_and +!! use stdlib_bitsets +!! type(bitset_large) :: set0, set1 +!! call set0 % init(166) +!! call set1 % init(166) +!! call and( set0, set1 ) ! none none +!! if ( none(set0) ) write(*,*) 'First test of AND worked.' +!! call set0 % not() +!! call and( set0, set1 ) ! all none +!! if ( none(set0) ) write(*,*) 'Second test of AND worked.' +!! call set1 % not() +!! call and( set0, set1 ) ! none all +!! if ( none(set0) ) write(*,*) 'Third test of AND worked.' +!! call set0 % not() +!! call and( set0, set1 ) ! all all +!! if ( all(set0) ) write(*,*) 'Fourth test of AND worked.' +!! end program demo_and +!! + type(bitset_large), intent(inout) :: set1 + type(bitset_large), intent(in) :: set2 + end subroutine and_large + + elemental module subroutine and_64(set1, set2) +!! Version: experimental +!! +!! Sets the bits in `set1` to the bitwise `and` of the original bits in `set1` +!! and `set2`. The sets must have the same number of bits +!! otherwise the result is undefined. + type(bitset_64), intent(inout) :: set1 + type(bitset_64), intent(in) :: set2 + end subroutine and_64 + + end interface and + + + interface and_not + + elemental module subroutine and_not_large(set1, set2) +!! Version: experimental +!! +!! Sets the bits in `set1` to the bitwise and of the original bits in `set1` +!! with the bitwise negation of `set2`. The sets must have the same +!! number of bits otherwise the result is undefined. +!! +!!#### Example +!! +!! ```fortran +!! program demo_and_not +!! use stdlib_bitsets +!! type(bitset_large) :: set0, set1 +!! call set0 % init(166) +!! call set1 % init(166) +!! call and_not( set0, set1 ) ! none none +!! if ( none(set0) ) write(*,*) 'First test of AND_NOT worked.' +!! call set0 % not() +!! call and_not( set0, set1 ) ! all none +!! if ( all(set0) ) write(*,*) 'Second test of AND_NOT worked.' +!! call set0 % not() +!! call set1 % not() +!! call and_not( set0, set1 ) ! none all +!! if ( none(set0) ) write(*,*) 'Third test of AND_NOT worked.' +!! call set0 % not() +!! call and_not( set0, set1 ) ! all all +!! if ( none(set0) ) write(*,*) 'Fourth test of AND_NOT worked.' +!! end program demo_and_not +!! + type(bitset_large), intent(inout) :: set1 + type(bitset_large), intent(in) :: set2 + end subroutine and_not_large + + elemental module subroutine and_not_64(set1, set2) +!! Version: experimental +!! +!! Sets the bits in `set1` to the bitwise and of the original bits in `set1` +!! with the bitwise negation of `set2`. The sets must have the same +!! number of bits otherwise the result is undefined. + type(bitset_64), intent(inout) :: set1 + type(bitset_64), intent(in) :: set2 + end subroutine and_not_64 + + end interface and_not + + interface extract + + module subroutine extract_large(new, old, start_pos, stop_pos, status) +!! Version: experimental +!! +!! Creates a new bitset, `new`, from a range, `start_pos` to `stop_pos`, in +!! bitset `old`. If 'start_pos` is greater than `stop_pos` the new bitset is +!! empty. If `start_pos` is less than zero or `stop_pos` is greater than +!! `bits(old)-1` then if `status` is present it has the value +!! `index_invalid_error`and `new` is undefined, otherwise processing stops +!! with an informative message. +!! +!!#### Example +!! +!! ```fortran +!! program demo_extract +!! use stdlib_bitsets +!! type(bitset_large) :: set0, set1 +!! call set0 % init(166) +!! call set0 % set(100,150) +!! call extract( set1, set0, 100, 150) +!! if ( set1 % bits() == 51 ) & +!! write(*,*) 'SET1 has the proper size.' +!! if ( set1 % all() ) write(*,*) 'SET1 has the proper values.' +!! end program demo_extract +!! + type(bitset_large), intent(out) :: new + type(bitset_large), intent(in) :: old + integer(bits_kind), intent(in) :: start_pos, stop_pos + integer, intent(out), optional :: status + end subroutine extract_large + + module subroutine extract_64(new, old, start_pos, stop_pos, status) +!! Version: experimental +!! +!! Creates a new bitset, `new`, from a range, `start_pos` to `stop_pos`, in +!! bitset `old`. If 'start_pos` is greater than `stop_pos` the new bitset is +!! empty. If `start_pos` is less than zero or `stop_pos` is greater than +!! `bits(old)-1` then if `status` is present it has the value +!! `index_invalid_error`and `new` is undefined, otherwise processing stops +!! with an informative message. + type(bitset_64), intent(out) :: new + type(bitset_64), intent(in) :: old + integer(bits_kind), intent(in) :: start_pos, stop_pos + integer, intent(out), optional :: status + end subroutine extract_64 + + end interface extract + + + interface or + + elemental module subroutine or_large(set1, set2) +!! Version: experimental +!! +!! Sets the bits in `set1` to the bitwise `or` of the original bits in `set1` +!! and `set2`. The sets must have the same number of bits otherwise +!! the result is undefined. +!! +!!#### Example +!! +!! ```fortran +!! program demo_or +!! use stdlib_bitsets +!! type(bitset_large) :: set0, set1 +!! call set0 % init(166) +!! call set1 % init(166) +!! call or( set0, set1 ) ! none none +!! if ( none(set0) ) write(*,*) 'First test of OR worked.' +!! call set0 % not() +!! call or( set0, set1 ) ! all none +!! if ( all(set0) ) write(*,*) 'Second test of OR worked.' +!! call set0 % not() +!! call set1 % not() +!! call or( set0, set1 ) ! none all +!! if ( all(set0) ) write(*,*) 'Third test of OR worked.' +!! call set0 % not() +!! call or( set0, set1 ) ! all all +!! if ( all(set0) ) write(*,*) 'Fourth test of OR worked.' +!! end program demo_or +!! + type(bitset_large), intent(inout) :: set1 + type(bitset_large), intent(in) :: set2 + end subroutine or_large + + elemental module subroutine or_64(set1, set2) +!! Version: experimental +!! +!! Sets the bits in `set1` to the bitwise `or` of the original bits in `set1` +!! and `set2`. The sets must have the same number of bits otherwise +!! the result is undefined. + type(bitset_64), intent(inout) :: set1 + type(bitset_64), intent(in) :: set2 + end subroutine or_64 + + end interface or + + + interface xor + + elemental module subroutine xor_large(set1, set2) +!! Version: experimental +!! +!! Sets the bits in `set1` to the bitwise `xor` of the original bits in `set1` +!! and `set2`. The sets must have the same number of bits otherwise +!! the result is undefined. +!! +!!#### Example +!! +!! ```fortran +!! program demo_xor +!! use stdlib_bitsets +!! type(bitset_large) :: set0, set1 +!! call set0 % init(166) +!! call set1 % init(166) +!! call xor( set0, set1 ) ! none none +!! if ( none(set0) ) write(*,*) 'First test of XOR worked.' +!! call set0 % not() +!! call xor( set0, set1 ) ! all none +!! if ( all(set0) ) write(*,*) 'Second test of XOR worked.' +!! call set0 % not() +!! call set1 % not() +!! call xor( set0, set1 ) ! none all +!! if ( all(set0) ) write(*,*) 'Third test of XOR worked.' +!! call set0 % not() +!! call xor( set0, set1 ) ! all all +!! if ( none(set0) ) write(*,*) 'Fourth test of XOR worked.' +!! end program demo_xor +!! + type(bitset_large), intent(inout) :: set1 + type(bitset_large), intent(in) :: set2 + end subroutine xor_large + + elemental module subroutine xor_64(set1, set2) +!! Version: experimental +!! +!! Sets the bits in `set1` to the bitwise `xor` of the original bits in `set1` +!! and `set2`. The sets must have the same number of bits +!! otherwise the result is undefined. + type(bitset_64), intent(inout) :: set1 + type(bitset_64), intent(in) :: set2 + end subroutine xor_64 + + end interface xor + + + interface operator(==) + + elemental module function eqv_large(set1, set2) result(eqv) +!! Version: experimental +!! +!! Returns `.true`. if all bits in `set1` and `set2` have the same value, +!! `.false.` otherwise. The sets must have the same number of bits +!! otherwise the result is undefined. +!! +!!#### Example +!! +!! ```fortran +!! program demo_equality +!! use stdlib_bitsets +!! type(bitset_64) :: set0, set1, set2 +!! call set0 % init( 33 ) +!! call set1 % init( 33 ) +!! call set2 % init( 33 ) +!! call set1 % set( 0 ) +!! call set2 % set( 32 ) +!! if ( set0 == set0 .and. set1 == set1 .and. set2 == set2 .and. & +!! .not. set0 == set1 .and. .not. set0 == set2 .and. .not. & +!! set1 == set2 ) then +!! write(*,*) 'Passed 64 bit equality tests.' +!! else +!! error stop 'Failed 64 bit equality tests.' +!! end if +!! end program demo_equality +!! + logical :: eqv + type(bitset_large), intent(in) :: set1, set2 + end function eqv_large + + elemental module function eqv_64(set1, set2) result(eqv) +!! Version: experimental +!! +!! Returns `.true`. if all bits in `set1` and `set2` have the same value, +!! `.false.` otherwise. The sets must have the same number of bits +!! otherwise the result is undefined. + logical :: eqv + type(bitset_64), intent(in) :: set1, set2 + end function eqv_64 + + end interface operator(==) + + + interface operator(/=) + + elemental module function neqv_large(set1, set2) result(neqv) +!! Version: experimental +!! +!! Returns `.true.` if not all bits in `set1` and `set2` have the same value, +!! `.false.` otherwise. The sets must have the same number of bits +!! otherwise the result is undefined. +!! +!!#### Example +!! +!! ```fortran +!! program demo_inequality +!! use stdlib_bitsets +!! type(bitset_64) :: set0, set1, set2 +!! call set0 % init( 33 ) +!! call set1 % init( 33 ) +!! call set2 % init( 33 ) +!! call set1 % set( 0 ) +!! call set2 % set( 32 ) +!! if ( set0 /= set1 .and. set0 /= set2 .and. set1 /= set2 .and. & +!! .not. set0 /= set0 .and. .not. set1 /= set1 .and. .not. & +!! set2 /= set2 ) then +!! write(*,*) 'Passed 64 bit inequality tests.' +!! else +!! error stop 'Failed 64 bit inequality tests.' +!! end if +!! end program demo_inequality +!! + logical :: neqv + type(bitset_large), intent(in) :: set1, set2 + end function neqv_large + + elemental module function neqv_64(set1, set2) result(neqv) +!! Version: experimental +!! +!! Returns `.true.` if not all bits in `set1` and `set2 have the same value, +!! `.false.` otherwise. The sets must have the same number of bits +!! otherwise the result is undefined. + logical :: neqv + type(bitset_64), intent(in) :: set1, set2 + end function neqv_64 + + end interface operator(/=) + + + interface operator(>) + + elemental module function gt_large(set1, set2) result(gt) +!! Version: experimental +!! +!! Returns `.true.` if the bits in `set1` and `set2` differ and the +!! highest order different bit is set to 1 in `set1` and to 0 in `set2`. +!! `.false.` otherwise. The sets must have the same number of bits +!! otherwise the result is undefined. +!! +!!#### Example +!! +!! ```fortran +!! program demo_gt +!! use stdlib_bitsets +!! type(bitset_64) :: set0, set1, set2 +!! call set0 % init( 33 ) +!! call set1 % init( 33 ) +!! call set2 % init( 33 ) +!! call set1 % set( 0 ) +!! call set2 % set( 32 ) +!! if ( set1 > set0 .and. set2 > set1 .and. set2 > set0 .and. & +!! .not. set0 > set0 .and. .not. set0 > set1 .and. .not. & +!! set1 > set2 ) then +!! write(*,*) 'Passed 64 bit greater than tests.' +!! else +!! error stop 'Failed 64 bit greater than tests.' +!! end if +!! end program demo_gt +!! + logical :: gt + type(bitset_large), intent(in) :: set1, set2 + end function gt_large + + elemental module function gt_64(set1, set2) result(gt) +!! Version: experimental +!! +!! Returns `.true.` if the bits in `set1` and `set2` differ and the +!! highest order different bit is set to 1 in `set1` and to 0 in `set2`. +!! `.false.` otherwise. The sets must have the same number of bits +!! otherwise the result is undefined. + logical :: gt + type(bitset_64), intent(in) :: set1, set2 + end function gt_64 + + end interface operator(>) + + + interface operator(>=) + + elemental module function ge_large(set1, set2) result(ge) +!! Version: experimental +!! +!! Returns `.true.` if the bits in `set1` and `set2` are the same or the +!! highest order different bit is set to 1 in `set1` and to 0 in `set2`. +!! `.false.` otherwise. The sets must have the same number of bits +!! otherwise the result is undefined. +!! +!!#### Example +!! +!! ```fortran +!! program demo_ge +!! use stdlib_bitsets +!! type(bitset_64) :: set0, set1, set2 +!! call set0 % init( 33 ) +!! call set1 % init( 33 ) +!! call set2 % init( 33 ) +!! call set1 % set( 0 ) +!! call set2 % set( 32 ) +!! if ( set1 >= set0 .and. set2 >= set1 .and. set2 >= set0 .and. & +!! set0 >= set0 .and. set1 >= set1 .and. set2 >= set2 .and. & +!! .not. set0 >= set1 .and. .not. set0 >= set2 .and. .not. & +!! set1 >= set2 ) then +!! write(*,*) 'Passed 64 bit greater than or equals tests.' +!! else +!! error stop 'Failed 64 bit greater than or equals tests.' +!! end if +!! end program demo_ge +!! + logical :: ge + type(bitset_large), intent(in) :: set1, set2 + end function ge_large + + elemental module function ge_64(set1, set2) result(ge) +!! Version: experimental +!! +!! Returns `.true.` if the bits in `set1` and `set2` are the same or the +!! highest order different bit is set to 1 in `set1` and to 0 in `set2`. +!! `.false.` otherwise. The sets must have the same number of bits +!! otherwise the result is undefined. + logical :: ge + type(bitset_64), intent(in) :: set1, set2 + end function ge_64 + + end interface operator(>=) + + + interface operator(<) + + elemental module function lt_large(set1, set2) result(lt) +!! Version: experimental +!! +!! Returns `.true.` if the bits in `set1` and `set2` differ and the +!! highest order different bit is set to 0 in `set1` and to 1 in `set2`. +!! `.false.` otherwise. The sets must have the same number of bits +!! otherwise the result is undefined. +!! +!!#### Example +!! +!! ```fortran +!! program demo_lt +!! use stdlib_bitsets +!! type(bitset_64) :: set0, set1, set2 +!! call set0 % init( 33 ) +!! call set1 % init( 33 ) +!! call set2 % init( 33 ) +!! call set1 % set( 0 ) +!! call set2 % set( 32 ) +!! if ( set0 < set1 .and. set1 < set2 .and. set0 < set2 .and. & +!! .not. set0 < set0 .and. .not. set2 < set0 .and. .not. & +!! set2 < set1 ) then +!! write(*,*) 'Passed 64 bit less than tests.' +!! else +!! error stop 'Failed 64 bit less than tests.' +!! end if +!! end program demo_lt +!! + logical :: lt + type(bitset_large), intent(in) :: set1, set2 + end function lt_large + + elemental module function lt_64(set1, set2) result(lt) +!! Version: experimental +!! +!! Returns `.true.` if the bits in `set1` and `set2` differ and the +!! highest order different bit is set to 0 in `set1` and to 1 in `set2`. +!! `.false.` otherwise. The sets must have the same number of bits +!! otherwise the result is undefined. + logical :: lt + type(bitset_64), intent(in) :: set1, set2 + end function lt_64 + + end interface operator(<) + + + interface operator(<=) + + elemental module function le_large(set1, set2) result(le) +!! Version: experimental +!! +!! Returns `.true.` if the bits in `set1` and `set2` are the same or the +!! highest order different bit is set to 0 in `set1` and to 1 in `set2`. +!! `.false.` otherwise. The sets must have the same number of bits +!! otherwise the result is undefined. +!! +!!#### Example +!! +!! ```fortran +!! program demo_le +!! use stdlib_bitsets +!! type(bitset_64) :: set0, set1, set2 +!! call set0 % init( 33 ) +!! call set1 % init( 33 ) +!! call set2 % init( 33 ) +!! call set1 % set( 0 ) +!! call set2 % set( 32 ) +!! if ( set0 <= set1 .and. set1 <= set2 .and. set0 <= set2 .and. & +!! set0 <= set0 .and. set1 <= set1 .and. set2 <= set2 .and. & +!! .not. set1 <= set0 .and. .not. set2 <= set0 .and. .not. & +!! set2 <= set1 ) then +!! write(*,*) 'Passed 64 bit less than or equal tests.' +!! else +!! error stop 'Failed 64 bit less than or equal tests.' +!! end if +!! end program demo_le +!! + logical :: le + type(bitset_large), intent(in) :: set1, set2 + end function le_large + + elemental module function le_64(set1, set2) result(le) +!! Version: experimental +!! +!! Returns `.true.` if the bits in `set1` and `set2` are the same or the +!! highest order different bit is set to 0 in `set1` and to 1 in `set2`. +!! `.false.` otherwise. The sets must have the same number of bits +!! otherwise the result is undefined. + logical :: le + type(bitset_64), intent(in) :: set1, set2 + end function le_64 + + end interface operator(<=) + +contains + + elemental function bits(self) +!! Version: experimental +!! +!! Returns the number of bit positions in `self`. + integer(bits_kind) :: bits + class(bitset_type), intent(in) :: self + + bits = self % num_bits + + return + end function bits + + +end module stdlib_bitsets From 2833ffa244c9a4aa3d52235f9490ce793b87f508 Mon Sep 17 00:00:00 2001 From: William Clodius Date: Wed, 7 Oct 2020 18:44:43 -0600 Subject: [PATCH 13/53] Removed files now generated by the preprocessor Removed stdlib_bitsets.f90, stdlib_bitset_64.f90, and stdlib_bitset_large.f90 as they are now generated by the preprocessor. [ticket: X] --- src/stdlib_bitset_64.f90 | 1326 ---------------------- src/stdlib_bitset_large.f90 | 1564 -------------------------- src/stdlib_bitsets.f90 | 2124 ----------------------------------- 3 files changed, 5014 deletions(-) delete mode 100644 src/stdlib_bitset_64.f90 delete mode 100644 src/stdlib_bitset_large.f90 delete mode 100644 src/stdlib_bitsets.f90 diff --git a/src/stdlib_bitset_64.f90 b/src/stdlib_bitset_64.f90 deleted file mode 100644 index bebce9bde..000000000 --- a/src/stdlib_bitset_64.f90 +++ /dev/null @@ -1,1326 +0,0 @@ -submodule(stdlib_bitsets) stdlib_bitset_64 - implicit none - -contains - - elemental module function all_64( self ) result(all) -! Returns .TRUE. if all bits in SELF are 1, .FALSE. otherwise. - logical :: all - class(bitset_64), intent(in) :: self - - intrinsic :: btest - integer(bits_kind) :: pos - - do pos=0, self % num_bits - 1 - if ( .not. btest(self % block, pos) ) then - all = .false. - return - end if - end do - all = .true. - - end function all_64 - - - elemental module subroutine and_64(set1, set2) -! -! Sets the bits in SET1 to the bitwise AND of the original bits in SET1 -! and SET2. It is required that SET1 have the same number of bits as -! SET2 otherwise the result is undefined. -! - type(bitset_64), intent(inout) :: set1 - type(bitset_64), intent(in) :: set2 - -! The set2 extent includes the entire extent of set1. -! The (zeroed) region past the end of set1 is unaffected by -! the iand. - set1 % block = iand( set1 % block, & - set2 % block ) - - end subroutine and_64 - - - elemental module subroutine and_not_64(set1, set2) -! -! Sets the bits in SET1 to the bitwise and of the original bits in SET1 -! with the bitwise negation of SET2. SET1 and SET2 must have the same -! number of bits otherwise the result is undefined. -! - type(bitset_64), intent(inout) :: set1 - type(bitset_64), intent(in) :: set2 - -! The not with iand means that the zero'ed regions past the end of each set -! do not interact with the in set regions - set1 % block = iand( set1 % block, not( set2 % block ) ) - - end subroutine and_not_64 - - - elemental module function any_64(self) result(any) -! Returns .TRUE. if any bit in SELF is 1, .FALSE. otherwise. - logical :: any - class(bitset_64), intent(in) :: self - - if ( self % block /= 0 ) then - any = .true. - return - else - any = .false. - end if - - end function any_64 - - - pure module subroutine assign_64( set1, set2 ) -! Used to define assignment for bitset_64 - type(bitset_64), intent(out) :: set1 - type(bitset_64), intent(in) :: set2 - - set1 % num_bits = set2 % num_bits - set1 % block = set2 % block - - end subroutine assign_64 - - - module subroutine assign_logint8_64( self, logical_vector ) -! Used to define assignment from an array of type logical for bitset_64 - type(bitset_64), intent(out) :: self - logical(int8), intent(in) :: logical_vector(:) - - integer(bits_kind) :: log_size - integer(bits_kind) :: index - - log_size = size( logical_vector, kind=bits_kind ) - if ( log_size > 64 ) then - error stop module_name // ' % ' // 'ASSIGNMENT' // " has " // & - "SIZE(LOGICAL_VECTOR) > 64 with assignment to a BITSET_64." - end if - self % num_bits = log_size - self % block = 0 - - do index=0, log_size-1 - if ( logical_vector(index+1) ) then - self % block = ibset( self % block, index ) - end if - end do - - end subroutine assign_logint8_64 - - - pure module subroutine logint8_assign_64( logical_vector, set ) -! Used to define assignment to an array of type logical for bitset_64 - logical(int8), intent(out), allocatable :: logical_vector(:) - type(bitset_64), intent(in) :: set - - integer(bits_kind) :: index - - allocate( logical_vector( set % num_bits ) ) - do index=0, set % num_bits-1 - if ( set % value( index ) == 1 ) then - logical_vector(index+1) = .true. - else - logical_vector(index+1) = .false. - end if - end do - - end subroutine logint8_assign_64 - module subroutine assign_logint16_64( self, logical_vector ) -! Used to define assignment from an array of type logical for bitset_64 - type(bitset_64), intent(out) :: self - logical(int16), intent(in) :: logical_vector(:) - - integer(bits_kind) :: log_size - integer(bits_kind) :: index - - log_size = size( logical_vector, kind=bits_kind ) - if ( log_size > 64 ) then - error stop module_name // ' % ' // 'ASSIGNMENT' // " has " // & - "SIZE(LOGICAL_VECTOR) > 64 with assignment to a BITSET_64." - end if - self % num_bits = log_size - self % block = 0 - - do index=0, log_size-1 - if ( logical_vector(index+1) ) then - self % block = ibset( self % block, index ) - end if - end do - - end subroutine assign_logint16_64 - - - pure module subroutine logint16_assign_64( logical_vector, set ) -! Used to define assignment to an array of type logical for bitset_64 - logical(int16), intent(out), allocatable :: logical_vector(:) - type(bitset_64), intent(in) :: set - - integer(bits_kind) :: index - - allocate( logical_vector( set % num_bits ) ) - do index=0, set % num_bits-1 - if ( set % value( index ) == 1 ) then - logical_vector(index+1) = .true. - else - logical_vector(index+1) = .false. - end if - end do - - end subroutine logint16_assign_64 - module subroutine assign_logint32_64( self, logical_vector ) -! Used to define assignment from an array of type logical for bitset_64 - type(bitset_64), intent(out) :: self - logical(int32), intent(in) :: logical_vector(:) - - integer(bits_kind) :: log_size - integer(bits_kind) :: index - - log_size = size( logical_vector, kind=bits_kind ) - if ( log_size > 64 ) then - error stop module_name // ' % ' // 'ASSIGNMENT' // " has " // & - "SIZE(LOGICAL_VECTOR) > 64 with assignment to a BITSET_64." - end if - self % num_bits = log_size - self % block = 0 - - do index=0, log_size-1 - if ( logical_vector(index+1) ) then - self % block = ibset( self % block, index ) - end if - end do - - end subroutine assign_logint32_64 - - - pure module subroutine logint32_assign_64( logical_vector, set ) -! Used to define assignment to an array of type logical for bitset_64 - logical(int32), intent(out), allocatable :: logical_vector(:) - type(bitset_64), intent(in) :: set - - integer(bits_kind) :: index - - allocate( logical_vector( set % num_bits ) ) - do index=0, set % num_bits-1 - if ( set % value( index ) == 1 ) then - logical_vector(index+1) = .true. - else - logical_vector(index+1) = .false. - end if - end do - - end subroutine logint32_assign_64 - module subroutine assign_logint64_64( self, logical_vector ) -! Used to define assignment from an array of type logical for bitset_64 - type(bitset_64), intent(out) :: self - logical(int64), intent(in) :: logical_vector(:) - - integer(bits_kind) :: log_size - integer(bits_kind) :: index - - log_size = size( logical_vector, kind=bits_kind ) - if ( log_size > 64 ) then - error stop module_name // ' % ' // 'ASSIGNMENT' // " has " // & - "SIZE(LOGICAL_VECTOR) > 64 with assignment to a BITSET_64." - end if - self % num_bits = log_size - self % block = 0 - - do index=0, log_size-1 - if ( logical_vector(index+1) ) then - self % block = ibset( self % block, index ) - end if - end do - - end subroutine assign_logint64_64 - - - pure module subroutine logint64_assign_64( logical_vector, set ) -! Used to define assignment to an array of type logical for bitset_64 - logical(int64), intent(out), allocatable :: logical_vector(:) - type(bitset_64), intent(in) :: set - - integer(bits_kind) :: index - - allocate( logical_vector( set % num_bits ) ) - do index=0, set % num_bits-1 - if ( set % value( index ) == 1 ) then - logical_vector(index+1) = .true. - else - logical_vector(index+1) = .false. - end if - end do - - end subroutine logint64_assign_64 - - - elemental module function bit_count_64(self) result(bit_count) -! Returns the number of non-zero bits in SELF. - integer(bits_kind) :: bit_count - class(bitset_64), intent(in) :: self - - integer(bits_kind) :: pos - - bit_count = 0 - - do pos = 0, self % num_bits - 1 - if ( btest( self % block, pos ) ) bit_count = bit_count + 1 - end do - - end function bit_count_64 - - - elemental module subroutine clear_bit_64(self, pos) -! -! Sets to zero the POS position in SELF. If POS is less than zero or -! greater than BITS(SELF)-1 it is ignored. -! - class(bitset_64), intent(inout) :: self - integer(bits_kind), intent(in) :: pos - - if ( pos < 0 .OR. (pos > self % num_bits-1) ) & - return - self % block = ibclr( self % block, pos ) - - end subroutine clear_bit_64 - - - pure module subroutine clear_range_64(self, start_pos, stop_pos) -! -! Sets to zero all bits from the START_POS to STOP_POS positions in SELF. -! If STOP_POS < START_POS then no bits are modified. Positions outside -! the range 0 to BITS(SELF)-1 are ignored. -! - class(bitset_64), intent(inout) :: self - integer(bits_kind), intent(in) :: start_pos, stop_pos - - integer(bits_kind) :: true_first, true_last - - true_first = max( 0, start_pos ) - true_last = min( self % num_bits-1, stop_pos ) - if ( true_last < true_first ) return - - call mvbits( all_zeros, & - true_first, & - true_last - true_first + 1, & - self % block, & - true_first ) - - end subroutine clear_range_64 - - - elemental module function eqv_64(set1, set2) result(eqv) -! -! Returns .TRUE. if all bits in SET1 and SET2 have the same value, -! .FALSE. otherwise. The sets must have the same number of bits -! otherwise the results are undefined. -! - logical :: eqv - type(bitset_64), intent(in) :: set1, set2 - - eqv = set1 % block == set2 % block - - end function eqv_64 - - - module subroutine extract_64(new, old, start_pos, stop_pos, status) -! Creates a new bitset, NEW, from a range, START_POS to STOP_POS, in bitset -! OLD. If START_POS is greater than STOP_POS the new bitset is empty. -! If START_POS is less than zero or STOP_POS is greater than BITS(OLD)-1 -! then if STATUS is present it has the value INDEX_INVALID_ERROR, -! otherwise processing stops with an informative message. - type(bitset_64), intent(out) :: new - type(bitset_64), intent(in) :: old - integer(bits_kind), intent(in) :: start_pos, stop_pos - integer, intent(out), optional :: status - - integer(bits_kind) :: bits, i, k - character(*), parameter :: procedure = 'EXTRACT' - - if ( start_pos < 0 ) go to 999 - if ( stop_pos >= old % num_bits ) go to 998 - bits = stop_pos - start_pos + 1 - - if ( bits <= 0 ) then - new % num_bits = 0 - new % block = 0 - return - else - new % num_bits = bits - do i=0, bits-1 - k = start_pos + i - if ( btest( old % block, k ) ) & - new % block = ibset(new % block, i) - end do - end if - - if ( present(status) ) status = success - - return - -998 if ( present(status) ) then - status = index_invalid_error - return - else - error stop module_name // ' % ' // procedure // ' had a ' // & - 'STOP_POS greater than BITS(OLD)-1.' - end if - -999 if ( present(status) ) then - status = index_invalid_error - return - else - error stop module_name // ' % ' // procedure // ' had a ' // & - 'START_POS less than 0.' - end if - - end subroutine extract_64 - - - elemental module subroutine flip_bit_64(self, pos) -! -! Flips the value at the POS position in SELF, provided the position is -! valid. If POS is less than 0 or greater than BITS(SELF)-1, no value is -! changed. -! - class(bitset_64), intent(inout) :: self - integer(bits_kind), intent(in) :: pos - - if ( pos < 0 .OR. pos > self % num_bits-1 ) return - - if ( btest( self % block, pos ) ) then - self % block = ibclr( self % block, pos ) - else - self % block = ibset( self % block, pos ) - end if - - end subroutine flip_bit_64 - - - pure module subroutine flip_range_64(self, start_pos, stop_pos) -! -! Flips all valid bits from the START_POS to the STOP_POS positions in -! SELF. If STOP_POS < START_POS no bits are flipped. Positions less than -! 0 or greater than BITS(SELF)-1 are ignored. -! - class(bitset_64), intent(inout) :: self - integer(bits_kind), intent(in) :: start_pos, stop_pos - - integer(bits_kind) :: end_bit, start_bit - - start_bit = max( 0, start_pos ) - end_bit = min( stop_pos , self % num_bits-1 ) - call mvbits( not(self % block), & - start_bit, & - end_bit - start_bit + 1, & - self % block, & - start_bit ) - - end subroutine flip_range_64 - - - module subroutine from_string_64(self, string, status) -! Initializes the bitset SELF treating STRING as a binary literal -! STATUS may have the values SUCCESS, ALLOC_FAULT, -! ARRAY_SIZE_INVALID_ERROR, or CHAR_STRING_INVALID. - class(bitset_64), intent(out) :: self - character(*), intent(in) :: string - integer, intent(out), optional :: status - - character(*), parameter :: procedure = 'FROM_STRING' - integer(bits_kind) :: bit - integer(int64) :: bits - character(1) :: char - - bits = len(string, kind=int64) - if ( bits > 64 ) go to 998 - self % num_bits = bits - do bit = 1, bits - char = string(bit:bit) - if ( char == '0' ) then - call self % clear( int(bits, kind=bits_kind)-bit ) - else if ( char == '1' ) then - call self % set( int(bits, kind=bits_kind)-bit ) - else - go to 999 - end if - end do - - if ( present(status) ) status = success - - return - -998 if ( present(status) ) then - status = array_size_invalid_error - return - else - error stop module_name // ' % ' // procedure // ' STRING ' // & - 'was too long for a BITSET_64 SELF.' - end if - -999 if ( present(status) ) then - status = char_string_invalid_error - return - else - error stop module_name // ' % ' // procedure // ' STRING ' // & - 'had a character other than "0" or "1",' - end if - - end subroutine from_string_64 - - - elemental module function ge_64(set1, set2) result(ge) -! -! Returns .TRUE. if the bits in SET1 and SET2 are the same or the -! highest order different bit is set to 1 in SET1 and to 0 in set2. -! .FALSE. otherwise. The sets must have the same number of bits -! otherwise the results are undefined. -! - logical :: ge - type(bitset_64), intent(in) :: set1, set2 - - ge = bge( set1 % block, set2 % block ) - - end function ge_64 - - - elemental module function gt_64(set1, set2) result(gt) -! -! Returns .TRUE. if the bits in SET1 and SET2 differ and the -! highest order different bit is set to 1 in SET1 and to 0 in set2. -! .FALSE. otherwise. The sets must have the same number of bits -! otherwise the results are undefined. -! - logical :: gt - type(bitset_64), intent(in) :: set1, set2 - - gt = bgt( set1 % block, set2 % block ) - - end function gt_64 - - - module subroutine init_zero_64(self, bits, status) -! -! Creates the bitset, SELF, of size BITS, with all bits initialized to -! zero. BITS must be non-negative. If an error occurs and STATUS is -! absent then processing stops with an informative stop code. STATUS -! has a default value of SUCCESS. If an error occurs it has the value -! ARRAY_SIZE_INVALID_ERROR if BITS is either negative larger than 64 -! if SELF is of type BITSET_64, or the value ALLOC_FAULT if it failed -! during allocation of memory for SELF. -! - class(bitset_64), intent(out) :: self - integer(bits_kind), intent(in) :: bits - integer, intent(out), optional :: status - - character(*), parameter :: procedure = "INIT" - - if ( bits < 0 .or. bits > 64 ) go to 999 - - self % num_bits = bits - self % block = all_zeros - - if ( present(status) ) status = success - - return - -999 if ( present(status) ) then - status = array_size_invalid_error - return - else - if ( bits < 0 ) then - error stop module_name // ' %' // procedure // ' BITS had ' // & - 'a negative value.' - else - error stop module_name // ' %' // procedure // ' BITS had ' // & - 'a value greater than 64.' - end if - end if - - end subroutine init_zero_64 - - - module subroutine input_64(self, unit, status) -! -! Reads the components of the bitset, SELF, from the unformatted I/O -! unit, UNIT, assuming that the components were written using OUTPUT. -! If an error occurs and STATUS is absent then processing stops with -! an informative stop code. STATUS has a default value of SUCCESS. -! If an error occurs it has the value READ_FAILURE if it failed -! during the reads from UNIT or the value ALLOC_FAULT if it failed -! during allocation of memory for SELF, or the value -! ARRAY_SIZE_INVALID_ERROR if the BITS(SELF) in UNIT is less than 0 -! or greater than 64 for a BITSET_64 input. -! - class(bitset_64), intent(out) :: self - integer, intent(in) :: unit - integer, intent(out), optional :: status - - integer(bits_kind) :: bits - integer :: ierr - character(len=120) :: message - character(*), parameter :: procedure = 'INPUT' - integer :: stat - - read(unit, iostat=ierr, iomsg=message) bits - if (ierr /= 0) go to 999 - if ( bits < 0 .or. bits > 64 ) go to 998 - - call self % init(bits, stat) - if (stat /= success) go to 998 - - if (bits < 1) return - - read(unit, iostat=ierr, iomsg=message) self % block - if (ierr /= 0) go to 999 - - if ( present(status) ) status = success - - return - -998 if ( present(status) ) then - status = array_size_invalid_error - return - else - if ( bits < 0 ) then - error stop module_name // ' %' // procedure // ' BITS in ' // & - 'UNIT had a negative value.' - else - error stop module_name // ' %' // procedure // ' BITS in ' // & - 'UNIT had a value greater than 64.' - end if - end if - -999 if ( present(status) ) then - status = read_failure - return - else - error stop module_name // ' % ' // procedure // ' had a ' // & - 'failure on a READ statement for UNIT.' - end if - - end subroutine input_64 - - - elemental module function le_64(set1, set2) result(le) -! -! Returns .TRUE. if the bits in SET1 and SET2 are the same or the -! highest order different bit is set to 0 in SET1 and to 1 in set2. -! .FALSE. otherwise. The sets must have the same number of bits -! otherwise the results are undefined. -! - logical :: le - type(bitset_64), intent(in) :: set1, set2 - - le = ble( set1 % block, set2 % block ) - - end function le_64 - - - elemental module function lt_64(set1, set2) result(lt) -! -! Returns .TRUE. if the bits in SET1 and SET2 differ and the -! highest order different bit is set to 0 in SET1 and to 1 in set2. -! .FALSE. otherwise. The sets must have the same number of bits -! otherwise the results are undefined. -! - logical :: lt - type(bitset_64), intent(in) :: set1, set2 - - lt = blt( set1 % block, set2 % block ) - - end function lt_64 - - - elemental module function neqv_64(set1, set2) result(neqv) -! -! Returns .TRUE. if all bits in SET1 and SET2 have the same value, -! .FALSE. otherwise. The sets must have the same number of bits -! otherwise the results are undefined. -! - logical :: neqv - type(bitset_64), intent(in) :: set1, set2 - - neqv = set1 % block /= set2 % block - - end function neqv_64 - - - elemental module function none_64(self) result(none) -! -! Returns .TRUE. if none of the bits in SELF have the value 1. -! - logical :: none - class(bitset_64), intent(in) :: self - - none = .true. - if (self % block /= 0) then - none = .false. - return - end if - - end function none_64 - - - elemental module subroutine not_64(self) -! -! Sets the bits in SELF to their logical complement -! - class(bitset_64), intent(inout) :: self - - integer(bits_kind) :: bit - - if ( self % num_bits == 0 ) return - - do bit=0, self % num_bits - 1 - if ( btest( self % block, bit ) ) then - self % block = ibclr( self % block, bit ) - else - self % block = ibset( self % block, bit ) - end if - end do - - end subroutine not_64 - - - elemental module subroutine or_64(set1, set2) -! -! Sets the bits in SET1 to the bitwise OR of the original bits in SET1 -! and SET2. If SET1 has fewer bits than SET2 then the additional bits -! in SET2 are ignored. If SET1 has more bits than SET2, then the -! absent SET2 bits are treated as if present with zero value. -! - type(bitset_64), intent(inout) :: set1 - type(bitset_64), intent(in) :: set2 - - if ( set1 % num_bits >= set2 % num_bits ) then - set1 % block = ior( set1 % block, & - set2 % block ) - else -! The set1 extent ends before set2 => set2 bits must not affect bits in -! set1 beyond its extent => set those bits to zero while keeping proper -! values of other bits in set2 - set1 % block = & - ior( set1 % block, & - ibits( set2 % block, & - 0, & - set1 % num_bits ) ) - end if - - end subroutine or_64 - - - module subroutine output_64(self, unit, status) -! -! Writes the components of the bitset, SELF, to the unformatted I/O -! unit, UNIT, in a unformatted sequence compatible with INPUT. If -! STATUS is absent an error results in an error stop with an -! informative stop code. If STATUS is present it has the default -! value of SUCCESS, or the value WRITE_FAILURE if the write failed. -! - class(bitset_64), intent(in) :: self - integer, intent(in) :: unit - integer, intent(out), optional :: status - - integer :: ierr - character(len=120) :: message - character(*), parameter :: procedure = "OUTPUT" - - write(unit, iostat=ierr, iomsg=message) self % num_bits - if (ierr /= 0) go to 999 - - if (self % num_bits < 1) return - write(unit, iostat=ierr, iomsg=message) self % block - if (ierr /= 0) go to 999 - - return - -999 if ( present(status) ) then - status = write_failure - return - else - error stop module_name // ' % ' // procedure // ' had a ' // & - 'failure in the write to UNIT.' - end if - - end subroutine output_64 - - - module subroutine read_bitset_string_64(self, string, status) -! -! Uses the bitset literal in the default character STRING, to define -! the bitset, SELF. The literal may be preceded by an an arbitrary -! sequence of blank characters. If STATUS is absent an error results -! in an error stop with an informative stop code. If STATUS -! is present it has the default value of SUCCESS, the value -! INTEGER_OVERFLOW_ERROR if the bitset literal has a BITS(SELF) value -! too large to be represented, the value ALLOC_FAULT if allocation of -! memory for SELF failed, or CHAR_STRING_INVALID_ERROR if the bitset -! literal has an invalid character, or ARRAY_SIZE_INVALID_ERROR if -! BITS(SELF) in STRING is greater than 64 for a BITSET_64, or -! CHAR_STRING_TOO_SMALL_ERROR if the string ends before all the bits -! are read. -! - class(bitset_64), intent(out) :: self - character(len=*), intent(in) :: string - integer, intent(out), optional :: status - - integer(bits_kind) :: bit, bits - integer(bits_kind) :: digits, pos - character(*), parameter :: procedure = "READ_BITSET" - integer :: stat - - pos = 1 - find_start: do pos=1, len(string) - if ( string(pos:pos) /= ' ' ) exit - end do find_start - - if ( pos > len(string) - 8 ) go to 999 - - if ( string(pos:pos) /= 's' .AND. string(pos:pos) /= 'S' ) go to 999 - - pos = pos + 1 - bits = 0 - digits = 0 - - do - select case( iachar( string(pos:pos) ) ) - case(ia0:ia9) - digits = digits + 1 - if ( digits == 10 .AND. bits > 2_bits_kind**30/5 ) go to 996 -!! May not be quite right - if ( digits > 10 ) go to 996 - bits = bits*10 + iachar( string(pos:pos) ) - ia0 - if ( bits < 0 ) go to 996 - case(iachar('b'), iachar('B')) - go to 100 - case default - go to 999 - end select - - pos = pos + 1 - - end do - -100 if ( bits > 64 ) go to 995 - if ( bits + pos > len(string) ) go to 994 - call self % init( bits, stat ) - if (stat /= success) go to 998 - - pos = pos + 1 - bit = bits - 1 - do - if ( string(pos:pos) == '0' ) then - call self % clear( bit ) ! this may not be needed - else if ( string(pos:pos) == '1' ) then - call self % set( bit ) - else - go to 999 - end if - pos = pos + 1 - bit = bit - 1 - if ( bit < 0 ) exit - end do - - if ( present(status) ) status = success - - return - -994 if ( present(status) ) then - status = char_string_too_small_error - return - else - error stop module_name // ' % ' // procedure // ' STRING ' // & - 'was too small for the BITS specified by the STRING.' - end if - -995 if ( present(status) ) then - status = array_size_invalid_error - return - else - error stop module_name // ' %' // procedure // ' BITS in ' // & - 'STRING had a value greater than 64.' - end if - - -996 if ( present(status) ) then - status = integer_overflow_error - return - else - error stop module_name // ' % ' // procedure // ' failed on ' // & - 'integer overflow in reading size of bitset literal from ' // & - 'UNIT.' - end if - -998 if ( present(status) ) then - status = alloc_fault - return - else - error stop module_name // ' % ' // procedure // ' failed in ' // & - 'allocating memory for the bitset.' - end if - -999 if ( present(status) ) then - status = char_string_invalid_error - return - else - error stop module_name // ' % ' // procedure // ' failed due ' // & - 'to an invalid character in STRING.' - end if - - end subroutine read_bitset_string_64 - - - module subroutine read_bitset_unit_64(self, unit, advance, status) -! -! - class(bitset_64), intent(out) :: self - integer, intent(in) :: unit - character(*), intent(in), optional :: advance - integer, intent(out), optional :: status - - integer(bits_kind) :: bit, bits, digits - integer :: ierr - character(len=128) :: message - character(*), parameter :: procedure = "READ_BITSET" - character(len=1) :: char - - do - read( unit, & - advance='NO', & - FMT='(A1)', & - err=997, & - end=998, & - iostat=ierr, & - iomsg=message ) char - select case( char ) - case( ' ' ) - cycle - case( 's', 'S' ) - exit - case default - go to 999 - end select - end do - - bits = 0 - digits = 0 - do - read( unit, & - advance='NO', & - FMT='(A1)', & - err=998, & - end=999, & - iostat=ierr, & - iomsg=message ) char - if ( char == 'b' .or. char == 'B' ) exit - select case( char ) - case( '0', '1', '2', '3', '4', '5', '6', '7', '8', '9' ) - digits = digits + 1 - if ( digits == 10 .AND. bits > 2_bits_kind**30/5 ) go to 996 -!! May not be quite right - if ( digits > 10 ) go to 996 - bits = 10*bits + iachar(char) - iachar('0') - if ( bits < 0 ) go to 996 - case default - go to 999 - end select - end do - - if ( bits < 0 .OR. digits == 0 .OR. digits > 10 ) go to 999 - - if ( bits > 64 ) go to 995 - call self % init( bits ) - do bit = 1, bits-1 - read( unit, & - advance='NO', & - FMT='(A1)', & - err=997, & - end=998, & - iostat=ierr, & - iomsg=message ) char - if ( char == '0' ) then - call self % clear( bits-bit ) - else if ( char == '1' ) then - call self % set( bits-bit ) - else - go to 999 - end if - end do - - if ( present(advance) ) then - read( unit, & - advance=advance, & - FMT='(A1)', & - err=997, & - end=998, & - iostat=ierr, & - iomsg=message ) char - - else - read( unit, & - advance='YES', & - FMT='(A1)', & - err=997, & - end=998, & - iostat=ierr, & - iomsg=message ) char - - end if - if ( char == '0' ) then - call self % clear( bits-bit ) - else if ( char == '1' ) then - call self % set( bits-bit ) - else - go to 999 - end if - - if ( present(status) ) status = success - - return - -995 if ( present(status) ) then - status = array_size_invalid_error - return - else - error stop module_name // ' %' // procedure // ' BITS in ' // & - 'STRING had a value greater than 64.' - end if - -996 if ( present(status) ) then - status = integer_overflow_error - return - else - error stop module_name // ' % ' // procedure // ' failed on ' // & - 'integer overflow in reading size of bitset literal from ' // & - 'UNIT.' - end if - -997 if ( present(status) ) then - status = read_failure - return - else - error stop module_name // ' % ' // procedure // ' failed on ' // & - 'read of UNIT.' - end if - -998 if ( present(status) ) then - status = eof_failure - return - else - error stop module_name // ' % ' // procedure // ' reached ' // & - 'End of File of UNIT before finding a bitset literal.' - end if - -999 if ( present(status) ) then - status = char_string_invalid_error - return - else - error stop module_name // ' % ' // procedure // ' found an ' // & - 'invalid bitset literal in UNIT.' - end if - - end subroutine read_bitset_unit_64 - - - elemental module subroutine set_bit_64(self, pos) -! -! Sets the value at the POS position in SELF, provided the position is -! valid. If the position is less than 0 or greater than BITS(SELF)-1 -! then SELF is unchanged. -! - class(bitset_64), intent(inout) :: self - integer(bits_kind), intent(in) :: pos - - if ( pos < 0 .OR. pos > self % num_bits-1 ) return - self % block = ibset( self % block, pos ) - - end subroutine set_bit_64 - - - pure module subroutine set_range_64(self, start_pos, stop_pos) -! -! Sets all valid bits to 1 from the START_POS to the STOP_POS positions -! in SELF. If STOP_POA < START_POS no bits are changed. Positions outside -! the range 0 to BITS(SELF)-1 are ignored. -! - class(bitset_64), intent(inout) :: self - integer(bits_kind), intent(in) :: start_pos, stop_pos - - integer(bits_kind) :: end_bit, start_bit - - start_bit = max( 0, start_pos ) - end_bit = min( stop_pos, self % num_bits-1 ) - if ( end_bit < start_bit ) return - -! FIRST and LAST are in the same block - call mvbits( all_ones, & - start_bit, & - end_bit - start_bit + 1, & - self % block, & - start_bit ) - - end subroutine set_range_64 - - - elemental module function test_64(self, pos) result(test) -! -! Returns .TRUE. if the POS position is set, .FALSE. otherwise. If POS -! is negative or greater than BITS(SELF) - 1 the result is .FALSE.. -! - logical :: test - class(bitset_64), intent(in) :: self - integer(bits_kind), intent(in) :: pos - - if ( pos < 0 .or. pos >= self % num_bits ) then - test = .false. - else - test = btest( self % block, pos ) - end if - - end function test_64 - - - module subroutine to_string_64(self, string, status) -! -! Represents the value of SELF as a binary literal in STRING -! Status may have the values SUCCESS or ALLOC_FAULT -! - class(bitset_64), intent(in) :: self - character(len=:), allocatable, intent(out) :: string - integer, intent(out), optional :: status - - character(*), parameter :: procedure = 'TO_STRING' - integer :: bit, bit_count, pos, stat - - bit_count = self % num_bits - allocate( character(len=bit_count)::string, stat=stat ) - if ( stat > 0 ) go to 999 - - do bit=0, bit_count-1 - pos = bit_count - bit - if ( btest( self % block, bit ) ) then - string( pos:pos ) = '1' - else - string( pos:pos ) = '0' - end if - end do - - if ( present(status) ) status = success - - return - -999 if ( present(status) ) then - status = alloc_fault - return - - else - error stop module_name // ' % ' // procedure // ' allocation ' // & - 'of STRING failed.' - - end if - - end subroutine to_string_64 - - - elemental module function value_64(self, pos) result(value) -! -! Returns 1 if the POS position is set, 0 otherwise. If POS is negative -! or greater than BITS(SELF) - 1 the result is 0. -! - integer :: value - class(bitset_64), intent(in) :: self - integer(bits_kind), intent(in) :: pos - - if ( pos < 0 .or. pos >= self % num_bits ) then - value = 0 - - else - if ( btest( self % block, pos ) ) then - value = 1 - - else - value = 0 - - end if - - end if - - end function value_64 - - - module subroutine write_bitset_string_64(self, string, status) -! -! Writes a bitset literal to the allocatable default character STRING, -! representing the individual bit values in the bitset_t, SELF. -! If STATUS is absent an error results in an error stop with an -! informative stop code. If STATUS is present it has the default -! value of SUCCESS, or the value ALLOC_FAULT if allocation of -! the output string failed. -! - class(bitset_64), intent(in) :: self - character(len=:), allocatable, intent(out) :: string - integer, intent(out), optional :: status - - integer(bits_kind) :: bit, & - bit_count, & - count_digits, & - pos - integer :: stat - - character(*), parameter :: procedure = 'WRITE_BITSET' - - bit_count = bits(self) - - call digit_count( self % num_bits, count_digits ) - - allocate( character(len=count_digits+bit_count+2)::string, stat=stat ) - if ( stat > 0 ) go to 999 - - write( string, "('S', i0)" ) self % num_bits - - string( count_digits + 2:count_digits + 2 ) = "B" - do bit=0, bit_count-1 - pos = count_digits + 2 + bit_count - bit - if ( btest( self % block, bit ) ) then - string( pos:pos ) = '1' - else - string( pos:pos ) = '0' - end if - end do - - if ( present(status) ) status = success - - return - -999 if ( present(status) ) then - status = alloc_fault - return - - else - error stop module_name // ' % ' // procedure // ' had a ' // & - 'memory sllocation failure for a string.' - - end if - - contains - - subroutine digit_count( bits, digits ) - integer(bits_kind), intent(in) :: bits - integer(bits_kind), intent(out) :: digits - - select case ( bits ) - case ( 0:9 ) - digits = 1 - - case ( 10:99 ) - digits = 2 - - case ( 100:999 ) - digits = 3 - - case ( 1000:9999 ) - digits = 4 - - case ( 10000:99999 ) - digits = 5 - - case ( 100000:999999 ) - digits = 6 - - case ( 1000000:9999999 ) - digits = 7 - - case ( 10000000:99999999 ) - digits = 8 - - case ( 100000000:999999999 ) - digits = 9 - - case ( 1000000000:min(2147483647, huge( self % num_bits ) ) ) - digits = 10 - - case default - error stop module_name // ' % ' // procedure // & - ' internal consistency fault was found.' - - end select - - end subroutine digit_count - - end subroutine write_bitset_string_64 - - - module subroutine write_bitset_unit_64(self, unit, advance, status) -! -! Writes a bitset literal to the I/O unit, UNIT, representing the -! individual bit values in the bitset_t, SELF. By default or if -! ADVANCE is present with the value 'YES', advancing output is used. -! If ADVANCE is present with the value 'NO', then the current record -! is not advanced by the write. If STATUS is absent an error results -! in an error stop with an informative stop code. If STATUS is -! present it has the default value of SUCCESS, the value -! ALLOC_FAULT if allocation of the output string failed, or -! WRITE_FAILURE if the WRITE statement outputting the literal failed. -! - class(bitset_64), intent(in) :: self - integer, intent(in) :: unit - character(len=*), intent(in), optional :: advance - integer, intent(out), optional :: status - - integer :: ierr - character(:), allocatable :: string - character(len=120) :: message - character(*), parameter :: procedure = "WRITE_BITSET" - - call self % write_bitset(string, status) - - if ( present(status) ) then - if (status /= success ) return - end if - - - if ( present( advance ) ) then - write( unit, & - FMT='(A)', & - advance=advance, & - iostat=ierr, & - iomsg=message ) & - string - else - write( unit, & - FMT='(A)', & - advance='YES', & - iostat=ierr, & - iomsg=message ) & - string - end if - if (ierr /= 0) go to 999 - - return - -999 if ( present(status) ) then - status = write_failure - return - else - error stop module_name // ' % ' // procedure // ' had a ' // & - 'failure on a WRITE statement.' - end if - - end subroutine write_bitset_unit_64 - - - elemental module subroutine xor_64(set1, set2) -! -! Sets the bits in SET1 to the bitwise XOR of the original bits in SET1 -! and SET2. SET1 and SET2 must have the same number of bits otherwise -! the result is undefined. -! - type(bitset_64), intent(inout) :: set1 - type(bitset_64), intent(in) :: set2 - - set1 % block = ieor( set1 % block, & - set2 % block ) - - end subroutine xor_64 - - -end submodule stdlib_bitset_64 diff --git a/src/stdlib_bitset_large.f90 b/src/stdlib_bitset_large.f90 deleted file mode 100644 index 137825694..000000000 --- a/src/stdlib_bitset_large.f90 +++ /dev/null @@ -1,1564 +0,0 @@ -submodule(stdlib_bitsets) stdlib_bitset_large - implicit none - -contains - - - elemental module function all_large( self ) result(all) -! Returns .TRUE. if all bits in SELF are 1, .FALSE. otherwise. - logical :: all - class(bitset_large), intent(in) :: self - - integer(bits_kind) :: block, full_blocks, pos - - all = .true. - full_blocks = bits(self)/block_size - do block = 1, full_blocks - if ( self % blocks(block) /= -1_block_kind ) then - all = .false. - return - end if - end do - - if ( full_blocks == size(self % blocks) ) return - - do pos=0, modulo( bits(self), block_size )-1 - if ( .not. btest(self % blocks(full_blocks+1), pos) ) then - all = .false. - return - end if - end do - - end function all_large - - - elemental module subroutine and_large(set1, set2) -! -! Sets the bits in SET1 to the bitwise AND of the original bits in SET1 -! and SET2. It is required that SET1 have the same number of bits as -! SET2 otherwise the result is undefined. -! - type(bitset_large), intent(inout) :: set1 - type(bitset_large), intent(in) :: set2 - - integer(bits_kind) :: block_ - - do block_ = 1, size(set1 % blocks) - set1 % blocks(block_) = iand( set1 % blocks(block_), & - set2 % blocks(block_) ) - end do - - end subroutine and_large - - - elemental module subroutine and_not_large(set1, set2) -! -! Sets the bits in SET1 to the bitwise and of the original bits in SET1 -! with the bitwise negation of SET2. SET1 and SET2 must have the same -! number of bits otherwise the result is undefined. -! - type(bitset_large), intent(inout) :: set1 - type(bitset_large), intent(in) :: set2 - - integer(bits_kind) :: block_ - - do block_ = 1, size( set1 % blocks ) - set1 % blocks(block_) = & - iand( set1 % blocks(block_), not( set2 % blocks(block_) ) ) - end do - - end subroutine and_not_large - - - elemental module function any_large(self) result(any) -! Returns .TRUE. if any bit in SELF is 1, .FALSE. otherwise. - logical :: any - class(bitset_large), intent(in) :: self - - integer(bits_kind) :: block_ - - do block_ = 1, size(self % blocks) - if ( self % blocks(block_) /= 0 ) then - any = .true. - return - end if - end do - any = .false. - - end function any_large - - - pure module subroutine assign_large( set1, set2 ) -! Used to define assignment for bitset_large - type(bitset_large), intent(out) :: set1 - type(bitset_large), intent(in) :: set2 - - set1 % num_bits = set2 % num_bits - allocate( set1 % blocks( size( set2 % blocks, kind=bits_kind ) ) ) - set1 % blocks(:) = set2 % blocks(:) - - end subroutine assign_large - - pure module subroutine assign_logint8_large( self, logical_vector ) -! Used to define assignment from an array of type logical for bitset_large - type(bitset_large), intent(out) :: self - logical(int8), intent(in) :: logical_vector(:) - - integer(bits_kind) :: blocks - integer(bits_kind) :: log_size - integer(bits_kind) :: index - - log_size = size( logical_vector, 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 - - do index=0, log_size-1 - if ( logical_vector(index+1) ) then - call self % set( index ) - end if - end do - - end subroutine assign_logint8_large - - - pure module subroutine logint8_assign_large( logical_vector, set ) -! Used to define assignment to an array of type logical for bitset_large - logical(int8), intent(out), allocatable :: logical_vector(:) - type(bitset_large), intent(in) :: set - - integer(bits_kind) :: index - - allocate( logical_vector( set % num_bits ) ) - do index=0, set % num_bits-1 - if ( set % value( index ) == 1 ) then - logical_vector(index+1) = .true. - else - logical_vector(index+1) = .false. - end if - end do - - end subroutine logint8_assign_large - pure module subroutine assign_logint16_large( self, logical_vector ) -! Used to define assignment from an array of type logical for bitset_large - type(bitset_large), intent(out) :: self - logical(int16), intent(in) :: logical_vector(:) - - integer(bits_kind) :: blocks - integer(bits_kind) :: log_size - integer(bits_kind) :: index - - log_size = size( logical_vector, 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 - - do index=0, log_size-1 - if ( logical_vector(index+1) ) then - call self % set( index ) - end if - end do - - end subroutine assign_logint16_large - - - pure module subroutine logint16_assign_large( logical_vector, set ) -! Used to define assignment to an array of type logical for bitset_large - logical(int16), intent(out), allocatable :: logical_vector(:) - type(bitset_large), intent(in) :: set - - integer(bits_kind) :: index - - allocate( logical_vector( set % num_bits ) ) - do index=0, set % num_bits-1 - if ( set % value( index ) == 1 ) then - logical_vector(index+1) = .true. - else - logical_vector(index+1) = .false. - end if - end do - - end subroutine logint16_assign_large - pure module subroutine assign_logint32_large( self, logical_vector ) -! Used to define assignment from an array of type logical for bitset_large - type(bitset_large), intent(out) :: self - logical(int32), intent(in) :: logical_vector(:) - - integer(bits_kind) :: blocks - integer(bits_kind) :: log_size - integer(bits_kind) :: index - - log_size = size( logical_vector, 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 - - do index=0, log_size-1 - if ( logical_vector(index+1) ) then - call self % set( index ) - end if - end do - - end subroutine assign_logint32_large - - - pure module subroutine logint32_assign_large( logical_vector, set ) -! Used to define assignment to an array of type logical for bitset_large - logical(int32), intent(out), allocatable :: logical_vector(:) - type(bitset_large), intent(in) :: set - - integer(bits_kind) :: index - - allocate( logical_vector( set % num_bits ) ) - do index=0, set % num_bits-1 - if ( set % value( index ) == 1 ) then - logical_vector(index+1) = .true. - else - logical_vector(index+1) = .false. - end if - end do - - end subroutine logint32_assign_large - pure module subroutine assign_logint64_large( self, logical_vector ) -! Used to define assignment from an array of type logical for bitset_large - type(bitset_large), intent(out) :: self - logical(int64), intent(in) :: logical_vector(:) - - integer(bits_kind) :: blocks - integer(bits_kind) :: log_size - integer(bits_kind) :: index - - log_size = size( logical_vector, 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 - - do index=0, log_size-1 - if ( logical_vector(index+1) ) then - call self % set( index ) - end if - end do - - end subroutine assign_logint64_large - - - pure module subroutine logint64_assign_large( logical_vector, set ) -! Used to define assignment to an array of type logical for bitset_large - logical(int64), intent(out), allocatable :: logical_vector(:) - type(bitset_large), intent(in) :: set - - integer(bits_kind) :: index - - allocate( logical_vector( set % num_bits ) ) - do index=0, set % num_bits-1 - if ( set % value( index ) == 1 ) then - logical_vector(index+1) = .true. - else - logical_vector(index+1) = .false. - end if - end do - - end subroutine logint64_assign_large - - - elemental module function bit_count_large(self) result(bit_count) -! Returns the number of non-zero bits in SELF. - integer(bits_kind) :: bit_count - class(bitset_large), intent(in) :: self - - integer(bits_kind) :: block_, pos - - bit_count = 0 - do block_ = 1, size(self % blocks) - 1 - do pos = 0, block_size-1 - if ( btest( self % blocks(block_), pos ) ) & - bit_count = bit_count + 1 - end do - - end do - - do pos = 0, self % num_bits - (block_-1)*block_size - 1 - if ( btest( self % blocks(block_), pos ) ) bit_count = bit_count + 1 - end do - - end function bit_count_large - - - elemental module subroutine clear_bit_large(self, pos) -! -! Sets to zero the POS position in SELF. If POS is less than zero or -! greater than BITS(SELF)-1 it is ignored. -! - class(bitset_large), intent(inout) :: self - integer(bits_kind), intent(in) :: pos - - integer :: clear_block, block_bit - - if ( pos < 0 .OR. (pos > self % num_bits-1) ) return - clear_block = pos / block_size + 1 - block_bit = pos - (clear_block - 1) * block_size - self % blocks(clear_block) = & - ibclr( self % blocks(clear_block), block_bit ) - - end subroutine clear_bit_large - - - pure module subroutine clear_range_large(self, start_pos, stop_pos) -! -! Sets to zero all bits from the START_POS to STOP_POS positions in SELF. -! If STOP_POS < START_POS then no bits are modified. Positions outside -! the range 0 to BITS(SELF)-1 are ignored. -! - class(bitset_large), intent(inout) :: self - integer(bits_kind), intent(in) :: start_pos, stop_pos - - integer(bits_kind) :: bit, block_, first_block, last_block, & - true_first, true_last - - true_first = max( 0, start_pos ) - true_last = min( self % num_bits-1, stop_pos ) - if ( true_last < true_first ) return - - first_block = true_first / block_size + 1 - last_block = true_last / block_size + 1 - if ( first_block == last_block ) then -! TRUE_FIRST and TRUE_LAST are in the same block - call mvbits( all_zeros, & - true_first - (first_block-1)*block_size, & - true_last - true_first + 1, & - self % blocks(first_block), & - true_first - (first_block-1)*block_size ) - return - end if - -! Do "partial" black containing FIRST - bit = true_first - (first_block-1)*block_size - call mvbits( all_zeros, & - bit, & - block_size - bit, & - self % blocks(first_block), & - bit ) - -! Do "partial" black containing LAST - bit = true_last - (last_block-1)*block_size - call mvbits( all_zeros, & - 0, & - bit+1, & - self % blocks(last_block), & - 0 ) - -! Do intermediate blocks - do block_ = first_block+1, last_block-1 - self % blocks(block_) = all_zeros - end do - - end subroutine clear_range_large - - - elemental module function eqv_large(set1, set2) result(eqv) -! -! Returns .TRUE. if all bits in SET1 and SET2 have the same value, -! .FALSE. otherwise. The sets must have the same number of bits -! otherwise the results are undefined. -! - logical :: eqv - type(bitset_large), intent(in) :: set1, set2 - - integer(bits_kind) :: block, common_blocks - - eqv = .false. - common_blocks = size(set1 % blocks) - do block = 1, common_blocks - if ( set1 % blocks(block) /= set2 % blocks(block) ) return - end do - eqv = .true. - - end function eqv_large - - - module subroutine extract_large(new, old, start_pos, stop_pos, status) -! Creates a new bitset, NEW, from a range, START_POS to STOP_POS, in bitset -! OLD. If START_POS is greater than STOP_POS the new bitset is empty. -! If START_POS is less than zero or STOP_POS is greater than BITS(OLD)-1 -! then if STATUS is present it has the value INDEX_INVALID_ERROR, -! otherwise processing stops with an informative message. - type(bitset_large), intent(out) :: new - type(bitset_large), intent(in) :: old - integer(bits_kind), intent(in) :: start_pos, stop_pos - integer, intent(out), optional :: status - - integer(bits_kind) :: bits, blocks, ex_block, i, j, k, old_block - character(*), parameter :: procedure = 'EXTRACT' - - if ( start_pos < 0 ) go to 999 - if ( stop_pos >= old % num_bits ) go to 998 - bits = stop_pos - start_pos + 1 - - if ( bits <= 0 ) then - new % num_bits = 0 - allocate( new % blocks(0) ) - return - end if - - blocks = ((bits-1) / block_size) + 1 - - new % num_bits = bits - allocate( new % blocks(blocks) ) - new % blocks(:) = 0 - - do i=0, bits-1 - ex_block = i / block_size + 1 - j = i - (ex_block-1) * block_size - old_block = (start_pos + i) / block_size + 1 - k = (start_pos + i) - (old_block-1) * block_size - if ( btest( old % blocks(old_block), k ) ) then - new % blocks(ex_block) = ibset(new % blocks(ex_block), j) - end if - end do - - if ( present(status) ) status = success - - return - -998 if ( present(status) ) then - status = index_invalid_error - return - else - error stop module_name // ' % ' // procedure // ' had a ' // & - 'STOP_POS greater than BITS(OLD)-1.' - end if - -999 if ( present(status) ) then - status = index_invalid_error - return - else - error stop module_name // ' % ' // procedure // ' had a ' // & - 'START_POS less than 0.' - end if - - end subroutine extract_large - - - elemental module subroutine flip_bit_large(self, pos) -! -! Flips the value at the POS position in SELF, provided the position is -! valid. If POS is less than 0 or greater than BITS(SELF)-1, no value is -! changed. -! - class(bitset_large), intent(inout) :: self - integer(bits_kind), intent(in) :: pos - - integer :: flip_block, block_bit - - if ( pos < 0 .OR. pos > self % num_bits-1 ) return - - flip_block = pos / block_size + 1 - block_bit = pos - (flip_block - 1) * block_size - if ( btest( self % blocks(flip_block), block_bit ) ) then - self % blocks(flip_block) = ibclr( self % blocks(flip_block), & - block_bit ) - else - self % blocks(flip_block) = ibset( self % blocks(flip_block), & - block_bit ) - end if - - end subroutine flip_bit_large - - - pure module subroutine flip_range_large(self, start_pos, stop_pos) -! -! Flips all valid bits from the START_POS to the STOP_POS positions in -! SELF. If STOP_POS < START_POS no bits are flipped. Positions less than -! 0 or greater than BITS(SELF)-1 are ignored. -! - class(bitset_large), intent(inout) :: self - integer(bits_kind), intent(in) :: start_pos, stop_pos - - integer(bits_kind) :: bit, block_, end_bit, first_block, last_block, & - start_bit - - start_bit = max( 0, start_pos ) - end_bit = min( stop_pos , self % num_bits-1 ) - if ( end_bit < start_bit ) return - - first_block = start_bit / block_size + 1 - last_block = end_bit / block_size + 1 - if (first_block == last_block) then -! FIRST and LAST are in the same block - call mvbits( not(self % blocks(first_block)), & - start_bit - (first_block-1)*block_size, & - end_bit - start_bit + 1, & - self % blocks(first_block), & - start_bit - (first_block-1)*block_size ) - return - end if - -! Do "partial" black containing FIRST - bit = start_bit - (first_block-1)*block_size - call mvbits( not(self % blocks(first_block) ), & - bit, & - block_size - bit, & - self % blocks(first_block), & - bit ) - -! Do "partial" black containing LAST - bit = end_bit - (last_block-1)*block_size - call mvbits( not( self % blocks(last_block) ), & - 0, & - bit+1, & - self % blocks(last_block), & - 0 ) - -! Do remaining blocks - do block_ = first_block+1, last_block-1 - self % blocks(block_) = not( self % blocks(block_) ) - end do - - end subroutine flip_range_large - - module subroutine from_string_large(self, string, status) -! Initializes the bitset SELF treating STRING as a binary literal -! STATUS may have the values SUCCESS, ALLOC_FAULT, -! ARRAY_SIZE_INVALID_ERROR, or CHAR_STRING_INVALID. - class(bitset_large), intent(out) :: self - character(*), intent(in) :: string - integer, intent(out), optional :: status - - character(*), parameter :: procedure = 'FROM_STRING' - integer(bits_kind) :: bit - integer(int64) :: bits - character(1) :: char - - bits = len(string, kind=int64) - if ( bits > huge(0_bits_kind) ) go to 998 - - call init_zero_large( self, int(bits, kind=bits_kind), status ) - - if ( present(status) ) then - if ( status /= success ) return - end if - - do bit = 1_bits_kind, bits - char = string(bit:bit) - if ( char == '0' ) then - call self % clear( int(bits, kind=bits_kind)-bit ) - else if ( char == '1' ) then - call self % set( int(bits, kind=bits_kind)-bit ) - else - go to 999 - end if - end do - - if ( present(status) ) status = success - - return - -998 if ( present(status) ) then - status = array_size_invalid_error - return - else - error stop module_name // ' % ' // procedure // ' STRING ' // & - 'was too long for a BITSET_64 SELF.' - end if - -999 if ( present(status) ) then - status = char_string_invalid_error - return - else - error stop module_name // ' % ' // procedure // ' STRING ' // & - 'had a character other than "0" or "1",' - end if - - end subroutine from_string_large - - - elemental module function ge_large(set1, set2) result(ge) -! -! Returns .TRUE. if the bits in SET1 and SET2 are the same or the -! highest order different bit is set to 1 in SET1 and to 0 in set2. -! .FALSE. otherwise. The sets must have the same number of bits -! otherwise the results are undefined. -! - logical :: ge - type(bitset_large), intent(in) :: set1, set2 - - integer(bits_kind) :: block_ - - do block_ = size(set1 % blocks), 1, -1 - if ( set1 % blocks(block_) == set2 % blocks(block_) ) then - cycle - else if ( bgt(set1 % blocks(block_), set2 % blocks(block_) ) ) then - ge = .true. - return - else - ge = .false. - return - end if - end do - ge = .true. - - end function ge_large - - - elemental module function gt_large(set1, set2) result(gt) -! -! Returns .TRUE. if the bits in SET1 and SET2 differ and the -! highest order different bit is set to 1 in SET1 and to 0 in set2. -! .FALSE. otherwise. The sets must have the same number of bits -! otherwise the results are undefined. -! - logical :: gt - type(bitset_large), intent(in) :: set1, set2 - - integer(bits_kind) :: block_ - - do block_ = size(set1 % blocks), 1, -1 - if ( set1 % blocks(block_) == set2 % blocks(block_) ) then - cycle - else if ( bgt( set1 % blocks(block_), set2 % blocks(block_) ) ) then - gt = .true. - return - else - gt = .false. - return - end if - end do - gt = .false. - - end function gt_large - - - module subroutine init_zero_large(self, bits, status) -! -! Creates the bitset, SELF, of size BITS, with all bits initialized to -! zero. BITS must be non-negative. If an error occurs and STATUS is -! absent then processing stops with an informative stop code. STATUS -! has a default value of SUCCESS. If an error occurs it has the value -! ARRAY_SIZE_INVALID_ERROR if BITS is either negative larger than 64 -! if SELF is of type BITSET_64, or the value ALLOC_FAULT if it failed -! during allocation of memory for SELF. -! - class(bitset_large), intent(out) :: self - integer(bits_kind), intent(in) :: bits - integer, intent(out), optional :: status - - character(len=120) :: message - character(*), parameter :: procedure = "INIT" - integer :: blocks, ierr - - message = '' - if ( bits < 0 ) go to 999 - - if (bits == 0) then - self % num_bits = 0 - allocate( self % blocks(0), stat=ierr, errmsg=message ) - if (ierr /= 0) go to 998 - return - else - blocks = ((bits-1) / block_size) + 1 - end if - - self % num_bits = bits - allocate( self % blocks(blocks), stat=ierr, errmsg=message ) - if (ierr /= 0) go to 998 - - self % blocks(:) = all_zeros - - if ( present(status) ) status = success - - return - -998 if ( present(status) ) then - status = alloc_fault - return - else - error stop module_name // ' % ' // procedure // ' allocation ' // & - 'failure for SELF.' - end if - -999 if ( present(status) ) then - status = array_size_invalid_error - return - else - error stop module_name // ' %' // procedure // ' BITS had ' // & - 'a negative value.' - end if - - end subroutine init_zero_large - - - module subroutine input_large(self, unit, status) -! -! Reads the components of the bitset, SELF, from the unformatted I/O -! unit, UNIT, assuming that the components were written using OUTPUT. -! If an error occurs and STATUS is absent then processing stops with -! an informative stop code. STATUS has a default value of SUCCESS. -! If an error occurs it has the value READ_FAILURE if it failed -! during the reads from UNIT or the value ALLOC_FAULT if it failed -! during allocation of memory for SELF, or the value -! ARRAY_SIZE_INVALID_ERROR if the BITS(SELF) in UNIT is less than 0 -! or greater than 64 for a BITSET_64 input. -! - class(bitset_large), intent(out) :: self - integer, intent(in) :: unit - integer, intent(out), optional :: status - - integer(bits_kind) :: bits - integer :: ierr - character(len=120) :: message - character(*), parameter :: procedure = 'INPUT' - integer :: stat - - read(unit, iostat=ierr, iomsg=message) bits - if (ierr /= 0) go to 999 - if ( bits < 0 ) go to 997 - - call self % init(bits, stat) - if (stat /= success) go to 998 - - if (bits < 1) return - - read(unit, iostat=ierr, iomsg=message) self % blocks(:) - if (ierr /= 0) go to 999 - - if ( present(status) ) status = success - - return - -997 if ( present(status) ) then - status = array_size_invalid_error - return - else - error stop module_name // ' %' // procedure // ' BITS in ' // & - 'UNIT had a negative value.' - end if - -998 if ( present(status) ) then - status = alloc_fault - return - else - error stop module_name // ' % ' // procedure // ' had an ' // & - 'alloction fault for SELF.' - end if - -999 if ( present(status) ) then - status = read_failure - return - else - error stop module_name // ' % ' // procedure // ' had a ' // & - 'failure on a READ statement for UNIT.' - end if - - end subroutine input_large - - - elemental module function le_large(set1, set2) result(le) -! -! Returns .TRUE. if the bits in SET1 and SET2 are the same or the -! highest order different bit is set to 0 in SET1 and to 1 in set2. -! .FALSE. otherwise. The sets must have the same number of bits -! otherwise the results are undefined. -! - logical :: le - type(bitset_large), intent(in) :: set1, set2 - - integer(bits_kind) :: block_ - - do block_ = size(set1 % blocks), 1, -1 - if ( set1 % blocks(block_) == set2 % blocks(block_) ) then - cycle - else if ( blt( set1 % blocks(block_), set2 % blocks(block_) ) ) then - le = .true. - return - else - le = .false. - return - end if - end do - - le = .true. - - end function le_large - - - elemental module function lt_large(set1, set2) result(lt) -! -! Returns .TRUE. if the bits in SET1 and SET2 differ and the -! highest order different bit is set to 0 in SET1 and to 1 in set2. -! .FALSE. otherwise. The sets must have the same number of bits -! otherwise the results are undefined. -! - logical :: lt - type(bitset_large), intent(in) :: set1, set2 - - integer(bits_kind) :: block_ - - do block_ = size(set1 % blocks), 1, -1 - if ( set1 % blocks(block_) == set2 % blocks(block_) ) then - cycle - else if ( blt( set1 % blocks(block_), set2 % blocks(block_) ) ) then - lt = .true. - return - else - lt = .false. - return - end if - end do - lt = .false. - - end function lt_large - - - elemental module function neqv_large(set1, set2) result(neqv) -! -! Returns .TRUE. if any bits in SET1 and SET2 differ in value, -! .FALSE. otherwise. The sets must have the same number of bits -! otherwise the results are undefined. -! - logical :: neqv - type(bitset_large), intent(in) :: set1, set2 - - integer(bits_kind) :: block - - neqv = .true. - do block = 1, size(set1 % blocks) - if ( set1 % blocks(block) /= set2 % blocks(block) ) return - end do - neqv = .false. - - end function neqv_large - - - elemental module function none_large(self) result(none) -! -! Returns .TRUE. if none of the bits in SELF have the value 1. -! - logical :: none - class(bitset_large), intent(in) :: self - - integer :: block - - none = .true. - do block = 1, size(self % blocks) - if (self % blocks(block) /= 0) then - none = .false. - return - end if - end do - - end function none_large - - - elemental module subroutine not_large(self) -! -! Sets the bits in SELF to their logical complement -! - class(bitset_large), intent(inout) :: self - - integer(bits_kind) :: bit, full_blocks, block, remaining_bits - - if ( self % num_bits == 0 ) return - full_blocks = self % num_bits / block_size - do block = 1, full_blocks - self % blocks(block) = not( self % blocks(block) ) - end do - remaining_bits = self % num_bits - full_blocks * block_size - - do bit=0, remaining_bits - 1 - if ( btest( self % blocks( block ), bit ) ) then - self % blocks( block ) = ibclr( self % blocks(block), bit ) - else - self % blocks( block ) = ibset( self % blocks(block), bit ) - end if - end do - - end subroutine not_large - - - elemental module subroutine or_large(set1, set2) -! -! Sets the bits in SET1 to the bitwise OR of the original bits in SET1 -! and SET2. SET1 and SET2 must have the same number of bits otherwise -! the result is undefined. -! - type(bitset_large), intent(inout) :: set1 - type(bitset_large), intent(in) :: set2 - - integer(bits_kind) :: block_ - - do block_ = 1, size( set1 % blocks ) - set1 % blocks(block_) = ior( set1 % blocks(block_), & - set2 % blocks(block_) ) - end do - - end subroutine or_large - - - module subroutine output_large(self, unit, status) -! -! Writes the components of the bitset, SELF, to the unformatted I/O -! unit, UNIT, in a unformatted sequence compatible with INPUT. If -! STATUS is absent an error results in an error stop with an -! informative stop code. If STATUS is present it has the default -! value of SUCCESS, or the value WRITE_FAILURE if the write failed. -! - class(bitset_large), intent(in) :: self - integer, intent(in) :: unit - integer, intent(out), optional :: status - - integer :: ierr - character(len=120) :: message - character(*), parameter :: procedure = "OUTPUT" - - write(unit, iostat=ierr, iomsg=message) self % num_bits - if (ierr /= 0) go to 999 - - if (self % num_bits < 1) return - write(unit, iostat=ierr, iomsg=message) self % blocks(:) - if (ierr /= 0) go to 999 - - return - -999 if ( present(status) ) then - status = write_failure - return - else - error stop module_name // ' % ' // procedure // ' had a ' // & - 'failure in the write to UNIT.' - end if - - end subroutine output_large - - - module subroutine read_bitset_string_large(self, string, status) -! -! Uses the bitset literal in the default character STRING, to define -! the bitset, SELF. The literal may be preceded by an an arbitrary -! sequence of blank characters. If STATUS is absent an error results -! in an error stop with an informative stop code. If STATUS -! is present it has the default value of SUCCESS, the value -! INTEGER_OVERFLOW_ERROR if the bitset literal has a BITS(SELF) value -! too large to be represented, the value ALLOC_FAULT if allocation of -! memory for SELF failed, or CHAR_STRING_INVALID_ERROR if the bitset -! literal has an invalid character, or ARRAY_SIZE_INVALID_ERROR if -! BITS(SELF) in STRING is greater than 64 for a BITSET_64, or -! CHAR_STRING_TOO_SMALL_ERROR if the string ends before all the bits -! are read. -! - class(bitset_large), intent(out) :: self - character(len=*), intent(in) :: string - integer, intent(out), optional :: status - - integer(bits_kind) :: bit, bits - integer(bits_kind) :: digits, pos - character(*), parameter :: procedure = "READ_BITSET" - integer :: stat - - pos = 1 - find_start: do pos=1, len(string) - if ( string(pos:pos) /= ' ' ) exit - end do find_start - - if ( pos > len(string) - 8 ) go to 999 - - if ( string(pos:pos) /= 's' .AND. string(pos:pos) /= 'S' ) go to 999 - - pos = pos + 1 - bits = 0 - digits = 0 - - do - select case( iachar( string(pos:pos) ) ) - case(ia0:ia9) - digits = digits + 1 - if ( digits == 10 .AND. bits > 2_bits_kind**30/5 ) go to 996 -!! May not be quite right - if ( digits > 10 ) go to 996 - bits = bits*10 + iachar( string(pos:pos) ) - ia0 - if ( bits < 0 ) go to 996 - case(iachar('b'), iachar('B')) - go to 100 - case default - go to 999 - end select - - pos = pos + 1 - end do - -100 if ( bits + pos > len(string) ) go to 994 - call self % init( bits, stat ) - if (stat /= success) go to 998 - - pos = pos + 1 - bit = bits - 1 - do - if ( string(pos:pos) == '0' ) then - call self % clear( bit ) - else if ( string(pos:pos) == '1' ) then - call self % set( bit ) - else - go to 999 - end if - pos = pos + 1 - bit = bit - 1 - if ( bit < 0 ) exit - end do - - if ( present(status) ) status = success - - return - -994 if ( present(status) ) then - status = char_string_too_small_error - return - else - error stop module_name // ' % ' // procedure // ' STRING ' // & - 'was too small for the BITS specified by the STRING.' - end if - -996 if ( present(status) ) then - status = integer_overflow_error - return - else - error stop module_name // ' % ' // procedure // ' failed on ' // & - 'integer overflow in reading size of bitset literal from ' // & - 'UNIT.' - end if - -998 if ( present(status) ) then - status = alloc_fault - return - else - error stop module_name // ' % ' // procedure // ' failed in ' // & - 'allocating memory for the bitset.' - end if - -999 if ( present(status) ) then - status = char_string_invalid_error - return - else - error stop module_name // ' % ' // procedure // ' failed due ' // & - 'to an invalid character in STRING.' - end if - - end subroutine read_bitset_string_large - - - module subroutine read_bitset_unit_large(self, unit, advance, status) -! -! Uses the bitset literal at the current position in the formatted -! file with I/O unit, UNIT, to define the bitset, SELF. The literal -! may be preceded by an an arbitrary sequence of blank characters. -! If ADVANCE is present it must be either 'YES' or 'NO'. If absent -! it has the default value of 'YES' to determine whether advancing -! I/O occurs. If STATUS is absent an error results in an error stop -! with an informative stop code. If STATUS is present it has the -! default value of SUCCESS, the value INTEGER_OVERFLOW_ERROR if the -! bitset literal has a BITS(SELF) value too large to be -! represented, the value READ_FAILURE if a READ statement fails, -! EOF_FAILURE if a READ statement reach an end-of-file before -! completing the read of the bitset literal, or the value -! CHAR_STRING_INVALID_ERROR if the read of the bitset literal found -! an invalid character, or ARRAY_SIZE_INVALID_ERROR if BITS(SELF) -! in STRING is greater than 64 for a BITSET_64. -! - class(bitset_large), intent(out) :: self - integer, intent(in) :: unit - character(*), intent(in), optional :: advance - integer, intent(out), optional :: status - - integer(bits_kind) :: bit, bits, digits - integer :: ierr - character(len=128) :: message - character(*), parameter :: procedure = "READ_BITSET" - integer :: stat - character(len=1) :: char - - do - read( unit, & - advance='NO', & - FMT='(A1)', & - err=997, & - end=998, & - iostat=ierr, & - iomsg=message ) char - select case( char ) - case( ' ' ) - cycle - case( 's', 'S' ) - exit - case default - go to 999 - end select - end do - - bits = 0 - digits = 0 - do - read( unit, & - advance='NO', & - FMT='(A1)', & - err=998, & - end=999, & - iostat=ierr, & - iomsg=message ) char - if ( char == 'b' .or. char == 'B' ) exit - select case( char ) - case( '0', '1', '2', '3', '4', '5', '6', '7', '8', '9' ) - digits = digits + 1 - if ( digits == 10 .AND. bits > 2_bits_kind**30/5 ) go to 996 -!! May not be quite right - if ( digits > 10 ) go to 996 - bits = 10*bits + iachar(char) - iachar('0') - if ( bits < 0 ) go to 996 - case default - go to 999 - end select - end do - - if ( bits < 0 .OR. digits == 0 .OR. digits > 10 ) go to 999 - - call self % init( bits ) - do bit = 1, bits-1 - read( unit, & - advance='NO', & - FMT='(A1)', & - err=997, & - end=998, & - iostat=ierr, & - iomsg=message ) char - if ( char == '0' ) then - call self % clear( bits-bit ) - else if ( char == '1' ) then - call self % set( bits-bit ) - else - go to 999 - end if - end do - - if ( present(advance) ) then - read( unit, & - advance=advance, & - FMT='(A1)', & - err=997, & - end=998, & - iostat=ierr, & - iomsg=message ) char - else - read( unit, & - advance='YES', & - FMT='(A1)', & - err=997, & - end=998, & - iostat=ierr, & - iomsg=message ) char - end if - - if ( char == '0' ) then - call self % clear( bits-bit ) - else if ( char == '1' ) then - call self % set( bits-bit ) - else - go to 999 - end if - - if ( present(status) ) status = success - - return - -996 if ( present(status) ) then - status = integer_overflow_error - return - else - error stop module_name // ' % ' // procedure // ' failed on ' // & - 'integer overflow in reading size of bitset literal from ' // & - 'UNIT.' - end if - - -997 if ( present(status) ) then - status = read_failure - return - else - error stop module_name // ' % ' // procedure // ' failed on ' // & - 'read of UNIT.' - end if - -998 if ( present(status) ) then - status = eof_failure - return - else - error stop module_name // ' % ' // procedure // ' reached ' // & - 'End of File of UNIT before finding a bitset literal.' - end if - -999 if ( present(status) ) then - status = char_string_invalid_error - return - else - error stop module_name // ' % ' // procedure // ' found an ' // & - 'invalid bitset literal in UNIT.' - end if - - end subroutine read_bitset_unit_large - - - elemental module subroutine set_bit_large(self, pos) -! -! Sets the value at the POS position in SELF, provided the position is -! valid. If the position is less than 0 or greater than BITS(SELF)-1 -! then SELF is unchanged. -! - class(bitset_large), intent(inout) :: self - integer(bits_kind), intent(in) :: pos - - integer(bits_kind) :: set_block, block_bit - - if ( pos < 0 .OR. pos > self % num_bits-1 ) return - - set_block = pos / block_size + 1 - block_bit = pos - (set_block - 1) * block_size - self % blocks(set_block) = ibset( self % blocks(set_block), block_bit ) - - end subroutine set_bit_large - - - pure module subroutine set_range_large(self, start_pos, stop_pos) -! -! Sets all valid bits to 1 from the START_POS to the STOP_POS positions -! in SELF. If STOP_POA < START_POS no bits are changed. Positions outside -! the range 0 to BITS(SELF)-1 are ignored. -! - class(bitset_large), intent(inout) :: self - integer(bits_kind), intent(in) :: start_pos, stop_pos - - integer(bits_kind) :: bit, block_, end_bit, first_block, last_block, & - start_bit - - start_bit = max( 0, start_pos ) - end_bit = min( stop_pos, self % num_bits-1 ) - if ( end_bit < start_bit ) return - - first_block = start_bit / block_size + 1 - last_block = end_bit / block_size + 1 - if ( first_block == last_block ) then -! FIRST and LAST are in the same block - call mvbits( all_ones, & - start_bit - (first_block-1)*block_size, & - end_bit - start_bit + 1, & - self % blocks(first_block), & - start_bit - (first_block-1)*block_size ) - return - end if - -! Do "partial" black containing FIRST - bit = start_bit - (first_block-1)*block_size - call mvbits( all_ones, & - bit, & - block_size - bit, & - self % blocks(first_block), & - bit ) - -! Do "partial" black containing LAST - bit = end_bit - (last_block-1)*block_size - call mvbits( all_ones, & - 0, & - bit+1, & - self % blocks(last_block), & - 0 ) - -! Do remaining blocks - do block_ = first_block+1, last_block-1 - self % blocks(block_) = all_ones - end do - - end subroutine set_range_large - - - elemental module function test_large(self, pos) result(test) -! -! Returns .TRUE. if the POS position is set, .FALSE. otherwise. If POS -! is negative or greater than BITS(SELF) - 1 the result is .FALSE.. -! - logical :: test - class(bitset_large), intent(in) :: self - integer(bits_kind), intent(in) :: pos - - integer(bits_kind) :: bit_block - - if ( pos < 0 .or. pos >= self % num_bits ) then - test = .false. - else - bit_block = pos / block_size + 1 - test = btest( self % blocks(bit_block), & - pos - ( bit_block-1 ) * block_size ) - end if - - end function test_large - - - module subroutine to_string_large(self, string, status) -! -! Represents the value of SELF as a binary literal in STRING -! Status may have the values SUCCESS or ALLOC_FAULT -! - class(bitset_large), intent(in) :: self - character(len=:), allocatable, intent(out) :: string - integer, intent(out), optional :: status - - character(*), parameter :: procedure = 'TO_STRING' - integer(bits_kind) :: bit, bit_count, pos - integer :: stat - - bit_count = self % num_bits - allocate( character(len=bit_count)::string, stat=stat ) - if ( stat > 0 ) go to 999 - do bit=0, bit_count-1 - pos = bit_count - bit - if ( self % test( bit) ) then - string( pos:pos ) = '1' - else - string( pos:pos ) = '0' - end if - end do - - if ( present(status) ) status = success - - return - -999 if ( present(status) ) then - status = alloc_fault - return - else - error stop module_name // ' % ' // procedure // ' allocation ' // & - 'of STRING failed.' - end if - - end subroutine to_string_large - - - elemental module function value_large(self, pos) result(value) -! -! Returns 1 if the POS position is set, 0 otherwise. If POS is negative -! or greater than BITS(SELF) - 1 the result is 0. -! - integer :: value - class(bitset_large), intent(in) :: self - integer(bits_kind), intent(in) :: pos - - integer :: bit_block - - if ( pos < 0 .or. pos >= self % num_bits ) then - value = 0 - else - bit_block = pos / block_size + 1 - if ( btest( self % blocks(bit_block), & - pos - ( bit_block-1 ) * block_size ) ) then - value = 1 - else - value = 0 - end if - end if - - end function value_large - - - module subroutine write_bitset_string_large(self, string, status) -! -! Writes a bitset literal to the allocatable default character STRING, -! representing the individual bit values in the bitset_t, SELF. -! If STATUS is absent an error results in an error stop with an -! informative stop code. If STATUS is present it has the default -! value of SUCCESS, or the value ALLOC_FAULT if allocation of -! the output string failed. -! - class(bitset_large), intent(in) :: self - character(len=:), allocatable, intent(out) :: string - integer, intent(out), optional :: status - - integer(bits_kind) :: bit, & - bit_count, & - count_digits, & - pos - integer :: stat - - character(*), parameter :: procedure = 'WRITE_BITSET' - - bit_count = bits(self) - - call digit_count( self % num_bits, count_digits ) - - allocate( character(len=count_digits+bit_count+2)::string, stat=stat ) - if ( stat > 0 ) go to 999 - - write( string, "('S', i0)" ) self % num_bits - - string( count_digits + 2:count_digits + 2 ) = "B" - do bit=0, bit_count-1 - pos = count_digits + 2 + bit_count - bit - if ( self % test( bit) ) then - string( pos:pos ) = '1' - else - string( pos:pos ) = '0' - end if - end do - - if ( present(status) ) status = success - - return - -999 if ( present(status) ) then - status = alloc_fault - return - else - error stop module_name // ' % ' // procedure // ' had a ' // & - 'memory sllocation failure for a string.' - end if - - contains - - subroutine digit_count( bits, digits ) - integer(bits_kind), intent(in) :: bits - integer(bits_kind), intent(out) :: digits - - select case ( bits ) - case ( 0:9 ) - digits = 1 - - case ( 10:99 ) - digits = 2 - - case ( 100:999 ) - digits = 3 - - case ( 1000:9999 ) - digits = 4 - - case ( 10000:99999 ) - digits = 5 - - case ( 100000:999999 ) - digits = 6 - - case ( 1000000:9999999 ) - digits = 7 - - case ( 10000000:99999999 ) - digits = 8 - - case ( 100000000:999999999 ) - digits = 9 - - case ( 1000000000:min(2147483647, huge( self % num_bits ) ) ) - digits = 10 - - case default - error stop module_name // ' % ' // procedure // & - ' internal consistency fault was found.' - - end select - - end subroutine digit_count - - end subroutine write_bitset_string_large - - - module subroutine write_bitset_unit_large(self, unit, advance, status) -! -! Writes a bitset literal to the I/O unit, UNIT, representing the -! individual bit values in the bitset_t, SELF. By default or if -! ADVANCE is present with the value 'YES', advancing output is used. -! If ADVANCE is present with the value 'NO', then the current record -! is not advanced by the write. If STATUS is absent an error results -! in an error stop with an informative stop code. If STATUS is -! present it has the default value of SUCCESS, the value -! ALLOC_FAULT if allocation of the output string failed, or -! WRITE_FAILURE if the WRITE statement outputting the literal failed. -! - class(bitset_large), intent(in) :: self - integer, intent(in) :: unit - character(len=*), intent(in), optional :: advance - integer, intent(out), optional :: status - - integer :: ierr - character(:), allocatable :: string - character(len=120) :: message - character(*), parameter :: procedure = "WRITE_BITSET" - - call self % write_bitset(string, status) - - if ( present(status) ) then - if (status /= success ) return - - end if - - - if ( present( advance ) ) then - write( unit, & - FMT='(A)', & - advance=advance, & - iostat=ierr, & - iomsg=message ) & - string - else - write( unit, & - FMT='(A)', & - advance='YES', & - iostat=ierr, & - iomsg=message ) & - string - end if - if (ierr /= 0) go to 999 - - return - -999 if ( present(status) ) then - status = write_failure - return - else - error stop module_name // ' % ' // procedure // ' had a ' // & - 'failure on a WRITE statement.' - end if - - end subroutine write_bitset_unit_large - - - elemental module subroutine xor_large(set1, set2) -! -! Sets the bits in SET1 to the bitwise XOR of the original bits in SET1 -! and SET2. SET1 and SET2 must have the same number of bits otherwise -! the result is undefined. -! - type(bitset_large), intent(inout) :: set1 - type(bitset_large), intent(in) :: set2 - - integer(bits_kind) :: block_ - - do block_ = 1, size(set1 % blocks) - set1 % blocks(block_) = ieor( set1 % blocks(block_), & - set2 % blocks(block_) ) - end do - - end subroutine xor_large - -end submodule stdlib_bitset_large diff --git a/src/stdlib_bitsets.f90 b/src/stdlib_bitsets.f90 deleted file mode 100644 index d9965549d..000000000 --- a/src/stdlib_bitsets.f90 +++ /dev/null @@ -1,2124 +0,0 @@ -module stdlib_bitsets -!! Implements zero based bitsets of size up to `huge(0_int32)`. -!! The current code uses 64 bit integers to store the bits and uses all 64 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, & - int16, & - int32, & - int64, & - dp => real64 - - implicit none - - private - - integer, parameter :: & - block_size = bit_size(0_block_kind) - - integer(block_kind), private, parameter :: all_zeros = 0_block_kind - integer(block_kind), private, parameter :: all_ones = not(all_zeros) - - character(*), parameter, private :: module_name = "STDLIB_BITSETS" - integer, parameter, private :: & - ia0 = iachar('0'), & - ia9 = iachar('9') - - integer, parameter, public :: success = 0 -!! Error flag indicating no errors - integer, parameter, public :: alloc_fault = 1 -!! Error flag indicating a memory allocation failure - integer, parameter, public :: array_size_invalid_error = 2 -!! error flag indicating an invalid bits value - integer, parameter, public :: char_string_invalid_error = 3 -!! Error flag indicating an invalid character string - integer, parameter, public :: char_string_too_small_error = 4 -!! Error flag indicating a too small character string - integer, parameter, public :: index_invalid_error = 5 -!! Error flag indicating an invalid index - integer, parameter, public :: integer_overflow_error = 6 -!! Error flag indicating integer overflow - integer, parameter, public :: read_failure = 7 -!! Error flag indicating failure of a READ statement - integer, parameter, public :: eof_failure = 8 -!! Error flag indicating unexpected End-of-File on a READ - integer, parameter, public :: write_failure = 9 -!! Error flag indicating a failure on a WRITE statement - - public :: bits_kind -! Public constant - - public :: & - bitset_type, & - bitset_large, & - bitset_64 - -! Public types - - public :: & - assignment(=), & - and, & - and_not, & - bits, & - extract, & - operator(==), & - operator(/=), & - operator(>), & - operator(>=), & - operator(<), & - operator(<=), & - or, & - xor -! Public procedures - - type, abstract :: bitset_type -!! version: experimental -!! -!! Parent type for bitset_64 and bitset_large - private - integer(bits_kind) :: num_bits - - contains - - procedure(all_abstract), deferred, pass(self) :: all - procedure(any_abstract), deferred, pass(self) :: any - procedure(bit_count_abstract), deferred, pass(self) :: bit_count - procedure, pass(self) :: bits - procedure(clear_bit_abstract), deferred, pass(self) :: clear_bit - procedure(clear_range_abstract), deferred, pass(self) :: clear_range - generic :: clear => clear_bit, clear_range - procedure(flip_bit_abstract), deferred, pass(self) :: flip_bit - procedure(flip_range_abstract), deferred, pass(self) :: flip_range - generic :: flip => flip_bit, flip_range - procedure(from_string_abstract), deferred, pass(self) :: from_string - procedure(init_zero_abstract), deferred, pass(self) :: init_zero - generic :: init => init_zero - procedure(input_abstract), deferred, pass(self) :: input - procedure(none_abstract), deferred, pass(self) :: none - procedure(not_abstract), deferred, pass(self) :: not - procedure(output_abstract), deferred, pass(self) :: output - procedure(read_bitset_string_abstract), deferred, pass(self) :: & - read_bitset_string - procedure(read_bitset_unit_abstract), deferred, pass(self) :: & - read_bitset_unit - generic :: read_bitset => read_bitset_string, read_bitset_unit - procedure(set_bit_abstract), deferred, pass(self) :: set_bit - procedure(set_range_abstract), deferred, pass(self) :: set_range - generic :: set => set_bit, set_range - procedure(test_abstract), deferred, pass(self) :: test - procedure(to_string_abstract), deferred, pass(self) :: to_string - procedure(value_abstract), deferred, pass(self) :: value - procedure(write_bitset_string_abstract), deferred, pass(self) :: & - write_bitset_string - procedure(write_bitset_unit_abstract), deferred, pass(self) :: & - write_bitset_unit - generic :: write_bitset => write_bitset_string, write_bitset_unit - - end type bitset_type - - - abstract interface - - elemental function all_abstract( self ) result(all) -!! Version: experimental -!! -!! Returns `.true.` if all bits in `self` are 1, `.false`. otherwise. -!! -!!#### Example -!! -!! ```fortran -!! program demo_all -!! use stdlib_bitsets -!! character(*), parameter :: & -!! bits_all = '111111111111111111111111111111111' -!! type(bitset_64) :: set0 -!! call set0 % from_string( bits_all ) -!! if ( bits(set0) /= 33 ) then -!! error stop "FROM_STRING failed to interpret " // & -!! 'BITS_ALL's size properly." -!! else if ( .not. set0 % all() ) then -!! error stop "FROM_STRING failed to interpret" // & -!! "BITS_ALL's value properly." -!! else -!! write(*,*) "FROM_STRING transferred BITS_ALL properly" // & -!! " into set0." -!! end if -!! end program demo_all -!! - import :: bitset_type - logical :: all - class(bitset_type), intent(in) :: self - end function all_abstract - - elemental function any_abstract(self) result(any) -!! Version: experimental -!! -!! Returns `.true.` if any bit in `self` is 1, `.false.` otherwise. -!! -!!#### Example -!! -!! ```fortran -!! program demo_any -!! use stdlib_bitsets -!! character(*), parameter :: & -!! bits_0 = '0000000000000000000' -!! type(bitset_64) :: set0 -!! call set0 % from_string( bits_0 ) -!! if ( .not. set0 % any() ) then -!! write(*,*) "FROM_STRING interpreted " // & -!! "BITS_0's value properly." -!! end if -!! call set0 % set(5) -!! if ( set0 % any() ) then -!! write(*,*) "ANY interpreted SET0's value properly." -!! end if -!! end program demo_any -!! - import :: bitset_type - logical :: any - class(bitset_type), intent(in) :: self - end function any_abstract - - elemental function bit_count_abstract(self) result(bit_count) -!! Version: experimental -!! -!! Returns the number of non-zero bits in `self`. -!! -!!#### Example -!! -!! ```fortran -!! program demo_bit_count -!! use stdlib_bitsets -!! character(*), parameter :: & -!! bits_0 = '0000000000000000000' -!! type(bitset_64) :: set0 -!! call set0 % from_string( bits_0 ) -!! if ( set0 % bit_count() == 0 ) then -!! write(*,*) "FROM_STRING interpreted " // & -!! "BITS_0's value properly." -!! end if -!! call set0 % set(5) -!! if ( set0 % bit_count() == 1 ) then -!! write(*,*) "BIT_COUNT interpreted SET0's value properly." -!! end if -!! end program demo_bit_count -!! - import :: bitset_type, bits_kind - integer(bits_kind) :: bit_count - class(bitset_type), intent(in) :: self - end function bit_count_abstract - - elemental subroutine clear_bit_abstract(self, pos) -!! Version: experimental -!! -!! Sets to zero the `pos` position in `self`. If `pos` is less than zero or -!! greater than `bits(self)-1` it is ignored. -!! -!!#### Example -!! -!! ```fortran -!! program demo_clear -!! use stdlib_bitsets -!! type(bitset_large) :: set0 -!! call set0 % init(166) -!! call set0 % not() -!! if ( set0 % all() ) write(*,*) 'SET0 is properly initialized.' -!! call set0 % clear(165) -!! if ( .not. set0 % test(165) ) write(*,*) 'Bit 165 is cleared.' -!! call set0 % clear(0,164) -!! if ( set0 % none() ) write(*,*) 'All bits are cleared.' -!! end program demo_clear -!! - import :: bitset_type, bits_kind - class(bitset_type), intent(inout) :: self - integer(bits_kind), intent(in) :: pos - end subroutine clear_bit_abstract - - pure subroutine clear_range_abstract(self, start_pos, stop_pos) -!! Version: experimental -!! -!! Sets to zero all bits from the `start_pos` to `stop_pos` positions in `set`. -!! If `stop_pos < start_pos` then no bits are modified. Positions outside -!! the range 0 to `bits(self)-1` are ignored. - import :: bitset_type, bits_kind - class(bitset_type), intent(inout) :: self - integer(bits_kind), intent(in) :: start_pos, stop_pos - end subroutine clear_range_abstract - - elemental subroutine flip_bit_abstract(self, pos) -!! Version: experimental -!! -!! Flips the value at the `pos` position in `self`, provided the position is -!! valid. If `pos` is less than 0 or greater than `bits(self)-1`, no value is -!! changed. -!! -!!#### Example -!! -!! ```fortran -!! program demo_flip -!! use stdlib_bitsets -!! type(bitset_large) :: set0 -!! call set0 % init(166) -!! if ( set0 % none() ) write(*,*) 'SET0 is properly initialized.' -!! call set0 % flip(165) -!! if ( set0 % test(165) ) write(*,*) 'Bit 165 is flipped.' -!! call set0 % flip(0,164) -!! if ( set0 % all() ) write(*,*) 'All bits are flipped.' -!! end program demo_flip -!! - import :: bitset_type, bits_kind - class(bitset_type), intent(inout) :: self - integer(bits_kind), intent(in) :: pos - end subroutine flip_bit_abstract - - pure subroutine flip_range_abstract(self, start_pos, stop_pos) -!! Version: experimental -!! -!! Flips all valid bits from the `start_pos` to the `stop_pos` positions in -!! `self`. If `stop_pos < start_pos` no bits are flipped. Positions less than -!! 0 or greater than `bits(self)-1` are ignored. - import :: bitset_type, bits_kind - class(bitset_type), intent(inout) :: self - integer(bits_kind), intent(in) :: start_pos, stop_pos - end subroutine flip_range_abstract - - subroutine from_string_abstract(self, string, status) -!! Version: experimental -!! -!! Initializes the bitset `self` treating `string` as a binary literal -!! `status` may have the values `success`, `alloc_fault`, -!! `array_size_invalid_error`, or `char_string_invalid`. -!! -!!#### Example -!! -!! ```fortran -!! program demo_from_string -!! use stdlib_bitsets -!! character(*), parameter :: & -!! bits_all = '111111111111111111111111111111111' -!! type(bitset_64) :: set0 -!! call set0 % from_string( bits_all ) -!! if ( bits(set0) /= 33 ) then -!! error stop "FROM_STRING failed to interpret " // & -!! 'BITS_ALL's size properly." -!! else if ( .not. set0 % all() ) then -!! error stop "FROM_STRING failed to interpret" // & -!! "BITS_ALL's value properly." -!! else -!! write(*,*) "FROM_STRING transferred BITS_ALL properly" // & -!! " into set0." -!! end if -!! end program demo_from_string -!! - import :: bitset_type - class(bitset_type), intent(out) :: self - character(*), intent(in) :: string - integer, intent(out), optional :: status - end subroutine from_string_abstract - - subroutine init_zero_abstract(self, bits, status) -!! Creates the bitset, `self`, of size `bits`, with all bits initialized to -!! zero. `bits` must be non-negative. If an error occurs and `status` is -!! absent then processing stops with an informative stop code. `status` -!! has a default value of `success`. If an error occurs it has the value -!! `array_size_invalid_error` if `bits` is either negative or larger than 64 -!! if `self` is class `bitset_64`, or the value `alloc_fault` if it failed -!! during allocation of memory for `self`. -!! -!!#### Example -!! -!! ```fortran -!! program demo_init -!! use stdlib_bitsets -!! type(bitset_large) :: set0 -!! call set0 % init(166) -!! if ( set0 % bits() == 166 ) & -!! write(*,*) `SET0 has the proper size.' -!! if ( set0 % none() ) write(*,*) 'SET0 is properly initialized.' -!! end program demo_init -!! - import :: bitset_type, bits_kind - class(bitset_type), intent(out) :: self - integer(bits_kind), intent(in) :: bits - integer, intent(out), optional :: status - end subroutine init_zero_abstract - - subroutine input_abstract(self, unit, status) -!! Version: experimental -!! -!! Reads the components of the bitset, `self`, from the unformatted I/O -!! unit, `unit`, assuming that the components were written using `output`. -!! If an error occurs and `status` is absent then processing stops with -!! an informative stop code. `status` has a default value of `success`. -!! If an error occurs it has the value `read_failure` if it failed -!! during the reads from `unit` or the value `alloc_fault` if it failed -!! during allocation of memory for `self`, or the value -!! `array_size_invalid_error` if the `bits(self)` in `unit` is less than 0 -!! or greater than 64 for a `bitset_64` input. -!! -!!#### Example -!! -!! ```fortran -!! program demo_input -!! character(*), parameter :: & -!! bits_0 = '000000000000000000000000000000000', & -!! bits_1 = '000000000000000000000000000000001', & -!! bits_33 = '100000000000000000000000000000000' -!! integer :: unit -!! type(bitset_64) :: set0, set1, set2, set3, set4, set5 -!! call set0 % from_string( bits_0 ) -!! call set1 % from_string( bits_1 ) -!! call set2 % from_string( bits_33 ) -!! open( newunit=unit, file='test.bin', status='replace', & -!! form='unformatted', action='write' ) -!! call set2 % output(unit) -!! call set1 % output(unit) -!! call set0 % output(unit) -!! close( unit ) -!! open( newunit=unit, file='test.bin', status='old', & -!! form='unformatted', action='read' ) -!! call set5 % input(unit) -!! call set4 % input(unit) -!! call set3 % input(unit) -!! close( unit ) -!! if ( set3 /= set0 .or. set4 /= set1 .or. set5 /= set2 ) then -!! error stop 'Transfer to and from units using ' // & -!! ' output and input failed.' -!! else -!! write(*,*) 'Transfer to and from units using ' // & -!! 'output and input succeeded.' -!! end if -!! end program demo_input -!! - import :: bitset_type - class(bitset_type), intent(out) :: self - integer, intent(in) :: unit - integer, intent(out), optional :: status - end subroutine input_abstract - - elemental function none_abstract(self) result(none) -!! Version: experimental -!! -!! Returns `.true.` if none of the bits in `self` have the value 1. -!! -!!#### Example -!! -!! ```fortran -!! program demo_none -!! use stdlib_bitsets -!! character(*), parameter :: & -!! bits_0 = '0000000000000000000' -!! type(bitset_large) :: set0 -!! call set0 % from_string( bits_0 ) -!! if ( set0 % none() ) then -!! write(*,*) "FROM_STRING interpreted " // & -!! "BITS_0's value properly." -!! end if -!! call set0 % set(5) -!! if ( .not. set0 % none() ) then -!! write(*,*) "NONE interpreted SET0's value properly." -!! end if -!! end program demo_none -!! - import :: bitset_type - logical :: none - class(bitset_type), intent(in) :: self - end function none_abstract - - elemental subroutine not_abstract(self) -!! Version: experimental -!! -!! Sets the bits in `self` to their logical complement -!! -!!#### Example -!! -!! ```fortran -!! program demo_not -!! use stdlib_bitsets -!! type(bitset_large) :: set0 -!! call set0 % init( 155 ) -!! if ( set0 % none() ) then -!! write(*,*) "FROM_STRING interpreted " // & -!! "BITS_0's value properly." -!! end if -!! call set0 % not() -!! if ( set0 % all() ) then -!! write(*,*) "ALL interpreted SET0's value properly." -!! end if -!! end program demo_not -!! - import :: bitset_type - class(bitset_type), intent(inout) :: self - end subroutine not_abstract - - subroutine output_abstract(self, unit, status) -!! Version: experimental -!! -!! Writes the components of the bitset, `self`, to the unformatted I/O -!! unit, `unit`, in a unformatted sequence compatible with `input`. If -!! `status` is absent an error results in an error stop with an -!! informative stop code. If `status` is present it has the default -!! value of `success`, or the value `write_failure` if the write failed. -!! -!!#### Example -!! -!! ```fortran -!! program demo_output -!! character(*), parameter :: & -!! bits_0 = '000000000000000000000000000000000', & -!! bits_1 = '000000000000000000000000000000001', & -!! bits_33 = '100000000000000000000000000000000' -!! integer :: unit -!! type(bitset_64) :: set0, set1, set2, set3, set4, set5 -!! call set0 % from_string( bits_0 ) -!! call set1 % from_string( bits_1 ) -!! call set2 % from_string( bits_33 ) -!! open( newunit=unit, file='test.bin', status='replace', & -!! form='unformatted', action='write' ) -!! call set2 % output(unit) -!! call set1 % output(unit) -!! call set0 % output(unit) -!! close( unit ) -!! open( newunit=unit, file='test.bin', status='old', & -!! form='unformatted', action='read' ) -!! call set5 % input(unit) -!! call set4 % input(unit) -!! call set3 % input(unit) -!! close( unit ) -!! if ( set3 /= set0 .or. set4 /= set1 .or. set5 /= set2 ) then -!! error stop 'Transfer to and from units using ' // & -!! ' output and input failed.' -!! else -!! write(*,*) 'Transfer to and from units using ' // & -!! 'output and input succeeded.' -!! end if -!! end program demo_output -!! - import :: bitset_type - class(bitset_type), intent(in) :: self - integer, intent(in) :: unit - integer, intent(out), optional :: status - end subroutine output_abstract - - subroutine read_bitset_string_abstract(self, string, status) -!! Version: experimental -!! -!! Uses the bitset literal in the default character `string`, to define -!! the bitset, `self`. The literal may be preceded by an an arbitrary -!! sequence of blank characters. If `status` is absent an error results -!! in an error stop with an informative stop code. If `status` is -!! present it has the default value of `success`, the value -!! `integer_overflow_error` if the bitset literal has a `bits(self)` value -!! too large to be represented, the value `alloc_fault` if allocation of -!! memory for `self` failed, or `char_string_invalid_error` if the bitset -!! literal has an invlaaid character, or `array_size_invalid_error` if -!! `bits(self)` in `string` is greater than 64 for a `bitset_64`. -!! -!!#### Example -!! -!! ```fortran -!! program demo_read_bitset -!! character(*), parameter :: & -!! bits_0 = 'S33B000000000000000000000000000000000', & -!! bits_1 = 'S33B000000000000000000000000000000001', & -!! bits_33 = 'S33B100000000000000000000000000000000' -!! character(:), allocatable :: test_0, test_1, test_2 -!! integer :: unit -!! type(bitset_64) :: set0, set1, set2, set3, set4, set5 -!! call set0 % read_bitset( bits_0, status ) -!! call set1 % read_bitset( bits_1, status ) -!! call set2 % read_bitset( bits_2, status ) -!! call set0 % write_bitset( test_0, status ) -!! call set1 % write_bitset( test_1, status ) -!! call set2 % write_bitset( test_2, status ) -!! if ( bits_0 == test_0 .and. bits_1 == test_1 .and. & -!! bits_2 == test_2 ) then -!! write(*,*) 'READ_BITSET to WRITE_BITSET strings worked.' -!! end if -!! open( newunit=unit, file='test.txt', status='replace', & -!! form='formatted', action='write' ) -!! call set2 % write_bitset(unit, advance='no') -!! call set1 % write_bitset(unit, advance='no') -!! call set0 % write_bitset(unit) -!! close( unit ) -!! open( newunit=unit, file='test.txt', status='old', & -!! form='formatted', action='read' ) -!! call set3 % read_bitset(unit, advance='no') -!! call set4 % read_bitset(unit, advance='no') -!! call set5 % read_bitset(unit) -!! if ( set3 == set0 .and. set4 == set1 .and. set5 == set2 ) then -!! write(*,*) WRITE_BITSET to READ_BITSET through unit worked.' -!! end if -!! end program demo_read_bitset -!! - import :: bitset_type - class(bitset_type), intent(out) :: self - character(len=*), intent(in) :: string - integer, intent(out), optional :: status - end subroutine read_bitset_string_abstract - - subroutine read_bitset_unit_abstract(self, unit, advance, status) -!! Version: experimental -!! -!! Uses the bitset literal at the current position in the formatted -!! file with I/O unit, `unit`, to define the bitset, `self`. The literal -!! may be preceded by an an arbitrary sequence of blank characters. -!! If `advance` is present it must be either 'YES' or 'NO'. If absent -!! it has the default value of 'YES' to determine whether advancing -!! I/O occurs. If `status` is absent an error results in an error stop -!! with an informative stop code. If `status` is present it has the -!! default value of `success`, the value `integer_overflow_error` if the -!! bitset literal has a `bits(self)` value too large to be -!! represented, the value `read_failure` if a `read` statement fails, -!! `eof_failure` if a `read` statement reaches an end-of-file before -!! completing the read of the bitset literal, or the value -!! `char_string_invalid_error` if the read of the bitset literal found -!! an invalid character, or `array_size_invalid_error` if `bits(self)` -!! in `string` is greater than 64 for a `bitset_64`. - import :: bitset_type - class(bitset_type), intent(out) :: self - integer, intent(in) :: unit - character(*), intent(in), optional :: advance - integer, intent(out), optional :: status - end subroutine read_bitset_unit_abstract - - elemental subroutine set_bit_abstract(self, pos) -!! Version: experimental -!! -!! Sets the value at the `pos` position in `self`, provided the position is -!! valid. If the position is less than 0 or greater than `bits(self)-1` -!! then `self` is unchanged. -!! -!!#### Example -!! -!! ```fortran -!! program demo_set -!! use stdlib_bitsets -!! type(bitset_large) :: set0 -!! call set0 % init(166) -!! if ( set0 % none() ) write(*,*) 'SET0 is properly initialized.' -!! call set0 % set(165) -!! if ( set0 % test(165) ) write(*,*) 'Bit 165 is set.' -!! call set0 % set(0,164) -!! if ( set0 % all() ) write(*,*) 'All bits are set.' -!! end program demo_set -!! - import :: bitset_type, bits_kind - class(bitset_type), intent(inout) :: self - integer(bits_kind), intent(in) :: pos - end subroutine set_bit_abstract - - pure subroutine set_range_abstract(self, start_pos, stop_pos) -!! Version: experimental -!! -!! Sets all valid bits to 1 from the `start_pos` to the `stop_pos` positions -!! in `self`. If `stop_pos < start_pos` no bits are changed. Positions outside -!! the range 0 to `bits(self)-1` are ignored. - import :: bitset_type, bits_kind - class(bitset_type), intent(inout) :: self - integer(bits_kind), intent(in) :: start_pos, stop_pos - end subroutine set_range_abstract - - elemental function test_abstract(self, pos) result(test) -!! Version: experimental -!! -!! Returns `.true.` if the `pos` position is set, `.false.` otherwise. If `pos` -!! is negative or greater than `bits(self) - 1` the result is `.false.`. -!! -!!#### Example -!! -!! ```fortran -!! program demo_test -!! use stdlib_bitsets -!! type(bitset_large) :: set0 -!! call set0 % init(166) -!! call set0 % not() -!! if ( set0 % all() ) write(*,*) 'SET0 is properly initialized.' -!! call set0 % clear(165) -!! if ( .not. set0 % test(165) ) write(*,*) 'Bit 165 is cleared.' -!! call set0 % set(165) -!! if ( set0 % test(165) ) write(*,*) 'Bit 165 is set.' -!! end program demo_test -!! - import :: bitset_type, bits_kind - logical :: test - class(bitset_type), intent(in) :: self - integer(bits_kind), intent(in) :: pos - end function test_abstract - - subroutine to_string_abstract(self, string, status) -!! Version: experimental -!! -!! Represents the value of `self` as a binary literal in `string` -!! Status may have the values `success` or `alloc_fault`. -!! -!!#### Example -!! -!! ```fortran -!! program demo_to_string -!! use stdlib_bitsets -!! character(*), parameter :: & -!! bits_all = '111111111111111111111111111111111' -!! type(bitset_64) :: set0 -!! character(:), allocatable :: new_string -!! call set0 % init(33) -!! call set0 % not() -!! call set0 % to_string( new_string ) -!! if ( new_string == bits_all ) then -!! write(*,*) "TO_STRING transferred BITS0 properly" // & -!! " into NEW_STRING." -!! end if -!! end program demo_to_string -!! - import :: bitset_type - class(bitset_type), intent(in) :: self - character(:), allocatable, intent(out) :: string - integer, intent(out), optional :: status - end subroutine to_string_abstract - - elemental function value_abstract(self, pos) result(value) -!! Version: experimental -!! -!! Returns 1 if the `pos` position is set, 0 otherwise. If `pos` is negative -!! or greater than `bits(set) - 1` the result is 0. -!! -!!#### Example -!! -!! ```fortran -!! program demo_value -!! use stdlib_bitsets -!! type(bitset_large) :: set0 -!! call set0 % init(166) -!! call set0 % not() -!! if ( set0 % all() ) write(*,*) 'SET0 is properly initialized.' -!! call set0 % clear(165) -!! if ( set0 % value(165) == 0 ) write(*,*) 'Bit 165 is cleared.' -!! call set0 % set(165) -!! if ( set0 % value(165) == 1 ) write(*,*) 'Bit 165 is set.' -!! end program demo_value -!! - import :: bitset_type, bits_kind - integer :: value - class(bitset_type), intent(in) :: self - integer(bits_kind), intent(in) :: pos - end function value_abstract - - subroutine write_bitset_string_abstract(self, string, status) -!! Version: experimental -!! -!! Writes a bitset literal to the allocatable default character `string`, -!! representing the individual bit values in the `bitset_type`, `self`. -!! If `status` is absent an error results in an error stop with an -!! informative stop code. If `status` is present it has the default -!! value of `success`, or the value `alloc_fault` if allocation of -!! the output string failed. -!! -!!#### Example -!! -!! ```fortran -!! program demo_write_bitset -!! character(*), parameter :: & -!! bits_0 = 'S33B000000000000000000000000000000000', & -!! bits_1 = 'S33B000000000000000000000000000000001', & -!! bits_33 = 'S33B100000000000000000000000000000000' -!! character(:), allocatable :: test_0, test_1, test_2 -!! integer :: unit -!! type(bitset_64) :: set0, set1, set2, set3, set4, set5 -!! call set0 % read_bitset( bits_0, status ) -!! call set1 % read_bitset( bits_1, status ) -!! call set2 % read_bitset( bits_2, status ) -!! call set0 % write_bitset( test_0, status ) -!! call set1 % write_bitset( test_1, status ) -!! call set2 % write_bitset( test_2, status ) -!! if ( bits_0 == test_0 .and. bits_1 == test_1 .and. & -!! bits_2 == test_2 ) then -!! write(*,*) 'READ_BITSET to WRITE_BITSET strings worked.' -!! end if -!! open( newunit=unit, file='test.txt', status='replace', & -!! form='formatted', action='write' ) -!! call set2 % write_bitset(unit, advance='no') -!! call set1 % write_bitset(unit, advance='no') -!! call set0 % write_bitset(unit) -!! close( unit ) -!! open( newunit=unit, file='test.txt', status='old', & -!! form='formatted', action='read' ) -!! call set3 % read_bitset(unit, advance='no') -!! call set4 % read_bitset(unit, advance='no') -!! call set5 % read_bitset(unit) -!! if ( set3 == set0 .and. set4 == set1 .and. set5 == set2 ) then -!! write(*,*) WRITE_BITSET to READ_BITSET through unit worked.' -!! end if -!! end program demo_write_bitset -!! - import :: bitset_type - class(bitset_type), intent(in) :: self - character(len=:), allocatable, intent(out) :: string - integer, intent(out), optional :: status - end subroutine write_bitset_string_abstract - - subroutine write_bitset_unit_abstract(self, unit, advance, & - status) -!! Version: experimental -!! -!! Writes a bitset literal to the I/O unit, `unit`, representing the -!! individual bit values in the `bitset_t`, `self`. If an error occurs then -!! processing stops with a message to `error_unit`. By default or if -!! `advance` is present with the value 'YES', advancing output is used. -!! If `advance` is present with the value 'NO', then the current record -!! is not advanced by the write. If `status` is absent, an error results -!! in an error stop with an informative stop code. If `status` is -!! present it has the default value of `success`, the value -!! `alloc_fault` if allocation of the output string failed, -!! `write_failure` if the `write` statement outputting the literal failed. - import :: bitset_type - class(bitset_type), intent(in) :: self - integer, intent(in) :: unit - character(len=*), intent(in), optional :: advance - integer, intent(out), optional :: status - end subroutine write_bitset_unit_abstract - - end interface - - type, extends(bitset_type) :: bitset_large -!! Version: experimental -!! -!! Type for bitsets with more than 64 bits. - private - integer(block_kind), private, allocatable :: blocks(:) - - contains - - procedure, pass(self) :: all => all_large - procedure, pass(self) :: any => any_large - procedure, pass(self) :: bit_count => bit_count_large - procedure, pass(self) :: clear_bit => clear_bit_large - procedure, pass(self) :: clear_range => clear_range_large - procedure, pass(self) :: flip_bit => flip_bit_large - procedure, pass(self) :: flip_range => flip_range_large - procedure, pass(self) :: from_string => from_string_large - procedure, pass(self) :: init_zero => init_zero_large - procedure, pass(self) :: input => input_large - procedure, pass(self) :: none => none_large - procedure, pass(self) :: not => not_large - procedure, pass(self) :: output => output_large - procedure, pass(self) :: & - read_bitset_string => read_bitset_string_large - procedure, pass(self) :: read_bitset_unit => read_bitset_unit_large - procedure, pass(self) :: set_bit => set_bit_large - procedure, pass(self) :: set_range => set_range_large - procedure, pass(self) :: test => test_large - procedure, pass(self) :: to_string => to_string_large - procedure, pass(self) :: value => value_large - procedure, pass(self) :: & - write_bitset_string => write_bitset_string_large - procedure, pass(self) :: write_bitset_unit => write_bitset_unit_large - - end type bitset_large - - - interface - - elemental module function all_large( self ) result(all) -!! Version: experimental -!! -!! Returns `.true.` if all bits in `self` are 1, `.false.` otherwise. - logical :: all - class(bitset_large), intent(in) :: self - end function all_large - - elemental module function any_large(self) result(any) -!! Version: experimental -!! -!! Returns `.true.` if any bit in `self` is 1, `.false.` otherwise. - logical :: any - class(bitset_large), intent(in) :: self - end function any_large - - elemental module function bit_count_large(self) result(bit_count) -!! Version: experimental -!! -!! Returns the number of non-zero bits in `self`. - integer(bits_kind) :: bit_count - class(bitset_large), intent(in) :: self - end function bit_count_large - - elemental module subroutine clear_bit_large(self, pos) -!! Version: experimental -!! -!! Sets to zero the bit at `pos` position in `self`. If 'pos` is less than -!! zero or greater than `bits(self)-1` it is ignored. - class(bitset_large), intent(inout) :: self - integer(bits_kind), intent(in) :: pos - end subroutine clear_bit_large - - pure module subroutine clear_range_large(self, start_pos, stop_pos) -!! Version: experimental -!! -!! Sets to zero all bits from the `start_pos` to `stop_pos` positions in `self`. -!! If `stop_pos < start_pos` then no bits are modified. Positions outside -!! the range 0 to `bits(set)-1` are ignored. - class(bitset_large), intent(inout) :: self - integer(bits_kind), intent(in) :: start_pos, stop_pos - end subroutine clear_range_large - - elemental module subroutine flip_bit_large(self, pos) -!! Version: experimental -!! -!! Flips the bit value at the `pos` position in `self`, provided the position is -!! valid. If `pos` is less than 0 or greater than `bits(self)-1`, no value is -!! changed. - class(bitset_large), intent(inout) :: self - integer(bits_kind), intent(in) :: pos - end subroutine flip_bit_large - - pure module subroutine flip_range_large(self, start_pos, stop_pos) -!! Version: experimental -!! -!! Flips all valid bits from the `start_pos` to the `stop_pos` positions in -!! `self`. If `stop_pos < start_pos` no bits are flipped. Positions less than -!! 0 or greater than `bits(self)-1` are ignored. - class(bitset_large), intent(inout) :: self - integer(bits_kind), intent(in) :: start_pos, stop_pos - end subroutine flip_range_large - - module subroutine from_string_large(self, string, status) -!! Version: experimental -!! -!! Initializes the bitset `self` treating `string` as a binary literal -!! `status` may have the values `success`, `alloc_fault`, -!! `array_size_invalid_error`, or `char_string_invalid`. - class(bitset_large), intent(out) :: self - character(*), intent(in) :: string - integer, intent(out), optional :: status - end subroutine from_string_large - - module subroutine init_zero_large(self, bits, status) -!! Version: experimental -!! -!! Creates the bitset, `self`, of size `bits`, with all bits initialized to -!! zero. `bits` must be non-negative. If an error occurs and `status` is -!! absent then processing stops with an informative stop code. `status` -!! has a default value of `success`. If an error occurs it has the value -!! `array_size_invalid_error` if `bits` is either negative larger than 64 -!! if `self` is of type `bitset_64`, or the value `alloc_fault` if it failed -!! during allocation of memory for `self`. - class(bitset_large), intent(out) :: self - integer(bits_kind), intent(in) :: bits - integer, intent(out), optional :: status - end subroutine init_zero_large - - module subroutine input_large(self, unit, status) -!! Version: experimental -!! -!! Reads the components of the bitset, `self`, from the unformatted I/O -!! unit, `unit`, assuming that the components were written using `output`. -!! If an error occurs and `status` is absent then processing stops with -!! an informative stop code. `status` has a default value of `success`. -!! If an error occurs it has the value `read_failure` if it failed -!! during the reads from `unit` or the value `alloc_fault` if it failed -!! during allocation of memory for `self`, or the value -!! `array_size_invalid_error if the `bits(self) in `unit` is less than 0 -!! or greater than 64 for a `bitset_64` input. - class(bitset_large), intent(out) :: self - integer, intent(in) :: unit - integer, intent(out), optional :: status - end subroutine input_large - - elemental module function none_large(self) result(none) -!! Version: experimental -!! -!! Returns `.true.` if none of the bits in `self` have the value 1. - logical :: none - class(bitset_large), intent(in) :: self - end function none_large - - elemental module subroutine not_large(self) -!! Version: experimental -!! -!! Sets the bits in `self` to their logical complement - class(bitset_large), intent(inout) :: self - end subroutine not_large - - module subroutine output_large(self, unit, status) -!! Version: experimental -!! -!! Writes the components of the bitset, `self`, to the unformatted I/O -!! unit, `unit`, in a unformatted sequence compatible with `input`. If -!! `status` is absent an error results in an error stop with an -!! informative stop code. If `status` is present it has the default -!! value of `success`, or the value `write_failure` if the write failed. - class(bitset_large), intent(in) :: self - integer, intent(in) :: unit - integer, intent(out), optional :: status - end subroutine output_large - - module subroutine read_bitset_string_large(self, string, status) -!! Version: experimental -!! -!! Uses the bitset literal in the default character `string`, to define -!! the bitset, `self`. The literal may be preceded by an an arbitrary -!! sequence of blank characters. If `status` is absent an error results -!! in an error stop with an informative stop code. If `status` is -!! present it has the default value of `success`, the value -!! `integer_overflow_error` if the bitset literal has a `bits(self)` value -!! too large to be represented, the value `alloc_fault` if allocation of -!! memory for `self` failed, or `char_string_invalid_error` if the bitset -!! literal has an invlaid character, or `array_size_invalid_error` if -!! `bits(self)` in `string` is greater than 64 for a `bitset_64`, or -!! `char_string_too_small_error` if the string ends before all the bits -!! are read. - class(bitset_large), intent(out) :: self - character(len=*), intent(in) :: string - integer, intent(out), optional :: status - end subroutine read_bitset_string_large - - module subroutine read_bitset_unit_large(self, unit, advance, status) -!! Version: experimental -!! -!! Uses the bitset literal at the current position in the formatted -!! file with I/O unit, `unit`, to define the bitset, `self`. The literal -!! may be preceded by an an arbitrary sequence of blank characters. -!! If `advance` is present it must be either 'YES' or 'NO'. If absent -!! it has the default value of 'YES' to determine whether advancing -!! I/O occurs. If `status` is absent an error results in an error stop -!! with an informative stop code. If `status` is present it has the -!! default value of `success`, the value `integer_overflow_error` if the -!! bitset literal has a `bits(self)` value too large to be -!! represented, the value `read_failure` if a `read` statement fails, -!! `eof_failure` if a `read` statement reach an end-of-file before -!! completing the read of the bitset literal, or the value -!! `char_string_invalid_error` if the read of the bitset literal found -!! an invalid character, or `array_size_invalid_error` if `bits(self)` -!! in `string` is greater than 64 for a `bitset_64`. - class(bitset_large), intent(out) :: self - integer, intent(in) :: unit - character(*), intent(in), optional :: advance - integer, intent(out), optional :: status - end subroutine read_bitset_unit_large - - elemental module subroutine set_bit_large(self, pos) -!! Version: experimental -!! -!! Sets the value at the `pos` position in `self`, provided the position is -!! valid. If the position is less than 0 or greater than `bits(self)-1` -!! then `self` is unchanged. - class(bitset_large), intent(inout) :: self - integer(bits_kind), intent(in) :: pos - end subroutine set_bit_large - - pure module subroutine set_range_large(self, start_pos, stop_pos) -!! Version: experimental -!! -!! Sets all valid bits to 1 from the `start_pos` to the `stop_pos` positions -!! in `self`. If `stop_pos < start_pos` no bits are changed. Positions outside -!! the range 0 to `bits(self)-1` are ignored. - class(bitset_large), intent(inout) :: self - integer(bits_kind), intent(in) :: start_pos, stop_pos - end subroutine set_range_large - - elemental module function test_large(self, pos) result(test) -!! Version: experimental -!! -!! Returns `.true.` if the `pos` position is set, `.false.` otherwise. If `pos` -!! is negative or greater than `bits(self) - 1` the result is `.false.`. - logical :: test - class(bitset_large), intent(in) :: self - integer(bits_kind), intent(in) :: pos - end function test_large - - module subroutine to_string_large(self, string, status) -!! Version: experimental -!! -!! Represents the value of `self` as a binary literal in `string` -!! Status may have the values `success` or `alloc_fault`. - class(bitset_large), intent(in) :: self - character(len=:), allocatable, intent(out) :: string - integer, intent(out), optional :: status - end subroutine to_string_large - - elemental module function value_large(self, pos) result(value) -!! Version: experimental -!! -!! Returns 1 if the `pos` position is set, 0 otherwise. If `pos` is negative -!! or greater than `bits(set) - 1` the result is 0. - integer :: value - class(bitset_large), intent(in) :: self - integer(bits_kind), intent(in) :: pos - end function value_large - - module subroutine write_bitset_string_large(self, string, status) -!! Version: experimental -!! -!! Writes a bitset literal to the allocatable default character `string`, -!! representing the individual bit values in the bitset_large, `self`. -!! If `status` is absent an error results in an error stop with an -!! informative stop code. If `status` is present it has the default -!! value of `success, or the value `alloc_fault` if allocation of -!! the output string failed. - class(bitset_large), intent(in) :: self - character(len=:), allocatable, intent(out) :: string - integer, intent(out), optional :: status - end subroutine write_bitset_string_large - - module subroutine write_bitset_unit_large(self, unit, advance, status) -!! Version: experimental -!! -!! Writes a bitset literal to the I/O unit, `unit`, representing the -!! individual bit values in the bitset, `self`. By default or if -!! `advance` is present with the value 'YES', advancing output is used. -!! If `advance` is present with the value 'NO', then the current record -!! is not advanced by the write. If `status` is absent an error results -!! in an error stop with an informative stop code. If `status` is -!! present it has the default value of `success`, the value -!! `alloc_fault` if allocation of the output string failed, or -!! `write_failure` if the `write` statement outputting the literal failed. - class(bitset_large), intent(in) :: self - integer, intent(in) :: unit - character(len=*), intent(in), optional :: advance - integer, intent(out), optional :: status - end subroutine write_bitset_unit_large - - end interface - - - interface assignment(=) -!! -!!#### Example -!! -!! ```fortran -!! program demo_assignment -!! use stdlib_bitsets -!! logical(int8) :: logical1(64) = .true. -!! logical(int32), allocatable :: logical2(:) -!! type(bitset_64) :: set0, set1 -!! set0 = logical1 -!! if ( set0 % bits() /= 64 ) then -!! error stop procedure // & -!! ' initialization with logical(int8) failed to set' // & -!! ' the right size.' -!! else if ( .not. set0 % all() ) then -!! error stop procedure // ' initialization with' // & -!! ' logical(int8) failed to set the right values.' -!! else -!! write(*,*) 'Initialization with logical(int8) succeeded.' -!! end if -!! set1 = set0 -!! if ( set1 == set0 ) & -!! write(*,*) 'Initialization by assignment succeeded' -!! logical2 = set1 -!! if ( all( logical2 ) ) then -!! write(*,*) 'Initialization of logical(int32) succeeded.' -!! end if -!! end program demo_assignment -!! - - pure module subroutine assign_large( set1, set2 ) -!! Version: experimental -!! -!! Used to define assignment for `bitset_large`. - type(bitset_large), intent(out) :: set1 - type(bitset_large), intent(in) :: set2 - end subroutine assign_large - - pure module subroutine assign_logint8_large( self, logical_vector ) -!! Version: experimental -!! -!! Used to define assignment from an array of type `logical(int8)` to a -!! `bitset_large`. - type(bitset_large), intent(out) :: self - logical(int8), intent(in) :: logical_vector(:) - end subroutine assign_logint8_large - - pure module subroutine logint8_assign_large( logical_vector, set ) -!! Version: experimental -!! -!! Used to define assignment to an array of type `logical(int8)` from a -!! `bitset_large`. - logical(int8), intent(out), allocatable :: logical_vector(:) - type(bitset_large), intent(in) :: set - end subroutine logint8_assign_large - pure module subroutine assign_logint16_large( self, logical_vector ) -!! Version: experimental -!! -!! Used to define assignment from an array of type `logical(int16)` to a -!! `bitset_large`. - type(bitset_large), intent(out) :: self - logical(int16), intent(in) :: logical_vector(:) - end subroutine assign_logint16_large - - pure module subroutine logint16_assign_large( logical_vector, set ) -!! Version: experimental -!! -!! Used to define assignment to an array of type `logical(int16)` from a -!! `bitset_large`. - logical(int16), intent(out), allocatable :: logical_vector(:) - type(bitset_large), intent(in) :: set - end subroutine logint16_assign_large - pure module subroutine assign_logint32_large( self, logical_vector ) -!! Version: experimental -!! -!! Used to define assignment from an array of type `logical(int32)` to a -!! `bitset_large`. - type(bitset_large), intent(out) :: self - logical(int32), intent(in) :: logical_vector(:) - end subroutine assign_logint32_large - - pure module subroutine logint32_assign_large( logical_vector, set ) -!! Version: experimental -!! -!! Used to define assignment to an array of type `logical(int32)` from a -!! `bitset_large`. - logical(int32), intent(out), allocatable :: logical_vector(:) - type(bitset_large), intent(in) :: set - end subroutine logint32_assign_large - pure module subroutine assign_logint64_large( self, logical_vector ) -!! Version: experimental -!! -!! Used to define assignment from an array of type `logical(int64)` to a -!! `bitset_large`. - type(bitset_large), intent(out) :: self - logical(int64), intent(in) :: logical_vector(:) - end subroutine assign_logint64_large - - pure module subroutine logint64_assign_large( logical_vector, set ) -!! Version: experimental -!! -!! Used to define assignment to an array of type `logical(int64)` from a -!! `bitset_large`. - logical(int64), intent(out), allocatable :: logical_vector(:) - type(bitset_large), intent(in) :: set - end subroutine logint64_assign_large - - end interface assignment(=) - - - type, extends(bitset_type) :: bitset_64 -!! Version: experimental -!! -!! Type for bitsets with no more than 64 bits. - private - integer(block_kind), private :: block = 0 - - contains - - procedure, pass(self) :: all => all_64 - procedure, pass(self) :: any => any_64 - procedure, pass(self) :: bit_count => bit_count_64 - procedure, pass(self) :: clear_bit => clear_bit_64 - procedure, pass(self) :: clear_range => clear_range_64 - procedure, pass(self) :: flip_bit => flip_bit_64 - procedure, pass(self) :: flip_range => flip_range_64 - procedure, pass(self) :: from_string => from_string_64 - procedure, pass(self) :: init_zero => init_zero_64 - procedure, pass(self) :: input => input_64 - procedure, pass(self) :: none => none_64 - procedure, pass(self) :: not => not_64 - procedure, pass(self) :: output => output_64 - procedure, pass(self) :: read_bitset_string => read_bitset_string_64 - procedure, pass(self) :: read_bitset_unit => read_bitset_unit_64 - procedure, pass(self) :: set_bit => set_bit_64 - procedure, pass(self) :: set_range => set_range_64 - procedure, pass(self) :: test => test_64 - procedure, pass(self) :: to_string => to_string_64 - procedure, pass(self) :: value => value_64 - procedure, pass(self) :: write_bitset_string => write_bitset_string_64 - procedure, pass(self) :: write_bitset_unit => write_bitset_unit_64 - - end type bitset_64 - - - interface - - elemental module function all_64( self ) result(all) -!! Version: experimental -!! -!! Returns `.true.` if all bits in `self` are 1, `.false.` otherwise. - logical :: all - class(bitset_64), intent(in) :: self - end function all_64 - - elemental module function any_64(self) result(any) -!! Version: experimental -!! -!! Returns `.true.` if any bit in `self` is 1, `.false.` otherwise. - logical :: any - class(bitset_64), intent(in) :: self - end function any_64 - - elemental module function bit_count_64(self) result(bit_count) -!! Version: experimental -!! -!! Returns the number of non-zero bits in `self`. - integer(bits_kind) :: bit_count - class(bitset_64), intent(in) :: self - end function bit_count_64 - - elemental module subroutine clear_bit_64(self, pos) -!! Version: experimental -!! -!! Sets to zero the bit at `pos` position in `self`. If 'pos` is less than -!! zero or greater than `bits(self)-1` it is ignored. - class(bitset_64), intent(inout) :: self - integer(bits_kind), intent(in) :: pos - end subroutine clear_bit_64 - - pure module subroutine clear_range_64(self, start_pos, stop_pos) -!! Version: experimental -!! -!! Sets to zero all bits from the `start_pos` to `stop_pos` positions in `self`. -!! If `stop_pos < start_pos` then no bits are modified. Positions outside -!! the range 0 to `bits(set)-1` are ignored. - class(bitset_64), intent(inout) :: self - integer(bits_kind), intent(in) :: start_pos, stop_pos - end subroutine clear_range_64 - - elemental module subroutine flip_bit_64(self, pos) -!! Version: experimental -!! -!! Flips the bit value at the `pos` position in `self`, provided the position is -!! valid. If `pos` is less than 0 or greater than `bits(self)-1`, no value is -!! changed. - class(bitset_64), intent(inout) :: self - integer(bits_kind), intent(in) :: pos - end subroutine flip_bit_64 - - pure module subroutine flip_range_64(self, start_pos, stop_pos) -!! Version: experimental -!! -!! Flips all valid bits from the `start_pos` to the `stop_pos` positions in -!! `self`. If `stop_pos < start_pos` no bits are flipped. Positions less than -!! 0 or greater than `bits(self)-1` are ignored. - class(bitset_64), intent(inout) :: self - integer(bits_kind), intent(in) :: start_pos, stop_pos - end subroutine flip_range_64 - - module subroutine from_string_64(self, string, status) -!! Version: experimental -!! -!! Initializes the bitset `self` treating `string` as a binary literal -!! `status` has the default value `success`, the value `alloc_fault` if the -!! allocation of the bits in self failed, `array_size_invalid_error` if the -!! `len(string)>64` for a `bitset_64`, or `char_string_invalid` if an invalid -!! character was found in `string`. - class(bitset_64), intent(out) :: self - character(*), intent(in) :: string - integer, intent(out), optional :: status - end subroutine from_string_64 - - module subroutine init_zero_64(self, bits, status) -!! Version: experimental -!! -!! Creates the bitset, `self`, of size `bits`, with all bits initialized to -!! zero. `bits` must be non-negative. If an error occurs and `status` is -!! absent then processing stops with an informative stop code. `status` -!! has a default value of `success`. If an error occurs it has the value -!! `array_size_invalid_error` if `bits` is either negative larger than 64 -!! for `self` of type `bitset_64`, or the value `alloc_fault` if it failed -!! during allocation of memory for `self`. - class(bitset_64), intent(out) :: self - integer(bits_kind), intent(in) :: bits - integer, intent(out), optional :: status - end subroutine init_zero_64 - - module subroutine input_64(self, unit, status) -!! Version: experimental -!! -!! Reads the components of the bitset, `self`, from the unformatted I/O -!! unit, `unit`, assuming that the components were written using `output`. -!! If an error occurs and `status` is absent then processing stops with -!! an informative stop code. `status` has a default value of `success`. -!! If an error occurs it has the value `read_failure` if it failed -!! during the reads from `unit` or the value `alloc_fault` if it failed -!! during allocation of memory for `self`, or the value -!! `array_size_invalid_error` if the `bits(self)` in `unit` is less than 0 -!! or greater than 64 for a `bitset_64` input. - class(bitset_64), intent(out) :: self - integer, intent(in) :: unit - integer, intent(out), optional :: status - end subroutine input_64 - - elemental module function none_64(self) result(none) -!! Version: experimental -!! -!! Returns `.true.` if none of the bits in `self` have the value 1. - logical :: none - class(bitset_64), intent(in) :: self - end function none_64 - - elemental module subroutine not_64(self) -!! Version: experimental -!! -!! Sets the bits in `self` to their logical complement. - class(bitset_64), intent(inout) :: self - end subroutine not_64 - - module subroutine output_64(self, unit, status) -!! Version: experimental -!! -!! Writes the components of the bitset, `self`, to the unformatted I/O -!! unit, `unit`, in a unformatted sequence compatible with `input`. If -!! `status` is absent an error results in an error stop with an -!! informative stop code. If `status` is present it has the default -!! value of `success`, or the value `write_failure` if the write failed. - class(bitset_64), intent(in) :: self - integer, intent(in) :: unit - integer, intent(out), optional :: status - end subroutine output_64 - - module subroutine read_bitset_string_64(self, string, status) -!! Version: experimental -!! -!! Uses the bitset literal in the default character `string`, to define -!! the bitset, `self`. The literal may be preceded by an an arbitrary -!! sequence of blank characters. If `status` is absent an error results -!! in an error stop with an informative stop code. If `status` is -!! present it has the default value of `success`, the value -!! `integer_overflow_error` if the bitset literal has a `bits(self)` value -!! too large to be represented, the value `alloc_fault` if allocation of -!! memory for `self` failed, or `char_string_invalid_error` if the bitset -!! literal has an invlaid character, or `array_size_invalid_error` if -!! `bits(self)` in `string` is greater than 64 for a `bitset_64`, or -!! `char_string_too_small_error` if the string ends before all the bits -!! are read. - class(bitset_64), intent(out) :: self - character(len=*), intent(in) :: string - integer, intent(out), optional :: status - end subroutine read_bitset_string_64 - - module subroutine read_bitset_unit_64(self, unit, advance, status) -!! Version: experimental -!! -!! Uses the bitset literal at the current position in the formatted -!! file with I/O unit, `unit`, to define the bitset, `self`. The literal -!! may be preceded by an an arbitrary sequence of blank characters. -!! If `advance` is present it must be either 'YES' or 'NO'. If absent -!! it has the default value of 'YES' to determine whether advancing -!! I/O occurs. If `status` is absent an error results in an error stop -!! with an informative stop code. If `status` is present it has the -!! default value of `success`, the value `integer_overflow_error` if the -!! bitset literal has a `bits(self)` value too large to be -!! represented, the value `read_failure` if a `read` statement fails, -!! `eof_failure` if a `read` statement reach an end-of-file before -!! completing the read of the bitset literal, or the value -!! `char_string_invalid_error` if the read of the bitset literal found -!! an invalid character, or `array_size_invalid_error` if `bits(self)` -!! in `string` is greater than 64 for a `bitset_64`. - class(bitset_64), intent(out) :: self - integer, intent(in) :: unit - character(*), intent(in), optional :: advance - integer, intent(out), optional :: status - end subroutine read_bitset_unit_64 - - elemental module subroutine set_bit_64(self, pos) -!! Version: experimental -!! -!! Sets the value at the `pos` position in `self`, provided the position is -!! valid. If the position is less than 0 or greater than `bits(self)-1` -!! then `self` is unchanged. - class(bitset_64), intent(inout) :: self - integer(bits_kind), intent(in) :: pos - end subroutine set_bit_64 - - pure module subroutine set_range_64(self, start_pos, stop_pos) -!! Version: experimental -!! -!! Sets all valid bits to 1 from the `start_pos` to the `stop_pos` positions -!! in `self`. If `stop_pos < start_pos` no bits are changed. Positions outside -!! the range 0 to `bits(self)-1` are ignored. - class(bitset_64), intent(inout) :: self - integer(bits_kind), intent(in) :: start_pos, stop_pos - end subroutine set_range_64 - - elemental module function test_64(self, pos) result(test) -!! Version: experimental -!! -!! Returns `.true.` if the `pos` position is set, `.false.` otherwise. If `pos` -!! is negative or greater than `bits(self)-1` the result is `.false.`. - logical :: test - class(bitset_64), intent(in) :: self - integer(bits_kind), intent(in) :: pos - end function test_64 - - module subroutine to_string_64(self, string, status) -!! Version: experimental -!! -!! Represents the value of `self` as a binary literal in `string`. -!! Status may have the values `success` or `alloc_fault` - class(bitset_64), intent(in) :: self - character(len=:), allocatable, intent(out) :: string - integer, intent(out), optional :: status - end subroutine to_string_64 - - elemental module function value_64(self, pos) result(value) -!! Version: experimental -!! -!! Returns 1 if the `pos` position is set, 0 otherwise. If `pos` is negative -!! or greater than `bits(set)-1` the result is 0. - integer :: value - class(bitset_64), intent(in) :: self - integer(bits_kind), intent(in) :: pos - end function value_64 - - module subroutine write_bitset_string_64(self, string, status) -!! Version: experimental -!! -!! Writes a bitset literal to the allocatable default character `string`, -!! representing the individual bit values in the `bitset_64`, `self`. -!! If `status` is absent an error results in an error stop with an -!! informative stop code. If `status` is present it has the default -!! value of `success`, or the value `alloc_fault` if allocation of -!! the output string failed. - class(bitset_64), intent(in) :: self - character(len=:), allocatable, intent(out) :: string - integer, intent(out), optional :: status - end subroutine write_bitset_string_64 - - module subroutine write_bitset_unit_64(self, unit, advance, status) -!! Version: experimental -!! -!! Writes a bitset literal to the I/O unit, `unit`, representing the -!! individual bit values in the bitset, `self`. By default or if -!! `advance` is present with the value 'YES', advancing output is used. -!! If `advance` is present with the value 'NO', then the current record -!! is not advanced by the write. If `status` is absent an error results -!! in an error stop with an informative stop code. If `status` is -!! present it has the default value of `success`, the value -!! `alloc_fault` if allocation of the output string failed, or -!! `write_failure` if the `write` statement outputting the literal failed. - class(bitset_64), intent(in) :: self - integer, intent(in) :: unit - character(len=*), intent(in), optional :: advance - integer, intent(out), optional :: status - end subroutine write_bitset_unit_64 - - end interface - - - interface assignment(=) - - pure module subroutine assign_64( set1, set2 ) -!! Version: experimental -!! -!! Used to define assignment for `bitset_64`. - type(bitset_64), intent(out) :: set1 - type(bitset_64), intent(in) :: set2 - end subroutine assign_64 - - module subroutine assign_logint8_64( self, logical_vector ) -!! Version: experimental -!! -!! Used to define assignment from an array of type `logical(int8)` to a -!! `bitset_64`. - type(bitset_64), intent(out) :: self - logical(int8), intent(in) :: logical_vector(:) - end subroutine assign_logint8_64 - - pure module subroutine logint8_assign_64( logical_vector, set ) -!! Version: experimental -!! -!! Used to define assignment to an array of type `logical(int8)` from a -!! `bitset_64`. - logical(int8), intent(out), allocatable :: logical_vector(:) - type(bitset_64), intent(in) :: set - end subroutine logint8_assign_64 - module subroutine assign_logint16_64( self, logical_vector ) -!! Version: experimental -!! -!! Used to define assignment from an array of type `logical(int8)` to a -!! `bitset_64`. - type(bitset_64), intent(out) :: self - logical(int16), intent(in) :: logical_vector(:) - end subroutine assign_logint16_64 - - pure module subroutine logint16_assign_64( logical_vector, set ) -!! Version: experimental -!! -!! Used to define assignment to an array of type `logical(int8)` from a -!! `bitset_64`. - logical(int16), intent(out), allocatable :: logical_vector(:) - type(bitset_64), intent(in) :: set - end subroutine logint16_assign_64 - module subroutine assign_logint32_64( self, logical_vector ) -!! Version: experimental -!! -!! Used to define assignment from an array of type `logical(int8)` to a -!! `bitset_64`. - type(bitset_64), intent(out) :: self - logical(int32), intent(in) :: logical_vector(:) - end subroutine assign_logint32_64 - - pure module subroutine logint32_assign_64( logical_vector, set ) -!! Version: experimental -!! -!! Used to define assignment to an array of type `logical(int8)` from a -!! `bitset_64`. - logical(int32), intent(out), allocatable :: logical_vector(:) - type(bitset_64), intent(in) :: set - end subroutine logint32_assign_64 - module subroutine assign_logint64_64( self, logical_vector ) -!! Version: experimental -!! -!! Used to define assignment from an array of type `logical(int8)` to a -!! `bitset_64`. - type(bitset_64), intent(out) :: self - logical(int64), intent(in) :: logical_vector(:) - end subroutine assign_logint64_64 - - pure module subroutine logint64_assign_64( logical_vector, set ) -!! Version: experimental -!! -!! Used to define assignment to an array of type `logical(int8)` from a -!! `bitset_64`. - logical(int64), intent(out), allocatable :: logical_vector(:) - type(bitset_64), intent(in) :: set - end subroutine logint64_assign_64 - - end interface assignment(=) - - - interface and - - elemental module subroutine and_large(set1, set2) -!! Version: experimental -!! -!! Sets the bits in `set1` to the bitwise `and` of the original bits in `set1` -!! and `set2`. The sets mmust have the same number of bits -!! otherwise the result is undefined. -!! -!!#### Example -!! -!! ```fortran -!! program demo_and -!! use stdlib_bitsets -!! type(bitset_large) :: set0, set1 -!! call set0 % init(166) -!! call set1 % init(166) -!! call and( set0, set1 ) ! none none -!! if ( none(set0) ) write(*,*) 'First test of AND worked.' -!! call set0 % not() -!! call and( set0, set1 ) ! all none -!! if ( none(set0) ) write(*,*) 'Second test of AND worked.' -!! call set1 % not() -!! call and( set0, set1 ) ! none all -!! if ( none(set0) ) write(*,*) 'Third test of AND worked.' -!! call set0 % not() -!! call and( set0, set1 ) ! all all -!! if ( all(set0) ) write(*,*) 'Fourth test of AND worked.' -!! end program demo_and -!! - type(bitset_large), intent(inout) :: set1 - type(bitset_large), intent(in) :: set2 - end subroutine and_large - - elemental module subroutine and_64(set1, set2) -!! Version: experimental -!! -!! Sets the bits in `set1` to the bitwise `and` of the original bits in `set1` -!! and `set2`. The sets must have the same number of bits -!! otherwise the result is undefined. - type(bitset_64), intent(inout) :: set1 - type(bitset_64), intent(in) :: set2 - end subroutine and_64 - - end interface and - - - interface and_not - - elemental module subroutine and_not_large(set1, set2) -!! Version: experimental -!! -!! Sets the bits in `set1` to the bitwise and of the original bits in `set1` -!! with the bitwise negation of `set2`. The sets must have the same -!! number of bits otherwise the result is undefined. -!! -!!#### Example -!! -!! ```fortran -!! program demo_and_not -!! use stdlib_bitsets -!! type(bitset_large) :: set0, set1 -!! call set0 % init(166) -!! call set1 % init(166) -!! call and_not( set0, set1 ) ! none none -!! if ( none(set0) ) write(*,*) 'First test of AND_NOT worked.' -!! call set0 % not() -!! call and_not( set0, set1 ) ! all none -!! if ( all(set0) ) write(*,*) 'Second test of AND_NOT worked.' -!! call set0 % not() -!! call set1 % not() -!! call and_not( set0, set1 ) ! none all -!! if ( none(set0) ) write(*,*) 'Third test of AND_NOT worked.' -!! call set0 % not() -!! call and_not( set0, set1 ) ! all all -!! if ( none(set0) ) write(*,*) 'Fourth test of AND_NOT worked.' -!! end program demo_and_not -!! - type(bitset_large), intent(inout) :: set1 - type(bitset_large), intent(in) :: set2 - end subroutine and_not_large - - elemental module subroutine and_not_64(set1, set2) -!! Version: experimental -!! -!! Sets the bits in `set1` to the bitwise and of the original bits in `set1` -!! with the bitwise negation of `set2`. The sets must have the same -!! number of bits otherwise the result is undefined. - type(bitset_64), intent(inout) :: set1 - type(bitset_64), intent(in) :: set2 - end subroutine and_not_64 - - end interface and_not - - interface extract - - module subroutine extract_large(new, old, start_pos, stop_pos, status) -!! Version: experimental -!! -!! Creates a new bitset, `new`, from a range, `start_pos` to `stop_pos`, in -!! bitset `old`. If 'start_pos` is greater than `stop_pos` the new bitset is -!! empty. If `start_pos` is less than zero or `stop_pos` is greater than -!! `bits(old)-1` then if `status` is present it has the value -!! `index_invalid_error`and `new` is undefined, otherwise processing stops -!! with an informative message. -!! -!!#### Example -!! -!! ```fortran -!! program demo_extract -!! use stdlib_bitsets -!! type(bitset_large) :: set0, set1 -!! call set0 % init(166) -!! call set0 % set(100,150) -!! call extract( set1, set0, 100, 150) -!! if ( set1 % bits() == 51 ) & -!! write(*,*) 'SET1 has the proper size.' -!! if ( set1 % all() ) write(*,*) 'SET1 has the proper values.' -!! end program demo_extract -!! - type(bitset_large), intent(out) :: new - type(bitset_large), intent(in) :: old - integer(bits_kind), intent(in) :: start_pos, stop_pos - integer, intent(out), optional :: status - end subroutine extract_large - - module subroutine extract_64(new, old, start_pos, stop_pos, status) -!! Version: experimental -!! -!! Creates a new bitset, `new`, from a range, `start_pos` to `stop_pos`, in -!! bitset `old`. If 'start_pos` is greater than `stop_pos` the new bitset is -!! empty. If `start_pos` is less than zero or `stop_pos` is greater than -!! `bits(old)-1` then if `status` is present it has the value -!! `index_invalid_error`and `new` is undefined, otherwise processing stops -!! with an informative message. - type(bitset_64), intent(out) :: new - type(bitset_64), intent(in) :: old - integer(bits_kind), intent(in) :: start_pos, stop_pos - integer, intent(out), optional :: status - end subroutine extract_64 - - end interface extract - - - interface or - - elemental module subroutine or_large(set1, set2) -!! Version: experimental -!! -!! Sets the bits in `set1` to the bitwise `or` of the original bits in `set1` -!! and `set2`. The sets must have the same number of bits otherwise -!! the result is undefined. -!! -!!#### Example -!! -!! ```fortran -!! program demo_or -!! use stdlib_bitsets -!! type(bitset_large) :: set0, set1 -!! call set0 % init(166) -!! call set1 % init(166) -!! call or( set0, set1 ) ! none none -!! if ( none(set0) ) write(*,*) 'First test of OR worked.' -!! call set0 % not() -!! call or( set0, set1 ) ! all none -!! if ( all(set0) ) write(*,*) 'Second test of OR worked.' -!! call set0 % not() -!! call set1 % not() -!! call or( set0, set1 ) ! none all -!! if ( all(set0) ) write(*,*) 'Third test of OR worked.' -!! call set0 % not() -!! call or( set0, set1 ) ! all all -!! if ( all(set0) ) write(*,*) 'Fourth test of OR worked.' -!! end program demo_or -!! - type(bitset_large), intent(inout) :: set1 - type(bitset_large), intent(in) :: set2 - end subroutine or_large - - elemental module subroutine or_64(set1, set2) -!! Version: experimental -!! -!! Sets the bits in `set1` to the bitwise `or` of the original bits in `set1` -!! and `set2`. The sets must have the same number of bits otherwise -!! the result is undefined. - type(bitset_64), intent(inout) :: set1 - type(bitset_64), intent(in) :: set2 - end subroutine or_64 - - end interface or - - - interface xor - - elemental module subroutine xor_large(set1, set2) -!! Version: experimental -!! -!! Sets the bits in `set1` to the bitwise `xor` of the original bits in `set1` -!! and `set2`. The sets must have the same number of bits otherwise -!! the result is undefined. -!! -!!#### Example -!! -!! ```fortran -!! program demo_xor -!! use stdlib_bitsets -!! type(bitset_large) :: set0, set1 -!! call set0 % init(166) -!! call set1 % init(166) -!! call xor( set0, set1 ) ! none none -!! if ( none(set0) ) write(*,*) 'First test of XOR worked.' -!! call set0 % not() -!! call xor( set0, set1 ) ! all none -!! if ( all(set0) ) write(*,*) 'Second test of XOR worked.' -!! call set0 % not() -!! call set1 % not() -!! call xor( set0, set1 ) ! none all -!! if ( all(set0) ) write(*,*) 'Third test of XOR worked.' -!! call set0 % not() -!! call xor( set0, set1 ) ! all all -!! if ( none(set0) ) write(*,*) 'Fourth test of XOR worked.' -!! end program demo_xor -!! - type(bitset_large), intent(inout) :: set1 - type(bitset_large), intent(in) :: set2 - end subroutine xor_large - - elemental module subroutine xor_64(set1, set2) -!! Version: experimental -!! -!! Sets the bits in `set1` to the bitwise `xor` of the original bits in `set1` -!! and `set2`. The sets must have the same number of bits -!! otherwise the result is undefined. - type(bitset_64), intent(inout) :: set1 - type(bitset_64), intent(in) :: set2 - end subroutine xor_64 - - end interface xor - - - interface operator(==) - - elemental module function eqv_large(set1, set2) result(eqv) -!! Version: experimental -!! -!! Returns `.true`. if all bits in `set1` and `set2` have the same value, -!! `.false.` otherwise. The sets must have the same number of bits -!! otherwise the result is undefined. -!! -!!#### Example -!! -!! ```fortran -!! program demo_equality -!! use stdlib_bitsets -!! type(bitset_64) :: set0, set1, set2 -!! call set0 % init( 33 ) -!! call set1 % init( 33 ) -!! call set2 % init( 33 ) -!! call set1 % set( 0 ) -!! call set2 % set( 32 ) -!! if ( set0 == set0 .and. set1 == set1 .and. set2 == set2 .and. & -!! .not. set0 == set1 .and. .not. set0 == set2 .and. .not. & -!! set1 == set2 ) then -!! write(*,*) 'Passed 64 bit equality tests.' -!! else -!! error stop 'Failed 64 bit equality tests.' -!! end if -!! end program demo_equality -!! - logical :: eqv - type(bitset_large), intent(in) :: set1, set2 - end function eqv_large - - elemental module function eqv_64(set1, set2) result(eqv) -!! Version: experimental -!! -!! Returns `.true`. if all bits in `set1` and `set2` have the same value, -!! `.false.` otherwise. The sets must have the same number of bits -!! otherwise the result is undefined. - logical :: eqv - type(bitset_64), intent(in) :: set1, set2 - end function eqv_64 - - end interface operator(==) - - - interface operator(/=) - - elemental module function neqv_large(set1, set2) result(neqv) -!! Version: experimental -!! -!! Returns `.true.` if not all bits in `set1` and `set2` have the same value, -!! `.false.` otherwise. The sets must have the same number of bits -!! otherwise the result is undefined. -!! -!!#### Example -!! -!! ```fortran -!! program demo_inequality -!! use stdlib_bitsets -!! type(bitset_64) :: set0, set1, set2 -!! call set0 % init( 33 ) -!! call set1 % init( 33 ) -!! call set2 % init( 33 ) -!! call set1 % set( 0 ) -!! call set2 % set( 32 ) -!! if ( set0 /= set1 .and. set0 /= set2 .and. set1 /= set2 .and. & -!! .not. set0 /= set0 .and. .not. set1 /= set1 .and. .not. & -!! set2 /= set2 ) then -!! write(*,*) 'Passed 64 bit inequality tests.' -!! else -!! error stop 'Failed 64 bit inequality tests.' -!! end if -!! end program demo_inequality -!! - logical :: neqv - type(bitset_large), intent(in) :: set1, set2 - end function neqv_large - - elemental module function neqv_64(set1, set2) result(neqv) -!! Version: experimental -!! -!! Returns `.true.` if not all bits in `set1` and `set2 have the same value, -!! `.false.` otherwise. The sets must have the same number of bits -!! otherwise the result is undefined. - logical :: neqv - type(bitset_64), intent(in) :: set1, set2 - end function neqv_64 - - end interface operator(/=) - - - interface operator(>) - - elemental module function gt_large(set1, set2) result(gt) -!! Version: experimental -!! -!! Returns `.true.` if the bits in `set1` and `set2` differ and the -!! highest order different bit is set to 1 in `set1` and to 0 in `set2`. -!! `.false.` otherwise. The sets must have the same number of bits -!! otherwise the result is undefined. -!! -!!#### Example -!! -!! ```fortran -!! program demo_gt -!! use stdlib_bitsets -!! type(bitset_64) :: set0, set1, set2 -!! call set0 % init( 33 ) -!! call set1 % init( 33 ) -!! call set2 % init( 33 ) -!! call set1 % set( 0 ) -!! call set2 % set( 32 ) -!! if ( set1 > set0 .and. set2 > set1 .and. set2 > set0 .and. & -!! .not. set0 > set0 .and. .not. set0 > set1 .and. .not. & -!! set1 > set2 ) then -!! write(*,*) 'Passed 64 bit greater than tests.' -!! else -!! error stop 'Failed 64 bit greater than tests.' -!! end if -!! end program demo_gt -!! - logical :: gt - type(bitset_large), intent(in) :: set1, set2 - end function gt_large - - elemental module function gt_64(set1, set2) result(gt) -!! Version: experimental -!! -!! Returns `.true.` if the bits in `set1` and `set2` differ and the -!! highest order different bit is set to 1 in `set1` and to 0 in `set2`. -!! `.false.` otherwise. The sets must have the same number of bits -!! otherwise the result is undefined. - logical :: gt - type(bitset_64), intent(in) :: set1, set2 - end function gt_64 - - end interface operator(>) - - - interface operator(>=) - - elemental module function ge_large(set1, set2) result(ge) -!! Version: experimental -!! -!! Returns `.true.` if the bits in `set1` and `set2` are the same or the -!! highest order different bit is set to 1 in `set1` and to 0 in `set2`. -!! `.false.` otherwise. The sets must have the same number of bits -!! otherwise the result is undefined. -!! -!!#### Example -!! -!! ```fortran -!! program demo_ge -!! use stdlib_bitsets -!! type(bitset_64) :: set0, set1, set2 -!! call set0 % init( 33 ) -!! call set1 % init( 33 ) -!! call set2 % init( 33 ) -!! call set1 % set( 0 ) -!! call set2 % set( 32 ) -!! if ( set1 >= set0 .and. set2 >= set1 .and. set2 >= set0 .and. & -!! set0 >= set0 .and. set1 >= set1 .and. set2 >= set2 .and. & -!! .not. set0 >= set1 .and. .not. set0 >= set2 .and. .not. & -!! set1 >= set2 ) then -!! write(*,*) 'Passed 64 bit greater than or equals tests.' -!! else -!! error stop 'Failed 64 bit greater than or equals tests.' -!! end if -!! end program demo_ge -!! - logical :: ge - type(bitset_large), intent(in) :: set1, set2 - end function ge_large - - elemental module function ge_64(set1, set2) result(ge) -!! Version: experimental -!! -!! Returns `.true.` if the bits in `set1` and `set2` are the same or the -!! highest order different bit is set to 1 in `set1` and to 0 in `set2`. -!! `.false.` otherwise. The sets must have the same number of bits -!! otherwise the result is undefined. - logical :: ge - type(bitset_64), intent(in) :: set1, set2 - end function ge_64 - - end interface operator(>=) - - - interface operator(<) - - elemental module function lt_large(set1, set2) result(lt) -!! Version: experimental -!! -!! Returns `.true.` if the bits in `set1` and `set2` differ and the -!! highest order different bit is set to 0 in `set1` and to 1 in `set2`. -!! `.false.` otherwise. The sets must have the same number of bits -!! otherwise the result is undefined. -!! -!!#### Example -!! -!! ```fortran -!! program demo_lt -!! use stdlib_bitsets -!! type(bitset_64) :: set0, set1, set2 -!! call set0 % init( 33 ) -!! call set1 % init( 33 ) -!! call set2 % init( 33 ) -!! call set1 % set( 0 ) -!! call set2 % set( 32 ) -!! if ( set0 < set1 .and. set1 < set2 .and. set0 < set2 .and. & -!! .not. set0 < set0 .and. .not. set2 < set0 .and. .not. & -!! set2 < set1 ) then -!! write(*,*) 'Passed 64 bit less than tests.' -!! else -!! error stop 'Failed 64 bit less than tests.' -!! end if -!! end program demo_lt -!! - logical :: lt - type(bitset_large), intent(in) :: set1, set2 - end function lt_large - - elemental module function lt_64(set1, set2) result(lt) -!! Version: experimental -!! -!! Returns `.true.` if the bits in `set1` and `set2` differ and the -!! highest order different bit is set to 0 in `set1` and to 1 in `set2`. -!! `.false.` otherwise. The sets must have the same number of bits -!! otherwise the result is undefined. - logical :: lt - type(bitset_64), intent(in) :: set1, set2 - end function lt_64 - - end interface operator(<) - - - interface operator(<=) - - elemental module function le_large(set1, set2) result(le) -!! Version: experimental -!! -!! Returns `.true.` if the bits in `set1` and `set2` are the same or the -!! highest order different bit is set to 0 in `set1` and to 1 in `set2`. -!! `.false.` otherwise. The sets must have the same number of bits -!! otherwise the result is undefined. -!! -!!#### Example -!! -!! ```fortran -!! program demo_le -!! use stdlib_bitsets -!! type(bitset_64) :: set0, set1, set2 -!! call set0 % init( 33 ) -!! call set1 % init( 33 ) -!! call set2 % init( 33 ) -!! call set1 % set( 0 ) -!! call set2 % set( 32 ) -!! if ( set0 <= set1 .and. set1 <= set2 .and. set0 <= set2 .and. & -!! set0 <= set0 .and. set1 <= set1 .and. set2 <= set2 .and. & -!! .not. set1 <= set0 .and. .not. set2 <= set0 .and. .not. & -!! set2 <= set1 ) then -!! write(*,*) 'Passed 64 bit less than or equal tests.' -!! else -!! error stop 'Failed 64 bit less than or equal tests.' -!! end if -!! end program demo_le -!! - logical :: le - type(bitset_large), intent(in) :: set1, set2 - end function le_large - - elemental module function le_64(set1, set2) result(le) -!! Version: experimental -!! -!! Returns `.true.` if the bits in `set1` and `set2` are the same or the -!! highest order different bit is set to 0 in `set1` and to 1 in `set2`. -!! `.false.` otherwise. The sets must have the same number of bits -!! otherwise the result is undefined. - logical :: le - type(bitset_64), intent(in) :: set1, set2 - end function le_64 - - end interface operator(<=) - -contains - - elemental function bits(self) -!! Version: experimental -!! -!! Returns the number of bit positions in `self`. - integer(bits_kind) :: bits - class(bitset_type), intent(in) :: self - - bits = self % num_bits - - return - end function bits - - -end module stdlib_bitsets From 3844561336857c361a3dc25c2518a6a48485e4af Mon Sep 17 00:00:00 2001 From: William Clodius Date: Fri, 9 Oct 2020 06:47:32 -0600 Subject: [PATCH 14/53] Modified code to use error_handler. Defined an error_handler subroutine in stdlib_bitsets.fypp and used it to handle errors in stdlib_bitset_64.fypp and stdlib_bitset_large.fypp. Also was more consistent in documenting status argument results. Added char_string_too_large_error to status results. [ticket: X] --- src/stdlib_bitset_64.fypp | 420 +++++++++++++++-------------------- src/stdlib_bitset_large.fypp | 418 +++++++++++++++------------------- src/stdlib_bitsets.fypp | 299 ++++++++++++++++--------- 3 files changed, 558 insertions(+), 579 deletions(-) diff --git a/src/stdlib_bitset_64.fypp b/src/stdlib_bitset_64.fypp index da586d73a..954ad8377 100644 --- a/src/stdlib_bitset_64.fypp +++ b/src/stdlib_bitset_64.fypp @@ -212,8 +212,18 @@ contains integer(bits_kind) :: bits, i, k character(*), parameter :: procedure = 'EXTRACT' - if ( start_pos < 0 ) go to 999 - if ( stop_pos >= old % num_bits ) go to 998 + if ( start_pos < 0 ) then + call error_handler( 'had a START_POS less than 0.', & + index_invalid_error, status, & + module_name, procedure ) + return + end if + if ( stop_pos >= old % num_bits ) then + call error_handler( 'had a STOP_POS greater than BITS(OLD)-1.', & + index_invalid_error, status, & + module_name, procedure ) + return + end if bits = stop_pos - start_pos + 1 if ( bits <= 0 ) then @@ -231,24 +241,6 @@ contains if ( present(status) ) status = success - return - -998 if ( present(status) ) then - status = index_invalid_error - return - else - error stop module_name // ' % ' // procedure // ' had a ' // & - 'STOP_POS greater than BITS(OLD)-1.' - end if - -999 if ( present(status) ) then - status = index_invalid_error - return - else - error stop module_name // ' % ' // procedure // ' had a ' // & - 'START_POS less than 0.' - end if - end subroutine extract_64 @@ -295,9 +287,12 @@ contains module subroutine from_string_64(self, string, status) -! Initializes the bitset SELF treating STRING as a binary literal -! STATUS may have the values SUCCESS, ALLOC_FAULT, -! ARRAY_SIZE_INVALID_ERROR, or CHAR_STRING_INVALID. +! Initializes the bitset `self` treating `string` as a binary literal +! `status` may have the values: +! `success` - if no problems were found, +! `alloc_fault` - if allocation of the bitset failed +! `char_string_too_large_error` - if `string` was too large, or +! `char_string_invalid_error` - if string had an invalid character. class(bitset_64), intent(out) :: self character(*), intent(in) :: string integer, intent(out), optional :: status @@ -308,7 +303,13 @@ contains character(1) :: char bits = len(string, kind=int64) - if ( bits > 64 ) go to 998 + if ( bits > 64 ) then + call error_handler( 'STRING was too long for a ' // & + 'BITSET_64 SELF.', & + char_string_too_large_error, status, & + module_name, procedure ) + return + end if self % num_bits = bits do bit = 1, bits char = string(bit:bit) @@ -317,7 +318,11 @@ contains else if ( char == '1' ) then call self % set( int(bits, kind=bits_kind)-bit ) else - go to 999 + call error_handler( 'STRING had a character other than ' // & + '0 or 1.', & + char_string_invalid_error, status, & + module_name, procedure ) + return end if end do @@ -325,22 +330,6 @@ contains return -998 if ( present(status) ) then - status = array_size_invalid_error - return - else - error stop module_name // ' % ' // procedure // ' STRING ' // & - 'was too long for a BITSET_64 SELF.' - end if - -999 if ( present(status) ) then - status = char_string_invalid_error - return - else - error stop module_name // ' % ' // procedure // ' STRING ' // & - 'had a character other than "0" or "1",' - end if - end subroutine from_string_64 @@ -376,13 +365,14 @@ contains module subroutine init_zero_64(self, bits, status) ! -! Creates the bitset, SELF, of size BITS, with all bits initialized to -! zero. BITS must be non-negative. If an error occurs and STATUS is -! absent then processing stops with an informative stop code. STATUS -! has a default value of SUCCESS. If an error occurs it has the value -! ARRAY_SIZE_INVALID_ERROR if BITS is either negative larger than 64 -! if SELF is of type BITSET_64, or the value ALLOC_FAULT if it failed -! during allocation of memory for SELF. +! Creates the bitset, `self`, of size `bits`, with all bits initialized to +! zero. `bits` must be non-negative. If an error occurs and `status` is +! absent then processing stops with an informative stop code. `status` +! will have one of the values; +! * `success` - if no problems were found, +! * `array_size_invalid_error` - if `bits` is either negative or larger +! than 64 with `self` of class `bitset_64`, or +! * `alloc_fault` - if memory allocation failed ! class(bitset_64), intent(out) :: self integer(bits_kind), intent(in) :: bits @@ -390,42 +380,38 @@ contains character(*), parameter :: procedure = "INIT" - if ( bits < 0 .or. bits > 64 ) go to 999 + if ( bits < 0 ) then + call error_handler( 'BITS had a negative value.', & + array_size_invalid_error, status, & + module_name, procedure ) + return + end if + if ( bits > 64 ) then + call error_handler( 'BITS had a value greater than 64.', & + array_size_invalid_error, status, & + module_name, procedure ) + return + end if self % num_bits = bits self % block = all_zeros if ( present(status) ) status = success - return - -999 if ( present(status) ) then - status = array_size_invalid_error - return - else - if ( bits < 0 ) then - error stop module_name // ' %' // procedure // ' BITS had ' // & - 'a negative value.' - else - error stop module_name // ' %' // procedure // ' BITS had ' // & - 'a value greater than 64.' - end if - end if - end subroutine init_zero_64 module subroutine input_64(self, unit, status) ! -! Reads the components of the bitset, SELF, from the unformatted I/O -! unit, UNIT, assuming that the components were written using OUTPUT. -! If an error occurs and STATUS is absent then processing stops with -! an informative stop code. STATUS has a default value of SUCCESS. -! If an error occurs it has the value READ_FAILURE if it failed -! during the reads from UNIT or the value ALLOC_FAULT if it failed -! during allocation of memory for SELF, or the value -! ARRAY_SIZE_INVALID_ERROR if the BITS(SELF) in UNIT is less than 0 -! or greater than 64 for a BITSET_64 input. +! Reads the components of the bitset, `self`, from the unformatted I/O +! unit, `unit`, assuming that the components were written using `output`. +! If an error occurs and `status` is absent then processing stops with +! an informative stop code. `status` has one of the values: +! * `success` - if no problem was found +! * `alloc_fault` - if it failed during allocation of memory for `self`, or +! * `array_size_invalid_error` if the `bits(self)` in `unit` is negative +! or greater than 64 for a `bitset_64` input. +! * `read_failure` - if it failed during the reads from `unit` ! class(bitset_64), intent(out) :: self integer, intent(in) :: unit @@ -438,41 +424,41 @@ contains integer :: stat read(unit, iostat=ierr, iomsg=message) bits - if (ierr /= 0) go to 999 - if ( bits < 0 .or. bits > 64 ) go to 998 + if (ierr /= 0) then + call error_handler( 'Failure on a READ statement for UNIT.', & + read_failure, status, module_name, procedure ) + return + end if + if ( bits < 0 ) then + call error_handler( 'BITS in UNIT had a negative value.', & + array_size_invalid_error, status, & + module_name, procedure ) + return + end if + if ( bits > 64 ) then + call error_handler( 'BITS in UNIT had a value greater than 64.', & + array_size_invalid_error, status, & + module_name, procedure ) + return + end if call self % init(bits, stat) - if (stat /= success) go to 998 + if (stat /= success) then + call error_handler( 'Allocation failure for SELF.', & + alloc_fault, status, module_name, procedure ) + return + end if if (bits < 1) return read(unit, iostat=ierr, iomsg=message) self % block - if (ierr /= 0) go to 999 - - if ( present(status) ) status = success - - return - -998 if ( present(status) ) then - status = array_size_invalid_error + if (ierr /= 0) then + call error_handler( 'Failure on a READ statement for UNIT.', & + read_failure, status, module_name, procedure ) return - else - if ( bits < 0 ) then - error stop module_name // ' %' // procedure // ' BITS in ' // & - 'UNIT had a negative value.' - else - error stop module_name // ' %' // procedure // ' BITS in ' // & - 'UNIT had a value greater than 64.' - end if end if -999 if ( present(status) ) then - status = read_failure - return - else - error stop module_name // ' % ' // procedure // ' had a ' // & - 'failure on a READ statement for UNIT.' - end if + if ( present(status) ) status = success end subroutine input_64 @@ -610,31 +596,29 @@ contains return -999 if ( present(status) ) then - status = write_failure - return - else - error stop module_name // ' % ' // procedure // ' had a ' // & - 'failure in the write to UNIT.' - end if +999 call error_handler( 'Failure on a WRiTE statement for UNIT.', & + write_failure, status, module_name, procedure ) end subroutine output_64 module subroutine read_bitset_string_64(self, string, status) ! -! Uses the bitset literal in the default character STRING, to define -! the bitset, SELF. The literal may be preceded by an an arbitrary -! sequence of blank characters. If STATUS is absent an error results -! in an error stop with an informative stop code. If STATUS -! is present it has the default value of SUCCESS, the value -! INTEGER_OVERFLOW_ERROR if the bitset literal has a BITS(SELF) value -! too large to be represented, the value ALLOC_FAULT if allocation of -! memory for SELF failed, or CHAR_STRING_INVALID_ERROR if the bitset -! literal has an invalid character, or ARRAY_SIZE_INVALID_ERROR if -! BITS(SELF) in STRING is greater than 64 for a BITSET_64, or -! CHAR_STRING_TOO_SMALL_ERROR if the string ends before all the bits -! are read. +! Uses the bitset literal in the default character `string`, to define +! the bitset, `self`. The literal may be preceded by an an arbitrary +! sequence of blank characters. If `status` is absent an error results +! in an error stop with an informative stop code. If `status` +! is present it has one of the values +! * `success` - if no problems occurred, +! * `alloc_fault` - if allocation of memory for SELF failed, +! * `array_size_invalid_error - if `bits(self)` in `string` is greater +! than 64 for a `bitset_64`, +! * `char_string_invalid_error` - if the bitset literal has an invalid +! character, +! * `char_string_too_small_error - if the string ends before all the bits +! are read. +! * `integer_overflow_error` - if the bitset literal has a `bits(self)` +! value too large to be represented, ! class(bitset_64), intent(out) :: self character(len=*), intent(in) :: string @@ -677,10 +661,25 @@ contains end do -100 if ( bits > 64 ) go to 995 - if ( bits + pos > len(string) ) go to 994 +100 if ( bits > 64 ) then + call error_handler( 'BITS in STRING was greater than 64.', & + char_string_too_large_error, status, & + module_name, procedure ) + return + end if + if ( bits + pos > len(string) ) then + call error_handler( 'STRING was too small for the number of ' // & + 'bits specified by STRING.', & + char_string_too_small_error, status, & + module_name, procedure ) + return + end if call self % init( bits, stat ) - if (stat /= success) go to 998 + if (stat /= success) then + call error_handler( 'There was an allocation fault for SELF.', & + alloc_fault, status, module_name, procedure ) + return + end if pos = pos + 1 bit = bits - 1 @@ -701,53 +700,40 @@ contains return -994 if ( present(status) ) then - status = char_string_too_small_error - return - else - error stop module_name // ' % ' // procedure // ' STRING ' // & - 'was too small for the BITS specified by the STRING.' - end if - -995 if ( present(status) ) then - status = array_size_invalid_error - return - else - error stop module_name // ' %' // procedure // ' BITS in ' // & - 'STRING had a value greater than 64.' - end if - - -996 if ( present(status) ) then - status = integer_overflow_error - return - else - error stop module_name // ' % ' // procedure // ' failed on ' // & - 'integer overflow in reading size of bitset literal from ' // & - 'UNIT.' - end if +996 call error_handler( 'There was an integer overflow in reading' // & + 'size of bitset literal from UNIT', & + integer_overflow_error, status, & + module_name, procedure ) + return -998 if ( present(status) ) then - status = alloc_fault - return - else - error stop module_name // ' % ' // procedure // ' failed in ' // & - 'allocating memory for the bitset.' - end if - -999 if ( present(status) ) then - status = char_string_invalid_error - return - else - error stop module_name // ' % ' // procedure // ' failed due ' // & - 'to an invalid character in STRING.' - end if +999 call error_handler( 'There was an invalid character in STRING', & + char_string_invalid_error, status, & + module_name, procedure ) end subroutine read_bitset_string_64 module subroutine read_bitset_unit_64(self, unit, advance, status) ! +! Uses the bitset literal at the current position in the formatted +! file with I/O unit, `unit`, to define the bitset, `self`. The literal +! may be preceded by an arbitrary sequence of blank characters. +! If `advance` is present it must be either 'YES' or 'NO'. If absent +! it has the default value of 'YES' to determine whether advancing +! I/O occurs. If `status` is absent an error results in an error stop +! with an informative stop code. If `status` is present it has one of +! the values: +! * `success` - if no problem occurred, +! * `alloc_fault` - if allocation of `self` failed, +! * `array_size_invalid_error` - if `bits(self)` in the bitset literal +! is greater than 64 for a `bitset_64`. +! * `char_string_invalid_error` - if the read of the bitset literal found +! an invalid character, +! * `eof_failure` - if a `read` statement reaches an end-of-file before +! completing the read of the bitset literal, +! * `integer_overflow_error` - if the bitset literal has a `bits(self)` +! value too large to be represented, +! * `read_failure` - if a `read` statement fails, ! class(bitset_64), intent(out) :: self integer, intent(in) :: unit @@ -804,7 +790,12 @@ contains if ( bits < 0 .OR. digits == 0 .OR. digits > 10 ) go to 999 - if ( bits > 64 ) go to 995 + if ( bits > 64 ) then + call error_handler( 'BITS in UNIT was greater than 64.', & + array_size_invalid_error, status, & + module_name, procedure ) + return + end if call self % init( bits ) do bit = 1, bits-1 read( unit, & @@ -831,7 +822,6 @@ contains end=998, & iostat=ierr, & iomsg=message ) char - else read( unit, & advance='YES', & @@ -840,7 +830,6 @@ contains end=998, & iostat=ierr, & iomsg=message ) char - end if if ( char == '0' ) then call self % clear( bits-bit ) @@ -852,48 +841,23 @@ contains if ( present(status) ) status = success +996 call error_handler( 'Integer overflow in reading size of ' // & + 'bitset literal from UNIT.', & + read_failure, status, module_name, procedure ) return -995 if ( present(status) ) then - status = array_size_invalid_error - return - else - error stop module_name // ' %' // procedure // ' BITS in ' // & - 'STRING had a value greater than 64.' - end if - -996 if ( present(status) ) then - status = integer_overflow_error - return - else - error stop module_name // ' % ' // procedure // ' failed on ' // & - 'integer overflow in reading size of bitset literal from ' // & - 'UNIT.' - end if - -997 if ( present(status) ) then - status = read_failure - return - else - error stop module_name // ' % ' // procedure // ' failed on ' // & - 'read of UNIT.' - end if +997 call error_handler( 'Failure on read of UNIT.', & + read_failure, status, module_name, procedure ) + return -998 if ( present(status) ) then - status = eof_failure - return - else - error stop module_name // ' % ' // procedure // ' reached ' // & - 'End of File of UNIT before finding a bitset literal.' - end if +998 call error_handler( 'End of File of UNIT before finishing a ' // & + 'bitset literal.', & + eof_failure, status, module_name, procedure ) + return -999 if ( present(status) ) then - status = char_string_invalid_error - return - else - error stop module_name // ' % ' // procedure // ' found an ' // & - 'invalid bitset literal in UNIT.' - end if +999 call error_handler( 'Invalid character in bitset literal in UNIT ', & + char_string_invalid_error, status, & + module_name, procedure ) end subroutine read_bitset_unit_64 @@ -970,8 +934,11 @@ contains bit_count = self % num_bits allocate( character(len=bit_count)::string, stat=stat ) - if ( stat > 0 ) go to 999 - + if ( stat > 0 ) then + call error_handler( 'There was an allocation fault for STRING.', & + alloc_fault, status, module_name, procedure ) + return + end if do bit=0, bit_count-1 pos = bit_count - bit if ( btest( self % block, bit ) ) then @@ -983,18 +950,6 @@ contains if ( present(status) ) status = success - return - -999 if ( present(status) ) then - status = alloc_fault - return - - else - error stop module_name // ' % ' // procedure // ' allocation ' // & - 'of STRING failed.' - - end if - end subroutine to_string_64 @@ -1050,8 +1005,11 @@ contains call digit_count( self % num_bits, count_digits ) allocate( character(len=count_digits+bit_count+2)::string, stat=stat ) - if ( stat > 0 ) go to 999 - + if ( stat > 0 ) then + call error_handler( 'There was an allocation fault for STRING.', & + alloc_fault, status, module_name, procedure ) + return + end if write( string, "('S', i0)" ) self % num_bits string( count_digits + 2:count_digits + 2 ) = "B" @@ -1066,18 +1024,6 @@ contains if ( present(status) ) status = success - return - -999 if ( present(status) ) then - status = alloc_fault - return - - else - error stop module_name // ' % ' // procedure // ' had a ' // & - 'memory sllocation failure for a string.' - - end if - contains subroutine digit_count( bits, digits ) @@ -1170,17 +1116,11 @@ contains iomsg=message ) & string end if - if (ierr /= 0) go to 999 - - return - -999 if ( present(status) ) then - status = write_failure + if (ierr /= 0) then + call error_handler( 'Failure on a WRiTE statement for UNIT.', & + write_failure, status, module_name, procedure ) return - else - error stop module_name // ' % ' // procedure // ' had a ' // & - 'failure on a WRITE statement.' - end if + endif end subroutine write_bitset_unit_64 diff --git a/src/stdlib_bitset_large.fypp b/src/stdlib_bitset_large.fypp index 7cfb74892..d166d383b 100644 --- a/src/stdlib_bitset_large.fypp +++ b/src/stdlib_bitset_large.fypp @@ -278,8 +278,18 @@ contains integer(bits_kind) :: bits, blocks, ex_block, i, j, k, old_block character(*), parameter :: procedure = 'EXTRACT' - if ( start_pos < 0 ) go to 999 - if ( stop_pos >= old % num_bits ) go to 998 + if ( start_pos < 0 ) then + call error_handler( 'had a START_POS less than 0.', & + index_invalid_error, status, & + module_name, procedure ) + return + end if + if ( stop_pos >= old % num_bits ) then + call error_handler( 'had a STOP_POS greater than BITS(OLD)-1.', & + index_invalid_error, status, & + module_name, procedure ) + return + end if bits = stop_pos - start_pos + 1 if ( bits <= 0 ) then @@ -306,24 +316,6 @@ contains if ( present(status) ) status = success - return - -998 if ( present(status) ) then - status = index_invalid_error - return - else - error stop module_name // ' % ' // procedure // ' had a ' // & - 'STOP_POS greater than BITS(OLD)-1.' - end if - -999 if ( present(status) ) then - status = index_invalid_error - return - else - error stop module_name // ' % ' // procedure // ' had a ' // & - 'START_POS less than 0.' - end if - end subroutine extract_large @@ -405,9 +397,12 @@ contains end subroutine flip_range_large module subroutine from_string_large(self, string, status) -! Initializes the bitset SELF treating STRING as a binary literal -! STATUS may have the values SUCCESS, ALLOC_FAULT, -! ARRAY_SIZE_INVALID_ERROR, or CHAR_STRING_INVALID. +! Initializes the bitset `self` treating `string` as a binary literal +! `status` may have the values: +! `success` - if no problems were found, +! `alloc_fault` - if allocation of the bitset failed +! `char_string_too_large_error` - if `string` was too large, or +! `char_string_invalid_error` - if string had an invalid character. class(bitset_large), intent(out) :: self character(*), intent(in) :: string integer, intent(out), optional :: status @@ -418,7 +413,13 @@ contains character(1) :: char bits = len(string, kind=int64) - if ( bits > huge(0_bits_kind) ) go to 998 + if ( bits > huge(0_bits_kind) ) then + call error_handler( 'STRING was too long for a ' // & + 'BITSET_LARGE SELF.', & + char_string_too_large_error, status, & + module_name, procedure ) + return + end if call init_zero_large( self, int(bits, kind=bits_kind), status ) @@ -433,7 +434,11 @@ contains else if ( char == '1' ) then call self % set( int(bits, kind=bits_kind)-bit ) else - go to 999 + call error_handler( 'STRING had a character other than ' // & + '0 or 1.', & + char_string_invalid_error, status, & + module_name, procedure ) + return end if end do @@ -441,22 +446,6 @@ contains return -998 if ( present(status) ) then - status = array_size_invalid_error - return - else - error stop module_name // ' % ' // procedure // ' STRING ' // & - 'was too long for a BITSET_64 SELF.' - end if - -999 if ( present(status) ) then - status = char_string_invalid_error - return - else - error stop module_name // ' % ' // procedure // ' STRING ' // & - 'had a character other than "0" or "1",' - end if - end subroutine from_string_large @@ -503,7 +492,8 @@ contains do block_ = size(set1 % blocks), 1, -1 if ( set1 % blocks(block_) == set2 % blocks(block_) ) then cycle - else if ( bgt( set1 % blocks(block_), set2 % blocks(block_) ) ) then + else if ( bgt( set1 % blocks(block_), & + set2 % blocks(block_) ) ) then gt = .true. return else @@ -518,13 +508,14 @@ contains module subroutine init_zero_large(self, bits, status) ! -! Creates the bitset, SELF, of size BITS, with all bits initialized to -! zero. BITS must be non-negative. If an error occurs and STATUS is -! absent then processing stops with an informative stop code. STATUS -! has a default value of SUCCESS. If an error occurs it has the value -! ARRAY_SIZE_INVALID_ERROR if BITS is either negative larger than 64 -! if SELF is of type BITSET_64, or the value ALLOC_FAULT if it failed -! during allocation of memory for SELF. +! Creates the bitset, `self`, of size `bits`, with all bits initialized to +! zero. `bits` must be non-negative. If an error occurs and `status` is +! absent then processing stops with an informative stop code. `status` +! will have one of the values; +! * `success` - if no problems were found, +! * `array_size_invalid_error` - if `bits` is either negative or larger +! than 64 with `self` of class `bitset_64`, or +! * `alloc_fault` - if memory allocation failed ! class(bitset_large), intent(out) :: self integer(bits_kind), intent(in) :: bits @@ -535,7 +526,12 @@ contains integer :: blocks, ierr message = '' - if ( bits < 0 ) go to 999 + if ( bits < 0 ) then + call error_handler( 'BITS had a negative value.', & + array_size_invalid_error, status, & + module_name, procedure ) + return + end if if (bits == 0) then self % num_bits = 0 @@ -556,36 +552,24 @@ contains return -998 if ( present(status) ) then - status = alloc_fault - return - else - error stop module_name // ' % ' // procedure // ' allocation ' // & - 'failure for SELF.' - end if - -999 if ( present(status) ) then - status = array_size_invalid_error - return - else - error stop module_name // ' %' // procedure // ' BITS had ' // & - 'a negative value.' - end if +998 call error_handler( 'Allocation failure for SELF.', & + alloc_fault, status, & + module_name, procedure ) end subroutine init_zero_large module subroutine input_large(self, unit, status) ! -! Reads the components of the bitset, SELF, from the unformatted I/O -! unit, UNIT, assuming that the components were written using OUTPUT. -! If an error occurs and STATUS is absent then processing stops with -! an informative stop code. STATUS has a default value of SUCCESS. -! If an error occurs it has the value READ_FAILURE if it failed -! during the reads from UNIT or the value ALLOC_FAULT if it failed -! during allocation of memory for SELF, or the value -! ARRAY_SIZE_INVALID_ERROR if the BITS(SELF) in UNIT is less than 0 -! or greater than 64 for a BITSET_64 input. +! Reads the components of the bitset, `self`, from the unformatted I/O +! unit, `unit`, assuming that the components were written using `output`. +! If an error occurs and `status` is absent then processing stops with +! an informative stop code. `status` has one of the values: +! * `success` - if no problem was found +! * `alloc_fault` - if it failed during allocation of memory for `self`, or +! * `array_size_invalid_error` if the `bits(self)` in `unit` is negative +! or greater than 64 for a `bitset_64` input. +! * `read_failure` - if it failed during the reads from `unit` ! class(bitset_large), intent(out) :: self integer, intent(in) :: unit @@ -598,45 +582,37 @@ contains integer :: stat read(unit, iostat=ierr, iomsg=message) bits - if (ierr /= 0) go to 999 - if ( bits < 0 ) go to 997 - - call self % init(bits, stat) - if (stat /= success) go to 998 - - if (bits < 1) return - - read(unit, iostat=ierr, iomsg=message) self % blocks(:) - if (ierr /= 0) go to 999 - - if ( present(status) ) status = success - - return + if (ierr /= 0) then + call error_handler( 'Failure on a READ statement for UNIT.', & + read_failure, status, module_name, procedure ) + return + end if -997 if ( present(status) ) then - status = array_size_invalid_error + if ( bits < 0 ) then + call error_handler( 'BITS in UNIT had a negative value.', & + array_size_invalid_error, status, & + module_name, procedure ) return - else - error stop module_name // ' %' // procedure // ' BITS in ' // & - 'UNIT had a negative value.' end if -998 if ( present(status) ) then - status = alloc_fault + call self % init(bits, stat) + if (stat /= success) then + call error_handler( 'Allocation failure for SELF.', & + alloc_fault, status, module_name, procedure ) return - else - error stop module_name // ' % ' // procedure // ' had an ' // & - 'alloction fault for SELF.' end if -999 if ( present(status) ) then - status = read_failure + if (bits < 1) return + + read(unit, iostat=ierr, iomsg=message) self % blocks(:) + if (ierr /= 0) then + call error_handler( 'Failure on a READ statement for UNIT.', & + read_failure, status, module_name, procedure ) return - else - error stop module_name // ' % ' // procedure // ' had a ' // & - 'failure on a READ statement for UNIT.' end if + if ( present(status) ) status = success + end subroutine input_large @@ -655,7 +631,8 @@ contains do block_ = size(set1 % blocks), 1, -1 if ( set1 % blocks(block_) == set2 % blocks(block_) ) then cycle - else if ( blt( set1 % blocks(block_), set2 % blocks(block_) ) ) then + else if ( blt( set1 % blocks(block_), & + set2 % blocks(block_) ) ) then le = .true. return else @@ -684,7 +661,8 @@ contains do block_ = size(set1 % blocks), 1, -1 if ( set1 % blocks(block_) == set2 % blocks(block_) ) then cycle - else if ( blt( set1 % blocks(block_), set2 % blocks(block_) ) ) then + else if ( blt( set1 % blocks(block_), & + set2 % blocks(block_) ) ) then lt = .true. return else @@ -807,31 +785,29 @@ contains return -999 if ( present(status) ) then - status = write_failure - return - else - error stop module_name // ' % ' // procedure // ' had a ' // & - 'failure in the write to UNIT.' - end if +999 call error_handler( 'Failure on a WRiTE statement for UNIT.', & + write_failure, status, module_name, procedure ) end subroutine output_large module subroutine read_bitset_string_large(self, string, status) ! -! Uses the bitset literal in the default character STRING, to define -! the bitset, SELF. The literal may be preceded by an an arbitrary -! sequence of blank characters. If STATUS is absent an error results -! in an error stop with an informative stop code. If STATUS -! is present it has the default value of SUCCESS, the value -! INTEGER_OVERFLOW_ERROR if the bitset literal has a BITS(SELF) value -! too large to be represented, the value ALLOC_FAULT if allocation of -! memory for SELF failed, or CHAR_STRING_INVALID_ERROR if the bitset -! literal has an invalid character, or ARRAY_SIZE_INVALID_ERROR if -! BITS(SELF) in STRING is greater than 64 for a BITSET_64, or -! CHAR_STRING_TOO_SMALL_ERROR if the string ends before all the bits -! are read. +! Uses the bitset literal in the default character `string`, to define +! the bitset, `self`. The literal may be preceded by an an arbitrary +! sequence of blank characters. If `status` is absent an error results +! in an error stop with an informative stop code. If `status` +! is present it has one of the values +! * `success` - if no problems occurred, +! * `alloc_fault` - if allocation of memory for SELF failed, +! * `array_size_invalid_error - if `bits(self)` in `string` is greater +! than 64 for a `bitset_64`, +! * `char_string_invalid_error` - if the bitset literal has an invalid +! character, +! * `char_string_too_small_error - if the string ends before all the bits +! are read. +! * `integer_overflow_error` - if the bitset literal has a `bits(self)` +! value too large to be represented, ! class(bitset_large), intent(out) :: self character(len=*), intent(in) :: string @@ -867,15 +843,29 @@ contains case(iachar('b'), iachar('B')) go to 100 case default - go to 999 + call error_handler( 'There was an invalid character ' // & + 'in STRING', & + char_string_invalid_error, status, & + module_name, procedure ) + return end select pos = pos + 1 end do -100 if ( bits + pos > len(string) ) go to 994 +100 if ( bits + pos > len(string) ) then + call error_handler( 'STRING was too small for the number of ' // & + 'bits specified by STRING.', & + char_string_too_small_error, status, & + module_name, procedure ) + return + end if call self % init( bits, stat ) - if (stat /= success) go to 998 + if (stat /= success) then + call error_handler( 'There was an allocation fault for SELF.', & + alloc_fault, status, module_name, procedure ) + return + end if pos = pos + 1 bit = bits - 1 @@ -896,38 +886,15 @@ contains return -994 if ( present(status) ) then - status = char_string_too_small_error - return - else - error stop module_name // ' % ' // procedure // ' STRING ' // & - 'was too small for the BITS specified by the STRING.' - end if - -996 if ( present(status) ) then - status = integer_overflow_error - return - else - error stop module_name // ' % ' // procedure // ' failed on ' // & - 'integer overflow in reading size of bitset literal from ' // & - 'UNIT.' - end if - -998 if ( present(status) ) then - status = alloc_fault - return - else - error stop module_name // ' % ' // procedure // ' failed in ' // & - 'allocating memory for the bitset.' - end if +996 call error_handler( 'There was an integer overflow in reading' // & + 'size of bitset literal from UNIT', & + integer_overflow_error, status, & + module_name, procedure ) + return -999 if ( present(status) ) then - status = char_string_invalid_error - return - else - error stop module_name // ' % ' // procedure // ' failed due ' // & - 'to an invalid character in STRING.' - end if +999 call error_handler( 'There was an invalid character in STRING', & + char_string_invalid_error, status, & + module_name, procedure ) end subroutine read_bitset_string_large @@ -935,20 +902,24 @@ contains module subroutine read_bitset_unit_large(self, unit, advance, status) ! ! Uses the bitset literal at the current position in the formatted -! file with I/O unit, UNIT, to define the bitset, SELF. The literal -! may be preceded by an an arbitrary sequence of blank characters. -! If ADVANCE is present it must be either 'YES' or 'NO'. If absent +! file with I/O unit, `unit`, to define the bitset, `self`. The literal +! may be preceded by an arbitrary sequence of blank characters. +! If `advance` is present it must be either 'YES' or 'NO'. If absent ! it has the default value of 'YES' to determine whether advancing -! I/O occurs. If STATUS is absent an error results in an error stop -! with an informative stop code. If STATUS is present it has the -! default value of SUCCESS, the value INTEGER_OVERFLOW_ERROR if the -! bitset literal has a BITS(SELF) value too large to be -! represented, the value READ_FAILURE if a READ statement fails, -! EOF_FAILURE if a READ statement reach an end-of-file before -! completing the read of the bitset literal, or the value -! CHAR_STRING_INVALID_ERROR if the read of the bitset literal found -! an invalid character, or ARRAY_SIZE_INVALID_ERROR if BITS(SELF) -! in STRING is greater than 64 for a BITSET_64. +! I/O occurs. If `status` is absent an error results in an error stop +! with an informative stop code. If `status` is present it has one of +! the values: +! * `success` - if no problem occurred, +! * `alloc_fault` - if allocation of `self` failed, +! * `array_size_invalid_error` - if `bits(self)` in the bitset literal +! is greater than 64 for a `bitset_64`. +! * `char_string_invalid_error` - if the read of the bitset literal found +! an invalid character, +! * `eof_failure` - if a `read` statement reaches an end-of-file before +! completing the read of the bitset literal, +! * `integer_overflow_error` - if the bitset literal has a `bits(self)` +! value too large to be represented, +! * `read_failure` - if a `read` statement fails, ! class(bitset_large), intent(out) :: self integer, intent(in) :: unit @@ -959,7 +930,6 @@ contains integer :: ierr character(len=128) :: message character(*), parameter :: procedure = "READ_BITSET" - integer :: stat character(len=1) :: char do @@ -968,7 +938,7 @@ contains FMT='(A1)', & err=997, & end=998, & - iostat=ierr, & + iostat=ierr, & iomsg=message ) char select case( char ) case( ' ' ) @@ -986,8 +956,8 @@ contains read( unit, & advance='NO', & FMT='(A1)', & - err=998, & - end=999, & + err=997, & + end=998, & iostat=ierr, & iomsg=message ) char if ( char == 'b' .or. char == 'B' ) exit @@ -995,7 +965,6 @@ contains case( '0', '1', '2', '3', '4', '5', '6', '7', '8', '9' ) digits = digits + 1 if ( digits == 10 .AND. bits > 2_bits_kind**30/5 ) go to 996 -!! May not be quite right if ( digits > 10 ) go to 996 bits = 10*bits + iachar(char) - iachar('0') if ( bits < 0 ) go to 996 @@ -1006,7 +975,12 @@ contains if ( bits < 0 .OR. digits == 0 .OR. digits > 10 ) go to 999 - call self % init( bits ) + call self % init( bits, status ) + if ( present(status) ) then + call error_handler( 'There was an allocation fault for SELF.', & + alloc_fault, status, module_name, procedure ) + return + end if do bit = 1, bits-1 read( unit, & advance='NO', & @@ -1054,39 +1028,23 @@ contains return -996 if ( present(status) ) then - status = integer_overflow_error - return - else - error stop module_name // ' % ' // procedure // ' failed on ' // & - 'integer overflow in reading size of bitset literal from ' // & - 'UNIT.' - end if - +996 call error_handler( 'Integer overflow in reading size of ' // & + 'bitset literal from UNIT.', & + read_failure, status, module_name, procedure ) + return -997 if ( present(status) ) then - status = read_failure - return - else - error stop module_name // ' % ' // procedure // ' failed on ' // & - 'read of UNIT.' - end if +997 call error_handler( 'Failure on read of UNIT.', & + read_failure, status, module_name, procedure ) + return -998 if ( present(status) ) then - status = eof_failure - return - else - error stop module_name // ' % ' // procedure // ' reached ' // & - 'End of File of UNIT before finding a bitset literal.' - end if +998 call error_handler( 'End of File of UNIT before finishing a ' // & + 'bitset literal.', & + eof_failure, status, module_name, procedure ) + return -999 if ( present(status) ) then - status = char_string_invalid_error - return - else - error stop module_name // ' % ' // procedure // ' found an ' // & - 'invalid bitset literal in UNIT.' - end if +999 call error_handler( 'Invalid character in bitset literal in UNIT ', & + char_string_invalid_error, status, & + module_name, procedure ) end subroutine read_bitset_unit_large @@ -1200,7 +1158,11 @@ contains bit_count = self % num_bits allocate( character(len=bit_count)::string, stat=stat ) - if ( stat > 0 ) go to 999 + if ( stat > 0 ) then + call error_handler( 'There was an allocation fault for STRING.', & + alloc_fault, status, module_name, procedure ) + return + end if do bit=0, bit_count-1 pos = bit_count - bit if ( self % test( bit) ) then @@ -1212,16 +1174,6 @@ contains if ( present(status) ) status = success - return - -999 if ( present(status) ) then - status = alloc_fault - return - else - error stop module_name // ' % ' // procedure // ' allocation ' // & - 'of STRING failed.' - end if - end subroutine to_string_large @@ -1277,7 +1229,11 @@ contains call digit_count( self % num_bits, count_digits ) allocate( character(len=count_digits+bit_count+2)::string, stat=stat ) - if ( stat > 0 ) go to 999 + if ( stat > 0 ) then + call error_handler( 'There was an allocation fault for STRING.', & + alloc_fault, status, module_name, procedure ) + return + end if write( string, "('S', i0)" ) self % num_bits @@ -1293,16 +1249,6 @@ contains if ( present(status) ) status = success - return - -999 if ( present(status) ) then - status = alloc_fault - return - else - error stop module_name // ' % ' // procedure // ' had a ' // & - 'memory sllocation failure for a string.' - end if - contains subroutine digit_count( bits, digits ) @@ -1396,17 +1342,11 @@ contains iomsg=message ) & string end if - if (ierr /= 0) go to 999 - - return - -999 if ( present(status) ) then - status = write_failure + if (ierr /= 0) then + call error_handler( 'Failure on a WRiTE statement for UNIT.', & + write_failure, status, module_name, procedure ) return - else - error stop module_name // ' % ' // procedure // ' had a ' // & - 'failure on a WRITE statement.' - end if + endif end subroutine write_bitset_unit_large diff --git a/src/stdlib_bitsets.fypp b/src/stdlib_bitsets.fypp index 5e9e13433..cce3f11bb 100644 --- a/src/stdlib_bitsets.fypp +++ b/src/stdlib_bitsets.fypp @@ -9,6 +9,7 @@ module stdlib_bitsets iso_fortran_env, only: & bits_kind => int32, & block_kind => int64, & + error_unit, & int8, & int16, & int32, & @@ -35,20 +36,22 @@ module stdlib_bitsets integer, parameter, public :: alloc_fault = 1 !! Error flag indicating a memory allocation failure integer, parameter, public :: array_size_invalid_error = 2 -!! error flag indicating an invalid bits value +!! Error flag indicating an invalid bits value integer, parameter, public :: char_string_invalid_error = 3 !! Error flag indicating an invalid character string - integer, parameter, public :: char_string_too_small_error = 4 + integer, parameter, public :: char_string_too_large_error = 4 +!! Error flag indicating a too large character string + integer, parameter, public :: char_string_too_small_error = 5 !! Error flag indicating a too small character string - integer, parameter, public :: index_invalid_error = 5 + integer, parameter, public :: eof_failure = 6 +!! Error flag indicating unexpected End-of-File on a READ + integer, parameter, public :: index_invalid_error = 7 !! Error flag indicating an invalid index - integer, parameter, public :: integer_overflow_error = 6 + integer, parameter, public :: integer_overflow_error = 8 !! Error flag indicating integer overflow - integer, parameter, public :: read_failure = 7 + integer, parameter, public :: read_failure = 9 !! Error flag indicating failure of a READ statement - integer, parameter, public :: eof_failure = 8 -!! Error flag indicating unexpected End-of-File on a READ - integer, parameter, public :: write_failure = 9 + integer, parameter, public :: write_failure = 10 !! Error flag indicating a failure on a WRITE statement public :: bits_kind @@ -75,7 +78,9 @@ module stdlib_bitsets operator(<=), & or, & xor -! Public procedures +!! Public procedures + + public :: error_handler type, abstract :: bitset_type !! version: experimental @@ -292,8 +297,11 @@ module stdlib_bitsets !! Version: experimental !! !! Initializes the bitset `self` treating `string` as a binary literal -!! `status` may have the values `success`, `alloc_fault`, -!! `array_size_invalid_error`, or `char_string_invalid`. +!! `status` may have the values: +!! * `success` - if no problems were found, +!! * `alloc_fault` - if allocation of the bitset failed +!! * `char_string_too_large_error` - if `string` was too large, or +!! * `char_string_invalid_error` - if string had an invalid character. !! !!#### Example !! @@ -326,10 +334,11 @@ module stdlib_bitsets !! Creates the bitset, `self`, of size `bits`, with all bits initialized to !! zero. `bits` must be non-negative. If an error occurs and `status` is !! absent then processing stops with an informative stop code. `status` -!! has a default value of `success`. If an error occurs it has the value -!! `array_size_invalid_error` if `bits` is either negative or larger than 64 -!! if `self` is class `bitset_64`, or the value `alloc_fault` if it failed -!! during allocation of memory for `self`. +!! will have one of the values; +!! * `success` - if no problems were found, +!! * `alloc_fault` - if memory allocation failed +!! * `array_size_invalid_error` - if `bits` is either negative or larger +!! than 64 with `self` of class `bitset_64`, or !! !!#### Example !! @@ -355,12 +364,12 @@ module stdlib_bitsets !! Reads the components of the bitset, `self`, from the unformatted I/O !! unit, `unit`, assuming that the components were written using `output`. !! If an error occurs and `status` is absent then processing stops with -!! an informative stop code. `status` has a default value of `success`. -!! If an error occurs it has the value `read_failure` if it failed -!! during the reads from `unit` or the value `alloc_fault` if it failed -!! during allocation of memory for `self`, or the value -!! `array_size_invalid_error` if the `bits(self)` in `unit` is less than 0 -!! or greater than 64 for a `bitset_64` input. +!! an informative stop code. `status` has one of the values: +!! * `success` - if no problem was found +!! * `alloc_fault` - if it failed allocating memory for `self`, or +!! * `array_size_invalid_error` if the `bits(self)` in `unit` is negative +!! or greater than 64 for a `bitset_64` input. +!! * `read_failure` - if it failed during the reads from `unit` !! !!#### Example !! @@ -512,13 +521,18 @@ module stdlib_bitsets !! Uses the bitset literal in the default character `string`, to define !! the bitset, `self`. The literal may be preceded by an an arbitrary !! sequence of blank characters. If `status` is absent an error results -!! in an error stop with an informative stop code. If `status` is -!! present it has the default value of `success`, the value -!! `integer_overflow_error` if the bitset literal has a `bits(self)` value -!! too large to be represented, the value `alloc_fault` if allocation of -!! memory for `self` failed, or `char_string_invalid_error` if the bitset -!! literal has an invlaaid character, or `array_size_invalid_error` if -!! `bits(self)` in `string` is greater than 64 for a `bitset_64`. +!! in an error stop with an informative stop code. If `status` +!! is present it has one of the values +!! * `success` - if no problems occurred, +!! * `alloc_fault` - if allocation of memory for SELF failed, +!! * `array_size_invalid_error - if `bits(self)` in `string` is greater +!! than 64 for a `bitset_64`, +!! * `char_string_invalid_error` - if the bitset literal has an invalid +!! character, +!! * `char_string_too_small_error - if the string ends before all the bits +!! are read. +!! * `integer_overflow_error` - if the bitset literal has a `bits(self)` +!! value too large to be represented, !! !!#### Example !! @@ -572,15 +586,20 @@ module stdlib_bitsets !! If `advance` is present it must be either 'YES' or 'NO'. If absent !! it has the default value of 'YES' to determine whether advancing !! I/O occurs. If `status` is absent an error results in an error stop -!! with an informative stop code. If `status` is present it has the -!! default value of `success`, the value `integer_overflow_error` if the -!! bitset literal has a `bits(self)` value too large to be -!! represented, the value `read_failure` if a `read` statement fails, -!! `eof_failure` if a `read` statement reaches an end-of-file before -!! completing the read of the bitset literal, or the value -!! `char_string_invalid_error` if the read of the bitset literal found -!! an invalid character, or `array_size_invalid_error` if `bits(self)` -!! in `string` is greater than 64 for a `bitset_64`. +!! with an informative stop code. If `status` is present it has one of +!! the values: +!! * `success` - if no problem occurred, +!! * `alloc_fault` - if allocation of `self` failed, +!! * `array_size_invalid_error` - if `bits(self)` in the bitset literal +!! is greater than 64 for a `bitset_64`, +!! * `char_string_invalid_error` - if the read of the bitset literal found +!! an invalid character, +!! * `eof_failure` - if a `read` statement reached an end-of-file before +!! completing the read of the bitset literal, +!! * `integer_overflow_error` - if the bitset literal has a `bits(self)` +!! value too large to be represented, +!! * `read_failure` - if a `read` statement fails, +! import :: bitset_type class(bitset_type), intent(out) :: self integer, intent(in) :: unit @@ -891,8 +910,11 @@ module stdlib_bitsets !! Version: experimental !! !! Initializes the bitset `self` treating `string` as a binary literal -!! `status` may have the values `success`, `alloc_fault`, -!! `array_size_invalid_error`, or `char_string_invalid`. +!! `status` may have the values: +!! * `success` - if no problems were found, +!! * `alloc_fault` - if allocation of the bitset failed +!! * `char_string_too_large_error` - if `string` was too large, or +!! * `char_string_invalid_error` - if string had an invalid character. class(bitset_large), intent(out) :: self character(*), intent(in) :: string integer, intent(out), optional :: status @@ -904,10 +926,11 @@ module stdlib_bitsets !! Creates the bitset, `self`, of size `bits`, with all bits initialized to !! zero. `bits` must be non-negative. If an error occurs and `status` is !! absent then processing stops with an informative stop code. `status` -!! has a default value of `success`. If an error occurs it has the value -!! `array_size_invalid_error` if `bits` is either negative larger than 64 -!! if `self` is of type `bitset_64`, or the value `alloc_fault` if it failed -!! during allocation of memory for `self`. +!! will have one of the values; +!! * `success` - if no problems were found, +!! * `alloc_fault` - if memory allocation failed +!! * `array_size_invalid_error` - if `bits` is either negative or larger +!! than 64 with `self` of class `bitset_64`, or class(bitset_large), intent(out) :: self integer(bits_kind), intent(in) :: bits integer, intent(out), optional :: status @@ -919,12 +942,12 @@ module stdlib_bitsets !! Reads the components of the bitset, `self`, from the unformatted I/O !! unit, `unit`, assuming that the components were written using `output`. !! If an error occurs and `status` is absent then processing stops with -!! an informative stop code. `status` has a default value of `success`. -!! If an error occurs it has the value `read_failure` if it failed -!! during the reads from `unit` or the value `alloc_fault` if it failed -!! during allocation of memory for `self`, or the value -!! `array_size_invalid_error if the `bits(self) in `unit` is less than 0 -!! or greater than 64 for a `bitset_64` input. +!! an informative stop code. `status` has one of the values: +!! * `success` - if no problem was found +!! * `alloc_fault` - if it failed allocating memory for `self`, or +!! * `array_size_invalid_error` if the `bits(self)` in `unit` is negative +!! or greater than 64 for a `bitset_64` input. +!! * `read_failure` - if it failed during the reads from `unit` class(bitset_large), intent(out) :: self integer, intent(in) :: unit integer, intent(out), optional :: status @@ -964,15 +987,18 @@ module stdlib_bitsets !! Uses the bitset literal in the default character `string`, to define !! the bitset, `self`. The literal may be preceded by an an arbitrary !! sequence of blank characters. If `status` is absent an error results -!! in an error stop with an informative stop code. If `status` is -!! present it has the default value of `success`, the value -!! `integer_overflow_error` if the bitset literal has a `bits(self)` value -!! too large to be represented, the value `alloc_fault` if allocation of -!! memory for `self` failed, or `char_string_invalid_error` if the bitset -!! literal has an invlaid character, or `array_size_invalid_error` if -!! `bits(self)` in `string` is greater than 64 for a `bitset_64`, or -!! `char_string_too_small_error` if the string ends before all the bits -!! are read. +!! in an error stop with an informative stop code. If `status` +!! is present it has one of the values +!! * `success` - if no problems occurred, +!! * `alloc_fault` - if allocation of memory for SELF failed, +!! * `array_size_invalid_error - if `bits(self)` in `string` is greater +!! than 64 for a `bitset_64`, +!! * `char_string_invalid_error` - if the bitset literal has an invalid +!! character, +!! * `char_string_too_small_error - if the string ends before all the bits +!! are read. +!! * `integer_overflow_error` - if the bitset literal has a `bits(self)` +!! value too large to be represented, class(bitset_large), intent(out) :: self character(len=*), intent(in) :: string integer, intent(out), optional :: status @@ -987,15 +1013,19 @@ module stdlib_bitsets !! If `advance` is present it must be either 'YES' or 'NO'. If absent !! it has the default value of 'YES' to determine whether advancing !! I/O occurs. If `status` is absent an error results in an error stop -!! with an informative stop code. If `status` is present it has the -!! default value of `success`, the value `integer_overflow_error` if the -!! bitset literal has a `bits(self)` value too large to be -!! represented, the value `read_failure` if a `read` statement fails, -!! `eof_failure` if a `read` statement reach an end-of-file before -!! completing the read of the bitset literal, or the value -!! `char_string_invalid_error` if the read of the bitset literal found -!! an invalid character, or `array_size_invalid_error` if `bits(self)` -!! in `string` is greater than 64 for a `bitset_64`. +!! with an informative stop code. If `status` is present it has one of +!! the values: +!! * `success` - if no problem occurred, +!! * `alloc_fault` - if allocation of `self` failed, +!! * `array_size_invalid_error` - if `bits(self)` in the bitset literal +!! is greater than 64 for a `bitset_64`, +!! * `char_string_invalid_error` - if the read of the bitset literal found +!! an invalid character, +!! * `eof_failure` - if a `read` statement reached an end-of-file before +!! completing the read of the bitset literal, +!! * `integer_overflow_error` - if the bitset literal has a `bits(self)` +!! value too large to be represented, +!! * `read_failure` - if a `read` statement fails, class(bitset_large), intent(out) :: self integer, intent(in) :: unit character(*), intent(in), optional :: advance @@ -1253,10 +1283,11 @@ module stdlib_bitsets !! Version: experimental !! !! Initializes the bitset `self` treating `string` as a binary literal -!! `status` has the default value `success`, the value `alloc_fault` if the -!! allocation of the bits in self failed, `array_size_invalid_error` if the -!! `len(string)>64` for a `bitset_64`, or `char_string_invalid` if an invalid -!! character was found in `string`. +!! `status` may have the values: +!! * `success` - if no problems were found, +!! * `alloc_fault` - if allocation of the bitset failed +!! * `char_string_too_large_error` - if `string` was too large, or +!! * `char_string_invalid_error` - if string had an invalid character. class(bitset_64), intent(out) :: self character(*), intent(in) :: string integer, intent(out), optional :: status @@ -1268,10 +1299,11 @@ module stdlib_bitsets !! Creates the bitset, `self`, of size `bits`, with all bits initialized to !! zero. `bits` must be non-negative. If an error occurs and `status` is !! absent then processing stops with an informative stop code. `status` -!! has a default value of `success`. If an error occurs it has the value -!! `array_size_invalid_error` if `bits` is either negative larger than 64 -!! for `self` of type `bitset_64`, or the value `alloc_fault` if it failed -!! during allocation of memory for `self`. +!! will have one of the values; +!! * `success` - if no problems were found, +!! * `alloc_fault` - if memory allocation failed +!! * `array_size_invalid_error` - if `bits` is either negative or larger +!! than 64 with `self` of class `bitset_64`, or class(bitset_64), intent(out) :: self integer(bits_kind), intent(in) :: bits integer, intent(out), optional :: status @@ -1283,12 +1315,12 @@ module stdlib_bitsets !! Reads the components of the bitset, `self`, from the unformatted I/O !! unit, `unit`, assuming that the components were written using `output`. !! If an error occurs and `status` is absent then processing stops with -!! an informative stop code. `status` has a default value of `success`. -!! If an error occurs it has the value `read_failure` if it failed -!! during the reads from `unit` or the value `alloc_fault` if it failed -!! during allocation of memory for `self`, or the value -!! `array_size_invalid_error` if the `bits(self)` in `unit` is less than 0 -!! or greater than 64 for a `bitset_64` input. +!! an informative stop code. `status` has one of the values: +!! * `success` - if no problem was found +!! * `alloc_fault` - if it failed allocating memory for `self`, or +!! * `array_size_invalid_error` if the `bits(self)` in `unit` is negative +!! or greater than 64 for a `bitset_64` input. +!! * `read_failure` - if it failed during the reads from `unit` class(bitset_64), intent(out) :: self integer, intent(in) :: unit integer, intent(out), optional :: status @@ -1328,15 +1360,18 @@ module stdlib_bitsets !! Uses the bitset literal in the default character `string`, to define !! the bitset, `self`. The literal may be preceded by an an arbitrary !! sequence of blank characters. If `status` is absent an error results -!! in an error stop with an informative stop code. If `status` is -!! present it has the default value of `success`, the value -!! `integer_overflow_error` if the bitset literal has a `bits(self)` value -!! too large to be represented, the value `alloc_fault` if allocation of -!! memory for `self` failed, or `char_string_invalid_error` if the bitset -!! literal has an invlaid character, or `array_size_invalid_error` if -!! `bits(self)` in `string` is greater than 64 for a `bitset_64`, or -!! `char_string_too_small_error` if the string ends before all the bits -!! are read. +!! in an error stop with an informative stop code. If `status` +!! is present it has one of the values +!! * `success` - if no problems occurred, +!! * `alloc_fault` - if allocation of memory for SELF failed, +!! * `array_size_invalid_error - if `bits(self)` in `string` is greater +!! than 64 for a `bitset_64`, +!! * `char_string_invalid_error` - if the bitset literal has an invalid +!! character, +!! * `char_string_too_small_error - if the string ends before all the bits +!! are read. +!! * `integer_overflow_error` - if the bitset literal has a `bits(self)` +!! value too large to be represented, class(bitset_64), intent(out) :: self character(len=*), intent(in) :: string integer, intent(out), optional :: status @@ -1351,15 +1386,19 @@ module stdlib_bitsets !! If `advance` is present it must be either 'YES' or 'NO'. If absent !! it has the default value of 'YES' to determine whether advancing !! I/O occurs. If `status` is absent an error results in an error stop -!! with an informative stop code. If `status` is present it has the -!! default value of `success`, the value `integer_overflow_error` if the -!! bitset literal has a `bits(self)` value too large to be -!! represented, the value `read_failure` if a `read` statement fails, -!! `eof_failure` if a `read` statement reach an end-of-file before -!! completing the read of the bitset literal, or the value -!! `char_string_invalid_error` if the read of the bitset literal found -!! an invalid character, or `array_size_invalid_error` if `bits(self)` -!! in `string` is greater than 64 for a `bitset_64`. +!! with an informative stop code. If `status` is present it has one of +!! the values: +!! * `success` - if no problem occurred, +!! * `alloc_fault` - if allocation of `self` failed, +!! * `array_size_invalid_error` - if `bits(self)` in the bitset literal +!! is greater than 64 for a `bitset_64`, +!! * `char_string_invalid_error` - if the read of the bitset literal found +!! an invalid character, +!! * `eof_failure` - if a `read` statement reached an end-of-file before +!! completing the read of the bitset literal, +!! * `integer_overflow_error` - if the bitset literal has a `bits(self)` +!! value too large to be represented, +!! * `read_failure` - if a `read` statement fails, class(bitset_64), intent(out) :: self integer, intent(in) :: unit character(*), intent(in), optional :: advance @@ -1587,7 +1626,7 @@ module stdlib_bitsets !! bitset `old`. If 'start_pos` is greater than `stop_pos` the new bitset is !! empty. If `start_pos` is less than zero or `stop_pos` is greater than !! `bits(old)-1` then if `status` is present it has the value -!! `index_invalid_error`and `new` is undefined, otherwise processing stops +!! `index_invalid_error` and `new` is undefined, otherwise processing stops !! with an informative message. !! !!#### Example @@ -2009,6 +2048,16 @@ module stdlib_bitsets end interface operator(<=) + interface error_handler + module subroutine error_handler( message, error, status, module, procedure ) + character(*), intent(in) :: message + integer, intent(in) :: error + integer, intent(out), optional :: status + character(*), intent(in), optional :: module + character(*), intent(in), optional :: procedure + end subroutine error_handler + end interface error_handler + contains elemental function bits(self) @@ -2023,5 +2072,55 @@ contains return end function bits + module subroutine error_handler( message, error, status, module, procedure ) + character(*), intent(in) :: message + integer, intent(in) :: error + integer, intent(out), optional :: status + character(*), intent(in), optional :: module + character(*), intent(in), optional :: procedure + + if ( present(status) ) then + status = error + else + if ( present(module) ) then + if ( present(procedure) ) then + write(error_unit, '(a)') trim(module) // ' % ' // & + trim(procedure) // ': ' // trim(message) + else + write(error_unit, '(a)') trim(module) // ' % N/A: ' // & + trim(message) + end if + else if ( present(procedure) ) then + write(error_unit, '(a)') trim(procedure) // ': ' // & + trim(message) + else + write(error_unit, '(a)') trim(message) + end if + select case(error) + case( alloc_fault ) + error stop 'A memory allocation failed.' + case( array_size_invalid_error ) + error stop "An array size was invalid." + case( char_string_invalid_error ) + error stop "A character string had an invalid character." + case( char_string_too_large_error ) + error stop "A character string was too large." + case( char_string_too_small_error ) + error stop "A character string was too small." + case( eof_failure ) + error stop "An End-Of-File failure occurred on a READ " // & + "statement." + case( index_invalid_error ) + error stop "An index was invalid." + case( integer_overflow_error ) + error stop "An integer overflow error occurred." + case( read_failure ) + error stop "A failure occurred in a READ statement." + case( write_failure ) + error stop "A failure occurRed on a WRITE statement." + end select + end if + end subroutine error_handler + end module stdlib_bitsets From 9e9c252d38b9635369a5be696c05624724d83e2f Mon Sep 17 00:00:00 2001 From: William Clodius Date: Fri, 9 Oct 2020 06:55:02 -0600 Subject: [PATCH 15/53] Better documented status results Was more consistent in using bulleted lists in documenting status error codes. Added char_string_too_large_error to the error codes. [ticket: X] --- doc/specs/stdlib_bitsets.md | 26 +++++++++++++++++++++----- 1 file changed, 21 insertions(+), 5 deletions(-) diff --git a/doc/specs/stdlib_bitsets.md b/doc/specs/stdlib_bitsets.md index 756e70ca7..bd9b5406c 100644 --- a/doc/specs/stdlib_bitsets.md +++ b/doc/specs/stdlib_bitsets.md @@ -34,8 +34,9 @@ bits. The other constants that are error codes are summarized below: |----------|-------| |`success`|No problems found| |`alloc_fault`|Failure with a memory allocation| -|`array_size_invalid_error`|Attempt to define more than 64 bits in a `bitset_64`| +|`array_size_invalid_error`|Attempt to define either negative bits or more than 64 bits in a `bitset_64`| |`char_string_invalid_error`|Invalid character found in a character string| +|`char_string_too_large_error`|Character string was too large to be encoded in the bitset| |`char_string_too_small_error`|Character string was too small to hold the expected number of bits| |`index_invalid_error`|Index to a bitstring was less than zero or greater than the number of bits| |`integer_overflow_error`|Attempt to define an integer value bigger than `huge(0_bits_kind`)| @@ -753,7 +754,17 @@ and "1". an `intent(out)` argument. If present, on return its value shall be one of the error codes defined in this module. If absent, and its value would not have been `success`, then processing will stop with an -informative text as its stop code. +informative text as its stop code. It shall have one of the error +codes: + +* `success` - if no problems were found, + +* `alloc_fault` - if allocation of the bitset failed + +* `char_string_too_large_error` - if `string` was too large, or + +* `char_string_invalid_error` - if string had an invalid character. + #### Example @@ -1188,7 +1199,7 @@ value of one of the error codes of this module. If absent and it would not have had the value `success` processing will stop with a message as its error code. The possible error codes are: -* `success` - no problems detected; +* `success` - no problems found; * `alloc_fault` - if `self` is of class `bitset_large` and allocation of the bits failed; @@ -1200,10 +1211,15 @@ as its error code. The possible error codes are: character; * `char_string_too_small_error` - if `string` ends before all the bits - are read; or + are read; + +* `eof_failure` - if a `read` statement reached an end-of-file before + completing the read of the bitset literal, * `integer_overflow_error` - if the *bitset-literal* has a `bits` - value larger than `huge(0_bits_kind)`. + value larger than `huge(0_bits_kind)`; or + +* `read_failure` - if a read statement failed. #### Example From 421c4d247886dbe2790189bcd4fa656173d9c607 Mon Sep 17 00:00:00 2001 From: William Clodius Date: Fri, 9 Oct 2020 07:18:23 -0600 Subject: [PATCH 16/53] Removed trailing blanks Working with fypp made it easier to add unwanted trailing blanks. I removed them. [ticket: X] --- src/stdlib_bitset_64.fypp | 6 +++--- src/stdlib_bitset_large.fypp | 6 +++--- src/stdlib_bitsets.fypp | 18 +++++++++--------- 3 files changed, 15 insertions(+), 15 deletions(-) diff --git a/src/stdlib_bitset_64.fypp b/src/stdlib_bitset_64.fypp index 954ad8377..354bfe4e6 100644 --- a/src/stdlib_bitset_64.fypp +++ b/src/stdlib_bitset_64.fypp @@ -291,7 +291,7 @@ contains ! `status` may have the values: ! `success` - if no problems were found, ! `alloc_fault` - if allocation of the bitset failed -! `char_string_too_large_error` - if `string` was too large, or +! `char_string_too_large_error` - if `string` was too large, or ! `char_string_invalid_error` - if string had an invalid character. class(bitset_64), intent(out) :: self character(*), intent(in) :: string @@ -610,7 +610,7 @@ contains ! in an error stop with an informative stop code. If `status` ! is present it has one of the values ! * `success` - if no problems occurred, -! * `alloc_fault` - if allocation of memory for SELF failed, +! * `alloc_fault` - if allocation of memory for SELF failed, ! * `array_size_invalid_error - if `bits(self)` in `string` is greater ! than 64 for a `bitset_64`, ! * `char_string_invalid_error` - if the bitset literal has an invalid @@ -618,7 +618,7 @@ contains ! * `char_string_too_small_error - if the string ends before all the bits ! are read. ! * `integer_overflow_error` - if the bitset literal has a `bits(self)` -! value too large to be represented, +! value too large to be represented, ! class(bitset_64), intent(out) :: self character(len=*), intent(in) :: string diff --git a/src/stdlib_bitset_large.fypp b/src/stdlib_bitset_large.fypp index d166d383b..0fa42e795 100644 --- a/src/stdlib_bitset_large.fypp +++ b/src/stdlib_bitset_large.fypp @@ -401,7 +401,7 @@ contains ! `status` may have the values: ! `success` - if no problems were found, ! `alloc_fault` - if allocation of the bitset failed -! `char_string_too_large_error` - if `string` was too large, or +! `char_string_too_large_error` - if `string` was too large, or ! `char_string_invalid_error` - if string had an invalid character. class(bitset_large), intent(out) :: self character(*), intent(in) :: string @@ -799,7 +799,7 @@ contains ! in an error stop with an informative stop code. If `status` ! is present it has one of the values ! * `success` - if no problems occurred, -! * `alloc_fault` - if allocation of memory for SELF failed, +! * `alloc_fault` - if allocation of memory for SELF failed, ! * `array_size_invalid_error - if `bits(self)` in `string` is greater ! than 64 for a `bitset_64`, ! * `char_string_invalid_error` - if the bitset literal has an invalid @@ -807,7 +807,7 @@ contains ! * `char_string_too_small_error - if the string ends before all the bits ! are read. ! * `integer_overflow_error` - if the bitset literal has a `bits(self)` -! value too large to be represented, +! value too large to be represented, ! class(bitset_large), intent(out) :: self character(len=*), intent(in) :: string diff --git a/src/stdlib_bitsets.fypp b/src/stdlib_bitsets.fypp index cce3f11bb..b1d5297e1 100644 --- a/src/stdlib_bitsets.fypp +++ b/src/stdlib_bitsets.fypp @@ -300,7 +300,7 @@ module stdlib_bitsets !! `status` may have the values: !! * `success` - if no problems were found, !! * `alloc_fault` - if allocation of the bitset failed -!! * `char_string_too_large_error` - if `string` was too large, or +!! * `char_string_too_large_error` - if `string` was too large, or !! * `char_string_invalid_error` - if string had an invalid character. !! !!#### Example @@ -524,7 +524,7 @@ module stdlib_bitsets !! in an error stop with an informative stop code. If `status` !! is present it has one of the values !! * `success` - if no problems occurred, -!! * `alloc_fault` - if allocation of memory for SELF failed, +!! * `alloc_fault` - if allocation of memory for SELF failed, !! * `array_size_invalid_error - if `bits(self)` in `string` is greater !! than 64 for a `bitset_64`, !! * `char_string_invalid_error` - if the bitset literal has an invalid @@ -532,7 +532,7 @@ module stdlib_bitsets !! * `char_string_too_small_error - if the string ends before all the bits !! are read. !! * `integer_overflow_error` - if the bitset literal has a `bits(self)` -!! value too large to be represented, +!! value too large to be represented, !! !!#### Example !! @@ -913,7 +913,7 @@ module stdlib_bitsets !! `status` may have the values: !! * `success` - if no problems were found, !! * `alloc_fault` - if allocation of the bitset failed -!! * `char_string_too_large_error` - if `string` was too large, or +!! * `char_string_too_large_error` - if `string` was too large, or !! * `char_string_invalid_error` - if string had an invalid character. class(bitset_large), intent(out) :: self character(*), intent(in) :: string @@ -990,7 +990,7 @@ module stdlib_bitsets !! in an error stop with an informative stop code. If `status` !! is present it has one of the values !! * `success` - if no problems occurred, -!! * `alloc_fault` - if allocation of memory for SELF failed, +!! * `alloc_fault` - if allocation of memory for SELF failed, !! * `array_size_invalid_error - if `bits(self)` in `string` is greater !! than 64 for a `bitset_64`, !! * `char_string_invalid_error` - if the bitset literal has an invalid @@ -998,7 +998,7 @@ module stdlib_bitsets !! * `char_string_too_small_error - if the string ends before all the bits !! are read. !! * `integer_overflow_error` - if the bitset literal has a `bits(self)` -!! value too large to be represented, +!! value too large to be represented, class(bitset_large), intent(out) :: self character(len=*), intent(in) :: string integer, intent(out), optional :: status @@ -1286,7 +1286,7 @@ module stdlib_bitsets !! `status` may have the values: !! * `success` - if no problems were found, !! * `alloc_fault` - if allocation of the bitset failed -!! * `char_string_too_large_error` - if `string` was too large, or +!! * `char_string_too_large_error` - if `string` was too large, or !! * `char_string_invalid_error` - if string had an invalid character. class(bitset_64), intent(out) :: self character(*), intent(in) :: string @@ -1363,7 +1363,7 @@ module stdlib_bitsets !! in an error stop with an informative stop code. If `status` !! is present it has one of the values !! * `success` - if no problems occurred, -!! * `alloc_fault` - if allocation of memory for SELF failed, +!! * `alloc_fault` - if allocation of memory for SELF failed, !! * `array_size_invalid_error - if `bits(self)` in `string` is greater !! than 64 for a `bitset_64`, !! * `char_string_invalid_error` - if the bitset literal has an invalid @@ -1371,7 +1371,7 @@ module stdlib_bitsets !! * `char_string_too_small_error - if the string ends before all the bits !! are read. !! * `integer_overflow_error` - if the bitset literal has a `bits(self)` -!! value too large to be represented, +!! value too large to be represented, class(bitset_64), intent(out) :: self character(len=*), intent(in) :: string integer, intent(out), optional :: status From d2be3dc2a69bf3ed5e31b230244f8bf90c667ba8 Mon Sep 17 00:00:00 2001 From: William Clodius Date: Fri, 9 Oct 2020 07:36:32 -0600 Subject: [PATCH 17/53] Added missing return In all my editing I dropped a return in stdlib_bitset_64.fypp and failed to run test_stdlib_bitset_64. [ticket: X] --- src/stdlib_bitset_64.fypp | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/stdlib_bitset_64.fypp b/src/stdlib_bitset_64.fypp index 354bfe4e6..b451b64fe 100644 --- a/src/stdlib_bitset_64.fypp +++ b/src/stdlib_bitset_64.fypp @@ -841,6 +841,8 @@ contains if ( present(status) ) status = success + return + 996 call error_handler( 'Integer overflow in reading size of ' // & 'bitset literal from UNIT.', & read_failure, status, module_name, procedure ) From b0c0f63f40b62bf535c8ab5aaaa5eb55dde2c795 Mon Sep 17 00:00:00 2001 From: William Clodius Date: Fri, 9 Oct 2020 07:44:57 -0600 Subject: [PATCH 18/53] Changed WRiTE to WRITE Fixed typo in four places [ticket: X] --- src/stdlib_bitset_64.fypp | 4 ++-- src/stdlib_bitset_large.fypp | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/stdlib_bitset_64.fypp b/src/stdlib_bitset_64.fypp index b451b64fe..861a7c4b4 100644 --- a/src/stdlib_bitset_64.fypp +++ b/src/stdlib_bitset_64.fypp @@ -596,7 +596,7 @@ contains return -999 call error_handler( 'Failure on a WRiTE statement for UNIT.', & +999 call error_handler( 'Failure on a WRITE statement for UNIT.', & write_failure, status, module_name, procedure ) end subroutine output_64 @@ -1119,7 +1119,7 @@ contains string end if if (ierr /= 0) then - call error_handler( 'Failure on a WRiTE statement for UNIT.', & + call error_handler( 'Failure on a WRITE statement for UNIT.', & write_failure, status, module_name, procedure ) return endif diff --git a/src/stdlib_bitset_large.fypp b/src/stdlib_bitset_large.fypp index 0fa42e795..819874745 100644 --- a/src/stdlib_bitset_large.fypp +++ b/src/stdlib_bitset_large.fypp @@ -785,7 +785,7 @@ contains return -999 call error_handler( 'Failure on a WRiTE statement for UNIT.', & +999 call error_handler( 'Failure on a WRITE statement for UNIT.', & write_failure, status, module_name, procedure ) end subroutine output_large @@ -1343,7 +1343,7 @@ contains string end if if (ierr /= 0) then - call error_handler( 'Failure on a WRiTE statement for UNIT.', & + call error_handler( 'Failure on a WRITE statement for UNIT.', & write_failure, status, module_name, procedure ) return endif From b12e39839e2933ed98694808b1f9345b4f90ce10 Mon Sep 17 00:00:00 2001 From: William Clodius Date: Fri, 9 Oct 2020 17:17:00 -0600 Subject: [PATCH 19/53] Changed the kind of bit Changed the kind of bit from bits_kind to int64 to silence a spurious warning. [ticket: X] --- src/stdlib_bitset_64.fypp | 6 +++--- src/stdlib_bitset_large.fypp | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/stdlib_bitset_64.fypp b/src/stdlib_bitset_64.fypp index 861a7c4b4..dca6a9c0e 100644 --- a/src/stdlib_bitset_64.fypp +++ b/src/stdlib_bitset_64.fypp @@ -298,9 +298,9 @@ contains integer, intent(out), optional :: status character(*), parameter :: procedure = 'FROM_STRING' - integer(bits_kind) :: bit - integer(int64) :: bits - character(1) :: char + integer(int64) :: bit + integer(int64) :: bits + character(1) :: char bits = len(string, kind=int64) if ( bits > 64 ) then diff --git a/src/stdlib_bitset_large.fypp b/src/stdlib_bitset_large.fypp index 819874745..f3ed73cb1 100644 --- a/src/stdlib_bitset_large.fypp +++ b/src/stdlib_bitset_large.fypp @@ -408,9 +408,9 @@ contains integer, intent(out), optional :: status character(*), parameter :: procedure = 'FROM_STRING' - integer(bits_kind) :: bit - integer(int64) :: bits - character(1) :: char + integer(int64) :: bit + integer(int64) :: bits + character(1) :: char bits = len(string, kind=int64) if ( bits > huge(0_bits_kind) ) then From 983a08340d4212728e5fc9858b0e3b25bd7d5759 Mon Sep 17 00:00:00 2001 From: William Clodius Date: Fri, 9 Oct 2020 17:23:27 -0600 Subject: [PATCH 20/53] Changed subtraction of bit from outside an int converson to inside Changing bit's kind to int64 and not putting it in the int conversion made the arguments to clear and set of kind int64, for wwhich there was no specific interface. [ticket: X] --- src/stdlib_bitset_64.fypp | 4 ++-- src/stdlib_bitset_large.fypp | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/stdlib_bitset_64.fypp b/src/stdlib_bitset_64.fypp index dca6a9c0e..1ba52c368 100644 --- a/src/stdlib_bitset_64.fypp +++ b/src/stdlib_bitset_64.fypp @@ -314,9 +314,9 @@ contains do bit = 1, bits char = string(bit:bit) if ( char == '0' ) then - call self % clear( int(bits, kind=bits_kind)-bit ) + call self % clear( int(bits-bit, kind=bits_kind) ) else if ( char == '1' ) then - call self % set( int(bits, kind=bits_kind)-bit ) + call self % set( int(bits-bit, kind=bits_kind) ) else call error_handler( 'STRING had a character other than ' // & '0 or 1.', & diff --git a/src/stdlib_bitset_large.fypp b/src/stdlib_bitset_large.fypp index f3ed73cb1..e7e24b9fb 100644 --- a/src/stdlib_bitset_large.fypp +++ b/src/stdlib_bitset_large.fypp @@ -430,9 +430,9 @@ contains do bit = 1_bits_kind, bits char = string(bit:bit) if ( char == '0' ) then - call self % clear( int(bits, kind=bits_kind)-bit ) + call self % clear( int(bits-bit, kind=bits_kind) ) else if ( char == '1' ) then - call self % set( int(bits, kind=bits_kind)-bit ) + call self % set( int(bits-bit, kind=bits_kind) ) else call error_handler( 'STRING had a character other than ' // & '0 or 1.', & From 38095c0cd3a136591dacf4345e418db3184ba208 Mon Sep 17 00:00:00 2001 From: William Clodius Date: Fri, 9 Oct 2020 20:01:34 -0600 Subject: [PATCH 21/53] Deleted redundant returns. Deleted two returns at the end of procedures. [ticket: X] --- src/stdlib_bitset_large.fypp | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/stdlib_bitset_large.fypp b/src/stdlib_bitset_large.fypp index e7e24b9fb..b5020ddf5 100644 --- a/src/stdlib_bitset_large.fypp +++ b/src/stdlib_bitset_large.fypp @@ -444,8 +444,6 @@ contains if ( present(status) ) status = success - return - end subroutine from_string_large From cc477b91bac8ea69e0b5a751a7299091da86068f Mon Sep 17 00:00:00 2001 From: William Clodius Date: Fri, 9 Oct 2020 20:03:59 -0600 Subject: [PATCH 22/53] Deleted redundant return Deleted return at the end of a procedure. [ticket: X] --- src/stdlib_bitset_64.fypp | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/stdlib_bitset_64.fypp b/src/stdlib_bitset_64.fypp index 1ba52c368..bcf9376ee 100644 --- a/src/stdlib_bitset_64.fypp +++ b/src/stdlib_bitset_64.fypp @@ -328,8 +328,6 @@ contains if ( present(status) ) status = success - return - end subroutine from_string_64 From beca325a2731eb2326785c096560cba70332be2e Mon Sep 17 00:00:00 2001 From: William Clodius Date: Fri, 9 Oct 2020 21:15:52 -0600 Subject: [PATCH 23/53] Regularized code fences Unindented ```fortran and added trailing ``` to the example codes in the FORD comments, [ticket: X] --- src/stdlib_bitsets.fypp | 116 ++++++++++++++++++++-------------------- 1 file changed, 58 insertions(+), 58 deletions(-) diff --git a/src/stdlib_bitsets.fypp b/src/stdlib_bitsets.fypp index b1d5297e1..4ba4a5566 100644 --- a/src/stdlib_bitsets.fypp +++ b/src/stdlib_bitsets.fypp @@ -137,7 +137,7 @@ module stdlib_bitsets !! !!#### Example !! -!! ```fortran +!!```fortran !! program demo_all !! use stdlib_bitsets !! character(*), parameter :: & @@ -155,7 +155,7 @@ module stdlib_bitsets !! " into set0." !! end if !! end program demo_all -!! +!!``` import :: bitset_type logical :: all class(bitset_type), intent(in) :: self @@ -168,7 +168,7 @@ module stdlib_bitsets !! !!#### Example !! -!! ```fortran +!!```fortran !! program demo_any !! use stdlib_bitsets !! character(*), parameter :: & @@ -184,7 +184,7 @@ module stdlib_bitsets !! write(*,*) "ANY interpreted SET0's value properly." !! end if !! end program demo_any -!! +!!``` import :: bitset_type logical :: any class(bitset_type), intent(in) :: self @@ -197,7 +197,7 @@ module stdlib_bitsets !! !!#### Example !! -!! ```fortran +!!```fortran !! program demo_bit_count !! use stdlib_bitsets !! character(*), parameter :: & @@ -213,7 +213,7 @@ module stdlib_bitsets !! write(*,*) "BIT_COUNT interpreted SET0's value properly." !! end if !! end program demo_bit_count -!! +!!``` import :: bitset_type, bits_kind integer(bits_kind) :: bit_count class(bitset_type), intent(in) :: self @@ -227,7 +227,7 @@ module stdlib_bitsets !! !!#### Example !! -!! ```fortran +!!```fortran !! program demo_clear !! use stdlib_bitsets !! type(bitset_large) :: set0 @@ -239,7 +239,7 @@ module stdlib_bitsets !! call set0 % clear(0,164) !! if ( set0 % none() ) write(*,*) 'All bits are cleared.' !! end program demo_clear -!! +!!``` import :: bitset_type, bits_kind class(bitset_type), intent(inout) :: self integer(bits_kind), intent(in) :: pos @@ -265,7 +265,7 @@ module stdlib_bitsets !! !!#### Example !! -!! ```fortran +!!```fortran !! program demo_flip !! use stdlib_bitsets !! type(bitset_large) :: set0 @@ -276,7 +276,7 @@ module stdlib_bitsets !! call set0 % flip(0,164) !! if ( set0 % all() ) write(*,*) 'All bits are flipped.' !! end program demo_flip -!! +!!``` import :: bitset_type, bits_kind class(bitset_type), intent(inout) :: self integer(bits_kind), intent(in) :: pos @@ -305,7 +305,7 @@ module stdlib_bitsets !! !!#### Example !! -!! ```fortran +!!```fortran !! program demo_from_string !! use stdlib_bitsets !! character(*), parameter :: & @@ -323,7 +323,7 @@ module stdlib_bitsets !! " into set0." !! end if !! end program demo_from_string -!! +!!``` import :: bitset_type class(bitset_type), intent(out) :: self character(*), intent(in) :: string @@ -342,7 +342,7 @@ module stdlib_bitsets !! !!#### Example !! -!! ```fortran +!!```fortran !! program demo_init !! use stdlib_bitsets !! type(bitset_large) :: set0 @@ -351,7 +351,7 @@ module stdlib_bitsets !! write(*,*) `SET0 has the proper size.' !! if ( set0 % none() ) write(*,*) 'SET0 is properly initialized.' !! end program demo_init -!! +!!``` import :: bitset_type, bits_kind class(bitset_type), intent(out) :: self integer(bits_kind), intent(in) :: bits @@ -373,7 +373,7 @@ module stdlib_bitsets !! !!#### Example !! -!! ```fortran +!!```fortran !! program demo_input !! character(*), parameter :: & !! bits_0 = '000000000000000000000000000000000', & @@ -404,7 +404,7 @@ module stdlib_bitsets !! 'output and input succeeded.' !! end if !! end program demo_input -!! +!!``` import :: bitset_type class(bitset_type), intent(out) :: self integer, intent(in) :: unit @@ -418,7 +418,7 @@ module stdlib_bitsets !! !!#### Example !! -!! ```fortran +!!```fortran !! program demo_none !! use stdlib_bitsets !! character(*), parameter :: & @@ -434,7 +434,7 @@ module stdlib_bitsets !! write(*,*) "NONE interpreted SET0's value properly." !! end if !! end program demo_none -!! +!!``` import :: bitset_type logical :: none class(bitset_type), intent(in) :: self @@ -447,7 +447,7 @@ module stdlib_bitsets !! !!#### Example !! -!! ```fortran +!!```fortran !! program demo_not !! use stdlib_bitsets !! type(bitset_large) :: set0 @@ -461,7 +461,7 @@ module stdlib_bitsets !! write(*,*) "ALL interpreted SET0's value properly." !! end if !! end program demo_not -!! +!!``` import :: bitset_type class(bitset_type), intent(inout) :: self end subroutine not_abstract @@ -477,7 +477,7 @@ module stdlib_bitsets !! !!#### Example !! -!! ```fortran +!!```fortran !! program demo_output !! character(*), parameter :: & !! bits_0 = '000000000000000000000000000000000', & @@ -508,7 +508,7 @@ module stdlib_bitsets !! 'output and input succeeded.' !! end if !! end program demo_output -!! +!!``` import :: bitset_type class(bitset_type), intent(in) :: self integer, intent(in) :: unit @@ -536,7 +536,7 @@ module stdlib_bitsets !! !!#### Example !! -!! ```fortran +!!```fortran !! program demo_read_bitset !! character(*), parameter :: & !! bits_0 = 'S33B000000000000000000000000000000000', & @@ -570,7 +570,7 @@ module stdlib_bitsets !! write(*,*) WRITE_BITSET to READ_BITSET through unit worked.' !! end if !! end program demo_read_bitset -!! +!!``` import :: bitset_type class(bitset_type), intent(out) :: self character(len=*), intent(in) :: string @@ -616,7 +616,7 @@ module stdlib_bitsets !! !!#### Example !! -!! ```fortran +!!```fortran !! program demo_set !! use stdlib_bitsets !! type(bitset_large) :: set0 @@ -627,7 +627,7 @@ module stdlib_bitsets !! call set0 % set(0,164) !! if ( set0 % all() ) write(*,*) 'All bits are set.' !! end program demo_set -!! +!!``` import :: bitset_type, bits_kind class(bitset_type), intent(inout) :: self integer(bits_kind), intent(in) :: pos @@ -652,7 +652,7 @@ module stdlib_bitsets !! !!#### Example !! -!! ```fortran +!!```fortran !! program demo_test !! use stdlib_bitsets !! type(bitset_large) :: set0 @@ -664,7 +664,7 @@ module stdlib_bitsets !! call set0 % set(165) !! if ( set0 % test(165) ) write(*,*) 'Bit 165 is set.' !! end program demo_test -!! +!!``` import :: bitset_type, bits_kind logical :: test class(bitset_type), intent(in) :: self @@ -679,7 +679,7 @@ module stdlib_bitsets !! !!#### Example !! -!! ```fortran +!!```fortran !! program demo_to_string !! use stdlib_bitsets !! character(*), parameter :: & @@ -694,7 +694,7 @@ module stdlib_bitsets !! " into NEW_STRING." !! end if !! end program demo_to_string -!! +!!``` import :: bitset_type class(bitset_type), intent(in) :: self character(:), allocatable, intent(out) :: string @@ -709,7 +709,7 @@ module stdlib_bitsets !! !!#### Example !! -!! ```fortran +!!```fortran !! program demo_value !! use stdlib_bitsets !! type(bitset_large) :: set0 @@ -721,7 +721,7 @@ module stdlib_bitsets !! call set0 % set(165) !! if ( set0 % value(165) == 1 ) write(*,*) 'Bit 165 is set.' !! end program demo_value -!! +!!``` import :: bitset_type, bits_kind integer :: value class(bitset_type), intent(in) :: self @@ -740,7 +740,7 @@ module stdlib_bitsets !! !!#### Example !! -!! ```fortran +!!```fortran !! program demo_write_bitset !! character(*), parameter :: & !! bits_0 = 'S33B000000000000000000000000000000000', & @@ -774,7 +774,7 @@ module stdlib_bitsets !! write(*,*) WRITE_BITSET to READ_BITSET through unit worked.' !! end if !! end program demo_write_bitset -!! +!!``` import :: bitset_type class(bitset_type), intent(in) :: self character(len=:), allocatable, intent(out) :: string @@ -1121,7 +1121,7 @@ module stdlib_bitsets !! !!#### Example !! -!! ```fortran +!!```fortran !! program demo_assignment !! use stdlib_bitsets !! logical(int8) :: logical1(64) = .true. @@ -1146,7 +1146,7 @@ module stdlib_bitsets !! write(*,*) 'Initialization of logical(int32) succeeded.' !! end if !! end program demo_assignment -!! +!!``` pure module subroutine assign_large( set1, set2 ) !! Version: experimental @@ -1534,7 +1534,7 @@ module stdlib_bitsets !! !!#### Example !! -!! ```fortran +!!```fortran !! program demo_and !! use stdlib_bitsets !! type(bitset_large) :: set0, set1 @@ -1552,7 +1552,7 @@ module stdlib_bitsets !! call and( set0, set1 ) ! all all !! if ( all(set0) ) write(*,*) 'Fourth test of AND worked.' !! end program demo_and -!! +!!``` type(bitset_large), intent(inout) :: set1 type(bitset_large), intent(in) :: set2 end subroutine and_large @@ -1581,7 +1581,7 @@ module stdlib_bitsets !! !!#### Example !! -!! ```fortran +!!```fortran !! program demo_and_not !! use stdlib_bitsets !! type(bitset_large) :: set0, set1 @@ -1600,7 +1600,7 @@ module stdlib_bitsets !! call and_not( set0, set1 ) ! all all !! if ( none(set0) ) write(*,*) 'Fourth test of AND_NOT worked.' !! end program demo_and_not -!! +!!``` type(bitset_large), intent(inout) :: set1 type(bitset_large), intent(in) :: set2 end subroutine and_not_large @@ -1631,7 +1631,7 @@ module stdlib_bitsets !! !!#### Example !! -!! ```fortran +!!```fortran !! program demo_extract !! use stdlib_bitsets !! type(bitset_large) :: set0, set1 @@ -1642,7 +1642,7 @@ module stdlib_bitsets !! write(*,*) 'SET1 has the proper size.' !! if ( set1 % all() ) write(*,*) 'SET1 has the proper values.' !! end program demo_extract -!! +!!``` type(bitset_large), intent(out) :: new type(bitset_large), intent(in) :: old integer(bits_kind), intent(in) :: start_pos, stop_pos @@ -1678,7 +1678,7 @@ module stdlib_bitsets !! !!#### Example !! -!! ```fortran +!!```fortran !! program demo_or !! use stdlib_bitsets !! type(bitset_large) :: set0, set1 @@ -1697,7 +1697,7 @@ module stdlib_bitsets !! call or( set0, set1 ) ! all all !! if ( all(set0) ) write(*,*) 'Fourth test of OR worked.' !! end program demo_or -!! +!!``` type(bitset_large), intent(inout) :: set1 type(bitset_large), intent(in) :: set2 end subroutine or_large @@ -1726,7 +1726,7 @@ module stdlib_bitsets !! !!#### Example !! -!! ```fortran +!!```fortran !! program demo_xor !! use stdlib_bitsets !! type(bitset_large) :: set0, set1 @@ -1745,7 +1745,7 @@ module stdlib_bitsets !! call xor( set0, set1 ) ! all all !! if ( none(set0) ) write(*,*) 'Fourth test of XOR worked.' !! end program demo_xor -!! +!!``` type(bitset_large), intent(inout) :: set1 type(bitset_large), intent(in) :: set2 end subroutine xor_large @@ -1774,7 +1774,7 @@ module stdlib_bitsets !! !!#### Example !! -!! ```fortran +!!```fortran !! program demo_equality !! use stdlib_bitsets !! type(bitset_64) :: set0, set1, set2 @@ -1791,7 +1791,7 @@ module stdlib_bitsets !! error stop 'Failed 64 bit equality tests.' !! end if !! end program demo_equality -!! +!!``` logical :: eqv type(bitset_large), intent(in) :: set1, set2 end function eqv_large @@ -1820,7 +1820,7 @@ module stdlib_bitsets !! !!#### Example !! -!! ```fortran +!!```fortran !! program demo_inequality !! use stdlib_bitsets !! type(bitset_64) :: set0, set1, set2 @@ -1837,7 +1837,7 @@ module stdlib_bitsets !! error stop 'Failed 64 bit inequality tests.' !! end if !! end program demo_inequality -!! +!!``` logical :: neqv type(bitset_large), intent(in) :: set1, set2 end function neqv_large @@ -1867,7 +1867,7 @@ module stdlib_bitsets !! !!#### Example !! -!! ```fortran +!!```fortran !! program demo_gt !! use stdlib_bitsets !! type(bitset_64) :: set0, set1, set2 @@ -1884,7 +1884,7 @@ module stdlib_bitsets !! error stop 'Failed 64 bit greater than tests.' !! end if !! end program demo_gt -!! +!!``` logical :: gt type(bitset_large), intent(in) :: set1, set2 end function gt_large @@ -1915,7 +1915,7 @@ module stdlib_bitsets !! !!#### Example !! -!! ```fortran +!!```fortran !! program demo_ge !! use stdlib_bitsets !! type(bitset_64) :: set0, set1, set2 @@ -1933,7 +1933,7 @@ module stdlib_bitsets !! error stop 'Failed 64 bit greater than or equals tests.' !! end if !! end program demo_ge -!! +!!``` logical :: ge type(bitset_large), intent(in) :: set1, set2 end function ge_large @@ -1964,7 +1964,7 @@ module stdlib_bitsets !! !!#### Example !! -!! ```fortran +!!```fortran !! program demo_lt !! use stdlib_bitsets !! type(bitset_64) :: set0, set1, set2 @@ -1981,7 +1981,7 @@ module stdlib_bitsets !! error stop 'Failed 64 bit less than tests.' !! end if !! end program demo_lt -!! +!!``` logical :: lt type(bitset_large), intent(in) :: set1, set2 end function lt_large @@ -2012,7 +2012,7 @@ module stdlib_bitsets !! !!#### Example !! -!! ```fortran +!!```fortran !! program demo_le !! use stdlib_bitsets !! type(bitset_64) :: set0, set1, set2 @@ -2030,7 +2030,7 @@ module stdlib_bitsets !! error stop 'Failed 64 bit less than or equal tests.' !! end if !! end program demo_le -!! +!!``` logical :: le type(bitset_large), intent(in) :: set1, set2 end function le_large From d3919704f46d94f4f566f51f2caad4a5ec8a8be8 Mon Sep 17 00:00:00 2001 From: Jeremie Vandenplas Date: Wed, 14 Oct 2020 21:53:04 +0200 Subject: [PATCH 24/53] Some typs and obvious changes --- doc/specs/stdlib_bitsets.md | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/doc/specs/stdlib_bitsets.md b/doc/specs/stdlib_bitsets.md index bd9b5406c..a13fe9013 100644 --- a/doc/specs/stdlib_bitsets.md +++ b/doc/specs/stdlib_bitsets.md @@ -182,7 +182,7 @@ summarized below: |`clear`|subroutine|sets a sequence of one or more bits to 0| |`flip`|subroutine|flips the value of a sequence of one or more bits| |`from_string`|subroutine|reads the bitset from a string treating it as a binary literal| -|`init`|subroutine|creates a new bitset of size `bits`with no bits set| +|`init`|subroutine|creates a new bitset of size `bits` with no bits set| |`input`|subroutine|reads a bitset from an unformatted I/O unit| |`none`|function|`.true.` if no bits are 1, `.false.` otherwise| |`not`|subroutine|performs a logical `not` operation on all the bits| @@ -201,7 +201,7 @@ The procedures with two arguments of type `bitset_large` or prevents them from being methods. The bitwise "logical" procedures, `and`, `and_not`, `or`, and `xor` also require that the two bitset arguments have the same number of bits, otherwise the results are -undefined, These procedures are summarized in the following table: +undefined. These procedures are summarized in the following table: |Procedure name|Class|Summary| |--------------|-----|-------| @@ -368,7 +368,7 @@ corresponding negation of the bits in `set2`. `set2`: shall be a scalar expression of the same type as `set1`. It is an `intent(in)` argument. Note that it should also have the same -number of bits as `set1` otherwise the result is undefined. +number of bits as `set1`, otherwise the result is undefined. #### Example @@ -876,7 +876,7 @@ access positioned at the start of a BITSET value written by a `status` (optional): shall be a scalar default integer variable. If present its value shall be of one of the error codes defined in this -module. IF absent and it would have had a value other than `success` +module. If absent and it would have had a value other than `success` processing will stop with an informative stop code. Allowed error code values for this `status` are: @@ -1030,7 +1030,7 @@ Experimental Replaces the original bits of `set1` with the bitwise `or` of those bits with the bits of `set2`. Note `set1` and `set2` must have the -samee number of bits, otherwise the result is undefined. +same number of bits, otherwise the result is undefined. #### Syntax From 84d7d33ee602ca94a6b43d4655704acbfc187714 Mon Sep 17 00:00:00 2001 From: Jeremie Vandenplas Date: Wed, 14 Oct 2020 21:55:42 +0200 Subject: [PATCH 25/53] Apply suggestions from code review --- doc/specs/stdlib_bitsets.md | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/doc/specs/stdlib_bitsets.md b/doc/specs/stdlib_bitsets.md index a13fe9013..526413c5e 100644 --- a/doc/specs/stdlib_bitsets.md +++ b/doc/specs/stdlib_bitsets.md @@ -560,7 +560,7 @@ clears the bits with positions from `start_pos` to `end_pos` in `self`. * if `start_pos` and `end_pos` are present with `end_pos < start_pos` `self` is unmodified. -Note: Positions outside the range 0 to `BITS(SET) -1` are ignored. +Note: Positions outside the range 0 to `bits(set) -1` are ignored. #### Syntax @@ -1355,7 +1355,7 @@ The result is a default logical scalar. #### Result value -The result is `.true.` if the bit at `pos`, in `self` is set, +The result is `.true.` if the bit at `pos` in `self` is set, otherwise it is `.false.`. If `pos` is outside the range `0... bits(self)-1` the result is `.false.`. @@ -1387,7 +1387,7 @@ Represents the value of `self` as a binary literal in `string`. #### Syntax -`call self % [[bitset_type(class):to_string(bound)]](string[, status]) +`call self % [[bitset_type(class):to_string(bound)]](string[, status])` #### Class @@ -1436,7 +1436,7 @@ the stop code. The values have the following meanings: #### Status -Experimeental +Experimental #### Description @@ -1795,7 +1795,7 @@ The result is a default logical scalar. The result is `.true.` if the bits in `set1` and `set2` are the same or the highest order different bit is set to 1 in `set1` and to 0 in -`set2`, `.false.`. otherwise. +`set2`, `.false.` otherwise. #### Example @@ -1829,7 +1829,7 @@ Experimental Returns `.true.` if the bits in `set1` and `set2` differ and the highest order different bit is set to 1 in `set1` and to 0 in `set2`, -`.false.`. otherwise. The sets must be the same size otherwise the +`.false.` otherwise. The sets must be the same size otherwise the results are undefined #### Syntax @@ -1890,7 +1890,7 @@ Experimental Returns `.true.` if the bits in `set1` and `set2` are the same or the highest order different bit is set to 0 in `set1` and to 1 in `set2`, -`.false.`. otherwise. The sets must be the same size otherwise the +`.false.` otherwise. The sets must be the same size otherwise the results are undefined @@ -1919,7 +1919,7 @@ The result is a default logical scalar. The result is `.true.` if the bits in `set1` and `set2` are the same or the highest order different bit is set to 0 in `set1` and to 1 in -`set2`, `.false.`. otherwise. +`set2`, `.false.` otherwise. #### Example @@ -1953,7 +1953,7 @@ Experimental Returns `.true.` if the bits in `set1` and `set2` differ and the highest order different bit is set to 0 in `set1` and to 1 in `set2`, -`.false.`. otherwise. The sets must be the same size otherwise the +`.false.` otherwise. The sets must be the same size otherwise the results are undefined From d6dc6b100496ef42b83ea2d493bad6f40d9dcc66 Mon Sep 17 00:00:00 2001 From: William Clodius Date: Thu, 15 Oct 2020 12:10:15 -0600 Subject: [PATCH 26/53] Corrected stdlib_bitsets.md Implemented most of the suggestions of Jeremie Vandenplas: 1. Rephrased the first paragraph adding a definition of bits and changed 'a sequence' to 'as a seqauence' and 'a subset' to 'as a subset' 2. Changed 'constants all integers' to 'integer constants' 3. Changed 'up 64 bits' to 'up to 64 bits' 4. Changed i'th to i-th 5. Made the summary of operations into a bulleted list 6. Moved the discussion of assignments to later in the text 7. Merged discussions of result character and result value for functions/operators 8. Remove `if ( bits(set0) /= 33)...` 9. Added commas 10. Changed `Result = ...` to `result = ...` 11. Changed state type of the result for the value function from logical to integer [ticket: X] --- doc/specs/stdlib_bitsets.md | 196 +++++++++++++++--------------------- 1 file changed, 79 insertions(+), 117 deletions(-) diff --git a/doc/specs/stdlib_bitsets.md b/doc/specs/stdlib_bitsets.md index 526413c5e..201e5a290 100644 --- a/doc/specs/stdlib_bitsets.md +++ b/doc/specs/stdlib_bitsets.md @@ -9,12 +9,14 @@ title: Bitsets ## Introduction The `stdlib_bitsets` module implements bitset types. A bitset is a -compact representation of a sequence of binary values, that can -equivalently be considered a sequence of logical values or a subset of -the integers 0 ... `bits(bitset)-1`. The bits are indexed from 0 to -`bits(bitset)-1`. A bitset is used when space savings are critical in applications that require a large number +compact representation of a sequence of `bits` binary values. It can +equivalently be considered as a sequence of logical values or as a subset of +the integers 0 ... `bits-1`. The bits are indexed from 0 to +`bits(bitset)-1`. A bitset is used when space savings are critical in +applications that require a large number of closely related logical values. -It may also improve performance by reducing memory traffic. To implement bitsets the module +It may also improve performance by reducing memory traffic. To implement +bitsets the module defines three bitset types, multiple constants, a character string literal that can be read to and from strings and formatted files, a simple character string literal that can be read to and from strings, @@ -24,7 +26,7 @@ assumes two's complement integers, but all current Fortran 95+ processors use su ## The module's constants -The module defines several public constants all integers, almost all +The module defines several public integer constants, almost all intended to serve as error codes in reporting problems through an optional `stat` argument. One constant, `bits_kind` is the integer kind value for indexing bits and reporting counts of @@ -52,7 +54,7 @@ The `stdlib_bitsets` module defines three derived types, type that serves as the ancestor of `bitset_64` and `bitset_large`. `bitset_type` defines one method, `bits`, all of its other methods are deferred to its extensions. `bitset_64` is a bitset -that can handle up 64 bits. `bitset_large` is a bitset that can handle +that can handle up to 64 bits. `bitset_large` is a bitset that can handle up `huge(0_bits_kind)` bits. All attributes of the bitset types are private. The various types each define a sequence of binary values: 0 or 1. In some cases it is useful to associate a logical value, `test`, @@ -106,7 +108,7 @@ The *bitset-literal* consists of two parts: a *bitsize-literal* and a The *binary-literal* value is interpreted as a sequence of bit values and there must be as many binary digits in the literal as there are `bits`. The sequence of binary digits are treated as if they were -an unsigned integer with the i'th digit corresponding to the `bits-i` +an unsigned integer with the i-th digit corresponding to the `bits-i` bit position. ## The *binary-literal* @@ -120,49 +122,12 @@ and all characters in the string must be either "0" or "1". ## Summary of the module's operations The `stdlib_bitsets` module defines a number of operations: -assignments, "unary" methods of class `bitset_type`, "binary" -procedure overloads of type `bitset_64` or `bitset_large`, and binary -comparison operators of type `bitset_64` or `bitset_large`. Each -category will be discussed separately. +* "unary" methods of class `bitset_type`, +* "binary" procedure overloads of type `bitset_64` or `bitset_large`, +* assignments, and +* "binary" comparison operators of type `bitset_64` or `bitset_large`. -### Assignments - -The module defines an assignment operation, `=`, that creates a -duplicate of an original bitset. It also defines assignments to and -from rank one arrays of logical type of kinds `int8`, `int16`, -`int32`, and `int64`. In the assignment to and from logical arrays -array index, `i`, is mapped to bit position, `pos=i-1`, and `.true.` -is mapped to a set bit, and `.false.` is mapped to an unset bit. - - -#### Example - -```fortran - program demo_assignment - use stdlib_bitsets - logical(int8) :: logical1(64) = .true. - logical(int32), allocatable :: logical2(:) - type(bitset_64) :: set0, set1 - set0 = logical1 - if ( set0 % bits() /= 64 ) then - error stop procedure // & - ' initialization with logical(int8) failed to set' // & - ' the right size.' - else if ( .not. set0 % all() ) then - error stop procedure // ' initialization with' // & - ' logical(int8) failed to set the right values.' - else - write(*,*) 'Initialization with logical(int8) succeeded.' - end if - set1 = set0 - if ( set1 == set0 ) & - write(*,*) 'Initialization by assignment succeeded' - logical2 = set1 - if ( all( logical2 ) ) then - write(*,*) 'Initialization of logical(int32) succeeded.' - end if - end program demo_assignment -``` +Each category will be discussed separately. ### Table of the `bitset_type` methods @@ -212,6 +177,45 @@ undefined. These procedures are summarized in the following table: |`xor`|elemental subroutine|Sets `self` to the bitwise exclusive `or` of the original bits in `self` and `set2`| +### Assignments + +The module defines an assignment operation, `=`, that creates a +duplicate of an original bitset. It also defines assignments to and +from rank one arrays of logical type of kinds `int8`, `int16`, +`int32`, and `int64`. In the assignment to and from logical arrays +array index, `i`, is mapped to bit position, `pos=i-1`, and `.true.` +is mapped to a set bit, and `.false.` is mapped to an unset bit. + + +#### Example + +```fortran + program demo_assignment + use stdlib_bitsets + logical(int8) :: logical1(64) = .true. + logical(int32), allocatable :: logical2(:) + type(bitset_64) :: set0, set1 + set0 = logical1 + if ( set0 % bits() /= 64 ) then + error stop procedure // & + ' initialization with logical(int8) failed to set' // & + ' the right size.' + else if ( .not. set0 % all() ) then + error stop procedure // ' initialization with' // & + ' logical(int8) failed to set the right values.' + else + write(*,*) 'Initialization with logical(int8) succeeded.' + end if + set1 = set0 + if ( set1 == set0 ) & + write(*,*) 'Initialization by assignment succeeded' + logical2 = set1 + if ( all( logical2 ) ) then + write(*,*) 'Initialization of logical(int32) succeeded.' + end if + end program demo_assignment +``` + ### Table of the non-member comparison operations The comparison operators with two arguments of type `bitset_large` or `bitset_64` must have both arguments of the same known type which @@ -254,12 +258,9 @@ Elemental function. `self`: shall be a scalar expression of class `bitset_type`. It is an `intent(in)` argument. -#### Result character - -The result is a default logical scalar. - #### Result value +The result is a default logical scalar. The result is `.true.` if all bits in `self` are set, otherwise it is `.false.`. @@ -272,10 +273,7 @@ otherwise it is `.false.`. bits_all = '111111111111111111111111111111111' type(bitset_64) :: set0 call set0 % from_string( bits_all ) - if ( bits(set0) /= 33 ) then - error stop "FROM_STRING failed to interpret " // & - 'BITS_ALL's size properly." - else if ( .not. set0 % all() ) then + if ( .not. set0 % all() ) then error stop "FROM_STRING failed to interpret" // & "BITS_ALL's value properly." else @@ -416,12 +414,9 @@ Elemental function. `self`: shall be a scalar expression of class `bitset_type`. It is an `intent(in)` argument. -#### Result character - -The result is a default logical scalar. - #### Result value +The result is a default logical scalar. The result is `.true.` if any bits in `self` are set, otherwise it is `.false.`. @@ -468,13 +463,10 @@ Elemental function. `self`: shall be a scalar expression of class `bitset_type`. It is an `intent(in)` argument. -#### Result character - -The result is an integer scalar of kind `bits_kind`. - #### Result value -The result is the number of bits that are set in `self`. +The result is an integer scalar of kind `bits_kind`, +equal to the number of bits that are set in `self`. #### Example @@ -519,13 +511,10 @@ Elemental function. `self`: shall be a scalar expression of class `bitset_type`. It is an `intent(in)` argument. -#### Result character - -The result is an integer scalar of kind `bits_kind`. - #### Result value -The result is the number of defined bits in `self`. +The result is an integer scalar of kind `bits_kind`, equal to +the number of defined bits in `self`. #### Example @@ -813,8 +802,8 @@ is an `intent(out)` argument. `bits` (optional): shall be a scalar integer expression of kind `bits_kind`. It is an `intent(in)` argument that if present -specifies the number of bits in `set`. A negative value or a value -greater than 64 if `self` is of type `bitset_64` is an error. +specifies the number of bits in `set`. A negative value, or a value +greater than 64 if `self` is of type `bitset_64`, is an error. `status` (optional): shall be a scalar default integer variable. It is an `intent(out)` argument that, if present, returns an error code @@ -949,12 +938,9 @@ Elemental function. `self`: shall be a scalar expression of class `bitset_type`. It is an `intent(in)` argument. -#### Result character - -The result is a default logical scalar. - #### Result value +The result is a default logical scalar. The result is `.true.` if no bits in `self` are set, otherwise it is `.false.`. @@ -1349,12 +1335,9 @@ Elemental function. `pos`: shall be a scalar integer expression of kind `bits_kind`. It is an `intent(in)` argument. -#### Result character - -The result is a default logical scalar. - #### Result value +The result is a default logical scalar. The result is `.true.` if the bit at `pos` in `self` is set, otherwise it is `.false.`. If `pos` is outside the range `0... bits(self)-1` the result is `.false.`. @@ -1458,12 +1441,9 @@ Elemental function. `pos`: shall be a scalar integer expression of kind `bits_kind`. It is an `intent(in)` argument. -#### Result character - -The result is a default logical scalar. - #### Result value +The result is a default integer scalar. The result is one if the bit at `pos` in `self` is set, otherwise it is zero. If `pos` is outside the range `0... bits(set)-1` the result is zero. @@ -1652,7 +1632,7 @@ Returns `.true.` if all bits in `set1` and `set2` have the same value, #### Syntax -`Result = set1 [[stdlib_bitsets(module):==(interface)]] set2 +`result = set1 [[stdlib_bitsets(module):==(interface)]] set2 #### Class @@ -1667,14 +1647,11 @@ is an `intent(in)` argument. will have the same number of bits as `set1`. It is an `intent(in)` argument. -#### Result character - -The result is a default logical scalar. - #### Result value +The result is a default logical scalar. The result is `.true.` if the bits in both bitsets are set - to the same value, otherwise the result is `.FALSE.`. +to the same value, otherwise the result is `.FALSE.`. #### Example @@ -1711,7 +1688,7 @@ Returns `.true.` if any bits in `self` and `set2` differ in value, #### Syntax -`Result = set1 [[stdlib_bitsets(module):/=(interface)]] set2` +`result = set1 [[stdlib_bitsets(module):/=(interface)]] set2` #### Class @@ -1726,12 +1703,9 @@ is an `intent(in)` argument. will have the same number of bits as `set1`. It is an `intent(in)` argument. -#### Result character - -The result is a default logical scalar. - #### Result value +The result is a default logical scalar. The result is `.true.` if any bits in both bitsets differ, otherwise the result is `.false.`. @@ -1772,7 +1746,7 @@ results are undefined #### Syntax -`Result = set1 [[stdlib_bitsets(module):>=(interface)]] set2` +`result = set1 [[stdlib_bitsets(module):>=(interface)]] set2` #### Class @@ -1787,12 +1761,9 @@ is an `intent(in)` argument. will have the same number of bits as `set1`. It is an `intent(in)` argument. -#### Result character - -The result is a default logical scalar. - #### Result value +The result is a default logical scalar. The result is `.true.` if the bits in `set1` and `set2` are the same or the highest order different bit is set to 1 in `set1` and to 0 in `set2`, `.false.` otherwise. @@ -1834,7 +1805,7 @@ results are undefined #### Syntax -`Result = set1 [[stdlib_bitsets(module):>(interface)]] set2` +`result = set1 [[stdlib_bitsets(module):>(interface)]] set2` #### Class @@ -1849,12 +1820,9 @@ is an `intent(in)` argument. will have the same number of bits as `set1`. It is an `intent(in)` argument. -#### Result character - -The result is a default logical scalar. - #### Result value +The result is a default logical scalar. The result is `.true.` if the bits in `set1` and `set2` differ and the highest order different bit is set to 1 in `set1` and to 0 in `set2`, `.false.`. otherwise. @@ -1896,7 +1864,7 @@ results are undefined #### Syntax -`Result = set1 [[stdlib_bitsets(module):<=(interface)]] set2` +`result = set1 [[stdlib_bitsets(module):<=(interface)]] set2` #### Class @@ -1911,12 +1879,9 @@ is an `intent(in)` argument. will have the same number of bits as `set1`. It is an `intent(in)` argument. -#### Result character - -The result is a default logical scalar. - #### Result value +The result is a default logical scalar. The result is `.true.` if the bits in `set1` and `set2` are the same or the highest order different bit is set to 0 in `set1` and to 1 in `set2`, `.false.` otherwise. @@ -1959,7 +1924,7 @@ results are undefined #### Syntax -`Result = set1 [[stdlib_bitsets(module):<(interface)]] set2` +`result = set1 [[stdlib_bitsets(module):<(interface)]] set2` #### Class @@ -1974,12 +1939,9 @@ is an `intent(in)` argument. will have the same number of bits as `set1`. It is an `intent(in)` argument. -#### Result character - -The result is a default logical scalar. - #### Result value +The result is a default logical scalar. The result is `.true.` if the bits in `set1` and `set2` differ and the highest order different bit is set to 0 in `set1` and to 1 in `set2`, `.false.` otherwise. From daa83d20822198ad579fe2d2ba9d985456d3d970 Mon Sep 17 00:00:00 2001 From: Jeremie Vandenplas Date: Thu, 15 Oct 2020 20:18:41 +0200 Subject: [PATCH 27/53] Update doc/specs/stdlib_bitsets.md --- doc/specs/stdlib_bitsets.md | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/doc/specs/stdlib_bitsets.md b/doc/specs/stdlib_bitsets.md index 526413c5e..57a15482e 100644 --- a/doc/specs/stdlib_bitsets.md +++ b/doc/specs/stdlib_bitsets.md @@ -416,13 +416,9 @@ Elemental function. `self`: shall be a scalar expression of class `bitset_type`. It is an `intent(in)` argument. -#### Result character - -The result is a default logical scalar. - #### Result value -The result is `.true.` if any bits in `self` are set, otherwise it +The result is a default logical scalar. The result is `.true.` if any bits in `self` are set, otherwise it is `.false.`. #### Example From 30c21165a6355c6bb0cbf239387f10d56ef086fb Mon Sep 17 00:00:00 2001 From: Jeremie Vandenplas Date: Thu, 15 Oct 2020 20:29:33 +0200 Subject: [PATCH 28/53] Apply suggestions from code review --- doc/specs/stdlib_bitsets.md | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/doc/specs/stdlib_bitsets.md b/doc/specs/stdlib_bitsets.md index 57a15482e..57ef824a8 100644 --- a/doc/specs/stdlib_bitsets.md +++ b/doc/specs/stdlib_bitsets.md @@ -986,7 +986,7 @@ Performs the logical complement on the bits of `self`. #### Syntax -`result = self % [[bitset_type(class):not(bound)]] ()` +`call self % [[bitset_type(class):not(bound)]] ()` #### Class @@ -1648,7 +1648,7 @@ Returns `.true.` if all bits in `set1` and `set2` have the same value, #### Syntax -`Result = set1 [[stdlib_bitsets(module):==(interface)]] set2 +`result = set1 [[stdlib_bitsets(module):==(interface)]] set2 #### Class @@ -1830,7 +1830,7 @@ results are undefined #### Syntax -`Result = set1 [[stdlib_bitsets(module):>(interface)]] set2` +`result = set1 [[stdlib_bitsets(module):>(interface)]] set2` #### Class @@ -1892,7 +1892,7 @@ results are undefined #### Syntax -`Result = set1 [[stdlib_bitsets(module):<=(interface)]] set2` +`result = set1 [[stdlib_bitsets(module):<=(interface)]] set2` #### Class @@ -1955,7 +1955,7 @@ results are undefined #### Syntax -`Result = set1 [[stdlib_bitsets(module):<(interface)]] set2` +`result = set1 [[stdlib_bitsets(module):<(interface)]] set2` #### Class From adab16696f99a5bfb80020928cab01ee5972d7eb Mon Sep 17 00:00:00 2001 From: William Clodius Date: Thu, 15 Oct 2020 14:06:10 -0600 Subject: [PATCH 29/53] Changed file names Changed stdlib_bitset_64.fypp and stdlib_bitset_large.fypp to stdlib_bitsets_64.fypp and stdlib_bitsets_large.fypp. [ticket: X] --- src/{stdlib_bitset_64.fypp => stdlib_bitsets_64.fypp} | 4 ++-- src/{stdlib_bitset_large.fypp => stdlib_bitsets_large.fypp} | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) rename src/{stdlib_bitset_64.fypp => stdlib_bitsets_64.fypp} (99%) rename src/{stdlib_bitset_large.fypp => stdlib_bitsets_large.fypp} (99%) diff --git a/src/stdlib_bitset_64.fypp b/src/stdlib_bitsets_64.fypp similarity index 99% rename from src/stdlib_bitset_64.fypp rename to src/stdlib_bitsets_64.fypp index bcf9376ee..68bb725b7 100644 --- a/src/stdlib_bitset_64.fypp +++ b/src/stdlib_bitsets_64.fypp @@ -1,5 +1,5 @@ #:include "common.fypp" -submodule(stdlib_bitsets) stdlib_bitset_64 +submodule(stdlib_bitsets) stdlib_bitsets_64 implicit none contains @@ -1140,4 +1140,4 @@ contains end subroutine xor_64 -end submodule stdlib_bitset_64 +end submodule stdlib_bitsets_64 diff --git a/src/stdlib_bitset_large.fypp b/src/stdlib_bitsets_large.fypp similarity index 99% rename from src/stdlib_bitset_large.fypp rename to src/stdlib_bitsets_large.fypp index b5020ddf5..7f6a7716b 100644 --- a/src/stdlib_bitset_large.fypp +++ b/src/stdlib_bitsets_large.fypp @@ -1,5 +1,5 @@ #:include "common.fypp" -submodule(stdlib_bitsets) stdlib_bitset_large +submodule(stdlib_bitsets) stdlib_bitsets_large implicit none contains @@ -1367,4 +1367,4 @@ contains end subroutine xor_large -end submodule stdlib_bitset_large +end submodule stdlib_bitsets_large From d7cf384b6ada1bb712488decebdcc1bdf9bfc5ae Mon Sep 17 00:00:00 2001 From: William Clodius Date: Thu, 15 Oct 2020 14:09:22 -0600 Subject: [PATCH 30/53] Updated makefiles to deal with new names Updated CMakeLists.txt and Makefile.manual to deal with the new filenames stdlib_bitsets_64.fypp and stdlib_bitsets_large.fypp. [ticket: X] --- src/CMakeLists.txt | 4 ++-- src/Makefile.manual | 12 ++++++------ 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 0253a8e9c..02604959e 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -2,9 +2,9 @@ # Create a list of the files to be preprocessed set(fppFiles - stdlib_bitset_64.fypp - stdlib_bitset_large.fypp stdlib_bitsets.fypp + stdlib_bitsets_64.fypp + stdlib_bitsets_large.fypp stdlib_io.fypp stdlib_linalg.fypp stdlib_linalg_diag.fypp diff --git a/src/Makefile.manual b/src/Makefile.manual index 4a1ec3110..99f4105bd 100644 --- a/src/Makefile.manual +++ b/src/Makefile.manual @@ -1,8 +1,8 @@ SRC = f18estop.f90 \ stdlib_ascii.f90 \ stdlib_bitsets.f90 \ - stdlib_bitset_64.f90 \ - stdlib_bitset_large.f90 \ + stdlib_bitsest_64.f90 \ + stdlib_bitsets_large.f90 \ stdlib_error.f90 \ stdlib_io.f90 \ stdlib_kinds.f90 \ @@ -43,8 +43,8 @@ clean: # Fortran module dependencies f18estop.o: stdlib_error.o -stdlib_bitset_64.o: stdlib_bitsets.o -stdlib_bitset_large.o: stdlib_bitsets.o +stdlib_bitsets_64.o: stdlib_bitsets.o +stdlib_bitsets_large.o: stdlib_bitsets.o stdlib_error.o: stdlib_optval.o stdlib_io.o: \ stdlib_error.o \ @@ -68,8 +68,8 @@ stdlib_stats_var.o: \ stdlib_stats.o # Fortran sources that are built from fypp templates -stdlib_bitset_64.f90: stdlib_bitset_64.fypp -stdlib_bitset_large.f90: stdlib_bitset_large.fypp +stdlib_bitsets_64.f90: stdlib_bitsets_64.fypp +stdlib_bitsets_large.f90: stdlib_bitsets_large.fypp stdlib_bitsets.f90: stdlib_bitsets.fypp stdlib_io.f90: stdlib_io.fypp stdlib_linalg.f90: stdlib_linalg.fypp From aeae7dd4b5390a35446f30e9462cb396fde195e4 Mon Sep 17 00:00:00 2001 From: William Clodius Date: Thu, 15 Oct 2020 14:32:43 -0600 Subject: [PATCH 31/53] Changed discussion of bitset_type Jeremie suggested a change that I thought wasn't right so I implemented my own change. [ticket: X] --- doc/specs/stdlib_bitsets.md | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/doc/specs/stdlib_bitsets.md b/doc/specs/stdlib_bitsets.md index 14752e06f..2e66a5be2 100644 --- a/doc/specs/stdlib_bitsets.md +++ b/doc/specs/stdlib_bitsets.md @@ -62,7 +62,8 @@ for each element of the sequence, where `test` is `.true.` if the value is 1 and `.false.` otherwise. The number of such values in an entity of that type is to be termed, `bits`. The bits are ordered in terms of position, that, in turn, is indexed from 0 to `bits-1`. `bitset_type` is -not used in source code. The syntax for using the types are: +used only as a `class` to define varibles that can be either a `bitset_64` or +a `bitset_large`. The syntax for using the types are: `class([[stdlib_bitset(module):bitset_type(class)]]) :: variable` From 833094570a57e83fe4ce415b7e8e3bc4cce5a5ca Mon Sep 17 00:00:00 2001 From: William Clodius Date: Thu, 15 Oct 2020 14:42:02 -0600 Subject: [PATCH 32/53] Changed varibles to entities. what happened [ticket: X] --- doc/specs/stdlib_bitsets.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/specs/stdlib_bitsets.md b/doc/specs/stdlib_bitsets.md index 2e66a5be2..70ec4275c 100644 --- a/doc/specs/stdlib_bitsets.md +++ b/doc/specs/stdlib_bitsets.md @@ -62,7 +62,7 @@ for each element of the sequence, where `test` is `.true.` if the value is 1 and `.false.` otherwise. The number of such values in an entity of that type is to be termed, `bits`. The bits are ordered in terms of position, that, in turn, is indexed from 0 to `bits-1`. `bitset_type` is -used only as a `class` to define varibles that can be either a `bitset_64` or +used only as a `class` to define entities that can be either a `bitset_64` or a `bitset_large`. The syntax for using the types are: `class([[stdlib_bitset(module):bitset_type(class)]]) :: variable` From 24881a5b7fd34e9a473097242799dd4c4efa36a3 Mon Sep 17 00:00:00 2001 From: William Clodius Date: Thu, 15 Oct 2020 14:46:44 -0600 Subject: [PATCH 33/53] Fixed typo in Makefile.manual Changed stdlib_bitsest_64.fypp to stdlib_bitsets_64.fypp in Makefile.manual. [ticket: X] --- src/Makefile.manual | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Makefile.manual b/src/Makefile.manual index 99f4105bd..2d838086a 100644 --- a/src/Makefile.manual +++ b/src/Makefile.manual @@ -1,7 +1,7 @@ SRC = f18estop.f90 \ stdlib_ascii.f90 \ stdlib_bitsets.f90 \ - stdlib_bitsest_64.f90 \ + stdlib_bitsets_64.f90 \ stdlib_bitsets_large.f90 \ stdlib_error.f90 \ stdlib_io.f90 \ From 0554f5d0d33a934acb302c97672c6fb192446e8e Mon Sep 17 00:00:00 2001 From: Jeremie Vandenplas Date: Thu, 15 Oct 2020 22:51:47 +0200 Subject: [PATCH 34/53] typos --- src/stdlib_bitsets.fypp | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/stdlib_bitsets.fypp b/src/stdlib_bitsets.fypp index 4ba4a5566..c01dce434 100644 --- a/src/stdlib_bitsets.fypp +++ b/src/stdlib_bitsets.fypp @@ -1243,7 +1243,7 @@ module stdlib_bitsets elemental module subroutine clear_bit_64(self, pos) !! Version: experimental !! -!! Sets to zero the bit at `pos` position in `self`. If 'pos` is less than +!! Sets to zero the bit at `pos` position in `self`. If `pos` is less than !! zero or greater than `bits(self)-1` it is ignored. class(bitset_64), intent(inout) :: self integer(bits_kind), intent(in) :: pos @@ -1529,7 +1529,7 @@ module stdlib_bitsets !! Version: experimental !! !! Sets the bits in `set1` to the bitwise `and` of the original bits in `set1` -!! and `set2`. The sets mmust have the same number of bits +!! and `set2`. The sets must have the same number of bits !! otherwise the result is undefined. !! !!#### Example @@ -1623,7 +1623,7 @@ module stdlib_bitsets !! Version: experimental !! !! Creates a new bitset, `new`, from a range, `start_pos` to `stop_pos`, in -!! bitset `old`. If 'start_pos` is greater than `stop_pos` the new bitset is +!! bitset `old`. If `start_pos` is greater than `stop_pos` the new bitset is !! empty. If `start_pos` is less than zero or `stop_pos` is greater than !! `bits(old)-1` then if `status` is present it has the value !! `index_invalid_error` and `new` is undefined, otherwise processing stops @@ -1768,7 +1768,7 @@ module stdlib_bitsets elemental module function eqv_large(set1, set2) result(eqv) !! Version: experimental !! -!! Returns `.true`. if all bits in `set1` and `set2` have the same value, +!! Returns `.true.` if all bits in `set1` and `set2` have the same value, !! `.false.` otherwise. The sets must have the same number of bits !! otherwise the result is undefined. !! @@ -1861,7 +1861,7 @@ module stdlib_bitsets !! Version: experimental !! !! Returns `.true.` if the bits in `set1` and `set2` differ and the -!! highest order different bit is set to 1 in `set1` and to 0 in `set2`. +!! highest order different bit is set to 1 in `set1` and to 0 in `set2`, !! `.false.` otherwise. The sets must have the same number of bits !! otherwise the result is undefined. !! From ecd6c825a66d64e8391bbc0873a67992b8f63107 Mon Sep 17 00:00:00 2001 From: William Clodius Date: Thu, 15 Oct 2020 20:12:43 -0600 Subject: [PATCH 35/53] Typos and bits_kind fixes Fixed various typos found in stdlib_bitsets.fypp by Jeremie. Modified stdlib_bitsets_large.fypp so it whould work for bits_kind==int64. [ticket: X] --- src/stdlib_bitsets.fypp | 56 ++++++------ src/stdlib_bitsets_large.fypp | 168 +++++++++++++++++++++------------- 2 files changed, 133 insertions(+), 91 deletions(-) diff --git a/src/stdlib_bitsets.fypp b/src/stdlib_bitsets.fypp index c01dce434..842398e2f 100644 --- a/src/stdlib_bitsets.fypp +++ b/src/stdlib_bitsets.fypp @@ -5,29 +5,30 @@ module stdlib_bitsets !! 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, & - error_unit, & - int8, & - int16, & - int32, & - int64, & - dp => real64 + use :: stdlib_kinds, only: & + bits_kind => int32, & + block_kind => int64, & + int8, & + int16, & + int32, & + int64 + + use, intrinsic :: & + iso_fortran_env, only: & + error_unit implicit none private - integer, parameter :: & + integer(bits_kind), parameter :: & block_size = bit_size(0_block_kind) - integer(block_kind), private, parameter :: all_zeros = 0_block_kind - integer(block_kind), private, parameter :: all_ones = not(all_zeros) + integer(block_kind), parameter :: all_zeros = 0_block_kind + integer(block_kind), parameter :: all_ones = not(all_zeros) - character(*), parameter, private :: module_name = "STDLIB_BITSETS" - integer, parameter, private :: & + character(*), parameter :: module_name = "STDLIB_BITSETS" + integer, parameter :: & ia0 = iachar('0'), & ia9 = iachar('9') @@ -870,7 +871,7 @@ module stdlib_bitsets elemental module subroutine clear_bit_large(self, pos) !! Version: experimental !! -!! Sets to zero the bit at `pos` position in `self`. If 'pos` is less than +!! Sets to zero the bit at `pos` position in `self`. If `pos` is less than !! zero or greater than `bits(self)-1` it is ignored. class(bitset_large), intent(inout) :: self integer(bits_kind), intent(in) :: pos @@ -1303,7 +1304,7 @@ module stdlib_bitsets !! * `success` - if no problems were found, !! * `alloc_fault` - if memory allocation failed !! * `array_size_invalid_error` - if `bits` is either negative or larger -!! than 64 with `self` of class `bitset_64`, or +!! than 64 with `self` of class `bitset_64`. class(bitset_64), intent(out) :: self integer(bits_kind), intent(in) :: bits integer, intent(out), optional :: status @@ -1653,7 +1654,7 @@ module stdlib_bitsets !! Version: experimental !! !! Creates a new bitset, `new`, from a range, `start_pos` to `stop_pos`, in -!! bitset `old`. If 'start_pos` is greater than `stop_pos` the new bitset is +!! bitset `old`. If `start_pos` is greater than `stop_pos` the new bitset is !! empty. If `start_pos` is less than zero or `stop_pos` is greater than !! `bits(old)-1` then if `status` is present it has the value !! `index_invalid_error`and `new` is undefined, otherwise processing stops @@ -1799,7 +1800,7 @@ module stdlib_bitsets elemental module function eqv_64(set1, set2) result(eqv) !! Version: experimental !! -!! Returns `.true`. if all bits in `set1` and `set2` have the same value, +!! Returns `.true.` if all bits in `set1` and `set2` have the same value, !! `.false.` otherwise. The sets must have the same number of bits !! otherwise the result is undefined. logical :: eqv @@ -1893,7 +1894,7 @@ module stdlib_bitsets !! Version: experimental !! !! Returns `.true.` if the bits in `set1` and `set2` differ and the -!! highest order different bit is set to 1 in `set1` and to 0 in `set2`. +!! highest order different bit is set to 1 in `set1` and to 0 in `set2`, !! `.false.` otherwise. The sets must have the same number of bits !! otherwise the result is undefined. logical :: gt @@ -1909,7 +1910,7 @@ module stdlib_bitsets !! Version: experimental !! !! Returns `.true.` if the bits in `set1` and `set2` are the same or the -!! highest order different bit is set to 1 in `set1` and to 0 in `set2`. +!! highest order different bit is set to 1 in `set1` and to 0 in `set2`, !! `.false.` otherwise. The sets must have the same number of bits !! otherwise the result is undefined. !! @@ -1942,7 +1943,7 @@ module stdlib_bitsets !! Version: experimental !! !! Returns `.true.` if the bits in `set1` and `set2` are the same or the -!! highest order different bit is set to 1 in `set1` and to 0 in `set2`. +!! highest order different bit is set to 1 in `set1` and to 0 in `set2`, !! `.false.` otherwise. The sets must have the same number of bits !! otherwise the result is undefined. logical :: ge @@ -1958,7 +1959,7 @@ module stdlib_bitsets !! Version: experimental !! !! Returns `.true.` if the bits in `set1` and `set2` differ and the -!! highest order different bit is set to 0 in `set1` and to 1 in `set2`. +!! highest order different bit is set to 0 in `set1` and to 1 in `set2`, !! `.false.` otherwise. The sets must have the same number of bits !! otherwise the result is undefined. !! @@ -1990,7 +1991,7 @@ module stdlib_bitsets !! Version: experimental !! !! Returns `.true.` if the bits in `set1` and `set2` differ and the -!! highest order different bit is set to 0 in `set1` and to 1 in `set2`. +!! highest order different bit is set to 0 in `set1` and to 1 in `set2`, !! `.false.` otherwise. The sets must have the same number of bits !! otherwise the result is undefined. logical :: lt @@ -2006,7 +2007,7 @@ module stdlib_bitsets !! Version: experimental !! !! Returns `.true.` if the bits in `set1` and `set2` are the same or the -!! highest order different bit is set to 0 in `set1` and to 1 in `set2`. +!! highest order different bit is set to 0 in `set1` and to 1 in `set2`, !! `.false.` otherwise. The sets must have the same number of bits !! otherwise the result is undefined. !! @@ -2039,7 +2040,7 @@ module stdlib_bitsets !! Version: experimental !! !! Returns `.true.` if the bits in `set1` and `set2` are the same or the -!! highest order different bit is set to 0 in `set1` and to 1 in `set2`. +!! highest order different bit is set to 0 in `set1` and to 1 in `set2`, !! `.false.` otherwise. The sets must have the same number of bits !! otherwise the result is undefined. logical :: le @@ -2049,7 +2050,8 @@ module stdlib_bitsets end interface operator(<=) interface error_handler - module subroutine error_handler( message, error, status, module, procedure ) + module subroutine error_handler( message, error, status, & + module, procedure ) character(*), intent(in) :: message integer, intent(in) :: error integer, intent(out), optional :: status diff --git a/src/stdlib_bitsets_large.fypp b/src/stdlib_bitsets_large.fypp index 7f6a7716b..b4d97e518 100644 --- a/src/stdlib_bitsets_large.fypp +++ b/src/stdlib_bitsets_large.fypp @@ -14,7 +14,7 @@ contains all = .true. full_blocks = bits(self)/block_size - do block = 1, full_blocks + do block = 1_bits_kind, full_blocks if ( self % blocks(block) /= -1_block_kind ) then all = .false. return @@ -23,7 +23,7 @@ contains if ( full_blocks == size(self % blocks) ) return - do pos=0, modulo( bits(self), block_size )-1 + do pos=0_bits_kind, modulo( bits(self), block_size )-1 if ( .not. btest(self % blocks(full_blocks+1), pos) ) then all = .false. return @@ -44,7 +44,7 @@ contains integer(bits_kind) :: block_ - do block_ = 1, size(set1 % blocks) + do block_ = 1_bits_kind, size(set1 % blocks, kind=bits_kind) set1 % blocks(block_) = iand( set1 % blocks(block_), & set2 % blocks(block_) ) end do @@ -63,7 +63,7 @@ contains integer(bits_kind) :: block_ - do block_ = 1, size( set1 % blocks ) + do block_ = 1_bits_kind, size( set1 % blocks, kind=bits_kind ) set1 % blocks(block_) = & iand( set1 % blocks(block_), not( set2 % blocks(block_) ) ) end do @@ -78,7 +78,7 @@ contains integer(bits_kind) :: block_ - do block_ = 1, size(self % blocks) + do block_ = 1_bits_kind, size(self % blocks, kind=bits_kind) if ( self % blocks(block_) /= 0 ) then any = .true. return @@ -120,7 +120,7 @@ contains allocate( self % blocks( blocks ) ) self % blocks(:) = 0 - do index=0, log_size-1 + do index=0_bits_kind, log_size-1 if ( logical_vector(index+1) ) then call self % set( index ) end if @@ -137,7 +137,7 @@ contains integer(bits_kind) :: index allocate( logical_vector( set % num_bits ) ) - do index=0, set % num_bits-1 + do index=0_bits_kind, set % num_bits-1 if ( set % value( index ) == 1 ) then logical_vector(index+1) = .true. else @@ -157,7 +157,7 @@ contains integer(bits_kind) :: block_, pos bit_count = 0 - do block_ = 1, size(self % blocks) - 1 + do block_ = 1_bits_kind, size(self % blocks, kind=bits_kind) - 1 do pos = 0, block_size-1 if ( btest( self % blocks(block_), pos ) ) & bit_count = bit_count + 1 @@ -165,7 +165,7 @@ contains end do - do pos = 0, self % num_bits - (block_-1)*block_size - 1 + do pos = 0_bits_kind, self % num_bits - (block_-1)*block_size - 1 if ( btest( self % blocks(block_), pos ) ) bit_count = bit_count + 1 end do @@ -255,7 +255,7 @@ contains integer(bits_kind) :: block, common_blocks eqv = .false. - common_blocks = size(set1 % blocks) + common_blocks = size(set1 % blocks, kind=bits_kind) do block = 1, common_blocks if ( set1 % blocks(block) /= set2 % blocks(block) ) return end do @@ -304,7 +304,7 @@ contains allocate( new % blocks(blocks) ) new % blocks(:) = 0 - do i=0, bits-1 + do i=0_bits_kind, bits-1 ex_block = i / block_size + 1 j = i - (ex_block-1) * block_size old_block = (start_pos + i) / block_size + 1 @@ -328,7 +328,7 @@ contains class(bitset_large), intent(inout) :: self integer(bits_kind), intent(in) :: pos - integer :: flip_block, block_bit + integer(bits_kind) :: flip_block, block_bit if ( pos < 0 .OR. pos > self % num_bits-1 ) return @@ -459,7 +459,7 @@ contains integer(bits_kind) :: block_ - do block_ = size(set1 % blocks), 1, -1 + do block_ = size(set1 % blocks, kind=bits_kind), 1_bits_kind, -1 if ( set1 % blocks(block_) == set2 % blocks(block_) ) then cycle else if ( bgt(set1 % blocks(block_), set2 % blocks(block_) ) ) then @@ -487,7 +487,7 @@ contains integer(bits_kind) :: block_ - do block_ = size(set1 % blocks), 1, -1 + do block_ = size(set1 % blocks, kind=bits_kind), 1_bits_kind, -1 if ( set1 % blocks(block_) == set2 % blocks(block_) ) then cycle else if ( bgt( set1 % blocks(block_), & @@ -626,7 +626,7 @@ contains integer(bits_kind) :: block_ - do block_ = size(set1 % blocks), 1, -1 + do block_ = size(set1 % blocks, kind=bits_kind), 1_bits_kind, -1 if ( set1 % blocks(block_) == set2 % blocks(block_) ) then cycle else if ( blt( set1 % blocks(block_), & @@ -656,7 +656,7 @@ contains integer(bits_kind) :: block_ - do block_ = size(set1 % blocks), 1, -1 + do block_ = size(set1 % blocks, kind=bits_kind), 1_bits_kind, -1 if ( set1 % blocks(block_) == set2 % blocks(block_) ) then cycle else if ( blt( set1 % blocks(block_), & @@ -682,11 +682,11 @@ contains logical :: neqv type(bitset_large), intent(in) :: set1, set2 - integer(bits_kind) :: block + integer(bits_kind) :: block_ neqv = .true. - do block = 1, size(set1 % blocks) - if ( set1 % blocks(block) /= set2 % blocks(block) ) return + do block_ = 1_bits_kind, size(set1 % blocks, kind=bits_kind) + if ( set1 % blocks(block_) /= set2 % blocks(block_) ) return end do neqv = .false. @@ -700,10 +700,10 @@ contains logical :: none class(bitset_large), intent(in) :: self - integer :: block + integer(bits_kind) :: block none = .true. - do block = 1, size(self % blocks) + do block = 1_bits_kind, size(self % blocks, kind=bits_kind) if (self % blocks(block) /= 0) then none = .false. return @@ -719,11 +719,12 @@ contains ! class(bitset_large), intent(inout) :: self - integer(bits_kind) :: bit, full_blocks, block, remaining_bits + integer(bits_kind) :: bit, full_blocks, block + integer :: remaining_bits if ( self % num_bits == 0 ) return full_blocks = self % num_bits / block_size - do block = 1, full_blocks + do block = 1_bits_kind, full_blocks self % blocks(block) = not( self % blocks(block) ) end do remaining_bits = self % num_bits - full_blocks * block_size @@ -750,7 +751,7 @@ contains integer(bits_kind) :: block_ - do block_ = 1, size( set1 % blocks ) + do block_ = 1, size( set1 % blocks, kind=bits_kind ) set1 % blocks(block_) = ior( set1 % blocks(block_), & set2 % blocks(block_) ) end do @@ -817,7 +818,7 @@ contains integer :: stat pos = 1 - find_start: do pos=1, len(string) + find_start: do pos=1_bits_kind, len(string, kind=bits_kind) if ( string(pos:pos) /= ' ' ) exit end do find_start @@ -1161,7 +1162,7 @@ contains alloc_fault, status, module_name, procedure ) return end if - do bit=0, bit_count-1 + do bit=0_bits_kind, bit_count-1 pos = bit_count - bit if ( self % test( bit) ) then string( pos:pos ) = '1' @@ -1236,7 +1237,7 @@ contains write( string, "('S', i0)" ) self % num_bits string( count_digits + 2:count_digits + 2 ) = "B" - do bit=0, bit_count-1 + do bit=0_bits_kind, bit_count-1 pos = count_digits + 2 + bit_count - bit if ( self % test( bit) ) then string( pos:pos ) = '1' @@ -1253,42 +1254,82 @@ contains integer(bits_kind), intent(in) :: bits integer(bits_kind), intent(out) :: digits - select case ( bits ) - case ( 0:9 ) - digits = 1 - - case ( 10:99 ) - digits = 2 - - case ( 100:999 ) - digits = 3 - - case ( 1000:9999 ) - digits = 4 - - case ( 10000:99999 ) - digits = 5 - - case ( 100000:999999 ) - digits = 6 - - case ( 1000000:9999999 ) - digits = 7 + if ( bits_kind == int32 ) then + select case ( bits ) + case ( 0_int32:9_int32 ) + digits = 1 + case ( 10_int32:99_int32 ) + digits = 2 + case ( 100_int32:999_int32 ) + digits = 3 + case ( 1000_int32:9999_int32 ) + digits = 4 + case ( 10000_int32:99999_int32 ) + digits = 5 + case ( 100000_int32:999999_int32 ) + digits = 6 + case ( 1000000_int32:9999999_int32 ) + digits = 7 + case ( 10000000_int32:99999999_int32 ) + digits = 8 + case ( 100000000_int32:999999999_int32 ) + digits = 9 + case ( 1000000000_int32:huge(0_int32) ) + digits = 10 + case default + error stop module_name // ' % ' // procedure // & + ' internal consistency fault was found.' + end select + + else if ( bits_kind == int64 ) then + select case ( bits ) + case ( 0_int64:9_int64 ) + digits = 1 + case ( 10_int64:99_int64 ) + digits = 2 + case ( 100_int64:999_int64 ) + digits = 3 + case ( 1000_int64:9999_int64 ) + digits = 4 + case ( 10000_int64:99999_int64 ) + digits = 5 + case ( 100000_int64:999999_int64 ) + digits = 6 + case ( 1000000_int64:9999999_int64 ) + digits = 7 + case ( 10000000_int64:99999999_int64 ) + digits = 8 + case ( 100000000_int64:999999999_int64 ) + digits = 9 + case ( 1000000000_int64:9999999999_int64 ) + digits = 10 + case ( 10000000000_int64:99999999999_int64 ) + digits = 11 + case ( 100000000000_int64:999999999999_int64 ) + digits = 12 + case ( 1000000000000_int64:9999999999999_int64 ) + digits = 13 + case ( 10000000000000_int64:99999999999999_int64 ) + digits = 14 + case ( 100000000000000_int64:999999999999999_int64 ) + digits = 15 + case ( 1000000000000000_int64:9999999999999999_int64 ) + digits = 16 + case ( 10000000000000000_int64:99999999999999999_int64 ) + digits = 17 + case ( 100000000000000000_int64:999999999999999999_int64 ) + digits = 18 + case ( 1000000000000000000_int64:huge(0_int64) ) + digits = 19 + case default + error stop module_name // ' % ' // procedure // & + ' internal consistency fault was found.' + end select - case ( 10000000:99999999 ) - digits = 8 - - case ( 100000000:999999999 ) - digits = 9 - - case ( 1000000000:min(2147483647, huge( self % num_bits ) ) ) - digits = 10 - - case default + else error stop module_name // ' % ' // procedure // & ' internal consistency fault was found.' - - end select + end if end subroutine digit_count @@ -1314,14 +1355,13 @@ contains integer :: ierr character(:), allocatable :: string - character(len=120) :: message - character(*), parameter :: procedure = "WRITE_BITSET" + character(len=120) :: message + character(*), parameter :: procedure = "WRITE_BITSET" call self % write_bitset(string, status) if ( present(status) ) then if (status /= success ) return - end if @@ -1360,7 +1400,7 @@ contains integer(bits_kind) :: block_ - do block_ = 1, size(set1 % blocks) + do block_ = 1_bits_kind, size(set1 % blocks, kind=bits_kind) set1 % blocks(block_) = ieor( set1 % blocks(block_), & set2 % blocks(block_) ) end do From 47c7d6e9c8fce80ba90c9248e79aaa09b04c0c7e Mon Sep 17 00:00:00 2001 From: William Clodius Date: Thu, 15 Oct 2020 21:08:59 -0600 Subject: [PATCH 36/53] Fixed digit_count For digit_count in stdlib_bitsets_large.fypp replaced the select case construct with a do loop and a divide by ten. [ticket: X] --- src/stdlib_bitsets_large.fypp | 85 +++++------------------------------ 1 file changed, 11 insertions(+), 74 deletions(-) diff --git a/src/stdlib_bitsets_large.fypp b/src/stdlib_bitsets_large.fypp index b4d97e518..e71776833 100644 --- a/src/stdlib_bitsets_large.fypp +++ b/src/stdlib_bitsets_large.fypp @@ -1254,83 +1254,20 @@ contains integer(bits_kind), intent(in) :: bits integer(bits_kind), intent(out) :: digits - if ( bits_kind == int32 ) then - select case ( bits ) - case ( 0_int32:9_int32 ) - digits = 1 - case ( 10_int32:99_int32 ) - digits = 2 - case ( 100_int32:999_int32 ) - digits = 3 - case ( 1000_int32:9999_int32 ) - digits = 4 - case ( 10000_int32:99999_int32 ) - digits = 5 - case ( 100000_int32:999999_int32 ) - digits = 6 - case ( 1000000_int32:9999999_int32 ) - digits = 7 - case ( 10000000_int32:99999999_int32 ) - digits = 8 - case ( 100000000_int32:999999999_int32 ) - digits = 9 - case ( 1000000000_int32:huge(0_int32) ) - digits = 10 - case default - error stop module_name // ' % ' // procedure // & - ' internal consistency fault was found.' - end select - - else if ( bits_kind == int64 ) then - select case ( bits ) - case ( 0_int64:9_int64 ) - digits = 1 - case ( 10_int64:99_int64 ) - digits = 2 - case ( 100_int64:999_int64 ) - digits = 3 - case ( 1000_int64:9999_int64 ) - digits = 4 - case ( 10000_int64:99999_int64 ) - digits = 5 - case ( 100000_int64:999999_int64 ) - digits = 6 - case ( 1000000_int64:9999999_int64 ) - digits = 7 - case ( 10000000_int64:99999999_int64 ) - digits = 8 - case ( 100000000_int64:999999999_int64 ) - digits = 9 - case ( 1000000000_int64:9999999999_int64 ) - digits = 10 - case ( 10000000000_int64:99999999999_int64 ) - digits = 11 - case ( 100000000000_int64:999999999999_int64 ) - digits = 12 - case ( 1000000000000_int64:9999999999999_int64 ) - digits = 13 - case ( 10000000000000_int64:99999999999999_int64 ) - digits = 14 - case ( 100000000000000_int64:999999999999999_int64 ) - digits = 15 - case ( 1000000000000000_int64:9999999999999999_int64 ) - digits = 16 - case ( 10000000000000000_int64:99999999999999999_int64 ) - digits = 17 - case ( 100000000000000000_int64:999999999999999999_int64 ) - digits = 18 - case ( 1000000000000000000_int64:huge(0_int64) ) - digits = 19 - case default - error stop module_name // ' % ' // procedure // & - ' internal consistency fault was found.' - end select + integer(bits_kind) :: factor - else - error stop module_name // ' % ' // procedure // & - ' internal consistency fault was found.' + factor = bits + + if ( factor <= 0 ) then + digits = 1 + return end if + do digits = 1, 127 + factor = factor / 10 + if ( factor == 0 ) return + end do + end subroutine digit_count end subroutine write_bitset_string_large From 80af2c526c196e8085d25b633f5ba35c520b2dd4 Mon Sep 17 00:00:00 2001 From: William Clodius Date: Fri, 16 Oct 2020 08:14:04 -0600 Subject: [PATCH 37/53] Added dependence on stdlib_kinds.f90 Added dependence of stdlib_bitsets.f90 on stdlib_kinds.f90. [ticket: X] --- src/Makefile.manual | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Makefile.manual b/src/Makefile.manual index 2d838086a..872f704c0 100644 --- a/src/Makefile.manual +++ b/src/Makefile.manual @@ -43,6 +43,7 @@ clean: # Fortran module dependencies f18estop.o: stdlib_error.o +stdlib_bitsets.o: stdlib_kinds.o stdlib_bitsets_64.o: stdlib_bitsets.o stdlib_bitsets_large.o: stdlib_bitsets.o stdlib_error.o: stdlib_optval.o From 0deab15ccee1f0cfd40078c8a4bb0748f01d34c5 Mon Sep 17 00:00:00 2001 From: William Clodius Date: Fri, 16 Oct 2020 08:17:37 -0600 Subject: [PATCH 38/53] Fixed bits_kind breakage Made constants in max et al bits_kind to match variables kind, fixed digit_count in stdlib_bitsets_64.fypp. [ticket: X] --- src/stdlib_bitsets_64.fypp | 49 ++++++++++------------------------- src/stdlib_bitsets_large.fypp | 6 ++--- 2 files changed, 16 insertions(+), 39 deletions(-) diff --git a/src/stdlib_bitsets_64.fypp b/src/stdlib_bitsets_64.fypp index 68bb725b7..12fe884cb 100644 --- a/src/stdlib_bitsets_64.fypp +++ b/src/stdlib_bitsets_64.fypp @@ -171,7 +171,7 @@ contains integer(bits_kind) :: true_first, true_last - true_first = max( 0, start_pos ) + true_first = max( 0_bits_kind, start_pos ) true_last = min( self % num_bits-1, stop_pos ) if ( true_last < true_first ) return @@ -275,7 +275,7 @@ contains integer(bits_kind) :: end_bit, start_bit - start_bit = max( 0, start_pos ) + start_bit = max( 0_bits_kind, start_pos ) end_bit = min( stop_pos , self % num_bits-1 ) call mvbits( not(self % block), & start_bit, & @@ -888,7 +888,7 @@ contains integer(bits_kind) :: end_bit, start_bit - start_bit = max( 0, start_pos ) + start_bit = max( 0_bits_kind, start_pos ) end_bit = min( stop_pos, self % num_bits-1 ) if ( end_bit < start_bit ) return @@ -1030,42 +1030,19 @@ contains integer(bits_kind), intent(in) :: bits integer(bits_kind), intent(out) :: digits - select case ( bits ) - case ( 0:9 ) - digits = 1 - - case ( 10:99 ) - digits = 2 - - case ( 100:999 ) - digits = 3 - - case ( 1000:9999 ) - digits = 4 - - case ( 10000:99999 ) - digits = 5 - - case ( 100000:999999 ) - digits = 6 - - case ( 1000000:9999999 ) - digits = 7 - - case ( 10000000:99999999 ) - digits = 8 + integer(bits_kind) :: factor - case ( 100000000:999999999 ) - digits = 9 + factor = bits - case ( 1000000000:min(2147483647, huge( self % num_bits ) ) ) - digits = 10 - - case default - error stop module_name // ' % ' // procedure // & - ' internal consistency fault was found.' + if ( factor <= 0 ) then + digits = 1 + return + end if - end select + do digits = 1, 127 + factor = factor / 10 + if ( factor == 0 ) return + end do end subroutine digit_count diff --git a/src/stdlib_bitsets_large.fypp b/src/stdlib_bitsets_large.fypp index e71776833..0c499c732 100644 --- a/src/stdlib_bitsets_large.fypp +++ b/src/stdlib_bitsets_large.fypp @@ -203,7 +203,7 @@ contains integer(bits_kind) :: bit, block_, first_block, last_block, & true_first, true_last - true_first = max( 0, start_pos ) + true_first = max( 0_bits_kind, start_pos ) true_last = min( self % num_bits-1, stop_pos ) if ( true_last < true_first ) return @@ -357,7 +357,7 @@ contains integer(bits_kind) :: bit, block_, end_bit, first_block, last_block, & start_bit - start_bit = max( 0, start_pos ) + start_bit = max( 0_bits_kind, start_pos ) end_bit = min( stop_pos , self % num_bits-1 ) if ( end_bit < start_bit ) return @@ -1080,7 +1080,7 @@ contains integer(bits_kind) :: bit, block_, end_bit, first_block, last_block, & start_bit - start_bit = max( 0, start_pos ) + start_bit = max( 0_bits_kind, start_pos ) end_bit = min( stop_pos, self % num_bits-1 ) if ( end_bit < start_bit ) return From 9f0e4a90659b817a58105e0c7291938816c9d4f2 Mon Sep 17 00:00:00 2001 From: William Clodius Date: Fri, 16 Oct 2020 08:21:33 -0600 Subject: [PATCH 39/53] Fixed up constants Made many constants of kind bits_kind so the pertinent procedures would be recognized. [ticket: X] --- src/tests/bitsets/test_stdlib_bitset_64.f90 | 28 ++--- .../bitsets/test_stdlib_bitset_large.f90 | 110 +++++++++--------- 2 files changed, 69 insertions(+), 69 deletions(-) diff --git a/src/tests/bitsets/test_stdlib_bitset_64.f90 b/src/tests/bitsets/test_stdlib_bitset_64.f90 index a71b3cd8b..ad285861e 100644 --- a/src/tests/bitsets/test_stdlib_bitset_64.f90 +++ b/src/tests/bitsets/test_stdlib_bitset_64.f90 @@ -277,7 +277,7 @@ subroutine test_initialization() end if set5 = log1 - call extract( set4, set5, 1, 33 ) + call extract( set4, set5, 1_bits_kind, 33_bits_kind ) if ( set4 % bits() /= 33 ) then error stop procedure // & ' initialization with extract failed to set' // & @@ -360,7 +360,7 @@ end subroutine test_initialization subroutine test_bitset_inquiry() character(*), parameter:: procedure = 'TEST_BITSET_INQUIRY' - integer :: i + integer(bits_kind) :: i write(*,*) write(*,*) 'Test bitset inquiry: all, any, bits, none, test, and value' @@ -472,9 +472,9 @@ subroutine test_bit_operations() error stop procedure // ' set1 is not all set.' end if - call set1 % clear(0) - if ( .not. set1 % test(0) ) then - if ( set1 % test(1) ) then + call set1 % clear(0_bits_kind) + if ( .not. set1 % test(0_bits_kind) ) then + if ( set1 % test(1_bits_kind) ) then write(*,*) 'Cleared one bit in set1 as expected.' else error stop procedure // ' cleared more than one bit in set1.' @@ -483,7 +483,7 @@ subroutine test_bit_operations() error stop procedure // ' did not clear the first bit in set1.' end if - call set1 % clear(1, 32) + call set1 % clear(1_bits_kind, 32_bits_kind) if ( set1 % none() ) then write(*,*) 'Cleared remaining bits in set1 as expected.' else @@ -491,9 +491,9 @@ subroutine test_bit_operations() 'in set1.' end if - call set1 % flip(0) - if ( set1 % test(0) ) then - if ( .not. set1 % test(1) ) then + call set1 % flip(0_bits_kind) + if ( set1 % test(0_bits_kind) ) then + if ( .not. set1 % test(1_bits_kind) ) then write(*,*) 'Flipped one bit in set1 as expected.' else error stop procedure // ' flipped more than one bit in set1.' @@ -502,7 +502,7 @@ subroutine test_bit_operations() error stop procedure // ' did not flip the first bit in set1.' end if - call set1 % flip(1, 32) + call set1 % flip(1_bits_kind, 32_bits_kind) if ( set1 % all() ) then write(*,*) 'Flipped remaining bits in set1 as expected.' else @@ -517,9 +517,9 @@ subroutine test_bit_operations() error stop procedure // ' did not unset bits in set1.' end if - call set1 % set(0) - if ( set1 % test(0) ) then - if ( .not. set1 % test(1) ) then + call set1 % set(0_bits_kind) + if ( set1 % test(0_bits_kind) ) then + if ( .not. set1 % test(1_bits_kind) ) then write(*,*) 'Set first bit in set1 as expected.' else error stop procedure // ' set more than one bit in set1.' @@ -528,7 +528,7 @@ subroutine test_bit_operations() error stop procedure // ' did not set the first bit in set1.' end if - call set1 % set(1, 32) + call set1 % set(1_bits_kind, 32_bits_kind) if ( set1 % all() ) then write(*,*) 'Set the remaining bits in set1 as expected.' else diff --git a/src/tests/bitsets/test_stdlib_bitset_large.f90 b/src/tests/bitsets/test_stdlib_bitset_large.f90 index dec05bb09..18445fe3d 100644 --- a/src/tests/bitsets/test_stdlib_bitset_large.f90 +++ b/src/tests/bitsets/test_stdlib_bitset_large.f90 @@ -503,7 +503,7 @@ subroutine test_initialization() end if set5 = log1 - call extract( set4, set5, 1, 33 ) + call extract( set4, set5, 1_bits_kind, 33_bits_kind ) if ( set4 % bits() /= 33 ) then error stop procedure // & ' initialization with extract failed to set' // & @@ -517,7 +517,7 @@ subroutine test_initialization() end if set5 = log11 - call extract( set4, set5, 1, 65 ) + call extract( set4, set5, 1_bits_kind, 65_bits_kind ) if ( set4 % bits() /= 65 ) then error stop procedure // & ' initialization with extract failed to set' // & @@ -677,7 +677,7 @@ end subroutine test_initialization subroutine test_bitset_inquiry() character(*), parameter:: procedure = 'TEST_BITSET_INQUIRY' - integer :: i + integer(bits_kind) :: i write(*,*) write(*,*) 'Test bitset inquiry: all, any, bits, none, test, and value' @@ -898,9 +898,9 @@ subroutine test_bit_operations() error stop procedure // ' set1 is not all set.' end if - call set1 % clear(0) - if ( .not. set1 % test(0) ) then - if ( set1 % test(1) ) then + call set1 % clear(0_bits_kind) + if ( .not. set1 % test(0_bits_kind) ) then + if ( set1 % test(1_bits_kind) ) then write(*,*) 'Cleared one bit in set1 as expected.' else error stop procedure // ' cleared more than one bit in set1.' @@ -909,7 +909,7 @@ subroutine test_bit_operations() error stop procedure // ' did not clear the first bit in set1.' end if - call set1 % clear(1, 32) + call set1 % clear(1_bits_kind, 32_bits_kind) if ( set1 % none() ) then write(*,*) 'Cleared remaining bits in set1 as expected.' else @@ -917,9 +917,9 @@ subroutine test_bit_operations() 'in set1.' end if - call set1 % flip(0) - if ( set1 % test(0) ) then - if ( .not. set1 % test(1) ) then + call set1 % flip(0_bits_kind) + if ( set1 % test(0_bits_kind) ) then + if ( .not. set1 % test(1_bits_kind) ) then write(*,*) 'Flipped one bit in set1 as expected.' else error stop procedure // ' flipped more than one bit in set1.' @@ -928,7 +928,7 @@ subroutine test_bit_operations() error stop procedure // ' did not flip the first bit in set1.' end if - call set1 % flip(1, 32) + call set1 % flip(1_bits_kind, 32_bits_kind) if ( set1 % all() ) then write(*,*) 'Flipped remaining bits in set1 as expected.' else @@ -943,9 +943,9 @@ subroutine test_bit_operations() error stop procedure // ' did not unset bits in set1.' end if - call set1 % set(0) - if ( set1 % test(0) ) then - if ( .not. set1 % test(1) ) then + call set1 % set(0_bits_kind) + if ( set1 % test(0_bits_kind) ) then + if ( .not. set1 % test(1_bits_kind) ) then write(*,*) 'Set first bit in set1 as expected.' else error stop procedure // ' set more than one bit in set1.' @@ -954,7 +954,7 @@ subroutine test_bit_operations() error stop procedure // ' did not set the first bit in set1.' end if - call set1 % set(1, 32) + call set1 % set(1_bits_kind, 32_bits_kind) if ( set1 % all() ) then write(*,*) 'Set the remaining bits in set1 as expected.' else @@ -962,15 +962,15 @@ subroutine test_bit_operations() 'in set1.' end if - call set11 % init( 166 ) + call set11 % init( 166_bits_kind ) call set11 % not() if ( .not. set11 % all() ) then error stop procedure // ' set11 is not all set.' end if - call set11 % clear(0) - if ( .not. set11 % test(0) ) then - if ( set11 % test(1) ) then + call set11 % clear(0_bits_kind) + if ( .not. set11 % test(0_bits_kind) ) then + if ( set11 % test(1_bits_kind) ) then write(*,*) 'Cleared one bit in set11 as expected.' else error stop procedure // ' cleared more than one bit in set11.' @@ -979,9 +979,9 @@ subroutine test_bit_operations() error stop procedure // ' did not clear the first bit in set11.' end if - call set11 % clear(165) - if ( .not. set11 % test(165) ) then - if ( set11 % test(164) ) then + call set11 % clear(165_bits_kind) + if ( .not. set11 % test(165_bits_kind) ) then + if ( set11 % test(164_bits_kind) ) then write(*,*) 'Cleared the last bit in set11 as expected.' else error stop procedure // ' cleared more than one bit in set11.' @@ -990,7 +990,7 @@ subroutine test_bit_operations() error stop procedure // ' did not clear the last bit in set11.' end if - call set11 % clear(1, 164) + call set11 % clear(1_bits_kind, 164_bits_kind) if ( set11 % none() ) then write(*,*) 'Cleared remaining bits in set11 as expected.' else @@ -998,9 +998,9 @@ subroutine test_bit_operations() 'in set11.' end if - call set11 % flip(0) - if ( set11 % test(0) ) then - if ( .not. set11 % test(1) ) then + call set11 % flip(0_bits_kind) + if ( set11 % test(0_bits_kind) ) then + if ( .not. set11 % test(1_bits_kind) ) then write(*,*) 'Flipped one bit in set11 as expected.' else error stop procedure // ' flipped more than one bit in set11.' @@ -1009,9 +1009,9 @@ subroutine test_bit_operations() error stop procedure // ' did not flip the first bit in set11.' end if - call set11 % flip(165) - if ( set11 % test(165) ) then - if ( .not. set11 % test(164) ) then + call set11 % flip(165_bits_kind) + if ( set11 % test(165_bits_kind) ) then + if ( .not. set11 % test(164_bits_kind) ) then write(*,*) 'Flipped last bit in set11 as expected.' else error stop procedure // ' flipped more than one bit in set11.' @@ -1020,7 +1020,7 @@ subroutine test_bit_operations() error stop procedure // ' did not flip the last bit in set11.' end if - call set11 % flip(1, 164) + call set11 % flip(1_bits_kind, 164_bits_kind) if ( set11 % all() ) then write(*,*) 'Flipped remaining bits in set11 as expected.' else @@ -1035,9 +1035,9 @@ subroutine test_bit_operations() error stop procedure // ' did not unset bits in set11.' end if - call set11 % set(0) - if ( set11 % test(0) ) then - if ( .not. set11 % test(1) ) then + call set11 % set(0_bits_kind) + if ( set11 % test(0_bits_kind) ) then + if ( .not. set11 % test(1_bits_kind) ) then write(*,*) 'Set first bit in set11 as expected.' else error stop procedure // ' set more than one bit in set11.' @@ -1046,9 +1046,9 @@ subroutine test_bit_operations() error stop procedure // ' did not set the first bit in set11.' end if - call set11 % set(165) - if ( set11 % test(165) ) then - if ( .not. set11 % test(164) ) then + call set11 % set(165_bits_kind) + if ( set11 % test(165_bits_kind) ) then + if ( .not. set11 % test(164_bits_kind) ) then write(*,*) 'Set last bit in set11 as expected.' else error stop procedure // ' set more than one bit in set11.' @@ -1057,7 +1057,7 @@ subroutine test_bit_operations() error stop procedure // ' did not set the last bit in set11.' end if - call set11 % set(1, 164) + call set11 % set(1_bits_kind, 164_bits_kind) if ( set11 % all() ) then write(*,*) 'Set the remaining bits in set11 as expected.' else @@ -1123,15 +1123,15 @@ subroutine test_bitset_comparisons() 'equal tests.' end if - call set10 % init(166) - call set11 % init(166) + call set10 % init(166_bits_kind) + call set11 % init(166_bits_kind) call set11 % not() - call set12 % init(166) - call set12 % set(165) - call set13 % init(166) - call set13 % set(65) - call set14 % init(166) - call set14 % set(0) + call set12 % init(166_bits_kind) + call set12 % set(165_bits_kind) + call set13 % init(166_bits_kind) + call set13 % set(65_bits_kind) + call set14 % init(166_bits_kind) + call set14 % set(0_bits_kind) if ( set10 == set10 .and. set11 == set11 .and. set12 == set12 .and. & set13 == set13 .and. set14 == set14 .and. & .not. set13 == set14 .and. .not. set12 == set13 .and. & @@ -1337,9 +1337,9 @@ subroutine test_bitset_operations() error stop procedure // ' fourth test of < 64 bit XOR failed.' end if - call set0 % init(166) + call set0 % init(166_bits_kind) call set0 % not() - call set4 % init(166) + call set4 % init(166_bits_kind) call set4 % not() call and( set0, set4 ) ! all all if ( set0 % all() ) then @@ -1348,7 +1348,7 @@ subroutine test_bitset_operations() error stop procedure // ' first test of > 64 bit AND failed.' end if - call set4 % init(166) + call set4 % init(166_bits_kind) call and( set0, set4 ) ! all none if ( set0 % none() ) then write(*,*) 'Second test of > 64 bit AND worked.' @@ -1356,7 +1356,7 @@ subroutine test_bitset_operations() error stop procedure // ' second test of > 64 bit AND failed.' end if - call set3 % init(166) + call set3 % init(166_bits_kind) call set3 % not() call and( set4, set3 ) ! none all if ( set4 % none() ) then @@ -1365,7 +1365,7 @@ subroutine test_bitset_operations() error stop procedure // ' third test of > 64 bit AND failed.' end if - call set3 % init(166) + call set3 % init(166_bits_kind) call and( set4, set3 ) ! none none if ( set4 % none() ) then write(*,*) 'Fourth test of > 64 bit AND worked.' @@ -1404,9 +1404,9 @@ subroutine test_bitset_operations() error stop procedure // ' fourth test of > 64 bit AND_NOT failed.' end if - call set3 % init(166) + call set3 % init(166_bits_kind) call set3 % not() - call set4 % init(166) + call set4 % init(166_bits_kind) call set4 % not() call or( set3, set4 ) ! all all if ( set3 % all() ) then @@ -1415,7 +1415,7 @@ subroutine test_bitset_operations() error stop procedure // ' first test of > 64 bit OR failed.' end if - call set3 % init(166) + call set3 % init(166_bits_kind) call or( set4, set3 ) ! all none if ( set4 % all() ) then write(*,*) 'Second test of > 64 bit OR worked.' @@ -1430,8 +1430,8 @@ subroutine test_bitset_operations() error stop procedure // ' third test of > 64 bit OR failed.' end if - call set3 % init(166) - call set4 % init(166) + call set3 % init(166_bits_kind) + call set4 % init(166_bits_kind) call or( set4, set3 ) !none none if ( set4 % none() ) then write(*,*) 'Fourth test of > 64 bit OR worked.' From 9f690fd79bf2e0d0b08de0a9a30352fce74edf9a Mon Sep 17 00:00:00 2001 From: Jeremie Vandenplas Date: Fri, 16 Oct 2020 21:04:54 +0200 Subject: [PATCH 40/53] some typos --- src/stdlib_bitsets.fypp | 10 +++++----- src/stdlib_bitsets_64.fypp | 2 +- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/stdlib_bitsets.fypp b/src/stdlib_bitsets.fypp index 842398e2f..cc329772d 100644 --- a/src/stdlib_bitsets.fypp +++ b/src/stdlib_bitsets.fypp @@ -134,7 +134,7 @@ module stdlib_bitsets elemental function all_abstract( self ) result(all) !! Version: experimental !! -!! Returns `.true.` if all bits in `self` are 1, `.false`. otherwise. +!! Returns `.true.` if all bits in `self` are 1, `.false.` otherwise. !! !!#### Example !! @@ -1300,7 +1300,7 @@ module stdlib_bitsets !! Creates the bitset, `self`, of size `bits`, with all bits initialized to !! zero. `bits` must be non-negative. If an error occurs and `status` is !! absent then processing stops with an informative stop code. `status` -!! will have one of the values; +!! will have one of the values: !! * `success` - if no problems were found, !! * `alloc_fault` - if memory allocation failed !! * `array_size_invalid_error` - if `bits` is either negative or larger @@ -1362,7 +1362,7 @@ module stdlib_bitsets !! the bitset, `self`. The literal may be preceded by an an arbitrary !! sequence of blank characters. If `status` is absent an error results !! in an error stop with an informative stop code. If `status` -!! is present it has one of the values +!! is present it has one of the values: !! * `success` - if no problems occurred, !! * `alloc_fault` - if allocation of memory for SELF failed, !! * `array_size_invalid_error - if `bits(self)` in `string` is greater @@ -1505,7 +1505,7 @@ module stdlib_bitsets module subroutine assign_log${k1}$_64( self, logical_vector ) !! Version: experimental !! -!! Used to define assignment from an array of type `logical(int8)` to a +!! Used to define assignment from an array of type `logical(${k1}$)` to a !! `bitset_64`. type(bitset_64), intent(out) :: self logical(${k1}$), intent(in) :: logical_vector(:) @@ -1514,7 +1514,7 @@ module stdlib_bitsets pure module subroutine log${k1}$_assign_64( logical_vector, set ) !! Version: experimental !! -!! Used to define assignment to an array of type `logical(int8)` from a +!! Used to define assignment to an array of type `logical(${k1}$)` from a !! `bitset_64`. logical(${k1}$), intent(out), allocatable :: logical_vector(:) type(bitset_64), intent(in) :: set diff --git a/src/stdlib_bitsets_64.fypp b/src/stdlib_bitsets_64.fypp index 12fe884cb..756e3afa8 100644 --- a/src/stdlib_bitsets_64.fypp +++ b/src/stdlib_bitsets_64.fypp @@ -366,7 +366,7 @@ contains ! Creates the bitset, `self`, of size `bits`, with all bits initialized to ! zero. `bits` must be non-negative. If an error occurs and `status` is ! absent then processing stops with an informative stop code. `status` -! will have one of the values; +! will have one of the values: ! * `success` - if no problems were found, ! * `array_size_invalid_error` - if `bits` is either negative or larger ! than 64 with `self` of class `bitset_64`, or From f7053461b3f34d60918bd69aa53519d208f3597b Mon Sep 17 00:00:00 2001 From: William Clodius Date: Mon, 19 Oct 2020 13:40:00 -0600 Subject: [PATCH 41/53] Added discussion of undefined behavior Added discussion of the undefined behavior that can occur when the bitset "sizes" for the two bitset arguments to "binary" procedures do not agree. [ticket: X] --- doc/specs/stdlib_bitsets.md | 22 +++++++++++++++++----- 1 file changed, 17 insertions(+), 5 deletions(-) diff --git a/doc/specs/stdlib_bitsets.md b/doc/specs/stdlib_bitsets.md index 70ec4275c..a75e2635b 100644 --- a/doc/specs/stdlib_bitsets.md +++ b/doc/specs/stdlib_bitsets.md @@ -10,18 +10,30 @@ title: Bitsets The `stdlib_bitsets` module implements bitset types. A bitset is a compact representation of a sequence of `bits` binary values. It can -equivalently be considered as a sequence of logical values or as a subset of -the integers 0 ... `bits-1`. The bits are indexed from 0 to +equivalently be considered as a sequence of logical values or as a +subset of the integers 0 ... `bits-1`. The bits are indexed from 0 to `bits(bitset)-1`. A bitset is used when space savings are critical in applications that require a large number of closely related logical values. -It may also improve performance by reducing memory traffic. To implement -bitsets the module +It may also improve performance by reducing memory traffic. To +implement bitsets the module defines three bitset types, multiple constants, a character string literal that can be read to and from strings and formatted files, a simple character string literal that can be read to and from strings, assignments, procedures, methods, and operators. Note that the module -assumes two's complement integers, but all current Fortran 95+ processors use such integers. +assumes two's complement integers, but all current Fortran 95+ +processors use such integers. + +Note that the module defines a number of "binary" procedure, +procedures with two bitset arguments. These arguments must be of the +same type and should have the same number of `bits`. For reasons of +performance the module does not enforce the `bits` constraint, but +failure to obey that constraint results in undefined behavior. This +undefined behavior includes undefined values for those bits that +exceed the defined number of `bits` in the smaller bitset. The +undefined behavior may also include a "segmentation fault" for +attempting to address bits in the smaller bitset, beyond the defined +number of `bits`. Other problems are also possible. ## The module's constants From 242950b03f7040586038bf3f9297b255d08a27e8 Mon Sep 17 00:00:00 2001 From: William Clodius Date: Mon, 19 Oct 2020 13:48:38 -0600 Subject: [PATCH 42/53] Fixed typo Changed procedure to its plural procedures. [ticket: X] --- doc/specs/stdlib_bitsets.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/specs/stdlib_bitsets.md b/doc/specs/stdlib_bitsets.md index a75e2635b..08e0fc8d0 100644 --- a/doc/specs/stdlib_bitsets.md +++ b/doc/specs/stdlib_bitsets.md @@ -24,7 +24,7 @@ assignments, procedures, methods, and operators. Note that the module assumes two's complement integers, but all current Fortran 95+ processors use such integers. -Note that the module defines a number of "binary" procedure, +Note that the module defines a number of "binary" procedures, procedures with two bitset arguments. These arguments must be of the same type and should have the same number of `bits`. For reasons of performance the module does not enforce the `bits` constraint, but From 032c4401e4488acc8b9115500a9f45a62bdb4820 Mon Sep 17 00:00:00 2001 From: William Clodius Date: Mon, 19 Oct 2020 13:53:54 -0600 Subject: [PATCH 43/53] Added reference to the bitsets module Addedl line refering to the fitsets source file. [ticket: X] --- doc/specs/index.md | 1 + 1 file changed, 1 insertion(+) diff --git a/doc/specs/index.md b/doc/specs/index.md index 91284c2df..c10818fa9 100644 --- a/doc/specs/index.md +++ b/doc/specs/index.md @@ -11,6 +11,7 @@ This is and index/directory of the specifications (specs) for each new module/fe ## Experimental Features & Modules + - [bitsets](./stdlib_bitsets.html) - Bitset data types and procedures - [error](./stdlib_error.html) - Catching and handling errors - [IO](./stdlib_io.html) - Input/output helper & convenience - [linalg](./stdlib_linalg.html) - Linear Algebra From e9573427aea56e60db032310c9bc7c20c8eb0d49 Mon Sep 17 00:00:00 2001 From: William Clodius Date: Mon, 19 Oct 2020 20:08:29 -0600 Subject: [PATCH 44/53] Made it easier to change bits_kind Introduced the parameters max_digits and overflow_bits to be used in checking for overflows on reads and writes. The parameters need to be changed if bits_kind is changed, and preferred parameters for bits_kind==int64 are defined, but commented out. [ticket: X] --- src/stdlib_bitsets.fypp | 17 +++++++++++++---- src/stdlib_bitsets_64.fypp | 16 ++++++++++------ src/stdlib_bitsets_large.fypp | 11 ++++++----- 3 files changed, 29 insertions(+), 15 deletions(-) diff --git a/src/stdlib_bitsets.fypp b/src/stdlib_bitsets.fypp index cc329772d..0732a5a0f 100644 --- a/src/stdlib_bitsets.fypp +++ b/src/stdlib_bitsets.fypp @@ -6,8 +6,8 @@ module stdlib_bitsets !! having the sign bit set. use :: stdlib_kinds, only: & - bits_kind => int32, & - block_kind => int64, & + bits_kind => int32, & ! If changed change also max_digits, and + block_kind => int64, & ! overflow_bits int8, & int16, & int32, & @@ -24,12 +24,21 @@ module stdlib_bitsets integer(bits_kind), parameter :: & block_size = bit_size(0_block_kind) + public :: max_digits, overflow_bits + integer, parameter :: & + max_digits = 10 ! bits_kind == int32 +! max_digits = 20 ! bits_kind == int64 + + integer(bits_kind), parameter :: & + overflow_bits = 2_bits_kind**30/5 ! bits_kind == int32 +! overflow_bits = 2_bits_kind**62/5 ! bits_kind == int64 + integer(block_kind), parameter :: all_zeros = 0_block_kind integer(block_kind), parameter :: all_ones = not(all_zeros) character(*), parameter :: module_name = "STDLIB_BITSETS" - integer, parameter :: & - ia0 = iachar('0'), & + integer, parameter :: & + ia0 = iachar('0'), & ia9 = iachar('9') integer, parameter, public :: success = 0 diff --git a/src/stdlib_bitsets_64.fypp b/src/stdlib_bitsets_64.fypp index 756e3afa8..949482215 100644 --- a/src/stdlib_bitsets_64.fypp +++ b/src/stdlib_bitsets_64.fypp @@ -644,9 +644,10 @@ contains select case( iachar( string(pos:pos) ) ) case(ia0:ia9) digits = digits + 1 - if ( digits == 10 .AND. bits > 2_bits_kind**30/5 ) go to 996 + if ( digits == max_digits .AND. bits > overflow_bits ) & + go to 996 !! May not be quite right - if ( digits > 10 ) go to 996 + if ( digits > max_digits ) go to 996 bits = bits*10 + iachar( string(pos:pos) ) - ia0 if ( bits < 0 ) go to 996 case(iachar('b'), iachar('B')) @@ -776,9 +777,10 @@ contains select case( char ) case( '0', '1', '2', '3', '4', '5', '6', '7', '8', '9' ) digits = digits + 1 - if ( digits == 10 .AND. bits > 2_bits_kind**30/5 ) go to 996 + if ( digits == max_digits .AND. bits > overflow_bits ) & + go to 996 !! May not be quite right - if ( digits > 10 ) go to 996 + if ( digits > max_digits ) go to 996 bits = 10*bits + iachar(char) - iachar('0') if ( bits < 0 ) go to 996 case default @@ -786,7 +788,7 @@ contains end select end do - if ( bits < 0 .OR. digits == 0 .OR. digits > 10 ) go to 999 + if ( bits < 0 .OR. digits == 0 .OR. digits > max_digits ) go to 999 if ( bits > 64 ) then call error_handler( 'BITS in UNIT was greater than 64.', & @@ -870,9 +872,11 @@ contains ! class(bitset_64), intent(inout) :: self integer(bits_kind), intent(in) :: pos + integer(block_kind) :: dummy if ( pos < 0 .OR. pos > self % num_bits-1 ) return - self % block = ibset( self % block, pos ) + dummy = ibset( self % block, pos ) + self % block = dummy end subroutine set_bit_64 diff --git a/src/stdlib_bitsets_large.fypp b/src/stdlib_bitsets_large.fypp index 0c499c732..c82003de6 100644 --- a/src/stdlib_bitsets_large.fypp +++ b/src/stdlib_bitsets_large.fypp @@ -834,9 +834,9 @@ contains select case( iachar( string(pos:pos) ) ) case(ia0:ia9) digits = digits + 1 - if ( digits == 10 .AND. bits > 2_bits_kind**30/5 ) go to 996 + if ( digits == max_digits .AND. bits > overflow_bits ) go to 996 !! May not be quite right - if ( digits > 10 ) go to 996 + if ( digits > max_digits ) go to 996 bits = bits*10 + iachar( string(pos:pos) ) - ia0 if ( bits < 0 ) go to 996 case(iachar('b'), iachar('B')) @@ -963,8 +963,9 @@ contains select case( char ) case( '0', '1', '2', '3', '4', '5', '6', '7', '8', '9' ) digits = digits + 1 - if ( digits == 10 .AND. bits > 2_bits_kind**30/5 ) go to 996 - if ( digits > 10 ) go to 996 + if ( digits == max_digits .AND. bits > overflow_bits ) & + go to 996 + if ( digits > max_digits ) go to 996 bits = 10*bits + iachar(char) - iachar('0') if ( bits < 0 ) go to 996 case default @@ -972,7 +973,7 @@ contains end select end do - if ( bits < 0 .OR. digits == 0 .OR. digits > 10 ) go to 999 + if ( bits < 0 .OR. digits == 0 .OR. digits > max_digits ) go to 999 call self % init( bits, status ) if ( present(status) ) then From 9161fc73ef36d0cac6e39889fdc9d60612c25cf8 Mon Sep 17 00:00:00 2001 From: William Clodius Date: Tue, 20 Oct 2020 10:46:32 -0600 Subject: [PATCH 45/53] Replaced go to 100 with exit Replaced go to 100 with exit in both stdlib_bitsets_64.fypp and stdlib_bitsets_large.fypp. [ticket: X] --- src/stdlib_bitsets_64.fypp | 4 ++-- src/stdlib_bitsets_large.fypp | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/stdlib_bitsets_64.fypp b/src/stdlib_bitsets_64.fypp index 949482215..e86691c8d 100644 --- a/src/stdlib_bitsets_64.fypp +++ b/src/stdlib_bitsets_64.fypp @@ -651,7 +651,7 @@ contains bits = bits*10 + iachar( string(pos:pos) ) - ia0 if ( bits < 0 ) go to 996 case(iachar('b'), iachar('B')) - go to 100 + exit case default go to 999 end select @@ -660,7 +660,7 @@ contains end do -100 if ( bits > 64 ) then + if ( bits > 64 ) then call error_handler( 'BITS in STRING was greater than 64.', & char_string_too_large_error, status, & module_name, procedure ) diff --git a/src/stdlib_bitsets_large.fypp b/src/stdlib_bitsets_large.fypp index c82003de6..0d4627c46 100644 --- a/src/stdlib_bitsets_large.fypp +++ b/src/stdlib_bitsets_large.fypp @@ -840,7 +840,7 @@ contains bits = bits*10 + iachar( string(pos:pos) ) - ia0 if ( bits < 0 ) go to 996 case(iachar('b'), iachar('B')) - go to 100 + exit case default call error_handler( 'There was an invalid character ' // & 'in STRING', & @@ -852,7 +852,7 @@ contains pos = pos + 1 end do -100 if ( bits + pos > len(string) ) then + if ( bits + pos > len(string) ) then call error_handler( 'STRING was too small for the number of ' // & 'bits specified by STRING.', & char_string_too_small_error, status, & From 3235ab4a465e5f19f0988bd2983219cfe2e17938 Mon Sep 17 00:00:00 2001 From: William Clodius Date: Tue, 20 Oct 2020 17:40:56 -0600 Subject: [PATCH 46/53] Changed used modues Replaced the use of iso_fortran_env with stdlib_kinds. [ticket: X] --- src/tests/bitsets/test_stdlib_bitset_64.f90 | 2 +- src/tests/bitsets/test_stdlib_bitset_large.f90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/tests/bitsets/test_stdlib_bitset_64.f90 b/src/tests/bitsets/test_stdlib_bitset_64.f90 index ad285861e..8d1778695 100644 --- a/src/tests/bitsets/test_stdlib_bitset_64.f90 +++ b/src/tests/bitsets/test_stdlib_bitset_64.f90 @@ -1,5 +1,5 @@ program test_stdlib_bitset_64 - use, intrinsic :: iso_fortran_env, only : int8, int16, int32, int64 + use :: stdlib_kinds, only : int8, int16, int32, int64 use stdlib_bitsets character(*), parameter :: & bitstring_0 = '000000000000000000000000000000000', & diff --git a/src/tests/bitsets/test_stdlib_bitset_large.f90 b/src/tests/bitsets/test_stdlib_bitset_large.f90 index 18445fe3d..7785d268a 100644 --- a/src/tests/bitsets/test_stdlib_bitset_large.f90 +++ b/src/tests/bitsets/test_stdlib_bitset_large.f90 @@ -1,5 +1,5 @@ program test_stdlib_bitset_large - use, intrinsic :: iso_fortran_env, only : int8, int16, int32, int64 + use :: stdlib_kinds, only : int8, int16, int32, int64 use stdlib_bitsets implicit none character(*), parameter :: & From 523dbc691575e54a9d54b02f83219c79020ef0dd Mon Sep 17 00:00:00 2001 From: William Clodius Date: Tue, 20 Oct 2020 18:04:29 -0600 Subject: [PATCH 47/53] Changed handling of potential integer overflows on reads Changed handling of potential integer overflows on reads for bits_kind==int64, changing max_digits from 20 to 19. Removed comment that my treatment may not be quite right. Also fixed a typo in an error message. [ticket: X] --- src/stdlib_bitsets.fypp | 4 ++-- src/stdlib_bitsets_64.fypp | 2 -- src/stdlib_bitsets_large.fypp | 1 - 3 files changed, 2 insertions(+), 5 deletions(-) diff --git a/src/stdlib_bitsets.fypp b/src/stdlib_bitsets.fypp index 0732a5a0f..881a7bd2c 100644 --- a/src/stdlib_bitsets.fypp +++ b/src/stdlib_bitsets.fypp @@ -27,7 +27,7 @@ module stdlib_bitsets public :: max_digits, overflow_bits integer, parameter :: & max_digits = 10 ! bits_kind == int32 -! max_digits = 20 ! bits_kind == int64 +! max_digits = 19 ! bits_kind == int64 integer(bits_kind), parameter :: & overflow_bits = 2_bits_kind**30/5 ! bits_kind == int32 @@ -2128,7 +2128,7 @@ contains case( read_failure ) error stop "A failure occurred in a READ statement." case( write_failure ) - error stop "A failure occurRed on a WRITE statement." + error stop "A failure occurred on a WRITE statement." end select end if end subroutine error_handler diff --git a/src/stdlib_bitsets_64.fypp b/src/stdlib_bitsets_64.fypp index e86691c8d..3cdd0b17a 100644 --- a/src/stdlib_bitsets_64.fypp +++ b/src/stdlib_bitsets_64.fypp @@ -646,7 +646,6 @@ contains digits = digits + 1 if ( digits == max_digits .AND. bits > overflow_bits ) & go to 996 -!! May not be quite right if ( digits > max_digits ) go to 996 bits = bits*10 + iachar( string(pos:pos) ) - ia0 if ( bits < 0 ) go to 996 @@ -779,7 +778,6 @@ contains digits = digits + 1 if ( digits == max_digits .AND. bits > overflow_bits ) & go to 996 -!! May not be quite right if ( digits > max_digits ) go to 996 bits = 10*bits + iachar(char) - iachar('0') if ( bits < 0 ) go to 996 diff --git a/src/stdlib_bitsets_large.fypp b/src/stdlib_bitsets_large.fypp index 0d4627c46..2bcd1c659 100644 --- a/src/stdlib_bitsets_large.fypp +++ b/src/stdlib_bitsets_large.fypp @@ -835,7 +835,6 @@ contains case(ia0:ia9) digits = digits + 1 if ( digits == max_digits .AND. bits > overflow_bits ) go to 996 -!! May not be quite right if ( digits > max_digits ) go to 996 bits = bits*10 + iachar( string(pos:pos) ) - ia0 if ( bits < 0 ) go to 996 From 20a15e51f54ee5c81169f363b355893d5dafbb10 Mon Sep 17 00:00:00 2001 From: William Clodius Date: Tue, 20 Oct 2020 20:18:47 -0600 Subject: [PATCH 48/53] Numerous changes suggested by Jeremie Jeremie suggested numerous changes. I implemented most of them. [ticket: X] --- src/tests/bitsets/test_stdlib_bitset_64.f90 | 76 ++++++++++--------- .../bitsets/test_stdlib_bitset_large.f90 | 50 +++++++++++- 2 files changed, 89 insertions(+), 37 deletions(-) diff --git a/src/tests/bitsets/test_stdlib_bitset_64.f90 b/src/tests/bitsets/test_stdlib_bitset_64.f90 index 8d1778695..fd92d458d 100644 --- a/src/tests/bitsets/test_stdlib_bitset_64.f90 +++ b/src/tests/bitsets/test_stdlib_bitset_64.f90 @@ -28,9 +28,8 @@ program test_stdlib_bitset_64 subroutine test_string_operations() character(*), parameter:: procedure = 'TEST_STRING_OPERATIONS' - write(*,*) - write(*,*) 'Test string operations: from_string, read_bitset, ' // & - 'to_string, and write_bitset' + write(*,'(/a)') 'Test string operations: from_string, ' // & + 'read_bitset, to_string, and write_bitset' call set0 % from_string( bitstring_0 ) if ( bits(set0) /= 33 ) then @@ -67,6 +66,9 @@ subroutine test_string_operations() call set3 % read_bitset( bitstring_0, status ) if ( status /= success ) then write(*,*) 'read_bitset_string failed with bitstring_0 as expected.' + else + error stop procedure // ' read_bitset_string did not fail ' // & + 'with bitstring_0 as expected.' end if call set3 % read_bitset( 's33b' // bitstring_0, status ) @@ -209,6 +211,27 @@ subroutine test_io() 'output and input succeeded.' end if + open( newunit=unit, file='test.bin', status='replace', & + form='unformatted', access='stream', action='write' ) + call set2 % output(unit) + call set1 % output(unit) + call set0 % output(unit) + close( unit ) + open( newunit=unit, file='test.bin', status='old', & + form='unformatted', access='stream', action='read' ) + call set5 % input(unit) + call set4 % input(unit) + call set3 % input(unit) + close( unit ) + + if ( set3 /= set0 .or. set4 /= set1 .or. set5 /= set2 ) then + error stop procedure // ' transfer to and from units using ' // & + ' stream output and input failed.' + else + write(*,*) 'Transfer to and from units using ' // & + 'stream output and input succeeded.' + end if + end subroutine test_io subroutine test_initialization() @@ -404,56 +427,41 @@ subroutine test_bitset_inquiry() call set0 % not() do i=0, set0 % bits() - 1 - if ( set0 % test(i) ) go to 100 + if ( set0 % test(i) ) then + error stop procedure // ' against expectations set0 has ' // & + 'at least 1 bit set.' + end if end do write(*,*) 'As expected set0 had no bits set.' - go to 110 - -100 error stop procedure // ' against expectations set0 has ' // & - 'at least 1 bit set.' - -110 continue - do i=0, set1 % bits() - 1 - if ( .not. set1 % test(i) ) go to 200 + if ( .not. set1 % test(i) ) then + error stop procedure // ' against expectations set1 has ' // & + 'at least 1 bit unset.' + end if end do write(*,*) 'As expected set1 had all bits set.' - go to 210 - -200 error stop procedure // ' against expectations set1 has ' // & - 'at least 1 bit unset.' -210 continue - do i=0, set0 % bits() - 1 - if ( set0 % value(i) /= 0 ) go to 300 + if ( set0 % value(i) /= 0 ) then + error stop procedure // ' against expectations set0 has ' // & + 'at least 1 bit set.' + end if end do write(*,*) 'As expected set0 had no bits set.' - go to 310 - -300 error stop procedure // ' against expectations set0 has ' // & - 'at least 1 bit set.' - -310 continue - do i=0, set1 % bits() - 1 - if ( set1 % value(i) /= 1 ) go to 400 + if ( set1 % value(i) /= 1 ) then + error stop procedure // ' against expectations set1 has ' // & + 'at least 1 bit unset.' + end if end do write(*,*) 'As expected set1 had all bits set.' - go to 410 - -400 error stop procedure // ' against expectations set1 has ' // & - 'at least 1 bit unset.' - -410 continue - if ( set0 % bits() == 33 ) then write(*,*) 'set0 has 33 bits as expected.' else diff --git a/src/tests/bitsets/test_stdlib_bitset_large.f90 b/src/tests/bitsets/test_stdlib_bitset_large.f90 index 7785d268a..fd9d901b0 100644 --- a/src/tests/bitsets/test_stdlib_bitset_large.f90 +++ b/src/tests/bitsets/test_stdlib_bitset_large.f90 @@ -30,9 +30,8 @@ program test_stdlib_bitset_large subroutine test_string_operations() character(*), parameter:: procedure = 'TEST_STRING_OPERATIONS' - write(*,*) - write(*,*) 'Test string operations: from_string, read_bitset, ' // & - 'to_string, and write_bitset' + write(*,'(/a)') 'Test string operations: from_string, ' // & + 'read_bitset, to_string, and write_bitset' call set0 % from_string( bitstring_0 ) if ( bits(set0) /= 33 ) then @@ -101,6 +100,9 @@ subroutine test_string_operations() call set3 % read_bitset( bitstring_0, status ) if ( status /= success ) then write(*,*) 'read_bitset_string failed with bitstring_0 as expected.' + else + error stop procedure // ' read_bitset_string did not fail ' // & + 'with bitstring_0 as expected.' end if call set13 % read_bitset( bitstring_0 // bitstring_0, status ) @@ -358,6 +360,27 @@ subroutine test_io() close( unit ) + open( newunit=unit, file='test.bin', status='replace', & + form='unformatted', access='stream', action='write' ) + call set2 % output(unit) + call set1 % output(unit) + call set0 % output(unit) + close( unit ) + open( newunit=unit, file='test.bin', status='old', & + form='unformatted', access='stream', action='read' ) + call set5 % input(unit) + call set4 % input(unit) + call set3 % input(unit) + if ( set3 /= set0 .or. set4 /= set1 .or. set5 /= set2 ) then + error stop procedure // ' transfer to and from units using ' // & + ' stream output and input failed.' + else + write(*,*) 'Transfer to and from units using ' // & + 'stream output and input succeeded.' + end if + + close( unit ) + open( newunit=unit, file='test.bin', status='replace', & form='unformatted', action='write' ) call set12 % output(unit) @@ -376,6 +399,27 @@ subroutine test_io() write(*,*) 'Transfer to and from units using ' // & 'output and input succeeded for bits > 64.' end if + close(unit) + + open( newunit=unit, file='test.bin', status='replace', & + form='unformatted', access='stream', action='write' ) + call set12 % output(unit) + call set11 % output(unit) + call set10 % output(unit) + close( unit ) + open( newunit=unit, file='test.bin', status='old', & + form='unformatted', access='stream', action='read' ) + call set15 % input(unit) + call set14 % input(unit) + call set13 % input(unit) + if ( set13 /= set10 .or. set14 /= set11 .or. set15 /= set12 ) then + error stop procedure // ' transfer to and from units using ' // & + ' stream output and input failed for bits . 64.' + else + write(*,*) 'Transfer to and from units using ' // & + 'stream output and input succeeded for bits > 64.' + end if + close(unit) end subroutine test_io From 57faccd5272b01ad1977257a779ecd0d0dfd9aa9 Mon Sep 17 00:00:00 2001 From: William Clodius Date: Tue, 20 Oct 2020 20:31:24 -0600 Subject: [PATCH 49/53] Replaced go tos At the suggestion of Jeremie I replaced a number of go tos. [ticket: X] --- .../bitsets/test_stdlib_bitset_large.f90 | 48 +++++++------------ 1 file changed, 16 insertions(+), 32 deletions(-) diff --git a/src/tests/bitsets/test_stdlib_bitset_large.f90 b/src/tests/bitsets/test_stdlib_bitset_large.f90 index fd9d901b0..5d6dfe06d 100644 --- a/src/tests/bitsets/test_stdlib_bitset_large.f90 +++ b/src/tests/bitsets/test_stdlib_bitset_large.f90 @@ -766,57 +766,41 @@ subroutine test_bitset_inquiry() call set0 % not() do i=0, set0 % bits() - 1 - if ( set0 % test(i) ) go to 100 + if ( set0 % test(i) ) then + error stop procedure // ' against expectations set0 has ' // & + 'at least 1 bit set.' + end if end do write(*,*) 'As expected set0 had no bits set.' - go to 110 - -100 error stop procedure // ' against expectations set0 has ' // & - 'at least 1 bit set.' - -110 continue - do i=0, set1 % bits() - 1 - if ( .not. set1 % test(i) ) go to 200 + if ( .not. set1 % test(i) ) then + error stop procedure // ' against expectations set0 has ' // & + 'at least 1 bit unset.' + end if end do write(*,*) 'As expected set1 had all bits set.' - go to 210 - -200 error stop procedure // ' against expectations set0 has ' // & - 'at least 1 bit unset.' - -210 continue - do i=0, set0 % bits() - 1 - if ( set0 % value(i) /= 0 ) go to 300 + if ( set0 % value(i) /= 0 ) then + error stop procedure // ' against expectations set0 has ' // & + 'at least 1 bit set.' + end if end do write(*,*) 'As expected set0 had no bits set.' - go to 310 - -300 error stop procedure // ' against expectations set0 has ' // & - 'at least 1 bit set.' - -310 continue - do i=0, set1 % bits() - 1 - if ( set1 % value(i) /= 1 ) go to 400 + if ( set1 % value(i) /= 1 ) then + error stop procedure // ' against expectations set0 has ' // & + 'at least 1 bit unset.' + end if end do write(*,*) 'As expected set1 had all bits set.' - go to 410 - -400 error stop procedure // ' against expectations set0 has ' // & - 'at least 1 bit unset.' - -410 continue - if ( set0 % bits() == 33 ) then write(*,*) 'set0 has 33 bits as expected.' else From 9c03d16e1077706959a70854dfe1dd01312b0893 Mon Sep 17 00:00:00 2001 From: William Clodius Date: Wed, 21 Oct 2020 07:26:41 -0600 Subject: [PATCH 50/53] Replaced go tos Kreplaced go tos at the suggestion of Jeremie. [ticket: X] --- .../bitsets/test_stdlib_bitset_large.f90 | 48 +++++++------------ 1 file changed, 16 insertions(+), 32 deletions(-) diff --git a/src/tests/bitsets/test_stdlib_bitset_large.f90 b/src/tests/bitsets/test_stdlib_bitset_large.f90 index 5d6dfe06d..96d83d036 100644 --- a/src/tests/bitsets/test_stdlib_bitset_large.f90 +++ b/src/tests/bitsets/test_stdlib_bitset_large.f90 @@ -851,57 +851,41 @@ subroutine test_bitset_inquiry() call set10 % not() do i=0, set10 % bits() - 1 - if ( set10 % test(i) ) go to 500 + if ( set10 % test(i) ) then + error stop procedure // ' against expectations set10 has ' // & + 'at least 1 bit set.' + end if end do write(*,*) 'As expected set10 had no bits set.' - go to 510 - -500 error stop procedure // ' against expectations set10 has ' // & - 'at least 1 bit set.' - -510 continue - do i=0, set11 % bits() - 1 - if ( .not. set11 % test(i) ) go to 600 + if ( .not. set11 % test(i) ) then + error stop procedure // ' against expectations set11 has ' // & + 'at least 1 bit unset.' + end if end do write(*,*) 'As expected set11 had all bits set.' - go to 610 - -600 error stop procedure // ' against expectations set11 has ' // & - 'at least 1 bit unset.' - -610 continue - do i=0, set10 % bits() - 1 - if ( set10 % value(i) /= 0 ) go to 700 + if ( set10 % value(i) /= 0 ) then + error stop procedure // ' against expectations set10 has ' // & + 'at least 1 bit set.' + end if end do write(*,*) 'As expected set10 had no bits set.' - go to 710 - -700 error stop procedure // ' against expectations set10 has ' // & - 'at least 1 bit set.' - -710 continue - do i=0, set11 % bits() - 1 - if ( set11 % value(i) /= 1 ) go to 800 + if ( set11 % value(i) /= 1 ) then + error stop procedure // ' against expectations set11 has ' // & + 'at least 1 bit unset.' + end if end do write(*,*) 'As expected set11 had all bits set.' - go to 810 - -800 error stop procedure // ' against expectations set11 has ' // & - 'at least 1 bit unset.' - -810 continue - if ( set0 % bits() == 33 ) then write(*,*) 'set0 has 33 bits as expected.' else From 5c2779dc4ab3c2092bda0fe24eb94dcd9d3e62a4 Mon Sep 17 00:00:00 2001 From: William Clodius Date: Sun, 25 Oct 2020 18:08:21 -0600 Subject: [PATCH 51/53] Documented the "named" form for the comparison operations Documented the use of the "named" forms, .EQ., .NE., .GT., .GE., .LT., .LE., as alternatives to the symbolic forms, ==, /=, >, >=, <, <= of the comparison operations. [ticket: X] --- doc/specs/stdlib_bitsets.md | 37 +++++++++++++++++++++++++++++++------ 1 file changed, 31 insertions(+), 6 deletions(-) diff --git a/doc/specs/stdlib_bitsets.md b/doc/specs/stdlib_bitsets.md index 08e0fc8d0..2f5561b03 100644 --- a/doc/specs/stdlib_bitsets.md +++ b/doc/specs/stdlib_bitsets.md @@ -238,12 +238,12 @@ are summarized in the following table: |Operator|Description| |--------|-----------| -|`==`|`.true.` if all bits in `set1` and `set2` have the same value, `.false.` otherwise| -|`/=`|`.true.` if any bits in `set1` and `set2` differ in value, `.false.` otherwise| -|`>`|`.true.` if the bits in `set1` and `set2` differ in value and the highest order differing bit is 1 in `set1` and 0 in `set2`, `.false.` otherwise| -|`>=`|`.true.` if the bits in `set1` and `set2` are the same or the highest order differing bit is 1 in `set1` and 0 in `set2`, `.false.` otherwise| -|`<`|`.true.` if the bits in `set1` and `set2` differ in value and the highest order differing bit is 0 in `set1` and 1 in `set2`, `.false.` otherwise| -|`<=`|`.true.` if the bits in `set1` and `set2` are the same or the highest order differing bit is 0 in `set1` and 1 in `set2`, `.false.` otherwise| +|`==`, `.EQ.`|`.true.` if all bits in `set1` and `set2` have the same value, `.false.` otherwise| +|`/=`, `.NE.`|`.true.` if any bits in `set1` and `set2` differ in value, `.false.` otherwise| +|`>`, `.GT.`|`.true.` if the bits in `set1` and `set2` differ in value and the highest order differing bit is 1 in `set1` and 0 in `set2`, `.false.` otherwise| +|`>=`, `.GE.`|`.true.` if the bits in `set1` and `set2` are the same or the highest order differing bit is 1 in `set1` and 0 in `set2`, `.false.` otherwise| +|`<`, `.LT.`|`.true.` if the bits in `set1` and `set2` differ in value and the highest order differing bit is 0 in `set1` and 1 in `set2`, `.false.` otherwise| +|`<=`, `.LE.`|`.true.` if the bits in `set1` and `set2` are the same or the highest order differing bit is 0 in `set1` and 1 in `set2`, `.false.` otherwise| ## Specification of the `stdlib_bitsets` methods and procedures @@ -1646,6 +1646,11 @@ Returns `.true.` if all bits in `set1` and `set2` have the same value, `result = set1 [[stdlib_bitsets(module):==(interface)]] set2 +or + +`result = set1 [[stdlib_bitsets(module):.EQ.(interface)]] set2 + + #### Class Elemental operator @@ -1702,6 +1707,10 @@ Returns `.true.` if any bits in `self` and `set2` differ in value, `result = set1 [[stdlib_bitsets(module):/=(interface)]] set2` +or + +`result = set1 [[stdlib_bitsets(module):.NE.(interface)]] set2` + #### Class Elemental function @@ -1760,6 +1769,10 @@ results are undefined `result = set1 [[stdlib_bitsets(module):>=(interface)]] set2` +or + +`result = set1 [[stdlib_bitsets(module):.GE.(interface)]] set2` + #### Class Elemental operator @@ -1819,6 +1832,10 @@ results are undefined `result = set1 [[stdlib_bitsets(module):>(interface)]] set2` +or + +`result = set1 [[stdlib_bitsets(module):.GT.(interface)]] set2` + #### Class Elemental operator @@ -1878,6 +1895,10 @@ results are undefined `result = set1 [[stdlib_bitsets(module):<=(interface)]] set2` +or + +`result = set1 [[stdlib_bitsets(module):.LE.(interface)]] set2` + #### Class Elemental operator @@ -1938,6 +1959,10 @@ results are undefined `result = set1 [[stdlib_bitsets(module):<(interface)]] set2` +or + +`result = set1 [[stdlib_bitsets(module):.LT.(interface)]] set2 + #### Class Elemental operator From 99fa3825e63b8c44cf2285871cc18399fb4e0ab7 Mon Sep 17 00:00:00 2001 From: milancurcic Date: Fri, 13 Nov 2020 13:37:58 -0500 Subject: [PATCH 52/53] typography fixes --- doc/specs/stdlib_bitsets.md | 69 +++++++++++++++++-------------------- 1 file changed, 32 insertions(+), 37 deletions(-) diff --git a/doc/specs/stdlib_bitsets.md b/doc/specs/stdlib_bitsets.md index 2f5561b03..452bdb918 100644 --- a/doc/specs/stdlib_bitsets.md +++ b/doc/specs/stdlib_bitsets.md @@ -21,7 +21,7 @@ defines three bitset types, multiple constants, a character string literal that can be read to and from strings and formatted files, a simple character string literal that can be read to and from strings, assignments, procedures, methods, and operators. Note that the module -assumes two's complement integers, but all current Fortran 95+ +assumes two's complement integers, but all current Fortran 95 and later processors use such integers. Note that the module defines a number of "binary" procedures, @@ -64,7 +64,7 @@ bits. The other constants that are error codes are summarized below: The `stdlib_bitsets` module defines three derived types, `bitset_type`, `bitset_64`, and `bitset_large`. `bitset_type` is an abstract type that serves as the ancestor of `bitset_64` and -`bitset_large`. `bitset_type` defines one method, `bits`, all of its +`bitset_large`. `bitset_type` defines one method, `bits`, and all of its other methods are deferred to its extensions. `bitset_64` is a bitset that can handle up to 64 bits. `bitset_large` is a bitset that can handle up `huge(0_bits_kind)` bits. All attributes of the bitset types are @@ -238,12 +238,12 @@ are summarized in the following table: |Operator|Description| |--------|-----------| -|`==`, `.EQ.`|`.true.` if all bits in `set1` and `set2` have the same value, `.false.` otherwise| -|`/=`, `.NE.`|`.true.` if any bits in `set1` and `set2` differ in value, `.false.` otherwise| -|`>`, `.GT.`|`.true.` if the bits in `set1` and `set2` differ in value and the highest order differing bit is 1 in `set1` and 0 in `set2`, `.false.` otherwise| -|`>=`, `.GE.`|`.true.` if the bits in `set1` and `set2` are the same or the highest order differing bit is 1 in `set1` and 0 in `set2`, `.false.` otherwise| -|`<`, `.LT.`|`.true.` if the bits in `set1` and `set2` differ in value and the highest order differing bit is 0 in `set1` and 1 in `set2`, `.false.` otherwise| -|`<=`, `.LE.`|`.true.` if the bits in `set1` and `set2` are the same or the highest order differing bit is 0 in `set1` and 1 in `set2`, `.false.` otherwise| +|`==`, `.eq.`|`.true.` if all bits in `set1` and `set2` have the same value, `.false.` otherwise| +|`/=`, `.ne.`|`.true.` if any bits in `set1` and `set2` differ in value, `.false.` otherwise| +|`>`, `.gt.`|`.true.` if the bits in `set1` and `set2` differ in value and the highest order differing bit is 1 in `set1` and 0 in `set2`, `.false.` otherwise| +|`>=`, `.ge.`|`.true.` if the bits in `set1` and `set2` are the same or the highest order differing bit is 1 in `set1` and 0 in `set2`, `.false.` otherwise| +|`<`, `.lt.`|`.true.` if the bits in `set1` and `set2` differ in value and the highest order differing bit is 0 in `set1` and 1 in `set2`, `.false.` otherwise| +|`<=`, `.le.`|`.true.` if the bits in `set1` and `set2` are the same or the highest order differing bit is 0 in `set1` and 1 in `set2`, `.false.` otherwise| ## Specification of the `stdlib_bitsets` methods and procedures @@ -256,7 +256,7 @@ Experimental #### Description -Determines whether all bits are set to 1 in self. +Determines whether all bits are set to 1 in `self`. #### Syntax @@ -744,7 +744,7 @@ Subroutine #### Arguments -`self`: shall be a scalar class `bitset_type` variable. It is an +`self`: shall be a scalar class `bitset_type` variable. It is an `intent(out)` argument. `string`: shall be a scalar default character expression. It is an @@ -871,8 +871,8 @@ Subroutine `unit`: shall be a scalar default integer expression. It is an `intent(in)` argument. Its value must be that of a logical unit -number for an open unformatted file with `READ` or `READWRITE` -access positioned at the start of a BITSET value written by a +number for an open unformatted file with `read` or `readwrite` +access positioned at the start of a bitset value written by a `bitset_type` `output` subroutine by the same processor. `status` (optional): shall be a scalar default integer variable. If @@ -997,8 +997,8 @@ Elemental subroutine. #### Argument `self` shall be a scalar variable of class `bitset_type`. It is an - `intent(inout)` argument. On return its bits shall be the logical - complement of their values on input. +`intent(inout)` argument. On return its bits shall be the logical +complement of their values on input. #### Example @@ -1041,9 +1041,9 @@ Elemental subroutine. #### Arguments `set1`: shall be a scalar `bitset_64` or `bitset_large` variable. It - is an `intent(inout)` argument. On return the values of the bits in - `setf` are the bitwise `or` of the original bits in `set1` with the - corresponding bits in `set2`. +is an `intent(inout)` argument. On return the values of the bits in +`setf` are the bitwise `or` of the original bits in `set1` with the +corresponding bits in `set2`. `set2`: shall be a scalar expression of the same type as `set1`. It is an `intent(in)` argument. Note `bits(set2)` must equal `bits(set1)` @@ -1097,7 +1097,7 @@ Subroutine. `unit`: shall be a scalar default integer expression. It is an `intent(in)` argument. Its value must be that of an I/O unit number -for an open unformatted file with `WRITE` or `READWRITE` access. +for an open unformatted file with `write` or `readwrite` access. `status` (optional): shall be a scalar default integer variable. It is an `intent(out)` argument. If present on return it will have the value @@ -1182,7 +1182,7 @@ or a blank. `unit` (optional): shall be a scalar default integer expression. It is an `intent(in)` argument. Its value must be that of an I/O unit number -for an open formatted file with `READ` or `READWRITE` access +for an open formatted file with `read` or `readwrite` access positioned at the start of a *bitset-literal*. `advance` (optional): shall be a scalar default character @@ -1394,7 +1394,7 @@ Subroutine `intent(in)` argument. `string`: shall be a scalar default character variable of allocatable -length. It is an `intent(out)` argument. On return it shall hav a +length. It is an `intent(out)` argument. On return it shall have a *binary-literal* representation of the bitset `self`. `status` (optional): shall be a scalar default integer variable. It is @@ -1644,12 +1644,11 @@ Returns `.true.` if all bits in `set1` and `set2` have the same value, #### Syntax -`result = set1 [[stdlib_bitsets(module):==(interface)]] set2 +`result = set1 [[stdlib_bitsets(module):==(interface)]] set2` or -`result = set1 [[stdlib_bitsets(module):.EQ.(interface)]] set2 - +`result = set1 [[stdlib_bitsets(module):.EQ.(interface)]] set2` #### Class @@ -1668,7 +1667,7 @@ argument. The result is a default logical scalar. The result is `.true.` if the bits in both bitsets are set -to the same value, otherwise the result is `.FALSE.`. +to the same value, otherwise the result is `.false.`. #### Example @@ -1702,7 +1701,6 @@ Experimental Returns `.true.` if any bits in `self` and `set2` differ in value, `.false.` otherwise. - #### Syntax `result = set1 [[stdlib_bitsets(module):/=(interface)]] set2` @@ -1762,8 +1760,7 @@ Experimental Returns `.true.` if the bits in `set1` and `set2` are the same or the highest order different bit is set to 1 in `set1` and to 0 in `set2`, `.false.`. otherwise. The sets must be the same size otherwise the -results are undefined - +results are undefined. #### Syntax @@ -1825,8 +1822,8 @@ Experimental Returns `.true.` if the bits in `set1` and `set2` differ and the highest order different bit is set to 1 in `set1` and to 0 in `set2`, -`.false.` otherwise. The sets must be the same size otherwise the -results are undefined +`.false.` otherwise. The sets must be the same size otherwise the +results are undefined. #### Syntax @@ -1854,7 +1851,7 @@ argument. The result is a default logical scalar. The result is `.true.` if the bits in `set1` and `set2` differ and the highest order different bit is set to 1 in `set1` and to 0 in `set2`, -`.false.`. otherwise. +`.false.` otherwise. #### Example @@ -1887,9 +1884,8 @@ Experimental Returns `.true.` if the bits in `set1` and `set2` are the same or the highest order different bit is set to 0 in `set1` and to 1 in `set2`, -`.false.` otherwise. The sets must be the same size otherwise the -results are undefined - +`.false.` otherwise. The sets must be the same size otherwise the +results are undefined. #### Syntax @@ -1917,7 +1913,7 @@ argument. The result is a default logical scalar. The result is `.true.` if the bits in `set1` and `set2` are the same or the highest order different bit is set to 0 in `set1` and to 1 in -`set2`, `.false.` otherwise. +`set2`, `.false.` otherwise. #### Example @@ -1952,8 +1948,7 @@ Experimental Returns `.true.` if the bits in `set1` and `set2` differ and the highest order different bit is set to 0 in `set1` and to 1 in `set2`, `.false.` otherwise. The sets must be the same size otherwise the -results are undefined - +results are undefined. #### Syntax @@ -1981,7 +1976,7 @@ argument. The result is a default logical scalar. The result is `.true.` if the bits in `set1` and `set2` differ and the highest order different bit is set to 0 in `set1` and to 1 in `set2`, -`.false.` otherwise. +`.false.` otherwise. #### Example From acb7cdbe62615f9725b15aa2abacbefcd81c62ed Mon Sep 17 00:00:00 2001 From: milancurcic Date: Fri, 13 Nov 2020 14:10:54 -0500 Subject: [PATCH 53/53] add example to the first paragraph --- doc/specs/stdlib_bitsets.md | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/doc/specs/stdlib_bitsets.md b/doc/specs/stdlib_bitsets.md index 452bdb918..ea8ddb2a7 100644 --- a/doc/specs/stdlib_bitsets.md +++ b/doc/specs/stdlib_bitsets.md @@ -11,10 +11,11 @@ title: Bitsets The `stdlib_bitsets` module implements bitset types. A bitset is a compact representation of a sequence of `bits` binary values. It can equivalently be considered as a sequence of logical values or as a -subset of the integers 0 ... `bits-1`. The bits are indexed from 0 to -`bits(bitset)-1`. A bitset is used when space savings are critical in -applications that require a large number -of closely related logical values. +subset of the integers 0 ... `bits-1`. For example, the value `1110` +can be considered as defining the subset of integers [1, 2, 3]. +The bits are indexed from 0 to `bits(bitset)-1`. +A bitset is used when space savings are critical in applications +that require a large number of closely related logical values. It may also improve performance by reducing memory traffic. To implement bitsets the module defines three bitset types, multiple constants, a character string