From 3bc0a8beadddd3bb719389567e94ad8a98924b34 Mon Sep 17 00:00:00 2001 From: Milan Curcic Date: Sun, 22 Nov 2020 13:15:55 -0500 Subject: [PATCH] Revert "Bitsets3" --- doc/specs/index.md | 1 - doc/specs/stdlib_bitsets.md | 2001 --------------- src/CMakeLists.txt | 3 - src/Makefile.manual | 9 - src/stdlib_bitsets.fypp | 2137 ----------------- src/stdlib_bitsets_64.fypp | 1122 --------- src/stdlib_bitsets_large.fypp | 1347 ----------- src/tests/CMakeLists.txt | 1 - src/tests/Makefile.manual | 3 - src/tests/bitsets/CMakeLists.txt | 3 - src/tests/bitsets/Makefile.manual | 3 - src/tests/bitsets/test_stdlib_bitset_64.f90 | 752 ------ .../bitsets/test_stdlib_bitset_large.f90 | 1488 ------------ 13 files changed, 8870 deletions(-) delete mode 100644 doc/specs/stdlib_bitsets.md delete mode 100644 src/stdlib_bitsets.fypp delete mode 100644 src/stdlib_bitsets_64.fypp delete mode 100644 src/stdlib_bitsets_large.fypp delete mode 100644 src/tests/bitsets/CMakeLists.txt delete mode 100644 src/tests/bitsets/Makefile.manual delete mode 100644 src/tests/bitsets/test_stdlib_bitset_64.f90 delete mode 100644 src/tests/bitsets/test_stdlib_bitset_large.f90 diff --git a/doc/specs/index.md b/doc/specs/index.md index c10818fa9..91284c2df 100644 --- a/doc/specs/index.md +++ b/doc/specs/index.md @@ -11,7 +11,6 @@ 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 deleted file mode 100644 index ea8ddb2a7..000000000 --- a/doc/specs/stdlib_bitsets.md +++ /dev/null @@ -1,2001 +0,0 @@ ---- -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 02604959e..ea7403663 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -2,9 +2,6 @@ # 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 872f704c0..1c731b9bb 100644 --- a/src/Makefile.manual +++ b/src/Makefile.manual @@ -1,8 +1,5 @@ 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 \ @@ -43,9 +40,6 @@ 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 \ @@ -69,9 +63,6 @@ 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 deleted file mode 100644 index 881a7bd2c..000000000 --- a/src/stdlib_bitsets.fypp +++ /dev/null @@ -1,2137 +0,0 @@ -#: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 deleted file mode 100644 index 3cdd0b17a..000000000 --- a/src/stdlib_bitsets_64.fypp +++ /dev/null @@ -1,1122 +0,0 @@ -#: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 deleted file mode 100644 index 2bcd1c659..000000000 --- a/src/stdlib_bitsets_large.fypp +++ /dev/null @@ -1,1347 +0,0 @@ -#: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 c3b09e34d..9e341d380 100644 --- a/src/tests/CMakeLists.txt +++ b/src/tests/CMakeLists.txt @@ -7,7 +7,6 @@ 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 89325cd56..9b0227232 100644 --- a/src/tests/Makefile.manual +++ b/src/tests/Makefile.manual @@ -2,7 +2,6 @@ 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 @@ -11,7 +10,6 @@ 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 @@ -20,7 +18,6 @@ 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 deleted file mode 100644 index 519015e20..000000000 --- a/src/tests/bitsets/CMakeLists.txt +++ /dev/null @@ -1,3 +0,0 @@ -ADDTEST(stdlib_bitset_64) -ADDTEST(stdlib_bitset_large) - diff --git a/src/tests/bitsets/Makefile.manual b/src/tests/bitsets/Makefile.manual deleted file mode 100644 index 0ecba442e..000000000 --- a/src/tests/bitsets/Makefile.manual +++ /dev/null @@ -1,3 +0,0 @@ -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 deleted file mode 100644 index fd92d458d..000000000 --- a/src/tests/bitsets/test_stdlib_bitset_64.f90 +++ /dev/null @@ -1,752 +0,0 @@ -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 deleted file mode 100644 index 96d83d036..000000000 --- a/src/tests/bitsets/test_stdlib_bitset_large.f90 +++ /dev/null @@ -1,1488 +0,0 @@ -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