Skip to content

Commit 823dd59

Browse files
sethrjsethrj
committed
Fix generic comparison typemap and add example
1 parent d2985b3 commit 823dd59

File tree

7 files changed

+235
-101
lines changed

7 files changed

+235
-101
lines changed

‎doc/modules/algorithm.rst

Lines changed: 9 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -10,20 +10,19 @@ Algorithm
1010

1111
The ``flc_algorithm`` module wraps C++ standard `<algorithm>`_ routines.
1212
Instead of taking pairs of iterators, the Flibcpp algorithm subroutines accept
13-
target-qualified 1-D arrays.
14-
15-
Algorithms that take comparators (e.g. sorting and searching) are instantiated
16-
with function pointers that allow user functions to add arbitrary ordering by
17-
defining ``bind(C)`` functions.
18-
19-
Wherever possible, array indices are returned as Fortran 1-offset native
20-
integers, with the value 0 indicating off-the-end (e.g. "not found").
13+
target-qualified one-dimensional arrays. All algorithms follow the
14+
:ref:`indexing convention <conventions_indexing>` that the first element of an
15+
array has index 1, and an index of 0 indicates "not found".
2116

2217
.. _<algorithm> : https://en.cppreference.com/w/cpp/numeric/random
2318

2419
Sorting
2520
=======
2621

22+
Sorting algorithms for numeric types default to increasing order when provided
23+
with a single array argument. Numeric sorting routines accept an optional
24+
second argument, a comparator function,
25+
2726
sort
2827
----
2928

@@ -56,11 +55,10 @@ takes an array to analyze and an empty array of integers to fill::
5655
use flc_algorithm, only : argsort, INDEX_INT
5756
implicit none
5857
integer, dimension(5) :: iarr = [ 2, 5, -2, 3, -10000]
59-
integer(INDEX_INT), dimension(5) :: idx
58+
integer(INDEX_INT), dimension(size(iarr)) :: idx
6059

6160
call argsort(iarr, idx)
62-
! This line prints a sorted array:
63-
write(*,*) iarr(idx)
61+
write(*,*) iarr(idx) ! Prints the sorted array
6462

6563
Note that the index array is always a ``INDEX_INT``, which is an alias to
6664
``C_INT``. On some compilers and platforms, this may be the same as native

