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 diff --git a/doc/specs/stdlib_bitsets.md b/doc/specs/stdlib_bitsets.md new file mode 100644 index 000000000..ea8ddb2a7 --- /dev/null +++ b/doc/specs/stdlib_bitsets.md @@ -0,0 +1,2001 @@ +--- +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 `bits` binary values. It can +equivalently be considered as a sequence of logical values or as a +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 +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 and later +processors use such integers. + +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 +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 + +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 +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 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`)| +|`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`, 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 +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 +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` + +`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: +* "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`. + +Each category will be discussed separately. + +### 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`| + + +### 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 +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| +|--------|-----------| +|`==`, `.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 + +### `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 value + +The result is a default logical scalar. +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 ( .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 value + +The result is a default logical scalar. 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 value + +The result is an integer scalar of kind `bits_kind`, +equal to 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 value + +The result is an integer scalar of kind `bits_kind`, equal to +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. 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 + +```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 value + +The result is a default logical scalar. +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 + +`call 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 +same 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 occurred 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 found; + +* `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; + +* `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)`; or + +* `read_failure` - if a read statement failed. + +#### 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 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.`. + +#### 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 have 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 + +Experimental + +#### 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 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. + +#### 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` + +or + +`result = set1 [[stdlib_bitsets(module):.EQ.(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 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.`. + +#### 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` + +or + +`result = set1 [[stdlib_bitsets(module):.NE.(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 value + +The result is a default logical scalar. +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` + +or + +`result = set1 [[stdlib_bitsets(module):.GE.(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 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. + +#### 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` + +or + +`result = set1 [[stdlib_bitsets(module):.GT.(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 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. + +#### 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` + +or + +`result = set1 [[stdlib_bitsets(module):.LE.(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 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. + +#### 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` + +or + +`result = set1 [[stdlib_bitsets(module):.LT.(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 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. + +#### 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 +``` diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index ea7403663..02604959e 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_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 1c731b9bb..872f704c0 100644 --- a/src/Makefile.manual +++ b/src/Makefile.manual @@ -1,5 +1,8 @@ SRC = f18estop.f90 \ stdlib_ascii.f90 \ + stdlib_bitsets.f90 \ + stdlib_bitsets_64.f90 \ + stdlib_bitsets_large.f90 \ stdlib_error.f90 \ stdlib_io.f90 \ stdlib_kinds.f90 \ @@ -40,6 +43,9 @@ 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 stdlib_io.o: \ stdlib_error.o \ @@ -63,6 +69,9 @@ stdlib_stats_var.o: \ stdlib_stats.o # Fortran sources that are built from fypp templates +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 stdlib_linalg_diag.f90: stdlib_linalg_diag.fypp diff --git a/src/stdlib_bitsets.fypp b/src/stdlib_bitsets.fypp new file mode 100644 index 000000000..881a7bd2c --- /dev/null +++ b/src/stdlib_bitsets.fypp @@ -0,0 +1,2137 @@ +#: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 :: stdlib_kinds, only: & + bits_kind => int32, & ! If changed change also max_digits, and + block_kind => int64, & ! overflow_bits + int8, & + int16, & + int32, & + int64 + + use, intrinsic :: & + iso_fortran_env, only: & + error_unit + + implicit none + + private + + 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 = 19 ! 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'), & + 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_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 :: 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 = 8 +!! Error flag indicating integer overflow + integer, parameter, public :: read_failure = 9 +!! Error flag indicating failure of a READ statement + integer, parameter, public :: write_failure = 10 +!! 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 + + public :: error_handler + + 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` - 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 +!! +!!```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` +!! 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 +!! +!!```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 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 +!! +!!```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 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 +!! +!!```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 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 + 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` - 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 + 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` +!! 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 + 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 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 + 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 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 + 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 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 + 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` 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 + 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` +!! 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`. + 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 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 + 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 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 + 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 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 + 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(${k1}$)` 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(${k1}$)` 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 must 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(<=) + + 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) +!! 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 + + 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 diff --git a/src/stdlib_bitsets_64.fypp b/src/stdlib_bitsets_64.fypp new file mode 100644 index 000000000..3cdd0b17a --- /dev/null +++ b/src/stdlib_bitsets_64.fypp @@ -0,0 +1,1122 @@ +#:include "common.fypp" +submodule(stdlib_bitsets) stdlib_bitsets_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_bits_kind, 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 ) 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 + 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 + + 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_bits_kind, 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` - 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 + + character(*), parameter :: procedure = 'FROM_STRING' + integer(int64) :: bit + integer(int64) :: bits + character(1) :: char + + bits = len(string, kind=int64) + 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) + if ( char == '0' ) then + call self % clear( int(bits-bit, kind=bits_kind) ) + else if ( char == '1' ) then + call self % set( int(bits-bit, kind=bits_kind) ) + else + 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 + + if ( present(status) ) status = success + + 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` +! 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 + integer, intent(out), optional :: status + + character(*), parameter :: procedure = "INIT" + + 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 + + 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 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 + 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) 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) 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) then + call error_handler( 'Failure on a READ statement for UNIT.', & + read_failure, status, module_name, procedure ) + return + end if + + if ( present(status) ) status = success + + 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 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 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 + + 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 == max_digits .AND. bits > overflow_bits ) & + 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')) + exit + case default + go to 999 + end select + + pos = pos + 1 + + end do + + 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) 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 + 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 + +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 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 + 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 == 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 + go to 999 + end select + end do + + 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.', & + array_size_invalid_error, status, & + module_name, procedure ) + return + end if + 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 call error_handler( 'Integer overflow in reading size of ' // & + 'bitset literal from UNIT.', & + read_failure, status, module_name, procedure ) + return + +997 call error_handler( 'Failure on read of UNIT.', & + read_failure, status, module_name, procedure ) + return + +998 call error_handler( 'End of File of UNIT before finishing a ' // & + 'bitset literal.', & + eof_failure, status, module_name, procedure ) + return + +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 + + + 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(block_kind) :: dummy + + if ( pos < 0 .OR. pos > self % num_bits-1 ) return + dummy = ibset( self % block, pos ) + self % block = dummy + + 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_bits_kind, 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 ) 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 + string( pos:pos ) = '1' + else + string( pos:pos ) = '0' + end if + end do + + if ( present(status) ) status = success + + 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 ) 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" + 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 + + contains + + subroutine digit_count( bits, digits ) + integer(bits_kind), intent(in) :: bits + integer(bits_kind), intent(out) :: digits + + integer(bits_kind) :: factor + + 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_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) then + call error_handler( 'Failure on a WRITE statement for UNIT.', & + write_failure, status, module_name, procedure ) + return + endif + + 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_bitsets_64 diff --git a/src/stdlib_bitsets_large.fypp b/src/stdlib_bitsets_large.fypp new file mode 100644 index 000000000..2bcd1c659 --- /dev/null +++ b/src/stdlib_bitsets_large.fypp @@ -0,0 +1,1347 @@ +#:include "common.fypp" +submodule(stdlib_bitsets) stdlib_bitsets_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_bits_kind, 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_bits_kind, 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_bits_kind, size(set1 % blocks, kind=bits_kind) + 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_bits_kind, size( set1 % blocks, kind=bits_kind ) + 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_bits_kind, size(self % blocks, kind=bits_kind) + 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_bits_kind, 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_bits_kind, 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_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 + end do + + end do + + 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 + + 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_bits_kind, 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, kind=bits_kind) + 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 ) 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 + 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_kind, 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 + + 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(bits_kind) :: 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_bits_kind, 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` - 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 + + character(*), parameter :: procedure = 'FROM_STRING' + integer(int64) :: bit + integer(int64) :: bits + character(1) :: char + + bits = len(string, kind=int64) + 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 ) + + 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-bit, kind=bits_kind) ) + else if ( char == '1' ) then + call self % set( int(bits-bit, kind=bits_kind) ) + else + 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 + + if ( present(status) ) status = success + + 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, 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 + 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, 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 + 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` +! 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 + integer, intent(out), optional :: status + + character(len=120) :: message + character(*), parameter :: procedure = "INIT" + integer :: blocks, ierr + + message = '' + 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 + 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 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 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 + 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) 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 + + call self % init(bits, stat) + 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 % blocks(:) + if (ierr /= 0) then + call error_handler( 'Failure on a READ statement for UNIT.', & + read_failure, status, module_name, procedure ) + return + end if + + if ( present(status) ) status = success + + 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, kind=bits_kind), 1_bits_kind, -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, kind=bits_kind), 1_bits_kind, -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_bits_kind, size(set1 % blocks, kind=bits_kind) + 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(bits_kind) :: block + + none = .true. + do block = 1_bits_kind, size(self % blocks, kind=bits_kind) + 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 + integer :: remaining_bits + + if ( self % num_bits == 0 ) return + full_blocks = self % num_bits / block_size + 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 + + 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, kind=bits_kind ) + 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 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 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 + + integer(bits_kind) :: bit, bits + integer(bits_kind) :: digits, pos + character(*), parameter :: procedure = "READ_BITSET" + integer :: stat + + pos = 1 + find_start: do pos=1_bits_kind, len(string, kind=bits_kind) + 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 == max_digits .AND. bits > overflow_bits ) 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')) + exit + case default + 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 + + 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) 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 + 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 + +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 call error_handler( 'There was an invalid character in STRING', & + char_string_invalid_error, status, & + module_name, procedure ) + + 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 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_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" + 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=997, & + end=998, & + 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 == 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 + go to 999 + end select + end do + + if ( bits < 0 .OR. digits == 0 .OR. digits > max_digits ) go to 999 + + 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', & + 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 call error_handler( 'Integer overflow in reading size of ' // & + 'bitset literal from UNIT.', & + read_failure, status, module_name, procedure ) + return + +997 call error_handler( 'Failure on read of UNIT.', & + read_failure, status, module_name, procedure ) + return + +998 call error_handler( 'End of File of UNIT before finishing a ' // & + 'bitset literal.', & + eof_failure, status, module_name, procedure ) + return + +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 + + + 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_bits_kind, 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 ) then + call error_handler( 'There was an allocation fault for STRING.', & + alloc_fault, status, module_name, procedure ) + return + end if + do bit=0_bits_kind, 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 + + 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 ) 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" + do bit=0_bits_kind, 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 + + contains + + subroutine digit_count( bits, digits ) + integer(bits_kind), intent(in) :: bits + integer(bits_kind), intent(out) :: digits + + integer(bits_kind) :: factor + + 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 + + + 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) then + call error_handler( 'Failure on a WRITE statement for UNIT.', & + write_failure, status, module_name, procedure ) + return + endif + + 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_bits_kind, size(set1 % blocks, kind=bits_kind) + set1 % blocks(block_) = ieor( set1 % blocks(block_), & + set2 % blocks(block_) ) + end do + + end subroutine xor_large + +end submodule stdlib_bitsets_large 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..89325cd56 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 --directory=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..fd92d458d --- /dev/null +++ b/src/tests/bitsets/test_stdlib_bitset_64.f90 @@ -0,0 +1,752 @@ +program test_stdlib_bitset_64 + use :: stdlib_kinds, 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(*,'(/a)') '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.' + 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 ) + + 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 + + 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() + 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_bits_kind, 33_bits_kind ) + 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(bits_kind) :: 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) ) 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.' + + do i=0, set1 % bits() - 1 + 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.' + + do i=0, set0 % bits() - 1 + 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.' + + do i=0, set1 % bits() - 1 + 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.' + + 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_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.' + end if + else + error stop procedure // ' did not clear the first bit in set1.' + end if + + call set1 % clear(1_bits_kind, 32_bits_kind) + 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_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.' + end if + else + error stop procedure // ' did not flip the first bit in set1.' + end if + + call set1 % flip(1_bits_kind, 32_bits_kind) + 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_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.' + end if + else + error stop procedure // ' did not set the first bit in set1.' + end if + + call set1 % set(1_bits_kind, 32_bits_kind) + 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..96d83d036 --- /dev/null +++ b/src/tests/bitsets/test_stdlib_bitset_large.f90 @@ -0,0 +1,1488 @@ +program test_stdlib_bitset_large + use :: stdlib_kinds, 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(*,'(/a)') '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.' + 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 ) + 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', 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) + 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 + 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 + + 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_bits_kind, 33_bits_kind ) + 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_bits_kind, 65_bits_kind ) + 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(bits_kind) :: 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) ) 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.' + + do i=0, set1 % bits() - 1 + 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.' + + do i=0, set0 % bits() - 1 + 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.' + + do i=0, set1 % bits() - 1 + 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.' + + 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) ) 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.' + + do i=0, set11 % bits() - 1 + 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.' + + do i=0, set10 % bits() - 1 + 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.' + + do i=0, set11 % bits() - 1 + 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.' + + 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_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.' + end if + else + error stop procedure // ' did not clear the first bit in set1.' + end if + + call set1 % clear(1_bits_kind, 32_bits_kind) + 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_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.' + end if + else + error stop procedure // ' did not flip the first bit in set1.' + end if + + call set1 % flip(1_bits_kind, 32_bits_kind) + 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_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.' + end if + else + error stop procedure // ' did not set the first bit in set1.' + end if + + call set1 % set(1_bits_kind, 32_bits_kind) + 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_bits_kind ) + call set11 % not() + if ( .not. set11 % all() ) then + error stop procedure // ' set11 is not all set.' + end if + + 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.' + end if + else + error stop procedure // ' did not clear the first bit in set11.' + end if + + 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.' + end if + else + error stop procedure // ' did not clear the last bit in set11.' + end if + + call set11 % clear(1_bits_kind, 164_bits_kind) + 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_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.' + end if + else + error stop procedure // ' did not flip the first bit in set11.' + end if + + 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.' + end if + else + error stop procedure // ' did not flip the last bit in set11.' + end if + + call set11 % flip(1_bits_kind, 164_bits_kind) + 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_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.' + end if + else + error stop procedure // ' did not set the first bit in set11.' + end if + + 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.' + end if + else + error stop procedure // ' did not set the last bit in set11.' + end if + + call set11 % set(1_bits_kind, 164_bits_kind) + 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_bits_kind) + call set11 % init(166_bits_kind) + call set11 % not() + 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. & + .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_bits_kind) + call set0 % not() + call set4 % init(166_bits_kind) + 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_bits_kind) + 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_bits_kind) + 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_bits_kind) + 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_bits_kind) + call set3 % not() + call set4 % init(166_bits_kind) + 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_bits_kind) + 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_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.' + 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