From 0bca6c3b2325ecd2bb78b89a9a8b121a3352fab6 Mon Sep 17 00:00:00 2001
From: Florian Prill <m300196@mlogin102.hpc.dkrz.de>
Date: Mon, 12 Sep 2016 09:59:33 +0200
Subject: [PATCH] implemented a simple fortran error handling framework.
---
examples/example_hl.f90 | 56 +++++++++++++++++++++-
src/Makefile.am | 1 +
src/Makefile.in | 4 +-
src/error_handling.f90 | 100 ++++++++++++++++++++++++++++++++++++++++
4 files changed, 158 insertions(+), 3 deletions(-)
create mode 100644 src/error_handling.f90
diff --git a/examples/example_hl.f90 b/examples/example_hl.f90
index 2fc18713..694b5f19 100644
--- a/examples/example_hl.f90
+++ b/examples/example_hl.f90
@@ -1,13 +1,44 @@
+MODULE mo_example
+
+ USE error_handling
+ IMPLICIT NONE
+
+CONTAINS
+
+ INTEGER FUNCTION division(number1, number2, ifail)
+ INTEGER, INTENT(IN) :: number1, number2
+ TYPE(t_error), INTENT(INOUT) :: ifail
+
+ division = 0
+ IF (number2 == 0) THEN
+ CALL create_error(ifail, t_arithmetic_error("Division by zero!"))
+ ELSE IF ((number1 < 0) .OR. (number2 < 0)) THEN
+ CALL create_error(ifail, t_invalid_input_error("Only positive numbers allowed!"))
+ ELSE
+ division = number1 / number2
+ END IF
+ END FUNCTION division
+END MODULE mo_example
+
+
+
PROGRAM example
- USE mtime, ONLY: setCalendar, PROLEPTIC_GREGORIAN
- USE mtime_hl, ONLY: t_datetime, t_timedelta
+ USE mo_example
+
+ USE mtime, ONLY: setCalendar, PROLEPTIC_GREGORIAN
+ USE mtime_hl, ONLY: t_datetime, t_timedelta
+ USE error_handling
IMPLICIT NONE
TYPE(t_datetime) :: dt, dt2, dt3
TYPE(t_timedelta) :: td
+ INTEGER :: test_number1, test_number2, test_result
+ TYPE(t_error) :: ifail
+
+
WRITE (0,*) "example_hl : test example"
WRITE (0,*) " setting calendar."
@@ -55,5 +86,26 @@ PROGRAM example
WRITE (0,*) dt%to_string(), " == ", dt2%to_string(), ": ", (dt == dt2)
dt3 = "1970-01-01T00:00:01"
WRITE (0,*) dt%to_string(), " == ", dt3%to_string(), ": ", (dt == dt3)
+
+ ! ------------------------------------------------------------
+ ! EXAMPLE FOR ERROR HANDLING
+ ! ------------------------------------------------------------
+
+ WRITE (0,*) "EXAMPLE FOR ERROR HANDLING"
+ test_number1 = 10
+ test_number2 = -1
+ test_result = division(test_number1, test_number2, ifail)
+
+ SELECT TYPE(info => ifail%info)
+ CLASS is (t_arithmetic_error)
+ WRITE (0,*) "I'm too stupid!"
+ CALL ifail%report()
+ CLASS is (t_invalid_input_error)
+ WRITE (0,*) "You are too stupid!"
+ CALL ifail%report()
+ CLASS default
+ WRITE (0,*) "Everything was ok!"
+ WRITE (0,*) "result = ", test_result
+ END SELECT
END PROGRAM example
diff --git a/src/Makefile.am b/src/Makefile.am
index f4543686..327393f7 100644
--- a/src/Makefile.am
+++ b/src/Makefile.am
@@ -19,6 +19,7 @@ libmtime_la_SOURCES = mtime_calendar.c \
vsop87.c \
kepler.c \
orbit.c \
+ error_handling.f90 \
libmtime.f90 \
libmtime_hl.f90
diff --git a/src/Makefile.in b/src/Makefile.in
index e0d85be5..0958997d 100644
--- a/src/Makefile.in
+++ b/src/Makefile.in
@@ -128,7 +128,8 @@ am_libmtime_la_OBJECTS = mtime_calendar.lo mtime_calendar360day.lo \
mtime_iso8601.lo mtime_date.lo mtime_datetime.lo \
mtime_julianDay.lo mtime_time.lo mtime_timedelta.lo \
mtime_eventList.lo mtime_eventHandling.lo mtime_utilities.lo \
- vsop87.lo kepler.lo orbit.lo libmtime.lo libmtime_hl.lo
+ vsop87.lo kepler.lo orbit.lo error_handling.lo libmtime.lo \
+ libmtime_hl.lo
libmtime_la_OBJECTS = $(am_libmtime_la_OBJECTS)
AM_V_lt = $(am__v_lt_@AM_V@)
am__v_lt_ = $(am__v_lt_@AM_DEFAULT_V@)
@@ -382,6 +383,7 @@ libmtime_la_SOURCES = mtime_calendar.c \
vsop87.c \
kepler.c \
orbit.c \
+ error_handling.f90 \
libmtime.f90 \
libmtime_hl.f90
diff --git a/src/error_handling.f90 b/src/error_handling.f90
new file mode 100644
index 00000000..ab3ea6f7
--- /dev/null
+++ b/src/error_handling.f90
@@ -0,0 +1,100 @@
+!> Simple framework for error handling in Fortran.
+!
+! This error handling strategy has been described in:
+!
+! Poppe, Cools,Vandewoestyne:
+! Error handling in Fortran 2003 (2012)
+!
+! It benefits from a number of F2003 features. In this
+! implementation, some parts of the framework have been simplified.
+!
+! Implementation: 09/2016, F. Prill (DWD)
+!
+MODULE error_handling
+
+ IMPLICIT NONE
+
+ PUBLIC :: t_error
+ PUBLIC :: t_error_info, t_invalid_input_error, t_arithmetic_error
+
+ PUBLIC :: create_error
+ PUBLIC :: transfer_error
+
+
+ INTEGER, PARAMETER :: MAX_ERROR_STR_LEN = 256
+
+
+ !> Base class for error info, storing the details of the
+ ! circumstances in which the error occured. Making a distinction
+ ! between the error and the associated information simplifies the
+ ! use.
+ TYPE t_error_info
+ CHARACTER(LEN=MAX_ERROR_STR_LEN) :: error_string
+ END TYPE t_error_info
+
+
+ !> Error info type: Invalid user input
+ TYPE, EXTENDS(t_error_info) :: t_invalid_input_error
+ END TYPE t_invalid_input_error
+
+ !> Error info type: Arithmetic error
+ TYPE, EXTENDS(t_error_info) :: t_arithmetic_error
+ END TYPE t_arithmetic_error
+
+
+
+ !> Base class for errors
+ TYPE t_error
+ CLASS(t_error_info), POINTER :: info => NULL()
+ CONTAINS
+ PROCEDURE :: report => error_report
+ PROCEDURE :: discard => error_discard
+ END TYPE t_error
+
+CONTAINS
+
+ !> Called in an unexpected situation, this subroutine creates an
+ ! error, storing all parameters that are needed to uniquely define
+ ! the situation.
+ !
+ SUBROUTINE create_error(new_error, new_info)
+ TYPE(t_error), INTENT(INOUT) :: new_error
+ CLASS(t_error_info), INTENT(IN) :: new_info
+ ALLOCATE(new_error%info, source=new_info)
+ END SUBROUTINE create_error
+
+
+ !> Transfers the error from @p inform to the @p ifail argument.
+ !
+ ! Thus, the responsibility of the error can be transferred to the
+ ! calling procedure.
+ !
+ SUBROUTINE transfer_error(inform, new_error)
+ TYPE(t_error), INTENT(IN) :: inform
+ TYPE(t_error), INTENT(INOUT) :: new_error
+ new_error%info => inform%info
+ END SUBROUTINE transfer_error
+
+
+ !> Outputs the given error.
+ !
+ SUBROUTINE error_report(this)
+ CLASS(t_error) :: this
+ IF (ASSOCIATED(this%info)) THEN
+ WRITE (0,*) "ERROR STRING: ", this%info%error_string
+ ELSE
+ WRITE (0,*) "SUCCESS"
+ END IF
+ CALL this%discard()
+ END SUBROUTINE error_report
+
+
+ !> Indicates that the given error has been taken care of and can be
+ ! silenced safely.
+ !
+ SUBROUTINE error_discard(this)
+ CLASS(t_error) :: this
+ IF (ASSOCIATED(this%info)) DEALLOCATE(this%info)
+ END SUBROUTINE error_discard
+
+END MODULE error_handling
--
GitLab