‎example/CMakeLists.txt

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -30,6 +30,9 @@ swig_fortran_add_example(sort
3030
swig_fortran_add_example(vecstr
3131
flc_string flc_vector example_utils_lib)
3232

33+
swig_fortran_add_example(sort_generic
34+
flc_algorithm example_utils_lib)
35+
3336
#---------------------------------------------------------------------------##
3437
# TESTS
3538
#---------------------------------------------------------------------------##

‎example/sort_generic.f90

Lines changed: 153 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,153 @@
1+
!-----------------------------------------------------------------------------!
2+
! \file example/sort_generic.f90
3+
!
4+
! Copyright (c) 2019 Oak Ridge National Laboratory, UT-Battelle, LLC.
5+
!-----------------------------------------------------------------------------!
6+
7+
! Mock-up of a user-created type and comparison operator
8+
module sort_generic_extras
9+
implicit none
10+
public
11+
12+
! Declare an example Fortran derived type
13+
type :: FortranString
14+
character(len=:), allocatable :: chars
15+
end type
16+
17+
! Declare a 'less than' operator for that type
18+
interface operator(<)
19+
module procedure fortranstring_less
20+
end interface
21+
22+
contains
23+
24+
elemental function fortranstring_less(self, other) &
25+
result(fresult)
26+
type(FortranString), intent(in) :: self
27+
type(FortranString), intent(in) :: other
28+
logical :: fresult
29+
integer :: i, lchar, rchar
30+
31+
if (.not. allocated(self%chars) .and. .not. allocated(other%chars)) then
32+
! Both deallocated, therefore equal
33+
fresult = .false.
34+
return
35+
elseif (.not. allocated(self%chars)) then
36+
! self deallocated, therefore less
37+
fresult = .true.
38+
return
39+
elseif (.not. allocated(other%chars)) then
40+
! other deallocated, therefore greater
41+
fresult = .false.
42+
return
43+
endif
44+
45+
! If LHS is shorter, it is "less than" the RHS.
46+
if (len(self%chars) < len(other%chars)) then
47+
fresult = .true.
48+
return
49+
elseif (len(self%chars) > len(other%chars)) then
50+
fresult = .false.
51+
return
52+
endif
53+
54+
! If any character code is less than the RHS, it is less than.
55+
do i = 1, len(self%chars)
56+
lchar = ichar(self%chars(i:i))
57+
rchar = ichar(other%chars(i:i))
58+
if (lchar < rchar) then
59+
fresult = .true.
60+
return
61+
elseif (lchar > rchar) then
62+
fresult = .false.
63+
return
64+
endif
65+
end do
66+
67+
! Everything is equal: therefore not strictly "less than"
68+
fresult = .false.
69+
end function
70+
71+
! C++-accessible comparison function for two pointers-to-strings
72+
function compare_strings(lcptr, rcptr) bind(C) &
73+
result(fresult)
74+
use, intrinsic :: ISO_C_BINDING
75+
type(C_PTR), intent(in), value :: lcptr
76+
type(C_PTR), intent(in), value :: rcptr
77+
logical(C_BOOL) :: fresult
78+
type(FortranString), pointer :: lptr
79+
type(FortranString), pointer :: rptr
80+
81+
if (c_associated(lcptr) .and. c_associated(rcptr)) then
82+
! Both associated: convert from C to Fortran pointers
83+
call c_f_pointer(cptr=lcptr, fptr=lptr)
84+
call c_f_pointer(cptr=rcptr, fptr=rptr)
85+
86+
! Compare the strings
87+
fresult = (lptr < rptr)
88+
elseif (.not. c_associated(lcptr)) then
89+
! LHS is null => "less than"
90+
fresult = .true.
91+
elseif (.not. c_associated(rcptr)) then
92+
fresult = .false.
93+
endif
94+
95+
end function
96+
end module
97+
98+
program sort_generic_example
99+
use, intrinsic :: ISO_FORTRAN_ENV
100+
use, intrinsic :: ISO_C_BINDING
101+
use flc
102+
use flc_algorithm, only : argsort, INDEX_INT
103+
use sort_generic_extras, only : compare_strings, FortranString
104+
use example_utils, only : write_version, read_positive_int, STDOUT, STDIN
105+
implicit none
106+
type(FortranString), dimension(:), allocatable, target :: fs_array
107+
type(C_PTR), dimension(:), allocatable, target :: ptrs
108+
integer(INDEX_INT), dimension(:), allocatable, target :: ordering
109+
character(len=80) :: readstr
110+
integer :: arr_size, i, io_ierr
111+
112+
call write_version()
113+
114+
! Read strings
115+
arr_size = read_positive_int("string array size")
116+
allocate(fs_array(arr_size))
117+
do i = 1, arr_size
118+
write(STDOUT, "(a, i3)") "Enter string #", i
119+
read(STDIN, "(a)", iostat=io_ierr) readstr
120+
if (io_ierr == IOSTAT_END) then
121+
! Leave further strings unallocated
122+
exit
123+
endif
124+
! Allocate string
125+
allocate(fs_array(i)%chars, source=trim(readstr))
126+
enddo
127+
128+
! Create C pointers to the Fortran objects
129+
ptrs = [(c_loc(fs_array(i)), i = 1, arr_size)]
130+
131+
! Use 'argsort' to determine the new ordering
132+
allocate(ordering(arr_size))
133+
call argsort(ptrs, ordering, compare_strings)
134+
write(STDOUT, "(a, 20(i3))") "New order:", ordering
135+
136+
! Reorder the Fortran data
137+
fs_array = fs_array(ordering)
138+
139+
! Print the results
140+
write(STDOUT, *) "Sorted:"
141+
do i = 1, arr_size
142+
if (allocated(fs_array(i)%chars)) then
143+
write(STDOUT, "(i3, ': ', a)") i, fs_array(i)%chars
144+
else
145+
write(STDOUT, "(i3, ': ', a)") i, "<UNALLOCATED>"
146+
endif
147+
enddo
148+
149+
end program
150+
151+
!-----------------------------------------------------------------------------!
152+
! end of example/sort.f90
153+
!-----------------------------------------------------------------------------!

‎include/flc.i

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -82,7 +82,7 @@ using std::size_t;
8282
(const int32_t *DATA, size_t DATASIZE),
8383
(const int64_t *DATA, size_t DATASIZE),
8484
(const double *DATA, size_t DATASIZE),
85-
(const void **DATA, size_t DATASIZE)};
85+
(void * const *DATA, size_t DATASIZE)};
8686

8787
/* -------------------------------------------------------------------------
8888
* Version information

‎include/flc_algorithm.i

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -40,6 +40,7 @@ static RETURN_TYPE FUNCNAME##_cmp(ARGS, bool (*cmp)(T, T)) {
4040
%enddef
4141

4242
// >>> Create a native function pointer interface for the given comparator.
43+
4344
%define %flc_cmp_funptr(CTYPE, FTYPE)
4445

4546
#define flc_cmp_funptr flc_cmp_funptr_ ## %mangle(CTYPE)

0 commit comments

Comments
 (0)