Added tests and errors bubble-up

Author: mzecc

fortitude.toml

@@ -6,5 +6,5 @@ select = [ "C", "E", "S", "PORT" ]
 #Ignoring:
 # C003:	'implicit none' missing 'external'  [f2py does not recognize the syntax implicit none(type, external)]
 # ignore = ["C003","C072","S221"]
-ignore = ["C003"]
+ignore = ["C003","S221"]
 line-length = 120

src/example_fgen_basic/error_v/creation.f90

@@ -31,7 +31,7 @@ function create_error(inv) result(err)
             return
         end if
 
-        if (mod(inv, 2) .eq. 0) then
+        if (mod(inv, 2) == 0) then
             err = ErrorV(code=1, message="Even number supplied")
         else
             err = ErrorV(code=NO_ERROR_CODE)

src/example_fgen_basic/error_v/creation_wrapper.f90

@@ -15,7 +15,7 @@ module m_error_v_creation_w
     use m_error_v_manager, only: &
         error_v_manager_get_available_instance_index => get_available_instance_index, &
         error_v_manager_set_instance_index_to => set_instance_index_to, &
-        error_v_manager_ensure_instance_array_size_is_at_least => ensure_instance_array_size_is_at_least
+        error_v_manager_ensure_array_capacity_for_instances => ensure_array_capacity_for_instances
 
     implicit none
     private
@@ -44,7 +44,7 @@ function create_error(inv) result(res_instance_index)
         ! Do the Fortran call
         res = o_create_error(inv)
 
-        call error_v_manager_ensure_instance_array_size_is_at_least(1)
+        call error_v_manager_ensure_array_capacity_for_instances(1)
 
         ! Get the instance index to return to Python
         call error_v_manager_get_available_instance_index(res_instance_index)
@@ -81,11 +81,11 @@ function create_errors(invs, n) result(res_instance_indexes)
         ! Lots of ways resizing could work.
         ! Optimising could be very tricky.
         ! Just do something stupid for now to see the pattern.
-        call error_v_manager_ensure_instance_array_size_is_at_least(n)
+        call error_v_manager_ensure_array_capacity_for_instances(n)
 
         allocate(res(n))
         ! Do the Fortran call
-        ! MZ: somenthing funny happens wheb res is an automatic array and
+        ! MZ: somenthing funny happens when res is an automatic array and
         ! not an allocatable one. LLMs and internet resorces I found are not
         ! completely clear to me. What seems to happen is that returning an array of derived types with allocatable
         ! components may generate hidden temporary arrays whose allocatable components

src/example_fgen_basic/error_v/error_v.f90

@@ -31,7 +31,8 @@ module m_error_v
 
         ! TODO: think about adding trace (might be simpler than compiling with traceback)
 !        class(ErrorV), allocatable :: cause
-         type(ErrorV), pointer :: cause => null()
+!         type(ErrorV), pointer :: cause => null()
+        integer :: cause = 0
 
     contains
 
@@ -98,7 +99,7 @@ function constructor(code, message, cause) result(self)
 
         integer, intent(in) :: code
         character(len=*), optional, intent(in) :: message
-        type(ErrorV), target, optional, intent(in) :: cause
+        integer, optional, intent(in) :: cause
 
         type(ErrorV) :: self
 
@@ -119,26 +120,14 @@ subroutine build(self, code, message, cause)
 
         character(len=*), optional, intent(in) :: message
         !! Error message
-        type(ErrorV), target, optional, intent(in) :: cause
+
+        integer, optional, intent(in) :: cause
 
         self % code = code
 
-        if (present(cause)) then
-!            self % cause => cause
-!            allocate(self % cause)
-!            call self%cause%build(cause%code, cause%message, cause%cause)
-!            self%cause = cause
-            if (present(message)) then
-                self % message = adjustl(trim(message)) // " --> Cause: " // cause % message
-            else
-                self % message = " --> Cause: " // cause % message
-            end if
-
-        else
-            if (present(message)) then
-                self % message = adjustl(trim(message))
-            end if
-        end if
+        if (present(cause)) self % cause = cause
+
+        if (present(message)) self % message = adjustl(trim(message))
 
     end subroutine build
 !    subroutine build(self, code, message, cause)
@@ -185,10 +174,11 @@ subroutine finalise(self)
 
         ! If we make message allocatable, deallocate here
         self % code = 1
+        self % cause = 0
         if (allocated(self%message)) deallocate(self%message)
         ! MZ when the object is finalized or goes out of scope, its pointer components are destroyed.
         ! Hopefully no shared ownership??
-         if (associated(self%cause)) nullify(self%cause)
+!         if (associated(self%cause)) nullify(self%cause)
 !        if (allocated(self%cause)) deallocate(self%cause)
 
     end subroutine finalise

src/example_fgen_basic/error_v/error_v_manager.f90

@@ -10,15 +10,16 @@ module m_error_v_manager
     private
 
     type(ErrorV), dimension(:), allocatable :: instance_array
