diff --git a/doc/specs/index.md b/doc/specs/index.md index de3eb8f38..c65447045 100644 --- a/doc/specs/index.md +++ b/doc/specs/index.md @@ -17,6 +17,7 @@ This is an index/directory of the specifications (specs) for each new module/fea - [constants](./stdlib_constants.html) - Constants - [bitsets](./stdlib_bitsets.html) - Bitset data types and procedures - [error](./stdlib_error.html) - Catching and handling errors + - [state_type](./stdlib_error_state_type.html) - General state and error handling - [hash](./stdlib_hash_procedures.html) - Hashing integer vectors or character strings - [hashmaps](./stdlib_hashmaps.html) - Hash maps/tables diff --git a/doc/specs/stdlib_error_state_type.md b/doc/specs/stdlib_error_state_type.md new file mode 100644 index 000000000..227ad9ed8 --- /dev/null +++ b/doc/specs/stdlib_error_state_type.md @@ -0,0 +1,59 @@ +--- +title: state_type +--- + +# State and Error Handling Derived Type + +[TOC] + +## Introduction + +The `stdlib_error` module provides a derived type holding information on the state of operations within the standard library and procedures for expert control of workflows. +An optional `state_type` variable to hold such information is provided as a form of expert API. +If the user does not require state information but fatal errors are encountered during execution, the program will undergo a hard stop. +Instead, if the state argument is present, the program will never stop but will return detailed error information into the state handler. + +## Derived types provided + + +### The `state_type` derived type + +The `state_type` is defined as a derived type containing an integer error flag and fixed-size character strings to store an error message and the location of the error state change. +Fixed-size string storage was chosen to facilitate the compiler's memory allocation and ultimately ensure maximum computational performance. + +A similarly named generic interface, `state_type`, is provided to allow the developer to create diagnostic messages and raise error flags easily. +The call starts with an error flag or the location of the event and is followed by an arbitrary list of `integer`, `real`, `complex`, or `character` variables. +Numeric variables may be provided as either scalars or rank-1 (array) inputs. + +#### Type-bound procedures + +The following convenience type-bound procedures are provided: +- `print()` returns an allocatable character string containing state location, message, and error flag; +- `print_message()` returns an allocatable character string containing the state message; +- `ok()` returns a `logical` flag that is `.true.` in case of successful state (`flag==STDLIB_SUCCESS`); +- `error()` returns a `logical` flag that is `.true.` in case of an error state (`flag/=STDLIB_SUCCESS`). + +#### Status + +Experimental + +#### Example + +```fortran +{!example/error/example_error_state1.f90!} +``` + +## Error flags provided + +The module provides the following state flags: +- `STDLIB_SUCCESS`: Successful execution +- `STDLIB_VALUE_ERROR`: Numerical errors (such as infinity, not-a-number, range bounds) are encountered. +- `STDLIB_LINALG_ERROR`: Linear Algebra errors are encountered, such as non-converging iterations, impossible operations, etc. +- `STDLIB_INTERNAL_ERROR`: Provided as a developer safeguard for internal errors that should never occur. +- `STDLIB_IO_ERROR`: Input/Output-related errors, such as file reading/writing failures. +- `STDLIB_FS_ERROR`: File system-related errors, such as directory access issues. + +## Comparison operators provided + +The module provides overloaded comparison operators for all comparisons of a `state_type` variable with an integer error flag: `<`, `<=`, `==`, `>=`, `>`, `/=`. + diff --git a/doc/specs/stdlib_linalg_state_type.md b/doc/specs/stdlib_linalg_state_type.md index 54070fe4b..4e6833bb6 100644 --- a/doc/specs/stdlib_linalg_state_type.md +++ b/doc/specs/stdlib_linalg_state_type.md @@ -8,37 +8,27 @@ title: linalg_state_type ## Introduction -The `stdlib_linalg_state` module provides a derived type holding information on the -state of linear algebra operations, and procedures for expert control of linear algebra workflows. -All linear algebra procedures are engineered to support returning an optional `linalg_state_type` -variable to holds such information, as a form of expert API. If the user does not require state -information, but fatal errors are encountered during the execution of linear algebra routines, the -program will undergo a hard stop. -Instead, if the state argument is present, the program will never stop, but will return detailed error -information into the state handler. +The `stdlib_linalg_state` module provides a derived type holding information on the state of linear algebra operations, and procedures for expert control of linear algebra workflows. +All linear algebra procedures are engineered to support returning an optional `linalg_state_type` variable to hold such information, as a form of expert API. If the user does not require state information but fatal errors are encountered during the execution of linear algebra routines, the program will undergo a hard stop. +Instead, if the state argument is present, the program will never stop but will return detailed error information into the state handler. ## Derived types provided ### The `linalg_state_type` derived type -The `linalg_state_type` is defined as a derived type containing an integer error flag, and -fixed-size character strings to store an error message and the location of the error state change. -Fixed-size string storage was chosen to facilitate the compiler's memory allocation and ultimately -ensure maximum computational performance. +The `linalg_state_type` is an extension of the `state_type` derived type, containing an integer error flag and fixed-size character strings to store an error message and the location of the error state change. +Fixed-size string storage was chosen to facilitate the compiler's memory allocation and ultimately ensure maximum computational performance. -A similarly named generic interface, `linalg_state_type`, is provided to allow the developer to -create diagnostic messages and raise error flags easily. The call starts with an error flag or -the location of the event, and is followed by an arbitrary list of `integer`, `real`, `complex` or -`character` variables. Numeric variables may be provided as either scalars or rank-1 (array) inputs. +A similarly named generic interface, `linalg_state_type`, is provided to allow the developer to create diagnostic messages and raise error flags easily. The call starts with an error flag or the location of the event and is followed by an arbitrary list of `integer`, `real`, `complex`, or `character` variables. Numeric variables may be provided as either scalars or rank-1 (array) inputs. #### Type-bound procedures -The following convenience type-bound procedures are provided: +The following convenience type-bound procedures are inherited from `state_type` and available: - `print()` returns an allocatable character string containing state location, message, and error flag; - `print_message()` returns an allocatable character string containing the state message; - `ok()` returns a `logical` flag that is `.true.` in case of successful state (`flag==LINALG_SUCCESS`); -- `error()` returns a `logical` flag that is `.true.` in case of error state (`flag/=LINALG_SUCCESS`). +- `error()` returns a `logical` flag that is `.true.` in case of an error state (`flag/=LINALG_SUCCESS`). #### Status @@ -52,13 +42,13 @@ Experimental ## Error flags provided -The module provides the following state flags: -- `LINALG_SUCCESS`: Successful execution -- `LINALG_VALUE_ERROR`: Numerical errors (such as infinity, not-a-number, range bounds) are encountered. -- `LINALG_ERROR`: Linear Algebra errors are encountered, such as: non-converging iterations, impossible operations, etc. -- `LINALG_INTERNAL_ERROR`: Provided as a developer safeguard for internal errors that should never occur. +The module provides the following state flags, mapped to the general `state_type` error flags: +- `LINALG_SUCCESS`: Successful execution (equivalent to `STDLIB_SUCCESS`) +- `LINALG_VALUE_ERROR`: Numerical errors (such as infinity, not-a-number, range bounds) are encountered (equivalent to `STDLIB_VALUE_ERROR`). +- `LINALG_ERROR`: Linear Algebra errors are encountered, such as non-converging iterations, and impossible operations (equivalent to `STDLIB_LINALG_ERROR`). +- `LINALG_INTERNAL_ERROR`: Provided as a developer safeguard for internal errors that should never occur (equivalent to `STDLIB_INTERNAL_ERROR`). ## Comparison operators provided -The module provides overloaded comparison operators for all comparisons of a `linalg_state_type` variable -with an integer error flag: `<`, `<=`, `==`, `>=`, `>`, `/=`. +The module provides overloaded comparison operators for all comparisons of a `linalg_state_type` variable with an integer error flag: `<`, `<=`, `==`, `>=`, `>`, `/=`. + diff --git a/example/error/CMakeLists.txt b/example/error/CMakeLists.txt index c4830efb9..35831cb43 100644 --- a/example/error/CMakeLists.txt +++ b/example/error/CMakeLists.txt @@ -9,3 +9,5 @@ ADD_EXAMPLE(error_stop1) set_tests_properties(error_stop1 PROPERTIES WILL_FAIL true) ADD_EXAMPLE(error_stop2) set_tests_properties(error_stop2 PROPERTIES WILL_FAIL true) +ADD_EXAMPLE(error_state1) +ADD_EXAMPLE(error_state2) diff --git a/example/error/example_error_state1.f90 b/example/error/example_error_state1.f90 new file mode 100644 index 000000000..f6efe44ca --- /dev/null +++ b/example/error/example_error_state1.f90 @@ -0,0 +1,18 @@ +program example_error_state1 + use stdlib_error, only: state_type, STDLIB_VALUE_ERROR, STDLIB_SUCCESS, operator(/=) + implicit none + type(state_type) :: err + + ! To create a state variable, we enter its integer state flag, followed by a list of variables + ! that will be automatically assembled into a formatted error message. No need to provide string formats + err = state_type(STDLIB_VALUE_ERROR,'just an example with scalar ',& + 'integer=',1,'real=',2.0,'complex=',(3.0,1.0),'and array ',[1,2,3],'inputs') + + ! Print flag + print *, err%print() + + ! Check success + print *, 'Check error: ',err%error() + print *, 'Check flag : ',err /= STDLIB_SUCCESS + +end program example_error_state1 diff --git a/example/error/example_error_state2.f90 b/example/error/example_error_state2.f90 new file mode 100644 index 000000000..7d8a3b3c5 --- /dev/null +++ b/example/error/example_error_state2.f90 @@ -0,0 +1,62 @@ +program example_error_state2 + !! This example shows how to set a `type(state_type)` variable to process output conditions + !! out of a simple division routine. The example is meant to highlight: + !! 1) the different mechanisms that can be used to initialize the `state_type` variable providing + !! strings, scalars, or arrays, on input to it; + !! 2) `pure` setup of the error control + use stdlib_error, only: state_type, STDLIB_VALUE_ERROR, STDLIB_SUCCESS + implicit none + type(state_type) :: err + real :: a_div_b + + ! OK + call very_simple_division(0.0,2.0,a_div_b,err) + print *, err%print() + + ! Division by zero + call very_simple_division(1.0,0.0,a_div_b,err) + print *, err%print() + + ! Out of bounds + call very_simple_division(huge(0.0),0.001,a_div_b,err) + print *, err%print() + + contains + + !> Simple division returning an integer flag (LAPACK style) + elemental subroutine very_simple_division(a,b,a_div_b,err) + real, intent(in) :: a,b + real, intent(out) :: a_div_b + type(state_type), optional, intent(out) :: err + + type(state_type) :: err0 + real, parameter :: MAXABS = huge(0.0) + character(*), parameter :: this = 'simple division' + + !> Check a + if (b==0.0) then + ! Division by zero + err0 = state_type(this,STDLIB_VALUE_ERROR,'Division by zero trying ',a,'/',b) + elseif (.not.abs(b) error_unit, ilp => int32 + use stdlib_optval, only: optval + use stdlib_kinds, only: int8, int16, int32, int64, sp, dp, xdp, qp, lk + implicit none + private + + interface ! f{08,18}estop.f90 + module subroutine error_stop(msg, code) + !! version: experimental + !! + !! Provides a call to `error stop` and allows the user to specify a code and message + !! ([Specification](..//page/specs/stdlib_error.html#description_1)) + character(*), intent(in) :: msg + integer, intent(in), optional :: code + end subroutine error_stop + end interface + + public :: check, error_stop + + !> Version: experimental + !> + !> A fixed-storage state variable for error handling of linear algebra routines + public :: state_type + + !> Version: experimental + !> + !> Interfaces for comparison operators of error states with integer flags + public :: operator(==),operator(/=) + public :: operator(<),operator(<=) + public :: operator(>),operator(>=) + + !> Base state return types for + integer(ilp),parameter,public :: STDLIB_SUCCESS = 0_ilp + integer(ilp),parameter,public :: STDLIB_VALUE_ERROR = -1_ilp + integer(ilp),parameter,public :: STDLIB_LINALG_ERROR = -2_ilp + integer(ilp),parameter,public :: STDLIB_INTERNAL_ERROR = -3_ilp + integer(ilp),parameter,public :: STDLIB_IO_ERROR = -4_ilp + integer(ilp),parameter,public :: STDLIB_FS_ERROR = -5_ilp + + !> Use fixed-size character storage for performance + integer(ilp),parameter :: MSG_LENGTH = 512_ilp + integer(ilp),parameter :: NAME_LENGTH = 32_ilp + + !> `state_type` defines a general state return type for a + !> stdlib routine. State contains a status flag, a comment, and a + !> procedure specifier that can be used to mark where the error happened + type :: state_type + + !> The current exit state + integer(ilp) :: state = STDLIB_SUCCESS + + !> Message associated to the current state + character(len=MSG_LENGTH) :: message = repeat(' ',MSG_LENGTH) + + !> Location of the state change + character(len=NAME_LENGTH) :: where_at = repeat(' ',NAME_LENGTH) + + contains + + !> Cleanup + procedure :: destroy => state_destroy + + !> Parse error constructor + procedure, private :: state_parse_at_location + procedure, private :: state_parse_arguments + generic :: parse => state_parse_at_location, & + state_parse_arguments + + !> Print error message + procedure :: print => state_print + procedure :: print_msg => state_message + + !> State properties + procedure :: ok => state_is_ok + procedure :: error => state_is_error + + !> Handle optional error message + procedure :: handle => error_handling + + end type state_type + + !> Comparison operators + interface operator(==) + module procedure state_eq_flag + module procedure flag_eq_state + end interface + interface operator(/=) + module procedure state_neq_flag + module procedure flag_neq_state + end interface + interface operator(<) + module procedure state_lt_flag + module procedure flag_lt_state + end interface + interface operator(<=) + module procedure state_le_flag + module procedure flag_le_state + end interface + interface operator(>) + module procedure state_gt_flag + module procedure flag_gt_state + end interface + interface operator(>=) + module procedure state_ge_flag + module procedure flag_ge_state + end interface + + !> Assignment operator + interface assignment(=) + module procedure state_assign_state + end interface assignment(=) + + interface state_type + module procedure new_state + module procedure new_state_nowhere + end interface state_type + + !> Format strings with edit descriptors for each type and kind + !> cannot be retrieved from stdlib_io due to circular dependencies + character(*), parameter :: & + FMT_INT = '(i0)', & + FMT_REAL_SP = '(es15.8e2)', & + FMT_REAL_DP = '(es24.16e3)', & + FMT_REAL_XDP = '(es26.18e3)', & + FMT_REAL_QP = '(es44.35e4)', & + FMT_COMPLEX_SP = '(es15.8e2,1x,es15.8e2)', & + FMT_COMPLEX_DP = '(es24.16e3,1x,es24.16e3)', & + FMT_COMPLEX_XDP = '(es26.18e3,1x,es26.18e3)', & + FMT_COMPLEX_QP = '(es44.35e4,1x,es44.35e4)' + +contains + + subroutine check(condition, msg, code, warn) + !! version: experimental + !! + !! Checks the value of a logical condition + !! ([Specification](../page/specs/stdlib_error.html#description)) + !! + !!##### Behavior + !! + !! If `condition == .false.` and: + !! + !! * No other arguments are provided, it stops the program with the default + !! message and exit code `1`; + !! * `msg` is provided, it prints the value of `msg`; + !! * `code` is provided, it stops the program with the given exit code; + !! * `warn` is provided and `.true.`, it doesn't stop the program and prints + !! the message. + !! + !!##### Examples + !! + !!* If `a /= 5`, stops the program with exit code `1` + !! and prints `Check failed.` + !!``` fortran + !! call check(a == 5) + !!``` + !! + !!* As above, but prints `a == 5 failed`. + !!``` fortran + !! call check(a == 5, msg='a == 5 failed.') + !!``` + !! + !!* As above, but doesn't stop the program. + !!``` fortran + !! call check(a == 5, msg='a == 5 failed.', warn=.true.) + !!``` + !! + !!* As example #2, but stops the program with exit code `77` + !!``` fortran + !! call check(a == 5, msg='a == 5 failed.', code=77) + !!``` + + ! + ! Arguments + ! --------- + + logical, intent(in) :: condition + character(*), intent(in), optional :: msg + integer, intent(in), optional :: code + logical, intent(in), optional :: warn + character(*), parameter :: msg_default = 'Check failed.' + + if (.not. condition) then + if (optval(warn, .false.)) then + write(stderr,*) optval(msg, msg_default) + else + call error_stop(optval(msg, msg_default), optval(code, 1)) + end if + end if + + end subroutine check + + !> Cleanup the object + elemental subroutine state_destroy(this) + class(state_type),intent(inout) :: this + + this%state = STDLIB_SUCCESS + this%message = repeat(' ',len(this%message)) + this%where_at = repeat(' ',len(this%where_at)) + + end subroutine state_destroy + + !> Interface to print stdlib error messages + pure function state_flag_message(flag) result(msg) + integer(ilp),intent(in) :: flag + character(len=:),allocatable :: msg + + select case (flag) + case (STDLIB_SUCCESS); msg = 'Success!' + case (STDLIB_VALUE_ERROR); msg = 'Value Error' + case (STDLIB_LINALG_ERROR); msg = 'Linear Algebra Error' + case (STDLIB_IO_ERROR); msg = 'I/O Error' + case (STDLIB_FS_ERROR); msg = 'Filesystem Error' + case (STDLIB_INTERNAL_ERROR); msg = 'Internal Error' + case default; msg = 'INVALID/UNKNOWN STATE FLAG' + end select + + end function state_flag_message + + !> Return a formatted message + pure function state_message(this) result(msg) + class(state_type),intent(in) :: this + character(len=:),allocatable :: msg + + if (this%state == STDLIB_SUCCESS) then + msg = 'Success!' + else + msg = state_flag_message(this%state)//': '//trim(this%message) + end if + + end function state_message + + !> Flow control: on output flag present, return it; otherwise, halt on error + pure subroutine error_handling(ierr,ierr_out) + class(state_type), intent(in) :: ierr + class(state_type), optional, intent(inout) :: ierr_out + + character(len=:),allocatable :: err_msg + + if (present(ierr_out)) then + ! Return error flag + ierr_out = ierr + elseif (ierr%error()) then + err_msg = ierr%print() + error stop err_msg + end if + + end subroutine error_handling + + !> Produce a nice error string + pure function state_print(this) result(msg) + class(state_type),intent(in) :: this + character(len=:),allocatable :: msg + + if (len_trim(this%where_at) > 0) then + msg = '['//trim(this%where_at)//'] returned '//this%print_msg() + elseif (this%error()) then + msg = 'Error encountered: '//this%print_msg() + else + msg = this%print_msg() + end if + + end function state_print + + !> Check if the current state is successful + elemental logical(lk) function state_is_ok(this) + class(state_type),intent(in) :: this + state_is_ok = this%state == STDLIB_SUCCESS + end function state_is_ok + + !> Check if the current state is an error state + elemental logical(lk) function state_is_error(this) + class(state_type),intent(in) :: this + state_is_error = this%state /= STDLIB_SUCCESS + end function state_is_error + + !> Compare an error state with an integer flag + elemental logical(lk) function state_eq_flag(err,flag) + class(state_type),intent(in) :: err + integer,intent(in) :: flag + state_eq_flag = err%state == flag + end function state_eq_flag + + !> Compare an integer flag with the error state + elemental logical(lk) function flag_eq_state(flag,err) + integer,intent(in) :: flag + class(state_type),intent(in) :: err + flag_eq_state = err%state == flag + end function flag_eq_state + + !> Compare the error state with an integer flag + elemental logical(lk) function state_neq_flag(err,flag) + class(state_type),intent(in) :: err + integer,intent(in) :: flag + state_neq_flag = .not. state_eq_flag(err,flag) + end function state_neq_flag + + !> Compare an integer flag with the error state + elemental logical(lk) function flag_neq_state(flag,err) + integer,intent(in) :: flag + class(state_type),intent(in) :: err + flag_neq_state = .not. state_eq_flag(err,flag) + end function flag_neq_state + + !> Compare the error state with an integer flag + elemental logical(lk) function state_lt_flag(err,flag) + class(state_type),intent(in) :: err + integer,intent(in) :: flag + state_lt_flag = err%state < flag + end function state_lt_flag + + !> Compare the error state with an integer flag + elemental logical(lk) function state_le_flag(err,flag) + class(state_type),intent(in) :: err + integer,intent(in) :: flag + state_le_flag = err%state <= flag + end function state_le_flag + + !> Compare an integer flag with the error state + elemental logical(lk) function flag_lt_state(flag,err) + integer,intent(in) :: flag + class(state_type),intent(in) :: err + flag_lt_state = err%state < flag + end function flag_lt_state + + !> Compare an integer flag with the error state + elemental logical(lk) function flag_le_state(flag,err) + integer,intent(in) :: flag + class(state_type),intent(in) :: err + flag_le_state = err%state <= flag + end function flag_le_state + + !> Compare the error state with an integer flag + elemental logical(lk) function state_gt_flag(err,flag) + class(state_type),intent(in) :: err + integer,intent(in) :: flag + state_gt_flag = err%state > flag + end function state_gt_flag + + !> Compare the error state with an integer flag + elemental logical(lk) function state_ge_flag(err,flag) + class(state_type),intent(in) :: err + integer,intent(in) :: flag + state_ge_flag = err%state >= flag + end function state_ge_flag + + !> Compare an integer flag with the error state + elemental logical(lk) function flag_gt_state(flag,err) + integer,intent(in) :: flag + class(state_type),intent(in) :: err + flag_gt_state = err%state > flag + end function flag_gt_state + + !> Compare an integer flag with the error state + elemental logical(lk) function flag_ge_state(flag,err) + integer,intent(in) :: flag + class(state_type),intent(in) :: err + flag_ge_state = err%state >= flag + end function flag_ge_state + + !> Assign a state type to another + elemental subroutine state_assign_state(to, from) + class(state_type), intent(inout) :: to + class(state_type), intent(in) :: from + + to%state = from%state + to%message = from%message + to%where_at = from%where_at + + end subroutine state_assign_state + + !> Append a generic value to the error flag (rank-agnostic) + pure subroutine appendr(msg,a,prefix) + class(*),optional,intent(in) :: a(..) + character(len=*),intent(inout) :: msg + character,optional,intent(in) :: prefix + + if (present(a)) then + select rank (v=>a) + rank (0) + call append (msg,v,prefix) + rank (1) + call appendv(msg,v) + rank default + msg = trim(msg)//' ' + + end select + endif + + end subroutine appendr + + ! Append a generic value to the error flag + pure subroutine append(msg,a,prefix) + class(*),intent(in) :: a + character(len=*),intent(inout) :: msg + character,optional,intent(in) :: prefix + + character(len=MSG_LENGTH) :: buffer,buffer2 + character(len=2) :: sep + integer :: ls + + ! Do not add separator if this is the first instance + sep = ' ' + ls = merge(1,0,len_trim(msg) > 0) + + if (present(prefix)) then + ls = ls + 1 + sep(ls:ls) = prefix + end if + + select type (aa => a) + + !> String type + type is (character(len=*)) + msg = trim(msg)//sep(:ls)//aa + + !> Numeric types +#:for k1, t1 in KINDS_TYPES + type is (${t1}$) + #:if 'complex' in t1 + write (buffer, FMT_REAL_${k1}$) aa%re + write (buffer2,FMT_REAL_${k1}$) aa%im + msg = trim(msg)//sep(:ls)//'('//trim(adjustl(buffer))//','//trim(adjustl(buffer2))//')' + #:else + #:if 'real' in t1 + write (buffer,FMT_REAL_${k1}$) aa + #:else + write (buffer,FMT_INT) aa + #:endif + msg = trim(msg)//sep(:ls)//trim(adjustl(buffer)) + #:endif + +#:endfor + class default + msg = trim(msg)//' ' + + end select + + end subroutine append + + !> Append a generic vector to the error flag + pure subroutine appendv(msg,a) + class(*),intent(in) :: a(:) + character(len=*),intent(inout) :: msg + + integer :: j,ls + character(len=MSG_LENGTH) :: buffer,buffer2,buffer_format + character(len=2) :: sep + + if (size(a) <= 0) return + + ! Default: separate elements with one space + sep = ' ' + ls = 1 + + ! Open bracket + msg = trim(msg)//' [' + + ! Do not call append(msg(aa(j))), it will crash gfortran + select type (aa => a) + + !> Strings (cannot use string_type due to `sequence`) + type is (character(len=*)) + msg = trim(msg)//adjustl(aa(1)) + do j = 2,size(a) + msg = trim(msg)//sep(:ls)//adjustl(aa(j)) + end do + + !> Numeric types +#:for k1, t1 in KINDS_TYPES + type is (${t1}$) + #:if 'complex' in t1 + write (buffer,FMT_REAL_${k1}$) aa(1)%re + write (buffer2,FMT_REAL_${k1}$) aa(1)%im + msg = trim(msg)//'('//trim(adjustl(buffer))//','//trim(adjustl(buffer2))//')' + do j = 2,size(a) + write (buffer,FMT_REAL_${k1}$) aa(j)%re + write (buffer2,FMT_REAL_${k1}$) aa(j)%im + msg = trim(msg)//sep(:ls)//'('//trim(adjustl(buffer))//','//trim(adjustl(buffer2))//')' + end do + #:else + #:if 'real' in t1 + buffer_format = FMT_REAL_${k1}$ + #:else + buffer_format = FMT_INT + #:endif + + write (buffer,buffer_format) aa(1) + msg = trim(msg)//adjustl(buffer) + do j = 2,size(a) + write (buffer,buffer_format) aa(j) + msg = trim(msg)//sep(:ls)//adjustl(buffer) + end do + msg = trim(msg)//sep(:ls)//trim(adjustl(buffer)) + #:endif +#:endfor + class default + msg = trim(msg)//' ' + + end select + + ! Close bracket + msg = trim(msg)//']' + + end subroutine appendv + + !> Error creation message, with location location + pure type(state_type) function new_state(where_at,flag,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, & + a11,a12,a13,a14,a15,a16,a17,a18,a19,a20) + + !> Location + character(len=*),intent(in) :: where_at + + !> Input error flag + integer,intent(in) :: flag + + !> Optional rank-agnostic arguments + class(*),optional,intent(in),dimension(..) :: a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, & + a11,a12,a13,a14,a15,a16,a17,a18,a19,a20 + + ! Init object + call new_state%parse(where_at,flag,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, & + a11,a12,a13,a14,a15,a16,a17,a18,a19,a20) + + end function new_state + + !> Error creation message, from N input variables (numeric or strings) + pure type(state_type) function new_state_nowhere(flag,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, & + a11,a12,a13,a14,a15,a16,a17,a18,a19,a20) & + result(new_state) + + !> Input error flag + integer,intent(in) :: flag + + !> Optional rank-agnostic arguments + class(*),optional,intent(in),dimension(..) :: a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, & + a11,a12,a13,a14,a15,a16,a17,a18,a19,a20 + + ! Init object + call new_state%parse(flag,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, & + a11,a12,a13,a14,a15,a16,a17,a18,a19,a20) + + end function new_state_nowhere + + !> Parse a generic list of arguments provided to the error constructor + pure subroutine state_parse_at_location(new_state,where_at,flag,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, & + a11,a12,a13,a14,a15,a16,a17,a18,a19,a20) + + !> The current state variable + class(state_type), intent(inout) :: new_state + + !> Error Location + character(len=*),intent(in) :: where_at + + !> Input error flag + integer,intent(in) :: flag + + !> Optional rank-agnostic arguments + class(*),optional,intent(in),dimension(..) :: a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, & + a11,a12,a13,a14,a15,a16,a17,a18,a19,a20 + + ! Init object + call new_state%destroy() + + !> Set error flag + new_state%state = flag + + !> Set chain + new_state%message = "" + call appendr(new_state%message,a1) + call appendr(new_state%message,a2) + call appendr(new_state%message,a3) + call appendr(new_state%message,a4) + call appendr(new_state%message,a5) + call appendr(new_state%message,a6) + call appendr(new_state%message,a7) + call appendr(new_state%message,a8) + call appendr(new_state%message,a9) + call appendr(new_state%message,a10) + call appendr(new_state%message,a11) + call appendr(new_state%message,a12) + call appendr(new_state%message,a13) + call appendr(new_state%message,a14) + call appendr(new_state%message,a15) + call appendr(new_state%message,a16) + call appendr(new_state%message,a17) + call appendr(new_state%message,a18) + call appendr(new_state%message,a19) + call appendr(new_state%message,a20) + + !> Add location + if (len_trim(where_at) > 0) new_state%where_at = adjustl(where_at) + + end subroutine state_parse_at_location + + !> Parse a generic list of arguments provided to the error constructor + pure subroutine state_parse_arguments(new_state,flag,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, & + a11,a12,a13,a14,a15,a16,a17,a18,a19,a20) + + !> The current state variable + class(state_type), intent(inout) :: new_state + + !> Input error flag + integer,intent(in) :: flag + + !> Optional rank-agnostic arguments + class(*),optional,intent(in),dimension(..) :: a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, & + a11,a12,a13,a14,a15,a16,a17,a18,a19,a20 + + ! Init object + call new_state%destroy() + + !> Set error flag + new_state%state = flag + + !> Set chain + new_state%message = "" + call appendr(new_state%message,a1) + call appendr(new_state%message,a2) + call appendr(new_state%message,a3) + call appendr(new_state%message,a4) + call appendr(new_state%message,a5) + call appendr(new_state%message,a6) + call appendr(new_state%message,a7) + call appendr(new_state%message,a8) + call appendr(new_state%message,a9) + call appendr(new_state%message,a10) + call appendr(new_state%message,a11) + call appendr(new_state%message,a12) + call appendr(new_state%message,a13) + call appendr(new_state%message,a14) + call appendr(new_state%message,a15) + call appendr(new_state%message,a16) + call appendr(new_state%message,a17) + call appendr(new_state%message,a18) + call appendr(new_state%message,a19) + call appendr(new_state%message,a20) + + end subroutine state_parse_arguments + +end module stdlib_error diff --git a/src/stdlib_linalg_state.fypp b/src/stdlib_linalg_state.fypp index 08fe1ebe3..ed0b441ef 100644 --- a/src/stdlib_linalg_state.fypp +++ b/src/stdlib_linalg_state.fypp @@ -8,6 +8,8 @@ module stdlib_linalg_state !! ([Specification](../page/specs/stdlib_linalg.html)) use stdlib_linalg_constants,only: ilp use stdlib_kinds, only: int8, int16, int32, int64, sp, dp, xdp, qp, lk + use stdlib_error, only: state_type, operator(==), operator(/=), operator(<), operator(>), & + operator(<=), operator(>=), STDLIB_SUCCESS, STDLIB_VALUE_ERROR, STDLIB_LINALG_ERROR, STDLIB_INTERNAL_ERROR use stdlib_io, only: FMT_REAL_SP, FMT_REAL_DP, FMT_REAL_QP, FMT_COMPLEX_SP, FMT_COMPLEX_DP, & FMT_COMPLEX_QP, FMT_REAL_XDP, FMT_COMPLEX_XDP implicit none @@ -31,75 +33,27 @@ module stdlib_linalg_state public :: operator(<),operator(<=) public :: operator(>),operator(>=) - !> State return types - integer(ilp),parameter,public :: LINALG_SUCCESS = 0_ilp - integer(ilp),parameter,public :: LINALG_VALUE_ERROR = -1_ilp - integer(ilp),parameter,public :: LINALG_ERROR = -2_ilp - integer(ilp),parameter,public :: LINALG_INTERNAL_ERROR = -3_ilp - - !> Use fixed-size character storage for performance - integer(ilp),parameter :: MSG_LENGTH = 512_ilp - integer(ilp),parameter :: NAME_LENGTH = 32_ilp + !> State return types for linear algebra + integer(ilp),parameter,public :: LINALG_SUCCESS = STDLIB_SUCCESS + integer(ilp),parameter,public :: LINALG_VALUE_ERROR = STDLIB_VALUE_ERROR + integer(ilp),parameter,public :: LINALG_ERROR = STDLIB_LINALG_ERROR + integer(ilp),parameter,public :: LINALG_INTERNAL_ERROR = STDLIB_INTERNAL_ERROR !> `linalg_state_type` defines a state return type for a !> linear algebra routine. State contains a status flag, a comment, and a !> procedure specifier that can be used to mark where the error happened - type :: linalg_state_type - - !> The current exit state - integer(ilp) :: state = LINALG_SUCCESS - - !> Message associated to the current state - character(len=MSG_LENGTH) :: message = repeat(' ',MSG_LENGTH) - - !> Location of the state change - character(len=NAME_LENGTH) :: where_at = repeat(' ',NAME_LENGTH) - + type, extends(state_type) :: linalg_state_type contains - - !> Cleanup - procedure :: destroy => state_destroy - - !> Print error message - procedure :: print => state_print - procedure :: print_msg => state_message - - !> State properties - procedure :: ok => state_is_ok - procedure :: error => state_is_error - + + !> Print error message + procedure :: print_msg => state_message + end type linalg_state_type - !> Comparison operators - interface operator(==) - module procedure state_eq_flag - module procedure flag_eq_state - end interface - interface operator(/=) - module procedure state_neq_flag - module procedure flag_neq_state - end interface - interface operator(<) - module procedure state_lt_flag - module procedure flag_lt_state - end interface - interface operator(<=) - module procedure state_le_flag - module procedure flag_le_state - end interface - interface operator(>) - module procedure state_gt_flag - module procedure flag_gt_state - end interface - interface operator(>=) - module procedure state_ge_flag - module procedure flag_ge_state - end interface - - interface linalg_state_type - module procedure new_state - module procedure new_state_nowhere - end interface linalg_state_type + interface linalg_state_type + module procedure new_state + module procedure new_state_nowhere + end interface linalg_state_type contains @@ -148,127 +102,6 @@ module stdlib_linalg_state end function state_message - !> Produce a nice error string - pure function state_print(this) result(msg) - class(linalg_state_type),intent(in) :: this - character(len=:),allocatable :: msg - - if (len_trim(this%where_at) > 0) then - msg = '['//trim(this%where_at)//'] returned '//state_message(this) - elseif (this%error()) then - msg = 'Error encountered: '//state_message(this) - else - msg = state_message(this) - end if - - end function state_print - - !> Cleanup the object - elemental subroutine state_destroy(this) - class(linalg_state_type),intent(inout) :: this - - this%state = LINALG_SUCCESS - this%message = repeat(' ',len(this%message)) - this%where_at = repeat(' ',len(this%where_at)) - - end subroutine state_destroy - - !> Check if the current state is successful - elemental logical(lk) function state_is_ok(this) - class(linalg_state_type),intent(in) :: this - state_is_ok = this%state == LINALG_SUCCESS - end function state_is_ok - - !> Check if the current state is an error state - elemental logical(lk) function state_is_error(this) - class(linalg_state_type),intent(in) :: this - state_is_error = this%state /= LINALG_SUCCESS - end function state_is_error - - !> Compare an error state with an integer flag - elemental logical(lk) function state_eq_flag(err,flag) - type(linalg_state_type),intent(in) :: err - integer,intent(in) :: flag - state_eq_flag = err%state == flag - end function state_eq_flag - - !> Compare an integer flag with the error state - elemental logical(lk) function flag_eq_state(flag,err) - integer,intent(in) :: flag - type(linalg_state_type),intent(in) :: err - flag_eq_state = err%state == flag - end function flag_eq_state - - !> Compare the error state with an integer flag - elemental logical(lk) function state_neq_flag(err,flag) - type(linalg_state_type),intent(in) :: err - integer,intent(in) :: flag - state_neq_flag = .not. state_eq_flag(err,flag) - end function state_neq_flag - - !> Compare an integer flag with the error state - elemental logical(lk) function flag_neq_state(flag,err) - integer,intent(in) :: flag - type(linalg_state_type),intent(in) :: err - flag_neq_state = .not. state_eq_flag(err,flag) - end function flag_neq_state - - !> Compare the error state with an integer flag - elemental logical(lk) function state_lt_flag(err,flag) - type(linalg_state_type),intent(in) :: err - integer,intent(in) :: flag - state_lt_flag = err%state < flag - end function state_lt_flag - - !> Compare the error state with an integer flag - elemental logical(lk) function state_le_flag(err,flag) - type(linalg_state_type),intent(in) :: err - integer,intent(in) :: flag - state_le_flag = err%state <= flag - end function state_le_flag - - !> Compare an integer flag with the error state - elemental logical(lk) function flag_lt_state(flag,err) - integer,intent(in) :: flag - type(linalg_state_type),intent(in) :: err - flag_lt_state = err%state < flag - end function flag_lt_state - - !> Compare an integer flag with the error state - elemental logical(lk) function flag_le_state(flag,err) - integer,intent(in) :: flag - type(linalg_state_type),intent(in) :: err - flag_le_state = err%state <= flag - end function flag_le_state - - !> Compare the error state with an integer flag - elemental logical(lk) function state_gt_flag(err,flag) - type(linalg_state_type),intent(in) :: err - integer,intent(in) :: flag - state_gt_flag = err%state > flag - end function state_gt_flag - - !> Compare the error state with an integer flag - elemental logical(lk) function state_ge_flag(err,flag) - type(linalg_state_type),intent(in) :: err - integer,intent(in) :: flag - state_ge_flag = err%state >= flag - end function state_ge_flag - - !> Compare an integer flag with the error state - elemental logical(lk) function flag_gt_state(flag,err) - integer,intent(in) :: flag - type(linalg_state_type),intent(in) :: err - flag_gt_state = err%state > flag - end function flag_gt_state - - !> Compare an integer flag with the error state - elemental logical(lk) function flag_ge_state(flag,err) - integer,intent(in) :: flag - type(linalg_state_type),intent(in) :: err - flag_ge_state = err%state >= flag - end function flag_ge_state - !> Error creation message, with location location pure type(linalg_state_type) function new_state(where_at,flag,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, & a11,a12,a13,a14,a15,a16,a17,a18,a19,a20) @@ -283,12 +116,9 @@ module stdlib_linalg_state class(*),optional,intent(in),dimension(..) :: a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, & a11,a12,a13,a14,a15,a16,a17,a18,a19,a20 - !> Create state with no message - new_state = new_state_nowhere(flag,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, & - a11,a12,a13,a14,a15,a16,a17,a18,a19,a20) - - !> Add location - if (len_trim(where_at) > 0) new_state%where_at = adjustl(where_at) + ! Init object + call new_state%parse(where_at,flag,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, & + a11,a12,a13,a14,a15,a16,a17,a18,a19,a20) end function new_state @@ -305,169 +135,10 @@ module stdlib_linalg_state a11,a12,a13,a14,a15,a16,a17,a18,a19,a20 ! Init object - call new_state%destroy() - - !> Set error flag - new_state%state = flag - - !> Set chain - new_state%message = "" - call appendr(new_state%message,a1) - call appendr(new_state%message,a2) - call appendr(new_state%message,a3) - call appendr(new_state%message,a4) - call appendr(new_state%message,a5) - call appendr(new_state%message,a6) - call appendr(new_state%message,a7) - call appendr(new_state%message,a8) - call appendr(new_state%message,a9) - call appendr(new_state%message,a10) - call appendr(new_state%message,a11) - call appendr(new_state%message,a12) - call appendr(new_state%message,a13) - call appendr(new_state%message,a14) - call appendr(new_state%message,a15) - call appendr(new_state%message,a16) - call appendr(new_state%message,a17) - call appendr(new_state%message,a18) - call appendr(new_state%message,a19) - call appendr(new_state%message,a20) + call new_state%parse(flag,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, & + a11,a12,a13,a14,a15,a16,a17,a18,a19,a20) end function new_state_nowhere - !> Append a generic value to the error flag (rank-agnostic) - pure subroutine appendr(msg,a,prefix) - class(*),optional,intent(in) :: a(..) - character(len=*),intent(inout) :: msg - character,optional,intent(in) :: prefix - - if (present(a)) then - select rank (v=>a) - rank (0) - call append (msg,v,prefix) - rank (1) - call appendv(msg,v) - rank default - msg = trim(msg)//' ' - - end select - endif - - end subroutine appendr - - ! Append a generic value to the error flag - pure subroutine append(msg,a,prefix) - class(*),intent(in) :: a - character(len=*),intent(inout) :: msg - character,optional,intent(in) :: prefix - - character(len=MSG_LENGTH) :: buffer,buffer2 - character(len=2) :: sep - integer :: ls - - ! Do not add separator if this is the first instance - sep = ' ' - ls = merge(1,0,len_trim(msg) > 0) - - if (present(prefix)) then - ls = ls + 1 - sep(ls:ls) = prefix - end if - - select type (aa => a) - - !> String type - type is (character(len=*)) - msg = trim(msg)//sep(:ls)//aa - - !> Numeric types -#:for k1, t1 in KINDS_TYPES - type is (${t1}$) - #:if 'complex' in t1 - write (buffer, FMT_REAL_${k1}$) aa%re - write (buffer2,FMT_REAL_${k1}$) aa%im - msg = trim(msg)//sep(:ls)//'('//trim(adjustl(buffer))//','//trim(adjustl(buffer2))//')' - #:else - #:if 'real' in t1 - write (buffer,FMT_REAL_${k1}$) aa - #:else - write (buffer,'(i0)') aa - #:endif - msg = trim(msg)//sep(:ls)//trim(adjustl(buffer)) - #:endif - -#:endfor - class default - msg = trim(msg)//' ' - - end select - - end subroutine append - - !> Append a generic vector to the error flag - pure subroutine appendv(msg,a) - class(*),intent(in) :: a(:) - character(len=*),intent(inout) :: msg - - integer :: j,ls - character(len=MSG_LENGTH) :: buffer,buffer2,buffer_format - character(len=2) :: sep - - if (size(a) <= 0) return - - ! Default: separate elements with one space - sep = ' ' - ls = 1 - - ! Open bracket - msg = trim(msg)//' [' - - ! Do not call append(msg(aa(j))), it will crash gfortran - select type (aa => a) - - !> Strings (cannot use string_type due to `sequence`) - type is (character(len=*)) - msg = trim(msg)//adjustl(aa(1)) - do j = 2,size(a) - msg = trim(msg)//sep(:ls)//adjustl(aa(j)) - end do - - !> Numeric types -#:for k1, t1 in KINDS_TYPES - type is (${t1}$) - #:if 'complex' in t1 - write (buffer,FMT_REAL_${k1}$) aa(1)%re - write (buffer2,FMT_REAL_${k1}$) aa(1)%im - msg = trim(msg)//'('//trim(adjustl(buffer))//','//trim(adjustl(buffer2))//')' - do j = 2,size(a) - write (buffer,FMT_REAL_${k1}$) aa(j)%re - write (buffer2,FMT_REAL_${k1}$) aa(j)%im - msg = trim(msg)//sep(:ls)//'('//trim(adjustl(buffer))//','//trim(adjustl(buffer2))//')' - end do - #:else - #:if 'real' in t1 - buffer_format = FMT_REAL_${k1}$ - #:else - buffer_format = '(i0)' - #:endif - - write (buffer,buffer_format) aa(1) - msg = trim(msg)//adjustl(buffer) - do j = 2,size(a) - write (buffer,buffer_format) aa(j) - msg = trim(msg)//sep(:ls)//adjustl(buffer) - end do - msg = trim(msg)//sep(:ls)//trim(adjustl(buffer)) - #:endif -#:endfor - class default - msg = trim(msg)//' ' - - end select - - ! Close bracket - msg = trim(msg)//']' - - end subroutine appendv end module stdlib_linalg_state