diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index a753240ec..d65cd416d 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -2,6 +2,7 @@ set(SRC stdlib_experimental_ascii.f90 stdlib_experimental_io.f90 stdlib_experimental_error.f90 + stdlib_experimental_optval.f90 ) add_library(fortran_stdlib ${SRC}) diff --git a/src/Makefile.manual b/src/Makefile.manual index 71b6a8a31..f83c11aa7 100644 --- a/src/Makefile.manual +++ b/src/Makefile.manual @@ -1,6 +1,7 @@ SRC = stdlib_experimental_ascii.f90 \ stdlib_experimental_error.f90 \ stdlib_experimental_io.f90 \ + stdlib_experimental_optval.f90 \ f18estop.f90 LIB = libstdlib.a diff --git a/src/stdlib_experimental_optval.f90 b/src/stdlib_experimental_optval.f90 new file mode 100644 index 000000000..3f42fcee3 --- /dev/null +++ b/src/stdlib_experimental_optval.f90 @@ -0,0 +1,153 @@ +module stdlib_experimental_optval + !! + !! Provides a generic function `optval`, which can be used to + !! conveniently implement fallback values for optional arguments + !! to subprograms. If `x` is an `optional` parameter of a + !! subprogram, then the expression `optval(x, default)` inside that + !! subprogram evaluates to `x` if it is present, otherwise `default`. + !! + !! It is an error to call `optval` with a single actual argument. + !! + use iso_fortran_env, only: sp => real32, dp => real64, qp => real128, int8, int16, int32, int64 + implicit none + + + private + public :: optval + + + interface optval + module procedure optval_sp + module procedure optval_dp + module procedure optval_qp + module procedure optval_int8 + module procedure optval_int16 + module procedure optval_int32 + module procedure optval_int64 + module procedure optval_logical + module procedure optval_character + ! TODO: complex kinds + ! TODO: differentiate ascii & ucs char kinds + end interface optval + + +contains + + + function optval_sp(x, default) result(y) + real(sp), intent(in), optional :: x + real(sp), intent(in) :: default + real(sp) :: y + + if (present(x)) then + y = x + else + y = default + end if + end function optval_sp + + + function optval_dp(x, default) result(y) + real(dp), intent(in), optional :: x + real(dp), intent(in) :: default + real(dp) :: y + + if (present(x)) then + y = x + else + y = default + end if + end function optval_dp + + + function optval_qp(x, default) result(y) + real(qp), intent(in), optional :: x + real(qp), intent(in) :: default + real(qp) :: y + + if (present(x)) then + y = x + else + y = default + end if + end function optval_qp + + + function optval_int8(x, default) result(y) + integer(int8), intent(in), optional :: x + integer(int8), intent(in) :: default + integer(int8) :: y + + if (present(x)) then + y = x + else + y = default + end if + end function optval_int8 + + + function optval_int16(x, default) result(y) + integer(int16), intent(in), optional :: x + integer(int16), intent(in) :: default + integer(int16) :: y + + if (present(x)) then + y = x + else + y = default + end if + end function optval_int16 + + + function optval_int32(x, default) result(y) + integer(int32), intent(in), optional :: x + integer(int32), intent(in) :: default + integer(int32) :: y + + if (present(x)) then + y = x + else + y = default + end if + end function optval_int32 + + + function optval_int64(x, default) result(y) + integer(int64), intent(in), optional :: x + integer(int64), intent(in) :: default + integer(int64) :: y + + if (present(x)) then + y = x + else + y = default + end if + end function optval_int64 + + + function optval_logical(x, default) result(y) + logical, intent(in), optional :: x + logical, intent(in) :: default + logical :: y + + if (present(x)) then + y = x + else + y = default + end if + end function optval_logical + + + function optval_character(x, default) result(y) + character(len=*), intent(in), optional :: x + character(len=*), intent(in) :: default + character(len=:), allocatable :: y + + if (present(x)) then + y = x + else + y = default + end if + end function optval_character + +end module stdlib_experimental_optval diff --git a/src/tests/CMakeLists.txt b/src/tests/CMakeLists.txt index f8544b24a..74f949c7c 100644 --- a/src/tests/CMakeLists.txt +++ b/src/tests/CMakeLists.txt @@ -1,5 +1,6 @@ add_subdirectory(ascii) add_subdirectory(loadtxt) +add_subdirectory(optval) add_executable(test_skip test_skip.f90) target_link_libraries(test_skip fortran_stdlib) diff --git a/src/tests/Makefile.manual b/src/tests/Makefile.manual index 778f3a81a..a7e59d196 100644 --- a/src/tests/Makefile.manual +++ b/src/tests/Makefile.manual @@ -3,11 +3,14 @@ all: $(MAKE) -f Makefile.manual --directory=ascii $(MAKE) -f Makefile.manual --directory=loadtxt + $(MAKE) -f Makefile.manual --directory=optval test: $(MAKE) -f Makefile.manual --directory=ascii test $(MAKE) -f Makefile.manual --directory=loadtxt test + $(MAKE) -f Makefile.manual --directory=optval test clean: $(MAKE) -f Makefile.manual --directory=ascii clean $(MAKE) -f Makefile.manual --directory=loadtxt clean + $(MAKE) -f Makefile.manual --directory=optval clean diff --git a/src/tests/optval/CMakeLists.txt b/src/tests/optval/CMakeLists.txt new file mode 100644 index 000000000..5d6ae159e --- /dev/null +++ b/src/tests/optval/CMakeLists.txt @@ -0,0 +1,4 @@ +add_executable(test_optval test_optval.f90) +target_link_libraries(test_optval fortran_stdlib) + +add_test(NAME OPTVAL COMMAND $) diff --git a/src/tests/optval/Makefile.manual b/src/tests/optval/Makefile.manual new file mode 100644 index 000000000..79b41b2c9 --- /dev/null +++ b/src/tests/optval/Makefile.manual @@ -0,0 +1,4 @@ +PROGS_SRC = test_optval.f90 + + +include ../Makefile.manual.test.mk diff --git a/src/tests/optval/test_optval.f90 b/src/tests/optval/test_optval.f90 new file mode 100644 index 000000000..85d9748c9 --- /dev/null +++ b/src/tests/optval/test_optval.f90 @@ -0,0 +1,151 @@ +program test_optval + use, intrinsic :: iso_fortran_env, only: & + sp => real32, dp => real64, qp => real128, & + int8, int16, int32, int64 + use stdlib_experimental_error, only: assert + use stdlib_experimental_optval, only: optval + + implicit none + + call test_optval_sp + call test_optval_dp + call test_optval_qp + + call test_optval_int8 + call test_optval_int16 + call test_optval_int32 + call test_optval_int64 + + call test_optval_logical + + call test_optval_character + +contains + + + subroutine test_optval_sp + print *, "test_optval_sp" + call assert(foo_sp(1.0_sp) == 1.0_sp) + call assert(foo_sp() == 2.0_sp) + end subroutine test_optval_sp + + + function foo_sp(x) result(z) + real(sp), intent(in), optional :: x + real(sp) :: z + z = optval(x, 2.0_sp) + endfunction foo_sp + + + subroutine test_optval_dp + print *, "test_optval_dp" + call assert(foo_dp(1.0_dp) == 1.0_dp) + call assert(foo_dp() == 2.0_dp) + end subroutine test_optval_dp + + + function foo_dp(x) result(z) + real(dp), intent(in), optional :: x + real(dp) :: z + z = optval(x, 2.0_dp) + endfunction foo_dp + + + subroutine test_optval_qp + print *, "test_optval_qp" + call assert(foo_qp(1.0_qp) == 1.0_qp) + call assert(foo_qp() == 2.0_qp) + end subroutine test_optval_qp + + + function foo_qp(x) result(z) + real(qp), intent(in), optional :: x + real(qp) :: z + z = optval(x, 2.0_qp) + endfunction foo_qp + + + subroutine test_optval_int8 + print *, "test_optval_int8" + call assert(foo_int8(1_int8) == 1_int8) + call assert(foo_int8() == 2_int8) + end subroutine test_optval_int8 + + + function foo_int8(x) result(z) + integer(int8), intent(in), optional :: x + integer(int8) :: z + z = optval(x, 2_int8) + endfunction foo_int8 + + + subroutine test_optval_int16 + print *, "test_optval_int16" + call assert(foo_int16(1_int16) == 1_int16) + call assert(foo_int16() == 2_int16) + end subroutine test_optval_int16 + + + function foo_int16(x) result(z) + integer(int16), intent(in), optional :: x + integer(int16) :: z + z = optval(x, 2_int16) + endfunction foo_int16 + + + subroutine test_optval_int32 + print *, "test_optval_int32" + call assert(foo_int32(1_int32) == 1_int32) + call assert(foo_int32() == 2_int32) + end subroutine test_optval_int32 + + + function foo_int32(x) result(z) + integer(int32), intent(in), optional :: x + integer(int32) :: z + z = optval(x, 2_int32) + endfunction foo_int32 + + + subroutine test_optval_int64 + print *, "test_optval_int64" + call assert(foo_int64(1_int64) == 1_int64) + call assert(foo_int64() == 2_int64) + end subroutine test_optval_int64 + + + function foo_int64(x) result(z) + integer(int64), intent(in), optional :: x + integer(int64) :: z + z = optval(x, 2_int64) + endfunction foo_int64 + + + subroutine test_optval_logical + print *, "test_optval_logical" + call assert(foo_logical(.true.)) + call assert(.not.foo_logical()) + end subroutine test_optval_logical + + + function foo_logical(x) result(z) + logical, intent(in), optional :: x + logical :: z + z = optval(x, .false.) + endfunction foo_logical + + + subroutine test_optval_character + print *, "test_optval_character" + call assert(foo_character("x") == "x") + call assert(foo_character() == "y") + end subroutine test_optval_character + + + function foo_character(x) result(z) + character(len=*), intent(in), optional :: x + character(len=:), allocatable :: z + z = optval(x, "y") + endfunction foo_character + +end program test_optval