Skip to content

Commit be1a0c0

Browse files
scivisionscivision
committed
bounds: modularize
1 parent 03380b1 commit be1a0c0

3 files changed

Lines changed: 131 additions & 113 deletions

File tree

‎src/bounds/bounds.f90‎

Lines changed: 43 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,43 @@
1+
module C_bounds
2+
3+
use, intrinsic :: iso_c_binding
4+
use, intrinsic :: iso_fortran_env, only : error_unit
5+
6+
implicit none
7+
8+
interface
9+
logical(C_BOOL) function c_bounder(a, fl, fu) bind(c, name="c_bounder")
10+
import :: c_float, c_int64_t, C_BOOL
11+
real(c_float), intent(inout) :: a(:)
12+
integer(c_int64_t), value :: fl, fu
13+
end function
14+
15+
logical(C_BOOL) function c_bounder_2d(a, fl1, fu1, fl2, fu2) bind(c, name="c_bounder_2d")
16+
import :: c_float, c_int64_t, C_BOOL
17+
real(c_float), intent(inout) :: a(:,:)
18+
integer(c_int64_t), value :: fl1, fu1, fl2, fu2
19+
end function
20+
end interface
21+
22+
private
23+
public :: c_bounder, c_bounder_2d, check_bounds
24+
25+
contains
26+
27+
subroutine check_bounds(a, label, expected_l, expected_u)
28+
real, allocatable, intent(in) :: a(:)
29+
character(*), intent(in) :: label
30+
integer, intent(in) :: expected_l, expected_u
31+
integer :: l, u
32+
33+
l = lbound(a,1)
34+
u = ubound(a,1)
35+
36+
if (l /= expected_l .or. u /= expected_u) then
37+
write(error_unit, '(a,": FAIL got [",i0,":",i0,"] expected [",i0,":",i0,"]")') &
38+
label, l, u, expected_l, expected_u
39+
error stop "Fortran bounds corrupted"
40+
end if
41+
end subroutine
42+
43+
end module