+    ! MZ : Do we really need instance_available?
     logical, dimension(:), allocatable :: instance_available
 
     ! TODO: think about ordering here, alphabetical probably easiest
-    public :: build_instance, finalise_instance, get_available_instance_index, get_instance, set_instance_index_to, &
-              ensure_instance_array_size_is_at_least
+    public :: build_instance, finalise_instance, get_available_instance_index, get_instance, get_error_message, &
+            set_instance_index_to, ensure_array_capacity_for_instances,deallocate_instance_arrays
 
 contains
 
-    function build_instance(code, message) result(instance_index)
+    function build_instance(code, message, cause) result(instance_index)
         !! Build an instance
 
         integer, intent(in) :: code
@@ -27,12 +28,14 @@ function build_instance(code, message) result(instance_index)
         character(len=*), optional, intent(in) :: message
         !! Error message
 
+        integer, optional, intent(in) :: cause
+
         integer :: instance_index
         !! Index of the built instance
 
-        call ensure_instance_array_size_is_at_least(1)
+        call ensure_array_capacity_for_instances(1)
         call get_available_instance_index(instance_index)
-        call instance_array(instance_index) % build(code=code, message=message)
+        call instance_array(instance_index) % build(code=code, message=message, cause=cause)
 
     end function build_instance
 
@@ -82,7 +85,7 @@ subroutine get_available_instance_index(available_instance_index)
 
         ! TODO: switch to returning a Result type with an error set
         ! res = ResultInt(ErrorV(code=1, message="No available instances"))
-        print *, "print"
+        print *, "print dioooo"
         error stop 1
 
     end subroutine get_available_instance_index
@@ -97,6 +100,8 @@ function get_instance(instance_index) result(err_inst)
         !! Instance at `instance_array(instance_index)`
 
         type(ErrorV) :: err_check_index_claimed
+
+        integer :: cause
         character(len=20) :: idx_str
         character(len=:), allocatable :: msg
 
@@ -107,39 +112,46 @@ function get_instance(instance_index) result(err_inst)
             err_inst = instance_array(instance_index)
 
         else
+
             write(idx_str, "(I0)") instance_index
             msg = "Error at get_instance -> " // trim(adjustl(idx_str))
 
