From ec6d9007c781d3ae0de54277e6e55e69f34f7268 Mon Sep 17 00:00:00 2001 From: Nathaniel Shaffre Date: Fri, 3 Jan 2020 09:36:50 -0700 Subject: [PATCH 1/6] Preliminary implementation of default values --- src/CMakeLists.txt | 1 + src/Makefile.manual | 2 + src/stdlib_experimental_default.f90 | 142 ++++++++++++++++++++++++++++ 3 files changed, 145 insertions(+) create mode 100644 src/stdlib_experimental_default.f90 diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 20dc511d5..228591734 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_default.f90 ) add_library(fortran_stdlib ${SRC}) diff --git a/src/Makefile.manual b/src/Makefile.manual index 05640fc34..86f73f11a 100644 --- a/src/Makefile.manual +++ b/src/Makefile.manual @@ -1,6 +1,7 @@ OBJS = stdlib_experimental_ascii.o \ stdlib_experimental_error.o \ stdlib_experimental_io.o \ + stdlib_experimental_default.o \ .PHONY: all clean .SUFFIXES: .f90 .o @@ -15,6 +16,7 @@ all: $(OBJS) stdlib_experimental_ascii.o: stdlib_experimental_ascii.f90 stdlib_experimental_error.o: stdlib_experimental_error.f90 stdlib_experimental_io.o: stdlib_experimental_io.f90 +stdlib_experimental_default.o: stdlib_experimental_default.f90 clean: $(RM) *.o *.mod diff --git a/src/stdlib_experimental_default.f90 b/src/stdlib_experimental_default.f90 new file mode 100644 index 000000000..0f3dd3561 --- /dev/null +++ b/src/stdlib_experimental_default.f90 @@ -0,0 +1,142 @@ +module default_m + !! + !! Provides a generic function `default`, 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 `default(x, y)` inside that + !! subprogram evaluates to `x` if it is present, otherwise `y`. + !! + !! It is an error to call `default` with a single actual argument. + !! + !! For additional clarity, `default` be called with keyword argument + !! for the fallback value, e.g., `default(x, to=1.0)`. + !! + use iso_fortran_env, only: sp => real32, dp => real64, qp => real128, int16, int32, int64 + implicit none + + + private + public :: default + + + interface default + module procedure default_sp + module procedure default_dp + module procedure default_qp + module procedure default_int16 + module procedure default_int32 + module procedure default_int64 + module procedure default_logical + module procedure default_character + ! TODO: complex kinds + ! TODO: differentiate ascii & ucs char kinds + end interface default + + +contains + + + function default_sp(x, to) result(y) + real(sp), intent(in), optional :: x + real(sp), intent(in) :: to + real(sp) :: y + + if (present(x)) then + y = x + else + y = to + end if + end function default_sp + + + function default_dp(x, to) result(y) + real(dp), intent(in), optional :: x + real(dp), intent(in) :: to + real(dp) :: y + + if (present(x)) then + y = x + else + y = to + end if + end function default_dp + + + function default_qp(x, to) result(y) + real(qp), intent(in), optional :: x + real(qp), intent(in) :: to + real(qp) :: y + + if (present(x)) then + y = x + else + y = to + end if + end function default_qp + + + function default_int16(x, to) result(y) + integer(int16), intent(in), optional :: x + integer(int16), intent(in) :: to + integer(int16) :: y + + if (present(x)) then + y = x + else + y = to + end if + end function default_int16 + + + function default_int32(x, to) result(y) + integer(int32), intent(in), optional :: x + integer(int32), intent(in) :: to + integer(int32) :: y + + if (present(x)) then + y = x + else + y = to + end if + end function default_int32 + + + function default_int64(x, to) result(y) + integer(int64), intent(in), optional :: x + integer(int64), intent(in) :: to + integer(int64) :: y + + if (present(x)) then + y = x + else + y = to + end if + end function default_int64 + + + function default_logical(x, to) result(y) + logical, intent(in), optional :: x + logical, intent(in) :: to + logical :: y + + if (present(x)) then + y = x + else + y = to + end if + end function default_logical + + + function default_character(x, to) result(y) + character(len=*), intent(in), optional :: x + character(len=*), intent(in) :: to + character(len=:), allocatable :: y + + if (present(x)) then + y = x + else + y = to + end if + end function default_character + +end module default_m From b74d1a8815f12a6384bc95af28bfc00c748ed48b Mon Sep 17 00:00:00 2001 From: nshaffer Date: Fri, 3 Jan 2020 16:28:58 -0700 Subject: [PATCH 2/6] Update src/stdlib_experimental_default.f90 Co-Authored-By: Jeremie Vandenplas --- src/stdlib_experimental_default.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/stdlib_experimental_default.f90 b/src/stdlib_experimental_default.f90 index 0f3dd3561..2677029e7 100644 --- a/src/stdlib_experimental_default.f90 +++ b/src/stdlib_experimental_default.f90 @@ -139,4 +139,4 @@ function default_character(x, to) result(y) end if end function default_character -end module default_m +end module stdlib_experimental_default From ebde8b1494e396d9f92b13f75da2bd52d017bdbd Mon Sep 17 00:00:00 2001 From: nshaffer Date: Fri, 3 Jan 2020 16:29:23 -0700 Subject: [PATCH 3/6] Update src/stdlib_experimental_default.f90 Co-Authored-By: Jeremie Vandenplas --- src/stdlib_experimental_default.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/stdlib_experimental_default.f90 b/src/stdlib_experimental_default.f90 index 2677029e7..f8a2ea4ae 100644 --- a/src/stdlib_experimental_default.f90 +++ b/src/stdlib_experimental_default.f90 @@ -1,4 +1,4 @@ -module default_m +module stdlib_experimental_default !! !! Provides a generic function `default`, which can be used to !! conveniently implement fallback values for optional arguments From 486be15949ec2c6be6850437fbe8872a525f06b7 Mon Sep 17 00:00:00 2001 From: Nathaniel Shaffre Date: Fri, 3 Jan 2020 16:36:40 -0700 Subject: [PATCH 4/6] implement int8 --- src/stdlib_experimental_default.f90 | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/src/stdlib_experimental_default.f90 b/src/stdlib_experimental_default.f90 index f8a2ea4ae..39ebaab5a 100644 --- a/src/stdlib_experimental_default.f90 +++ b/src/stdlib_experimental_default.f90 @@ -11,7 +11,7 @@ module stdlib_experimental_default !! For additional clarity, `default` be called with keyword argument !! for the fallback value, e.g., `default(x, to=1.0)`. !! - use iso_fortran_env, only: sp => real32, dp => real64, qp => real128, int16, int32, int64 + use iso_fortran_env, only: sp => real32, dp => real64, qp => real128, int8, int16, int32, int64 implicit none @@ -23,6 +23,7 @@ module stdlib_experimental_default module procedure default_sp module procedure default_dp module procedure default_qp + module procedure default_int8 module procedure default_int16 module procedure default_int32 module procedure default_int64 @@ -75,6 +76,19 @@ function default_qp(x, to) result(y) end function default_qp + function default_int8(x, to) result(y) + integer(int8), intent(in), optional :: x + integer(int8), intent(in) :: to + integer(int8) :: y + + if (present(x)) then + y = x + else + y = to + end if + end function default_int8 + + function default_int16(x, to) result(y) integer(int16), intent(in), optional :: x integer(int16), intent(in) :: to From f39c35eaae130b8f07a3ca37131862b5bf94938d Mon Sep 17 00:00:00 2001 From: Nathaniel Shaffre Date: Fri, 3 Jan 2020 16:59:10 -0700 Subject: [PATCH 5/6] rename default -> optval --- src/CMakeLists.txt | 2 +- src/Makefile.manual | 2 +- src/stdlib_experimental_default.f90 | 156 ---------------------------- src/stdlib_experimental_optval.f90 | 153 +++++++++++++++++++++++++++ 4 files changed, 155 insertions(+), 158 deletions(-) delete mode 100644 src/stdlib_experimental_default.f90 create mode 100644 src/stdlib_experimental_optval.f90 diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 294185aa9..d65cd416d 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -2,7 +2,7 @@ set(SRC stdlib_experimental_ascii.f90 stdlib_experimental_io.f90 stdlib_experimental_error.f90 - stdlib_experimental_default.f90 + stdlib_experimental_optval.f90 ) add_library(fortran_stdlib ${SRC}) diff --git a/src/Makefile.manual b/src/Makefile.manual index 6148548ca..f83c11aa7 100644 --- a/src/Makefile.manual +++ b/src/Makefile.manual @@ -1,7 +1,7 @@ SRC = stdlib_experimental_ascii.f90 \ stdlib_experimental_error.f90 \ stdlib_experimental_io.f90 \ - stdlib_experimental_default.f90 \ + stdlib_experimental_optval.f90 \ f18estop.f90 LIB = libstdlib.a diff --git a/src/stdlib_experimental_default.f90 b/src/stdlib_experimental_default.f90 deleted file mode 100644 index 39ebaab5a..000000000 --- a/src/stdlib_experimental_default.f90 +++ /dev/null @@ -1,156 +0,0 @@ -module stdlib_experimental_default - !! - !! Provides a generic function `default`, 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 `default(x, y)` inside that - !! subprogram evaluates to `x` if it is present, otherwise `y`. - !! - !! It is an error to call `default` with a single actual argument. - !! - !! For additional clarity, `default` be called with keyword argument - !! for the fallback value, e.g., `default(x, to=1.0)`. - !! - use iso_fortran_env, only: sp => real32, dp => real64, qp => real128, int8, int16, int32, int64 - implicit none - - - private - public :: default - - - interface default - module procedure default_sp - module procedure default_dp - module procedure default_qp - module procedure default_int8 - module procedure default_int16 - module procedure default_int32 - module procedure default_int64 - module procedure default_logical - module procedure default_character - ! TODO: complex kinds - ! TODO: differentiate ascii & ucs char kinds - end interface default - - -contains - - - function default_sp(x, to) result(y) - real(sp), intent(in), optional :: x - real(sp), intent(in) :: to - real(sp) :: y - - if (present(x)) then - y = x - else - y = to - end if - end function default_sp - - - function default_dp(x, to) result(y) - real(dp), intent(in), optional :: x - real(dp), intent(in) :: to - real(dp) :: y - - if (present(x)) then - y = x - else - y = to - end if - end function default_dp - - - function default_qp(x, to) result(y) - real(qp), intent(in), optional :: x - real(qp), intent(in) :: to - real(qp) :: y - - if (present(x)) then - y = x - else - y = to - end if - end function default_qp - - - function default_int8(x, to) result(y) - integer(int8), intent(in), optional :: x - integer(int8), intent(in) :: to - integer(int8) :: y - - if (present(x)) then - y = x - else - y = to - end if - end function default_int8 - - - function default_int16(x, to) result(y) - integer(int16), intent(in), optional :: x - integer(int16), intent(in) :: to - integer(int16) :: y - - if (present(x)) then - y = x - else - y = to - end if - end function default_int16 - - - function default_int32(x, to) result(y) - integer(int32), intent(in), optional :: x - integer(int32), intent(in) :: to - integer(int32) :: y - - if (present(x)) then - y = x - else - y = to - end if - end function default_int32 - - - function default_int64(x, to) result(y) - integer(int64), intent(in), optional :: x - integer(int64), intent(in) :: to - integer(int64) :: y - - if (present(x)) then - y = x - else - y = to - end if - end function default_int64 - - - function default_logical(x, to) result(y) - logical, intent(in), optional :: x - logical, intent(in) :: to - logical :: y - - if (present(x)) then - y = x - else - y = to - end if - end function default_logical - - - function default_character(x, to) result(y) - character(len=*), intent(in), optional :: x - character(len=*), intent(in) :: to - character(len=:), allocatable :: y - - if (present(x)) then - y = x - else - y = to - end if - end function default_character - -end module stdlib_experimental_default 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 From fefbaf4564e38b7ab75e4639b9873fe3d8145d67 Mon Sep 17 00:00:00 2001 From: Nathaniel Shaffer Date: Fri, 3 Jan 2020 17:46:41 -0700 Subject: [PATCH 6/6] add tests for optval --- src/tests/CMakeLists.txt | 1 + src/tests/Makefile.manual | 3 + src/tests/optval/CMakeLists.txt | 4 + src/tests/optval/Makefile.manual | 4 + src/tests/optval/test_optval.f90 | 151 +++++++++++++++++++++++++++++++ 5 files changed, 163 insertions(+) create mode 100644 src/tests/optval/CMakeLists.txt create mode 100644 src/tests/optval/Makefile.manual create mode 100644 src/tests/optval/test_optval.f90 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