‎test/bounds/CMakeLists.txt‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -10,7 +10,7 @@ if(CMAKE_Fortran_COMPILER_ID STREQUAL "GNU" AND
1010
return()
1111
endif()
1212

13-
add_executable(bounds_fortran bounds.f90 ${PROJECT_SOURCE_DIR}/src/bounds/bounds.cpp)
13+
add_executable(bounds_fortran bounds.f90 ${PROJECT_SOURCE_DIR}/src/bounds/bounds.cpp ${PROJECT_SOURCE_DIR}/src/bounds/bounds.f90)
1414
target_include_directories(bounds_fortran PRIVATE ${PROJECT_SOURCE_DIR}/src/bounds)
1515
set_property(TARGET bounds_fortran PROPERTY LINKER_LANGUAGE ${linker_lang})
1616

‎test/bounds/bounds.f90‎

Lines changed: 87 additions & 112 deletions
Original file line numberDiff line numberDiff line change
@@ -1,118 +1,93 @@
11
program test_bindc_bounds
2-
use, intrinsic :: iso_fortran_env
3-
use, intrinsic :: iso_c_binding
4-
implicit none
5-
6-
interface
7-
logical(C_BOOL) function c_bounder(a, fl, fu) bind(c, name="c_bounder")
8-
import :: c_float, c_int64_t, C_BOOL
9-
real(c_float), intent(inout) :: a(:)
10-
integer(c_int64_t), value :: fl, fu
11-
end function
12-
13-
logical(C_BOOL) function c_bounder_2d(a, fl1, fu1, fl2, fu2) bind(c, name="c_bounder_2d")
14-
import :: c_float, c_int64_t, C_BOOL
15-
real(c_float), intent(inout) :: a(:,:)
16-
integer(c_int64_t), value :: fl1, fu1, fl2, fu2
17-
end function
18-
end interface
19-
20-
call test_default_bounds()
21-
call test_nondefault_bounds()
22-
call test_multidim()
23-
call test_array_section()
24-
call test_large_array()
25-
26-
write(output_unit, '(a)') "All bounds checks passed."
2+
3+
use, intrinsic :: iso_fortran_env
4+
use, intrinsic :: iso_c_binding
5+
6+
use C_bounds, only : c_bounder, c_bounder_2d, check_bounds
7+
8+
implicit none
9+
10+
call test_default_bounds()
11+
call test_nondefault_bounds()
12+
call test_multidim()
13+
call test_array_section()
14+
call test_large_array()
15+
16+
write(output_unit, '(a)') "All bounds checks passed."
2717

2818
contains
2919

30-
subroutine check_bounds(a, label, expected_l, expected_u)
31-
real, allocatable, intent(in) :: a(:)
32-
character(*), intent(in) :: label
33-
integer, intent(in) :: expected_l, expected_u
34-
integer :: l, u
35-
36-
l = lbound(a,1)
37-
u = ubound(a,1)
38-
39-
if (l /= expected_l .or. u /= expected_u) then
40-
write(error_unit, '(a,": FAIL got [",i0,":",i0,"] expected [",i0,":",i0,"]")') &
41-
label, l, u, expected_l, expected_u
42-
error stop "Fortran bounds corrupted"
43-
end if
44-
end subroutine
45-
46-
subroutine test_default_bounds()
47-
real, allocatable :: a(:)
48-
allocate(a(1:10))
49-
call check_bounds(a, "default before", 1, 10)
50-
if (.not. c_bounder(a, 1_c_int64_t, 10_c_int64_t)) then
51-
error stop "C bounder failed"
52-
end if
53-
call check_bounds(a, "default after ", 1, 10)
54-
end subroutine
55-
56-
subroutine test_nondefault_bounds()
57-
real, allocatable :: a(:)
58-
allocate(a(-3:6))
59-
call check_bounds(a, "nondefault before", -3, 6)
60-
if (.not. c_bounder(a, -3_c_int64_t, 6_c_int64_t)) then
61-
error stop "C bounder failed"
62-
end if
63-
call check_bounds(a, "nondefault after ", -3, 6)
64-
end subroutine
65-
66-
subroutine test_multidim()
67-
real, allocatable :: a(:,:)
68-
allocate(a(-2:5, 10:20))
69-
70-
if (lbound(a,1)/=-2 .or. ubound(a,1)/=5 .or. &
71-
lbound(a,2)/=10 .or. ubound(a,2)/=20) then
72-
error stop "Multidim setup failed"
73-
end if
74-
75-
if (.not. c_bounder_2d(a, -2_c_int64_t, 5_c_int64_t, 10_c_int64_t, 20_c_int64_t)) then
76-
error stop "C bounder 2D failed"
77-
end if
78-
79-
if (lbound(a,1)/=-2 .or. ubound(a,1)/=5 .or. &
80-
lbound(a,2)/=10 .or. ubound(a,2)/=20) then
81-
error stop "Multidim bounds corrupted"
82-
end if
83-
end subroutine
84-
85-
subroutine test_array_section()
86-
real, allocatable, target :: a(:)
87-
real, pointer :: p(:)
88-
89-
allocate(a(-10:20))
90-
p => a(5:15) ! pointer lower bound defaults to 1 here
91-
92-
if (lbound(p,1) /= 1 .or. ubound(p,1) /= 11) then
93-
error stop "Section setup failed"
94-
end if
95-
96-
! Pass the section (C will see 0-based)
97-
if (.not. c_bounder(p, 5_c_int64_t, 15_c_int64_t)) then
98-
error stop "C bounder failed"
99-
end if
100-
101-
! Original array should still be intact
102-
if (lbound(a,1) /= -10 .or. ubound(a,1) /= 20) then
103-
error stop "Original array corrupted via section"
104-
end if
105-
106-
print '(a)', "Array section test passed"
107-
end subroutine
108-
109-
subroutine test_large_array()
110-
real, allocatable :: a(:)
111-
allocate(a(1:1000000))
112-
if (.not. c_bounder(a, 1_c_int64_t, 1000000_c_int64_t)) then
113-
error stop "C bounder failed"
114-
end if
115-
print '(a)', "Large array test passed"
116-
end subroutine
20+
21+
subroutine test_default_bounds()
22+
real, allocatable :: a(:)
23+
allocate(a(1:10))
24+
call check_bounds(a, "default before", 1, 10)
25+
if (.not. c_bounder(a, 1_c_int64_t, 10_c_int64_t)) then
26+
error stop "C bounder failed"
27+
end if
28+
call check_bounds(a, "default after ", 1, 10)
29+
end subroutine
30+
31+
subroutine test_nondefault_bounds()
32+
real, allocatable :: a(:)
33+
allocate(a(-3:6))
34+
call check_bounds(a, "nondefault before", -3, 6)
35+
if (.not. c_bounder(a, -3_c_int64_t, 6_c_int64_t)) then
36+
error stop "C bounder failed"
37+
end if
38+
call check_bounds(a, "nondefault after ", -3, 6)
39+
end subroutine
40+
41+
subroutine test_multidim()
42+
real, allocatable :: a(:,:)
43+
allocate(a(-2:5, 10:20))
44+
45+
if (lbound(a,1)/=-2 .or. ubound(a,1)/=5 .or. &
46+
lbound(a,2)/=10 .or. ubound(a,2)/=20) then
47+
error stop "Multidim setup failed"
48+
end if
49+
50+
if (.not. c_bounder_2d(a, -2_c_int64_t, 5_c_int64_t, 10_c_int64_t, 20_c_int64_t)) then
51+
error stop "C bounder 2D failed"
52+
end if
53+
54+
if (lbound(a,1)/=-2 .or. ubound(a,1)/=5 .or. &
55+
lbound(a,2)/=10 .or. ubound(a,2)/=20) then
56+
error stop "Multidim bounds corrupted"
57+
end if
58+
end subroutine
59+
60+
subroutine test_array_section()
61+
real, allocatable, target :: a(:)
62+
real, pointer :: p(:)
63+
64+
allocate(a(-10:20))
65+
p => a(5:15) ! pointer lower bound defaults to 1 here
66+
67+
if (lbound(p,1) /= 1 .or. ubound(p,1) /= 11) then
68+
error stop "Section setup failed"
69+
end if
70+
71+
! Pass the section (C will see 0-based)
72+
if (.not. c_bounder(p, 5_c_int64_t, 15_c_int64_t)) then
73+
error stop "C bounder failed"
74+
end if
75+
76+
! Original array should still be intact
77+
if (lbound(a,1) /= -10 .or. ubound(a,1) /= 20) then
78+
error stop "Original array corrupted via section"
79+
end if
80+
81+
print '(a)', "Array section test passed"
82+
end subroutine
83+
84+
subroutine test_large_array()
85+
real, allocatable :: a(:)
86+
allocate(a(1:1000000))
87+
if (.not. c_bounder(a, 1_c_int64_t, 1000000_c_int64_t)) then
88+
error stop "C bounder failed"
89+
end if
90+
print '(a)', "Large array test passed"
91+
end subroutine
11792

11893
end program

0 commit comments

Comments
 (0)