Skip to content

Commit affb52c

Browse files
certikcertik
authored
Merge pull request #73 from nshaffer/master
Preliminary implementation of default values
2 parents 84c75fb + fefbaf4 commit affb52c

8 files changed

+318
-0
lines changed

‎src/CMakeLists.txt

+1
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,7 @@ set(SRC
22
stdlib_experimental_ascii.f90
33
stdlib_experimental_io.f90
44
stdlib_experimental_error.f90
5+
stdlib_experimental_optval.f90
56
)
67

78
add_library(fortran_stdlib ${SRC})

‎src/Makefile.manual

+1
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,7 @@
11
SRC = stdlib_experimental_ascii.f90 \
22
stdlib_experimental_error.f90 \
33
stdlib_experimental_io.f90 \
4+
stdlib_experimental_optval.f90 \
45
f18estop.f90
56

67
LIB = libstdlib.a

‎src/stdlib_experimental_optval.f90

+153
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,153 @@
1+
module stdlib_experimental_optval
2+
!!
3+
!! Provides a generic function `optval`, which can be used to
4+
!! conveniently implement fallback values for optional arguments
5+
!! to subprograms. If `x` is an `optional` parameter of a
6+
!! subprogram, then the expression `optval(x, default)` inside that
7+
!! subprogram evaluates to `x` if it is present, otherwise `default`.
8+
!!
9+
!! It is an error to call `optval` with a single actual argument.
10+
!!
11+
use iso_fortran_env, only: sp => real32, dp => real64, qp => real128, int8, int16, int32, int64
12+
implicit none
13+
14+
15+
private
16+
public :: optval
17+
18+
19+
interface optval
20+
module procedure optval_sp
21+
module procedure optval_dp
22+
module procedure optval_qp
23+
module procedure optval_int8
24+
module procedure optval_int16
25+
module procedure optval_int32
26+
module procedure optval_int64
27+
module procedure optval_logical
28+
module procedure optval_character
29+
! TODO: complex kinds
30+
! TODO: differentiate ascii & ucs char kinds
31+
end interface optval
32+
33+
34+
contains
35+
36+
37+
function optval_sp(x, default) result(y)
38+
real(sp), intent(in), optional :: x
39+
real(sp), intent(in) :: default
40+
real(sp) :: y
41+
42+
if (present(x)) then
43+
y = x
44+
else
45+
y = default
46+
end if
47+
end function optval_sp
48+
49+
50+
function optval_dp(x, default) result(y)
51+
real(dp), intent(in), optional :: x
52+
real(dp), intent(in) :: default
53+
real(dp) :: y
54+
55+
if (present(x)) then
56+
y = x
57+
else
58+
y = default
59+
end if
60+
end function optval_dp
61+
62+
63+
function optval_qp(x, default) result(y)
64+
real(qp), intent(in), optional :: x
65+
real(qp), intent(in) :: default
66+
real(qp) :: y
67+
68+
if (present(x)) then
69+
y = x
70+
else
71+
y = default
72+
end if
73+
end function optval_qp
74+
75+
76+
function optval_int8(x, default) result(y)
77+
integer(int8), intent(in), optional :: x
78+
integer(int8), intent(in) :: default
79+
integer(int8) :: y
80+
81+
if (present(x)) then
82+
y = x
83+
else
84+
y = default
85+
end if
86+
end function optval_int8
87+
88+
89+
function optval_int16(x, default) result(y)
90+
integer(int16), intent(in), optional :: x
91+
integer(int16), intent(in) :: default
92+
integer(int16) :: y
93+
94+
if (present(x)) then
95+
y = x
96+
else
97+
y = default
98+
end if
99+
end function optval_int16
100+
101+
102+
function optval_int32(x, default) result(y)
103+
integer(int32), intent(in), optional :: x
104+
integer(int32), intent(in) :: default
105+
integer(int32) :: y
106+
107+
if (present(x)) then
108+
y = x
109+
else
110+
y = default
111+
end if
112+
end function optval_int32
113+
114+
115+
function optval_int64(x, default) result(y)
116+
integer(int64), intent(in), optional :: x
117+
integer(int64), intent(in) :: default
118+
integer(int64) :: y
119+
120+
if (present(x)) then
121+
y = x
122+
else
123+
y = default
124+
end if
125+
end function optval_int64
126+
127+
128+
function optval_logical(x, default) result(y)
129+
logical, intent(in), optional :: x
130+
logical, intent(in) :: default
131+
logical :: y
132+
133+
if (present(x)) then
134+
y = x
135+
else
136+
y = default
137+
end if
138+
end function optval_logical
139+
140+
141+
function optval_character(x, default) result(y)
142+
character(len=*), intent(in), optional :: x
143+
character(len=*), intent(in) :: default
144+
character(len=:), allocatable :: y
145+
146+
if (present(x)) then
147+
y = x
148+
else
149+
y = default
150+
end if
151+
end function optval_character
152+
153+
end module stdlib_experimental_optval

‎src/tests/CMakeLists.txt

+1
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,6 @@
11
add_subdirectory(ascii)
22
add_subdirectory(loadtxt)
3+
add_subdirectory(optval)
34

45
add_executable(test_skip test_skip.f90)
56
target_link_libraries(test_skip fortran_stdlib)

‎src/tests/Makefile.manual

+3
Original file line numberDiff line numberDiff line change
@@ -3,11 +3,14 @@
33
all:
44
$(MAKE) -f Makefile.manual --directory=ascii
55
$(MAKE) -f Makefile.manual --directory=loadtxt
6+
$(MAKE) -f Makefile.manual --directory=optval
67

78
test:
89
$(MAKE) -f Makefile.manual --directory=ascii test
910
$(MAKE) -f Makefile.manual --directory=loadtxt test
11+
$(MAKE) -f Makefile.manual --directory=optval test
1012

