[1793] | 1 | ! Copyright Jérémie Burgalat (2010-2015) |
---|
| 2 | ! |
---|
| 3 | ! burgalat.jeremie@gmail.com |
---|
| 4 | ! |
---|
| 5 | ! This software is a computer program whose purpose is to provide configuration |
---|
| 6 | ! file and command line arguments parsing features to Fortran programs. |
---|
| 7 | ! |
---|
| 8 | ! This software is governed by the CeCILL-B license under French law and |
---|
| 9 | ! abiding by the rules of distribution of free software. You can use, |
---|
| 10 | ! modify and/ or redistribute the software under the terms of the CeCILL-B |
---|
| 11 | ! license as circulated by CEA, CNRS and INRIA at the following URL |
---|
| 12 | ! "http://www.cecill.info". |
---|
| 13 | ! |
---|
| 14 | ! As a counterpart to the access to the source code and rights to copy, |
---|
| 15 | ! modify and redistribute granted by the license, users are provided only |
---|
| 16 | ! with a limited warranty and the software's author, the holder of the |
---|
| 17 | ! economic rights, and the successive licensors have only limited |
---|
| 18 | ! liability. |
---|
| 19 | ! |
---|
| 20 | ! In this respect, the user's attention is drawn to the risks associated |
---|
| 21 | ! with loading, using, modifying and/or developing or reproducing the |
---|
| 22 | ! software by the user in light of its specific status of free software, |
---|
| 23 | ! that may mean that it is complicated to manipulate, and that also |
---|
| 24 | ! therefore means that it is reserved for developers and experienced |
---|
| 25 | ! professionals having in-depth computer knowledge. Users are therefore |
---|
| 26 | ! encouraged to load and test the software's suitability as regards their |
---|
| 27 | ! requirements in conditions enabling the security of their systems and/or |
---|
| 28 | ! data to be ensured and, more generally, to use and operate it in the |
---|
| 29 | ! same conditions as regards security. |
---|
| 30 | ! |
---|
| 31 | ! The fact that you are presently reading this means that you have had |
---|
| 32 | ! knowledge of the CeCILL-B license and that you accept its terms. |
---|
| 33 | |
---|
| 34 | !! file: errors.F90 |
---|
| 35 | !! summary: Errors handling source file |
---|
| 36 | !! author: Burgalat |
---|
| 37 | !! date: 2013-2015 |
---|
| 38 | |
---|
| 39 | #include "defined.h" |
---|
| 40 | |
---|
| 41 | MODULE ERRORS |
---|
| 42 | !! Error handler module |
---|
| 43 | !! |
---|
| 44 | !! This module provides a single derived type, [[error(type)]] which is used in all |
---|
| 45 | !! other parts of the library in order to handle errors. |
---|
| 46 | USE, INTRINSIC :: ISO_C_BINDING |
---|
| 47 | USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY : stdout=>OUTPUT_UNIT, stderr=>ERROR_UNIT |
---|
| 48 | |
---|
| 49 | IMPLICIT NONE |
---|
| 50 | |
---|
| 51 | PUBLIC |
---|
| 52 | |
---|
| 53 | PRIVATE :: error_equals,error_equals_int,error_differs,error_differs_int, & |
---|
| 54 | msg_length |
---|
| 55 | |
---|
| 56 | |
---|
| 57 | INTEGER, PARAMETER :: msg_length = 250 !! Length of error message. |
---|
| 58 | |
---|
| 59 | TYPE, PUBLIC :: error |
---|
| 60 | !! Define an error |
---|
| 61 | !! |
---|
| 62 | !! The following derived type represents in the simplest way (I believe) an error which |
---|
| 63 | !! stores: |
---|
| 64 | !! |
---|
| 65 | !! - An integer to numerically identify the error |
---|
| 66 | !! - A string (250 chars max) with an appropriate error message |
---|
| 67 | !! - A bounded procedure to get a string representation of the error (if bounded |
---|
| 68 | !! procedures are supported by the library). |
---|
| 69 | !! - internal subroutines for derived type IO WRITE statement (if Derived IO |
---|
| 70 | !! subroutines are supported by the library). |
---|
| 71 | !! |
---|
| 72 | !! error type comes also with two operators ("==", "/=") to compare error type with |
---|
| 73 | !! another one or an integer. |
---|
| 74 | !! If an error is not initialized explicitly, then it is set to [[errors(module):noerror(variable)]]. |
---|
| 75 | CHARACTER(len=msg_length) :: msg = "No error" |
---|
| 76 | !! Message associated to the error |
---|
| 77 | !! @note |
---|
| 78 | !! The message should be short (250 characters maximum) and explicit. |
---|
| 79 | INTEGER :: id = 0 |
---|
| 80 | !! Numerical identifier of the error |
---|
| 81 | !! @note |
---|
| 82 | !! The error identifier is used to test the equality/inequality of two error objects. |
---|
| 83 | #if HAVE_FTNPROC |
---|
| 84 | CONTAINS |
---|
| 85 | PROCEDURE, PUBLIC :: to_string => error_to_string |
---|
| 86 | #endif |
---|
| 87 | END TYPE error |
---|
| 88 | |
---|
| 89 | INTERFACE |
---|
| 90 | !! Clean subroutine interface |
---|
| 91 | SUBROUTINE clean_callback(err) |
---|
| 92 | !! A subroutine that may perform cleaning computation(s) before exit |
---|
| 93 | IMPORT error |
---|
| 94 | IMPLICIT NONE |
---|
| 95 | TYPE(error), INTENT(in) :: err |
---|
| 96 | !! An error object with the input error |
---|
| 97 | END SUBROUTINE clean_callback |
---|
| 98 | END INTERFACE |
---|
| 99 | |
---|
| 100 | INTERFACE |
---|
| 101 | subroutine abort_() bind(C, name="abort") |
---|
| 102 | end subroutine |
---|
| 103 | END INTERFACE |
---|
| 104 | |
---|
| 105 | INTERFACE assert |
---|
| 106 | !! _Raise_ an assertion. |
---|
| 107 | !! |
---|
| 108 | !! An assertion can be understood as a development error that should be raised in production mode. |
---|
| 109 | MODULE PROCEDURE :: assert_r,assert_w |
---|
| 110 | END INTERFACE assert |
---|
| 111 | |
---|
| 112 | !> error equality operator |
---|
| 113 | INTERFACE OPERATOR(==) |
---|
| 114 | MODULE PROCEDURE error_equals, error_equals_int |
---|
| 115 | END INTERFACE |
---|
| 116 | |
---|
| 117 | !> error inequality operator |
---|
| 118 | INTERFACE OPERATOR(/=) |
---|
| 119 | MODULE PROCEDURE error_differs, error_differs_int |
---|
| 120 | END INTERFACE |
---|
| 121 | |
---|
| 122 | !> The no error error ! |
---|
| 123 | TYPE(error), PUBLIC, PARAMETER :: noerror = error("No error",0) |
---|
| 124 | |
---|
| 125 | CONTAINS |
---|
| 126 | |
---|
| 127 | !=============================================================================== |
---|
| 128 | ! error TYPE RELATED METHODS |
---|
| 129 | !=============================================================================== |
---|
| 130 | |
---|
| 131 | FUNCTION error_equals(this, other) RESULT(res) |
---|
| 132 | !! Check if two error objects are equivalent |
---|
| 133 | TYPE(error), INTENT(in) :: this, & !! The first error object to compare |
---|
| 134 | other !! The second error object to compare |
---|
| 135 | LOGICAL :: res !! .true. if __this__ and __other__ identifiers are the same, .false. otherwise |
---|
| 136 | res = (this%id == other%id) |
---|
| 137 | RETURN |
---|
| 138 | END FUNCTION error_equals |
---|
| 139 | |
---|
| 140 | FUNCTION error_equals_int(this, id) RESULT(res) |
---|
| 141 | !! Check if an error id is equal to a given integer |
---|
| 142 | TYPE(error), INTENT(in) :: this !! An error object reference |
---|
| 143 | INTEGER, INTENT(in) :: id !! An integer to compare to __this__ identifier |
---|
| 144 | LOGICAL :: res !! .true. if __this__ identifier and __id__ have the same value, .false. otherwise |
---|
| 145 | res = (this%id == id) |
---|
| 146 | RETURN |
---|
| 147 | END FUNCTION error_equals_int |
---|
| 148 | |
---|
| 149 | FUNCTION error_differs(this, other) RESULT(res) |
---|
| 150 | !! Check if two error objects are different |
---|
| 151 | TYPE(error), INTENT(in) :: this, & !! The first error object to compare |
---|
| 152 | other !! The second error object to compare |
---|
| 153 | LOGICAL :: res !! .false. if __this__ and __other__ identifiers are the same, .true. otherwise |
---|
| 154 | res = (this%id /= other%id) |
---|
| 155 | RETURN |
---|
| 156 | END FUNCTION error_differs |
---|
| 157 | |
---|
| 158 | FUNCTION error_differs_int(this, id) RESULT(res) |
---|
| 159 | !! Check if an error id is different from a given integer |
---|
| 160 | TYPE(error), INTENT(in) :: this !! An error object reference |
---|
| 161 | INTEGER, INTENT(in) :: id !! An integer to compare to __this__ identifier |
---|
| 162 | LOGICAL :: res !! .false. if __this__ identifier and __id__ have the same value, .true. otherwise |
---|
| 163 | res = (this%id /= id) |
---|
| 164 | RETURN |
---|
| 165 | END FUNCTION error_differs_int |
---|
| 166 | |
---|
| 167 | FUNCTION error_to_string(this,progname,as_warning) RESULT(str) |
---|
| 168 | !! (simple) String representation of the error |
---|
| 169 | !! |
---|
| 170 | !! The function returns a very simple formatted string with the error. |
---|
| 171 | OBJECT(error), INTENT(in) :: this |
---|
| 172 | !! An error object reference |
---|
| 173 | CHARACTER(len=*), INTENT(in), OPTIONAL :: progname |
---|
| 174 | !! An optional string with the name of the program |
---|
| 175 | LOGICAL, INTENT(in), OPTIONAL :: as_warning |
---|
| 176 | !! An optional boolean flag to print the message as warning rather than as error (default to .false.). |
---|
| 177 | CHARACTER(len=:), ALLOCATABLE :: str |
---|
| 178 | !! An allocatable string with the string representation of the error |
---|
| 179 | CHARACTER(len=:), ALLOCATABLE :: pref |
---|
| 180 | pref = "error: " |
---|
| 181 | IF (PRESENT(as_warning)) THEN ; IF (as_warning) pref = "warning: " ; ENDIF |
---|
| 182 | IF (PRESENT(progname)) THEN |
---|
| 183 | IF (LEN_TRIM(progname) /=0) THEN |
---|
| 184 | str = TRIM(progname)//': '//pref//TRIM(this%msg) |
---|
| 185 | ELSE |
---|
| 186 | str = pref//TRIM(this%msg) |
---|
| 187 | ENDIF |
---|
| 188 | ELSE |
---|
| 189 | str = pref//TRIM(this%msg) |
---|
| 190 | ENDIF |
---|
| 191 | RETURN |
---|
| 192 | END FUNCTION error_to_string |
---|
| 193 | |
---|
| 194 | SUBROUTINE aborting(err) |
---|
| 195 | !! Abort the program with specific exit code |
---|
| 196 | !! |
---|
| 197 | !! The method prints the message of the given error object and |
---|
| 198 | !! stops the program using exit() subroutine. |
---|
| 199 | TYPE(error), INTENT(in) :: err |
---|
| 200 | !! An error object |
---|
| 201 | IF (err /= 0) THEN |
---|
| 202 | WRITE(*,'(a)') error_to_string(err) |
---|
[1814] | 203 | CALL EXIT(abs(err%id)) |
---|
[1793] | 204 | ENDIF |
---|
| 205 | END SUBROUTINE aborting |
---|
| 206 | |
---|
| 207 | SUBROUTINE assert_r(test,reason) |
---|
| 208 | !! _Raise_ an assertion. |
---|
| 209 | !! |
---|
| 210 | !! The method raises an assertion and stops the execution if __test__ is .false. |
---|
| 211 | !! |
---|
| 212 | !! @note |
---|
| 213 | !! If ISO_C_BINDING module is available, the method calls the method abort from the C standard library. Doing so, |
---|
| 214 | !! developer is able to debug the source code by getting the backtrace of the execution. |
---|
| 215 | !! In other situation, the method simply uses the Fortran STOP statement which makes its usage... useless. |
---|
| 216 | LOGICAL, INTENT(in) :: test |
---|
| 217 | !! Expression to test. |
---|
| 218 | CHARACTER(len=*), INTENT(in) :: reason |
---|
| 219 | !! Optional assertion reason. |
---|
| 220 | IF (.NOT.test) THEN |
---|
| 221 | WRITE(stderr,'(a)') "assertion: "//reason |
---|
| 222 | call abort_() |
---|
| 223 | ENDIF |
---|
| 224 | END SUBROUTINE assert_r |
---|
| 225 | |
---|
| 226 | SUBROUTINE assert_w(test,where,reason) |
---|
| 227 | !! _Raise_ an assertion. |
---|
| 228 | !! |
---|
| 229 | !! The method raises an assertion and stops the execution if __test__ is .false. |
---|
| 230 | !! |
---|
| 231 | !! See [[errors(module):assert_r(subroutine)] remark. |
---|
| 232 | LOGICAL, INTENT(in) :: test |
---|
| 233 | !! Expression to test. |
---|
| 234 | CHARACTER(len=*), INTENT(in) :: where |
---|
| 235 | !! Optional _location_ of the assertion. |
---|
| 236 | CHARACTER(len=*), INTENT(in) :: reason |
---|
| 237 | !! Optional assertion reason. |
---|
| 238 | IF (.NOT.test) THEN |
---|
| 239 | WRITE(stderr,'(a)') "assertion in "//where//": "//reason |
---|
| 240 | call abort_() |
---|
| 241 | ENDIF |
---|
| 242 | END SUBROUTINE assert_w |
---|
| 243 | |
---|
| 244 | |
---|
| 245 | END MODULE ERRORS |
---|
| 246 | |
---|