-            err_inst = ErrorV( &
+            cause = build_instance(code=err_check_index_claimed % code, message=err_check_index_claimed % message)
+
+            call err_inst % build( &
                     code= err_check_index_claimed%code,&
                     message = msg, &
-                    cause = err_check_index_claimed &
+                    cause = cause &
                     )
         end if
 
     end function get_instance
 
-    function set_instance_index_to(instance_index, val) result(err)
+    function set_instance_index_to(instance_index, val) result(err_inst)
 
         integer, intent(in) :: instance_index
         !! Index in `instance_array` of which to set the value equal to `val`
 
         type(ErrorV), intent(in) :: val
-        type(ErrorV) :: err
+        type(ErrorV) :: err_inst
 
         type(ErrorV) :: err_check_index_claimed
+        integer :: cause
         character(len=:), allocatable :: msg
 
         err_check_index_claimed = check_index_claimed(instance_index)
 
-        if(err_check_index_claimed%code /= NO_ERROR_CODE) then
+        if (err_check_index_claimed%code /= NO_ERROR_CODE) then
             ! MZ: here we do not set if the index has not been claimed.
             ! Must be harmonised with Results type
             msg ="Setting Instance Error: "
-            err = ErrorV ( &
-                    code = err_check_index_claimed% code, &
+
+            cause = build_instance(code=err_check_index_claimed % code, message=err_check_index_claimed % message)
+
+            call err_inst % build( &
+                    code= err_check_index_claimed%code,&
                     message = msg, &
-                    cause = err_check_index_claimed &
+                    cause = cause &
                     )
 
         else
@@ -153,7 +165,7 @@ function set_instance_index_to(instance_index, val) result(err)
             ! Reassigning the slot
             call instance_array(instance_index)%build(code=val%code, message=val%message, cause=val%cause)
 
-            err = ErrorV(code=NO_ERROR_CODE)
+            call err_inst % build(code= NO_ERROR_CODE)
 
         end if
 
@@ -192,8 +204,7 @@ function check_index_claimed(instance_index) result(err_check_index_claimed)
             ! print *, "Index ", instance_index, " has not been claimed"
             ! error stop 1
             msg = "Index " // trim(adjustl(idx_str)) // " has not been claimed"
-
-            err_check_index_claimed = ErrorV(code=1, message=msg)
+            call err_check_index_claimed % build(code=1, message=msg)
 
             return
         end if
@@ -209,41 +220,123 @@ function check_index_claimed(instance_index) result(err_check_index_claimed)
             ! print *, "Requested index is ", instance_index, " which is less than 1"
             ! error stop 1
             msg = "Requested index is: " // trim(adjustl(idx_str)) // " ==> out of boundary"
-            err_check_index_claimed = ErrorV(code=2, message=msg)
+            call err_check_index_claimed % build(code=2, message=msg)
 
             return
         end if
 
-        err_check_index_claimed = ErrorV(code=NO_ERROR_CODE)
+        call err_check_index_claimed % build(code=NO_ERROR_CODE)
 
     end function check_index_claimed
 
-    subroutine ensure_instance_array_size_is_at_least(n)
-        !! Ensure that `instance_array` and `instance_available` have at least `n` slots
+!   subroutine ensure_instance_array_size_is_at_least(n)
+!        !! Ensure that `instance_array` and `instance_available` have at least `n` slots
+!
+!        integer, intent(in) :: n
+!
+!        type(ErrorV), dimension(:), allocatable :: tmp_instances
+!        logical, dimension(:), allocatable :: tmp_available
+!
+!        if (.not. allocated(instance_array)) then
+!            allocate (instance_array(n))
+!
+!            allocate (instance_available(n))
+!            ! Race conditions ?
+!            instance_available = .true.
+!
+!        else if (size(instance_available) < n) then
+!            allocate (tmp_instances(n))
+!            tmp_instances(1:size(instance_array)) = instance_array
+!            call move_alloc(tmp_instances, instance_array)
+!
+!            allocate (tmp_available(n))
+!            tmp_available(1:size(instance_available)) = instance_available
+!            tmp_available(size(instance_available) + 1:size(tmp_available)) = .true.
+!            call move_alloc(tmp_available, instance_available)
+!
+!        end if
+!    end subroutine ensure_instance_array_size_is_at_least
+
+  subroutine ensure_array_capacity_for_instances(n)
+  !! Ensure that `instance_array` has at least `n` slots
+
+    integer, intent(in) :: n
+    type(ErrorV), dimension(:), allocatable :: tmp_instances
+    logical, dimension(:), allocatable :: tmp_available
+
+    integer :: free_count
+
+    if (.not. allocated(instance_array)) then
+
+        allocate (instance_array(n),instance_available(n))
+        ! Race conditions ?
+        instance_available = .true.
+
+    else if (size(instance_array) < n) then
+      ! MZ: in this case we just add n spaces on top
 
-        integer, intent(in) :: n
+        allocate(tmp_instances(n+size(instance_array)), &
+                  tmp_available(n+size(instance_available))  &
+                )
 
-        type(ErrorV), dimension(:), allocatable :: tmp_instances
-        logical, dimension(:), allocatable :: tmp_available
+        tmp_instances(1:size(instance_array)) = instance_array
+        tmp_available = .true.
+        tmp_available(1:size(instance_available)) = instance_available
 
-        if (.not. allocated(instance_array)) then
-            allocate (instance_array(n))
+        call move_alloc(tmp_instances, instance_array)
+        call move_alloc(tmp_available, instance_available)
 
-            allocate (instance_available(n))
-            ! Race conditions ?
-            instance_available = .true.
+    else
 
-        else if (size(instance_available) < n) then
-            allocate (tmp_instances(n))
-            tmp_instances(1:size(instance_array)) = instance_array
-            call move_alloc(tmp_instances, instance_array)
+      free_count = count(instance_available)
 
-            allocate (tmp_available(n))
-            tmp_available(1:size(instance_available)) = instance_available
-            tmp_available(size(instance_available) + 1:size(tmp_available)) = .true.
-            call move_alloc(tmp_available, instance_available)
+      if (free_count < n) then
+        ! MZ: doubling the size might be more efficient in the long run??
+        allocate(tmp_instances(size(instance_array)*2),&
+                  tmp_available(size(instance_available)*2) &
+                )
 
+        tmp_instances(1:size(instance_array)) = instance_array
+        tmp_available = .true.
+        tmp_available(1:size(instance_available)) = instance_available
+
+        call move_alloc(tmp_instances, instance_array)
+        call move_alloc(tmp_available, instance_available)
+
+      end if
+
+    end if
+
+  end subroutine ensure_array_capacity_for_instances
+
+    pure recursive function get_error_message(err) result(full_msg)
+
+        type(ErrorV), intent(in) :: err
+
+        character(len=:), allocatable :: full_msg
+        character(len=:), allocatable :: cause_msg
+
+        full_msg = err%message
+
+        if (err%cause/=0) then
+            !MZ : free slot while passing by?
+            cause_msg = get_error_message(instance_array(err%cause))
+            full_msg = trim(full_msg) // NEW_LINE("A") // " Previous error --> "  // trim(cause_msg)
         end if
-    end subroutine ensure_instance_array_size_is_at_least
+
+    end function get_error_message
+
+    subroutine deallocate_instance_arrays()
+        !! Finalise an instance
+
+        if (allocated(instance_available).and.allocated(instance_array)) then
+            deallocate(instance_available,instance_array)
+        else if(allocated(instance_available))then
+            deallocate(instance_available)
+        else if(allocated(instance_array)) then
+            deallocate(instance_array)
+        end if
+
+    end subroutine deallocate_instance_arrays
 
 end module m_error_v_manager