diff --git a/Makefile b/Makefile index fb38ff5..e48e7ab 100644 --- a/Makefile +++ b/Makefile @@ -52,7 +52,8 @@ test: ## run the tests (re-installs the package every time so you might want to uv run --no-sync python scripts/inject-srcs-into-meson-build.py uv run --no-sync python -c 'from pathlib import Path; import example_fgen_basic' || ( echo "Run make virtual-environment first" && false ) COV_DIR=$$(uv run --no-sync python -c 'from pathlib import Path; import example_fgen_basic; print(Path(example_fgen_basic.__file__).parent)'); \ - uv run --no-editable --reinstall-package example-fgen-basic pytest -r a -v tests src --doctest-modules --doctest-report ndiff --cov=$$COV_DIR + uv run --no-editable --reinstall-package example-fgen-basic pytest -s -r a -v tests src --doctest-modules --doctest-report ndiff --cov=$$COV_DIR + # uv run --no-editable --reinstall-package example-fgen-basic pytest -s -r a -v tests/unit/test_get_square_root.py src --doctest-modules --doctest-report ndiff --cov=$$COV_DIR # Note on code coverage and testing: # You must specify cov=src. @@ -113,7 +114,7 @@ test-fortran: build-fortran ## run the Fortran tests .PHONY: install-fortran install-fortran: build-fortran ## install the Fortran (including the extension module) - uv run meson install -C build -v + uv run meson install -C build # -v # # Can also do this to see where things go without making a mess # uv run meson install -C build --destdir ../install-example diff --git a/fortitude.toml b/fortitude.toml index 2161fc4..3f9415f 100644 --- a/fortitude.toml +++ b/fortitude.toml @@ -1,5 +1,10 @@ [check] -# TODO: think about adding other rules -select = [ "C", "E", "S" ] -ignore = [ ] +# Fortitude rules (https://fortitude.readthedocs.io/en/stable/rules/): +# Error (E), Correctness (C), Obsolescent (OB), Modernisation (MOD), +# Style (S), Portability (PORT), Fortitude (FORT) +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","S221"] line-length = 120 diff --git a/meson.build b/meson.build index 84134c5..575afb9 100644 --- a/meson.build +++ b/meson.build @@ -54,7 +54,9 @@ if pyprojectwheelbuild_enabled 'src/example_fgen_basic/error_v/creation_wrapper.f90', 'src/example_fgen_basic/error_v/error_v_wrapper.f90', 'src/example_fgen_basic/error_v/passing_wrapper.f90', + 'src/example_fgen_basic/get_square_root_wrapper.f90', 'src/example_fgen_basic/get_wavelength_wrapper.f90', + 'src/example_fgen_basic/result/result_wrapper.f90', ) # Specify all the other source Fortran files (original files and managers) @@ -66,8 +68,18 @@ if pyprojectwheelbuild_enabled 'src/example_fgen_basic/error_v/passing.f90', 'src/example_fgen_basic/fpyfgen/base_finalisable.f90', 'src/example_fgen_basic/fpyfgen/derived_type_manager_helpers.f90', + 'src/example_fgen_basic/get_square_root.f90', 'src/example_fgen_basic/get_wavelength.f90', 'src/example_fgen_basic/kind_parameters.f90', + 'src/example_fgen_basic/result/result_gen.f90', + 'src/example_fgen_basic/result/result_manager.f90', + # 'src/example_fgen_basic/result/result.f90', + # 'src/example_fgen_basic/result/result_none.f90', + # 'src/example_fgen_basic/result/result_dp.f90', + # 'src/example_fgen_basic/result/result_dp_manager.f90', + # 'src/example_fgen_basic/result/result_int.f90', + # 'src/example_fgen_basic/result/result_int_manager.f90', + # 'src/example_fgen_basic/result/result_int1D.f90', ) # All Python files (wrappers and otherwise) @@ -79,9 +91,12 @@ if pyprojectwheelbuild_enabled 'src/example_fgen_basic/error_v/error_v.py', 'src/example_fgen_basic/error_v/passing.py', 'src/example_fgen_basic/exceptions.py', + 'src/example_fgen_basic/get_square_root.py', 'src/example_fgen_basic/get_wavelength.py', 'src/example_fgen_basic/pyfgen_runtime/__init__.py', 'src/example_fgen_basic/pyfgen_runtime/exceptions.py', + 'src/example_fgen_basic/result/__init__.py', + 'src/example_fgen_basic/result/result_gen.py', 'src/example_fgen_basic/typing.py', ) diff --git a/scripts/inject-srcs-into-meson-build.py b/scripts/inject-srcs-into-meson-build.py index 3487b16..5041b53 100644 --- a/scripts/inject-srcs-into-meson-build.py +++ b/scripts/inject-srcs-into-meson-build.py @@ -93,6 +93,7 @@ def main(): meson_variable, sorted(src_paths), REPO_ROOT ) + # TODO: something wrong in here meson_build_out = re.sub(pattern, substitution, meson_build_out) with open(REPO_ROOT / "meson.build", "w") as fh: diff --git a/src/example_fgen_basic/error_v/creation.f90 b/src/example_fgen_basic/error_v/creation.f90 index 97aed75..3dd4056 100644 --- a/src/example_fgen_basic/error_v/creation.f90 +++ b/src/example_fgen_basic/error_v/creation.f90 @@ -6,7 +6,7 @@ module m_error_v_creation use m_error_v, only: ErrorV, NO_ERROR_CODE - implicit none (type, external) + implicit none private public :: create_error, create_errors @@ -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) diff --git a/src/example_fgen_basic/error_v/creation.py b/src/example_fgen_basic/error_v/creation.py index a0695d6..8909f9b 100644 --- a/src/example_fgen_basic/error_v/creation.py +++ b/src/example_fgen_basic/error_v/creation.py @@ -53,7 +53,6 @@ def create_error(inv: int) -> ErrorV: # Initialise the result from the received index res = ErrorV.from_instance_index(instance_index) - # Tell Fortran to finalise the object on the Fortran side # (all data has been copied to Python now) m_error_v_w.finalise_instance(instance_index) @@ -80,7 +79,9 @@ def create_errors(invs: NP_ARRAY_OF_INT) -> tuple[ErrorV, ...]: Created errors """ # Get the result, but receiving an instance index rather than the object itself - instance_indexes: NP_ARRAY_OF_INT = m_error_v_creation_w.create_errors(invs) + instance_indexes: NP_ARRAY_OF_INT = m_error_v_creation_w.create_errors( + invs, len(invs) + ) # Initialise the result from the received index res = tuple(ErrorV.from_instance_index(i) for i in instance_indexes) diff --git a/src/example_fgen_basic/error_v/creation_wrapper.f90 b/src/example_fgen_basic/error_v/creation_wrapper.f90 index fbddaae..97a67f4 100644 --- a/src/example_fgen_basic/error_v/creation_wrapper.f90 +++ b/src/example_fgen_basic/error_v/creation_wrapper.f90 @@ -15,9 +15,9 @@ 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 (type, external) + implicit none private public :: create_error, create_errors @@ -39,19 +39,20 @@ function create_error(inv) result(res_instance_index) ! This is the major trick for wrapping. ! We return instance indexes (integers) to Python rather than the instance itself. - type(ErrorV) :: res + type(ErrorV) :: res, err ! 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) ! Set the derived type value in the manager's array, ! ready for its attributes to be retrieved from Python. - call error_v_manager_set_instance_index_to(res_instance_index, res) + err = error_v_manager_set_instance_index_to(res_instance_index, res) + !MZ: check for errors ? end function create_error @@ -72,17 +73,23 @@ function create_errors(invs, n) result(res_instance_indexes) ! ! This is the major trick for wrapping. ! We return instance indexes (integers) to Python rather than the instance itself. - - type(ErrorV), dimension(n) :: res + type(ErrorV) :: err + type(ErrorV), allocatable, dimension(:) :: res integer :: i, tmp ! 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 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 + ! become undefined (or the heap address gets corrupted) after the function returns. res = o_create_errors(invs, n) do i = 1, n @@ -91,7 +98,8 @@ function create_errors(invs, n) result(res_instance_indexes) call error_v_manager_get_available_instance_index(tmp) ! Set the derived type value in the manager's array, ! ready for its attributes to be retrieved from Python. - call error_v_manager_set_instance_index_to(tmp, res(i)) + err = error_v_manager_set_instance_index_to(tmp, res(i)) + !MZ: check for errors ? ! Set the result in the output array res_instance_indexes(i) = tmp diff --git a/src/example_fgen_basic/error_v/error_v.f90 b/src/example_fgen_basic/error_v/error_v.f90 index c0876bd..3742938 100644 --- a/src/example_fgen_basic/error_v/error_v.f90 +++ b/src/example_fgen_basic/error_v/error_v.f90 @@ -5,22 +5,24 @@ !> !> Fortran doesn't have a null value. !> As a result, we introduce this derived type -!> with the convention that a code of 0 indicates no error. +!> with the convention that a code of `NO_ERROR_CODE` (0) +!> indicates no error (i.e. is our equivalent of a null value). module m_error_v - implicit none (type, external) + implicit none private integer, parameter, public :: NO_ERROR_CODE = 0 !! Code that indicates no error type, public :: ErrorV - !! Error value + !! Error value integer :: code = 1 !! Error code - character(len=128) :: message = "" + character(len=:), allocatable :: message + !! Error message ! TODO: think about making the message allocatable to handle long messages @@ -28,41 +30,87 @@ module m_error_v ! (means you can stop but also unwind errors and traceback along the way) ! TODO: think about adding trace (might be simpler than compiling with traceback) - ! type(ErrorV), allocatable, dimension(:) :: causes +! class(ErrorV), allocatable :: cause +! type(ErrorV), pointer :: cause => null() + integer :: cause = 0 contains private - procedure, public :: build, finalise + procedure, public :: build + procedure, public :: finalise +! procedure, public :: get_error_message + final :: finalise_auto ! get_res sort of not needed (?) ! get_err sort of not needed (?) end type ErrorV interface ErrorV - !! Constructor interface - see build (TODO: figure out cross-ref syntax) for details + !! Constructor interface - see build (TODO: figure out cross-ref syntax) for details module procedure :: constructor end interface ErrorV contains - function constructor(code, message) result(self) +! pure recursive function get_error_message(self) result(full_msg) +! +! class(ErrorV), target, intent(in) :: self +! +! character(len=:), allocatable :: full_msg +! character(len=:), allocatable :: cause_msg +! +! full_msg = self%message +! if (associated(self%cause)) then +! cause_msg = self%cause%get_error_message() +! full_msg = trim(full_msg) // ' Previous error: ' // trim(cause_msg) +! end if +! +! end function +! function get_error_message(self) result(full_msg) +! +! class(ErrorV), target, intent(in) :: self +! class(ErrorV), pointer :: p_errorv +! +! character(len=:), allocatable :: full_msg +! +! full_msg = "" +! +! if (allocated(self%message)) full_msg = trim(self%message) +! p_errorv => self +! +! do while (associated(p_errorv)) +! +! if(len(full_msg)>0)then +! full_msg = trim(full_msg) // " --> Cause: " // p_errorv % message +! else +! full_msg = p_errorv % message +! end if +! +! p_errorv => p_errorv % cause +! +! end do +! +! end function + + function constructor(code, message, cause) result(self) !! Constructor - see build (TODO: figure out cross-ref syntax) for details integer, intent(in) :: code character(len=*), optional, intent(in) :: message + integer, optional, intent(in) :: cause type(ErrorV) :: self - call self % build(code, message) + call self % build(code, message, cause) end function constructor - subroutine build(self, code, message) + subroutine build(self, code, message, cause) !! Build instance - class(ErrorV), intent(inout) :: self + class(ErrorV), intent(out) :: self ! Hopefully can leave without docstring (like Python) integer, intent(in) :: code @@ -73,12 +121,50 @@ subroutine build(self, code, message) character(len=*), optional, intent(in) :: message !! Error message + integer, optional, intent(in) :: cause + self % code = code - if (present(message)) then - self % message = message - 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) +! !! Build instance +! +! class(ErrorV), intent(out) :: self +! ! Hopefully can leave without docstring (like Python) +! +! integer, intent(in) :: code +! !! Error code +! !! +! !! Use [TODO: figure out xref] `NO_ERROR_CODE` if there is no error +! +! character(len=*), optional, intent(in) :: message +! !! Error message +! type(ErrorV), target, 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 +! +! end subroutine build subroutine finalise(self) !! Finalise the instance (i.e. free/deallocate) @@ -88,8 +174,26 @@ subroutine finalise(self) ! If we make message allocatable, deallocate here self % code = 1 - self % message = "" + 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 (allocated(self%cause)) deallocate(self%cause) end subroutine finalise + subroutine finalise_auto(self) + !! Finalise the instance (i.e. free/deallocate) + !! + !! This method is expected to be called automatically + !! by clever clean up, which is why it differs from [TODO x-ref] `finalise` + + type(ErrorV), intent(inout) :: self + ! Hopefully can leave without docstring (like Python) + + call self % finalise() + + end subroutine finalise_auto + end module m_error_v diff --git a/src/example_fgen_basic/error_v/error_v.py b/src/example_fgen_basic/error_v/error_v.py index c508148..68d0868 100644 --- a/src/example_fgen_basic/error_v/error_v.py +++ b/src/example_fgen_basic/error_v/error_v.py @@ -53,10 +53,8 @@ def from_instance_index(cls, instance_index: int) -> ErrorV: # Integer is very simple code = m_error_v_w.get_code(instance_index) - # String requires decode message = m_error_v_w.get_message(instance_index).decode() - res = cls(code=code, message=message) return res diff --git a/src/example_fgen_basic/error_v/error_v_manager.f90 b/src/example_fgen_basic/error_v/error_v_manager.f90 index 693a50f..85af6d3 100644 --- a/src/example_fgen_basic/error_v/error_v_manager.f90 +++ b/src/example_fgen_basic/error_v/error_v_manager.f90 @@ -4,21 +4,22 @@ !> Generation to be automated in future (including docstrings of some sort). module m_error_v_manager - use m_error_v, only: ErrorV + use m_error_v, only: ErrorV, NO_ERROR_CODE - implicit none (type, external) + implicit none 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 @@ -41,8 +44,12 @@ subroutine finalise_instance(instance_index) integer, intent(in) :: instance_index !! Index of the instance to finalise + type(ErrorV) :: err_check_index_claimed + + err_check_index_claimed = check_index_claimed(instance_index) - call check_index_claimed(instance_index) + ! MZ how do we handle unsuccefull finalisation? + if(err_check_index_claimed% code /= 0) return call instance_array(instance_index) % finalise() instance_available(instance_index) = .true. @@ -68,6 +75,8 @@ subroutine get_available_instance_index(available_instance_index) instance_available(i) = .false. available_instance_index = i + ! TODO: switch to returning a Result type + ! res = ResultInt(data=i) return end if @@ -75,87 +84,259 @@ subroutine get_available_instance_index(available_instance_index) end do ! TODO: switch to returning a Result type with an error set + ! res = ResultInt(ErrorV(code=1, message="No available instances")) + print *, "print dioooo" error stop 1 end subroutine get_available_instance_index ! Change to pure function when we update check_index_claimed to be pure - function get_instance(instance_index) result(inst) + function get_instance(instance_index) result(err_inst) integer, intent(in) :: instance_index !! Index in `instance_array` of which to set the value equal to `val` - type(ErrorV) :: inst + type(ErrorV) :: err_inst !! Instance at `instance_array(instance_index)` - call check_index_claimed(instance_index) - inst = instance_array(instance_index) + type(ErrorV) :: err_check_index_claimed + + integer :: cause + character(len=20) :: idx_str + character(len=:), allocatable :: msg + + err_check_index_claimed = check_index_claimed(instance_index) + + if (err_check_index_claimed % code == NO_ERROR_CODE) then + + err_inst = instance_array(instance_index) + + else + + write(idx_str, "(I0)") instance_index + msg = "Error at get_instance -> " // trim(adjustl(idx_str)) + + 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 = cause & + ) + end if end function get_instance - subroutine set_instance_index_to(instance_index, val) + 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_inst + + type(ErrorV) :: err_check_index_claimed + integer :: cause + character(len=:), allocatable :: msg - call check_index_claimed(instance_index) - instance_array(instance_index) = val + err_check_index_claimed = check_index_claimed(instance_index) - end subroutine set_instance_index_to + 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: " - subroutine check_index_claimed(instance_index) + 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 = cause & + ) + + else + !MZ: When there's no error the index is claimed and the value is updated/overwritten(?) + !Manually finalising before updating + !Fortran intrinsic assignment does free allocatables automatically. + ! But calling finalise(): guarantees immediate release, handles non-allocatable resources, + ! avoids temporary double memory + call instance_array(instance_index)%finalise() + + ! Reassigning the slot + call instance_array(instance_index)%build(code=val%code, message=val%message, cause=val%cause) + + call err_inst % build(code= NO_ERROR_CODE) + + end if + + end function set_instance_index_to + + function check_index_claimed(instance_index) result(err_check_index_claimed) !! Check that an index has already been claimed !! !! Stops execution if the index has not been claimed. integer, intent(in) :: instance_index !! Instance index to check + type(ErrorV) :: err_check_index_claimed + character(len=20) :: idx_str + character(len=:), allocatable :: msg + + + if (.not. allocated(instance_available)) then + + msg = "instance_available in NOT allocated" + err_check_index_claimed = ErrorV(code=3, message=msg) + + return + end if + + write(idx_str, "(I0)") instance_index if (instance_available(instance_index)) then - ! TODO: switch to errors here - will require some thinking - print *, "Index ", instance_index, " has not been claimed" - error stop 1 + ! TODO: Switch to using Result here + ! Use `ResultNone` which is a Result type + ! that doesn't have a `data` attribute + ! (i.e. if this succeeds, there is no data to check, + ! if it fails, the result_dp attribute will be set). + ! So the code would be something like + ! res = ResultNone(ResultDP(code=1, message="Index ", instance_index, " has not been claimed")) + ! print *, "Index ", instance_index, " has not been claimed" + ! error stop 1 + msg = "Index " // trim(adjustl(idx_str)) // " has not been claimed" + call err_check_index_claimed % build(code=1, message=msg) + + return end if - if (instance_index < 1) then - ! TODO: switch to errors here - will require some thinking - print *, "Requested index is ", instance_index, " which is less than 1" - error stop 1 + if (instance_index < 1 .or. instance_index > size(instance_array)) then + ! TODO: Switch to using Result here + ! Use `ResultNone` which is a Result type + ! that doesn't have a `data` attribute + ! (i.e. if this succeeds, there is no data to check, + ! if it fails, the result_dp attribute will be set). + ! So the code would be something like + ! res = ResultNone(ResultDP(code=2, message="Requested index is ", instance_index, " which is less than 1")) + ! 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" + call err_check_index_claimed % build(code=2, message=msg) + + return end if - end subroutine check_index_claimed + 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 +! +! 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 - subroutine ensure_instance_array_size_is_at_least(n) - !! Ensure that `instance_array` and `instance_available` have at least `n` slots + allocate(tmp_instances(n+size(instance_array)), & + tmp_available(n+size(instance_available)) & + ) - integer, intent(in) :: n + tmp_instances(1:size(instance_array)) = instance_array + tmp_available = .true. + tmp_available(1:size(instance_available)) = instance_available - type(ErrorV), dimension(:), allocatable :: tmp_instances - logical, dimension(:), allocatable :: tmp_available + call move_alloc(tmp_instances, instance_array) + call move_alloc(tmp_available, instance_available) - if (.not. allocated(instance_array)) then + else - allocate(instance_array(n)) + free_count = count(instance_available) - allocate(instance_available(n)) - ! Race conditions ? - instance_available = .true. + 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) & + ) - else if (size(instance_available) < n) then + tmp_instances(1:size(instance_array)) = instance_array + tmp_available = .true. + tmp_available(1:size(instance_available)) = instance_available - allocate(tmp_instances(n)) - tmp_instances(1:size(instance_array)) = instance_array - call move_alloc(tmp_instances, instance_array) + call move_alloc(tmp_instances, instance_array) + call move_alloc(tmp_available, 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) + 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 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 ensure_instance_array_size_is_at_least + end subroutine deallocate_instance_arrays end module m_error_v_manager diff --git a/src/example_fgen_basic/error_v/error_v_wrapper.f90 b/src/example_fgen_basic/error_v/error_v_wrapper.f90 index 7825cc9..0505fac 100644 --- a/src/example_fgen_basic/error_v/error_v_wrapper.f90 +++ b/src/example_fgen_basic/error_v/error_v_wrapper.f90 @@ -12,14 +12,16 @@ module m_error_v_w error_v_manager_build_instance => build_instance, & error_v_manager_finalise_instance => finalise_instance, & error_v_manager_get_instance => get_instance, & - error_v_manager_ensure_instance_array_size_is_at_least => ensure_instance_array_size_is_at_least + error_v_manager_get_error_message => get_error_message, & + error_v_manager_deallocate_instance_arrays => deallocate_instance_arrays, & + error_v_manager_ensure_array_capacity_for_instances => ensure_array_capacity_for_instances - implicit none (type, external) + implicit none private public :: build_instance, finalise_instance, finalise_instances, & ensure_at_least_n_instances_can_be_passed_simultaneously, & - get_code, get_message + get_code, get_message, free_memory contains @@ -85,7 +87,7 @@ subroutine ensure_at_least_n_instances_can_be_passed_simultaneously(n) integer, intent(in) :: n - call error_v_manager_ensure_instance_array_size_is_at_least(n) + call error_v_manager_ensure_array_capacity_for_instances(n) end subroutine ensure_at_least_n_instances_can_be_passed_simultaneously @@ -118,14 +120,30 @@ subroutine get_message( & integer, intent(in) :: instance_index ! TODO: make this variable length - character(len=128), intent(out) :: message + ! MZ attempts to put allocatable lead to segfault + ! it seems to be really trick. F2PY does not like allocatable + ! and assumed-lenght does not work well with long sentences. + character(len=1000), intent(out) :: message type(ErrorV) :: instance instance = error_v_manager_get_instance(instance_index) - message = instance % message + if (allocated(instance%message)) then + + if(instance % cause == 0) then + message = adjustl(trim(instance % message)) + else + message = adjustl(trim(error_v_manager_get_error_message(instance))) + end if +! else !MZ what to do?? +!! message = "Invalid query: message not allocated" + end if end subroutine get_message + subroutine free_memory() + call error_v_manager_deallocate_instance_arrays() + end subroutine free_memory + end module m_error_v_w diff --git a/src/example_fgen_basic/error_v/passing.f90 b/src/example_fgen_basic/error_v/passing.f90 index c274eb7..eb44274 100644 --- a/src/example_fgen_basic/error_v/passing.f90 +++ b/src/example_fgen_basic/error_v/passing.f90 @@ -6,7 +6,7 @@ module m_error_v_passing use m_error_v, only: ErrorV, NO_ERROR_CODE - implicit none (type, external) + implicit none private public :: pass_error, pass_errors diff --git a/src/example_fgen_basic/error_v/passing_wrapper.f90 b/src/example_fgen_basic/error_v/passing_wrapper.f90 index 7fd899b..92476a9 100644 --- a/src/example_fgen_basic/error_v/passing_wrapper.f90 +++ b/src/example_fgen_basic/error_v/passing_wrapper.f90 @@ -13,12 +13,12 @@ module m_error_v_passing_w ! The manager module, which makes this all work use m_error_v_manager, only: & - error_v_manager_get_instance => get_instance + error_v_manager_get_instance => get_instance ! 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 - implicit none (type, external) + implicit none private public :: pass_error, pass_errors diff --git a/src/example_fgen_basic/fpyfgen/base_finalisable.f90 b/src/example_fgen_basic/fpyfgen/base_finalisable.f90 index 617ecc0..4632ef8 100644 --- a/src/example_fgen_basic/fpyfgen/base_finalisable.f90 +++ b/src/example_fgen_basic/fpyfgen/base_finalisable.f90 @@ -4,7 +4,7 @@ !> across the Python-Fortran interface. module fpyfgen_base_finalisable - implicit none (type, external) + implicit none(type, external) private integer, parameter, public :: INVALID_INSTANCE_INDEX = -1 @@ -38,7 +38,7 @@ subroutine derived_type_finalise(self) import :: BaseFinalisable - implicit none (type, external) + implicit none(type, external) class(BaseFinalisable), intent(inout) :: self diff --git a/src/example_fgen_basic/fpyfgen/derived_type_manager_helpers.f90 b/src/example_fgen_basic/fpyfgen/derived_type_manager_helpers.f90 index 9a4148c..8f1a3f6 100644 --- a/src/example_fgen_basic/fpyfgen/derived_type_manager_helpers.f90 +++ b/src/example_fgen_basic/fpyfgen/derived_type_manager_helpers.f90 @@ -3,7 +3,7 @@ module fpyfgen_derived_type_manager_helpers use fpyfgen_base_finalisable, only: BaseFinalisable, invalid_instance_index - implicit none (type, external) + implicit none(type, external) private public :: get_derived_type_free_instance_number, & diff --git a/src/example_fgen_basic/get_square_root.f90 b/src/example_fgen_basic/get_square_root.f90 new file mode 100644 index 0000000..cafa16b --- /dev/null +++ b/src/example_fgen_basic/get_square_root.f90 @@ -0,0 +1,40 @@ +!> Get square root of a number +module m_get_square_root + + use kind_parameters, only: dp + use m_error_v, only: ErrorV + use m_result_gen, only: ResultGen, T_DP, T_ERR + + implicit none + private + + public :: get_square_root + +contains + + function get_square_root(inv) result(res) + !! Get square root of a number + + real(kind=dp), intent(in) :: inv + !! Frequency + character(len=:), allocatable :: msg + character(len=10) :: input_char + + type(ResultGen) :: res + !! Result + !! + !! Square root if the number is positive or zero. + !! Error otherwise. + + if (inv >= 0) then + call res % build(tag=T_DP,data_dp=sqrt(inv)) + else + write(input_char, "(F9.3)") inv + msg = adjustl(trim("Error: Negative Input -> "// adjustl(trim(input_char)))) + + call res % build(tag=T_ERR,error_v=ErrorV(code=1, message=msg)) + end if + + end function get_square_root + +end module m_get_square_root diff --git a/src/example_fgen_basic/get_square_root.py b/src/example_fgen_basic/get_square_root.py new file mode 100644 index 0000000..6027388 --- /dev/null +++ b/src/example_fgen_basic/get_square_root.py @@ -0,0 +1,71 @@ +""" +Get square root of a number +""" + +from __future__ import annotations + +from example_fgen_basic.pyfgen_runtime.exceptions import ( + CompiledExtensionNotFoundError, + FortranError, +) +from example_fgen_basic.result import ResultGen + +try: + from example_fgen_basic._lib import m_get_square_root_w # type: ignore +except (ModuleNotFoundError, ImportError) as exc: # pragma: no cover + raise CompiledExtensionNotFoundError( + "example_fgen_basic._lib.m_get_square_root_w" + ) from exc + +try: + from example_fgen_basic._lib import m_result_w +except (ModuleNotFoundError, ImportError) as exc: # pragma: no cover + raise CompiledExtensionNotFoundError("example_fgen_basic._lib.m_result_w") from exc + + +def get_square_root(inv: float) -> float: + """ + Get square root + + Parameters + ---------- + inv + Value for which to get the square root + + Returns + ------- + : + Square root of `inv` + + Raises + ------ + FortranError + `inv` is negative + + TODO: use a more specific error + """ + result_instance_index: int = m_get_square_root_w.get_square_root(inv) + result = ResultGen.from_instance_index(result_instance_index) + + if result.error_v is not None: + # TODO: be more specific + # m_result_w.finalise_instance(result_instance_index) + raise FortranError(result.error_v.code, result.error_v.message) + # raise LessThanZeroError(result.error_v.message) + + if result.data_v is None: + raise AssertionError + + res = result.data_v + + # TODO: think + # I like the clarity of finalising result_instance_index here + # by having an explicit call + # (so you can see creation and finalisation in same place). + # (Probably the above is my preferred right now, but we should think about it.) + # I like the safety of finalising in `from_instance_index`. + # if not finalised(result_instance_index): + # finalise(result_instance_index) + m_result_w.finalise_instance(result_instance_index) + + return res diff --git a/src/example_fgen_basic/get_square_root_wrapper.f90 b/src/example_fgen_basic/get_square_root_wrapper.f90 new file mode 100644 index 0000000..b572c25 --- /dev/null +++ b/src/example_fgen_basic/get_square_root_wrapper.f90 @@ -0,0 +1,66 @@ +!> Wrapper for interfacing `m_get_square_root` with python +module m_get_square_root_w + + use m_result_gen, only: ResultGen,T_ERR + + use m_get_square_root, only: o_get_square_root => get_square_root + + ! The manager module, which makes this all work + use m_result_manager, only: & + result_manager_get_available_instance_index => get_available_instance_index, & + result_manager_set_instance_index_to => set_instance_index_to, & + result_manager_ensure_array_capacity_for_instances => ensure_array_capacity_for_instances + + implicit none + private + + public :: get_square_root + +contains + + function get_square_root(inv) result(res_instance_index) + + ! Annoying that this has to be injected everywhere, + ! but ok it can be automated. + integer, parameter :: dp = selected_real_kind(15, 307) + + real(kind=dp), intent(in) :: inv + !! inv + + integer :: res_instance_index + !! Instance index of the result type + + type(ResultGen) :: res + type(ResultGen) :: res_get_available_instance_index + type(ResultGen) :: res_chk + + res = o_get_square_root(inv) + + call result_manager_ensure_array_capacity_for_instances(1) + + ! Get the instance index to return to Python + ! res_get_available_instance_index = result_dp_manager_get_available_instance_index() + call result_manager_get_available_instance_index(res_instance_index,res_chk) + + ! Logic here is trickier. + ! If you can't create a result type to return to Python, + ! then you also can't return errors so you're a bit cooked. + + ! Set the derived type value in the manager's array, + ! ready for its attributes to be retrieved from Python. + ! MZ it would be probably good to check "res_chk" for errors + ! res_chk = result_dp_manager_set_instance_index_to(res_instance_index, res) + if (res%tag == T_ERR) then + call result_manager_set_instance_index_to(instance_index=res_instance_index,& + error_v=res%error_v, res_check = res_chk) + return + end if + + call result_manager_set_instance_index_to(instance_index=res_instance_index,& + data_dp=res%data_dp, res_check = res_chk) + + ! res_instance_index = int(res_get_available_instance_index % data_v, kind = 4) + + end function get_square_root + +end module m_get_square_root_w diff --git a/src/example_fgen_basic/get_wavelength.f90 b/src/example_fgen_basic/get_wavelength.f90 index 7edbcf3..abe43e4 100644 --- a/src/example_fgen_basic/get_wavelength.f90 +++ b/src/example_fgen_basic/get_wavelength.f90 @@ -7,7 +7,7 @@ module m_get_wavelength use kind_parameters, only: dp - implicit none (type, external) + implicit none private real(kind=dp), parameter, public :: speed_of_light = 2.99792e8_dp diff --git a/src/example_fgen_basic/get_wavelength_wrapper.f90 b/src/example_fgen_basic/get_wavelength_wrapper.f90 index 8aa3b49..c983c12 100644 --- a/src/example_fgen_basic/get_wavelength_wrapper.f90 +++ b/src/example_fgen_basic/get_wavelength_wrapper.f90 @@ -15,7 +15,7 @@ module m_get_wavelength_w ! Convention to date: just suffix wrappers with _w ! and the original function should have the same name. ! ("o_" for original) - implicit none (type, external) + implicit none private public :: get_wavelength diff --git a/src/example_fgen_basic/kind_parameters.f90 b/src/example_fgen_basic/kind_parameters.f90 index 4e7378e..b90dfdd 100644 --- a/src/example_fgen_basic/kind_parameters.f90 +++ b/src/example_fgen_basic/kind_parameters.f90 @@ -2,7 +2,7 @@ !> See https://fortran-lang.org/learn/best_practices/floating_point/ module kind_parameters - implicit none (type, external) + implicit none private !> Single precision real numbers, 6 digits, range 10⁻³⁷ to 10³⁷-1; 32 bits diff --git a/src/example_fgen_basic/meson.build b/src/example_fgen_basic/meson.build index 8c67049..2da4c2d 100644 --- a/src/example_fgen_basic/meson.build +++ b/src/example_fgen_basic/meson.build @@ -1,7 +1,24 @@ srcs += files( 'error_v/creation.f90', 'error_v/error_v.f90', + 'error_v/passing.f90', + 'error_v/creation_wrapper.f90', + 'error_v/error_v_manager.f90', + 'error_v/error_v_wrapper.f90', + 'error_v/passing_wrapper.f90', 'fpyfgen/base_finalisable.f90', 'get_wavelength.f90', 'kind_parameters.f90', + # 'result/result_dp_manager.f90', + # 'result/result_dp_wrapper.f90', + # 'result/result_int1D.f90', + # 'result/result_int_manager.f90', + # 'result/result_int_wrapper.f90', + # 'result/result_dp.f90', + # 'result/result.f90', + # 'result/result_int.f90', + # 'result/result_none.f90', + 'result/result_gen.f90', + 'result/result_manager.f90', + 'result/result_wrapper.f90', ) diff --git a/src/example_fgen_basic/pyfgen_runtime/exceptions.py b/src/example_fgen_basic/pyfgen_runtime/exceptions.py index 0edd2ed..9a34751 100644 --- a/src/example_fgen_basic/pyfgen_runtime/exceptions.py +++ b/src/example_fgen_basic/pyfgen_runtime/exceptions.py @@ -18,6 +18,12 @@ def __init__(self, compiled_extension_name: str): super().__init__(error_msg) +class FortranError(Exception): + """ + Base class for errors that originated on the Fortran side + """ + + class MissingOptionalDependencyError(ImportError): """ Raised when an optional dependency is missing diff --git a/src/example_fgen_basic/result/__init__.py b/src/example_fgen_basic/result/__init__.py new file mode 100644 index 0000000..9531709 --- /dev/null +++ b/src/example_fgen_basic/result/__init__.py @@ -0,0 +1,7 @@ +""" +Definition of result values +""" + +from example_fgen_basic.result.result_gen import ResultGen + +__all__ = ["ResultGen"] diff --git a/src/example_fgen_basic/result/result_gen.f90 b/src/example_fgen_basic/result/result_gen.f90 new file mode 100644 index 0000000..8eba654 --- /dev/null +++ b/src/example_fgen_basic/result/result_gen.f90 @@ -0,0 +1,171 @@ +module m_result_gen + + use kind_parameters, only: dp,i8 + use m_error_v, only: ErrorV + + implicit none + private + + integer, parameter, public :: T_NONE = 0, T_CLAIM = -1, & + T_INT = 1, T_DP = 2, T_ERR = 3 + + type, public :: ResultGen + + integer :: tag = T_NONE + class(ErrorV), allocatable :: error_v + + integer(kind=i8) :: data_int + real(kind=dp) :: data_dp + contains + procedure :: is_free => is_none + procedure :: is_error + procedure :: is_int + procedure :: is_dp + procedure :: build + procedure :: finalise + final :: finalise_auto + end type ResultGen + + interface ResultGen + module procedure :: constructor + end interface + +contains +! ------------------ Constructor ------------------------- + function constructor(tag,data_int,data_dp,error_v) result(self) + + type(ResultGen) :: self + type(ResultGen) :: res_check + + integer(kind=i8), optional, intent(in) :: data_int + real(kind=dp), optional, intent(in) :: data_dp + type(ErrorV), optional, intent(in) :: error_v + + integer, intent(in) :: tag + + call self % build (tag = tag, data_int = data_int, data_dp = data_dp,& + error_v = error_v, res=res_check) + + if (res_check % is_error()) then + print *, res_check % error_v % message + error stop + end if + + end function constructor + +! ------------------ Setter ------------------------- + subroutine build(self,tag,data_int,data_dp,error_v,res) + + class(ResultGen),intent(out) :: self + type(ResultGen),intent(out), optional :: res + + type(ErrorV), intent(in), optional :: error_v + real(kind=dp), intent(in), optional :: data_dp + integer(kind=i8), intent(in), optional :: data_int + integer, intent(in) :: tag + + self % tag = tag + + if (tag == T_CLAIM) then + return + else if (present(data_int) .and. tag == T_INT) then + self % data_int = data_int + else if (present(data_dp) .and. tag == T_DP)then + self % data_dp = data_dp + else if (present(error_v) .and. tag == T_ERR)then + allocate(self % error_v, source = error_v) + else + ! MZ is it really needed? + res % error_v % code = 11 + res % error_v % message = "Build Error: TAG / INPUT mismatch" + end if + + end subroutine build + +! ------------------ Destructor ------------------------- + + subroutine finalise(self) + + class(ResultGen),intent(inout) :: self + + self%tag = T_NONE + if (allocated(self % error_v)) deallocate(self % error_v) + + end subroutine finalise + + subroutine finalise_auto(self) + + type(ResultGen),intent(inout) :: self + + call self % finalise() + + end subroutine finalise_auto + +! ------------------ Checker ------------------------- + pure logical function is_none(self) + + class(ResultGen), intent(in) :: self + + is_none = (self % tag == T_NONE) + + end function is_none + + pure logical function is_error(self) + + class(ResultGen), intent(in) :: self + + if (self % tag == T_ERR) then + is_error = allocated(self % error_v) + ! MZ : might make sense to check tag/allocation mismatch? + else + is_error = .false. + end if + + end function is_error + + pure logical function is_int(self) + + class(ResultGen), intent(in) :: self + + is_int = (self % tag == T_INT) + + end function is_int + + pure logical function is_dp(self) + + class(ResultGen), intent(in) :: self + + is_dp = (self % tag == T_DP) + + end function is_dp + +! ------------------ Getter ------------------------- + ! + ! pure function get_int(self) result(data_int) + ! + ! class(ResultGen), intent(in) :: self + ! integer(kind=i8) :: data_int + ! + ! data_int = self % data_int + ! + ! end function get_int + ! + ! pure function get_dp(self) result(data_dp) + ! + ! class(ResultGen), intent(in) :: self + ! real(kind=dp) :: data_dp + ! + ! data_dp = self % data_dp + ! + ! end function get_dp + ! + ! function get_error(self) result(error_v) + ! + ! class(ResultGen), intent(in) :: self + ! type(ErrorV) :: error_v + ! + ! error_v = self % error_v + ! + ! end function get_error + +end module m_result_gen diff --git a/src/example_fgen_basic/result/result_gen.py b/src/example_fgen_basic/result/result_gen.py new file mode 100644 index 0000000..0bedf30 --- /dev/null +++ b/src/example_fgen_basic/result/result_gen.py @@ -0,0 +1,124 @@ +""" +Python equivalent of the Fortran `ResultGen` class +""" + +from __future__ import annotations + +from attrs import define + +from example_fgen_basic.error_v import ErrorV +from example_fgen_basic.pyfgen_runtime.exceptions import CompiledExtensionNotFoundError + +try: + from example_fgen_basic._lib import ( # type: ignore + m_result_w, + ) +except (ModuleNotFoundError, ImportError) as exc: # pragma: no cover + raise CompiledExtensionNotFoundError("example_fgen_basic._lib.m_result_w") from exc + + +@define +class ResultGen: + """ + Result type that can hold values + """ + + data_v: int | float | None + """ Data""" + + error_v: ErrorV | None + """Error""" + + """ + Parameters: + """ + __fs_int = m_result_w.s_int + __fs_dp = m_result_w.s_dp + __fs_err = m_result_w.s_err + + @classmethod + def from_instance_index(cls, instance_index: int) -> ResultGen: + """ + Get from an instance index received from Fortran + + Parameters + ---------- + instance_index + Instance index received form Fortran + + Returns + ------- + : + Initialised index + """ + valid_instance = m_result_w.probe_instance(instance_index) + + if valid_instance != instance_index: + instance_index = valid_instance + + tag = m_result_w.get_instance_tag(instance_index) + + if tag == cls.__fs_int: + data_v: int | None = m_result_w.get_data_int(instance_index) + error_v = None + + elif tag == cls.__fs_dp: + data_v: float | None = m_result_w.get_data_dp(instance_index) + error_v = None + + elif tag == cls.__fs_err: + data_v = None + error_tuple: tuple[int | None, str | None] = m_result_w.get_error( + instance_index + ) + code, message = error_tuple + error_v = ErrorV(code=code, message=message) + else: + print("ERRRORRR") + + res = cls(data_v=data_v, error_v=error_v) + + return res + + @classmethod + def free_fortran_memory(cls) -> None: + """ + Initialise from an instance index received from Fortran + + Parameters + ---------- + instance_index + None + + Returns + ------- + : + None: It just frees memory + """ + m_result_w.free_resources() + + def build_fortran_instance(self) -> int: + """ + Build an instance equivalent to `self` on the Fortran side + + Intended for use mainly by wrapping functions. + Most users should not need to use this method directly. + + Returns + ------- + : + Instance index of the object which has been created on the Fortran side + """ + if (self.data_v is None) & (self.error_v is not None): + instance_index: int = m_result_w.build_instance_err( + self.error_v.code, self.error_v.message + ) + elif isinstance(self.data_v, int): + instance_index: int = m_result_w.build_instance_int(self.data_v) + elif isinstance(self.data_v, float): + instance_index: int = m_result_w.build_instance_dp(self.data_v) + else: + msg = f"data_v={self.data_v}, error_v={self.error_v}" + raise KeyError(msg) + + return instance_index diff --git a/src/example_fgen_basic/result/result_manager.f90 b/src/example_fgen_basic/result/result_manager.f90 new file mode 100644 index 0000000..77d774f --- /dev/null +++ b/src/example_fgen_basic/result/result_manager.f90 @@ -0,0 +1,306 @@ +module m_result_manager + + use kind_parameters, only: dp,i8 + use m_error_v, only: ErrorV + use m_error_v_manager, only: error_v_manager_build_instance => build_instance + use m_result_gen, only: ResultGen, T_CLAIM, T_NONE, T_INT, T_DP, T_ERR + + implicit none + private + + type(ResultGen), allocatable, dimension(:) :: instance_array + + public :: build_instance, finalise_instance,& + set_instance_index_to, get_available_instance_index, get_instance, probe_instance,& + force_claim_instance_index, check_index_claimed, & + ensure_array_capacity_for_instances, deallocate_instance_array + +contains + + subroutine build_instance(tag, data_int, data_dp, error_v, instance_index, res_check) + + integer, intent(in) :: tag + integer(kind=i8), optional, intent(in) :: data_int + real(kind=dp), optional, intent(in) :: data_dp + type(ErrorV), optional, intent(in) :: error_v + + integer, intent(out) :: instance_index + type(ResultGen),optional, intent(out) :: res_check + integer :: cause + + call ensure_array_capacity_for_instances(1) + + call get_available_instance_index(instance_index,res_check) + + if (res_check % is_error()) then + !Already hit an error, quick return + return + end if + + ! CHECK whether the instance_array(instance_index) % tag = T_CLAIM ? + call instance_array(instance_index) % & + build(tag=tag,data_int=data_int,data_dp=data_dp,& + error_v=error_v,res=res_check) + + if (.not. res_check % is_error()) then + ! All happy + return + end if + ! + ! Error occured + ! + ! Free the slot again + ! + call instance_array(instance_index) % build(tag=T_NONE) + + ! Bubble the error up. + ! This is a good example of where stacking errors would be nice. + ! It would be great to be able to say, + ! "We got an instance index, + ! but when we tried to build the instance, + ! the following error occured...". + ! (Stacking error messages like this + ! would even let us do stack traces in a way...) + ! res_check = ResultGen(tag=T_ERR,error_v = ErrorV(code=1, message=("Build error : "), cause=res_check%error_v)) + + ! MZ here we build an instance into the ErrorV instance array and we return the correspondant index + cause = error_v_manager_build_instance(code = res_check % error_v % code, message = res_check % error_v % message) + + call instance_array(instance_index) % & + build(tag=T_ERR, error_v = ErrorV(code=1, message=("Build Instance error : "), cause=cause)) + + end subroutine build_instance + + subroutine finalise_instance(instance_index) + !! Finalise an instance + + integer, intent(in) :: instance_index + !! Index of the instance to finalise + + type(ResultGen) :: res_check_index_claimed + + res_check_index_claimed = check_index_claimed(instance_index) + ! MZ how do we handle unsuccefull finalisation? + ! if(res_check_index_claimed%is_error()) return + call instance_array(instance_index) % finalise() + + end subroutine finalise_instance + + subroutine set_instance_index_to(instance_index, data_int, data_dp, error_v, res_check) + + integer, intent(in) :: instance_index + integer(kind=i8),optional, intent(in) :: data_int + real(kind=dp),optional, intent(in) :: data_dp + type(ErrorV),optional, intent(in) :: error_v + + type(ResultGen), intent(out) :: res_check + + integer :: input_check + + input_check = merge(1,0,present(data_int)) + merge(1,0,present(data_dp)) + merge(1,0,present(error_v)) + + if (input_check == 0) then + + call res_check % build (tag = T_ERR,& + error_v = ErrorV(code=1,message="Setting instance ERROR: Empty Input")) + + else if (input_check > 1) then + + call res_check % build (tag = T_ERR,& + error_v = ErrorV(code=1,message="Setting instance ERROR: Multiple Input")) + + else + + if(present(data_int)) then + call instance_array(instance_index) % build (tag = T_INT,data_int=data_int) + else if(present(data_dp)) then + call instance_array(instance_index) % build (tag = T_DP,data_dp=data_dp) + else if(present(error_v)) then + call instance_array(instance_index) % build (tag = T_ERR,error_v = error_v) + end if + + end if + + end subroutine set_instance_index_to + +! ---------------- Getters --------------------- + function probe_instance(instance_index) result(res_instance_index) + + integer, intent(in) :: instance_index + type(ResultGen) :: res_check_index_claimed,res_check + integer :: errorv_instance_index + integer :: res_instance_index + + res_check_index_claimed = check_index_claimed(instance_index) + + if(res_check_index_claimed % tag /= T_CLAIM) then + + errorv_instance_index = error_v_manager_build_instance (res_check_index_claimed%error_v% code,& + res_check_index_claimed%error_v% message) + + call build_instance (tag = T_ERR,& + error_v = ErrorV(code=1,message="Probe instance ERROR: ",cause=errorv_instance_index),& + instance_index = res_instance_index, & + res_check=res_check & + ) + + ! if (.not. res_check % is_error()) then + return + ! end if + + end if + + res_instance_index = instance_index + + end function probe_instance + + function get_instance(instance_index) result(res_gen) + + integer, intent(in) :: instance_index + type(ResultGen) :: res_gen + + res_gen = instance_array(instance_index) + + end function get_instance + + ! pure subroutine get_available_instance_index(available_instance_index,res_check) + subroutine get_available_instance_index(available_instance_index,res_check) + !! Get a free instance index + + ! TODO: think through whether race conditions are possible + ! e.g. while returning a free index number to one Python call + ! a different one can be looking up a free instance index at the same time + ! and something goes wrong (maybe we need a lock) + type(ResultGen), intent(out), optional :: res_check + integer, intent(out) :: available_instance_index + !! Available instance index + character(len=:), allocatable :: msg + character(len=20) :: str_size_array + integer :: i + + if(allocated(instance_array)) then + do i = 1, size(instance_array) + + if (instance_array(i)%tag == 0) then + !MZ: check the tag, is it very slow? + !MZ: design choice -> getting an index sets its availabilty(?) (similar to malloc) + instance_array(i)%tag = T_CLAIM + available_instance_index = i + return + + end if + + end do + + write(str_size_array, "(I0)") size(instance_array) + msg = "FULL ARRAY: None of the " // trim(adjustl(str_size_array)) // " slots is available" + + else + msg = "instance_array NOT allocated" + end if + + available_instance_index = -1 + call res_check % build(tag=T_ERR, & + error_v=ErrorV( & + code=1, & + message=msg & + ) & + ) + + end subroutine get_available_instance_index + +! ---------------- Array management --------------------- + + ! pure function check_index_claimed(instance_index) result(res_check_index_claimed) + function check_index_claimed(instance_index) result(res_check_index_claimed) + !! Check that an index has already been claimed + + integer, intent(in) :: instance_index + !! Instance index to check + type(ResultGen) :: res_check_index_claimed + character(len=20) :: idx_str + character(len=:), allocatable :: msg + + if (.not. allocated(instance_array)) then + + msg = "instance array in NOT allocated" + call res_check_index_claimed % build(tag=T_ERR,error_v=ErrorV(code=3, message=msg)) + return + + end if + + write(idx_str, "(I0)") instance_index + + if (instance_index < 1 .or. instance_index > size(instance_array)) then + msg = "Requested index is: " // trim(adjustl(idx_str)) // " ==> out of boundary" + call res_check_index_claimed % build(tag=T_ERR,error_v=ErrorV(code=3, message=msg)) + + return + end if + + if (instance_array(instance_index)%tag==T_NONE) then + + msg = "Index " // trim(adjustl(idx_str)) // " has not been claimed" + call res_check_index_claimed % build(tag=T_ERR,error_v=ErrorV(code=3, message=msg)) + + return + end if + + call res_check_index_claimed % build(tag=T_CLAIM) + + end function check_index_claimed + + subroutine ensure_array_capacity_for_instances(n) + !! Ensure that `instance_array` has at least `n` slots + + integer, intent(in) :: n + + type(ResultGen), dimension(:), allocatable :: tmp_instances + integer :: free_count + + if (.not. allocated(instance_array)) then + + allocate (instance_array(n)) + + else if (size(instance_array) < n) then + ! MZ: in this case we just add n spaces on top + + allocate(tmp_instances(n+size(instance_array))) + tmp_instances(1:size(instance_array)) = instance_array + call move_alloc(tmp_instances, instance_array) + + else + + free_count = count(instance_array%tag == 0) + + 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_instances(1:size(instance_array)) = instance_array + call move_alloc(tmp_instances, instance_array) + end if + + end if + + end subroutine ensure_array_capacity_for_instances + + subroutine force_claim_instance_index(instance_index) + !! Ensure that `instance_array` has at least `n` slots + + integer, intent(in) :: instance_index + + instance_array(instance_index)%tag = T_CLAIM + + end subroutine force_claim_instance_index + + subroutine deallocate_instance_array() + + if (allocated (instance_array))then + deallocate(instance_array) + else + print *, "instance_array NOT allocated" + end if + + end subroutine deallocate_instance_array + +end module m_result_manager diff --git a/src/example_fgen_basic/result/result_wrapper.f90 b/src/example_fgen_basic/result/result_wrapper.f90 new file mode 100644 index 0000000..99ae6d5 --- /dev/null +++ b/src/example_fgen_basic/result/result_wrapper.f90 @@ -0,0 +1,285 @@ +module m_result_w + + ! use kind_parameters, only: dp, i8 + use m_error_v, only: ErrorV + use m_result_gen, only: ResultGen, T_CLAIM, T_NONE, T_INT, T_DP, T_ERR + + ! The manager module, which makes this all work + use m_error_v_manager, only: & + error_v_manager_get_instance => get_instance, & + error_v_manager_get_available_instance_index => get_available_instance_index, & + error_v_manager_get_error_message => get_error_message, & + error_v_manager_set_instance_index_to => set_instance_index_to, & + error_v_manager_deallocate_instance_arrays => deallocate_instance_arrays + + use m_result_manager, only: & + result_manager_build_instance => build_instance, & + result_manager_finalise_instance => finalise_instance, & + result_manager_get_instance => get_instance, & + result_manager_probe_instance => probe_instance, & + result_manager_ensure_array_capacity_for_instances => ensure_array_capacity_for_instances, & + result_manager_force_claim_instance_index => force_claim_instance_index, & + result_manager_set_instance_index_to => set_instance_index_to, & + result_manager_check_index_claimed => check_index_claimed, & + result_manager_deallocate_instance_array => deallocate_instance_array + + implicit none + private + + public :: build_instance_int, build_instance_dp, build_instance_err,& + finalise_instance, finalise_instances, free_resources,& + get_instance_tag, get_data_int, get_data_dp, get_error, & + probe_instance + + integer, parameter, public :: s_claimed=T_CLAIM, s_none=T_NONE, s_int=T_INT, s_dp=T_DP, s_err=T_ERR + +contains + +! ---------------- Builders --------------------- + function build_instance_int(data_int) result(instance_index) + + integer, parameter :: i8 = selected_int_kind(18) + integer(kind=i8), intent(in) :: data_int + + integer :: instance_index + + type(ResultGen) :: res_check + + ! Setting Result with data + call result_manager_build_instance(& + tag = T_INT, & + data_int = data_int, & + instance_index= instance_index,& + res_check = res_check & + ) + + if (res_check % is_error()) then + ! FAILED build + ! + ! Could not allocate a result type to handle the return to Python. + ! + call escape_hatch(instance_index) + + end if + + end function build_instance_int + + function build_instance_dp(data_dp) result(instance_index) + + integer, parameter :: dp = selected_real_kind(15, 307) + real(kind=dp), intent(in) :: data_dp + + integer :: instance_index + + type(ResultGen) :: res_check + + ! Setting Result with data + call result_manager_build_instance(& + tag = T_DP, & + data_dp = data_dp, & + instance_index= instance_index,& + res_check = res_check & + ) + + if (res_check % is_error()) then + ! FAILED build + ! + ! Could not allocate a result type to handle the return to Python. + ! + call escape_hatch(instance_index) + + end if + + end function build_instance_dp + + function build_instance_err(code,message) result(instance_index) + + integer, intent(in) :: code + character(len=*), intent(in) :: message + + integer :: instance_index + + type(ErrorV) :: error_v + type(ResultGen) :: res_check + if (code > 0) then + +! error_v = error_v_manager_get_instance(error_v_instance_index) + call error_v % build(code=code, message=message) + + ! Setting Result with error + call result_manager_build_instance(& + tag = T_ERR, & + error_v = error_v, & + instance_index= instance_index,& + res_check = res_check & + ) + + else + + call error_v % build(code = 1, message = "Provided code does NOT match any ERROR type") + call result_manager_build_instance(& + tag = T_ERR, & + error_v = error_v, & + instance_index= instance_index,& + res_check = res_check & + ) + + end if + + if (res_check % is_error() .and. instance_index==-1) then + ! FAILED build + ! + ! Could not allocate a result type to handle the return to Python. + ! + call escape_hatch(instance_index) + + end if + + end function build_instance_err + +! ---------------- Getters --------------------- + function probe_instance(instance_index) result(err_index) + + integer, intent(in) :: instance_index + integer :: err_index + + err_index = result_manager_probe_instance(instance_index) + + end function probe_instance + + ! pure function get_instance_tag(instance_index) result(tag) + function get_instance_tag(instance_index) result(tag) + + integer, intent(in) :: instance_index + integer :: tag + + type(ResultGen) :: res_stored + + res_stored = result_manager_get_instance(instance_index) + + tag = res_stored % tag + + end function get_instance_tag + + function get_data_int(instance_index) result(data_int) + + integer, parameter :: i8 = selected_int_kind(18) + integer, intent(in) :: instance_index + integer(kind=i8) :: data_int + + type(ResultGen) :: res_stored + + res_stored = result_manager_get_instance(instance_index) + + data_int = res_stored % data_int + + end function get_data_int + + function get_data_dp(instance_index) result(data_dp) + + integer, parameter :: dp = selected_real_kind(15, 307) + integer, intent(in) :: instance_index + real(kind=dp) :: data_dp + + type(ResultGen) :: res_stored + + res_stored = result_manager_get_instance(instance_index) + + data_dp = res_stored % data_dp + + end function get_data_dp + + ! NOT entirely sure of what should happen here: discuss with Zeb + subroutine get_error(instance_index,code,message) + + integer, intent(in) :: instance_index + integer, intent(out) :: code + ! MZ: How to avoid long fixed length?? + character(len=1000), intent(out) :: message + character(len=10) :: int2char + type(ResultGen) :: res_stored + + res_stored = result_manager_get_instance(instance_index) + + ! Think if it is worth checking as the Python side should already deal with it. Should be built an error? + if(res_stored % tag /= T_ERR) then + ! ERROR in a smarter way? + code = 1 + write(int2char,"(I0)") instance_index + message = "TAG mismatch! Expected -> ERROR but index: " // adjustl(trim(int2char)) + write(int2char,"(I0)") res_stored % tag + message = adjustl(trim(message)) // " has TAG = " // adjustl(trim(int2char)) + return + end if + + code = res_stored % error_v % code + message = error_v_manager_get_error_message(res_stored%error_v) + + end subroutine get_error + +! ---------------- Destructor --------------------- + subroutine finalise_instance(instance_index) + !! Finalise an instance + + integer, intent(in) :: instance_index + !! Instance index + ! + ! This is the major trick for wrapping. + ! We pass instance indexes (integers) to Python rather than the instance itself. + + call result_manager_finalise_instance(instance_index) + + end subroutine finalise_instance + + subroutine finalise_instances(instance_indexes) + !! Finalise an instance + + integer, dimension(:), intent(in) :: instance_indexes + !! Instance indexes to finalise + integer :: i + + do i = 1, size(instance_indexes) + call result_manager_finalise_instance(instance_indexes(i)) + end do + + end subroutine finalise_instances + + subroutine free_resources() + call result_manager_deallocate_instance_array() + call error_v_manager_deallocate_instance_arrays() + end subroutine free_resources + +! ---------------- Auxiliar --------------------- + subroutine escape_hatch(instance_index) + + integer, intent(out) :: instance_index + + type(ResultGen) :: res_check + + ! Logic here is trickier. + ! If you can't create a result type to return to Python, + ! then you also can't return errors so you're stuck. + ! As an escape hatch + call result_manager_ensure_array_capacity_for_instances(1) + instance_index = 1 + + ! Just use the first instance and write a message that the program + ! is fully broken. + res_check = ResultGen(tag=T_ERR,& + error_v = ErrorV( & + code=1, & + message=( & + "I wanted to return an error, " & + // "but I couldn't even get an available instance to do so. " & + // "I have forced a return, but your program is probably fully broken. " & + // "Please be very careful." & + ) & + ) & + ) + + call result_manager_force_claim_instance_index(instance_index) + call result_manager_set_instance_index_to(instance_index=instance_index,res_check=res_check) + + end subroutine escape_hatch + +end module m_result_w diff --git a/tests/unit/test_error_v_creation.f90 b/tests/unit/test_error_v_creation.f90 index b5b8d85..fa1939f 100644 --- a/tests/unit/test_error_v_creation.f90 +++ b/tests/unit/test_error_v_creation.f90 @@ -27,7 +27,7 @@ end subroutine collect_error_v_creation_tests subroutine test_error_v_creation_basic(error) use m_error_v, only: ErrorV - use m_error_v_passing, only: create_error + use m_error_v_creation, only: create_error type(error_type), allocatable, intent(out) :: error @@ -46,7 +46,7 @@ end subroutine test_error_v_creation_basic subroutine test_error_v_creation_edge(error) use m_error_v, only: ErrorV - use m_error_v_passing, only: create_error + use m_error_v_creation, only: create_error type(error_type), allocatable, intent(out) :: error diff --git a/tests/unit/test_error_v_creation.py b/tests/unit/test_error_v_creation.py index b3d3c7e..53ae51d 100644 --- a/tests/unit/test_error_v_creation.py +++ b/tests/unit/test_error_v_creation.py @@ -3,9 +3,11 @@ """ import numpy as np +import pytest from example_fgen_basic.error_v import ErrorV from example_fgen_basic.error_v.creation import create_error, create_errors +from example_fgen_basic.pyfgen_runtime.exceptions import FortranError def test_create_error_odd(): @@ -21,19 +23,16 @@ def test_create_error_even(): res = create_error(2.0) assert isinstance(res, ErrorV) - assert res.code != 0 assert res.code == 1 assert res.message == "Even number supplied" -def test_create_error_negative(): - res = create_error(-1.0) - - assert isinstance(res, ErrorV) - - assert res.code == 2 - assert res.message == "Negative number supplied" +@pytest.mark.xfail(reason="Not implemented") +def test_create_error_negative_raises(): + # TODO: switch to more precise error type + with pytest.raises(FortranError): + create_error(-1.0) def test_create_error_lots_of_repeated_calls(): diff --git a/tests/unit/test_get_square_root.py b/tests/unit/test_get_square_root.py new file mode 100644 index 0000000..1d64ca7 --- /dev/null +++ b/tests/unit/test_get_square_root.py @@ -0,0 +1,33 @@ +""" +Tests of `example_fgen_basic.get_square_root` +""" + +import pytest + +from example_fgen_basic.get_square_root import get_square_root +from example_fgen_basic.pyfgen_runtime.exceptions import ( + FortranError, +) + + +@pytest.mark.parametrize( + "inv, exp, exp_error", + [ + (4.0, 2.0, None), + ( + -4.0, + None, + pytest.raises(FortranError, match="Error: Negative Input -> -4.000"), + ), + ], +) +def test_basic(inv, exp, exp_error): + if exp is not None: + assert get_square_root(inv) == exp + + else: + if exp_error is None: + raise AssertionError + + with exp_error: + get_square_root(inv) diff --git a/tests/unit/test_result_gen.py b/tests/unit/test_result_gen.py new file mode 100644 index 0000000..aa8d1c7 --- /dev/null +++ b/tests/unit/test_result_gen.py @@ -0,0 +1,90 @@ +""" +Tests of `example_fgen_basic.error_v.creation` +""" + +from example_fgen_basic.error_v import ErrorV +from example_fgen_basic.result import ResultGen + + +def test_create_integer_result(): + ResultGen.free_fortran_memory() + + result_in = ResultGen(data_v=42, error_v=None) + + result_instance_index = result_in.build_fortran_instance() + result_out = ResultGen.from_instance_index(result_instance_index) + + assert result_in.data_v == result_out.data_v + assert result_in.error_v == result_out.error_v + + +def test_create_float_result(): + ResultGen.free_fortran_memory() + + result_in = ResultGen(data_v=3.21, error_v=None) + + result_instance_index = result_in.build_fortran_instance() + result_out = ResultGen.from_instance_index(result_instance_index) + + assert result_in.data_v == result_out.data_v + assert result_in.error_v == result_out.error_v + + +def test_create_error_result(): + ResultGen.free_fortran_memory() + + result_in = ResultGen(data_v=None, error_v=ErrorV(code=1, message="Error message")) + + result_instance_index = result_in.build_fortran_instance() + result_out = ResultGen.from_instance_index(result_instance_index) + result_out.error_v.message = result_out.error_v.message.decode("utf-8") + + assert result_in.data_v == result_out.data_v + assert result_in.error_v == result_out.error_v + + +def test_create_mix_results(): + ResultGen.free_fortran_memory() + + result_err = ResultGen(data_v=None, error_v=ErrorV(code=1, message="Error message")) + result_dp = ResultGen(data_v=3.21, error_v=None) + result_int = ResultGen(data_v=42, error_v=None) + + results = [result_err, result_int, result_dp] + + for res in results: + result_instance_index = res.build_fortran_instance() + result_out = ResultGen.from_instance_index(result_instance_index) + + if result_out.error_v: + result_out.error_v.message = result_out.error_v.message.decode("utf-8") + + assert res.data_v == result_out.data_v + assert res.error_v == result_out.error_v + + +def test_out_of_alloc_and_bound_error(): + ResultGen.free_fortran_memory() + + result_int = ResultGen(data_v=21, error_v=None) + + result_out = ResultGen.from_instance_index(1) + + if result_out.error_v: + result_out.error_v.message = result_out.error_v.message.decode("utf-8") + + assert ( + result_out.error_v.message + == "Probe instance ERROR:\n Previous error --> instance array in NOT allocated" + ) + + result_instance_index = result_int.build_fortran_instance() + result_out = ResultGen.from_instance_index(result_instance_index + 10) + + if result_out.error_v: + result_out.error_v.message = result_out.error_v.message.decode("utf-8") + + assert ( + result_out.error_v.message + == "Probe instance ERROR:\n Previous error --> Requested index is: 12 ==> out of boundary" # noqa: E501 + )