1113
clean:
1214
$(MAKE) -f Makefile.manual --directory=ascii clean
1315
$(MAKE) -f Makefile.manual --directory=loadtxt clean
16+
$(MAKE) -f Makefile.manual --directory=optval clean

‎src/tests/optval/CMakeLists.txt

+4
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,4 @@
1+
add_executable(test_optval test_optval.f90)
2+
target_link_libraries(test_optval fortran_stdlib)
3+
4+
add_test(NAME OPTVAL COMMAND $<TARGET_FILE:test_optval>)

‎src/tests/optval/Makefile.manual

+4
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,4 @@
1+
PROGS_SRC = test_optval.f90
2+
3+
4+
include ../Makefile.manual.test.mk

‎src/tests/optval/test_optval.f90

+151
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,151 @@
1+
program test_optval
2+
use, intrinsic :: iso_fortran_env, only: &
3+
sp => real32, dp => real64, qp => real128, &
4+
int8, int16, int32, int64
5+
use stdlib_experimental_error, only: assert
6+
use stdlib_experimental_optval, only: optval
7+
8+
implicit none
9+
10+
call test_optval_sp
11+
call test_optval_dp
12+
call test_optval_qp
13+
14+
call test_optval_int8
15+
call test_optval_int16
16+
call test_optval_int32
17+
call test_optval_int64
18+
19+
call test_optval_logical
20+
21+
call test_optval_character
22+
23+
contains
24+
25+
26+
subroutine test_optval_sp
27+
print *, "test_optval_sp"
28+
call assert(foo_sp(1.0_sp) == 1.0_sp)
29+
call assert(foo_sp() == 2.0_sp)
30+
end subroutine test_optval_sp
31+
32+
33+
function foo_sp(x) result(z)
34+
real(sp), intent(in), optional :: x
35+
real(sp) :: z
36+
z = optval(x, 2.0_sp)
37+
endfunction foo_sp
38+
39+
40+
subroutine test_optval_dp
41+
print *, "test_optval_dp"
42+
call assert(foo_dp(1.0_dp) == 1.0_dp)
43+
call assert(foo_dp() == 2.0_dp)
44+
end subroutine test_optval_dp
45+
46+
47+
function foo_dp(x) result(z)
48+
real(dp), intent(in), optional :: x
49+
real(dp) :: z
50+
z = optval(x, 2.0_dp)
51+
endfunction foo_dp
52+
53+
54+
subroutine test_optval_qp
55+
print *, "test_optval_qp"
56+
call assert(foo_qp(1.0_qp) == 1.0_qp)
57+
call assert(foo_qp() == 2.0_qp)
58+
end subroutine test_optval_qp
59+
60+
61+
function foo_qp(x) result(z)
62+
real(qp), intent(in), optional :: x
63+
real(qp) :: z
64+
z = optval(x, 2.0_qp)
65+
endfunction foo_qp
66+
67+
68+
subroutine test_optval_int8
69+
print *, "test_optval_int8"
70+
call assert(foo_int8(1_int8) == 1_int8)
71+
call assert(foo_int8() == 2_int8)
72+
end subroutine test_optval_int8
73+
74+
75+
function foo_int8(x) result(z)
76+
integer(int8), intent(in), optional :: x
77+
integer(int8) :: z
78+
z = optval(x, 2_int8)
79+
endfunction foo_int8
80+
81+
82+
subroutine test_optval_int16
83+
print *, "test_optval_int16"
84+
call assert(foo_int16(1_int16) == 1_int16)
85+
call assert(foo_int16() == 2_int16)
86+
end subroutine test_optval_int16
87+
88+
89+
function foo_int16(x) result(z)
90+
integer(int16), intent(in), optional :: x
91+
integer(int16) :: z
92+
z = optval(x, 2_int16)
93+
endfunction foo_int16
94+
95+
96+
subroutine test_optval_int32
97+
print *, "test_optval_int32"
98+
call assert(foo_int32(1_int32) == 1_int32)
99+
call assert(foo_int32() == 2_int32)
100+
end subroutine test_optval_int32
101+
102+
103+
function foo_int32(x) result(z)
104+
integer(int32), intent(in), optional :: x
105+
integer(int32) :: z
106+
z = optval(x, 2_int32)
107+
endfunction foo_int32
108+
109+
110+
subroutine test_optval_int64
111+
print *, "test_optval_int64"
112+
call assert(foo_int64(1_int64) == 1_int64)
113+
call assert(foo_int64() == 2_int64)
114+
end subroutine test_optval_int64
115+
116+
117+
function foo_int64(x) result(z)
118+
integer(int64), intent(in), optional :: x
119+
integer(int64) :: z
120+
z = optval(x, 2_int64)
121+
endfunction foo_int64
122+
123+
124+
subroutine test_optval_logical
125+
print *, "test_optval_logical"
126+
call assert(foo_logical(.true.))
127+
call assert(.not.foo_logical())
128+
end subroutine test_optval_logical
129+
130+
131+
function foo_logical(x) result(z)
132+
logical, intent(in), optional :: x
133+
logical :: z
134+
z = optval(x, .false.)
135+
endfunction foo_logical
136+
137+
138+
subroutine test_optval_character
139+
print *, "test_optval_character"
140+
call assert(foo_character("x") == "x")
141+
call assert(foo_character() == "y")
142+
end subroutine test_optval_character
143+
144+
145+
function foo_character(x) result(z)
146+
character(len=*), intent(in), optional :: x
147+
character(len=:), allocatable :: z
148+
z = optval(x, "y")
149+
endfunction foo_character
150+
151+
end program test_optval

0 commit comments

Comments
 (0)